Mercurial > urweb
comparison src/core_untangle.sml @ 519:23a88d81a1b5
Optimize CoreUntangle
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Thu, 27 Nov 2008 11:40:13 -0500 |
parents | d4a81273d4b1 |
children | ef6de4075dc1 |
comparison
equal
deleted
inserted
replaced
518:685d232bd1a5 | 519:23a88d81a1b5 |
---|---|
35 structure IS = IntBinarySet | 35 structure IS = IntBinarySet |
36 structure IM = IntBinaryMap | 36 structure IM = IntBinaryMap |
37 | 37 |
38 fun default (k, s) = s | 38 fun default (k, s) = s |
39 | 39 |
40 fun exp (e, s) = | 40 fun exp thisGroup (e, s) = |
41 case e of | 41 case e of |
42 ENamed n => IS.add (s, n) | 42 ENamed n => |
43 if IS.member (thisGroup, n) then | |
44 IS.add (s, n) | |
45 else | |
46 s | |
43 | 47 |
44 | _ => s | 48 | _ => s |
45 | 49 |
46 fun untangle file = | 50 fun untangle file = |
47 let | 51 let |
48 val edefs = foldl (fn ((d, _), edefs) => | 52 fun expUsed thisGroup = U.Exp.fold {con = default, |
49 case d of | 53 kind = default, |
50 DVal (_, n, _, e, _) => IM.insert (edefs, n, e) | 54 exp = exp thisGroup} IS.empty |
51 | DValRec vis => | |
52 foldl (fn ((_, n, _, e, _), edefs) => | |
53 IM.insert (edefs, n, e)) edefs vis | |
54 | _ => edefs) | |
55 IM.empty file | |
56 | 55 |
57 fun decl (dAll as (d, loc)) = | 56 fun decl (dAll as (d, loc)) = |
58 case d of | 57 case d of |
59 DValRec vis => | 58 DValRec vis => |
60 let | 59 let |
61 val thisGroup = foldl (fn ((_, n, _, _, _), thisGroup) => | 60 val thisGroup = foldl (fn ((_, n, _, _, _), thisGroup) => |
62 IS.add (thisGroup, n)) IS.empty vis | 61 IS.add (thisGroup, n)) IS.empty vis |
63 | 62 |
64 val expUsed = U.Exp.fold {con = default, | 63 val edefs = foldl (fn ((_, n, _, e, _), edefs) => |
65 kind = default, | 64 IM.insert (edefs, n, expUsed thisGroup e)) |
66 exp = exp} IS.empty | 65 IM.empty vis |
67 | 66 |
68 val used = foldl (fn ((_, n, _, e, _), used) => | 67 val used = edefs |
69 let | |
70 val usedHere = expUsed e | |
71 in | |
72 IM.insert (used, n, usedHere) | |
73 end) | |
74 IM.empty vis | |
75 | 68 |
76 fun expand used = | 69 fun expand used = |
77 IS.foldl (fn (n, used) => | 70 IS.foldl (fn (n, used) => |
78 case IM.find (edefs, n) of | 71 case IM.find (edefs, n) of |
79 NONE => used | 72 NONE => used |
80 | SOME e => | 73 | SOME usedHere => |
81 let | 74 if IS.isEmpty (IS.difference (usedHere, used)) then |
82 val usedHere = expUsed e | 75 used |
83 in | 76 else |
84 if IS.isEmpty (IS.difference (usedHere, used)) then | 77 expand (IS.union (usedHere, used))) |
85 used | |
86 else | |
87 expand (IS.union (usedHere, used)) | |
88 end) | |
89 used used | 78 used used |
90 | |
91 val used = IM.map (fn s => IS.intersection (expand s, thisGroup)) used | |
92 | 79 |
93 fun p_graph reachable = | 80 fun p_graph reachable = |
94 IM.appi (fn (n, reachableHere) => | 81 IM.appi (fn (n, reachableHere) => |
95 (print (Int.toString n); | 82 (print (Int.toString n); |
96 print ":"; | 83 print ":"; |
162 in | 149 in |
163 sccs (nodes, scc :: acc) | 150 sccs (nodes, scc :: acc) |
164 end | 151 end |
165 | 152 |
166 val sccs = sccs (thisGroup, []) | 153 val sccs = sccs (thisGroup, []) |
154 | |
167 (*val () = app (fn nodes => (print "SCC:"; | 155 (*val () = app (fn nodes => (print "SCC:"; |
168 IS.app (fn i => (print " "; | 156 IS.app (fn i => (print " "; |
169 print (Int.toString i))) nodes; | 157 print (Int.toString i))) nodes; |
170 print "\n")) sccs*) | 158 print "\n")) sccs*) |
171 | 159 |
197 in | 185 in |
198 topo (sccs, node :: acc) | 186 topo (sccs, node :: acc) |
199 end | 187 end |
200 | 188 |
201 val sccs = topo (sccs, []) | 189 val sccs = topo (sccs, []) |
190 | |
202 (*val () = app (fn nodes => (print "SCC':"; | 191 (*val () = app (fn nodes => (print "SCC':"; |
203 IS.app (fn i => (print " "; | 192 IS.app (fn i => (print " "; |
204 print (Int.toString i))) nodes; | 193 print (Int.toString i))) nodes; |
205 print "\n")) sccs*) | 194 print "\n")) sccs*) |
206 | 195 |