Mercurial > urweb

annotate 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
rev   line source
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@454 40 fun exp (e, s) =
adamc@454 41 case e of
adamc@454 42 ENamed n => IS.add (s, n)
adamc@454 43
adamc@454 44 | _ => s
adamc@454 45
adamc@454 46 fun untangle file =
adamc@454 47 let
adamc@454 48 fun decl (dAll as (d, loc)) =
adamc@454 49 case d of
adamc@454 50 DValRec vis =>
adamc@454 51 let
adamc@454 52 val thisGroup = foldl (fn ((_, n, _, _, _), thisGroup) =>
adamc@454 53 IS.add (thisGroup, n)) IS.empty vis
adamc@454 54
adamc@454 55 val used = foldl (fn ((_, n, _, e, _), used) =>
adamc@454 56 let
adamc@454 57 val usedHere = U.Exp.fold {con = default,
adamc@454 58 kind = default,
adamc@454 59 exp = exp} IS.empty e
adamc@454 60 in
adamc@454 61 IM.insert (used, n, IS.intersection (usedHere, thisGroup))
adamc@454 62 end)
adamc@454 63 IM.empty vis
adamc@454 64
adamc@454 65 fun p_graph reachable =
adamc@454 66 IM.appi (fn (n, reachableHere) =>
adamc@454 67 (print (Int.toString n);
adamc@454 68 print ":";
adamc@454 69 IS.app (fn n' => (print " ";
adamc@454 70 print (Int.toString n'))) reachableHere;
adamc@454 71 print "\n")) reachable
adamc@454 72
adamc@454 73 (*val () = print "used:\n"
adamc@454 74 val () = p_graph used*)
adamc@454 75
adamc@454 76 fun expand reachable =
adamc@454 77 let
adamc@454 78 val changed = ref false
adamc@454 79
adamc@454 80 val reachable =
adamc@454 81 IM.mapi (fn (n, reachableHere) =>
adamc@454 82 IS.foldl (fn (n', reachableHere) =>
adamc@454 83 let
adamc@454 84 val more = valOf (IM.find (reachable, n'))
adamc@454 85 in
adamc@454 86 if IS.isEmpty (IS.difference (more, reachableHere)) then
adamc@454 87 reachableHere
adamc@454 88 else
adamc@454 89 (changed := true;
adamc@454 90 IS.union (more, reachableHere))
adamc@454 91 end)
adamc@454 92 reachableHere reachableHere) reachable
adamc@454 93 in
adamc@454 94 (reachable, !changed)
adamc@454 95 end
adamc@454 96
adamc@454 97 fun iterate reachable =
adamc@454 98 let
adamc@454 99 val (reachable, changed) = expand reachable
adamc@454 100 in
adamc@454 101 if changed then
adamc@454 102 iterate reachable
adamc@454 103 else
adamc@454 104 reachable
adamc@454 105 end
adamc@454 106
adamc@454 107 val reachable = iterate used
adamc@454 108
adamc@454 109 (*val () = print "reachable:\n"
adamc@454 110 val () = p_graph reachable*)
adamc@454 111
adamc@454 112 fun sccs (nodes, acc) =
adamc@454 113 case IS.find (fn _ => true) nodes of
adamc@454 114 NONE => acc
adamc@454 115 | SOME rep =>
adamc@454 116 let
adamc@454 117 val reachableHere = valOf (IM.find (reachable, rep))
adamc@454 118
adamc@454 119 val (nodes, scc) = IS.foldl (fn (node, (nodes, scc)) =>
adamc@454 120 if node = rep then
adamc@454 121 (nodes, scc)
adamc@454 122 else
adamc@454 123 let
adamc@454 124 val reachableThere =
adamc@454 125 valOf (IM.find (reachable, node))
adamc@454 126 in
adamc@454 127 if IS.member (reachableThere, rep) then
adamc@454 128 (IS.delete (nodes, node),
adamc@454 129 IS.add (scc, node))
adamc@454 130 else
adamc@454 131 (nodes, scc)
adamc@454 132 end)
adamc@454 133 (IS.delete (nodes, rep), IS.singleton rep) reachableHere
adamc@454 134 in
adamc@454 135 sccs (nodes, scc :: acc)
adamc@454 136 end
adamc@454 137
adamc@454 138 val sccs = sccs (thisGroup, [])
adamc@454 139 (*val () = app (fn nodes => (print "SCC:";
adamc@454 140 IS.app (fn i => (print " ";
adamc@454 141 print (Int.toString i))) nodes;
adamc@454 142 print "\n")) sccs*)
adamc@454 143
adamc@454 144 fun depends nodes1 nodes2 =
adamc@454 145 let
adamc@454 146 val node1 = valOf (IS.find (fn _ => true) nodes1)
adamc@454 147 val node2 = valOf (IS.find (fn _ => true) nodes2)
adamc@454 148 val reachable1 = valOf (IM.find (reachable, node1))
adamc@454 149 in
adamc@454 150 IS.member (reachable1, node2)
adamc@454 151 end
adamc@454 152
adamc@454 153 fun findReady (sccs, passed) =
adamc@454 154 case sccs of
adamc@454 155 [] => raise Fail "Untangle: Unable to topologically sort 'val rec'"
adamc@454 156 | nodes :: sccs =>
adamc@454 157 if List.exists (depends nodes) passed
adamc@454 158 orelse List.exists (depends nodes) sccs then
adamc@454 159 findReady (sccs, nodes :: passed)
adamc@454 160 else
adamc@454 161 (nodes, List.revAppend (passed, sccs))
adamc@454 162
adamc@454 163 fun topo (sccs, acc) =
adamc@454 164 case sccs of
adamc@454 165 [] => rev acc
adamc@454 166 | _ =>
adamc@454 167 let
adamc@454 168 val (node, sccs) = findReady (sccs, [])
adamc@454 169 in
adamc@454 170 topo (sccs, node :: acc)
adamc@454 171 end
adamc@454 172
adamc@454 173 val sccs = topo (sccs, [])
adamc@454 174 (*val () = app (fn nodes => (print "SCC':";
adamc@454 175 IS.app (fn i => (print " ";
adamc@454 176 print (Int.toString i))) nodes;
adamc@454 177 print "\n")) sccs*)
adamc@454 178
adamc@454 179 fun isNonrec nodes =
adamc@454 180 case IS.find (fn _ => true) nodes of
adamc@454 181 NONE => NONE
adamc@454 182 | SOME node =>
adamc@454 183 let
adamc@454 184 val nodes = IS.delete (nodes, node)
adamc@454 185 val reachableHere = valOf (IM.find (reachable, node))
adamc@454 186 in
adamc@454 187 if IS.isEmpty nodes then
adamc@454 188 if IS.member (reachableHere, node) then
adamc@454 189 NONE
adamc@454 190 else
adamc@454 191 SOME node
adamc@454 192 else
adamc@454 193 NONE
adamc@454 194 end
adamc@454 195
adamc@454 196 val ds = map (fn nodes =>
adamc@454 197 case isNonrec nodes of
adamc@454 198 SOME node =>
adamc@454 199 let
adamc@454 200 val vi = valOf (List.find (fn (_, n, _, _, _) => n = node) vis)
adamc@454 201 in
adamc@454 202 (DVal vi, loc)
adamc@454 203 end
adamc@454 204 | NONE =>
adamc@454 205 (DValRec (List.filter (fn (_, n, _, _, _) => IS.member (nodes, n)) vis), loc))
adamc@454 206 sccs
adamc@454 207 in
adamc@454 208 ds
adamc@454 209 end
adamc@454 210 | _ => [dAll]
adamc@454 211 in
adamc@454 212 ListUtil.mapConcat decl file
adamc@454 213 end
adamc@454 214
adamc@454 215 end