Mercurial > urweb

annotate src/core_untangle.sml @ 2057:f4a6ccb7937f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Allow Body tags inside cformTags This is required by Bootstrap. For example, see http://getbootstrap.com/components/#alerts-dismissible
author Sergey Mironov <grrwlf@gmail.com>
date Sun, 17 Aug 2014 18:28:37 +0000
parents e15234fbb163
children
rev   line source
adam@1848 1 (* Copyright (c) 2008, 2013, 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@519 40 fun exp thisGroup (e, s) =
adamc@954 41 let
adamc@954 42 fun try n =
adamc@954 43 if IS.member (thisGroup, n) then
adamc@954 44 IS.add (s, n)
adamc@954 45 else
adamc@954 46 s
adamc@954 47 in
adamc@954 48 case e of
adamc@954 49 ENamed n => try n
adamc@954 50 | EClosure (n, _) => try n
adam@1848 51 | EServerCall (n, _, _, _) => try n
adamc@954 52 | _ => s
adamc@954 53 end
adamc@454 54
adamc@454 55 fun untangle file =
adamc@454 56 let
adamc@519 57 fun expUsed thisGroup = U.Exp.fold {con = default,
adamc@519 58 kind = default,
adamc@519 59 exp = exp thisGroup} IS.empty
adamc@455 60
adamc@454 61 fun decl (dAll as (d, loc)) =
adamc@454 62 case d of
adamc@454 63 DValRec vis =>
adamc@454 64 let
adamc@454 65 val thisGroup = foldl (fn ((_, n, _, _, _), thisGroup) =>
adamc@454 66 IS.add (thisGroup, n)) IS.empty vis
adamc@454 67
adamc@519 68 val edefs = foldl (fn ((_, n, _, e, _), edefs) =>
adamc@519 69 IM.insert (edefs, n, expUsed thisGroup e))
adamc@519 70 IM.empty vis
adamc@455 71
adamc@519 72 val used = edefs
adamc@454 73
adamc@455 74 fun expand used =
adamc@455 75 IS.foldl (fn (n, used) =>
adamc@455 76 case IM.find (edefs, n) of
adamc@455 77 NONE => used
adamc@519 78 | SOME usedHere =>
adamc@519 79 if IS.isEmpty (IS.difference (usedHere, used)) then
adamc@519 80 used
adamc@519 81 else
adamc@519 82 expand (IS.union (usedHere, used)))
adamc@455 83 used used
adamc@455 84
adamc@454 85 fun p_graph reachable =
adamc@454 86 IM.appi (fn (n, reachableHere) =>
adamc@454 87 (print (Int.toString n);
adamc@454 88 print ":";
adamc@454 89 IS.app (fn n' => (print " ";
adamc@454 90 print (Int.toString n'))) reachableHere;
adamc@454 91 print "\n")) reachable
adamc@454 92
adamc@454 93 (*val () = print "used:\n"
adamc@454 94 val () = p_graph used*)
adamc@454 95
adamc@454 96 fun expand reachable =
adamc@454 97 let
adamc@454 98 val changed = ref false
adamc@454 99
adamc@454 100 val reachable =
adamc@454 101 IM.mapi (fn (n, reachableHere) =>
adamc@454 102 IS.foldl (fn (n', reachableHere) =>
adamc@454 103 let
adamc@454 104 val more = valOf (IM.find (reachable, n'))
adamc@454 105 in
adamc@454 106 if IS.isEmpty (IS.difference (more, reachableHere)) then
adamc@454 107 reachableHere
adamc@454 108 else
adamc@454 109 (changed := true;
adamc@454 110 IS.union (more, reachableHere))
adamc@454 111 end)
adamc@454 112 reachableHere reachableHere) reachable
adamc@454 113 in
adamc@454 114 (reachable, !changed)
adamc@454 115 end
adamc@454 116
adamc@454 117 fun iterate reachable =
adamc@454 118 let
adamc@454 119 val (reachable, changed) = expand reachable
adamc@454 120 in
adamc@454 121 if changed then
adamc@454 122 iterate reachable
adamc@454 123 else
adamc@454 124 reachable
adamc@454 125 end
adamc@454 126
adamc@454 127 val reachable = iterate used
adamc@454 128
adamc@454 129 (*val () = print "reachable:\n"
adamc@454 130 val () = p_graph reachable*)
adamc@454 131
adamc@454 132 fun sccs (nodes, acc) =
adamc@454 133 case IS.find (fn _ => true) nodes of
adamc@454 134 NONE => acc
adamc@454 135 | SOME rep =>
adamc@454 136 let
adamc@454 137 val reachableHere = valOf (IM.find (reachable, rep))
adamc@454 138
adamc@454 139 val (nodes, scc) = IS.foldl (fn (node, (nodes, scc)) =>
adamc@454 140 if node = rep then
adamc@454 141 (nodes, scc)
adamc@454 142 else
adamc@454 143 let
adamc@454 144 val reachableThere =
adamc@454 145 valOf (IM.find (reachable, node))
adamc@454 146 in
adamc@454 147 if IS.member (reachableThere, rep) then
adamc@454 148 (IS.delete (nodes, node),
adamc@454 149 IS.add (scc, node))
adamc@454 150 else
adamc@454 151 (nodes, scc)
adamc@454 152 end)
adamc@454 153 (IS.delete (nodes, rep), IS.singleton rep) reachableHere
adamc@454 154 in
adamc@454 155 sccs (nodes, scc :: acc)
adamc@454 156 end
adamc@454 157
adamc@454 158 val sccs = sccs (thisGroup, [])
adamc@519 159
adamc@454 160 (*val () = app (fn nodes => (print "SCC:";
adamc@454 161 IS.app (fn i => (print " ";
adamc@454 162 print (Int.toString i))) nodes;
adamc@454 163 print "\n")) sccs*)
adamc@454 164
adamc@454 165 fun depends nodes1 nodes2 =
adamc@454 166 let
adamc@454 167 val node1 = valOf (IS.find (fn _ => true) nodes1)
adamc@454 168 val node2 = valOf (IS.find (fn _ => true) nodes2)
adamc@454 169 val reachable1 = valOf (IM.find (reachable, node1))
adamc@454 170 in
adamc@454 171 IS.member (reachable1, node2)
adamc@454 172 end
adamc@454 173
adamc@454 174 fun findReady (sccs, passed) =
adamc@454 175 case sccs of
adamc@454 176 [] => raise Fail "Untangle: Unable to topologically sort 'val rec'"
adamc@454 177 | nodes :: sccs =>
adamc@454 178 if List.exists (depends nodes) passed
adamc@454 179 orelse List.exists (depends nodes) sccs then
adamc@454 180 findReady (sccs, nodes :: passed)
adamc@454 181 else
adamc@454 182 (nodes, List.revAppend (passed, sccs))
adamc@454 183
adamc@454 184 fun topo (sccs, acc) =
adamc@454 185 case sccs of
adamc@454 186 [] => rev acc
adamc@454 187 | _ =>
adamc@454 188 let
adamc@454 189 val (node, sccs) = findReady (sccs, [])
adamc@454 190 in
adamc@454 191 topo (sccs, node :: acc)
adamc@454 192 end
adamc@454 193
adamc@454 194 val sccs = topo (sccs, [])
adamc@519 195
adamc@454 196 (*val () = app (fn nodes => (print "SCC':";
adamc@454 197 IS.app (fn i => (print " ";
adamc@454 198 print (Int.toString i))) nodes;
adamc@454 199 print "\n")) sccs*)
adamc@454 200
adamc@454 201 fun isNonrec nodes =
adamc@454 202 case IS.find (fn _ => true) nodes of
adamc@454 203 NONE => NONE
adamc@454 204 | SOME node =>
adamc@454 205 let
adamc@454 206 val nodes = IS.delete (nodes, node)
adamc@454 207 val reachableHere = valOf (IM.find (reachable, node))
adamc@454 208 in
adamc@454 209 if IS.isEmpty nodes then
adamc@454 210 if IS.member (reachableHere, node) then
adamc@454 211 NONE
adamc@454 212 else
adamc@454 213 SOME node
adamc@454 214 else
adamc@454 215 NONE
adamc@454 216 end
adamc@454 217
adamc@454 218 val ds = map (fn nodes =>
adamc@454 219 case isNonrec nodes of
adamc@454 220 SOME node =>
adamc@454 221 let
adamc@454 222 val vi = valOf (List.find (fn (_, n, _, _, _) => n = node) vis)
adamc@454 223 in
adamc@454 224 (DVal vi, loc)
adamc@454 225 end
adamc@454 226 | NONE =>
adamc@454 227 (DValRec (List.filter (fn (_, n, _, _, _) => IS.member (nodes, n)) vis), loc))
adamc@454 228 sccs
adamc@454 229 in
adamc@454 230 ds
adamc@454 231 end
adamc@454 232 | _ => [dAll]
adamc@454 233 in
adamc@454 234 ListUtil.mapConcat decl file
adamc@454 235 end
adamc@454 236
adamc@454 237 end