[MLton-devel] cvs commit: int64 support in x86-codegen

Matthew Fluet fluet@users.sourceforge.net
Thu, 31 Jul 2003 16:10:33 -0700


fluet       03/07/31 16:10:33

  Modified:    include  x86-main.h
               mlton/backend ssa-to-rssa.fun
               mlton/codegen/x86-codegen x86-allocate-registers.fun
                        x86-generate-transfers.fun x86-live-transfers.fun
                        x86-mlton-basic.fun x86-mlton-basic.sig
                        x86-mlton.fun x86-mlton.sig x86-pseudo.sig
                        x86-translate.fun x86.fun x86.sig
  Log:
  This commit adds support for int64 types in the x86-codgen,
  using the _import functions used by the C codegen.
  
  I modified the ssaToRssa pass to do two things:
  1) convert Prim.Int_equal IntSize.I64 to a CFunction call,
     (similar to the way Prim.IntInf_equal is converted)
  2) unroll swtiches on int64's into if-then-else cascades,
      using the CFunction for comparisons.

Revision  Changes    Path
1.8       +2 -0      mlton/include/x86-main.h

Index: x86-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86-main.h,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- x86-main.h	25 Jul 2003 20:14:46 -0000	1.7
+++ x86-main.h	31 Jul 2003 23:10:32 -0000	1.8
@@ -9,6 +9,8 @@
 word cReturnTemp[16];
 word c_stackP;
 word divTemp;
+word eq1Temp;
+word eq2Temp;
 word fileTemp;
 word fildTemp;
 word fpswTemp;



1.43      +58 -1     mlton/mlton/backend/ssa-to-rssa.fun

Index: ssa-to-rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.fun,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- ssa-to-rssa.fun	19 Jul 2003 01:23:26 -0000	1.42
+++ ssa-to-rssa.fun	31 Jul 2003 23:10:32 -0000	1.43
@@ -34,6 +34,7 @@
 	 open CType
       in
 	 val Int32 = Int I32
+	 val Int64 = Int I64
 	 val Word32 = Word W32
       end
 
@@ -119,6 +120,14 @@
 	 val intInfEqual = make "IntInf_equal"
       end
 
+      local
+	 fun make name = vanilla {args = Vector.new2 (Int64, Int64),
+				  name = name,
+				  return = SOME CType.defaultInt}
+      in
+	 val int64Equal = make "Int64_equal"
+      end
+
       val getPointer =
 	 vanilla {args = Vector.new1 Int32,
 		  name = "MLton_FFI_getPointer",
@@ -616,7 +625,51 @@
 					     testRep = tyconRep tycon}
 			    else Error.bug "strange type in case"
 			 end)
-	     | S.Cases.Int (s, cs) => simple (s, cs, Switch.Int, id, IntX.<=)
+	     | S.Cases.Int (s, cs) => 
+		  if s = IntSize.I64 andalso !Control.Native.native
+		     then let
+			     val defaultLabel =
+				case default of
+				   SOME default => default
+				 | NONE => Error.bug "case has no default"
+			     val firstLabel =
+				Vector.foldr
+				(cs, defaultLabel, fn ((i, l), nextLabel) =>
+				 let	
+				    val b = (Var.newNoname (), Type.bool)	
+				    val transfer =
+				       Transfer.ifInt
+				       (Operand.Var {var = #1 b, ty = #2 b}, 
+					{truee = l, falsee = nextLabel})
+				    val return =
+				       newBlock
+				       {args = Vector.new1 b,
+					kind = Kind.CReturn {func = CFunction.int64Equal},
+					statements = Vector.new0 (),
+					transfer = transfer}
+				    val args =
+				       Vector.new2
+				       (Operand.Var {var = test,
+						     ty = Type.int IntSize.I64},
+					Operand.Const (Const.int i))
+				    val transfer =
+				       Transfer.CCall
+				       {args = args,
+					func = CFunction.int64Equal,
+					return = SOME return}
+				    val label =
+				       newBlock
+				       {args = Vector.new0 (),
+					kind = Kind.Jump,
+					statements = Vector.new0 (),
+					transfer = transfer}
+				 in
+				    label
+				 end)
+			  in
+			     ([], Transfer.Goto {args = Vector.new0 (), dst = firstLabel})
+			  end
+		     else simple (s, cs, Switch.Int, id, IntX.<=)
 	     | S.Cases.Word (s, cs) => simple (s, cs, Switch.Word, id, WordX.<=)
 	 end
       val {get = labelInfo: (Label.t ->
@@ -1157,6 +1210,10 @@
 			       | GC_unpack =>
 				    ccall {args = Vector.new1 Operand.GCState,
 					   func = CFunction.unpack}
+			       | Int_equal s =>
+				    if s = IntSize.I64 andalso !Control.Native.native 
+				       then simpleCCall CFunction.int64Equal
+				       else normal ()
 			       | IntInf_add => simpleCCall CFunction.intInfAdd
 			       | IntInf_andb => simpleCCall CFunction.intInfAndb
 			       | IntInf_arshift =>



1.31      +66 -11    mlton/mlton/codegen/x86-codegen/x86-allocate-registers.fun

Index: x86-allocate-registers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-allocate-registers.fun,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- x86-allocate-registers.fun	25 Jul 2003 20:14:46 -0000	1.30
+++ x86-allocate-registers.fun	31 Jul 2003 23:10:33 -0000	1.31
@@ -529,10 +529,8 @@
 			       andalso
 			       (Size.class (MemLoc.size memloc) <> Size.INT)))::
 		      future
-		   | Directive.Return {memloc}
-		   => (M (FDEF, memloc))::future
-		   | Directive.FltReturn {memloc}
-		   => (M (FDEF, memloc))::future
+		   | Directive.Return {returns}
+		   => (List.map(returns, fn {dst, ...} => M (FDEF, dst))) @ future
 		   | Directive.ClearFlt
 		   => (MP (FMREMOVEP,
 			   fn memloc
@@ -6020,6 +6018,67 @@
 	     registerAllocation = registerAllocation}
 	  end
 
+      fun return {returns: {src: Operand.t, dst: MemLoc.t} list,
+		  info: Liveness.t,
+		  registerAllocation: t} =
+	 let
+	    val killed_values =
+	       valueFilter {filter = fn value as {memloc, ...} =>
+			    List.exists
+			    (returns, fn {dst = return_memloc, ...} =>
+			     List.exists(MemLoc.utilized memloc,
+					 fn memloc' =>
+					 MemLoc.eq(memloc', return_memloc))
+			     orelse
+			     MemLoc.mayAlias(return_memloc, memloc)),
+			    registerAllocation = registerAllocation}
+	    val killed_memlocs = List.revMap(killed_values, #memloc)
+
+	    val registerAllocation =
+	       removes {memlocs = killed_memlocs,
+			registerAllocation = registerAllocation}
+
+	    val registerAllocation =
+	       List.fold
+	       (returns, registerAllocation, fn ({src = operand, 
+						  dst = return_memloc}, registerAllocation) =>
+		case operand of
+		   Operand.Register return_register =>
+		      update {value = {register = return_register,
+				       memloc = return_memloc,
+				       weight = 1024,
+				       sync = false,
+				       commit = NO},
+			      registerAllocation = registerAllocation}
+	         | Operand.FltRegister return_register => 
+		      #registerAllocation
+		      (fltpush {value = {fltregister = return_register,
+					 memloc = return_memloc,
+					 weight = 1024,
+					 sync = false,
+					 commit = NO},
+				registerAllocation = registerAllocation})
+		 | _ => Error.bug "return")
+
+	    val (final_defs, defs) =
+	       List.fold
+	       (returns, ([],[]), fn ({src,dst},(final_defs,defs)) =>
+		(src::final_defs,(Operand.memloc dst)::defs))
+	    val {assembly = assembly_post,
+		 registerAllocation}
+	      = post {uses = [],
+		      final_uses = [],
+		      defs = defs,
+		      final_defs = final_defs,
+		      kills = [],
+		      info = info,
+		      registerAllocation = registerAllocation}
+	  in
+	    {assembly = assembly_post,
+	     registerAllocation = registerAllocation}
+	  end
+
+(*
       fun return {memloc = return_memloc,
 		  info: Liveness.t,
 		  registerAllocation: t}
@@ -6095,6 +6154,7 @@
 	    {assembly = assembly_post,
 	     registerAllocation = registerAllocation}
 	  end
+*)
 
       fun clearflt {info: Liveness.t,
 		    registerAllocation: t}
@@ -10709,16 +10769,11 @@
 		   => RegisterAllocation.ccall
 		      {info = info,
 		       registerAllocation = registerAllocation}
-		   | Return {memloc}
+		   | Return {returns}
 		   => RegisterAllocation.return
-		      {memloc = memloc,
+		      {returns = returns,
 		       info = info,
 		       registerAllocation = registerAllocation}
-		   | FltReturn {memloc}
-		   => RegisterAllocation.fltreturn
-		      {memloc = memloc,
-		       info = info,
-		       registerAllocation = registerAllocation}		      
 		   | Reserve {registers}
 		   => RegisterAllocation.reserve 
 		      {registers = registers,



1.44      +38 -39    mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun

Index: x86-generate-transfers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -r1.43 -r1.44
--- x86-generate-transfers.fun	25 Jul 2003 20:14:47 -0000	1.43
+++ x86-generate-transfers.fun	31 Jul 2003 23:10:33 -0000	1.44
@@ -506,30 +506,35 @@
 		       = case entry
 			   of Jump {label}
 			    => near label
-			    | CReturn {dst, frameInfo, func, label}
+			    | CReturn {dsts, frameInfo, func, label}
 			    => let
-				 fun getReturn ()
-				   = case dst 
-				       of NONE => AppendList.empty
-				        | SOME (dst, dstsize)
-					=> (case Size.class dstsize
-					      of Size.INT
-					       => AppendList.single
-						  (x86.Assembly.instruction_mov
-						   {dst = dst,
-						    src = Operand.memloc
-						          (MemLoc.cReturnTempContent 
-							   dstsize),
-						    size = dstsize})
-					       | Size.FLT
-					       => AppendList.single
-						  (x86.Assembly.instruction_pfmov
-						   {dst = dst,
-						    src = Operand.memloc
-						          (MemLoc.cReturnTempContent 
-							   dstsize),
-						    size = dstsize})
-					       | _ => Error.bug "CReturn")
+				 fun getReturn () =
+				    if Vector.length dsts = 0
+				       then AppendList.empty
+				       else let
+					       val srcs =
+						  case CFunction.return func of
+						     NONE => Vector.new0 ()
+						   | SOME ty =>
+							(Vector.fromList o List.map)
+							(Operand.cReturnTemps ty,
+							 fn {src, dst} => dst)
+					    in
+					       (AppendList.fromList o Vector.fold2)
+					       (dsts, srcs, [], fn ((dst,dstsize),src,stmts) =>
+						case Size.class dstsize of
+						   Size.INT =>
+						      (x86.Assembly.instruction_mov
+						       {dst = dst,
+							src = Operand.memloc src,
+							size = dstsize})::stmts
+						 | Size.FLT =>
+						      (x86.Assembly.instruction_pfmov
+						       {dst = dst,
+							src = Operand.memloc src,
+							size = dstsize})::stmts
+						 | _ => Error.bug "CReturn")
+					    end
 			       in
 				 case frameInfo of
 				   SOME fi =>
@@ -1073,12 +1078,13 @@
 			 {target = x86MLton.gcState_stackTopMinusWordDerefOperand (),
 			  absolute = true})))
 		    end
-	        | CCall {args, dstsize, frameInfo, func, return, target}
+	        | CCall {args, frameInfo, func, return, target}
 		=> let
 		     val CFunction.T {convention,
 				      maySwitchThreads,
 				      modifiesFrontier,
-				      modifiesStackTop, ...} = func
+				      modifiesStackTop, 
+				      return = returnTy, ...} = func
 		     val stackTopMinusWordDeref
 		       = x86MLton.gcState_stackTopMinusWordDerefOperand ()
 		     val {dead, ...}
@@ -1284,20 +1290,13 @@
 						   s
 						 end,
 				  dead_classes = ccallflushClasses})
-		     val getResult
-		       = case dstsize
-			   of NONE => AppendList.empty
-			    | SOME dstsize
-			    => (case Size.class dstsize
-				  of Size.INT
-				   => AppendList.single
-				      (Assembly.directive_return
-				       {memloc = MemLoc.cReturnTempContent dstsize})
-				   | Size.FLT 
-				   => AppendList.single
-				      (Assembly.directive_fltreturn
-				       {memloc = MemLoc.cReturnTempContent dstsize})
-				   | _ => Error.bug "CCall")
+		     val getResult =
+			case returnTy of
+			   NONE => AppendList.empty
+			 | SOME ty =>
+			      AppendList.single
+			      (Assembly.directive_return
+			       {returns = Operand.cReturnTemps ty})
 		     val fixCStack =
 			if size_args > 0
 			   andalso convention = CFunction.Convention.Cdecl



1.14      +15 -19    mlton/mlton/codegen/x86-codegen/x86-live-transfers.fun

Index: x86-live-transfers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-live-transfers.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- x86-live-transfers.fun	25 Jul 2003 20:14:47 -0000	1.13
+++ x86-live-transfers.fun	31 Jul 2003 23:10:33 -0000	1.14
@@ -861,24 +861,20 @@
 							liveFltRegsTransfers)}
 		      fun doit'' label = enque {label = label, 
 						hints = ([],[])}
-		      fun doit''' dstsize label 
+		      fun doit''' func label 
 			= enque {label = label,
-				 hints = case dstsize
-					   of NONE => ([],[])
-					    | SOME dstsize
-					    => (case Size.class dstsize
-						  of Size.INT 
-						   => ([(MemLoc.cReturnTempContent
-							 dstsize,
-							 Register.return dstsize,
-							 ref true)],
-						       [])
-						   | Size.FLT 
-						   => ([],
-						       [(MemLoc.cReturnTempContent
-							 dstsize,
-							 ref true)])
-						   | _ => Error.bug "CCall")}
+				 hints = case CFunction.return func of
+				           NONE => ([],[])
+					 | SOME ty =>
+					      List.fold
+					      (Operand.cReturnTemps ty,
+					       ([],[]), fn ({src, dst}, (regHints, fltregHints)) =>
+					       case src of
+						  Operand.Register reg =>
+						     ((dst, reg, ref true)::regHints, fltregHints)
+						| Operand.FltRegister reg =>
+						     (regHints, (dst, ref true)::fltregHints)
+						| _ => (regHints, fltregHints))}
 		      datatype z = datatype Transfer.t
 		    in
 		      case transfer
@@ -901,10 +897,10 @@
 			 => ()
 			 | Raise {...}
 			 => ()
-			 | CCall {dstsize, func, return, ...}
+			 | CCall {func, return, ...}
 			 => if CFunction.maySwitchThreads func
 			      then Option.app (return, doit'')
-			    else Option.app (return, doit''' dstsize)
+			    else Option.app (return, doit''' func)
 		    end
 	    end
 



1.22      +17 -39    mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun

Index: x86-mlton-basic.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- x86-mlton-basic.fun	25 Jul 2003 20:14:47 -0000	1.21
+++ x86-mlton-basic.fun	31 Jul 2003 23:10:33 -0000	1.22
@@ -36,44 +36,6 @@
   val normalHeaderBytes = Runtime.normalHeaderSize
   val arrayHeaderBytes = Runtime.arrayHeaderSize
   val intInfOverheadBytes = Runtime.intInfOverheadSize
-   
-  local
-     datatype z = datatype CType.t
-     datatype z = datatype x86.Size.t
-  in
-    fun toX86Size' t =
-       case t of
-	  Int s =>
-	     let
-		datatype z = datatype IntSize.t
-	     in
-		case s of
-		   I8 => BYTE
-		 | I16 => WORD
-		 | I32 => LONG
-		 | I64 => Error.bug "FIXME"
-	     end
-	| Pointer => LONG
-	| Real s =>
-	     let
-		datatype z = datatype RealSize.t
-	     in
-		case s of
-		   R32 => SNGL
-		 | R64 => DBLE
-	     end
-	| Word s =>
-	     let
-		datatype z = datatype WordSize.t
-	     in
-		case s of
-		   W8 => BYTE
-		 | W16 => WORD 
-		 | W32 => LONG
-	     end
-    val toX86Size = toX86Size'
-    fun toX86Scale t = x86.Scale.fromBytes (CType.size t)
-  end
 
   (*
    * Memory classes
@@ -327,6 +289,22 @@
   val fildTempContentsOperand
     = Operand.memloc fildTempContents
 
+  val eq1Temp = Label.fromString "eq1Temp"
+  val eq1TempContents 
+    = makeContents {base = Immediate.label eq1Temp,
+		    size = wordSize,
+		    class = Classes.StaticTemp}
+  val eq1TempContentsOperand
+    = Operand.memloc eq1TempContents
+  val eq2Temp = Label.fromString "eq2Temp"
+  val eq2TempContents 
+    = makeContents {base = Immediate.label eq2Temp,
+		    size = wordSize,
+		    class = Classes.StaticTemp}
+  val eq2TempContentsOperand
+    = Operand.memloc eq2TempContents
+
+
   local
     val localI_base =
        IntSize.memoize
@@ -510,7 +488,7 @@
   fun gcState_offset {offset, ty} =
     let
       val (_,_,operand) = 
-	make' (offset, toX86Size ty, Classes.GCState)
+	make' (offset, Vector.sub(x86.Size.fromCType ty, 0), Classes.GCState)
     in
       operand ()
     end



1.27      +2 -3      mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig

Index: x86-mlton-basic.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- x86-mlton-basic.sig	25 Jul 2003 20:14:47 -0000	1.26
+++ x86-mlton-basic.sig	31 Jul 2003 23:10:33 -0000	1.27
@@ -37,9 +37,6 @@
     val arrayHeaderBytes : int
     val intInfOverheadBytes : int
 
-    val toX86Size : x86.CFunction.CType.t -> x86.Size.t
-    val toX86Scale : x86.CFunction.CType.t -> x86.Scale.t
-
     (*
      * Memory classes
      *)
@@ -88,6 +85,8 @@
     val fildTempContentsOperand : x86.Operand.t
     val fpswTempContentsOperand : x86.Operand.t
     val statusTempContentsOperand : x86.Operand.t
+    val eq1TempContentsOperand : x86.Operand.t
+    val eq2TempContentsOperand : x86.Operand.t
 
     (* Static arrays defined in main.h and x86-main.h *)
     val local_base : x86.CFunction.CType.t -> x86.Label.t



1.49      +96 -75    mlton/mlton/codegen/x86-codegen/x86-mlton.fun

Index: x86-mlton.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.fun,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -r1.48 -r1.49
--- x86-mlton.fun	31 Jul 2003 20:32:59 -0000	1.48
+++ x86-mlton.fun	31 Jul 2003 23:10:33 -0000	1.49
@@ -30,16 +30,18 @@
 
   fun prim {prim : Prim.t,
 	    args : (Operand.t * Size.t) vector,
-	    dst : (Operand.t * Size.t) option,
+	    dsts : (Operand.t * Size.t) vector,
 	    transInfo as {live, liveInfo, ...} : transInfo}
     = let
 	val primName = Prim.toString prim
 	datatype z = datatype Prim.Name.t
 
-	fun getDst ()
-	  = case dst
-	      of SOME dst => dst
-	       | NONE => Error.bug "applyPrim: getDst"
+	fun getDst1 ()
+	  = Vector.sub (dsts, 0)
+	    handle _ => Error.bug "applyPrim: getDst1"
+	fun getDst2 ()
+	  = (Vector.sub (dsts, 0), Vector.sub (dsts, 1))
+	    handle _ => Error.bug "applyPrim: getDst2"
 	fun getSrc1 ()
 	  = Vector.sub (args, 0)
 	    handle _ => Error.bug "applyPrim: getSrc1"
@@ -49,6 +51,10 @@
 	fun getSrc3 ()
 	  = (Vector.sub (args, 0), Vector.sub (args, 1), Vector.sub (args, 2))
 	    handle _ => Error.bug "applyPrim: getSrc3"
+	fun getSrc4 ()
+	  = (Vector.sub (args, 0), Vector.sub (args, 1), 
+	     Vector.sub (args, 2), Vector.sub (args, 3))
+	    handle _ => Error.bug "applyPrim: getSrc4"
 
 	fun unimplemented s
 	  = AppendList.fromList
@@ -59,7 +65,7 @@
 
 	fun mov ()
 	  = let
-	      val (dst,dstsize) = getDst ()
+	      val (dst,dstsize) = getDst1 ()
 	      val (src,srcsize) = getSrc1 ()
 	      val _ 
 		= Assert.assert
@@ -79,7 +85,7 @@
 	  
 	fun movx oper
 	  = let
-	      val (dst,dstsize) = getDst ()
+	      val (dst,dstsize) = getDst1 ()
 	      val (src,srcsize) = getSrc1 ()
 	      val _ 
 		= Assert.assert
@@ -101,7 +107,7 @@
 
 	fun xvom ()
 	  = let
-	      val (dst,dstsize) = getDst ()
+	      val (dst,dstsize) = getDst1 ()
 	      val (src,srcsize) = getSrc1 ()
 	      val _ 
 		= Assert.assert
@@ -124,7 +130,7 @@
 	  = let
 	      val ((src1,src1size),
 		   (src2,src2size)) = getSrc2 ()
-	      val (dst,dstsize) = getDst ()
+	      val (dst,dstsize) = getDst1 ()
 	      val _ 
 		= Assert.assert
 		  ("applyPrim: binal, dstsize/src1size/src2size",
@@ -174,7 +180,7 @@
 	  = let
 	      val ((src1,src1size),
 		   (src2,src2size)) = getSrc2 ()
-	      val (dst,dstsize) = getDst ()
+	      val (dst,dstsize) = getDst1 ()
 	      val _ 
 		= Assert.assert
 		  ("applyPrim: pmd, dstsize/src1size/src2size",
@@ -218,7 +224,7 @@
 	  = let
 	      val ((src1,src1size),
 		   (src2,src2size)) = getSrc2 ()
-	      val (dst,dstsize) = getDst ()
+	      val (dst,dstsize) = getDst1 ()
 	      val _ 
 		= Assert.assert
 		  ("applyPrim: pmd, dstsize/src1size/src2size",
@@ -256,7 +262,7 @@
 	fun unal oper
 	  = let
 	      val (src,srcsize) = getSrc1 ()
-	      val (dst,dstsize) = getDst ()
+	      val (dst,dstsize) = getDst1 ()
 	      val _ 
 		= Assert.assert
 		  ("applyPrim: unal, dstsize/srcsize",
@@ -279,7 +285,7 @@
 
 	fun sral oper
 	  = let
-	      val (dst,dstsize) = getDst ()
+	      val (dst,dstsize) = getDst1 ()
 	      val ((src1,src1size),
 		   (src2,src2size)) = getSrc2 ()
 	      val _ 
@@ -309,7 +315,7 @@
 
 	fun cmp condition
 	  = let
-	      val (dst,dstsize) = getDst ()
+	      val (dst,dstsize) = getDst1 ()
 	      val ((src1,src1size),
 		   (src2,src2size)) = getSrc2 ()
 	      val _ 
@@ -356,7 +362,7 @@
 
 	fun test condition
 	  = let
-	      val (dst,dstsize) = getDst ()
+	      val (dst,dstsize) = getDst1 ()
 	      val ((src1,src1size),
 		   (src2,src2size)) = getSrc2 ()
 	      val _ 
@@ -403,7 +409,7 @@
 	  
 	fun fbina oper
 	  = let
-	      val (dst,dstsize) = getDst ()
+	      val (dst,dstsize) = getDst1 ()
 	      val ((src1,src1size),
 		   (src2,src2size)) = getSrc2 ()
 	      val _ 
@@ -442,7 +448,7 @@
 
 	fun fbina_fmul oper
 	  = let
-	      val (dst,dstsize) = getDst ()
+	      val (dst,dstsize) = getDst1 ()
 	      val ((src1,src1size),
 		   (src2,src2size),
 		   (src3,src3size)) = getSrc3 ()
@@ -476,7 +482,7 @@
 
 	fun funa oper
 	  = let
-	      val (dst,dstsize) = getDst ()
+	      val (dst,dstsize) = getDst1 ()
 	      val (src,srcsize) = getSrc1 ()
 	      val _ 
 		= Assert.assert
@@ -500,7 +506,7 @@
 
 	fun flogarithm oper
 	  = let
-	      val (dst,dstsize) = getDst ()
+	      val (dst,dstsize) = getDst1 ()
 	      val (src,srcsize) = getSrc1 ()
 	      val _ 
 		= Assert.assert
@@ -551,7 +557,7 @@
 	 (case Prim.name prim of
 	     Cpointer_isNull 
 	     => let
-		  val (dst,dstsize) = getDst ()
+		  val (dst,dstsize) = getDst1 ()
 		  val (src,srcsize) = getSrc1 ()
 		in
 		  AppendList.fromList
@@ -570,7 +576,7 @@
 		end
 	     | FFI_Symbol {name, ...}
 	     => let
-		   val (dst,dstsize) = getDst ()
+		   val (dst,dstsize) = getDst1 ()
 		   val memloc
 		      = x86.MemLoc.makeContents 
 		      {base = Immediate.label (Label.fromString name),
@@ -683,7 +689,7 @@
 	     => let
 		  fun default () =
 		    let
-		      val (dst,dstsize) = getDst ()
+		      val (dst,dstsize) = getDst1 ()
 		      val (src,srcsize) = getSrc1 ()
 		    in
 		      AppendList.fromList
@@ -699,7 +705,7 @@
 		    end 
 		  fun default' () =
 		    let
-		      val (dst,dstsize) = getDst ()
+		      val (dst,dstsize) = getDst1 ()
 		      val (src,srcsize) = getSrc1 ()
 		      val (tmp,tmpsize) =
 			 (fildTempContentsOperand, Size.WORD)
@@ -749,7 +755,7 @@
 	     | MLton_eq => cmp Instruction.E
 	     | Real_Math_acos _
 	     => let
-		  val (dst,dstsize) = getDst ()
+		  val (dst,dstsize) = getDst1 ()
 		  val (src,srcsize) = getSrc1 ()
 		  val _
 		    = Assert.assert
@@ -802,7 +808,7 @@
 		end
 	     | Real_Math_asin _
 	     => let
-		  val (dst,dstsize) = getDst ()
+		  val (dst,dstsize) = getDst1 ()
 		  val (src,srcsize) = getSrc1 ()
 		  val _
 		    = Assert.assert
@@ -851,7 +857,7 @@
 		end
 	     | Real_Math_atan _
 	     => let
-		  val (dst,dstsize) = getDst ()
+		  val (dst,dstsize) = getDst1 ()
 		  val (src,srcsize) = getSrc1 ()
 		  val _
 		    = Assert.assert
@@ -882,7 +888,7 @@
 		end
 	     | Real_Math_atan2 _
 	     => let
-		  val (dst,dstsize) = getDst ()
+		  val (dst,dstsize) = getDst1 ()
 		  val ((src1,src1size),
 		       (src2,src2size))= getSrc2 ()
 		  val _
@@ -909,7 +915,7 @@
 	     | Real_Math_cos _ => funa Instruction.FCOS
 	     | Real_Math_exp _
 	     => let
-		  val (dst,dstsize) = getDst ()
+		  val (dst,dstsize) = getDst1 ()
 		  val (src,srcsize) = getSrc1 ()
 		  val _
 		    = Assert.assert
@@ -971,7 +977,7 @@
 	     | Real_Math_sqrt _ => funa Instruction.FSQRT
 	     | Real_Math_tan _
 	     => let
-		  val (dst,dstsize) = getDst ()
+		  val (dst,dstsize) = getDst1 ()
 		  val (src,srcsize) = getSrc1 ()
 		  val _
 		    = Assert.assert
@@ -999,7 +1005,7 @@
 	     | Real_div _ => fbina Instruction.FDIV
 	     | Real_lt _
 	     => let
-		  val (dst,dstsize) = getDst ()
+		  val (dst,dstsize) = getDst1 ()
 		  val ((src1,src1size),
 		       (src2,src2size))= getSrc2 ()
 		  val _
@@ -1030,7 +1036,7 @@
 		end
 	     | Real_le _
 	     => let
-		  val (dst,dstsize) = getDst ()
+		  val (dst,dstsize) = getDst1 ()
 		  val ((src1,src1size),
 		       (src2,src2size))= getSrc2 ()
 		  val _
@@ -1061,7 +1067,7 @@
 		end
 	     | Real_equal _
 	     => let
-		  val (dst,dstsize) = getDst ()
+		  val (dst,dstsize) = getDst1 ()
 		  val ((src1,src1size),
 		       (src2,src2size))= getSrc2 ()
 		  val _
@@ -1097,7 +1103,7 @@
 		end
 	     | Real_gt _
 	     => let
-		  val (dst,dstsize) = getDst ()
+		  val (dst,dstsize) = getDst1 ()
 		  val ((src1,src1size),
 		       (src2,src2size))= getSrc2 ()
 		  val _
@@ -1128,7 +1134,7 @@
 		end
 	     | Real_ge _
 	     => let
-		  val (dst,dstsize) = getDst ()
+		  val (dst,dstsize) = getDst1 ()
 		  val ((src1,src1size),
 		       (src2,src2size))= getSrc2 ()
 		  val _
@@ -1159,7 +1165,7 @@
 		end
 	     | Real_qequal _
 	     => let
-		  val (dst,dstsize) = getDst ()
+		  val (dst,dstsize) = getDst1 ()
 		  val ((src1,src1size),
 		       (src2,src2size))= getSrc2 ()
 		  val _
@@ -1193,7 +1199,7 @@
 	     => let
 		  fun default () =
 		    let
-		      val (dst,dstsize) = getDst ()
+		      val (dst,dstsize) = getDst1 ()
 		      val (src,srcsize) = getSrc1 ()
 		    in
 		      AppendList.fromList
@@ -1209,7 +1215,7 @@
 		    end 
 		  fun default' () =
 		    let
-		      val (dst,dstsize) = getDst ()
+		      val (dst,dstsize) = getDst1 ()
 		      val (src,srcsize) = getSrc1 ()
 		      val (tmp,tmpsize) =
 			 (fildTempContentsOperand, Size.WORD)
@@ -1243,7 +1249,7 @@
 		end
              | Real_toReal (s, s')
 	     => let
-		  val (dst,dstsize) = getDst ()
+		  val (dst,dstsize) = getDst1 ()
 		  val (src,srcsize) = getSrc1 ()
 		  fun mov () =
 		     AppendList.fromList
@@ -1286,7 +1292,7 @@
 		end 
 	     | Real_ldexp _ 
 	     => let
-		  val (dst,dstsize) = getDst ()
+		  val (dst,dstsize) = getDst1 ()
 		  val ((src1,src1size),
 		       (src2,src2size)) = getSrc2 ()
 		  val _
@@ -1403,7 +1409,7 @@
 	     return: x86.Label.t option,
 	     transInfo: transInfo}
     = let
-	val CFunction.T {convention, name, return = returnTy, ...} = func
+	val CFunction.T {convention, name, ...} = func
 	val name =
 	   if convention = CFunction.Convention.Stdcall
 	      then
@@ -1415,7 +1421,6 @@
 		    concat [name, "@", Int.toString argsSize]
 		 end
 	   else name
-	val dstsize = Option.map (returnTy, toX86Size)
 	val comment_begin
 	  = if !Control.Native.commented > 0
 	      then AppendList.single (x86.Block.mkBlock'
@@ -1434,24 +1439,19 @@
 	   statements = [],
 	   transfer = SOME (Transfer.ccall 
 			    {args = Vector.toList args,
-			     dstsize = dstsize,
 			     frameInfo = frameInfo,
 			     func = func,
 			     return = return,
 			     target = Label.fromString name})})]
       end
 
-  fun creturn {dst: (x86.Operand.t * x86.Size.t) option,
+  fun creturn {dsts: (x86.Operand.t * x86.Size.t) vector,
 	       frameInfo: x86.FrameInfo.t option,
 	       func: CFunction.t,
 	       label: x86.Label.t, 
 	       transInfo as {live, liveInfo, ...}: transInfo}
     = let
 	val name = CFunction.name func
-	fun getDst ()
-	  = case dst
-	      of SOME dst => dst
-	       | NONE => Error.bug "creturn: getDst"
 	fun default ()
 	  = let
 	      val _ = x86Liveness.LiveInfo.setLiveOperands
@@ -1459,7 +1459,7 @@
 	    in 
 	      AppendList.single
 	      (x86.Block.mkBlock'
-	       {entry = SOME (Entry.creturn {dst = dst,
+	       {entry = SOME (Entry.creturn {dsts = dsts,
 					     frameInfo = frameInfo,
 					     func = func,
 					     label = label}),
@@ -1480,7 +1480,7 @@
 
   fun arith {prim : Prim.t,
 	     args : (Operand.t * Size.t) vector,
-	     dst : (Operand.t * Size.t),
+	     dsts : (Operand.t * Size.t) vector,
 	     overflow : Label.t,
 	     success : Label.t,
 	     transInfo as {live, liveInfo, ...} : transInfo}
@@ -1488,21 +1488,34 @@
 	val primName = Prim.toString prim
 	datatype z = datatype Prim.Name.t
 
-	fun arg i = Vector.sub (args, i)
-	  
-	val (src1, src1size) = arg 0
-	val (dst, dstsize) = dst
-	val _ = Assert.assert
-	        ("arith: dstsize/srcsize",
-		 fn () => src1size = dstsize)
-	fun check (src, statement, condition)
+	fun getDst1 ()
+	  = Vector.sub (dsts, 0)
+	    handle _ => Error.bug "arith: getDst1"
+	fun getDst2 ()
+	  = (Vector.sub (dsts, 0), Vector.sub (dsts, 1))
+	    handle _ => Error.bug "arith: getDst2"
+	fun getSrc1 ()
+	  = Vector.sub (args, 0)
+	    handle _ => Error.bug "arith: getSrc1"
+	fun getSrc2 ()
+	  = (Vector.sub (args, 0), Vector.sub (args, 1))
+	    handle _ => Error.bug "arith: getSrc2"
+	fun getSrc3 ()
+	  = (Vector.sub (args, 0), Vector.sub (args, 1), Vector.sub (args, 2))
+	    handle _ => Error.bug "arith: getSrc3"
+	fun getSrc4 ()
+	  = (Vector.sub (args, 0), Vector.sub (args, 1), 
+	     Vector.sub (args, 2), Vector.sub (args, 3))
+	    handle _ => Error.bug "arith: getSrc4"
+
+	fun check (dst, src, size, statement, condition)
 	  = AppendList.single
 	    (x86.Block.mkBlock'
 	     {entry = NONE,	
 	      statements = [x86.Assembly.instruction_mov
 			    {dst = dst,
 			     src = src,
-			     size = src1size},
+			     size = size},
 			    statement],
 	      transfer = SOME (x86.Transfer.iff
 			       {condition = condition,
@@ -1510,10 +1523,11 @@
 				falsee = success})})
 	fun binal (oper: x86.Instruction.binal, condition)
 	  = let
-	      val (src2, src2size) = arg 1
+	      val (dst, dstsize) = getDst1 ()
+	      val ((src1, src1size), (src2, src2size)) = getSrc2 ()
 	      val _ = Assert.assert
-		      ("arith: binal, dstsize/src2size",
-		       fn () => src2size = dstsize)
+		      ("arith: binal, dstsize/src1size/src2size",
+		       fn () => src1size = dstsize andalso src2size = dstsize)
 	      (* Reverse src1/src2 when src1 and src2 are
 	       * temporaries and the oper is commutative. 
 	       *)
@@ -1530,7 +1544,7 @@
 			    | _ => (src1,src2)
 		    else (src1,src2)
 	    in
-	      check (src1,
+	      check (dst, src1, dstsize,
 		     x86.Assembly.instruction_binal
 		     {oper = oper,
 		      dst = dst,
@@ -1540,10 +1554,11 @@
 	    end
  	fun pmd (oper: x86.Instruction.md, condition)
   	  = let
- 	      val (src2, src2size) = arg 1
- 	      val _ = Assert.assert
- 		      ("arith: pmd, dstsize/src2size",
- 		       fn () => src2size = dstsize)
+	      val (dst, dstsize) = getDst1 ()
+	      val ((src1, src1size), (src2, src2size)) = getSrc2 ()
+	      val _ = Assert.assert
+		      ("arith: pmd, dstsize/src1size/src2size",
+		       fn () => src1size = dstsize andalso src2size = dstsize)
  	      (* Reverse src1/src2 when src1 and src2 are
  	       * temporaries and the oper is commutative. 
  	       *)
@@ -1560,7 +1575,7 @@
  			    | _ => (src1,src2)
  		    else (src1,src2)
  	    in
- 	      check (src1,
+ 	      check (dst, src1, dstsize,
 		     x86.Assembly.instruction_pmd
  		     {oper = oper,
  		      dst = dst,
@@ -1570,20 +1585,26 @@
  	    end
 	fun unal (oper: x86.Instruction.unal, condition)
 	  = let
+	      val (dst, dstsize) = getDst1 ()
+	      val (src1, src1size) = getSrc1 ()
+	      val _ = Assert.assert
+		      ("arith: unal, dstsize/src1size",
+		       fn () => src1size = dstsize)
 	    in
-	      check (src1,
+	      check (dst, src1, dstsize,
 		     x86.Assembly.instruction_unal 
 		     {oper = oper,
 		      dst = dst,
 		      size = dstsize},
 		     condition)
 	    end
-	fun imul2_check condition
+	fun imul2 condition
 	  = let
-	      val (src2, src2size) = arg 1
+	      val (dst, dstsize) = getDst1 ()
+	      val ((src1, src1size), (src2, src2size)) = getSrc2 ()
 	      val _ = Assert.assert
-		      ("arith: imul2_check, dstsizesrc2size",
-		       fn () => src2size = dstsize)
+		      ("arith: imul2, dstsize/src1size/src2size",
+		       fn () => src1size = dstsize andalso src2size = dstsize)
 	      (* Reverse src1/src2 when src1 and src2 are
 	       * temporaries and the oper is commutative. 
 	       *)
@@ -1598,7 +1619,7 @@
 			  else (src1,src2)
 		     | _ => (src1,src2)
 	    in
-	      check (src1,
+	      check (dst, src1, dstsize,
 		     x86.Assembly.instruction_imul2
 		     {dst = dst,
 		      src = src2,
@@ -1637,8 +1658,8 @@
 	   | Int_mulCheck s => 
 	       (case s of
 		  I8 => pmd (x86.Instruction.IMUL, x86.Instruction.O)
-		| I16 => imul2_check x86.Instruction.O
-		| I32 => imul2_check x86.Instruction.O
+		| I16 => imul2 x86.Instruction.O
+		| I32 => imul2 x86.Instruction.O
 		| I64 => Error.bug "FIXME")
 	   | Int_negCheck _ => unal (x86.Instruction.NEG, x86.Instruction.O)
 	   | Word_addCheck _ => binal (x86.Instruction.ADD, x86.Instruction.C)



1.15      +10 -10    mlton/mlton/codegen/x86-codegen/x86-mlton.sig

Index: x86-mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.sig,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- x86-mlton.sig	19 Dec 2002 23:43:34 -0000	1.14
+++ x86-mlton.sig	31 Jul 2003 23:10:33 -0000	1.15
@@ -31,24 +31,24 @@
 		      liveInfo: x86Liveness.LiveInfo.t}
 
     (* arith, c call, and primitive assembly sequences. *)
-    val arith: {prim : Machine.Prim.t,
-		args : (x86.Operand.t * x86.Size.t) vector,
-		dst : (x86.Operand.t * x86.Size.t),
-		overflow : x86.Label.t,
-		success : x86.Label.t,
+    val arith: {prim: Machine.Prim.t,
+		args: (x86.Operand.t * x86.Size.t) vector,
+		dsts: (x86.Operand.t * x86.Size.t) vector,
+		overflow: x86.Label.t,
+		success: x86.Label.t,
 		transInfo : transInfo} -> x86.Block.t' AppendList.t
     val ccall: {args: (x86.Operand.t * x86.Size.t) vector,
 		frameInfo: x86.FrameInfo.t option,
 		func: Machine.CFunction.t,
 		return: x86.Label.t option,
 		transInfo: transInfo} -> x86.Block.t' AppendList.t
-    val creturn: {dst: (x86.Operand.t * x86.Size.t) option,
+    val creturn: {dsts: (x86.Operand.t * x86.Size.t) vector,
 		  frameInfo: x86.FrameInfo.t option,
 		  func: Machine.CFunction.t,
 		  label: x86.Label.t, 
 		  transInfo: transInfo} -> x86.Block.t' AppendList.t
-    val prim: {prim : Machine.Prim.t,
-	       args : (x86.Operand.t * x86.Size.t) vector,
-	       dst : (x86.Operand.t * x86.Size.t) option,
-	       transInfo : transInfo} -> x86.Block.t' AppendList.t
+    val prim: {prim: Machine.Prim.t,
+	       args: (x86.Operand.t * x86.Size.t) vector,
+	       dsts: (x86.Operand.t * x86.Size.t) vector,
+	       transInfo: transInfo} -> x86.Block.t' AppendList.t
   end



1.20      +7 -2      mlton/mlton/codegen/x86-codegen/x86-pseudo.sig

Index: x86-pseudo.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-pseudo.sig,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- x86-pseudo.sig	25 Jul 2003 20:14:47 -0000	1.19
+++ x86-pseudo.sig	31 Jul 2003 23:10:33 -0000	1.20
@@ -29,6 +29,7 @@
 	  | FPIS | FPIL | FPIQ
 	val fromBytes : int -> t
 	val toBytes : t -> int
+	val fromCType : CFunction.CType.t -> t vector
 	val class : t -> class
 	val eq : t * t -> bool
 	val lt : t * t -> bool
@@ -74,6 +75,7 @@
       sig
 	datatype t = One | Two | Four | Eight
 	val fromBytes : int -> t
+	val fromCType : CFunction.CType.t -> t
       end
 
     structure MemLoc :
@@ -113,6 +115,10 @@
 		       scale: Scale.t,
 		       size: Size.t,
 		       class: Class.t} -> t
+	val shift : {origin: t,
+		     disp: Immediate.t,
+		     scale: Scale.t,
+		     size: Size.t} -> t
 	  
 	val class : t -> Class.t
 	val compare : t * t -> order
@@ -416,7 +422,7 @@
 	val cont: {label: Label.t,
 		   live: MemLocSet.t,
 		   frameInfo: FrameInfo.t} -> t
-	val creturn: {dst: (Operand.t * Size.t) option,
+	val creturn: {dsts: (Operand.t * Size.t) vector,
 		      frameInfo: FrameInfo.t option,
 		      func: CFunction.t,
 		      label: Label.t} -> t
@@ -459,7 +465,6 @@
 	val return : {live: MemLocSet.t} -> t 
 	val raisee : {live: MemLocSet.t} -> t
 	val ccall : {args: (Operand.t * Size.t) list,
-		     dstsize: Size.t option,
 		     frameInfo: FrameInfo.t option,
 		     func: CFunction.t,
 		     return: Label.t option,



1.47      +315 -153  mlton/mlton/codegen/x86-codegen/x86-translate.fun

Index: x86-translate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-translate.fun,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- x86-translate.fun	25 Jul 2003 20:14:47 -0000	1.46
+++ x86-translate.fun	31 Jul 2003 23:10:33 -0000	1.47
@@ -53,20 +53,31 @@
      struct
 	open Machine.Global
 
-	fun toX86MemLoc (g: t) =
+	fun toX86Operand (g: t) : (x86.Operand.t * x86.Size.t) vector =
 	   let
 	      val ty = Machine.Type.toCType (ty g)
+	      val index = index g
 	      val base =
 		 x86.Immediate.label
 		 (if isRoot g
 		     then x86MLton.global_base ty
 		  else x86MLton.globalPointerNonRoot_base)
+	      val origin =
+		 x86.MemLoc.imm
+		 {base = base,
+		  index = x86.Immediate.const_int index,
+		  scale = x86.Scale.fromCType ty,
+		  size = x86.Size.BYTE,
+		  class = x86MLton.Classes.Globals}
+	      val sizes = x86.Size.fromCType ty
 	   in
-	      x86.MemLoc.imm {base = base,
-			      index = x86.Immediate.const_int (index g),
-			      scale = x86MLton.toX86Scale ty,
-			      size = x86MLton.toX86Size ty,
-			      class = x86MLton.Classes.Globals}
+	      (#1 o Vector.mapAndFold)
+	      (sizes, 0, fn (size,offset) =>
+	       (((x86.Operand.memloc o x86.MemLoc.shift)
+		 {origin = origin,
+		  disp = x86.Immediate.const_int offset,
+		  scale = x86.Scale.One,
+		  size = size}, size), offset + x86.Size.toBytes size))
 	   end
 
 	val toString = Layout.toString o layout
@@ -76,15 +87,26 @@
     struct
       open Machine.Operand
 
-      val toX86Size = x86MLton.toX86Size o Type.toCType o ty
-
-      val rec toX86Operand =
-	 fn ArrayOffset {base, index, ty} =>
-	       let
+      fun get (f: ('a * 'b) -> 'c) (i: int) (v: ('a * 'b) vector) =
+	 f (Vector.sub (v, i))
+	 handle _ => Error.bug (concat ["toX86Operand: get"])
+      fun getOp0 v =
+	 get #1 0 v
+
+      val rec toX86Operand : t -> (x86.Operand.t * x86.Size.t) vector =
+	 fn ArrayOffset {base, index, ty}
+ 	    => let
 		  val base = toX86Operand base
+		  val _ = Assert.assert("x86Translate.Operand.toX86Operand: Array/base",
+					fn () => Vector.length base = 1)
+		  val base = getOp0 base
 		  val index = toX86Operand index
+		  val _ = Assert.assert("x86Translate.Operand.toX86Operand: Array/index",
+				       fn () => Vector.length index = 1)
+		  val index = getOp0 index
+		     
 		  val ty = Type.toCType ty
-		  val memloc =
+		  val origin =
 		     case (x86.Operand.deMemloc base,
 			   x86.Operand.deImmediate index,
 			   x86.Operand.deMemloc index) of
@@ -92,126 +114,258 @@
 			   x86.MemLoc.simple 
 			   {base = base,
 			    index = index,
-			    scale = x86MLton.toX86Scale ty,
-			    size = x86MLton.toX86Size ty,
+			    scale = x86.Scale.fromCType ty,
+			    size = x86.Size.BYTE,
 			    class = x86MLton.Classes.Heap}
 		      | (SOME base, _, SOME index) =>
 			   x86.MemLoc.complex 
 			   {base = base,
 			    index = index,
-			    scale = x86MLton.toX86Scale ty,
-			    size = x86MLton.toX86Size ty,
+			    scale = x86.Scale.fromCType ty,
+			    size = x86.Size.BYTE,
 			    class = x86MLton.Classes.Heap}
 		      | _ => Error.bug (concat ["toX86Operand: strange Offset:",
 						" base: ",
 						x86.Operand.toString base,
 						" index: ",
 						x86.Operand.toString index])
+		  val sizes = x86.Size.fromCType ty
 	       in
-		  x86.Operand.memloc memloc
+		  (#1 o Vector.mapAndFold)
+		  (sizes, 0, fn (size,offset) =>
+		   (((x86.Operand.memloc o x86.MemLoc.shift)
+		     {origin = origin,
+		      disp = x86.Immediate.const_int offset,
+		      scale = x86.Scale.One,
+		      size = size}, size), offset + x86.Size.toBytes size))
 	       end
 	  | Cast (z, _) => toX86Operand z
 	  | Contents {oper, ty} =>
 	       let
 		  val ty = Type.toCType ty
 		  val base = toX86Operand oper
+		  val _ = Assert.assert("x86Translate.Operand.toX86Operand: Contents/base",
+					fn () => Vector.length base = 1)
+		  val base = getOp0 base
 		  val offset = x86.Immediate.const_int 0
-		  val size = x86MLton.toX86Size ty
-		  val memloc =
+		  val origin =
 		     case x86.Operand.deMemloc base of
 			SOME base =>
 			   x86.MemLoc.simple 
 			   {base = base,
 			    index = x86.Immediate.const_int 0,
 			    scale = x86.Scale.One,
-			    size = x86MLton.toX86Size ty,
+			    size = x86.Size.BYTE,
 			    class = x86MLton.Classes.Heap}
 		      | _ => Error.bug (concat
 					["toX86Operand: strange Contents",
 					 " base: ",
-					 x86.Operand.toString base])
+					 x86.Operand.toString base])	
+		  val sizes = x86.Size.fromCType ty
+	       in
+		  (#1 o Vector.mapAndFold)
+		  (sizes, 0, fn (size,offset) =>
+		   (((x86.Operand.memloc o x86.MemLoc.shift)
+		     {origin = origin,
+		      disp = x86.Immediate.const_int offset,
+		      scale = x86.Scale.One,
+		      size = size}, size), offset + x86.Size.toBytes size))
+	       end
+	  | File => Vector.new1 (x86MLton.fileName, x86MLton.pointerSize)
+	  | Frontier => 
+	       let 
+		  val frontier = x86MLton.gcState_frontierContentsOperand ()
 	       in
-		  x86.Operand.memloc memloc
+		  Vector.new1 (frontier, valOf (x86.Operand.size frontier))
 	       end
-	  | File => x86MLton.fileName
-	  | Frontier => x86MLton.gcState_frontierContentsOperand ()
-	  | GCState => x86.Operand.label x86MLton.gcState_label
-	  | Global g => x86.Operand.memloc (Global.toX86MemLoc g)
+	  | GCState => 
+	       Vector.new1 (x86.Operand.label x86MLton.gcState_label,
+			    x86MLton.pointerSize)
+	  | Global g => Global.toX86Operand g
 	  | Int i =>
 	       let
-		  val i' = IntX.toIntInf i
+		  val i'' = fn () => x86.Operand.immediate_const_int (IntX.toInt i)
 	       in
-		  x86.Operand.immediate_const_int (IntInf.toInt i')
+		  case IntX.size i of
+		     I8 => Vector.new1 (i'' (), x86.Size.BYTE)
+		   | I16 => Vector.new1 (i'' (), x86.Size.WORD)
+		   | I32 => Vector.new1 (i'' (), x86.Size.LONG)
+		   | I64 => let
+			       fun convert1 (ii: IntInf.t): Word.t * Word.t =
+				  let
+				     val lo = Word.fromIntInf ii
+				     val ii = IntInf.~>> (ii, 0w32)
+				     val hi = Word.fromIntInf ii
+				  in
+				     (lo, hi)
+				  end
+(*
+			       fun convert2 (ii: IntInf.t): Word.t * Word.t =
+				  let
+				     fun finish (iis: String.t, c: Char.t) =
+					let
+					   val s =
+					      String.concat
+					      [String.tabulate
+					       (16 - String.size iis, fn _ => c),
+					       iis]
+					   fun cvt s = valOf (Word.fromString s)
+					   val lo = cvt(String.extract(s, 8, SOME 8))
+					   val hi = cvt(String.extract(s, 0, SOME 8))
+					in
+					   (lo, hi)
+					end
+				  in
+				     if IntInf.<(ii, IntInf.fromInt 0)
+					then let
+						val ii = IntInf.-(IntInf.~ ii, IntInf.fromInt 1)
+						val iis =
+						   String.translate
+						   (IntInf.format(ii, StringCvt.HEX),
+						    fn #"0" => "F"
+						     | #"1" => "E"
+						     | #"2" => "D"
+						     | #"3" => "C"
+						     | #"4" => "B"
+						     | #"5" => "A"
+						     | #"6" => "9"
+						     | #"7" => "8"
+						     | #"8" => "7"
+						     | #"9" => "6"
+						     | #"A" => "5"
+						     | #"B" => "4"
+						     | #"C" => "3"
+						     | #"D" => "2"
+						     | #"E" => "1"
+						     | #"F" => "0"
+						     | #"a" => "5"
+						     | #"b" => "4"
+						     | #"c" => "3"
+						     | #"d" => "2"
+						     | #"e" => "1"
+						     | #"f" => "0"
+						     | c => "")
+					     in
+						finish (iis, #"F")
+					     end
+					else finish (IntInf.format(ii, StringCvt.HEX), #"0")
+				  end
+*)
+			       val ii = IntX.toIntInf i
+			       val (lo, hi) = convert1 ii
+			    in
+			       Vector.new2
+			       ((x86.Operand.immediate_const_word lo, x86.Size.LONG),
+				(x86.Operand.immediate_const_word hi, x86.Size.LONG))
+			    end
 	       end
-	  | Label l => x86.Operand.immediate_label l
-	  | Line => x86MLton.fileLine ()
+	  | Label l => 
+	       Vector.new1 (x86.Operand.immediate_label l, x86MLton.pointerSize)
+	  | Line => 
+	       Vector.new1 (x86MLton.fileLine (), x86MLton.wordSize)
 	  | Offset {base = GCState, offset, ty} =>
 	       let
-		 val ty = Type.toCType ty
+		  val ty = Type.toCType ty
+		  val offset = x86MLton.gcState_offset {offset = offset, ty = ty}
 	       in
-		 x86MLton.gcState_offset {offset = offset, ty = ty}
+		  Vector.new1 (offset, valOf (x86.Operand.size offset))
 	       end
 	  | Offset {base, offset, ty} =>
 	       let
-		 val base = toX86Operand base
 		 val ty = Type.toCType ty
-		 val memloc =
+		 val base = toX86Operand base
+		 val _ = Assert.assert("x86Translate.Operand.toX86Operand: Contents/base",
+				       fn () => Vector.length base = 1)
+		 val base = getOp0 base
+		 val origin =
 		   case x86.Operand.deMemloc base of
 		     SOME base =>
 		       x86.MemLoc.simple 
 		       {base = base,
 			index = x86.Immediate.const_int offset,
 			scale = x86.Scale.One,
-			size = x86MLton.toX86Size ty,
+			size = x86.Size.BYTE,
 			class = x86MLton.Classes.Heap}
 		   | _ => Error.bug (concat ["toX86Operand: strange Offset:",
 					     " base: ",
 					     x86.Operand.toString base])
+		  val sizes = x86.Size.fromCType ty
 	       in
-		 x86.Operand.memloc memloc
+		  (#1 o Vector.mapAndFold)
+		  (sizes, 0, fn (size,offset) =>
+		   (((x86.Operand.memloc o x86.MemLoc.shift)
+		     {origin = origin,
+		      disp = x86.Immediate.const_int offset,
+		      scale = x86.Scale.One,
+		      size = size}, size), offset + x86.Size.toBytes size))
 	       end
 	  | Real _ => Error.bug "toX86Operand: Real unimplemented"
 	  | Register r =>
 	       let
 		  val ty = Machine.Type.toCType (Register.ty r)
+		  val index = Machine.Register.index r
 		  val base = x86.Immediate.label (x86MLton.local_base ty)
+		  val sizes = x86.Size.fromCType ty
+		  val origin =
+		     x86.MemLoc.imm
+		     {base = base,
+		      index = x86.Immediate.const_int index,
+		      scale = x86.Scale.fromCType ty,
+		      size = x86.Size.BYTE,
+		      class = x86MLton.Classes.Locals}
+		  val sizes = x86.Size.fromCType ty
 	       in
-		  x86.Operand.memloc
-		  (x86.MemLoc.imm {base = base,
-				   index = (x86.Immediate.const_int
-					    (Register.index r)),
-				   scale = x86MLton.toX86Scale ty,
-				   size = x86MLton.toX86Size ty,
-				   class = x86MLton.Classes.Locals})
+		  (#1 o Vector.mapAndFold)
+		  (sizes, 0, fn (size,offset) =>
+		   (((x86.Operand.memloc o x86.MemLoc.shift)
+		     {origin = origin,
+		      disp = x86.Immediate.const_int offset,
+		      scale = x86.Scale.One,
+		      size = size}, size), offset + x86.Size.toBytes size))
 	       end
-	  | SmallIntInf ii => x86.Operand.immediate_const_word ii
+	  | SmallIntInf ii => 
+	       Vector.new1 (x86.Operand.immediate_const_word ii,x86.Size.LONG)
 	  | StackOffset {offset, ty} =>
 	       let
 		  val ty = Type.toCType ty
-		  val memloc =
+		  val origin =
 		     x86.MemLoc.simple 
 		     {base = x86MLton.gcState_stackTopContents (), 
 		      index = x86.Immediate.const_int offset,
 		      scale = x86.Scale.One,
-		      size = x86MLton.toX86Size ty,
+		      size = x86.Size.BYTE,
 		      class = x86MLton.Classes.Stack}
+		  val sizes = x86.Size.fromCType ty
 	       in
-		  x86.Operand.memloc memloc
+		  (#1 o Vector.mapAndFold)
+		  (sizes, 0, fn (size,offset) =>
+		   (((x86.Operand.memloc o x86.MemLoc.shift)
+		     {origin = origin,
+		      disp = x86.Immediate.const_int offset,
+		      scale = x86.Scale.One,
+		      size = size}, size), offset + x86.Size.toBytes size))
+	       end
+	  | StackTop => 
+	       let 
+		  val stackTop = x86MLton.gcState_stackTopContentsOperand ()
+	       in
+		  Vector.new1 (stackTop, valOf (x86.Operand.size stackTop))
 	       end
-	  | StackTop => x86MLton.gcState_stackTopContentsOperand ()
 	  | Word w =>
 	       let
 		  val w' = WordX.toWord w
+		  val w'' = x86.Operand.immediate_const_word w'
 	       in
-		  x86.Operand.immediate_const_word w'
+		  case WordX.size w of
+		     W8 => Vector.new1 (w'', x86.Size.BYTE)
+		   | W16 => Vector.new1 (w'', x86.Size.WORD)
+		   | W32 => Vector.new1 (w'', x86.Size.LONG)
 	       end
 	       
       val toX86Operand =
 	 fn operand =>
 	 toX86Operand operand
 	 handle exn => Error.reraise (exn, "x86Translate.Operand.toX86Operand")
-
-      fun convert x = (toX86Operand x, toX86Size x)
     end
 
   type transInfo = x86MLton.transInfo
@@ -257,15 +411,16 @@
 	      | Kind.Cont {args, frameInfo, ...}
 	      => let
 		    val frameInfo = frameInfoToX86 frameInfo
-		   val args
-		     = Vector.fold
-		       (args,
-			x86.MemLocSet.empty,
-			fn (operand, args)
-			 => case x86.Operand.deMemloc
-			         (Operand.toX86Operand operand)
-			      of SOME memloc => x86.MemLocSet.add(args, memloc)
-			       | NONE => args)
+		    val args =
+		       Vector.fold
+		       (args, x86.MemLocSet.empty,
+			fn (operand,args) =>
+			Vector.fold
+			(Operand.toX86Operand operand, args,
+			 fn ((operand,size),args) =>
+			 case x86.Operand.deMemloc operand of
+			    SOME memloc => x86.MemLocSet.add(args, memloc)
+			  | NONE => args))
 		 in
 		   AppendList.single
 		   (x86.Block.mkBlock'
@@ -289,10 +444,13 @@
 		 end
 	      | Kind.CReturn {dst, frameInfo, func}
 	      => let
-		   val dst = Option.map (dst, Operand.convert)
+		   val dsts =
+		      case dst of
+			 NONE => Vector.new0 ()
+		       | SOME dst => Operand.toX86Operand dst
 		 in
 		   x86MLton.creturn
-		   {dst = dst,
+		   {dsts = dsts,
 		    frameInfo = Option.map (frameInfo, frameInfoToX86),
 		    func = func,
 		    label = label,
@@ -336,16 +494,8 @@
 		   val (comment_begin,
 			comment_end) = comments statement
 		     
-		   val dstsize = Operand.toX86Size dst
-		   val dst = Operand.toX86Operand dst
-		     
-		   val srcsize = Operand.toX86Size src
-		   val src = Operand.toX86Operand src 
-		     
-		   val _ 
-		     = Assert.assert
-		       ("toX86Blocks: Move",
-			fn () => srcsize = dstsize)
+		   val dsts = Operand.toX86Operand dst
+		   val srcs = Operand.toX86Operand src
 		 in
 		   AppendList.appends
 		   [comment_begin,
@@ -353,31 +503,37 @@
 		    (x86.Block.mkBlock'
 		     {entry = NONE,
 		      statements
-		      = [(* dst = src *)
+		      = (Vector.toList o Vector.map2)
+		        (dsts,srcs,fn ((dst,dstsize),(src,srcsize)) =>
+			 (* dst = src *)
 			 case x86.Size.class srcsize
-			   of x86.Size.INT => x86.Assembly.instruction_mov 
-			                      {dst = dst,
-					       src = src,
-					       size = srcsize}
-			    | x86.Size.FLT => x86.Assembly.instruction_pfmov
-					      {dst = dst,
-					       src = src,
-					       size = srcsize}
-			    | _ => Error.bug "toX86Blocks: Move"],
+			    of x86.Size.INT => x86.Assembly.instruction_mov 
+			                       {dst = dst,
+						src = src,
+						size = srcsize}
+			  | x86.Size.FLT => x86.Assembly.instruction_pfmov
+					    {dst = dst,
+					     src = src,
+					     size = srcsize}
+			  | _ => Error.bug "toX86Blocks: Move"),
 		      transfer = NONE}),
 		    comment_end]
 		 end 
 	      | PrimApp {dst, prim, args}
    	      => let
 		   val (comment_begin, comment_end) = comments statement
-		   val args = Vector.map (args, Operand.convert)
-		   val dst = Option.map (dst, Operand.convert)
+		   val args = (Vector.concatV o Vector.map)
+		              (args, Operand.toX86Operand)
+		   val dsts = 
+		      case dst of
+			 NONE => Vector.new0 ()
+		       | SOME dst => Operand.toX86Operand dst
 		 in
 		   AppendList.appends
 		   [comment_begin,
 		    (x86MLton.prim {prim = prim,
 				    args = args,
-				    dst = dst,
+				    dsts = dsts,
 				    transInfo = transInfo}),
 		    comment_end]
 		 end
@@ -389,16 +545,10 @@
 	      => let
 		   val (comment_begin,
 			comment_end) = comments statement
-		     
-		   val dstsize = Operand.toX86Size dst
-		   val dst = Operand.toX86Operand dst
+		   val (dst,dstsize) = Vector.sub(Operand.toX86Operand dst, 0)
 		   val dst' = case x86.Operand.deMemloc dst
 				of SOME dst' => dst'
 				 | NONE => Error.bug "Allocate: strange dst"
-		   val _ 
-		     = Assert.assert
-		       ("toX86Assembly: Allocate, dstsize",
-			fn () => dstsize = x86MLton.pointerSize)
 		       
 		   val frontier = x86MLton.gcState_frontierContentsOperand ()
 		   val frontierDeref = x86MLton.gcState_frontierDerefOperand ()
@@ -412,36 +562,39 @@
 		       
 		   fun stores_toX86Assembly ({offset, value}, l)
 		     = let
-			 val size =
-			    x86MLton.toX86Size
-			    (Type.toCType (Operand.ty value))
-			 val value = Operand.toX86Operand value
-			 val dst
-			   = let
-			       val index = x86.Immediate.const_int offset
-			       val memloc
-				 = x86.MemLoc.simple
-				   {base = dst',
-				    index = index,
-				    scale = x86.Scale.One,
-				    size = size,
-				    class = x86MLton.Classes.Heap}
-			     in
-			       x86.Operand.memloc memloc
-			     end
+			 val origin =
+			    x86.MemLoc.simple
+			    {base = dst',
+			     index = x86.Immediate.const_int offset,
+			     scale = x86.Scale.One,
+			     size = x86.Size.BYTE,
+			     class = x86MLton.Classes.Heap}
 		       in
-			 (case x86.Size.class size
-			    of x86.Size.INT 
-			     => x86.Assembly.instruction_mov 
-			        {dst = dst,
-				 src = value,
-				 size = size}
-			     | x86.Size.FLT 
-			     => x86.Assembly.instruction_pfmov
-				{dst = dst,
-				 src = value,
-				 size = size}
-			     | _ => Error.bug "toX86Blocks: Allocate")::l
+			 (
+			 (Vector.toList o #1 o Vector.mapAndFold)
+			 (Operand.toX86Operand value, 0, fn ((src,srcsize),offset) =>
+			  let
+			     val dst =
+				(x86.Operand.memloc o x86.MemLoc.shift)
+				{origin = origin,
+				 disp = x86.Immediate.const_int offset,
+				 scale = x86.Scale.One,
+				 size = srcsize}
+			  in
+			     (case x86.Size.class srcsize of 
+				 x86.Size.INT => 
+				    x86.Assembly.instruction_mov 
+				    {dst = dst,
+				     src = src,
+				     size = srcsize}
+			       | x86.Size.FLT => 
+				    x86.Assembly.instruction_pfmov
+				    {dst = dst,
+				     src = src,
+				     size = srcsize}
+			       | _ => Error.bug "toX86Blocks: Allocate",
+			      offset + x86.Size.toBytes srcsize)
+			  end)) @ l
 		       end
 		 in
 		   AppendList.appends
@@ -490,8 +643,8 @@
  
       fun iff (test, a, b)
 	= let
-	    val size = Operand.toX86Size test
-	    val test = Operand.toX86Operand test
+	    val (test,testsize) =
+	       Vector.sub (Operand.toX86Operand test, 0)
 	  in
 	    if Label.equals(a, b)
 	      then AppendList.single
@@ -509,7 +662,7 @@
 		     = [x86.Assembly.instruction_test
 			{src1 = test,
 			 src2 = test,
-			 size = size}],
+			 size = testsize}],
 		     transfer
 		     = SOME (x86.Transfer.iff
 			     {condition = x86.Instruction.NZ,
@@ -519,8 +672,8 @@
 
       fun cmp (test, k, a, b)
 	= let
-	    val size = Operand.toX86Size test
-	    val test = Operand.toX86Operand test
+	    val (test,testsize) =
+	       Vector.sub (Operand.toX86Operand test, 0)
 	  in
 	    if Label.equals(a, b)
 	      then AppendList.single
@@ -538,7 +691,7 @@
 		     = [x86.Assembly.instruction_cmp
 			{src1 = test,
 			 src2 = x86.Operand.immediate k,
-			 size = size}],
+			 size = testsize}],
 		     transfer
 		     = SOME (x86.Transfer.iff
 			     {condition = x86.Instruction.E,
@@ -549,6 +702,7 @@
       fun switch(test, cases, default)
 	= let
 	    val test = Operand.toX86Operand test
+	    val (test,testsize) = Vector.sub(test, 0)
 	  in
 	    AppendList.single
 	    (x86.Block.mkBlock'
@@ -560,7 +714,7 @@
 				default = default})})
 	  end
 
-       fun doSwitchChar (test, cases, default)
+      fun doSwitchChar (test, cases, default)
 	= (case (cases, default)
 	     of ([],            NONE)
 	      => Error.bug "toX86Blocks: doSwitchChar"
@@ -630,21 +784,23 @@
 	= (case transfer
 	     of Arith {prim, args, dst, overflow, success, ty}
 	      => let
-		   val args = Vector.map (args, Operand.convert)
-		   val dst = Operand.convert dst
+		   val args = (Vector.concatV o Vector.map)
+		              (args, Operand.toX86Operand)
+		   val dsts = Operand.toX86Operand dst
 		 in
 		   AppendList.append
 		   (comments transfer,
 		    x86MLton.arith {prim = prim,
 				    args = args,
-				    dst = dst,
+				    dsts = dsts,
 				    overflow = overflow,
 				    success = success,
 				    transInfo = transInfo})
 		 end
 	      | CCall {args, frameInfo, func, return}
 	      => let
-		   val args = Vector.map (args, Operand.convert)
+		   val args = (Vector.concatV o Vector.map)
+		              (args, Operand.toX86Operand)
 		 in
 		   AppendList.append
 		   (comments transfer,	
@@ -670,11 +826,13 @@
 				    NONE => Error.bug "strange Return"
 				  | SOME zs => zs),
 				x86.MemLocSet.empty,
-				fn (operand, live)
-				 => case x86.Operand.deMemloc
-				         (Operand.toX86Operand operand)
-				      of SOME memloc => x86.MemLocSet.add(live, memloc)
-				       | NONE => live)})}))
+				fn (operand, live) =>
+				Vector.fold
+				(Operand.toX86Operand operand, live,
+				 fn ((operand,size),live) =>
+				 case x86.Operand.deMemloc operand of
+				    SOME memloc => x86.MemLocSet.add(live, memloc)
+				  | NONE => live))})}))
   	      | Raise
 	      => AppendList.append
 	         (comments transfer,
@@ -702,8 +860,8 @@
 		    case switch of
 		       EnumPointers {enum, pointers, test} =>
 			  let
-			     val size = Operand.toX86Size test
-			     val test = Operand.toX86Operand test
+			     val (test,testsize) =
+				Vector.sub(Operand.toX86Operand test, 0)
 			  in
 			     AppendList.append
 			     (comments transfer,
@@ -717,7 +875,7 @@
 				= [x86.Assembly.instruction_test
 				   {src1 = test,
 				    src2 = x86.Operand.immediate_const_word 0wx3,
-				    size = size}],
+				    size = testsize}],
 				transfer 
 				= SOME (x86.Transfer.iff
 					{condition = x86.Instruction.NZ,
@@ -725,12 +883,14 @@
 					 falsee = pointers})}))
 			  end
 		     | Int {cases, default, size, test} =>
-			  simple ({cases = (Vector.map
-					    (cases, fn (i, l) =>
-					     (IntX.toInt i, l))),
-				   default = default,
-				   test = test},
-				  doSwitchInt)
+			  (Assert.assert("x86Translate.Transfer.toX86Blocks: Switch/Int", 
+					 fn () => size <> IntSize.I64)
+			   ; simple ({cases = (Vector.map
+					       (cases, fn (i, l) =>
+						(IntX.toInt i, l))),
+				      default = default,
+				      test = test},
+				     doSwitchInt))
 		     | Pointer {cases, default, tag, ...} =>
 			  simple ({cases = (Vector.map
 					    (cases, fn {dst, tag, ...} =>
@@ -756,15 +916,15 @@
 		     statements = [],
 		     transfer = SOME (x86.Transfer.goto {target = label})})))
 	      | Call {label, live, return, ...}
-	      =>
-		 let
+	      => let
 		    val live =
 		       Vector.fold
 		       (live, x86.MemLocSet.empty, fn (operand, live) =>
-			case (x86.Operand.deMemloc
-			      (Operand.toX86Operand operand)) of
-			   NONE => live
-			 | SOME memloc => x86.MemLocSet.add (live, memloc))
+			Vector.fold
+			(Operand.toX86Operand operand, live, fn ((operand,size),live) =>
+			 case x86.Operand.deMemloc operand of
+			    NONE => live
+			  | SOME memloc => x86.MemLocSet.add (live, memloc)))
 		    val com = comments transfer
 		    val transfer =
 		       case return of
@@ -862,7 +1022,9 @@
 	    val _ = Vector.foreach
 	            (blocks, fn Block.T {label, live, ...} =>
 		     setLive (label,
-			      Vector.toListMap (live, Operand.toX86Operand)))
+			      (Vector.toList o #1 o Vector.unzip o 
+			       Vector.concatV o Vector.map)
+			      (live, Operand.toX86Operand)))
 	    val transInfo = {addData = addData,
 			     frameInfoToX86 = frameInfoToX86,
 			     live = live,



1.41      +231 -63   mlton/mlton/codegen/x86-codegen/x86.fun

Index: x86.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.fun,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -r1.40 -r1.41
--- x86.fun	25 Jul 2003 20:14:47 -0000	1.40
+++ x86.fun	31 Jul 2003 23:10:33 -0000	1.41
@@ -43,13 +43,19 @@
 
   open S
 
-   local
-      open Runtime
-   in
-      structure CFunction = CFunction
-   end
-
-   structure CType = CFunction.CType
+  local
+     open Runtime
+  in
+     structure CFunction = CFunction
+  end
+  structure CType = CFunction.CType
+  local
+     open CType
+  in
+     structure IntSize = IntSize
+     structure RealSize = RealSize
+     structure WordSize = WordSize
+  end
    
   structure Label =
      struct
@@ -131,6 +137,35 @@
 	   | FPIL => 4
 	   | FPIQ => 8
 
+      local
+	 datatype z = datatype CType.t
+      in
+	 fun fromCType t =
+	    case t of
+	       Int s =>
+		  let datatype z = datatype IntSize.t
+		  in case s of
+		       I8 => Vector.new1 BYTE
+		     | I16 => Vector.new1 WORD
+		     | I32 => Vector.new1 LONG
+		     | I64 => Vector.new2 (LONG, LONG)
+		  end
+	     | Pointer => Vector.new1 LONG
+	     | Real s => 
+		  let datatype z = datatype RealSize.t
+		  in case s of
+		       R32 => Vector.new1 SNGL
+		     | R64 => Vector.new1 DBLE
+		  end
+	     | Word s =>
+		  let datatype z = datatype WordSize.t
+		  in case s of
+		       W8 => Vector.new1 BYTE
+		     | W16 => Vector.new1 WORD 
+		     | W32 => Vector.new1 LONG
+		  end
+      end
+
       val class
 	= fn BYTE => INT
 	   | WORD => INT
@@ -206,17 +241,19 @@
 
       fun eq(T r1, T r2) = r1 = r2
 
+(*
       fun return size
 	= T {reg = EAX, part = case size
 				 of Size.BYTE => L
 				  | Size.WORD => X
 				  | Size.LONG => E
 				  | _ => Error.bug "Register.return"}
-
+*)
       val eax = T {reg = EAX, part = E}
       val ebx = T {reg = EBX, part = E}
       val ecx = T {reg = ECX, part = E}
       val edx = T {reg = EDX, part = E}
+      val ax = T {reg= EAX, part = X}
       val al = T {reg = EAX, part = L}
       val bl = T {reg = EBX, part = L}
       val cl = T {reg = ECX, part = L}
@@ -377,7 +414,9 @@
       fun pop (T i) = T (i - 1)
       fun id (T i) = T i
 
+(*
       val return = T 0
+*)
       val top = T 0
       val one = T 1
       val total = 8 : int
@@ -676,6 +715,34 @@
 	   | Two => 2
 	   | Four => 4
 	   | Eight => 8
+      local
+	 datatype z = datatype CType.t
+      in
+	 fun fromCType t =
+	    case t of
+	       Int s =>
+		  let datatype z = datatype IntSize.t
+		  in case s of
+		       I8 => One
+		     | I16 => Two
+		     | I32 => Four
+		     | I64 => Eight
+		  end
+	     | Pointer => Four
+	     | Real s => 
+		  let datatype z = datatype RealSize.t
+		  in case s of
+		       R32 => Four
+		     | R64 => Eight
+		  end
+	     | Word s =>
+		  let datatype z = datatype WordSize.t
+		  in case s of
+		       W8 => One
+		     | W16 => Two
+		     | W32 => Four
+		  end
+      end
 
       fun eq(s1, s2) = s1 = s2
       val compare = fn (s1, s2) => Int.compare (toBytes s1, toBytes s2)
@@ -1179,6 +1246,33 @@
 			 scale = scale,
 			 size = size,
 			 class = class})
+      val shift = fn {origin, disp, scale, size} 
+        => let	
+	      val disp =
+		 Immediate.binexp
+		 {oper = Immediate.Multiplication,
+		  exp1 = disp,
+		  exp2 = Scale.toImmediate scale}
+	      val U {immBase, memBase, 
+		     immIndex, memIndex, 
+		     scale, class, ...} =
+		 destruct origin
+	   in
+	      construct (U {immBase = immBase,
+			    memBase = memBase,
+			    immIndex = 
+			    case immIndex of
+			       NONE => SOME disp
+			     | SOME immIndex => SOME (Immediate.binexp
+						      {oper = Immediate.Addition,
+						       exp1 = immIndex,
+						       exp2 = disp}),
+			    memIndex = memIndex,
+			    scale = scale,
+			    size = size,
+			    class = class})
+	   end
+
       local
 	val num : int ref = ref 0
       in
@@ -1199,15 +1293,10 @@
 	       scale = Scale.Four,
 	       size = size,
 	       class = class}
+(*
       local
-	val cReturnTemp = Label.fromString "cReturnTemp"
-	fun cReturnTempContent (index, size) =
-	   imm
-	   {base = Immediate.label cReturnTemp,
-	    index = Immediate.const_int index,
-	    scale = Scale.One,
-	    size = size,
-	    class = Class.StaticTemp}
+	datatype z = datatype CType.t
+	datatype z = datatype Size.t
       in
 	 fun cReturnTempContents sizes =
 	    (List.rev o #1)
@@ -1217,7 +1306,30 @@
 	       index + Size.toBytes size)))
 	 fun cReturnTempContent size =
 	    List.first(cReturnTempContents [size])
+	 val cReturnTempContents = fn size =>
+	    cReturnTempContents (
+	    case size of
+	       Int s => let datatype z = datatype IntSize.t
+			in case s of
+			     I8 => [BYTE]
+			   | I16 => [WORD]
+			   | I32 => [LONG]
+			   | I64 => [LONG, LONG]
+			end
+	     | Pointer => [LONG]
+	     | Real s => let datatype z = datatype RealSize.t
+			 in case s of
+			      R32 => [SNGL]
+			    | R64 => [DBLE]
+			 end
+	     | Word s => let datatype z = datatype WordSize.t
+			 in case s of
+			      W8 => [BYTE]
+			    | W16 => [WORD]
+			    | W32 => [LONG]
+			 end)
       end
+*)
     end
 
   local
@@ -1342,6 +1454,53 @@
       val deMemloc 
 	= fn MemLoc x => SOME x
            | _ => NONE
+
+      local
+	val cReturnTemp = Label.fromString "cReturnTemp"
+	fun cReturnTempContent (index, size) =
+	   MemLoc.imm
+	   {base = Immediate.label cReturnTemp,
+	    index = Immediate.const_int index,
+	    scale = Scale.One,
+	    size = size,
+	    class = MemLoc.Class.StaticTemp}
+	 datatype z = datatype CType.t
+	 datatype z = datatype Size.t
+      in
+	 fun cReturnTemps ty =
+	    case ty of
+	       Int s => let datatype z = datatype IntSize.t
+			in case s of
+			     I8 => [{src = register Register.al,
+				     dst = cReturnTempContent (0, BYTE)}]
+			   | I16 => [{src = register Register.ax,
+				      dst = cReturnTempContent (0, WORD)}]
+			   | I32 => [{src = register Register.eax,
+				      dst = cReturnTempContent (0, LONG)}]
+			   | I64 => [{src = register Register.eax,
+				      dst = cReturnTempContent (0, LONG)},
+				     {src = register Register.edx,
+				      dst = cReturnTempContent (4, LONG)}]
+			end
+	     | Pointer => [{src = register Register.eax,
+			    dst = cReturnTempContent (0, LONG)}]
+	     | Real s => let datatype z = datatype RealSize.t
+			 in case s of
+			      R32 => [{src = fltregister FltRegister.top,
+				       dst = cReturnTempContent (0, SNGL)}]
+			    | R64 => [{src = fltregister FltRegister.top,
+				       dst = cReturnTempContent (0, DBLE)}]
+			 end
+	     | Word s => let datatype z = datatype WordSize.t
+			 in case s of
+			      W8 => [{src = register Register.al,
+				      dst = cReturnTempContent (0, BYTE)}]
+			    | W16 => [{src = register Register.ax,
+				       dst = cReturnTempContent (0, WORD)}]
+			    | W32 => [{src = register Register.eax,
+				       dst = cReturnTempContent (0, LONG)}]
+			 end
+      end
     end
 
   structure Instruction =
@@ -3023,14 +3182,10 @@
 	   * used before C calls.
 	   *)
 	| CCall
-	  (* Assert that the return value is in a register;
-	   * used after C calls.
-	   *)
-	| Return of {memloc: MemLoc.t}
-          (* Assert that the return value is in a float register;
-	   * used after C calls.
-	   *)
-	| FltReturn of {memloc: MemLoc.t}
+        (* Assert the return value;
+	 * used after C calls.
+	 *)
+        | Return of {returns: {src: Operand.t, dst: MemLoc.t} list}
 	(* Misc. *)
 	  (* Assert that the register is not free for the allocator;
 	   * used ???
@@ -3151,10 +3306,10 @@
 	   => concat["Reset"]
 	   | CCall
 	   => concat["CCall"]
-	   | Return {memloc}
-	   => concat["Return: ", MemLoc.toString memloc]
-	   | FltReturn {memloc}
-	   => concat["FltReturn: ", MemLoc.toString memloc]
+	   | Return {returns}
+	   => concat["Return: ", List.toString (fn {src,dst} =>
+						concat ["(", Operand.toString src,
+							",", MemLoc.toString dst, ")"]) returns]
 	   | Reserve {registers}
 	   => concat["Reserve: ", 
 		     "registers: ",
@@ -3235,10 +3390,13 @@
 	       defs = [], 
 	       kills = []}
 	   | CCall => {uses = [], defs = [], kills = []}
-           | Return {memloc}
-           => {uses = [], defs = [Operand.memloc memloc], kills = []}
-           | FltReturn {memloc}
-           => {uses = [], defs = [Operand.memloc memloc], kills = []}
+           | Return {returns}
+	   => let 
+		 val uses = List.map(returns, fn {src, ...} => src)
+		 val defs = List.map(returns, fn {dst, ...} => Operand.memloc dst)
+	      in
+		 {uses = uses, defs = defs, kills = []}
+	      end
 	   | Reserve {registers} => {uses = [], defs = [], kills = []}
 	   | Unreserve {registers} => {uses = [], defs = [], kills = []}
 	   | ClearFlt => {uses = [], defs = [], kills = []}
@@ -3331,16 +3489,15 @@
 				            | _ => Error.bug "Directive.replace"),
 		     dead_classes = dead_classes}
 	   | CCall => CCall
-           | Return {memloc}
-           => Return {memloc = case replacer {use = true, def = false}
-                                             (Operand.memloc memloc)
-			         of Operand.MemLoc memloc => memloc
-			          | _ => Error.bug "Directive.replace"}
-           | FltReturn {memloc}
-           => FltReturn {memloc = case replacer {use = true, def = false}
-                                                (Operand.memloc memloc)
-			            of Operand.MemLoc memloc => memloc
-			             | _ => Error.bug "Directive.replace"}
+           | Return {returns}
+	   => Return {returns = List.map
+                                (returns, fn {src,dst} =>
+				 {src = src,
+				  dst = 
+				  case replacer {use = true, def = false}
+				       (Operand.memloc dst)
+				    of Operand.MemLoc memloc => memloc
+				     | _ => Error.bug "Directive.replace"})}
 	   | Reserve {registers} => Reserve {registers = registers}
 	   | Unreserve {registers} => Unreserve {registers = registers}
 	   | ClearFlt => ClearFlt
@@ -3355,7 +3512,6 @@
       val force = Force
       val ccall = fn () => CCall
       val return = Return
-      val fltreturn = FltReturn
       val reserve = Reserve
       val unreserve = Unreserve
       val saveregalloc = SaveRegAlloc
@@ -3557,7 +3713,6 @@
       val directive_force = Directive o Directive.force
       val directive_ccall = Directive o Directive.ccall
       val directive_return = Directive o Directive.return
-      val directive_fltreturn = Directive o Directive.fltreturn
       val directive_reserve = Directive o Directive.reserve
       val directive_unreserve = Directive o Directive.unreserve
       val directive_saveregalloc = Directive o Directive.saveregalloc
@@ -3661,7 +3816,7 @@
 	| Handler of {frameInfo: FrameInfo.t,
 		      label: Label.t,
 		      live: MemLocSet.t}
-	| CReturn of {dst: (Operand.t * Size.t) option,
+	| CReturn of {dsts: (Operand.t * Size.t) vector,
 		      frameInfo: FrameInfo.t option,
 		      func: CFunction.t,
 		      label: Label.t}
@@ -3705,13 +3860,11 @@
 		      "] (",
 		      FrameInfo.toString frameInfo,
 		      ")"]
-	   | CReturn {dst, frameInfo, func, label} 
+	   | CReturn {dsts, frameInfo, func, label} 
 	   => concat ["CReturn::",
 		      Label.toString label,
 		      " ",
-		      case dst
-			of SOME (dst, _) => Operand.toString dst
-			 | NONE => "",
+		      Vector.toString (fn (dst,dstsize) => Operand.toString dst) dsts,
 		      " ",
 		      CFunction.name func,
 		      " ",
@@ -3721,9 +3874,20 @@
       val layout = Layout.str o toString
 
       val uses_defs_kills
-	= fn CReturn {dst = SOME (dst, dstsize), ...} 
-	   => {uses = [Operand.memloc (MemLoc.cReturnTempContent dstsize)],
-	       defs = [dst], kills = []}
+	= fn CReturn {dsts, func, ...} 
+	   => let 
+		 val uses =
+		    case CFunction.return func of
+		       NONE => []
+		     | SOME ty => 
+			  List.map
+			  (Operand.cReturnTemps ty,
+			   fn {src, dst} => Operand.memloc dst)
+	      in
+		 {uses = uses, 
+		  defs = Vector.toListMap(dsts, fn (dst, dstsize) => dst), 
+		  kills = []}
+	      end
 	   | _ => {uses = [], defs = [], kills = []}
 	   
       val label
@@ -3938,7 +4102,6 @@
 	| Return of {live: MemLocSet.t}
 	| Raise of {live: MemLocSet.t}
 	| CCall of {args: (Operand.t * Size.t) list,
-		    dstsize: Size.t option,
 		    frameInfo: FrameInfo.t option,
 		    func: CFunction.t,
 		    return: Label.t option,
@@ -4020,7 +4183,7 @@
 			fn (memloc, l) => (MemLoc.toString memloc)::l),
 		       ", "),
 		      "]"]
-	   | CCall {args, dstsize, frameInfo, func, return, target}
+	   | CCall {args, frameInfo, func, return, target}
 	   => concat ["CCALL ",
 		      Label.toString target,
 		      "(",
@@ -4035,13 +4198,19 @@
       val uses_defs_kills
 	= fn Switch {test, cases, default}
 	   => {uses = [test], defs = [], kills = []}
-	   | CCall {args, dstsize, ...}
-	   => {uses = List.map(args, fn (oper,_) => oper),
-	       defs = case dstsize 
-			of NONE => []
-			 | SOME dstsize 
-			 => [Operand.memloc (MemLoc.cReturnTempContent dstsize)],
-	       kills = []}
+	   | CCall {args, func, ...}
+	   => let
+		 val defs =
+		    case CFunction.return func of
+		       NONE => []
+		     | SOME ty => 
+			  List.map
+			  (Operand.cReturnTemps ty,
+			   fn {src, dst} => Operand.memloc dst)
+	      in
+		 {uses = List.map(args, fn (oper,_) => oper),
+		  defs = defs, kills = []}
+	      end
 	   | _ => {uses = [], defs = [], kills = []}
 
       val nearTargets
@@ -4075,13 +4244,12 @@
 	   => Switch {test = replacer {use = true, def = false} test,
 		      cases = cases,
 		      default = default}
-	   | CCall {args, dstsize, frameInfo, func, return, target}
+	   | CCall {args, frameInfo, func, return, target}
 	   => CCall {args = List.map(args,
 				     fn (oper,size) => (replacer {use = true,
 								  def = false}
 							         oper,
 							size)),
-		     dstsize = dstsize,
 		     frameInfo = frameInfo,
 		     func = func,
 		     return = return,



1.29      +23 -16    mlton/mlton/codegen/x86-codegen/x86.sig

Index: x86.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.sig,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- x86.sig	25 Jul 2003 20:14:47 -0000	1.28
+++ x86.sig	31 Jul 2003 23:10:33 -0000	1.29
@@ -43,6 +43,7 @@
 	val toString' : t -> string
 	val fromBytes : int -> t
 	val toBytes : t -> int
+	val fromCType : CFunction.CType.t -> t vector
 	val class : t -> class
 	val toFPI : t -> t
 	val eq : t * t -> bool
@@ -69,7 +70,9 @@
 	val coincident' : reg -> t list
 	val coincident : t -> t list
 
+(*
 	val return : Size.t -> t
+*)
 	val eax : t
 	val ebx : t
 	val ecx : t
@@ -99,7 +102,9 @@
 	datatype t = T of int
 	val toString : t -> string
 	val eq: t * t -> bool
+(*
 	val return : t
+*)
 	val top : t
 	val one : t
 	val total : int
@@ -167,6 +172,7 @@
 	val eq : t * t -> bool
 	val toImmediate : t -> Immediate.t
 	val fromBytes : int -> t
+	val fromCType : CFunction.CType.t -> t
       end
 
     structure Address :
@@ -230,6 +236,10 @@
 		       scale: Scale.t,
 		       size: Size.t,
 		       class: Class.t} -> t
+	val shift : {origin: t,
+		     disp: Immediate.t,
+		     scale: Scale.t,
+		     size: Size.t} -> t
 	val destruct : t -> u
 	val clearAll : unit -> unit
 
@@ -251,7 +261,10 @@
 			    size: Size.t,
 			    class: Class.t} -> t
 	(* CReturn locations *)
+(*
 	val cReturnTempContent : Size.t -> t
+	val cReturnTempContents : CFunction.CType.t -> t list
+*)
     end
 
     structure ClassSet : SET
@@ -291,6 +304,8 @@
 
 	val size : t -> Size.t option
 	val eq : t * t -> bool
+
+	val cReturnTemps: CFunction.CType.t -> {src: t, dst: MemLoc.t} list
       end
 
     structure Instruction :
@@ -716,14 +731,10 @@
 	     * used before C calls.
 	     *)
 	  | CCall
-	    (* Assert that the return value is in a register;
-	     * used after C calls.
-	     *)
-	  | Return of {memloc: MemLoc.t}
-	    (* Assert that the return value is in a float register;
-	     * used after C calls.
-	     *)
-	  | FltReturn of {memloc: MemLoc.t}
+	  (* Assert the return value;
+	   * used after C calls.
+	   *)
+          | Return of {returns: {src:Operand.t, dst: MemLoc.t} list}
 	  (* Misc. *)
 	    (* Assert that the register is not free for the allocator;
 	     * used ???
@@ -780,8 +791,7 @@
 		     dead_memlocs: MemLocSet.t,
 		     dead_classes: ClassSet.t} -> t
 	val ccall : unit -> t
-	val return : {memloc: MemLoc.t} -> t
-	val fltreturn : {memloc: MemLoc.t} -> t
+	val return : {returns: {src: Operand.t, dst: MemLoc.t} list} -> t
 	val reserve : {registers: Register.t list} -> t
 	val unreserve : {registers: Register.t list} -> t
 	val clearflt : unit -> t
@@ -864,8 +874,7 @@
 			       dead_memlocs: MemLocSet.t,
 			       dead_classes: ClassSet.t} -> t
 	val directive_ccall : unit -> t
-	val directive_return : {memloc: MemLoc.t} -> t
-	val directive_fltreturn : {memloc: MemLoc.t} -> t
+	val directive_return : {returns: {src: Operand.t, dst: MemLoc.t} list} -> t
 	val directive_reserve : {registers: Register.t list} -> t
 	val directive_unreserve : {registers: Register.t list} -> t
 	val directive_saveregalloc : {live: MemLocSet.t,
@@ -1060,7 +1069,7 @@
 	  | Handler of {frameInfo: FrameInfo.t,
 			label: Label.t,
 			live: MemLocSet.t}
-	  | CReturn of {dst: (Operand.t * Size.t) option,
+	  | CReturn of {dsts: (Operand.t * Size.t) vector,
 			frameInfo: FrameInfo.t option,
 			func: CFunction.t,
 			label: Label.t}
@@ -1068,7 +1077,7 @@
 	val cont : {label: Label.t,
 		    live: MemLocSet.t,
 		    frameInfo: FrameInfo.t} -> t
-	val creturn: {dst: (Operand.t * Size.t) option,
+	val creturn: {dsts: (Operand.t * Size.t) vector,
 		      frameInfo: FrameInfo.t option,
 		      func: CFunction.t,
 		      label: Label.t}  -> t
@@ -1149,7 +1158,6 @@
 	  | Return of {live: MemLocSet.t}
 	  | Raise of {live: MemLocSet.t}
 	  | CCall of {args: (Operand.t * Size.t) list,
-		      dstsize: Size.t option,
 		      frameInfo: FrameInfo.t option,
 		      func: CFunction.t,
 		      return: Label.t option,
@@ -1182,7 +1190,6 @@
 	val return : {live: MemLocSet.t} -> t 
 	val raisee : {live: MemLocSet.t} -> t
 	val ccall: {args: (Operand.t * Size.t) list,
-		    dstsize: Size.t option,
 		    frameInfo: FrameInfo.t option,
 		    func: CFunction.t,
 		    return: Label.t option,





-------------------------------------------------------
This SF.Net email sponsored by: Free pre-built ASP.NET sites including
Data Reports, E-commerce, Portals, and Forums are available now.
Download today and enter to win an XBOX or Visual Studio .NET.
http://aspnet.click-url.com/go/psa00100003ave/direct;at.aspnet_072303_01/01
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel