Mercurial > urweb

comparison src/core_untangle.sml @ 519:23a88d81a1b5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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