Mercurial > urweb

comparison src/core_untangle.sml @ 454:9163f8014f9b

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