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