[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