Mercurial > urweb

comparison src/untangle.sml @ 131:5df655503288

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Untangle
author Adam Chlipala <adamc@hcoop.net>
date Thu, 17 Jul 2008 12:19:44 -0400
parents
children 25b28625d4df
comparison
equal deleted inserted replaced
130:96bd3350e77d 131:5df655503288
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 Untangle :> UNTANGLE = struct
29
30 open Mono
31
32 structure U = MonoUtil
33 structure E = MonoEnv
34
35 structure IS = IntBinarySet
36 structure IM = IntBinaryMap
37
38 fun typ (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 {typ = typ,
58 exp = exp} IS.empty e
59 in
60 IM.insert (used, n, IS.intersection (usedHere, thisGroup))
61 end)
62 IM.empty vis
63
64 fun p_graph reachable =
65 IM.appi (fn (n, reachableHere) =>
66 (print (Int.toString n);
67 print ":";
68 IS.app (fn n' => (print " ";
69 print (Int.toString n'))) reachableHere;
70 print "\n")) reachable
71
72 (*val () = print "used:\n"
73 val () = p_graph used*)
74
75 fun expand reachable =
76 let
77 val changed = ref false
78
79 val reachable =
80 IM.mapi (fn (n, reachableHere) =>
81 IS.foldl (fn (n', reachableHere) =>
82 let
83 val more = valOf (IM.find (reachable, n'))
84 in
85 if IS.isEmpty (IS.difference (more, reachableHere)) then
86 reachableHere
87 else
88 (changed := true;
89 IS.union (more, reachableHere))
90 end)
91 reachableHere reachableHere) reachable
92 in
93 (reachable, !changed)
94 end
95
96 fun iterate reachable =
97 let
98 val (reachable, changed) = expand reachable
99 in
100 if changed then
101 iterate reachable
102 else
103 reachable
104 end
105
106 val reachable = iterate used
107
108 (*val () = print "reachable:\n"
109 val () = p_graph reachable*)
110
111 fun sccs (nodes, acc) =
112 case IS.find (fn _ => true) nodes of
113 NONE => acc
114 | SOME rep =>
115 let
116 val reachableHere = valOf (IM.find (reachable, rep))
117
118 val (nodes, scc) = IS.foldl (fn (node, (nodes, scc)) =>
119 if node = rep then
120 (nodes, scc)
121 else
122 let
123 val reachableThere =
124 valOf (IM.find (reachable, node))
125 in
126 if IS.member (reachableThere, rep) then
127 (IS.delete (nodes, node),
128 IS.add (scc, node))
129 else
130 (nodes, scc)
131 end)
132 (IS.delete (nodes, rep), IS.singleton rep) reachableHere
133 in
134 sccs (nodes, scc :: acc)
135 end
136
137 val sccs = rev (sccs (thisGroup, []))
138 (*val () = app (fn nodes => (print "SCC:";
139 IS.app (fn i => (print " ";
140 print (Int.toString i))) nodes;
141 print "\n")) sccs*)
142
143 val sccs = ListMergeSort.sort (fn (nodes1, nodes2) =>
144 let
145 val node1 = valOf (IS.find (fn _ => true) nodes1)
146 val node2 = valOf (IS.find (fn _ => true) nodes2)
147 val reachable1 = valOf (IM.find (reachable, node1))
148 in
149 IS.member (reachable1, node2)
150 end) sccs
151 (*val () = app (fn nodes => (print "SCC':";
152 IS.app (fn i => (print " ";
153 print (Int.toString i))) nodes;
154 print "\n")) sccs*)
155
156 fun isNonrec nodes =
157 case IS.find (fn _ => true) nodes of
158 NONE => NONE
159 | SOME node =>
160 let
161 val nodes = IS.delete (nodes, node)
162 val reachableHere = valOf (IM.find (reachable, node))
163 in
164 if IS.isEmpty nodes then
165 if IS.member (reachableHere, node) then
166 NONE
167 else
168 SOME node
169 else
170 NONE
171 end
172
173 val ds = map (fn nodes =>
174 case isNonrec nodes of
175 SOME node =>
176 let
177 val vi = valOf (List.find (fn (_, n, _, _, _) => n = node) vis)
178 in
179 (DVal vi, loc)
180 end
181 | NONE =>
182 (DValRec (List.filter (fn (_, n, _, _, _) => IS.member (nodes, n)) vis), loc))
183 sccs
184 in
185 ds
186 end
187 | _ => [dAll]
188 in
189 ListUtil.mapConcat decl file
190 end
191
192 end