adamc@131: (* Copyright (c) 2008, Adam Chlipala adamc@131: * All rights reserved. adamc@131: * adamc@131: * Redistribution and use in source and binary forms, with or without adamc@131: * modification, are permitted provided that the following conditions are met: adamc@131: * adamc@131: * - Redistributions of source code must retain the above copyright notice, adamc@131: * this list of conditions and the following disclaimer. adamc@131: * - Redistributions in binary form must reproduce the above copyright notice, adamc@131: * this list of conditions and the following disclaimer in the documentation adamc@131: * and/or other materials provided with the distribution. adamc@131: * - The names of contributors may not be used to endorse or promote products adamc@131: * derived from this software without specific prior written permission. adamc@131: * adamc@131: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@131: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@131: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@131: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@131: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@131: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@131: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@131: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@131: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@131: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@131: * POSSIBILITY OF SUCH DAMAGE. adamc@131: *) adamc@131: adamc@131: structure Untangle :> UNTANGLE = struct adamc@131: adamc@131: open Mono adamc@131: adamc@131: structure U = MonoUtil adamc@131: structure E = MonoEnv adamc@131: adamc@131: structure IS = IntBinarySet adamc@131: structure IM = IntBinaryMap adamc@131: adamc@131: fun typ (k, s) = s adamc@131: adamc@131: fun exp (e, s) = adamc@131: case e of adamc@131: ENamed n => IS.add (s, n) adamc@131: adamc@131: | _ => s adamc@131: adamc@131: fun untangle file = adamc@131: let adamc@131: fun decl (dAll as (d, loc)) = adamc@131: case d of adamc@131: DValRec vis => adamc@131: let adamc@131: val thisGroup = foldl (fn ((_, n, _, _, _), thisGroup) => adamc@131: IS.add (thisGroup, n)) IS.empty vis adamc@131: adamc@131: val used = foldl (fn ((_, n, _, e, _), used) => adamc@131: let adamc@131: val usedHere = U.Exp.fold {typ = typ, adamc@131: exp = exp} IS.empty e adamc@131: in adamc@131: IM.insert (used, n, IS.intersection (usedHere, thisGroup)) adamc@131: end) adamc@131: IM.empty vis adamc@131: adamc@131: fun p_graph reachable = adamc@131: IM.appi (fn (n, reachableHere) => adamc@131: (print (Int.toString n); adamc@131: print ":"; adamc@131: IS.app (fn n' => (print " "; adamc@131: print (Int.toString n'))) reachableHere; adamc@131: print "\n")) reachable adamc@131: adamc@131: (*val () = print "used:\n" adamc@131: val () = p_graph used*) adamc@131: adamc@131: fun expand reachable = adamc@131: let adamc@131: val changed = ref false adamc@131: adamc@131: val reachable = adamc@131: IM.mapi (fn (n, reachableHere) => adamc@131: IS.foldl (fn (n', reachableHere) => adamc@131: let adamc@131: val more = valOf (IM.find (reachable, n')) adamc@131: in adamc@131: if IS.isEmpty (IS.difference (more, reachableHere)) then adamc@131: reachableHere adamc@131: else adamc@131: (changed := true; adamc@131: IS.union (more, reachableHere)) adamc@131: end) adamc@131: reachableHere reachableHere) reachable adamc@131: in adamc@131: (reachable, !changed) adamc@131: end adamc@131: adamc@131: fun iterate reachable = adamc@131: let adamc@131: val (reachable, changed) = expand reachable adamc@131: in adamc@131: if changed then adamc@131: iterate reachable adamc@131: else adamc@131: reachable adamc@131: end adamc@131: adamc@131: val reachable = iterate used adamc@131: adamc@131: (*val () = print "reachable:\n" adamc@131: val () = p_graph reachable*) adamc@131: adamc@131: fun sccs (nodes, acc) = adamc@131: case IS.find (fn _ => true) nodes of adamc@131: NONE => acc adamc@131: | SOME rep => adamc@131: let adamc@131: val reachableHere = valOf (IM.find (reachable, rep)) adamc@131: adamc@131: val (nodes, scc) = IS.foldl (fn (node, (nodes, scc)) => adamc@131: if node = rep then adamc@131: (nodes, scc) adamc@131: else adamc@131: let adamc@131: val reachableThere = adamc@131: valOf (IM.find (reachable, node)) adamc@131: in adamc@131: if IS.member (reachableThere, rep) then adamc@131: (IS.delete (nodes, node), adamc@131: IS.add (scc, node)) adamc@131: else adamc@131: (nodes, scc) adamc@131: end) adamc@131: (IS.delete (nodes, rep), IS.singleton rep) reachableHere adamc@131: in adamc@131: sccs (nodes, scc :: acc) adamc@131: end adamc@131: adamc@132: val sccs = sccs (thisGroup, []) adamc@131: (*val () = app (fn nodes => (print "SCC:"; adamc@131: IS.app (fn i => (print " "; adamc@131: print (Int.toString i))) nodes; adamc@131: print "\n")) sccs*) adamc@131: adamc@132: fun depends nodes1 nodes2 = adamc@132: let adamc@132: val node1 = valOf (IS.find (fn _ => true) nodes1) adamc@132: val node2 = valOf (IS.find (fn _ => true) nodes2) adamc@132: val reachable1 = valOf (IM.find (reachable, node1)) adamc@132: in adamc@132: IS.member (reachable1, node2) adamc@132: end adamc@132: adamc@132: fun findReady (sccs, passed) = adamc@132: case sccs of adamc@132: [] => raise Fail "Untangle: Unable to topologically sort 'val rec'" adamc@132: | nodes :: sccs => adamc@132: if List.exists (depends nodes) passed adamc@132: orelse List.exists (depends nodes) sccs then adamc@132: findReady (sccs, nodes :: passed) adamc@132: else adamc@132: (nodes, List.revAppend (passed, sccs)) adamc@132: adamc@132: fun topo (sccs, acc) = adamc@132: case sccs of adamc@132: [] => rev acc adamc@132: | _ => adamc@132: let adamc@132: val (node, sccs) = findReady (sccs, []) adamc@132: in adamc@132: topo (sccs, node :: acc) adamc@132: end adamc@132: adamc@132: val sccs = topo (sccs, []) adamc@131: (*val () = app (fn nodes => (print "SCC':"; adamc@131: IS.app (fn i => (print " "; adamc@131: print (Int.toString i))) nodes; adamc@131: print "\n")) sccs*) adamc@131: adamc@131: fun isNonrec nodes = adamc@131: case IS.find (fn _ => true) nodes of adamc@131: NONE => NONE adamc@131: | SOME node => adamc@131: let adamc@131: val nodes = IS.delete (nodes, node) adamc@131: val reachableHere = valOf (IM.find (reachable, node)) adamc@131: in adamc@131: if IS.isEmpty nodes then adamc@131: if IS.member (reachableHere, node) then adamc@131: NONE adamc@131: else adamc@131: SOME node adamc@131: else adamc@131: NONE adamc@131: end adamc@131: adamc@131: val ds = map (fn nodes => adamc@131: case isNonrec nodes of adamc@131: SOME node => adamc@131: let adamc@131: val vi = valOf (List.find (fn (_, n, _, _, _) => n = node) vis) adamc@131: in adamc@131: (DVal vi, loc) adamc@131: end adamc@131: | NONE => adamc@131: (DValRec (List.filter (fn (_, n, _, _, _) => IS.member (nodes, n)) vis), loc)) adamc@131: sccs adamc@131: in adamc@131: ds adamc@131: end adamc@131: | _ => [dAll] adamc@131: in adamc@131: ListUtil.mapConcat decl file adamc@131: end adamc@131: adamc@131: end