[MLton-commit] r6731
Matthew Fluet
fluet at mlton.org
Tue Aug 19 15:11:57 PDT 2008
Tighten SsaTree.Type interface.
----------------------------------------------------------------------
U mlton/trunk/mlton/closure-convert/closure-convert.fun
U mlton/trunk/mlton/ssa/constant-propagation.fun
U mlton/trunk/mlton/ssa/poly-equal.fun
U mlton/trunk/mlton/ssa/poly-hash.fun
U mlton/trunk/mlton/ssa/simplify-types.fun
U mlton/trunk/mlton/ssa/ssa-tree.fun
U mlton/trunk/mlton/ssa/ssa-tree.sig
U mlton/trunk/mlton/ssa/type-check.fun
U mlton/trunk/mlton/ssa/useless.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/closure-convert/closure-convert.fun
===================================================================
--- mlton/trunk/mlton/closure-convert/closure-convert.fun 2008-08-19 22:11:50 UTC (rev 6730)
+++ mlton/trunk/mlton/closure-convert/closure-convert.fun 2008-08-19 22:11:55 UTC (rev 6731)
@@ -469,7 +469,7 @@
(Lambdas.toList ls, fn l =>
{lambda = Value.Lambda.dest l,
con = Con.newString "Env"})
- val ty = Type.con (tycon, Vector.new0 ())
+ val ty = Type.datatypee tycon
val info = {ty = ty, cons = cons}
val _ = r := SOME info
(* r must be set before the following, because calls to
Modified: mlton/trunk/mlton/ssa/constant-propagation.fun
===================================================================
--- mlton/trunk/mlton/ssa/constant-propagation.fun 2008-08-19 22:11:50 UTC (rev 6730)
+++ mlton/trunk/mlton/ssa/constant-propagation.fun 2008-08-19 22:11:55 UTC (rev 6731)
@@ -645,7 +645,7 @@
Vector.foreach
(datatypes, fn Datatype.T {tycon, cons} =>
let
- val result = Type.con (tycon, Vector.new0 ())
+ val result = Type.datatypee tycon
in
Vector.foreach
(cons, fn {con, args} =>
Modified: mlton/trunk/mlton/ssa/poly-equal.fun
===================================================================
--- mlton/trunk/mlton/ssa/poly-equal.fun 2008-08-19 22:11:50 UTC (rev 6730)
+++ mlton/trunk/mlton/ssa/poly-equal.fun 2008-08-19 22:11:55 UTC (rev 6731)
@@ -124,7 +124,7 @@
val name =
Func.newString (concat ["equal_", Tycon.originalName tycon])
val _ = setEqualFunc (tycon, SOME name)
- val ty = Type.con (tycon, Vector.new0 ())
+ val ty = Type.datatypee tycon
val arg1 = (Var.newNoname (), ty)
val arg2 = (Var.newNoname (), ty)
val args = Vector.new2 (arg1, arg2)
Modified: mlton/trunk/mlton/ssa/poly-hash.fun
===================================================================
--- mlton/trunk/mlton/ssa/poly-hash.fun 2008-08-19 22:11:50 UTC (rev 6730)
+++ mlton/trunk/mlton/ssa/poly-hash.fun 2008-08-19 22:11:55 UTC (rev 6731)
@@ -386,7 +386,7 @@
val name =
Func.newString (concat ["hash_", Tycon.originalName tycon])
val _ = setTyconHashFunc (tycon, SOME name)
- val ty = Type.con (tycon, Vector.new0 ())
+ val ty = Type.datatypee tycon
val st = (Var.newNoname (), Hash.stateTy)
val dep = (Var.newNoname (), seqIndexTy)
val x = (Var.newNoname (), ty)
Modified: mlton/trunk/mlton/ssa/simplify-types.fun
===================================================================
--- mlton/trunk/mlton/ssa/simplify-types.fun 2008-08-19 22:11:50 UTC (rev 6730)
+++ mlton/trunk/mlton/ssa/simplify-types.fun 2008-08-19 22:11:55 UTC (rev 6731)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2005, 2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -216,28 +216,34 @@
(* Build the dependents for each tycon. *)
val _ =
let
- val {get = isDatatype, set = setDatatype, destroy} =
- Property.destGetSetOnce (Tycon.plist, Property.initConst false)
val _ =
- Vector.foreach
- (datatypes, fn Datatype.T {tycon, ...} =>
- setDatatype (tycon, true))
- val _ =
Vector.foreach
(datatypes, fn Datatype.T {tycon, cons} =>
let
val {get = isDependent, set = setDependent, destroy} =
Property.destGetSet (Tycon.plist, Property.initConst false)
fun setTypeDependents t =
- let val (tycon', ts) = Type.tyconArgs t
- in if isDatatype tycon'
- then if isDependent tycon'
- then ()
- else (setDependent (tycon', true)
- ; List.push (#dependents
- (tyconInfo tycon'),
- tycon))
- else Vector.foreach (ts, setTypeDependents)
+ let
+ datatype z = datatype Type.dest
+ in
+ case Type.dest t of
+ Array t => setTypeDependents t
+ | CPointer => ()
+ | Datatype tycon' =>
+ if isDependent tycon'
+ then ()
+ else (setDependent (tycon', true)
+ ; List.push (#dependents
+ (tyconInfo tycon'),
+ tycon))
+ | IntInf => ()
+ | Real _ => ()
+ | Ref t => setTypeDependents t
+ | Thread => ()
+ | Tuple ts => Vector.foreach (ts, setTypeDependents)
+ | Vector t => setTypeDependents t
+ | Weak t => setTypeDependents t
+ | Word _ => ()
end
val _ =
Vector.foreach (cons, fn {args, ...} =>
@@ -245,7 +251,6 @@
val _ = destroy ()
in ()
end)
- val _ = destroy ()
in ()
end
@@ -360,6 +365,19 @@
* For datatypes with one variant not containing an array type, eliminate
* the datatype.
*)
+ fun containsArrayOrVector (ty: Type.t): bool =
+ let
+ datatype z = datatype Type.dest
+ fun loop t =
+ case Type.dest t of
+ Array _ => true
+ | Ref t => loop t
+ | Tuple ts => Vector.exists (ts, loop)
+ | Vector _ => true
+ | Weak t => loop t
+ | _ => false
+ in loop ty
+ end
val (datatypes, unary) =
Vector.fold
(datatypes, ([], []), fn (Datatype.T {tycon, cons}, (datatypes, unary)) =>
@@ -380,12 +398,9 @@
let
val {con, args} = Vector.sub (cons, 0)
in
- if Vector.exists (args, fn t =>
- Type.containsTycon (t, Tycon.array)
- orelse Type.containsTycon (t, Tycon.vector))
+ if Vector.exists (args, containsArrayOrVector)
then (datatypes,
- {tycon = tycon, con = con, args = args}
- :: unary)
+ {tycon = tycon, con = con, args = args} :: unary)
else (transparent (tycon, con, args)
; (datatypes, unary))
end
@@ -393,18 +408,19 @@
unary)
end)
fun containsTycon (ty: Type.t, tyc: Tycon.t): bool =
- let open Type
+ let
+ datatype z = datatype Type.dest
fun loop t =
- case dest t of
- Tuple ts => Vector.exists (ts, loop)
- | Array t => loop t
- | Vector t => loop t
- | Ref t => loop t
- | Weak t => loop t
+ case Type.dest t of
+ Array t => loop t
| Datatype tyc' =>
(case tyconReplacement tyc' of
NONE => Tycon.equals (tyc, tyc')
| SOME t => loop t)
+ | Tuple ts => Vector.exists (ts, loop)
+ | Ref t => loop t
+ | Vector t => loop t
+ | Weak t => loop t
| _ => false
in loop ty
end
@@ -583,7 +599,7 @@
(_, NONE) => NONE
| (0, SOME l) => SOME l
| (n, SOME l) =>
- if n = tyconNumCons (Type.tycon (oldVarType test))
+ if n = tyconNumCons (Type.deDatatype (oldVarType test))
then NONE
else SOME l
fun normal () =
Modified: mlton/trunk/mlton/ssa/ssa-tree.fun
===================================================================
--- mlton/trunk/mlton/ssa/ssa-tree.fun 2008-08-19 22:11:50 UTC (rev 6730)
+++ mlton/trunk/mlton/ssa/ssa-tree.fun 2008-08-19 22:11:55 UTC (rev 6731)
@@ -19,11 +19,6 @@
in open T
end
- fun tyconArgs t =
- case Dest.dest t of
- Dest.Con x => x
- | _ => Error.bug "SsaTree.Type.tyconArgs"
-
datatype dest =
Array of t
| CPointer
@@ -74,6 +69,18 @@
| _ => Error.bug "SsaTree.Type.dest"
end
+ val con = con
+
+ fun datatypee tycon = con (tycon, Vector.new0 ())
+ fun deDatatypeOpt t =
+ case dest t of
+ Datatype tycon => SOME tycon
+ | _ => NONE
+ fun deDatatype t =
+ case deDatatypeOpt t of
+ SOME tycon => tycon
+ | _ => Error.bug "SsaTree.Type.deDatatype"
+
local
open Layout
in
Modified: mlton/trunk/mlton/ssa/ssa-tree.sig
===================================================================
--- mlton/trunk/mlton/ssa/ssa-tree.sig 2008-08-19 22:11:50 UTC (rev 6730)
+++ mlton/trunk/mlton/ssa/ssa-tree.sig 2008-08-19 22:11:55 UTC (rev 6731)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -7,6 +7,7 @@
*)
type int = Int.t
+type word = Word.t
signature SSA_TREE_STRUCTS =
sig
@@ -56,7 +57,7 @@
structure Type:
sig
- include HASH_TYPE
+ type t
datatype dest =
Array of t
@@ -71,10 +72,41 @@
| Weak of t
| Word of WordSize.t
+ val array: t -> t
+ val bool: t
+ val checkPrimApp: {targs: t vector,
+ args: t vector,
+ prim: t Prim.t,
+ result: t} -> bool
+ val con: Tycon.t * t vector -> t
+ (* val cpointer: t *)
+ val datatypee: Tycon.t -> t
val dest: t -> dest
- val tyconArgs: t -> Tycon.t * t vector
+ val deArray: t -> t
+ val deArrow: t -> t * t
+ val deDatatype: t -> Tycon.t
+ val deRef: t -> t
+ val deTuple: t -> t vector
+ val deTupleOpt: t -> t vector option
+ val deVector: t -> t
+ val deWeak: t -> t
+ val equals: t * t -> bool
+ val hash: t -> word
+ (* val intInf: t *)
+ val isTuple: t -> bool
+ val isUnit: t -> bool
+ val layout: t -> Layout.t
+ val ofConst: Const.t -> t
+ val plist: t -> PropertyList.t
+ (* val real: RealSize.t -> t *)
+ val reff: t -> t
+ (* val thread: t *)
+ val tuple: t vector -> t
+ val vector: t -> t
+ val weak: t -> t
+ val word: WordSize.t -> t
+ val unit: t
end
- sharing Atoms = Type.Atoms
structure Exp:
sig
Modified: mlton/trunk/mlton/ssa/type-check.fun
===================================================================
--- mlton/trunk/mlton/ssa/type-check.fun 2008-08-19 22:11:50 UTC (rev 6730)
+++ mlton/trunk/mlton/ssa/type-check.fun 2008-08-19 22:11:55 UTC (rev 6731)
@@ -402,7 +402,7 @@
val _ =
Vector.foreach
(datatypes, fn Datatype.T {tycon, cons} =>
- let val result = Type.con (tycon, Vector.new0 ())
+ let val result = Type.datatypee tycon
in Vector.foreach
(cons, fn {con, args} =>
setConInfo (con, {args = args,
Modified: mlton/trunk/mlton/ssa/useless.fun
===================================================================
--- mlton/trunk/mlton/ssa/useless.fun 2008-08-19 22:11:50 UTC (rev 6730)
+++ mlton/trunk/mlton/ssa/useless.fun 2008-08-19 22:11:55 UTC (rev 6731)
@@ -425,7 +425,7 @@
val _ =
setTyconInfo (tycon, {useful = ref false,
cons = Vector.map (cons, #con)})
- fun value () = fromType (Type.con (tycon, Vector.new0 ()))
+ fun value () = fromType (Type.datatypee tycon)
in Vector.foreach
(cons, fn {con, args} =>
setConInfo (con, {value = value,
More information about the MLton-commit
mailing list