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 LambdaFree (S: LAMBDA_FREE_STRUCTS): LAMBDA_FREE =
17 datatype t = Unseen | Free | Bound
21 datatype status = datatype Status.t
23 fun lambdaFree {program = Program.T {body, ...},
25 varInfo: Var.t -> {frees: Var.t list ref ref,
26 status: Status.t ref},
27 lambdaInfo: Lambda.t -> {frees: Var.t vector ref,
28 recs: Var.t vector ref}} =
30 fun setFree (l: Lambda.t, xs: Var.t vector): unit =
31 #frees (lambdaInfo l) := xs
32 fun setRec (l: Lambda.t, xs: Var.t vector): unit =
33 #recs (lambdaInfo l) := xs
34 type scope = {frees: Var.t list ref,
35 get: Var.t -> Status.t,
36 set: Var.t * Status.t -> unit}
37 fun bind (x: Var.t, {set, ...}: scope) = set (x, Bound)
38 fun var (x: Var.t, {get, set, frees}: scope) =
40 Unseen => (set (x, Free); List.push (frees, x))
42 fun vars (xs, s) = Vector.foreach (xs, fn x => var (x, s))
43 fun varExp (x: VarExp.t, s: scope) = var (VarExp.var x, s)
44 fun varExpOpt (x, s) =
47 | SOME x => varExp (x, s)
48 fun varExps (xs, s) = Vector.foreach (xs, fn x => varExp (x, s))
51 newScope is invoked whenever there is a need to consider a new scope while
52 looking for free variables. Its only parameter is a function taking a record that
53 represents a scope supporting "setting" and "getting" variable statuses.
54 The intent is that `th` will continue traversing the program in the current
55 scope while aggregating variable statuses.
57 Initially, newScope creates a reference to a list of variables (`frees`)
58 Its purpose is twofold:
59 - It is a unique identifier for every encountered scope.
60 - It is utilized by `th` to aggregate all variabes
62 Since each variable has an associated status, updating every single status
63 in the program would be unreasonably slow. Thus, we delay updating the status
64 by associating each variable with the last scope for which that variable was
65 seen. If the variable has been unmentioned until this point in the current scope,
66 then we save its last scope and status, and "initialize" it to be Unseen.
67 This is achieved by having `get` and `set` use the `statusRef` function.
69 After setting up these operations, we perform `th`, and then recover
70 every variable's previous status and scope so that we may continue
71 traversing the program.
74 (th: {frees: Var.t list ref,
75 get: Var.t -> Status.t,
76 set: Var.t * Status.t -> unit } -> unit)
82 let val {frees = frees', status, ...} = varInfo x
85 else (List.push (all, (frees', !frees', status, !status))
86 ; frees' := frees; status := Unseen)
89 fun get x = !(statusRef x)
90 fun set (x, s) = statusRef x := s
91 val _ = th {frees = frees, get = get, set = set}
92 val _ = List.foreach (!all, fn (r, v, r', v') => (r := v; r' := v'))
94 Vector.fromList (!frees)
98 let val {decs, result} = Exp.dest e
102 | MonoVal {var, exp, ...} => (primExp (exp, s); bind (var, s))
103 | PolyVal {var, exp = e, ...} => (exp (e, s); bind (var, s))
106 val {get = isBound, set, destroy} =
107 Property.destGetSetOnce (Var.plist,
108 Property.initConst false)
110 (* Consider each of the functions in this function group to be bound
111 according to a property list. *)
112 val _ = Vector.foreach (decs, fn {var, ...} => set (var, true))
114 (* Consider this recursive function group to be part of a new scope.
115 Then accumulate all free variables from each function (`lambda l`)
116 and if it is a mutually recursive function from this group (i.e. it
117 was marked as bound), then treat it as such; otherwise, delegate
118 the responsibility of checking/setting the variable to the var function *)
123 (decs, fn {lambda = l, ...} =>
129 else (var (x, s); false)))))
131 (* Get rid of the list of mutually recursive functions *)
134 (* Each function in this function group will have the same associated free variables.
135 Its name will then be bound to the current scope. *)
137 Vector.foreach (decs, fn {var, lambda, ...} =>
138 (setFree (lambda, xs)
147 App {func, arg} => (varExp (func, s); varExp (arg, s))
148 | Case {test, cases, default} =>
150 ; Option.app (default, fn (e, _) => exp (e, s))
151 ; Cases.foreach' (cases, fn e => exp (e, s),
152 fn Pat.T {arg, ...} =>
153 Option.app (arg, fn (x, _) => bind (x, s))))
154 | ConApp {arg, ...} => varExpOpt (arg, s)
156 | Handle {try, catch, handler} =>
157 (exp (try, s); bind (#1 catch, s); exp (handler, s))
159 let val xs = lambda l
160 in setFree (l, xs); vars (xs, s)
162 | PrimApp {prim, args, ...} =>
163 (if Prim.mayOverflow prim
164 then var (overflow, s)
168 | Raise {exn, ...} => varExp (exn, s)
169 | Select {tuple, ...} => varExp (tuple, s)
170 | Tuple xs => varExps (xs, s)
171 | Var x => varExp (x, s)
172 and lambda (l: Lambda.t) : Var.t vector =
173 let val {arg, body, ...} = Lambda.dest l
174 in newScope (fn s => (bind (arg, s); exp (body, s)))
176 val frees = newScope (fn s => exp (body, s))
178 if Vector.isEmpty frees
180 else Error.bug ("LambdaFree.lambdaFree: program has free variables: " ^
181 (Layout.toString (Vector.layout Var.layout frees)))