[MLton-devel] cvs commit: phantom types and directed graphs

Stephen Weeks MLton@mlton.org
Tue, 11 Feb 2003 21:11:33 -0800


sweeks      03/02/11 21:11:30

  Modified:    lib/mlton/basic directed-graph.sig directed-graph.sml
               mlprof   main.sml
               mlton/backend limit-check.fun rssa.fun signal-check.fun
               mlton/codegen/x86-codegen x86-loop-info.fun
               mlton/ssa contify.fun inline.fun multi.fun ssa-tree.fun
                        ssa-tree.sig
               mlton/xml scc-funs.fun simplify-types.fun
  Log:
  Added phantom types to directed graphs to help in catching errors that
  confuse different graphs.
  
  As hoped, the implementation of graphs didn't change much.  The trick
  of adding the wrapper declarations, like "type 'a t = t", to the end
  of the module worked well.  The only difficulty was with datatypes,
  which cannot be reparameterized in a similar manner.  In one case
  (idomRes), I went ahead and added the phantom type variable to the
  original declaration.  In the other case (LoopForest.t), I hid the
  fact that it was a datatype.
  
  Adding the phantom type variable might cause the monomorphiser to
  create unnecessary duplicates.  But with a little bit of smarts it
  should be able to notice that the type variable is unused and hence
  ignore it.

Revision  Changes    Path
1.24      +75 -65    mlton/lib/mlton/basic/directed-graph.sig

Index: directed-graph.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/directed-graph.sig,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- directed-graph.sig	11 Feb 2003 02:20:56 -0000	1.23
+++ directed-graph.sig	12 Feb 2003 05:11:22 -0000	1.24
@@ -10,57 +10,61 @@
    sig
       structure Node: 
 	 sig
-	    type edge
-	    type t
+	    type 'a edge
+	    type 'a t
 
-	    val equals: t * t -> bool
-	    val hasEdge: {from: t, to: t} -> bool
-	    val layout: t -> Layout.t
-	    val plist: t -> PropertyList.t
-	    val successors: t -> edge list
+	    val equals: 'a t * 'a t -> bool
+	    val hasEdge: {from: 'a t, to: 'a t} -> bool
+	    val layout: 'a t -> Layout.t
+	    val plist: 'a t -> PropertyList.t
+	    val successors: 'a t -> 'a edge list
 	 end
       structure Edge:
 	 sig
-	    type t
+	    type 'a t
 
-	    val equals: t * t -> bool
-	    val plist: t -> PropertyList.t
-	    val to: t -> Node.t
+	    val equals: 'a t * 'a t -> bool
+	    val plist: 'a t -> PropertyList.t
+	    val to: 'a t -> 'a Node.t
 	 end
       sharing type Node.edge = Edge.t
 
       (* depth first search *)
       structure DfsParam:
 	 sig
-	    type ('a, 'b, 'c, 'd) t =
-	       'a
-	       * (Node.t * 'a
-		  -> ('b
-		      * (Node.t * 'b -> ('c
-					 * (Edge.t * 'c -> 'c)
-					 * (Edge.t * 'c -> 'b * ('d -> 'c))
-					 * ('c -> 'd)))
-		      * ('d -> 'a)))
-	    type 'a u = ('a, 'a, 'a, 'a) t
+	    type ('a, 'b, 'c, 'd, 'e) t =
+	       'b
+	       * ('a Node.t * 'b
+		  -> ('c
+		      * ('a Node.t * 'c -> ('d
+					    * ('a Edge.t * 'd -> 'd)
+					    * ('a Edge.t * 'd -> 'c * ('e -> 'd))
+					    * ('d -> 'e)))
+		      * ('e -> 'b)))
+	    type ('a, 'b) u = ('a, 'b, 'b, 'b, 'b) t
 
 	    val discoverFinishTimes:
-	       unit -> (int u * {discover: Node.t -> int,
-				 finish: Node.t -> int,
-				 destroy: unit -> unit})
-	    val finishNode: (Node.t -> unit) -> unit u
-	    val startNode: (Node.t -> unit) -> unit u
+	       unit -> (('a, int) u * {discover: 'a Node.t -> int,
+				       finish: 'a Node.t -> int,
+				       destroy: unit -> unit})
+	    val finishNode: ('a Node.t -> unit) -> ('a, unit) u
+	    val startNode: ('a Node.t -> unit) -> ('a, unit) u
 	 end
 
       (* the main graph type *)
-      type t
+      type 'a t
+      type 'a u
 
-      val addEdge: t * {from: Node.t, to: Node.t} -> Edge.t
-      val dfs: t * ('a, 'b, 'c, 'd) DfsParam.t -> 'a
-      val dfsNodes: t * Node.t list * ('a, 'b, 'c, 'd) DfsParam.t -> 'a
-      val dfsTree: t * {root: Node.t, nodeValue: Node.t -> 'a} -> 'a Tree.t
+      val addEdge: 'a t * {from: 'a Node.t, to: 'a Node.t} -> 'a Edge.t
+      val coerce: 'a t -> unit t * {edge: 'a Edge.t -> unit Edge.t,
+				    node: 'a Node.t -> unit Node.t}
+      val dfs: 'a t * ('a, 'b, 'c, 'd, 'e) DfsParam.t -> 'b
+      val dfsNodes: 'a t * 'a Node.t list * ('a, 'b, 'c, 'd, 'e) DfsParam.t -> 'b
+      val dfsTree: 'a t * {root: 'a Node.t,
+			   nodeValue: 'a Node.t -> 'b} -> 'b Tree.t
       val display:
-	 {graph: t,
-	  layoutNode: Node.t -> Layout.t,
+	 {graph: 'a t,
+	  layoutNode: 'a Node.t -> Layout.t,
 	  display: Layout.t -> unit} -> unit
       (* dominators (graph, {root})
        * Returns the immediate dominator relation for the subgraph of graph
@@ -69,42 +73,46 @@
        *  idom n = Idom n'        where n' is the immediate dominator of n
        *  idom n = Unreachable    if n is not reachable from root
        *)
-      datatype idomRes =
-	 Idom of Node.t
+      datatype 'a idomRes =
+	 Idom of 'a Node.t
        | Root
        | Unreachable
-      val dominators: t * {root: Node.t} -> {idom: Node.t -> idomRes}
-      val dominatorTree: t * {root: Node.t, nodeValue: Node.t -> 'a} -> 'a Tree.t
-      val foreachDescendent: t * Node.t * (Node.t -> unit) -> unit
-      val foldNodes: t * 'a * (Node.t * 'a -> 'a) -> 'a
-      val foreachEdge: t * (Node.t * Edge.t -> unit) -> unit
-      val foreachNode: t * (Node.t -> unit) -> unit
+      val dominators: 'a t * {root: 'a Node.t} -> {idom: 'a Node.t -> 'a idomRes}
+      val dominatorTree: 'a t * {root: 'a Node.t,
+				 nodeValue: 'a Node.t -> 'b} -> 'b Tree.t
+      val foreachDescendent: 'a t * 'a Node.t * ('a Node.t -> unit) -> unit
+      val foldNodes: 'a t * 'b * ('a Node.t * 'b -> 'b) -> 'b
+      val foreachEdge: 'a t * ('a Node.t * 'a Edge.t -> unit) -> unit
+      val foreachNode: 'a t * ('a Node.t -> unit) -> unit
       (* ignoreNodes (g, f) builds a graph g' that looks like g, except that g'
        * does not contain nodes n such that f n, and that for every path in g
        * of the form n0 -> n1 -> ... -> nm, where n0 and nm are not ignored and
        * n1, ..., n_m-1 are ignored, there is an edge in g'.
        *)
       val ignoreNodes:
-	 t * (Node.t -> bool) -> t * {destroy: unit -> unit,
-				      newNode: Node.t -> Node.t}
+	 'a t * ('a Node.t -> bool)
+	 -> 'a u t * {destroy: unit -> unit,
+		      newNode: 'a Node.t -> 'a u Node.t}
       val layoutDot:
-	 t * ({nodeName: Node.t -> string}
-	      -> {edgeOptions: Edge.t -> Dot.EdgeOption.t list,
-		  nodeOptions: Node.t -> Dot.NodeOption.t list,
-		  options: Dot.GraphOption.t list,
-		  title: string})
+	 'a t * ({nodeName: 'a Node.t -> string}
+		 -> {edgeOptions: 'a Edge.t -> Dot.EdgeOption.t list,
+		     nodeOptions: 'a Node.t -> Dot.NodeOption.t list,
+		     options: Dot.GraphOption.t list,
+		     title: string})
 	 -> Layout.t
       structure LoopForest: 
 	 sig 
-	   datatype t = T of {loops: {headers: Node.t vector,
-				      child: t} vector,
-			      notInLoop: Node.t vector}
+	    type 'a t
+
+	    val dest: 'a t -> {loops: {headers: 'a Node.t vector,
+				       child: 'a t} vector,
+			       notInLoop: 'a Node.t vector}
 	 end
-      val loopForestSteensgaard: t * {root:Node.t} -> LoopForest.t
-      val new: unit -> t
-      val newNode: t -> Node.t
-      val nodes: t -> Node.t list
-      val numNodes: t -> int
+      val loopForestSteensgaard: 'a t * {root: 'a Node.t} -> 'a LoopForest.t
+      val new: unit -> 'a t
+      val newNode: 'a t -> 'a Node.t
+      val nodes: 'a t -> 'a Node.t list
+      val numNodes: 'a t -> int
       (* quotient (g, v)
        * Pre: v should be an equivalence relation on the nodes of g.  That is,
        *   each node in g should appear exactly once in some vector in v.
@@ -112,23 +120,25 @@
        * between classes iff there is an edge between nodes in the classes.
        *)
       val quotient:
-	 t * (Node.t vector vector)
-	 -> t * {destroy: unit -> unit,
-		 newNode: Node.t -> Node.t}
+	 'a t * ('a Node.t vector vector)
+	 -> 'a u t * {destroy: unit -> unit,
+		      newNode: 'a Node.t -> 'a u Node.t}
       (* Strongly-connected components.
        * Each component is given as a list of nodes.
        * The components are returned topologically sorted.
        *)
-      val stronglyConnectedComponents: t -> Node.t list list
-      val subgraph: t * (Node.t -> bool) -> t * {destroy: unit -> unit,
-						 newNode: Node.t -> Node.t}
+      val stronglyConnectedComponents: 'a t -> 'a Node.t list list
+      val subgraph:
+	 'a t * ('a Node.t -> bool)
+	 -> 'a u t * {destroy: unit -> unit,
+		      newNode: 'a Node.t -> 'a u Node.t}
       (* topologicalSort g returns NONE if there is a cycle in g.
        * Otherwise, returns then nodes in g in a list such that if there is a
        * path in g from n to n', then n appears before n' in the list.
        *)
-      val topologicalSort: t -> Node.t list option
-      val transpose: t -> t * {destroy: unit -> unit,
-			       newNode: Node.t -> Node.t}
+      val topologicalSort: 'a t -> 'a Node.t list option
+      val transpose: 'a t -> 'a u t * {destroy: unit -> unit,
+				       newNode: 'a Node.t -> 'a u Node.t}
    end
 
 



1.32      +57 -31    mlton/lib/mlton/basic/directed-graph.sml

Index: directed-graph.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/directed-graph.sml,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- directed-graph.sml	11 Feb 2003 02:20:56 -0000	1.31
+++ directed-graph.sml	12 Feb 2003 05:11:22 -0000	1.32
@@ -4,7 +4,7 @@
  * MLton is released under the GNU General Public License (GPL).
  * Please see the file MLton-LICENSE for license information.
  *)
-structure DirectedGraph: DIRECTED_GRAPH = 
+structure DirectedGraph:> DIRECTED_GRAPH = 
 struct
 
 structure Types =
@@ -70,6 +70,9 @@
 
 datatype t = T of {nodes: Node.t list ref}
 
+fun coerce g = (g, {edge = fn e => e,
+		    node = fn n => n})
+   
 fun nodes (T {nodes, ...}) = !nodes
 
 fun foldNodes (g, a, f) = List.fold (nodes g, a, f)
@@ -130,20 +133,20 @@
 
 structure DfsParam =
    struct
-      type ('a, 'b, 'c, 'd) t =
-	 'a
-	 * (Node.t * 'a -> ('b
-			    * (Node.t * 'b -> ('c
-					       * (Edge.t * 'c -> 'c)
-					       * (Edge.t * 'c -> 'b * ('d -> 'c))
-					       * ('c -> 'd)))
-			    * ('d -> 'a)))
-
-      type 'a u = ('a, 'a, 'a, 'a) t
+      type ('a, 'b, 'c, 'd, 'e) t =
+	 'b
+	 * (Node.t * 'b
+	    -> ('c
+		* (Node.t * 'c -> ('d
+				   * (Edge.t * 'd -> 'd)
+				   * (Edge.t * 'd -> 'c * ('e -> 'd))
+				   * ('d -> 'e)))
+		* ('e -> 'b)))
+      type ('a, 'b) u = ('a, 'b, 'b, 'b, 'b) t
 
       fun startFinishNode (a: 'a,
 			   start: Node.t * 'a -> 'a,
-			   finish: Node.t * 'a -> 'a): ('a, 'a, 'a, 'a) t =
+			   finish: Node.t * 'a -> 'a): ('b, 'a) u =
 	 (a,
 	  fn (_, a) => (a,
 			fn (n, a) =>
@@ -182,55 +185,55 @@
 	 
 fun dfsNodes (g: t,
 	      ns: Node.t list,
-	      (a, f): ('a, 'b, 'c, 'd) DfsParam.t) =
+	      (b, f): ('a, 'b, 'c, 'd, 'e) DfsParam.t) =
    let
       type info = {hasBeenVisited: bool ref}
       val {get = nodeInfo: Node.t -> info, destroy, ...} =
 	 Property.destGetSet (Node.plist,
 			      Property.initFun (fn _ =>
 						{hasBeenVisited = ref false}))
-      val a =
+      val b =
 	 List.fold
-	 (ns, a, fn (n, a) =>
+	 (ns, b, fn (n, b) =>
 	  let
 	     val info as {hasBeenVisited} = nodeInfo n
 	  in
 	     if !hasBeenVisited
-		then a
+		then b
 	     else
 		let
-		   val (b, startNode, finishTree) = f (n, a)
-		   fun visit (n: Node.t, {hasBeenVisited}: info, b: 'b): 'd =
+		   val (c, startNode, finishTree) = f (n, b)
+		   fun visit (n: Node.t, {hasBeenVisited}: info, c: 'c): 'e =
 		      let
 			 val _ = hasBeenVisited := true
-			 val (c, nonTreeEdge, treeEdge, finishNode) =
-			    startNode (n, b)
+			 val (d, nonTreeEdge, treeEdge, finishNode) =
+			    startNode (n, c)
 		      in
 			 finishNode
 			 (List.fold
-			  (Node.successors n, c,
-			   fn (e, c) =>
+			  (Node.successors n, d,
+			   fn (e, d) =>
 			   let
 			      val n = Edge.to e
 			      val info as {hasBeenVisited} = nodeInfo n
 			   in
 			      if !hasBeenVisited
-				 then nonTreeEdge (e, c)
+				 then nonTreeEdge (e, d)
 			      else
 				 let
-				    val (b, finish) = treeEdge (e, c)
+				    val (c, finish) = treeEdge (e, d)
 				 in
-				    finish (visit (n, info, b))
+				    finish (visit (n, info, c))
 				 end
 			   end))
 		      end
 		in
-		   finishTree (visit (n, info, b))
+		   finishTree (visit (n, info, c))
 		end
 	  end)
       val _ = destroy ()
    in
-      a
+      b
    end
 
 fun dfs (g, z) = dfsNodes (g, nodes g, z)
@@ -325,7 +328,7 @@
     in true
     end)
 
-datatype idomRes =
+datatype 'a idomRes =
    Idom of Node.t
   | Root
   | Unreachable
@@ -615,9 +618,6 @@
 				 child: t} vector,
 			 notInLoop: Node.t vector}
 
-      val empty = T {loops = Vector.new0 (),
-		     notInLoop = Vector.new0 ()}
-
       fun single n = T {loops = Vector.new0 (),
 			notInLoop = Vector.new1 n}
 
@@ -1117,5 +1117,31 @@
       end
    end
 
+structure Node =
+   struct
+      open Node
+
+      type 'a t = t
+      type 'a edge = edge
+   end
+
+structure Edge =
+   struct
+      open Edge
+
+      type 'a t = t
+   end
+
+type 'a t = t
+type 'a u = unit
+
+structure LoopForest =
+   struct
+      open LoopForest
+      type 'a t = t
+
+      fun dest (T r) = r
+   end
+   
 end
 



1.45      +37 -28    mlton/mlprof/main.sml

Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/main.sml,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -r1.44 -r1.45
--- main.sml	11 Feb 2003 02:24:32 -0000	1.44
+++ main.sml	12 Feb 2003 05:11:24 -0000	1.45
@@ -68,10 +68,10 @@
 
 structure AFile =
    struct
-      datatype t = T of {callGraph: Graph.t,
+      datatype t = T of {callGraph: unit Graph.t,
 			 magic: word,
 			 name: string,
-			 sources: {node: Node.t,
+			 sources: {node: unit Node.t,
 				   source: Source.t} option vector}
 
       fun layout (T {magic, name, sources, ...}) =
@@ -137,7 +137,7 @@
 		      "" => ()
 		    | _ => Error.bug "expected end of file"
 		val rc = Regexp.compileNFA (!ignore)
-		val {get = shouldIgnore: Node.t -> bool, ...} =
+		val {get = shouldIgnore: unit Node.t -> bool, ...} =
 		   Property.get
 		   (Node.plist,
 		    Property.initFun
@@ -148,11 +148,12 @@
 		      (#source (Vector.sub (sources, nodeIndex n))))))
 		val (graph, {newNode, ...}) =
 		   Graph.ignoreNodes (graph, shouldIgnore)
+		val (graph, {node = coerceNode, ...}) = Graph.coerce graph
 		val sources =
 		   Vector.map (sources, fn {node, source} =>
 			       if shouldIgnore node
 				  then NONE
-			       else SOME {node = newNode node,
+			       else SOME {node = coerceNode (newNode node),
 					  source = source})
 	     in
 		T {callGraph = graph,
@@ -459,10 +460,10 @@
 		  parse s
 	       end
 
-      fun nodes (p: t, g: Graph.t,
-		 atomic: Node.t * Atomic.t -> bool): Node.t vector =
+      fun nodes (p: t, g: 'a Graph.t,
+		 atomic: 'a Node.t * Atomic.t -> bool): 'a Node.t vector =
 	 let
-	    val {get = nodeIndex: Node.t -> int,
+	    val {get = nodeIndex: 'a Node.t -> int,
 		 set = setNodeIndex, ...} =
 	       Property.getSet (Node.plist,
 				Property.initRaise ("index", Node.layout))
@@ -473,14 +474,18 @@
 	       Promise.lazy
 	       (fn () =>
 		let
+		   val {get = nodeIndex': 'a Graph.u Node.t -> int,
+			set = setNodeIndex, ...} =
+		      Property.getSet (Node.plist,
+				       Property.initRaise ("index", Node.layout))
 		   val (transpose, {newNode, ...}) = Graph.transpose g
 		   val _ =
 		      Graph.foreachNode
 		      (g, fn n => setNodeIndex (newNode n, nodeIndex n))
 		in
-		   (transpose, newNode)
+		   (transpose, newNode, nodeIndex')
 		end)
-	    fun vectorToNodes (v: bool vector): Node.t vector =
+	    fun vectorToNodes (v: bool vector): 'a Node.t vector =
 	       Vector.keepAllMapi
 	       (v, fn (i, b) =>
 		if b
@@ -490,6 +495,23 @@
 				    Vector.tabulate (numNodes, fn _ => true))
 	    val none = Promise.lazy (fn () =>
 				     Vector.tabulate (numNodes, fn _ => false))
+	    fun path (v: bool vector,
+		      (g: 'b Graph.t,
+		       getNode: 'a Node.t -> 'b Node.t,
+		       nodeIndex: 'b Node.t -> int)): bool vector =
+	       let
+		  val roots = vectorToNodes v
+		  val a = Array.array (numNodes, false)
+		  val _ =
+		     Graph.dfsNodes
+		     (g,
+		      Vector.toListMap (roots, getNode),
+		      Graph.DfsParam.startNode (fn n =>
+						Array.update
+						(a, nodeIndex n, true)))
+	       in
+		  Vector.fromArray a
+	       end
 	    fun loop (p: t): bool vector =
 	       case p of
 		  All => all ()
@@ -503,8 +525,8 @@
 		     Vector.fold (ps, none (), fn (p, v) =>
 				  Vector.map2 (v, loop p, fn (b, b') =>
 					       b orelse b'))
-		| PathFrom p => path (p, (g, fn n => n))
-		| PathTo p => path (p, transpose ())
+		| PathFrom p => path (loop p, (g, fn n => n, nodeIndex))
+		| PathTo p => path (loop p, transpose ())
 		| Pred p =>
 		     let
 			val ns = vectorToNodes (loop p)
@@ -533,20 +555,6 @@
 		     in
 			Vector.fromArray a
 		     end
-	    and path (p: t, (g: Graph.t, getNode)): bool vector =
-	       let
-		  val roots = vectorToNodes (loop p)
-		  val a = Array.array (numNodes, false)
-		  val _ =
-		     Graph.dfsNodes
-		     (g,
-		      Vector.toListMap (roots, getNode),
-		      Graph.DfsParam.startNode (fn n =>
-						Array.update
-						(a, nodeIndex n, true)))
-	       in
-		  Vector.fromArray a
-	       end
 	    val v = loop p
 	 in
 	    vectorToNodes v
@@ -558,9 +566,10 @@
 fun display (AFile.T {callGraph, name = aname, sources, ...},
 	     ProfFile.T {counts, kind, total, totalGC, ...}): unit =
    let
-      val {get = nodeInfo: Node.t -> {keep: bool ref,
-				      mayKeep: (Atomic.t -> bool) ref,
-				      options: Dot.NodeOption.t list ref}, ...} =
+      val {get = nodeInfo: (unit Node.t
+			    -> {keep: bool ref,
+				mayKeep: (Atomic.t -> bool) ref,
+				options: Dot.NodeOption.t list ref}), ...} =
 	 Property.get (Node.plist,
 		       Property.initFun (fn _ => {keep = ref false,
 						  mayKeep = ref (fn _ => false),



1.36      +2 -1      mlton/mlton/backend/limit-check.fun

Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -r1.35 -r1.36
--- limit-check.fun	23 Jan 2003 03:34:36 -0000	1.35
+++ limit-check.fun	12 Feb 2003 05:11:24 -0000	1.36
@@ -561,8 +561,9 @@
 	    val classes = Array.array (n, ~1)
 	    fun indexClass i = Array.sub (classes, i)
 	    val c = Counter.new 0
-	    fun setClass (Forest.T {loops, notInLoop}) =
+	    fun setClass (f: unit Forest.t) =
 	       let
+		  val {loops, notInLoop} = Forest.dest f
 		  val class = Counter.next c
 		  val _ =
 		     Vector.foreach



1.30      +1 -1      mlton/mlton/backend/rssa.fun

Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- rssa.fun	23 Jan 2003 03:34:36 -0000	1.29
+++ rssa.fun	12 Feb 2003 05:11:25 -0000	1.30
@@ -610,7 +610,7 @@
 	    val {get = labelNode, ...} =
 	       Property.get
 	       (Label.plist, Property.initFun (fn _ => newNode ()))
-	    val {get = nodeInfo: Node.t -> {block: Block.t},
+	    val {get = nodeInfo: unit Node.t -> {block: Block.t},
 		 set = setNodeInfo, ...} =
 	       Property.getSetOnce
 	       (Node.plist, Property.initRaise ("info", Node.layout))



1.16      +23 -17    mlton/mlton/backend/signal-check.fun

Index: signal-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/signal-check.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- signal-check.fun	20 Dec 2002 20:20:36 -0000	1.15
+++ signal-check.fun	12 Feb 2003 05:11:27 -0000	1.16
@@ -33,7 +33,7 @@
 			  setLabelIndex (label, i))
       val g = Graph.new ()
       val n = Vector.length blocks
-      val {get = nodeIndex: Node.t -> int, set = setNodeIndex, ...} =
+      val {get = nodeIndex: unit Node.t -> int, set = setNodeIndex, ...} =
 	 Property.getSetOnce
 	 (Node.plist, Property.initRaise ("index", Node.layout))
       val nodes =
@@ -132,22 +132,28 @@
       (* Create extra blocks with signal checks for all blocks that are
        * loop headers.
        *)
-      fun loop (Forest.T {loops, ...}) =
-	 Vector.foreach
-	 (loops, fn {headers, child} =>
-	  let
-	     val _ = Vector.foreach (headers, fn n =>
-				     let
-					val i = nodeIndex n
-					val _ = Array.update (isHeader, i, true)
-				     in
-					addSignalCheck (Vector.sub (blocks, i))
-				     end)
-	     val _ = loop child
-	  in
-	     ()
-	  end)
-      (* Add a signal check at the function entry. *)
+      fun loop (f: unit Forest.t) =
+	 let
+	    val {loops, ...} = Forest.dest f
+	 in
+	    Vector.foreach
+	    (loops, fn {headers, child} =>
+	     let
+		val _ =
+		   Vector.foreach
+		   (headers, fn n =>
+		    let
+		       val i = nodeIndex n
+		       val _ = Array.update (isHeader, i, true)
+		    in
+		       addSignalCheck (Vector.sub (blocks, i))
+		    end)
+		val _ = loop child
+	     in
+		()
+	     end)
+	 end
+	    (* Add a signal check at the function entry. *)
       val newStart =
 	 case Vector.peek (blocks, fn Block.T {label, ...} =>
 			   Label.equals (label, start)) of



1.13      +4 -3      mlton/mlton/codegen/x86-codegen/x86-loop-info.fun

Index: x86-loop-info.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-loop-info.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- x86-loop-info.fun	11 Jul 2002 02:16:49 -0000	1.12
+++ x86-loop-info.fun	12 Feb 2003 05:11:27 -0000	1.13
@@ -27,13 +27,13 @@
     = let
 	val G = Graph.new ()
 
-	val nodeInfo as {get = getNodeInfo : Node.t -> Label.t,
+	val nodeInfo as {get = getNodeInfo : unit Node.t -> Label.t,
 			 set = setNodeInfo, ...}
 	  = Property.getSetOnce
 	    (Node.plist,
 	     Property.initRaise ("x86LoopInfo:getNodeInfo", Node.layout))
 
-	val info as {get = getInfo : Label.t -> Node.t,
+	val info as {get = getInfo : Label.t -> unit Node.t,
 		     destroy = destInfo}
 	  = Property.destGet
 	    (Label.plist,
@@ -120,10 +120,11 @@
 
 	val lf = Graph.loopForestSteensgaard (G, {root = root})
 	  
-	fun doit (LoopForest.T {loops, notInLoop}, 
+	fun doit (f: unit LoopForest.t,
 		  headers,
 		  path)
 	  = let
+	      val {loops, notInLoop} = LoopForest.dest f
 	      val notInLoop = Vector.toListMap (notInLoop, getNodeInfo)
 	      val path' = List.rev path
 	    in



1.13      +3 -3      mlton/mlton/ssa/contify.fun

Index: contify.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/contify.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- contify.fun	19 Dec 2002 23:43:35 -0000	1.12
+++ contify.fun	12 Feb 2003 05:11:27 -0000	1.13
@@ -74,7 +74,7 @@
 
 structure ContData =
   struct
-    datatype t = T of {node: DirectedGraph.Node.t option ref,
+    datatype t = T of {node: unit DirectedGraph.Node.t option ref,
 		       rootEdge: bool ref,
 		       prefixes: Func.t list ref}
       
@@ -99,7 +99,7 @@
 
 structure FuncData =
   struct
-    datatype t = T of {node: DirectedGraph.Node.t option ref,
+    datatype t = T of {node: unit DirectedGraph.Node.t option ref,
 		       reach: bool ref,
 		       callers: {nontail: (Func.t * Cont.t) list ref,
 				 tail: Func.t list ref},
@@ -170,7 +170,7 @@
 		then ()
 		else addEdge edge
 
-	  val {get = getNodeInfo : Node.t -> t, 
+	  val {get = getNodeInfo : unit Node.t -> t, 
 	       set = setNodeInfo, ...}
 	    = Property.getSetOnce
 	      (Node.plist,



1.14      +4 -4      mlton/mlton/ssa/inline.fun

Index: inline.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/inline.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- inline.fun	11 Jan 2003 00:34:40 -0000	1.13
+++ inline.fun	12 Feb 2003 05:11:28 -0000	1.14
@@ -171,13 +171,13 @@
 		  {size: int option}) =
    let
       val {get = funcInfo: Func.t -> {isBig: bool,
-				      node: Node.t,
+				      node: unit Node.t,
 				      numCalls: int ref,
 				      shouldInline: bool ref},
 	   set = setFuncInfo, ...} =
 	 Property.getSetOnce
 	 (Func.plist, Property.initRaise ("funcInfo", Func.layout))
-      val {get = nodeFunc: Node.t -> Func.t,
+      val {get = nodeFunc: unit Node.t -> Func.t,
 	   set = setNodeFunc, ...} = 
 	 Property.getSetOnce 
 	 (Node.plist, Property.initRaise ("nodeFunc", Node.layout))
@@ -284,7 +284,7 @@
    let
       type info = {doesCallSelf: bool ref,
 		   function: Function.t,
-		   node: Node.t,
+		   node: unit Node.t,
 		   numCalls: int ref,
 		   shouldInline: bool ref,
 		   size: int ref}
@@ -292,7 +292,7 @@
 	   set = setFuncInfo, ...} =
 	 Property.getSetOnce
 	 (Func.plist, Property.initRaise ("funcInfo", Func.layout))
-      val {get = nodeFunc: Node.t -> Func.t,
+      val {get = nodeFunc: unit Node.t -> Func.t,
 	   set = setNodeFunc, ...} = 
 	 Property.getSetOnce 
 	 (Node.plist, Property.initRaise ("nodeFunc", Node.layout))



1.4       +2 -2      mlton/mlton/ssa/multi.fun

Index: multi.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/multi.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- multi.fun	21 Aug 2002 13:10:35 -0000	1.3
+++ multi.fun	12 Feb 2003 05:11:28 -0000	1.4
@@ -163,14 +163,14 @@
 	= Program.hasPrim (p, fn p => Prim.name p = Prim.Name.Thread_switchTo)
 
       (* funcNode *)
-      val {get = funcNode: Func.t -> Node.t,
+      val {get = funcNode: Func.t -> unit Node.t,
 	   set = setFuncNode, 
 	   rem = remFuncNode, ...}
 	= Property.getSetOnce
 	  (Func.plist, Property.initRaise ("Multi.funcNode", Func.layout))
 
       (* nodeFunction *)
-      val {get = nodeFunction: Node.t -> Function.t,
+      val {get = nodeFunction: unit Node.t -> Function.t,
 	   set = setNodeFunction, ...}
 	= Property.getSetOnce 
 	  (Node.plist, Property.initRaise ("Multi.nodeFunc", Node.layout))



1.56      +5 -5      mlton/mlton/ssa/ssa-tree.fun

Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -r1.55 -r1.56
--- ssa-tree.fun	13 Jan 2003 01:14:27 -0000	1.55
+++ ssa-tree.fun	12 Feb 2003 05:11:28 -0000	1.56
@@ -860,9 +860,9 @@
 	 T of {controlFlow:
 	       {dfsTree: unit -> Block.t Tree.t,
 		dominatorTree: unit -> Block.t Tree.t,
-		graph: DirectedGraph.t,
-		labelNode: Label.t -> DirectedGraph.Node.t,
-		nodeBlock: DirectedGraph.Node.t -> Block.t} CPromise.t,
+		graph: unit DirectedGraph.t,
+		labelNode: Label.t -> unit DirectedGraph.Node.t,
+		nodeBlock: unit DirectedGraph.Node.t -> Block.t} CPromise.t,
 	       dest: dest}
 
       local
@@ -952,7 +952,7 @@
 	       val {get = labelNode, ...} =
 		  Property.get
 		  (Label.plist, Property.initFun (fn _ => newNode ()))
-	       val {get = nodeInfo: Node.t -> {block: Block.t},
+	       val {get = nodeInfo: unit Node.t -> {block: Block.t},
 		    set = setNodeInfo, ...} =
 		  Property.getSetOnce
 		  (Node.plist, Property.initRaise ("info", Node.layout))
@@ -1043,7 +1043,7 @@
 	       val graph = Graph.new ()
 	       val {get = nodeOptions, ...} =
 		  Property.get (Node.plist, Property.initFun (fn _ => ref []))
-	       fun setNodeText (n: Node.t, l): unit =
+	       fun setNodeText (n: unit Node.t, l): unit =
 		  List.push (nodeOptions n, NodeOption.Label l)
 	       fun newNode () = Graph.newNode graph
 	       val {destroy, get = labelNode} =



1.45      +4 -3      mlton/mlton/ssa/ssa-tree.sig

Index: ssa-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.sig,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -r1.44 -r1.45
--- ssa-tree.sig	11 Jan 2003 00:34:40 -0000	1.44
+++ ssa-tree.sig	12 Feb 2003 05:11:28 -0000	1.45
@@ -217,9 +217,10 @@
 	     * in the function, but not the function name's plist.
 	     *)
 	    val clear: t -> unit
-	    val controlFlow: t -> {graph: DirectedGraph.t,
-				   labelNode: Label.t -> DirectedGraph.Node.t,
-				   nodeBlock: DirectedGraph.Node.t -> Block.t}
+	    val controlFlow:
+	       t -> {graph: unit DirectedGraph.t,
+		     labelNode: Label.t -> unit DirectedGraph.Node.t,
+		     nodeBlock: unit DirectedGraph.Node.t -> Block.t}
 	    val dest: t -> {args: (Var.t * Type.t) vector,
 			    blocks: Block.t vector,
 			    name: Func.t,



1.9       +1 -1      mlton/mlton/xml/scc-funs.fun

Index: scc-funs.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/scc-funs.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- scc-funs.fun	10 Jan 2003 20:09:04 -0000	1.8
+++ scc-funs.fun	12 Feb 2003 05:11:29 -0000	1.9
@@ -21,7 +21,7 @@
        * if they appear in it's body.
        *)
       val {get = funInfo: Var.t -> {
-				    node: Node.t,
+				    node: unit Node.t,
 				    visit: (unit -> unit) ref
 				    } option,
 	   set = setFunInfo, ...} =



1.5       +1 -1      mlton/mlton/xml/simplify-types.fun

Index: simplify-types.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/simplify-types.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- simplify-types.fun	10 Apr 2002 07:02:21 -0000	1.4
+++ simplify-types.fun	12 Feb 2003 05:11:29 -0000	1.5
@@ -16,7 +16,7 @@
 fun simplifyTypes (p as Program.T {datatypes, body, ...}) =
    let
       val g = Graph.new ()
-      val {get = tyconInfo: Tycon.t -> {node: Node.t,
+      val {get = tyconInfo: Tycon.t -> {node: unit Node.t,
 					isOneVariantArrow: bool ref,
 					cons: {con: Con.t,
 					       arg: Type.t option





-------------------------------------------------------
This SF.NET email is sponsored by:
SourceForge Enterprise Edition + IBM + LinuxWorld = Something 2 See!
http://www.vasoftware.com
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel