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