mlton/xml/scc-funs.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 SccFuns (S: SCC_FUNS_STRUCTS): SCC_FUNS =
  10 struct
  11
  12 open S
  13 open Dec PrimExp
  14
  15 structure Graph = DirectedGraph
  16 structure Node = Graph.Node
  17
  18 fun sccFuns (Program.T {datatypes, body, overflow}) =
  19    let
  20       (* For each function appearing in a fun dec record its node, which will
  21        * have edges to the nodes of other functions declared in the same dec
  22        * if they appear in its body.
  23        *)
  24       val {get = funInfo: Var.t -> {
  25                                     node: unit Node.t,
  26                                     visit: (unit -> unit) ref
  27                                     } option,
  28            set = setFunInfo, ...} =
  29          Property.getSetOnce (Var.plist, Property.initConst NONE)
  30       val {get = nodeLambda, set = setNodeLambda, ...} =
  31          Property.getSetOnce (Node.plist,
  32                               Property.initRaise ("lambda", Node.layout))
  33       fun loopVar x =
  34          case funInfo x of
  35             NONE => ()
  36           | SOME {visit, ...} => !visit ()
  37       val loopVarExp = loopVar o VarExp.var
  38       fun loopVarExps xs = Vector.foreach (xs, loopVarExp)
  39       fun loopLambda (l: Lambda.t): Lambda.t =
  40          let
  41             val {arg, argType, body, mayInline} = Lambda.dest l
  42          in
  43             Lambda.make {arg = arg,
  44                          argType = argType,
  45                          body = loopExp body,
  46                          mayInline = mayInline}
  47          end
  48       and loopPrimExp (e: PrimExp.t): PrimExp.t =
  49          case e of
  50             App {func, arg} => (loopVarExp func; loopVarExp arg; e)
  51           | Case {test, cases, default} =>
  52                (loopVarExp test
  53                 ; Case {cases = Cases.map (cases, loopExp),
  54                         default = Option.map (default, fn (e, r) =>
  55                                               (loopExp e, r)),
  56                         test = test})
  57           | ConApp {arg, ...} => (Option.app (arg, loopVarExp); e)
  58           | Const _ => e
  59           | Handle {try, catch, handler} =>
  60                Handle {try = loopExp try,
  61                        catch = catch,
  62                        handler = loopExp handler}
  63           | Lambda l => Lambda (loopLambda l)
  64           | PrimApp {args, ...} => (loopVarExps args; e)
  65           | Profile _ => e
  66           | Raise {exn, ...} => (loopVarExp exn; e)
  67           | Select {tuple, ...} => (loopVarExp tuple; e)
  68           | Tuple xs => (loopVarExps xs; e)
  69           | Var x => (loopVarExp x; e)
  70       and loopExp (e: Exp.t): Exp.t =
  71          let
  72             val {decs, result} = Exp.dest e
  73             val decs =
  74                List.rev
  75                (List.fold
  76                 (decs, [], fn (dec, decs) =>
  77                  case dec of
  78                     MonoVal {var, ty, exp} =>
  79                        MonoVal {var = var, ty = ty,
  80                                 exp = loopPrimExp exp} :: decs
  81                   | PolyVal {var, tyvars, ty, exp} =>
  82                        PolyVal {var = var, tyvars = tyvars, ty = ty,
  83                                 exp = loopExp exp} :: decs
  84                   | Exception _ => dec :: decs
  85                   | Fun {tyvars, decs = lambdas} =>
  86                        let val g = Graph.new ()
  87                           val _ =
  88                              Vector.foreach
  89                              (lambdas, fn {var, ...} =>
  90                               setFunInfo (var, SOME {node = Graph.newNode g,
  91                                                      visit = ref ignore}))
  92                           val _ =
  93                              Vector.foreach
  94                              (lambdas, fn {var, ty, lambda} =>
  95                               let val {node = from, ...} = valOf (funInfo var)
  96                               in Vector.foreach
  97                                  (lambdas, fn {var = x, ...} =>
  98                                   let val {visit, node = to} = valOf (funInfo x)
  99                                   in visit := (fn () =>
 100                                                let
 101                                                   val _ = Graph.addEdge
 102                                                           (g, {from = from, to = to})
 103                                                in
 104                                                   visit := ignore
 105                                                end)
 106                                   end)
 107                                  ; (setNodeLambda
 108                                     (from, {var = var,
 109                                             ty = ty,
 110                                             lambda = loopLambda lambda}))
 111                                  ; (Vector.foreach
 112                                     (lambdas, fn {var, ...} =>
 113                                      let val {visit, ...} = valOf (funInfo var)
 114                                      in visit := ignore
 115                                      end))
 116                               end)
 117                        in List.map
 118                           (Graph.stronglyConnectedComponents g, fn nodes =>
 119                            Fun {tyvars = tyvars,
 120                                 decs = Vector.fromListMap (nodes, nodeLambda)})
 121                           @ decs
 122                        end))
 123             val _ = loopVarExp result
 124          in
 125             Exp.make {decs = decs, result = result}
 126          end
 127    in
 128       Program.T {datatypes = datatypes,
 129                  body = loopExp body,
 130                  overflow = overflow}
 131    end
 132
 133 end