[MLton] cvs commit: Fixed bug in refFlatten pass.

[Matthew Fluet]

fluet       05/07/23 19:11:36

  Modified:    doc      changelog
               mlton/ssa ref-flatten.fun
  Added:       regression ref-flatten.6.ok ref-flatten.6.sml
  Log:
  MAIL Fixed bug in refFlatten pass.
  
  Fixed a bug in the refFlatten pass reported by Vesa Karvonen.  When an
  Update statement was transformed, the value component was not propertly
  translated.  This could yield an SSA2 IL type-error when the value was
  itself flattenable.

Revision  Changes    Path
1.169     +3 -0      mlton/doc/changelog

Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.168
retrieving revision 1.169
diff -u -r1.168 -r1.169
--- changelog	23 Jul 2005 11:55:36 -0000	1.168
+++ changelog	24 Jul 2005 02:11:34 -0000	1.169
@@ -1,6 +1,9 @@
 Here are the changes since version 20041109.
 
 * 2005-07-23
+  - Fixed bug in pass to flatten refs into containing data structure.
+	
+* 2005-07-23
   - Overhaul of FFI.
     Deprecated _import of C base types.
     Added _symbol for address, getter, and setter of C base types.



1.36      +19 -7     mlton/mlton/ssa/ref-flatten.fun

Index: ref-flatten.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ref-flatten.fun,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -r1.35 -r1.36
--- ref-flatten.fun	19 Jun 2005 21:34:05 -0000	1.35
+++ ref-flatten.fun	24 Jul 2005 02:11:35 -0000	1.36
@@ -605,7 +605,9 @@
 		      case Value.value (varValue var) of
 			 Value.Ground _ => ()
 		       | Value.Object obj => f (var, args, obj)
-		       | _ => Error.bug "RefFlatten.foreachObject: Object with strange value")
+		       | _ => 
+			    Error.bug 
+			    "RefFlatten.foreachObject: Object with strange value")
 		| _ => ()
 	    val () = Vector.foreach (globals, loopStatement)
 	    val () =
@@ -802,7 +804,8 @@
 	  end)
       (* Conversion from values to types. *)
       datatype z = datatype Finish.t
-      val traceValueType = Trace.trace ("RefFlatten.valueType", Value.layout, Type.layout)
+      val traceValueType = 
+	 Trace.trace ("RefFlatten.valueType", Value.layout, Type.layout)
       fun valueType arg: Type.t =
 	 traceValueType
 	 (fn (v: Value.t) =>
@@ -971,9 +974,8 @@
 	  | Update {base, offset, value} =>
 	       (case base of
 		   Base.Object object =>
-		      Vector.new1
 		      (case varObject object of
-			  NONE => s
+			  NONE => Vector.new1 s
 			| SOME obj =>
 			     let
 				val base =
@@ -984,10 +986,20 @@
 						Base.Object objectVar
 					   | _ => base)
 				    | Unflattenable => base
+				val value =
+				   case flattenArgs (Vector.new1 value, obj, []) of
+				      [value] => value
+				    | _ => Error.bug 
+                                           "RefFlatten.transformStatement.Update"
+				val extra = !extraSelects
+				val () = extraSelects := []
 			     in
-				Update {base = base,
-					offset = objectOffset (obj, offset),
-					value = value}
+				Vector.concat
+				[Vector.fromList extra,
+				 (Vector.new1 o Update) 
+				 {base = base,
+				  offset = objectOffset (obj, offset),
+				  value = value}]
 			     end)
 		 | Base.VectorSub _ => Vector.new1 s)
       val transformStatement =



1.1                  mlton/regression/ref-flatten.6.ok

Index: ref-flatten.6.ok
===================================================================
hi
hi



1.1                  mlton/regression/ref-flatten.6.sml

Index: ref-flatten.6.sml
===================================================================
datatype ('a, 'b) either = LEFT of 'a | RIGHT of 'b

fun eval thunk =
    LEFT (thunk ()) handle e => RIGHT e

datatype 'a status = LAZY of unit -> 'a promise
                   | EAGER of ('a, exn) either
withtype 'a promise = 'a status ref ref

fun lazy exp =
    ref (ref (LAZY exp))

fun delay exp =
    lazy (fn () => ref (ref (EAGER (eval exp))))

fun force promise =
    case !(!promise)
     of EAGER (LEFT x) => x
      | EAGER (RIGHT x) => raise x
      | LAZY exp =>
        let
          val promise' = exp ()
        in
          (case !(!promise)
            of LAZY _ => (!promise := !(!promise') ;
                          promise' := !promise)
             | _ => ())
        ; force promise
        end

exception Assertion

fun check (b, e) = if b then () else raise e
fun verify b = check (b, Assertion)

val () =
    let
      val r = delay (fn () => (print "hi\n" ; 1))
      val s = lazy (fn () => r)
      val t = lazy (fn () => s)
    in
      verify (1 = force t)
    ; verify (1 = force r)
    end