mlton/closure-convert/lambda-free.fun

   1 (* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  * Copyright (C) 1997-2000 NEC Research Institute.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 functor LambdaFree (S: LAMBDA_FREE_STRUCTS): LAMBDA_FREE =
  10 struct
  11
  12 open S
  13 open Dec PrimExp
  14
  15 structure Status =
  16    struct
  17       datatype t = Unseen | Free | Bound
  18
  19       val init = Unseen
  20    end
  21 datatype status = datatype Status.t
  22
  23 fun lambdaFree {program = Program.T {body, ...},
  24                 overflow: Var.t,
  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}} =
  29    let
  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) =
  39          case get x of
  40             Unseen => (set (x, Free); List.push (frees, x))
  41           | _ => ()
  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) =
  45          case x of
  46             NONE => ()
  47           | SOME x => varExp (x, s)
  48       fun varExps (xs, s) = Vector.foreach (xs, fn x => varExp (x, s))
  49
  50       (*
  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.
  56
  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
  61
  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.
  68
  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.
  72        *)
  73       fun newScope
  74             (th: {frees: Var.t list ref,
  75                   get:   Var.t -> Status.t,
  76                   set:   Var.t * Status.t -> unit } -> unit)
  77             : Var.t vector =
  78          let
  79             val frees = ref []
  80             val all = ref []
  81             fun statusRef x =
  82                let val {frees = frees', status, ...} = varInfo x
  83                in if frees = !frees'
  84                      then ()
  85                   else (List.push (all, (frees', !frees', status, !status))
  86                         ; frees' := frees; status := Unseen)
  87                      ; status
  88                end
  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'))
  93          in
  94             Vector.fromList (!frees)
  95          end
  96
  97       fun exp (e, s) =
  98          let val {decs, result} = Exp.dest e
  99          in List.foreach
 100             (decs,
 101              fn Exception _ => ()
 102               | MonoVal {var, exp, ...} => (primExp (exp, s); bind (var, s))
 103               | PolyVal {var, exp = e, ...} => (exp (e, s); bind (var, s))
 104               | Fun {decs, ...} =>
 105                    let
 106                       val {get = isBound, set, destroy} =
 107                          Property.destGetSetOnce (Var.plist,
 108                                                   Property.initConst false)
 109
 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))
 113
 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 *)
 119                       val xs =
 120                          newScope
 121                          (fn s =>
 122                           Vector.foreach
 123                           (decs, fn {lambda = l, ...} =>
 124                            setRec (l,
 125                                    Vector.keepAll
 126                                    (lambda l, fn x =>
 127                                     if isBound x
 128                                        then true
 129                                     else (var (x, s); false)))))
 130
 131                       (* Get rid of the list of mutually recursive functions *)
 132                       val _ = destroy ()
 133
 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. *)
 136                       val _ =
 137                          Vector.foreach (decs, fn {var, lambda, ...} =>
 138                                          (setFree (lambda, xs)
 139                                           ; bind (var, s)))
 140                    in
 141                       vars (xs, s)
 142                    end)
 143             ; varExp (result, s)
 144          end
 145       and primExp (e, s) =
 146          case e of
 147             App {func, arg} => (varExp (func, s); varExp (arg, s))
 148           | Case {test, cases, default} =>
 149                (varExp (test, s)
 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)
 155           | Const _ => ()
 156           | Handle {try, catch, handler} =>
 157                (exp (try, s); bind (#1 catch, s); exp (handler, s))
 158           | Lambda l =>
 159                let val xs = lambda l
 160                in setFree (l, xs); vars (xs, s)
 161                end
 162           | PrimApp {prim, args, ...} =>
 163                (if Prim.mayOverflow prim
 164                   then var (overflow, s)
 165                   else ();
 166                 varExps (args, s))
 167           | Profile _ => ()
 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)))
 175          end
 176       val frees = newScope (fn s => exp (body, s))
 177       val _ =
 178          if Vector.isEmpty frees
 179             then ()
 180          else Error.bug ("LambdaFree.lambdaFree: program has free variables: " ^
 181                          (Layout.toString (Vector.layout Var.layout frees)))
 182    in
 183       ()
 184    end
 185
 186 end