[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