[MLton-commit] r7546

Matthew Fluet fluet at mlton.org
Tue Jun 14 19:20:59 PDT 2011


Fixed bug in SSA/SSA2 shrinker.

Fixed bug in SSA/SSA2 shrinker that could erroneously turn a non-tail
function call with a Bug transfer as its continuation into a tail
function call. The bug was triggered by the following SSA fragment:

fun tuple_1213 (env_9399: (lambdas_9377 * lambdas_9378 * lambdas_2366 * lambdas_234),
               x_108593: Region.Wrap.t_8 vector): {raises = Some (CodeGen.AMD64MLTree.an),
                                                   returns = Some ()} = L_39443 ()
  ...
  L_39452 (env_9400: lambdas_161 ref)
    sub_288 (env_9400, x_108600) NonTail {cont = L_39453,
                                          handler = Handle L_39454}
  L_39454 (x_108601: CodeGen.AMD64MLTree.an)
    Leave AstCore.Exp.tuple mlton/ast/ast-core.fun 625.11
    raise (x_108601)
  L_39453 (x_108602: Region.Wrap.t_8)
    region_7 (x_108602)
  region_7 (x_306671: Region.Wrap.t_8)
    L_161558 ()
  L_161558 ()
    Bug
  ...

which was transformed to:

fun tuple_1213 (env_9399: (lambdas_9377 * lambdas_9378 * lambdas_2366 * lambdas_234),
               x_108593: Region.Wrap.t_8 vector): {raises = Some (CodeGen.AMD64MLTree.an),
                                                   returns = Some ()} = L_39443 ()
  ...
  L_39452 (env_9400: lambdas_161 ref)
    Leave AstCore.Exp.tuple mlton/ast/ast-core.fun 625.11
    sub_288 (env_9400, x_108600) Tail
  ...

Note that sub_288 returns Region.Wrap.t_8, but tuple_1213 returns ();
hence the transformed program is ill-typed.

The shrinker attempts to turn a nontail call into a tail call when the
return continuation is a Bug transfer and the handler is Leaves
followed by a Raise. To enable this transformation, the shrinker only
assigns LabelMeaning.Bug to blocks where the formals match the
function return, the statements are exclusively profile statements,
and the transfer is Bug. However, the shrinker also assigned
LabelMeaning.Bug to blocks where the statements are exclusively
profile statements and the transfer is a Goto to a block assigned
LabelMeaning.Bug. Hence, in the above, LabelMeaning.Bug is assigned to
L_161558, region_7, and L_39453.

The fix is to not propagate the LabelMeaning.Bug to a block with a
Goto transfer unless the block's formals match the function return.

Thanks to Lars Bergstrom for the bug report.
----------------------------------------------------------------------

U   mlton/trunk/doc/changelog
U   mlton/trunk/mlton/ssa/shrink.fun
U   mlton/trunk/mlton/ssa/shrink2.fun

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

Modified: mlton/trunk/doc/changelog
===================================================================
--- mlton/trunk/doc/changelog	2011-06-11 21:23:09 UTC (rev 7545)
+++ mlton/trunk/doc/changelog	2011-06-15 02:20:56 UTC (rev 7546)
@@ -1,5 +1,10 @@
 Here are the changes from version 2010608 to version YYYYMMDD.
 
+* 2011-06-14
+   - Fixed bug in SSA/SSA2 shrinker that could erroneously turn a
+     non-tail function call with a Bug transfer as its continuation
+     into a tail function call.
+
 * 2011-06-10
    - Fixed bug in translation from SSA2 to RSSA with case expressions
      over non-primitive-sized words.

Modified: mlton/trunk/mlton/ssa/shrink.fun
===================================================================
--- mlton/trunk/mlton/ssa/shrink.fun	2011-06-11 21:23:09 UTC (rev 7545)
+++ mlton/trunk/mlton/ssa/shrink.fun	2011-06-15 02:20:56 UTC (rev 7546)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2009 Matthew Fluet.
+(* Copyright (C) 2009,2011 Matthew Fluet.
  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
@@ -460,7 +460,17 @@
                                              Goto {canMove = canMove',
                                                    dst = m,
                                                    args = ps}
-                                        | Bug => Bug
+                                        | Bug =>
+                                             if (case returns of
+                                                    NONE => true
+                                                  | SOME ts =>
+                                                       Vector.equals
+                                                       (ts, args, fn (t, (_, t')) =>
+                                                        Type.equals (t, t')))
+                                                then Bug
+                                             else Goto {canMove = canMove',
+                                                        dst = m,
+                                                        args = ps}
                                         | Case _ => 
                                              Goto {canMove = canMove',
                                                    dst = m,
@@ -707,7 +717,7 @@
                                         Transfer.layout))
          val traceSimplifyCase =
             Trace.trace
-            ("Ssa2.Shrink2.simplifyCase",
+            ("Ssa.Shrink2.simplifyCase",
              fn {canMove, cases, default, test, ...} =>
              Layout.record [("canMove", List.layout Statement.layout canMove),
                             ("cantSimplify", Layout.str "fn () => ..."),

Modified: mlton/trunk/mlton/ssa/shrink2.fun
===================================================================
--- mlton/trunk/mlton/ssa/shrink2.fun	2011-06-11 21:23:09 UTC (rev 7545)
+++ mlton/trunk/mlton/ssa/shrink2.fun	2011-06-15 02:20:56 UTC (rev 7546)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2009 Matthew Fluet.
+(* Copyright (C) 2009,2011 Matthew Fluet.
  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
@@ -465,8 +465,18 @@
                                              Goto {canMove = canMove',
                                                    dst = m,
                                                    args = ps}
-                                        | Bug => Bug
-                                        | Case _ =>
+                                        | Bug =>
+                                             if (case returns of
+                                                    NONE => true
+                                                  | SOME ts =>
+                                                       Vector.equals
+                                                       (ts, args, fn (t, (_, t')) =>
+                                                        Type.equals (t, t')))
+                                                then Bug
+                                             else Goto {canMove = canMove',
+                                                        dst = m,
+                                                        args = ps}
+                                       | Case _ =>
                                              Goto {canMove = canMove',
                                                    dst = m,
                                                    args = ps}




More information about the MLton-commit mailing list