[MLton-devel] cvs commit: knownCase bug
Matthew Fluet
fluet@users.sourceforge.net
Wed, 04 Jun 2003 13:52:16 -0700
fluet 03/06/04 13:52:15
Modified: mlton/ssa known-case.fun
Log:
Fixed a bug in known-case.fun when shuffling variables across a Goto
transfer. This bug was exhibitted by -loop-passes 2 on
kitreynolds2.sml.
Revision Changes Path
1.14 +53 -36 mlton/mlton/ssa/known-case.fun
Index: known-case.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/known-case.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- known-case.fun 22 Jan 2003 19:06:38 -0000 1.13
+++ known-case.fun 4 Jun 2003 20:52:14 -0000 1.14
@@ -132,7 +132,6 @@
structure VarInfo =
struct
datatype t = T of {active: bool ref,
- replaces: Var.t ref list ref,
tyconValues: TyconValue.t list ref,
var: Var.t}
@@ -141,19 +140,16 @@
fun make' f = (make f, ! o (make f))
in
val (active, active') = make' #active
- val (replaces, replaces') = make' #replaces
val (tyconValues, tyconValues') = make' #tyconValues
val var = make #var
end
- fun layout (T {active, replaces, tyconValues, var, ...})
+ fun layout (T {active, tyconValues, var, ...})
= Layout.record [("active", Bool.layout (!active)),
- ("replaces", List.layout (Var.layout o !) (!replaces)),
("tyconValues", List.layout TyconValue.layout (!tyconValues)),
("var", Var.layout var)]
fun new var = T {active = ref false,
- replaces = ref [ref var],
tyconValues = ref [],
var = var}
@@ -164,8 +160,46 @@
activate vi)
val active = active'
+ fun tyconValue (T {tyconValues, ...})
+ = case !tyconValues of h::_ => SOME h | _ => NONE
+ fun popTyconValue (T {tyconValues, ...}) = ignore (List.pop tyconValues)
+ fun pushTyconValue (T {tyconValues, ...}, tcv) = List.push (tyconValues, tcv)
+ fun pushTyconValue' (vi, tcv, addPost)
+ = let
+ val _ = pushTyconValue (vi, tcv)
+ val _ = addPost (fn () => popTyconValue vi)
+ in
+ ()
+ end
+ fun joinActiveTyconValue (vi, tcv, addPost, addPost')
+ = if active vi
+ then let val tcv' = valOf (tyconValue vi)
+ in
+ popTyconValue vi;
+ pushTyconValue (vi, TyconValue.join (tcv, tcv'))
+ end
+ else (activate' (vi, addPost');
+ pushTyconValue' (vi, tcv, addPost))
+ end
+
+structure ReplaceInfo =
+ struct
+ datatype t = T of {replaces: Var.t ref list ref}
+
+ local
+ fun make f (T r) = f r
+ fun make' f = (make f, ! o (make f))
+ in
+ val (replaces, replaces') = make' #replaces
+ end
+
+ fun layout (T {replaces, ...})
+ = Layout.record [("replaces", List.layout (Var.layout o !) (!replaces))]
+
+ fun new var = T {replaces = ref [ref var]}
+
fun replace (T {replaces, ...})
- = case !replaces of h::_ => SOME h | _ => NONE
+ = case !replaces of h::_ => h | _ => Error.bug "KnownCase.ReplaceInfo.replace"
fun popReplace (T {replaces, ...}) = ignore (List.pop replaces)
fun pushReplace (T {replaces, ...}, rep) = List.push (replaces, ref rep)
fun pushReplace' (vi, rep, addPost)
@@ -176,9 +210,9 @@
()
end
fun flipReplace (vi, rep)
- = case replace vi
- of SOME r => !r before (r := rep)
- | _ => Error.bug "KnownCase.VarInfo.flipReplace"
+ = let val r = replace vi
+ in !r before (r := rep)
+ end
fun flipReplace' (vi, rep, addPost)
= let
val rep = flipReplace (vi, rep)
@@ -193,27 +227,6 @@
in
()
end
-
- fun tyconValue (T {tyconValues, ...})
- = case !tyconValues of h::_ => SOME h | _ => NONE
- fun popTyconValue (T {tyconValues, ...}) = ignore (List.pop tyconValues)
- fun pushTyconValue (T {tyconValues, ...}, tcv) = List.push (tyconValues, tcv)
- fun pushTyconValue' (vi, tcv, addPost)
- = let
- val _ = pushTyconValue (vi, tcv)
- val _ = addPost (fn () => popTyconValue vi)
- in
- ()
- end
- fun joinActiveTyconValue (vi, tcv, addPost, addPost')
- = if active vi
- then let val tcv' = valOf (tyconValue vi)
- in
- popTyconValue vi;
- pushTyconValue (vi, TyconValue.join (tcv, tcv'))
- end
- else (activate' (vi, addPost');
- pushTyconValue' (vi, tcv, addPost))
end
structure LabelInfo =
@@ -345,6 +358,10 @@
set = setVarInfo, ...}
= Property.getSetOnce
(Var.plist, Property.initFun (fn x => VarInfo.new x))
+ (* replaceInfo *)
+ val {get = replaceInfo: Var.t -> ReplaceInfo.t, ...}
+ = Property.get
+ (Var.plist, Property.initFun (fn x => ReplaceInfo.new x))
fun bindVar' (x, ty, exp, addPost)
@@ -359,7 +376,7 @@
=> TyconValue.newKnown
(cons, con,
Vector.map
- (args, valOf o VarInfo.replace o varInfo))
+ (args, ReplaceInfo.replace o replaceInfo))
| _ => TyconValue.newUnknown cons
in
VarInfo.pushTyconValue'
@@ -555,11 +572,11 @@
VarInfo.pushTyconValue'
(tvi,
valOf (VarInfo.tyconValue zvi),
- addPost);
- VarInfo.nextReplace'
- (zvi, t, addPost)
+ addPost)
end
else ();
+ ReplaceInfo.nextReplace'
+ (replaceInfo z, t, addPost);
Statement.T {var = SOME t,
ty = ty,
exp = Var z}))
@@ -709,7 +726,7 @@
val conValues' = TyconValue.newKnown
(cons, con,
Vector.map
- (xs, valOf o VarInfo.replace o varInfo))
+ (xs, ReplaceInfo.replace o replaceInfo))
val label = Label.newNoname ()
val (statements, transfer)
= case rewriteDefault conValues'
@@ -937,7 +954,7 @@
= TyconValue.newKnown
(cons, con,
Vector.map
- (argsDst, valOf o VarInfo.replace o varInfo o #1))
+ (argsDst, ReplaceInfo.replace o replaceInfo o #1))
in
if LabelInfo.onePred liDst
then LabelInfo.addActivation
-------------------------------------------------------
This SF.net email is sponsored by: Etnus, makers of TotalView, The best
thread debugger on the planet. Designed with thread debugging features
you've never dreamed of, try TotalView 6 free at www.etnus.com.
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel