adamc@454
|
1 (* Copyright (c) 2008, Adam Chlipala
|
adamc@454
|
2 * All rights reserved.
|
adamc@454
|
3 *
|
adamc@454
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@454
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@454
|
6 *
|
adamc@454
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@454
|
8 * this list of conditions and the following disclaimer.
|
adamc@454
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@454
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@454
|
11 * and/or other materials provided with the distribution.
|
adamc@454
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@454
|
13 * derived from this software without specific prior written permission.
|
adamc@454
|
14 *
|
adamc@454
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@454
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@454
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@454
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@454
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@454
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@454
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@454
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@454
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@454
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@454
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@454
|
26 *)
|
adamc@454
|
27
|
adamc@454
|
28 structure CoreUntangle :> CORE_UNTANGLE = struct
|
adamc@454
|
29
|
adamc@454
|
30 open Core
|
adamc@454
|
31
|
adamc@454
|
32 structure U = CoreUtil
|
adamc@454
|
33 structure E = CoreEnv
|
adamc@454
|
34
|
adamc@454
|
35 structure IS = IntBinarySet
|
adamc@454
|
36 structure IM = IntBinaryMap
|
adamc@454
|
37
|
adamc@454
|
38 fun default (k, s) = s
|
adamc@454
|
39
|
adamc@519
|
40 fun exp thisGroup (e, s) =
|
adamc@954
|
41 let
|
adamc@954
|
42 fun try n =
|
adamc@954
|
43 if IS.member (thisGroup, n) then
|
adamc@954
|
44 IS.add (s, n)
|
adamc@954
|
45 else
|
adamc@954
|
46 s
|
adamc@954
|
47 in
|
adamc@954
|
48 case e of
|
adamc@954
|
49 ENamed n => try n
|
adamc@954
|
50 | EClosure (n, _) => try n
|
adamc@1020
|
51 | EServerCall (n, _, _) => try n
|
adamc@954
|
52 | _ => s
|
adamc@954
|
53 end
|
adamc@454
|
54
|
adamc@454
|
55 fun untangle file =
|
adamc@454
|
56 let
|
adamc@519
|
57 fun expUsed thisGroup = U.Exp.fold {con = default,
|
adamc@519
|
58 kind = default,
|
adamc@519
|
59 exp = exp thisGroup} IS.empty
|
adamc@455
|
60
|
adamc@454
|
61 fun decl (dAll as (d, loc)) =
|
adamc@454
|
62 case d of
|
adamc@454
|
63 DValRec vis =>
|
adamc@454
|
64 let
|
adamc@454
|
65 val thisGroup = foldl (fn ((_, n, _, _, _), thisGroup) =>
|
adamc@454
|
66 IS.add (thisGroup, n)) IS.empty vis
|
adamc@454
|
67
|
adamc@519
|
68 val edefs = foldl (fn ((_, n, _, e, _), edefs) =>
|
adamc@519
|
69 IM.insert (edefs, n, expUsed thisGroup e))
|
adamc@519
|
70 IM.empty vis
|
adamc@455
|
71
|
adamc@519
|
72 val used = edefs
|
adamc@454
|
73
|
adamc@455
|
74 fun expand used =
|
adamc@455
|
75 IS.foldl (fn (n, used) =>
|
adamc@455
|
76 case IM.find (edefs, n) of
|
adamc@455
|
77 NONE => used
|
adamc@519
|
78 | SOME usedHere =>
|
adamc@519
|
79 if IS.isEmpty (IS.difference (usedHere, used)) then
|
adamc@519
|
80 used
|
adamc@519
|
81 else
|
adamc@519
|
82 expand (IS.union (usedHere, used)))
|
adamc@455
|
83 used used
|
adamc@455
|
84
|
adamc@454
|
85 fun p_graph reachable =
|
adamc@454
|
86 IM.appi (fn (n, reachableHere) =>
|
adamc@454
|
87 (print (Int.toString n);
|
adamc@454
|
88 print ":";
|
adamc@454
|
89 IS.app (fn n' => (print " ";
|
adamc@454
|
90 print (Int.toString n'))) reachableHere;
|
adamc@454
|
91 print "\n")) reachable
|
adamc@454
|
92
|
adamc@454
|
93 (*val () = print "used:\n"
|
adamc@454
|
94 val () = p_graph used*)
|
adamc@454
|
95
|
adamc@454
|
96 fun expand reachable =
|
adamc@454
|
97 let
|
adamc@454
|
98 val changed = ref false
|
adamc@454
|
99
|
adamc@454
|
100 val reachable =
|
adamc@454
|
101 IM.mapi (fn (n, reachableHere) =>
|
adamc@454
|
102 IS.foldl (fn (n', reachableHere) =>
|
adamc@454
|
103 let
|
adamc@454
|
104 val more = valOf (IM.find (reachable, n'))
|
adamc@454
|
105 in
|
adamc@454
|
106 if IS.isEmpty (IS.difference (more, reachableHere)) then
|
adamc@454
|
107 reachableHere
|
adamc@454
|
108 else
|
adamc@454
|
109 (changed := true;
|
adamc@454
|
110 IS.union (more, reachableHere))
|
adamc@454
|
111 end)
|
adamc@454
|
112 reachableHere reachableHere) reachable
|
adamc@454
|
113 in
|
adamc@454
|
114 (reachable, !changed)
|
adamc@454
|
115 end
|
adamc@454
|
116
|
adamc@454
|
117 fun iterate reachable =
|
adamc@454
|
118 let
|
adamc@454
|
119 val (reachable, changed) = expand reachable
|
adamc@454
|
120 in
|
adamc@454
|
121 if changed then
|
adamc@454
|
122 iterate reachable
|
adamc@454
|
123 else
|
adamc@454
|
124 reachable
|
adamc@454
|
125 end
|
adamc@454
|
126
|
adamc@454
|
127 val reachable = iterate used
|
adamc@454
|
128
|
adamc@454
|
129 (*val () = print "reachable:\n"
|
adamc@454
|
130 val () = p_graph reachable*)
|
adamc@454
|
131
|
adamc@454
|
132 fun sccs (nodes, acc) =
|
adamc@454
|
133 case IS.find (fn _ => true) nodes of
|
adamc@454
|
134 NONE => acc
|
adamc@454
|
135 | SOME rep =>
|
adamc@454
|
136 let
|
adamc@454
|
137 val reachableHere = valOf (IM.find (reachable, rep))
|
adamc@454
|
138
|
adamc@454
|
139 val (nodes, scc) = IS.foldl (fn (node, (nodes, scc)) =>
|
adamc@454
|
140 if node = rep then
|
adamc@454
|
141 (nodes, scc)
|
adamc@454
|
142 else
|
adamc@454
|
143 let
|
adamc@454
|
144 val reachableThere =
|
adamc@454
|
145 valOf (IM.find (reachable, node))
|
adamc@454
|
146 in
|
adamc@454
|
147 if IS.member (reachableThere, rep) then
|
adamc@454
|
148 (IS.delete (nodes, node),
|
adamc@454
|
149 IS.add (scc, node))
|
adamc@454
|
150 else
|
adamc@454
|
151 (nodes, scc)
|
adamc@454
|
152 end)
|
adamc@454
|
153 (IS.delete (nodes, rep), IS.singleton rep) reachableHere
|
adamc@454
|
154 in
|
adamc@454
|
155 sccs (nodes, scc :: acc)
|
adamc@454
|
156 end
|
adamc@454
|
157
|
adamc@454
|
158 val sccs = sccs (thisGroup, [])
|
adamc@519
|
159
|
adamc@454
|
160 (*val () = app (fn nodes => (print "SCC:";
|
adamc@454
|
161 IS.app (fn i => (print " ";
|
adamc@454
|
162 print (Int.toString i))) nodes;
|
adamc@454
|
163 print "\n")) sccs*)
|
adamc@454
|
164
|
adamc@454
|
165 fun depends nodes1 nodes2 =
|
adamc@454
|
166 let
|
adamc@454
|
167 val node1 = valOf (IS.find (fn _ => true) nodes1)
|
adamc@454
|
168 val node2 = valOf (IS.find (fn _ => true) nodes2)
|
adamc@454
|
169 val reachable1 = valOf (IM.find (reachable, node1))
|
adamc@454
|
170 in
|
adamc@454
|
171 IS.member (reachable1, node2)
|
adamc@454
|
172 end
|
adamc@454
|
173
|
adamc@454
|
174 fun findReady (sccs, passed) =
|
adamc@454
|
175 case sccs of
|
adamc@454
|
176 [] => raise Fail "Untangle: Unable to topologically sort 'val rec'"
|
adamc@454
|
177 | nodes :: sccs =>
|
adamc@454
|
178 if List.exists (depends nodes) passed
|
adamc@454
|
179 orelse List.exists (depends nodes) sccs then
|
adamc@454
|
180 findReady (sccs, nodes :: passed)
|
adamc@454
|
181 else
|
adamc@454
|
182 (nodes, List.revAppend (passed, sccs))
|
adamc@454
|
183
|
adamc@454
|
184 fun topo (sccs, acc) =
|
adamc@454
|
185 case sccs of
|
adamc@454
|
186 [] => rev acc
|
adamc@454
|
187 | _ =>
|
adamc@454
|
188 let
|
adamc@454
|
189 val (node, sccs) = findReady (sccs, [])
|
adamc@454
|
190 in
|
adamc@454
|
191 topo (sccs, node :: acc)
|
adamc@454
|
192 end
|
adamc@454
|
193
|
adamc@454
|
194 val sccs = topo (sccs, [])
|
adamc@519
|
195
|
adamc@454
|
196 (*val () = app (fn nodes => (print "SCC':";
|
adamc@454
|
197 IS.app (fn i => (print " ";
|
adamc@454
|
198 print (Int.toString i))) nodes;
|
adamc@454
|
199 print "\n")) sccs*)
|
adamc@454
|
200
|
adamc@454
|
201 fun isNonrec nodes =
|
adamc@454
|
202 case IS.find (fn _ => true) nodes of
|
adamc@454
|
203 NONE => NONE
|
adamc@454
|
204 | SOME node =>
|
adamc@454
|
205 let
|
adamc@454
|
206 val nodes = IS.delete (nodes, node)
|
adamc@454
|
207 val reachableHere = valOf (IM.find (reachable, node))
|
adamc@454
|
208 in
|
adamc@454
|
209 if IS.isEmpty nodes then
|
adamc@454
|
210 if IS.member (reachableHere, node) then
|
adamc@454
|
211 NONE
|
adamc@454
|
212 else
|
adamc@454
|
213 SOME node
|
adamc@454
|
214 else
|
adamc@454
|
215 NONE
|
adamc@454
|
216 end
|
adamc@454
|
217
|
adamc@454
|
218 val ds = map (fn nodes =>
|
adamc@454
|
219 case isNonrec nodes of
|
adamc@454
|
220 SOME node =>
|
adamc@454
|
221 let
|
adamc@454
|
222 val vi = valOf (List.find (fn (_, n, _, _, _) => n = node) vis)
|
adamc@454
|
223 in
|
adamc@454
|
224 (DVal vi, loc)
|
adamc@454
|
225 end
|
adamc@454
|
226 | NONE =>
|
adamc@454
|
227 (DValRec (List.filter (fn (_, n, _, _, _) => IS.member (nodes, n)) vis), loc))
|
adamc@454
|
228 sccs
|
adamc@454
|
229 in
|
adamc@454
|
230 ds
|
adamc@454
|
231 end
|
adamc@454
|
232 | _ => [dAll]
|
adamc@454
|
233 in
|
adamc@454
|
234 ListUtil.mapConcat decl file
|
adamc@454
|
235 end
|
adamc@454
|
236
|
adamc@454
|
237 end
|