[MLton-commit] r7141

[Matthew Fluet]

Type-check primApp statements in MachineIL.
----------------------------------------------------------------------

U   mlton/trunk/mlton/backend/backend.fun
U   mlton/trunk/mlton/backend/machine.fun

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

Modified: mlton/trunk/mlton/backend/backend.fun
===================================================================
--- mlton/trunk/mlton/backend/backend.fun	2009-06-12 16:24:39 UTC (rev 7140)
+++ mlton/trunk/mlton/backend/backend.fun	2009-06-12 19:53:32 UTC (rev 7141)
@@ -452,7 +452,7 @@
                IntInf i =>
                   (case Const.SmallIntInf.toWord i of
                       NONE => globalIntInf i
-                    | SOME w => M.Operand.Word w)
+                    | SOME w => M.Operand.Cast (M.Operand.Word w, Type.intInf ()))
              | Null => M.Operand.Null
              | Real r => globalReal r
              | Word w => M.Operand.Word w
@@ -568,11 +568,14 @@
              | SetExnStackLocal =>
                   (* ExnStack = stackTop + (offset + LABEL_SIZE) - StackBottom; *)
                   let
-                     val tmp =
+                     val tmp1 =
                         M.Operand.Register
                         (Register.new (Type.cpointer (), NONE))
+                     val tmp2 =
+                        M.Operand.Register
+                        (Register.new (Type.csize (), NONE))
                   in
-                     Vector.new2
+                     Vector.new3
                      (M.Statement.PrimApp
                       {args = (Vector.new2
                                (stackTopOp,
@@ -582,15 +585,18 @@
                                   (Bytes.toInt
                                    (Bytes.+ (handlerOffset (), Runtime.labelSize ()))),
                                   WordSize.cpointer ())))),
-                       dst = SOME tmp,
+                       dst = SOME tmp1,
                        prim = Prim.cpointerAdd},
                       M.Statement.PrimApp
-                      {args = Vector.new2 (tmp, stackBottomOp),
-                       dst = SOME exnStackOp,
-                       prim = Prim.cpointerDiff})
+                      {args = Vector.new2 (tmp1, stackBottomOp),
+                       dst = SOME tmp2,
+                       prim = Prim.cpointerDiff},
+                      M.Statement.move
+                      {dst = exnStackOp,
+                       src = M.Operand.Cast (tmp2, Type.exnStack ())})
                   end
              | SetExnStackSlot =>
-                  (* ExnStack = *(uint* )(stackTop + offset);   *)
+                  (* ExnStack = *(uint* )(stackTop + offset); *)
                   Vector.new1
                   (M.Statement.move
                    {dst = exnStackOp,

Modified: mlton/trunk/mlton/backend/machine.fun
===================================================================
--- mlton/trunk/mlton/backend/machine.fun	2009-06-12 16:24:39 UTC (rev 7140)
+++ mlton/trunk/mlton/backend/machine.fun	2009-06-12 19:53:32 UTC (rev 7141)
@@ -386,17 +386,19 @@
             datatype z = datatype Operand.t
             fun bytes (b: Bytes.t): Operand.t =
                Word (WordX.fromIntInf (Bytes.toIntInf b, WordSize.csize ()))
+            val temp = Register (Register.new (Type.cpointer (), NONE))
          in
-            Vector.new3
+            Vector.new4
             (Move {dst = Contents {oper = Frontier,
                                    ty = Type.objptrHeader ()},
                    src = Word (WordX.fromIntInf (Word.toIntInf header,
                                                  WordSize.objptrHeader ()))},
-             (* CHECK; if objptr <> cpointer, need coercion here. *)
              PrimApp {args = Vector.new2 (Frontier,
                                           bytes (Runtime.headerSize ())),
-                      dst = SOME dst,
+                      dst = SOME temp,
                       prim = Prim.cpointerAdd},
+             (* CHECK; if objptr <> cpointer, need non-trivial coercion here. *)
+             Move {dst = dst, src = Cast (temp, Operand.ty dst)},
              PrimApp {args = Vector.new2 (Frontier, bytes size),
                       dst = SOME Frontier,
                       prim = Prim.cpointerAdd})
@@ -1219,19 +1221,28 @@
                            else NONE
                         end
                    | Noop => SOME alloc
-                   | PrimApp {args, dst, ...} =>
+                   | PrimApp {args, dst, prim, ...} =>
                         let
                            val _ = checkOperands (args, alloc)
+                           val alloc =
+                              case dst of
+                                 NONE => SOME alloc
+                               | SOME z =>
+                                    let
+                                       val alloc = Alloc.define (alloc, z)
+                                       val _ = checkOperand (z, alloc)
+                                    in
+                                       SOME alloc
+                                    end
+                           val ok =
+                              Type.checkPrimApp
+                              {args = Vector.map (args, Operand.ty),
+                               prim = prim,
+                               result = Option.map (dst, Operand.ty)}
                         in
-                           case dst of
-                              NONE => SOME alloc
-                            | SOME z =>
-                                 let
-                                    val alloc = Alloc.define (alloc, z)
-                                    val _ = checkOperand (z, alloc)
-                                 in
-                                    SOME alloc
-                                 end
+                           if ok
+                              then alloc
+                              else NONE
                         end
                    | ProfileLabel l =>
                         if profileLabelIsOk l