[MLton-commit] r4039

[Stephen Weeks]

Fixed bug in MLton.Finalizable.touch, which was not keeping alive
finalizable values in all cases.

Added a regression with the code that caused the problem.


----------------------------------------------------------------------

U   mlton/trunk/doc/changelog
U   mlton/trunk/mlton/backend/backend.fun
U   mlton/trunk/mlton/backend/ssa-to-rssa.fun
A   mlton/trunk/regression/finalize.3.ok
A   mlton/trunk/regression/finalize.3.sml

----------------------------------------------------------------------

Modified: mlton/trunk/doc/changelog
===================================================================
--- mlton/trunk/doc/changelog	2005-08-25 20:49:47 UTC (rev 4038)
+++ mlton/trunk/doc/changelog	2005-08-25 20:52:48 UTC (rev 4039)
@@ -1,5 +1,9 @@
 Here are the changes since version 20041109.
 
+* 2005-08-25
+  - Fixed bug in MLton.Finalizable.touch, which was not keeping alive
+    finalizable values in all cases.
+
 * 2005-08-18
   - Added SML/NJ Library and CKit Library from SML/NJ 110.55 to 
     standard distribution.

Modified: mlton/trunk/mlton/backend/backend.fun
===================================================================
--- mlton/trunk/mlton/backend/backend.fun	2005-08-25 20:49:47 UTC (rev 4038)
+++ mlton/trunk/mlton/backend/backend.fun	2005-08-25 20:52:48 UTC (rev 4039)
@@ -156,7 +156,7 @@
                          Regexp.Compiled.matchesAll (re, name))
             then program
          else pass (name, doit, program)
-      val program = pass ("ToRssa", SsaToRssa.convert, (program, codegen))
+      val program = pass ("toRssa", SsaToRssa.convert, (program, codegen))
       fun rssaSimplify program = 
          let
             val program = 
@@ -531,11 +531,18 @@
                                       header = header,
                                       size = size}
              | PrimApp {dst, prim, args} =>
-                  Vector.new1
-                  (M.Statement.PrimApp
-                   {args = translateOperands args,
-                    dst = Option.map (dst, varOperand o #1),
-                    prim = prim})
+                  let
+                     datatype z = datatype Prim.Name.t
+                  in
+                     case Prim.name prim of
+                        MLton_touch => Vector.new0 ()
+                      | _ => 
+                           Vector.new1
+                           (M.Statement.PrimApp
+                            {args = translateOperands args,
+                             dst = Option.map (dst, varOperand o #1),
+                             prim = prim})
+                  end
              | ProfileLabel s => Vector.new1 (M.Statement.ProfileLabel s)
              | SetExnStackLocal =>
                   (* ExnStack = stackTop + (offset + WORD_SIZE) - StackBottom; *)

Modified: mlton/trunk/mlton/backend/ssa-to-rssa.fun
===================================================================
--- mlton/trunk/mlton/backend/ssa-to-rssa.fun	2005-08-25 20:49:47 UTC (rev 4038)
+++ mlton/trunk/mlton/backend/ssa-to-rssa.fun	2005-08-25 20:52:48 UTC (rev 4039)
@@ -1189,8 +1189,8 @@
                                | MLton_size =>
                                     simpleCCall
                                     (CFunction.size (Operand.ty (a 0)))
-                               | MLton_touch => none ()
                                | Pointer_getPointer => pointerGet ()
+                               | MLton_touch => primApp prim
                                | Pointer_getReal _ => pointerGet ()
                                | Pointer_getWord _ => pointerGet ()
                                | Pointer_setPointer => pointerSet ()

Added: mlton/trunk/regression/finalize.3.ok
===================================================================
--- mlton/trunk/regression/finalize.3.ok	2005-08-25 20:49:47 UTC (rev 4038)
+++ mlton/trunk/regression/finalize.3.ok	2005-08-25 20:52:48 UTC (rev 4039)
@@ -0,0 +1,7 @@
+before test 4
+before GC 4a
+after GC 4a
+invoking touch
+before GC 4b
+test 4: finalizer
+after GC 4b

Added: mlton/trunk/regression/finalize.3.sml
===================================================================
--- mlton/trunk/regression/finalize.3.sml	2005-08-25 20:49:47 UTC (rev 4038)
+++ mlton/trunk/regression/finalize.3.sml	2005-08-25 20:52:48 UTC (rev 4039)
@@ -0,0 +1,17 @@
+fun test2 (str : string) =
+    let open MLton.Finalizable
+        val x = new str
+    in addFinalizer (x, fn s => print (s ^ ": finalizer\n"));
+       (fn () => (print "invoking touch\n"; touch x))
+    end
+
+val _ = (print "before test 4\n";
+         let val t = test2 "test 4"
+         in print "before GC 4a\n";
+            MLton.GC.collect ();
+            print "after GC 4a\n";
+            t ();
+            print "before GC 4b\n";
+            MLton.GC.collect ();
+            print "after GC 4b\n"
+         end)