Commit | Line | Data |
---|---|---|
7f918cf1 CE |
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 |