1 (* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
2 * Jagannathan, and Stephen Weeks.
3 * Copyright (C) 1997-2000 NEC Research Institute.
5 * MLton is released under a BSD-style license.
6 * See the file MLton-LICENSE for details.
9 functor Globalize (S: GLOBALIZE_STRUCTS): GLOBALIZE =
15 fun globalize {program = Program.T {datatypes, body, ...},
17 varGlobal: Var.t -> bool ref} =
20 not (Exp.hasPrim (body, fn p =>
22 Prim.Name.Thread_switchTo => true
25 val {get: Tycon.t -> bool, set, destroy} =
26 Property.destGetSetOnce (Tycon.plist, Property.initConst false)
27 fun makeBig tycon = set (tycon, true)
28 val _ = (Vector.foreach (datatypes, makeBig o #tycon)
31 ; makeBig Tycon.vector)
34 val destroyTycon = destroy
42 andalso if (Tycon.equals (c, Tycon.tuple)
43 orelse Tycon.equals (c, Tycon.reff))
44 then Vector.forall (ts, typeIsSmall)
46 | _ => Error.bug "Globalize.typeIsSmall: type variable"
49 Trace.trace ("Globalize.typeIsSmall", Type.layout, Bool.layout)
51 val varIsGlobal = ! o varGlobal
52 val isGlobal = varIsGlobal o VarExp.var
53 fun areGlobal xs = Vector.forall (xs, isGlobal)
54 fun makeGlobal x = varGlobal x := true
56 Trace.trace2 ("Globalize.loopExp", Exp.layout, Bool.layout, Bool.layout)
58 Trace.trace2 ("Globalize.loopDec", Dec.layout, Bool.layout, Bool.layout)
60 traceLoopExp (fn (e: Exp.t, once: bool) =>
61 List.fold (Exp.decs e, once, loopDec))
67 MonoVal {var, ty, exp} =>
72 (* If conts are used, then the application might
73 * call Thread_copyCurrent, in which case,
74 * subsequent stuff might run many times.
76 (false, once andalso noConts)
77 | Case {cases, default, ...} =>
81 (cases, once, fn (e, b) =>
82 loopExp (e, once) andalso b)
84 Option.fold (default, once',
86 loopExp (e, once) andalso b)
89 | ConApp {arg, ...} =>
92 | SOME x => isGlobal x,
94 | Const _ => (true, once)
95 | Handle {try, handler, ...} =>
97 loopExp (handler, loopExp (try, once)))
100 ; (Vector.forall (lambdaFree l, varIsGlobal),
102 | PrimApp {prim, args, ...} =>
105 areGlobal args andalso
106 ((Prim.isFunctional prim
107 (* Don't want to move MLton_equal or MLton_hash
108 * into the globals because polymorphic
109 * equality and hasing isn't implemented
113 (case Prim.name prim of
114 Prim.Name.MLton_equal => false
115 | Prim.Name.MLton_hash => false
119 (case Prim.name prim of
120 Prim.Name.Ref_ref => typeIsSmall ty
124 (case Prim.name prim of
125 Prim.Name.Thread_copyCurrent => false
130 | Profile _ => (false, once)
131 | Raise _ => (false, once)
132 | Select {tuple, ...} => (isGlobal tuple, once)
133 | Tuple xs => (areGlobal xs, once)
134 | Var x => (isGlobal x, once)
135 val _ = if global then makeGlobal var else ()
139 (if Vector.isEmpty decs
143 val {lambda, ...} = Vector.first decs
145 if Vector.forall (lambdaFree lambda, varIsGlobal)
146 then Vector.foreach (decs, makeGlobal o #var)
149 ; Vector.foreach (decs, loopLambda o #lambda)
151 | _ => Error.bug "Globalize.loopDec: strange dec") arg
152 and loopLambda (l: Lambda.t): unit =
153 ignore (loopExp (Lambda.body l, false))
154 val _ = loopExp (body, true)
155 val _ = destroyTycon ()