[MLton] cvs commit: bytecode codgen working again

Matthew Fluet fluet@mlton.org
Tue, 1 Mar 2005 16:39:16 -0800


fluet       05/03/01 16:39:16

  Modified:    mlton/codegen/bytecode bytecode.fun
  Log:
  MAIL bytecode codgen working again
  
  Type synonym replacement in the front end tickled a bug in the
  bytecode codegen which could result in the following error:
  
  missing opcode: Int32_storeStackOffset
  
  The bytecode abstract machine treates all words as unsigned, but
  foreign C-calls must respect the signed/unsigned distinction to
  properly handle calling conventions.  Hence, using the C-prototype to
  derive bytecode operations may introduce signed data, for which there
  are no corresponding opcodes or registers.  We mediate in the
  generated C-call dispatch with explicit casts to and from signed words
  when the C-prototype demands.

Revision  Changes    Path
1.20      +159 -112  mlton/mlton/codegen/bytecode/bytecode.fun

Index: bytecode.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/bytecode/bytecode.fun,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- bytecode.fun	21 Oct 2004 21:30:46 -0000	1.19
+++ bytecode.fun	2 Mar 2005 00:39:15 -0000	1.20
@@ -84,17 +84,17 @@
 				| _ => m t))
 	 end
 
-      val toStringOrig = toString
-      val toString = memo toString
-
-      val toStringNoInt =
+      val noSigned =
 	 memo (fn t =>
 	       case t of
-		  Int8 => toString Word8
-		| Int16 => toString Word16
-		| Int32 => toString Word32
-		| Int64 => toString Word64
-		| _ => toString t)
+		  Int8 => Word8
+		| Int16 => Word16
+		| Int32 => Word32
+		| Int64 =>  Word64
+		| _ => t)
+
+      val toStringOrig = toString
+      val toString = memo toString
    end
 
 structure LoadStore =
@@ -150,31 +150,72 @@
 	 let
 	    val (args, result) = prototype
 	    val c = Counter.new 0
+	    fun temp () = concat ["t", Int.toString (Counter.next c)]
+	    fun cast (cty, src) =
+	       concat ["(", cty, ")(", src, ")"]
 	    val args =
 	       Vector.map
 	       (args, fn cty =>
 		let
-		   val temp = concat ["t", Int.toString (Counter.next c)]
-		   val cty = CType.toStringNoInt cty
+		   val mty = CType.noSigned cty
+		   val (declarePop,mtemp) =
+		      let
+			 val mty = CType.toString mty
+			 val mtemp = temp ()
+		      in
+			 (concat ["\t", mty, " ", mtemp, 
+				  " = PopReg (", mty, ");\n"],
+			  mtemp)
+		      end
+		   val (declareCast, ctemp) =
+		      if mty = cty
+			 then ("", mtemp)
+			 else let
+				 val cty = CType.toString cty
+				 val ctemp = temp ()
+			      in
+				 (concat ["\t", cty, " ", ctemp, " = ",
+					  cast (cty, mtemp), ";\n"],
+				  ctemp)
+			      end
 		in
-		   {declare = concat ["\t", cty, " ",
-				      temp, " = PopReg (", cty, ");\n"],
-		    temp = temp}
+		   {declare = concat [declarePop, declareCast],
+		    temp = ctemp}
 		end)
+	    val call =
+	       concat [function,
+		       " (",
+		       (concat o List.separate) 
+		       (Vector.toListMap (args, #temp), ", "),
+		       ");\n"]
 	    val result =
 	       case result of
-		  NONE => ""
+		  NONE => concat ["\t", call]
 		| SOME cty =>
-		     concat ["PushReg (", CType.toStringNoInt cty, ") = "]
+		     let
+			val mty = CType.noSigned cty
+		     in
+			if mty = cty
+			   then concat 
+			        ["\tPushReg (", CType.toString cty, ") = ", 
+				 call]
+			   else let
+				   val cty = CType.toString cty
+				   val ctemp = temp ()
+				   val mty = CType.toString mty
+				in
+				   concat 
+				   ["\t", cty, " ", ctemp, " = ", call,
+				    "\tPushReg (", mty, ") = ", 
+				    cast (mty, ctemp), ";\n"]
+				end
+		     end
 	 in
 	    concat
 	    ["{\n",
 	     concat (Vector.toListMap (args, #declare)),
 	     "\tassertRegsEmpty ();\n",
-	     "\t", result, function,
-	     " (",
-	     concat (List.separate (Vector.toListMap (args, #temp), ", ")),
-	     ");\n",
+	     result,
 	     "\t}\n"]
 	 end
       local
@@ -509,6 +550,8 @@
 			  emitted = ref false,
 			  occurrenceOffsets = ref [],
 			  offset = ref NONE})))
+      val traceEmitTransfer =
+	 Trace.trace ("emitTransfer", Transfer.layout, Unit.layout)
       fun emitBlock (Block.T {kind, label, statements, transfer, ...}): unit =
 	 let
 	    val () =
@@ -538,8 +581,11 @@
 				   * We write it to a bogus location in the
 				   * callee's frame before popping back to the
 				   * caller.
+				   * We mediated between the signed/unsigned treatment
+				   * in the stub.
 				   *)
-				  (loadStoreStackOffset (Bytes.zero, cty, Store)
+				  (loadStoreStackOffset 
+				   (Bytes.zero, CType.noSigned cty, Store)
 				   ; popFrame ())
 			     | SOME z =>
 				  (popFrame ()
@@ -559,97 +605,96 @@
 	       then (emitOpcode gotoOp; emitLabel l)
 	    else (emitted := true; emitBlock block)
 	 end
-      and emitTransfer (t: Transfer.t): unit =
-	 let
-	    datatype z = datatype Transfer.t
-	 in
-	    case t of
-	       Arith {args, dst, overflow, prim, success} =>
-		  (emitArgs args
-		   ; emitPrim prim
-		   ; emitStoreOperand dst
-		   ; emitOpcode jumpOnOverflow
-		   ; emitLabel overflow
-		   ; goto success)
-	     | CCall {args, frameInfo, func, return} =>
-		  let
-		     val () = emitArgs args
-		     val CFunction.T {maySwitchThreads, prototype, target, ...} =
-			func
-		     val () =
-			Option.app
-			(frameInfo, fn frameInfo =>
-			 push (valOf return,
-			       Program.frameSize (program, frameInfo)))
-		     datatype z = datatype Target.t
-		     val () =
-			case target of
-			   Direct name => emitCallC (directIndex name)
-			 | Indirect => emitCallC (indirectIndex func)
-		     val () =
-			if maySwitchThreads
-			   then emitOpcode returnOp
-			else Option.app (return, goto)
-		  in
-		     ()
-		  end
-	     | Call {label, return, ...} =>
-		  (Option.app (return, fn {return, size, ...} =>
-			       push (return, size))
-		   ; goto label)
-	     | Goto l => goto l
-	     | Raise => emitOpcode raisee
-	     | Return => emitOpcode returnOp
-	     | Switch (Switch.T {cases, default, size, test}) =>
-		  let
-		     val () = emitLoadOperand test
-		     fun bool (test: Operand.t, a: Label.t, b: Label.t) =
-			(emitOpcode branchIfZero
-			 ; emitLabel b
-			 ; goto a)
-		     fun normal () =
-			let
-			   val numCases =
-			      Vector.length cases
-			      + (if isSome default then 1 else 0)
-			      - 1
-			   val () =
-			      (emitOpcode (switch size)
-			       ; emitWord16 (Int.toIntInf numCases))
-			   fun emitCases cases =
-			      Vector.foreach (cases, fn (w, l) =>
-					      (emitWordX w; emitLabel l))
-			in
-			   case default of
-			      NONE =>
-				 (emitCases (Vector.dropSuffix (cases, 1))
-				  ; goto (#2 (Vector.last cases)))
-			    | SOME l =>
-				 (emitCases cases; goto l)
-			end
-		  in
-		     if 2 = Vector.length cases
-			andalso Option.isNone default
-			andalso WordSize.equals (size, WordSize.default)
-			then
-			   let
-			      val (c0, l0) = Vector.sub (cases, 0)
-			      val (c1, l1) = Vector.sub (cases, 1)
-			      val i0 = WordX.toIntInf c0
-			      val i1 = WordX.toIntInf c1
-			   in
-			      if i0 = 0 andalso i1 = 1
-				 then bool (test, l1, l0)
-			      else if i0 = 1 andalso i1 = 0
-				      then bool (test, l0, l1)
-				   else normal ()
-			   end
-		     else normal ()
-		  end
-	 end
-      val emitTransfer =
-	 Trace.trace ("emitTransfer", Transfer.layout, Unit.layout)
-	 emitTransfer
+      and emitTransfer arg: unit =
+	 traceEmitTransfer
+	 (fn (t: Transfer.t) => 
+	  let
+	     datatype z = datatype Transfer.t
+	  in
+	     case t of
+		Arith {args, dst, overflow, prim, success} =>
+		   (emitArgs args
+		    ; emitPrim prim
+		    ; emitStoreOperand dst
+		    ; emitOpcode jumpOnOverflow
+		    ; emitLabel overflow
+		    ; goto success)
+	      | CCall {args, frameInfo, func, return} =>
+		   let
+		      val () = emitArgs args
+		      val CFunction.T {maySwitchThreads, target, ...} =
+			 func
+		      val () =
+			 Option.app
+			 (frameInfo, fn frameInfo =>
+			  push (valOf return,
+				Program.frameSize (program, frameInfo)))
+		      datatype z = datatype Target.t
+		      val () =
+			 case target of
+			    Direct name => emitCallC (directIndex name)
+			  | Indirect => emitCallC (indirectIndex func)
+		      val () =
+			 if maySwitchThreads
+			    then emitOpcode returnOp
+			    else Option.app (return, goto)
+		   in
+		      ()
+		   end
+	      | Call {label, return, ...} =>
+		   (Option.app (return, fn {return, size, ...} =>
+				push (return, size))
+		    ; goto label)
+	      | Goto l => goto l
+	      | Raise => emitOpcode raisee
+	      | Return => emitOpcode returnOp
+	      | Switch (Switch.T {cases, default, size, test}) =>
+		   let
+		      val () = emitLoadOperand test
+		      fun bool (test: Operand.t, a: Label.t, b: Label.t) =
+			 (emitOpcode branchIfZero
+			  ; emitLabel b
+			  ; goto a)
+		      fun normal () =
+			 let
+			    val numCases =
+			       Vector.length cases
+			       + (if isSome default then 1 else 0)
+			       - 1
+			    val () =
+			       (emitOpcode (switch size)
+				; emitWord16 (Int.toIntInf numCases))
+			    fun emitCases cases =
+			       Vector.foreach (cases, fn (w, l) =>
+					       (emitWordX w; emitLabel l))
+			 in
+			    case default of
+			       NONE =>
+				  (emitCases (Vector.dropSuffix (cases, 1))
+				   ; goto (#2 (Vector.last cases)))
+			     | SOME l =>
+				  (emitCases cases; goto l)
+			 end
+		   in
+		      if 2 = Vector.length cases
+			 andalso Option.isNone default
+			 andalso WordSize.equals (size, WordSize.default)
+			 then
+			    let
+			       val (c0, l0) = Vector.sub (cases, 0)
+			       val (c1, l1) = Vector.sub (cases, 1)
+			       val i0 = WordX.toIntInf c0
+			       val i1 = WordX.toIntInf c1
+			    in
+			       if i0 = 0 andalso i1 = 1
+				  then bool (test, l1, l0)
+				  else if i0 = 1 andalso i1 = 0
+					  then bool (test, l0, l1)
+					  else normal ()
+			    end
+			 else normal ()
+		   end
+	  end) arg
       fun loop () =
 	 case !needToEmit of
 	    [] => ()
@@ -687,6 +732,8 @@
 	      List.foreach (!r, fn occ => loop (occ, offset))
 	  end))
       val {done, file = _, print} = outputC ()
+      val print =
+	 Trace.trace ("Bytecode.print", String.layout, Unit.layout) print
       val () =
 	 CCodegen.outputDeclarations
 	 {additionalMainArgs = [Int.toString (labelOffset (#label main))],