[MLton] cvs commit: reorganized the handling of primitives in SsaToRssa

Stephen Weeks sweeks@mlton.org
Mon, 15 Mar 2004 22:38:27 -0800


sweeks      04/03/15 22:38:27

  Modified:    basis-library/misc primitive.sml
               include  c-chunk.h
               mlton/atoms const.fun
               mlton/backend backend.fun implement-handlers.fun
                        limit-check.fun profile.fun rssa.fun rssa.sig
                        signal-check.fun ssa-to-rssa.fun
  Log:
  MAIL reorganized the handling of primitives in SsaToRssa
  
  Now, for each codegen, there is an explicit statement of the
  primitives that ssaToRssa expects the codegen to implement.  There is
  also a specification of the primitives that are implemented by
  functions in the runtime library.  Using these, the translation of
  primitives is greatly simplified.  Either the primitive is handled by
  ssaToRssa directly, or it is implemented by the codegen, and if not,
  then it must be implemented by the runtime library or an error is
  reported.
  
  This should make it a lot easies to add a new codegen, which will
  surely implement a different subset of the primitives than either of
  our current codegens.
  
  Changed a lot of int and word primitives in the basis library from
  _import to _prim, with the decision on whether to call the runtime
  library now delayed until ssaToRssa.  This exposes the prims to the
  simplifier.  One reason for doing this is to make sure that arithmetic
  on all the new int and word sizes can be simplified at compile time.
  
  Tweaked the RSSA IL to record as part of the program itself whether or
  not the program handles signals.  It used to be kept by leaving around
  the MLton_installSignalHandler primitive.

Revision  Changes    Path
1.105     +29 -74    mlton/basis-library/misc/primitive.sml

Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.104
retrieving revision 1.105
diff -u -r1.104 -r1.105
--- primitive.sml	15 Mar 2004 02:36:43 -0000	1.104
+++ primitive.sml	16 Mar 2004 06:38:25 -0000	1.105
@@ -672,8 +672,8 @@
 	    val op <= = _prim "Int64_le": int * int -> bool;
 	    val op > = _prim "Int64_gt": int * int -> bool;
 	    val op >= = _prim "Int64_ge": int * int -> bool;
-	    val quot = _import "Int64_quot": int * int -> int;
-	    val rem = _import "Int64_rem": int * int -> int;
+	    val quot = _prim "Int64_quot": int * int -> int;
+	    val rem = _prim "Int64_rem": int * int -> int;
 	    val ~? = _prim "Int64_neg": int -> int; 
 	    val ~ =
 	       if detectOverflow
@@ -990,8 +990,6 @@
 	       _prim "Pointer_setWord64": t * int * Word64.word -> unit;
 	 end
 
-      val useMathLibForTrig = false
-
       structure Real64 =
 	 struct
 	    type real = Real64.real
@@ -1003,14 +1001,8 @@
 		  val acos = _prim "Real64_Math_acos": real -> real;
 		  val asin = _prim "Real64_Math_asin": real -> real;
 		  val atan = _prim "Real64_Math_atan": real -> real;
-		  val atan2 =
-		     if useMathLibForTrig
-			then _import "atan2": real * real -> real;
-		     else _prim "Real64_Math_atan2": real * real -> real;
-		  val cos =
-		     if useMathLibForTrig
-			then _import "cos": real -> real;
-		     else _prim "Real64_Math_cos": real -> real;
+		  val atan2 = _prim "Real64_Math_atan2": real * real -> real;
+		  val cos = _prim "Real64_Math_cos": real -> real;
 		  val cosh = _import "cosh": real -> real;
 		  val e = _import "Real64_Math_e": real;
 		  val exp = _prim "Real64_Math_exp": real -> real;
@@ -1018,16 +1010,10 @@
 		  val log10 = _prim "Real64_Math_log10": real -> real;
 		  val pi = _import "Real64_Math_pi": real;
 		  val pow = _import "pow": real * real -> real;
-		  val sin =
-		     if useMathLibForTrig
-			then _import "sin": real -> real;
-		     else _prim "Real64_Math_sin": real -> real;
+		  val sin = _prim "Real64_Math_sin": real -> real;
 		  val sinh = _import "sinh": real -> real;
 		  val sqrt = _prim "Real64_Math_sqrt": real -> real;
-		  val tan =
-		     if useMathLibForTrig
-			then _import "tan": real -> real;
-		     else _prim "Real64_Math_tan": real -> real;
+		  val tan = _prim "Real64_Math_tan": real -> real;
 		  val tanh = _import "tanh": real -> real;
 	       end
 
@@ -1049,19 +1035,13 @@
 	    val gdtoa =
 	       _import "Real64_gdtoa": real * int * int * int ref -> cstring;
 	    val fromInt = _prim "Int32_toReal64": int -> real;
-	    val ldexp =
-	       if MLton.native
-		  then _prim "Real64_ldexp": real * int -> real;
-	       else _import "ldexp": real * int -> real;
+	    val ldexp = _prim "Real64_ldexp": real * int -> real;
 	    val maxFinite = _import "Real64_maxFinite": real;
 	    val minNormalPos = _import "Real64_minNormalPos": real;
 	    val minPos = _import "Real64_minPos": real;
 	    val modf = _import "Real64_modf": real * real ref -> real;
 	    val nextAfter = _import "Real64_nextAfter": real * real -> real;
-	    val round =
-	       if MLton.native
-		  then _prim "Real64_round": real -> real;
-	       else _import "rint": real -> real;
+	    val round = _prim "Real64_round": real -> real;
 	    val signBit = _import "Real64_signBit": real -> bool;
 	    val strto = _import "Real64_strto": NullString.t -> real;
 	    val toInt = _prim "Real64_toInt32": real -> int;
@@ -1097,14 +1077,8 @@
 		  val acos = _prim "Real32_Math_acos": real -> real;
 		  val asin = _prim "Real32_Math_asin": real -> real;
 		  val atan = _prim "Real32_Math_atan": real -> real;
-		  val atan2 =
-		     if useMathLibForTrig
-			then binary Real64.Math.atan2
-		     else _prim "Real32_Math_atan2": real * real -> real;
-		  val cos =
-		     if useMathLibForTrig
-			then unary Real64.Math.cos
-		     else _prim "Real32_Math_cos": real -> real;
+		  val atan2 = _prim "Real32_Math_atan2": real * real -> real;
+		  val cos = _prim "Real32_Math_cos": real -> real;
 		  val cosh = unary Real64.Math.cosh
 		  val e = _import "Real32_Math_e": real;
 		  val exp = _prim "Real32_Math_exp": real -> real;
@@ -1112,16 +1086,10 @@
 		  val log10 = _prim "Real32_Math_log10": real -> real;
 		  val pi = _import "Real32_Math_pi": real;
 		  val pow = binary Real64.Math.pow
-		  val sin =
-		     if useMathLibForTrig
-			then unary Real64.Math.sin
-		     else _prim "Real32_Math_sin": real -> real;
+		  val sin = _prim "Real32_Math_sin": real -> real;
 		  val sinh = unary Real64.Math.sinh
 		  val sqrt = _prim "Real32_Math_sqrt": real -> real;
-		  val tan =
-		     if useMathLibForTrig
-			then unary Real64.Math.tan
-		     else _prim "Real32_Math_tan": real -> real;
+		  val tan = _prim "Real32_Math_tan": real -> real;
 		  val tanh = unary Real64.Math.tanh
 	       end
 
@@ -1144,10 +1112,7 @@
 	    val gdtoa =
 	       _import "Real32_gdtoa": real * int * int * int ref -> cstring;
 	    val fromInt = _prim "Int32_toReal32": int -> real;
-	    val ldexp =
-	       if MLton.native
-		  then _prim "Real32_ldexp": real * int -> real;
-	       else fn (r, i) => fromLarge (Real64.ldexp (toLarge r, i))
+	    val ldexp = _prim "Real32_ldexp": real * int -> real;
 	    val maxFinite = _import "Real32_maxFinite": real;
 	    val minNormalPos = _import "Real32_minNormalPos": real;
 	    val minPos = _import "Real32_minPos": real;
@@ -1417,12 +1382,11 @@
 	    val wordSize: int = 8
 
 	    val + = _prim "Word8_add": word * word -> word;
-(*	    val addCheck = _prim "Word8_addCheck": word * word -> word; *)
 	    val andb = _prim "Word8_andb": word * word -> word;
 	    val ~>> = _prim "Word8_arshift": word * Word.word -> word;
 	    val div = _prim "Word8_div": word * word -> word;
 	    val fromInt = _prim "Int32_toWord8": int -> word;
-	    val fromLarge = _import "Word64_toWord8": LargeWord.word -> word;
+	    val fromLarge = _prim "Word64_toWord8": LargeWord.word -> word;
 	    val op >= = _prim "Word8_ge": word * word -> bool;
 	    val op > = _prim "Word8_gt" : word * word -> bool;
 	    val op <= = _prim "Word8_le": word * word -> bool;
@@ -1430,7 +1394,6 @@
 	    val op < = _prim "Word8_lt" : word * word -> bool;
 	    val mod = _prim "Word8_mod": word * word -> word;
 	    val * = _prim "Word8_mul": word * word -> word;
-(*	    val mulCheck = _prim "Word8_mulCheck": word * word -> word; *)
 	    val ~ = _prim "Word8_neg": word -> word;
 	    val notb = _prim "Word8_notb": word -> word;
 	    val orb = _prim "Word8_orb": word * word -> word;
@@ -1473,12 +1436,11 @@
 	    val wordSize: int = 16
 
 	    val + = _prim "Word16_add": word * word -> word;
-(*	    val addCheck = _prim "Word16_addCheck": word * word -> word; *)
 	    val andb = _prim "Word16_andb": word * word -> word;
 	    val ~>> = _prim "Word16_arshift": word * Word.word -> word;
 	    val div = _prim "Word16_div": word * word -> word;
 	    val fromInt = _prim "Int32_toWord16": int -> word;
-	    val fromLarge = _import "Word64_toWord16": LargeWord.word -> word;
+	    val fromLarge = _prim "Word64_toWord16": LargeWord.word -> word;
 	    val op >= = _prim "Word16_ge": word * word -> bool;
 	    val op > = _prim "Word16_gt" : word * word -> bool;
 	    val op <= = _prim "Word16_le": word * word -> bool;
@@ -1486,12 +1448,9 @@
 	    val op < = _prim "Word16_lt" : word * word -> bool;
 	    val mod = _prim "Word16_mod": word * word -> word;
 	    val * = _prim "Word16_mul": word * word -> word;
-(*	    val mulCheck = _prim "Word16_mulCheck": word * word -> word; *)
 	    val ~ = _prim "Word16_neg": word -> word;
 	    val notb = _prim "Word16_notb": word -> word;
 	    val orb = _prim "Word16_orb": word * word -> word;
-(*	    val rol = _prim "Word16_rol": word * Word.word -> word; *)
-(*	    val ror = _prim "Word16_ror": word * Word.word -> word; *)
 	    val >> = _prim "Word16_rshift": word * Word.word -> word;
 	    val - = _prim "Word16_sub": word * word -> word;
 	    val toInt = _prim "Word16_toInt32": word -> int;
@@ -1512,7 +1471,7 @@
 	    val ~>> = _prim "Word32_arshift": word * word -> word;
 	    val div = _prim "Word32_div": word * word -> word;
 	    val fromInt = _prim "Int32_toWord32": int -> word;
-	    val fromLarge = _import "Word64_toWord32": LargeWord.word -> word;
+	    val fromLarge = _prim "Word64_toWord32": LargeWord.word -> word;
 	    val op >= = _prim "Word32_ge": word * word -> bool;
 	    val op > = _prim "Word32_gt" : word * word -> bool;
 	    val op <= = _prim "Word32_le": word * word -> bool;
@@ -1542,29 +1501,25 @@
 	    val wordSize: int = 64
 
 	    val + = _prim "Word64_add": word * word -> word;
-(*	    val addCheck = _prim "Word64_addCheck": word * word -> word; *)
 	    val andb = _prim "Word64_andb": word * word -> word;
-	    val ~>> = _import "Word64_arshift": word * Word.word -> word;
-	    val div = _import "Word64_div": word * word -> word;
-	    val fromInt = _import "Int32_toWord64": int -> word;
+	    val ~>> = _prim "Word64_arshift": word * Word.word -> word;
+	    val div = _prim "Word64_div": word * word -> word;
+	    val fromInt = _prim "Int32_toWord64": int -> word;
 	    val fromLarge: LargeWord.word -> word = fn x => x
-	    val op >= = _import "Word64_ge": word * word -> bool;
-	    val op > = _import "Word64_gt" : word * word -> bool;
-	    val op <= = _import "Word64_le": word * word -> bool;
-	    val << = _import "Word64_lshift": word * Word.word -> word;
-	    val op < = _import "Word64_lt" : word * word -> bool;
-	    val mod = _import "Word64_mod": word * word -> word;
-	    val * = _import "Word64_mul": word * word -> word;
-(*	    val mulCheck = _import "Word64_mulCheck": word * word -> word; *)
+	    val op >= = _prim "Word64_ge": word * word -> bool;
+	    val op > = _prim "Word64_gt" : word * word -> bool;
+	    val op <= = _prim "Word64_le": word * word -> bool;
+	    val << = _prim "Word64_lshift": word * Word.word -> word;
+	    val op < = _prim "Word64_lt" : word * word -> bool;
+	    val mod = _prim "Word64_mod": word * word -> word;
+	    val * = _prim "Word64_mul": word * word -> word;
 	    val ~ = _prim "Word64_neg": word -> word;
 	    val notb = _prim "Word64_notb": word -> word;
 	    val orb = _prim "Word64_orb": word * word -> word;
-(*	    val rol = _import "Word64_rol": word * Word.word -> word; *)
-(*	    val ror = _import "Word64_ror": word * Word.word -> word; *)
-	    val >> = _import "Word64_rshift": word * Word.word -> word;
+	    val >> = _prim "Word64_rshift": word * Word.word -> word;
 	    val - = _prim "Word64_sub": word * word -> word;
-	    val toInt = _import "Word64_toInt32": word -> int;
-	    val toIntX = _import "Word64_toInt32X": word -> int;
+	    val toInt = _prim "Word64_toInt32": word -> int;
+	    val toIntX = _prim "Word64_toInt32X": word -> int;
 	    val toLarge: word -> LargeWord.word = fn x => x
 	    val toLargeX: word -> LargeWord.word = fn x => x
 	    val xorb = _prim "Word64_xorb": word * word -> word;



1.21      +79 -61    mlton/include/c-chunk.h

Index: c-chunk.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-chunk.h,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- c-chunk.h	15 Mar 2004 02:36:43 -0000	1.20
+++ c-chunk.h	16 Mar 2004 06:38:26 -0000	1.21
@@ -436,11 +436,27 @@
 /*                       Real                        */
 /* ------------------------------------------------- */
 
-Real64 atan2 (Real64 x, Real64 y);
-#define Real64_Math_atan2 atan2
-static inline Real32 Real32_Math_atan2 (Real32 x, Real32 y) {
-	return (Real32)(Real64_Math_atan2 ((Real64)x, (Real64)y));
-}
+#define unaryReal(f,g)						\
+	Real64 g (Real64 x);					\
+	static inline Real64 Real64_##f (Real64 x) {		\
+		return g (x);					\
+	}							\
+	static inline Real32 Real32_##f (Real32 x) {		\
+		return (Real32)(Real64_##f ((Real64)x));	\
+	}
+unaryReal(round, rint)
+#undef unaryReal
+
+#define binaryReal(f,g)								\
+	Real64 g (Real64 x, Real64 y);						\
+	static inline Real64 Real64_Math_##f (Real64 x, Real64 y) {		\
+		return g (x, y);						\
+	}									\
+	static inline Real32 Real32_Math_##f (Real32 x, Real32 y) {		\
+		return (Real32)(Real64_Math_##f ((Real64)x, (Real64)y));	\
+	}
+binaryReal(atan2, atan2)
+#undef binaryReal
 
 #define unaryReal(f,g)						\
 	Real64 g (Real64 x);					\
@@ -460,6 +476,15 @@
 unaryReal(sin, sin)
 unaryReal(sqrt, sqrt)
 unaryReal(tan, tan)
+#undef unaryReal
+
+Real64 ldexp (Real64 x, Int32 i);
+static inline Real64 Real64_ldexp (Real64 x, Int32 i) {
+	return ldexp (x, i);
+}
+static inline Real32 Real32_ldexp (Real32 x, Int32 i) {
+	return (Real32)Real64_ldexp ((Real64)x, i);
+}
 
 #define binaryReal(name, op)						\
 	static inline Real32 Real32_##name (Real32 x, Real32 y) {	\
@@ -472,8 +497,8 @@
 binaryReal(div, /)
 binaryReal(mul, *)
 binaryReal(sub, -)
-
 #undef binaryReal
+
 #define binaryReal(name, op)					\
 	static inline Bool Real32_##name (Real32 x, Real32 y) {	\
 		return x op y;					\
@@ -486,6 +511,7 @@
 binaryReal(gt, >)
 binaryReal(le, <=)
 binaryReal(lt, <)
+#undef binaryReal
 
 #define Real32_muladd(x, y, z) ((x) * (y) + (z))
 #define Real32_mulsub(x, y, z) ((x) * (y) - (z))
@@ -493,8 +519,6 @@
 #define Real64_mulsub(x, y, z) ((x) * (y) - (z))
 #define Real32_neg(x) (-(x))
 #define Real64_neg(x) (-(x))
-#define Real32_toInt(x) ((Int)(x))
-#define Real64_toInt(x) ((Int)(x))
 
 typedef volatile union {
 	Word tab[2];
@@ -596,74 +620,68 @@
 	static inline t f##_to##t (f x) {	\
 		return (t)x;			\
 	}
-//coerce (Int64, Int64)
-coerce (Int64, Int32)
-//coerce (Int64, Int16)
-//coerce (Int64, Int8)
-coerce (Int32, Int64)
-coerce (Int32, Int32)
-coerce (Int32, Int16)
-coerce (Int32, Int8)
-//coerce (Int16, Int64)
-coerce (Int16, Int32)
 coerce (Int16, Int16)
+coerce (Int16, Int32)
 coerce (Int16, Int8)
-//coerce (Int8, Int64)
-coerce (Int8, Int32)
-coerce (Int8, Int16)
-coerce (Int8, Int8)
-//coerce (Int64, Real64)
-//coerce (Int64, Real32)
-coerce (Int32, Real64)
-coerce (Int32, Real32)
-coerce (Int16, Real64)
 coerce (Int16, Real32)
-coerce (Int8, Real64)
-coerce (Int8, Real32)
-coerce (Int64, Word32)
-//coerce (Int64, Word16)
-//coerce (Int64, Word8)  
-coerce (Int32, Word32)
-coerce (Int32, Word16)
-coerce (Int32, Word8)
-coerce (Int16, Word32)
+coerce (Int16, Real64)
 coerce (Int16, Word16)
+coerce (Int16, Word32)
 coerce (Int16, Word8)
-coerce (Int8, Word32)
+coerce (Int32, Int16)
+coerce (Int32, Int32)
+coerce (Int32, Int64)
+coerce (Int32, Int8)
+coerce (Int32, Real32)
+coerce (Int32, Real64)
+coerce (Int32, Word16)
+coerce (Int32, Word32)
+coerce (Int32, Word64)
+coerce (Int32, Word8)
+coerce (Int64, Int32)
+coerce (Int64, Word32)
+coerce (Int8, Int16)
+coerce (Int8, Int32)
+coerce (Int8, Int8)
+coerce (Int8, Real32)
+coerce (Int8, Real64)
 coerce (Int8, Word16)
+coerce (Int8, Word32)
 coerce (Int8, Word8)
-//coerce (Real64, Int64)
-coerce (Real64, Int32)
-coerce (Real64, Int16)
-coerce (Real64, Int8)
-//coerce (Real32, Int64)
-coerce (Real32, Int32)
 coerce (Real32, Int16)
+coerce (Real32, Int32)
 coerce (Real32, Int8)
-coerce (Real64, Real64)
-coerce (Real64, Real32)
-coerce (Real32, Real64)
 coerce (Real32, Real32)
-coerce (Word32, Int64)
-coerce (Word32, Int32)
-coerce (Word32, Int16)
-coerce (Word32, Int8)
-//coerce (Word16, Int64)
-coerce (Word16, Int32)
+coerce (Real32, Real64)
+coerce (Real64, Int16)
+coerce (Real64, Int32)
+coerce (Real64, Int8)
+coerce (Real64, Real32)
+coerce (Real64, Real64)
 coerce (Word16, Int16)
+coerce (Word16, Int32)
 coerce (Word16, Int8)
-//coerce (Word8, Int64)
-coerce (Word8, Int32)
-coerce (Word8, Int16)
-coerce (Word8, Int8)
-coerce (Word32, Word32)
-coerce (Word32, Word16)
-coerce (Word32, Word8)
-coerce (Word16, Word32)
 coerce (Word16, Word16)
+coerce (Word16, Word32)
+coerce (Word16, Word64)
 coerce (Word16, Word8)
-coerce (Word8, Word32)
+coerce (Word32, Int16)
+coerce (Word32, Int32)
+coerce (Word32, Int64)
+coerce (Word32, Int8)
+coerce (Word32, Word16)
+coerce (Word32, Word32)
+coerce (Word32, Word64)
+coerce (Word32, Word8)
+coerce (Word64, Word16)
+coerce (Word64, Word32)
+coerce (Word64, Word8)
+coerce (Word8, Int16)
+coerce (Word8, Int32)
+coerce (Word8, Int8)
 coerce (Word8, Word16)
+coerce (Word8, Word32)
+coerce (Word8, Word64)
 coerce (Word8, Word8)
 #undef coerce
 



1.16      +1 -1      mlton/mlton/atoms/const.fun

Index: const.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/const.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- const.fun	5 Mar 2004 03:50:52 -0000	1.15
+++ const.fun	16 Mar 2004 06:38:26 -0000	1.16
@@ -66,7 +66,7 @@
       fn Int i => IntX.layout i
        | IntInf i => IntInf.layout i
        | Real r => RealX.layout r
-       | Word w => WordX.layout w
+       | Word w => seq [str "0wx", WordX.layout w]
        | Word8Vector v => wrap ("\"", "\"", Word8.vectorToString v)
 end	 
 



1.62      +6 -15     mlton/mlton/backend/backend.fun

Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.61
retrieving revision 1.62
diff -u -r1.61 -r1.62
--- backend.fun	5 Mar 2004 09:28:07 -0000	1.61
+++ backend.fun	16 Mar 2004 06:38:26 -0000	1.62
@@ -169,8 +169,7 @@
 				Layouts Rssa.Program.layouts)
 	    else ()
 	 end
-      val program as R.Program.T {functions, main, objectTypes} = program
-      val handlesSignals = Rssa.Program.handlesSignals program
+      val R.Program.T {functions, handlesSignals, main, objectTypes} = program
       (* Chunk information *)
       val {get = labelChunk, set = setLabelChunk, ...} =
 	 Property.getSetOnce (Label.plist,
@@ -481,19 +480,11 @@
 					 {offset = offset,
 					  value = translateOperand value})})
 	     | PrimApp {dst, prim, args} =>
-		  let
-		     datatype z = datatype Prim.Name.t
-		  in
-		     case Prim.name prim of
-			MLton_installSignalHandler => Vector.new0 ()
-		      | MLton_touch => Vector.new0 ()
-		      | _ => 
-			   Vector.new1
-			   (M.Statement.PrimApp
-			    {args = translateOperands args,
-			     dst = Option.map (dst, varOperand o #1),
-			     prim = prim})
-		  end
+		  Vector.new1
+		  (M.Statement.PrimApp
+		   {args = translateOperands args,
+		    dst = Option.map (dst, varOperand o #1),
+		    prim = prim})
 	     | ProfileLabel s => Vector.new1 (M.Statement.ProfileLabel s)
 	     | SetExnStackLocal =>
 		  (* ExnStack = stackTop + (offset + WORD_SIZE) - StackBottom; *)



1.12      +2 -1      mlton/mlton/backend/implement-handlers.fun

Index: implement-handlers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/implement-handlers.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- implement-handlers.fun	20 Feb 2004 02:11:13 -0000	1.11
+++ implement-handlers.fun	16 Mar 2004 06:38:27 -0000	1.12
@@ -262,7 +262,7 @@
 		    start = newStart}
    end
 
-fun doit (Program.T {functions, main, objectTypes}) =
+fun doit (Program.T {functions, handlesSignals, main, objectTypes}) =
    let
       val implementFunction =
 	 case !Control.handlers of
@@ -270,6 +270,7 @@
 	  | Control.Simple => simple
    in
       Program.T {functions = List.revMap (functions, implementFunction),
+		 handlesSignals = handlesSignals,
 		 main = main,
 		 objectTypes = objectTypes}
    end



1.45      +2 -2      mlton/mlton/backend/limit-check.fun

Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -r1.44 -r1.45
--- limit-check.fun	5 Mar 2004 03:50:52 -0000	1.44
+++ limit-check.fun	16 Mar 2004 06:38:27 -0000	1.45
@@ -717,11 +717,10 @@
       f
    end
 
-fun insert (p as Program.T {functions, main, objectTypes}) =
+fun insert (p as Program.T {functions, handlesSignals, main, objectTypes}) =
    let
       val _ = Control.diagnostic (fn () => Layout.str "Limit Check maxPaths")
       datatype z = datatype Control.limitCheck
-      val handlesSignals = Program.handlesSignals p
       fun insert f =
 	 case !Control.limitCheck of
 	    PerBlock => insertPerBlock (f, handlesSignals)
@@ -750,6 +749,7 @@
 			       start = newStart}
    in
       Program.T {functions = functions,
+		 handlesSignals = handlesSignals,
 		 main = main,
 		 objectTypes = objectTypes}
    end



1.32      +2 -1      mlton/mlton/backend/profile.fun

Index: profile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.fun,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- profile.fun	5 Mar 2004 03:50:52 -0000	1.31
+++ profile.fun	16 Mar 2004 06:38:27 -0000	1.32
@@ -87,7 +87,7 @@
       then (program, fn _ => NONE)
    else
    let
-      val Program.T {functions, main, objectTypes} = program
+      val Program.T {functions, handlesSignals, main, objectTypes} = program
       val debug = false
       val profile = !Control.profile
       val profileAlloc: bool = profile = Control.ProfileAlloc
@@ -701,6 +701,7 @@
 			  start = start}
 	 end
       val program = Program.T {functions = List.revMap (functions, doFunction),
+			       handlesSignals = handlesSignals,
 			       main = doFunction main,
 			       objectTypes = objectTypes}
       val _ = addFuncEdges ()



1.43      +1 -6      mlton/mlton/backend/rssa.fun

Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- rssa.fun	5 Mar 2004 03:50:52 -0000	1.42
+++ rssa.fun	16 Mar 2004 06:38:27 -0000	1.43
@@ -633,6 +633,7 @@
    struct
       datatype t =
 	 T of {functions: Function.t list,
+	       handlesSignals: bool,
 	       main: Function.t,
 	       objectTypes: ObjectType.t vector}
 
@@ -647,12 +648,6 @@
 	    has main orelse List.exists (functions, has)
 	 end
 
-      fun handlesSignals p =
-	 hasPrim (p, fn p =>
-		  case Prim.name p of
-		     Prim.Name.MLton_installSignalHandler => true
-		   | _ => false)
-	 
       fun layouts (T {functions, main, objectTypes, ...},
 		   output': Layout.t -> unit): unit =
 	 let



1.28      +1 -1      mlton/mlton/backend/rssa.sig

Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- rssa.sig	5 Feb 2004 06:11:41 -0000	1.27
+++ rssa.sig	16 Mar 2004 06:38:27 -0000	1.28
@@ -222,12 +222,12 @@
 	 sig
 	    datatype t =
 	       T of {functions: Function.t list,
+		     handlesSignals: bool,
 		     main: Function.t,
 		     objectTypes: ObjectType.t vector}
 
 	    val clear: t -> unit
 	    val checkHandlers: t -> unit
-	    val handlesSignals: t -> bool
 	    val layouts: t * (Layout.t -> unit) -> unit
 	    val typeCheck: t -> unit
 	 end



1.21      +8 -7      mlton/mlton/backend/signal-check.fun

Index: signal-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/signal-check.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- signal-check.fun	20 Feb 2004 02:11:13 -0000	1.20
+++ signal-check.fun	16 Mar 2004 06:38:27 -0000	1.21
@@ -177,15 +177,16 @@
    end
 
 fun insert p =
-   if not (Program.handlesSignals p)
-      then p
-   else
-      let
-	 val Program.T {functions, main, objectTypes} = p
-      in
+   let
+      val Program.T {functions, handlesSignals, main, objectTypes} = p
+   in
+      if not handlesSignals
+	 then p
+      else
 	 Program.T {functions = List.revMap (functions, insertInFunction),
+		    handlesSignals = handlesSignals,
 		    main = main,
 		    objectTypes = objectTypes}
-      end
+   end
 
 end



1.61      +468 -255  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.60
retrieving revision 1.61
diff -u -r1.60 -r1.61
--- ssa-to-rssa.fun	15 Mar 2004 02:36:44 -0000	1.60
+++ ssa-to-rssa.fun	16 Mar 2004 06:38:27 -0000	1.61
@@ -34,157 +34,12 @@
 	 open CType
       in
 	 val Int32 = Int (IntSize.I 32)
-	 val Int64 = Int (IntSize.I 64)
 	 val Word32 = Word (WordSize.W 32)
-	 val Word64 = Word (WordSize.W 64)
       end
 
       datatype z = datatype CType.t
       datatype z = datatype Convention.t
 
-      local
-	 fun make (name, i) =
-	    CFunction.T {args = Vector.new3 (Pointer, Pointer, Word32),
-			 bytesNeeded = SOME i,
-			 convention = Cdecl,
-			 ensuresBytesFree = false,
-			 mayGC = false,
-			 maySwitchThreads = false,
-			 modifiesFrontier = true,
-			 modifiesStackTop = false,
-			 name = name,
-			 return = SOME CType.pointer}
-      in
-	 val intInfAdd = make ("IntInf_do_add", 2)
-	 val intInfAndb = make ("IntInf_do_andb", 2)
-	 val intInfGcd = make ("IntInf_do_gcd", 2)
-	 val intInfMul = make ("IntInf_do_mul", 2)
-	 val intInfOrb = make ("IntInf_do_orb", 2)
-	 val intInfQuot = make ("IntInf_do_quot", 2)
-	 val intInfRem = make ("IntInf_do_rem", 2)
-	 val intInfSub = make ("IntInf_do_sub", 2)
-	 val intInfXorb = make ("IntInf_do_xorb", 2)
-      end
-
-      local
-	 fun make (name, i) =
-	    CFunction.T {args = Vector.new3 (Pointer, Word32, Word32),
-			 bytesNeeded = SOME i,
-			 convention = Cdecl,
-			 ensuresBytesFree = false,
-			 mayGC = false,
-			 maySwitchThreads = false,
-			 modifiesFrontier = true,
-			 modifiesStackTop = false,
-			 name = name,
-			 return = SOME CType.pointer}
-      in
-	 val intInfArshift = make ("IntInf_do_arshift", 2)
-	 val intInfLshift = make ("IntInf_do_lshift", 2)
-      end
-
-      local
-	 fun make (name, i) =
-	    CFunction.T {args = Vector.new2 (Pointer, Word32),
-			 bytesNeeded = SOME i,
-			 convention = Cdecl,
-			 ensuresBytesFree = false,
-			 mayGC = false,
-			 maySwitchThreads = false,
-			 modifiesFrontier = true,
-			 modifiesStackTop = false,
-			 name = name,
-			 return = SOME CType.pointer}
-      in
-	 val intInfNeg = make ("IntInf_do_neg", 1)
-	 val intInfNotb = make ("IntInf_do_notb", 1)
-      end
-
-      val intInfToString =
-	 CFunction.T {args = Vector.new3 (Pointer, Int32, Word32),
-		      bytesNeeded = SOME 2,
-		      convention = Cdecl,
-		      ensuresBytesFree = false,
-		      mayGC = false,
-		      maySwitchThreads = false,
-		      modifiesFrontier = true,
-		      modifiesStackTop = false,
-		      name = "IntInf_do_toString",
-		      return = SOME Pointer}
-
-      local
-	 fun make name = vanilla {args = Vector.new2 (Pointer, Pointer),
-				  name = name,
-				  return = SOME CType.defaultInt}
-      in
-	 val intInfCompare = make "IntInf_compare"
-	 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
-
-      local
-	 fun make name =
-	    IntSize.memoize
-	    (fn s =>
-	     vanilla {args = Vector.new2 (CType.Int s, CType.Int s),
-		      name = concat ["Int", IntSize.toString s, "_", name],
-		      return = SOME CType.bool})
-      in
-	 val intGe = make "ge"
-	 val intGt = make "gt"
-	 val intLe = make "le"
-	 val intLt = make "lt"
-      end
-
-      local
-	 val int = ("Int", CType.Int, IntSize.memoize, IntSize.toString)
-	 val word = ("Word", CType.Word, WordSize.memoize, WordSize.toString)
-	 val wordX = ("WordX", CType.Word, WordSize.memoize, WordSize.toString)
-	 fun make ((fromName, fromType, fromMemo, fromString),
-		   (toName, toType, toMemo, toString)) =
-	    fn (s1, s2) =>
-	    vanilla {args = Vector.new1 (fromType s1),
-		     name = concat [fromName, fromString s1,
-				    "_to", toName, toString s2],
-		     return = SOME (toType s2)}
-      in
-	 val intToInt = make (int, int)
-	 val intToWord = make (int, word)
-	 val wordToInt = make (word, int)
-	 val wordToWord = make (word, word)
-      end
-
-      fun wordToWordX (s1, s2) =
-	 vanilla {args = Vector.new1 (CType.Word s1),
-		  name = concat ["Word", WordSize.toString s1,
-				 "_toWord", WordSize.toString s2,
-				 "X"],
-		  return = SOME (CType.Word s2)}
-   
-      local
-	 fun make name =
-	    IntSize.memoize
-	    (fn s =>
-	     vanilla {args = Vector.new2 (CType.Int s, CType.Int s),
-		      name = concat ["Int", IntSize.toString s, "_", name],
-		      return = SOME (CType.Int s)})
-      in
-	 val intMul = make "mul"
-	 val intQuot = make "quot"
-	 val intRem = make "rem"
-      end
-
-      val word64Equal = vanilla {args = Vector.new2 (Word64, Word64),
-				 name = "Word64_equal",
-				 return = SOME CType.defaultInt}
-
       val copyCurrentThread =
 	 T {args = Vector.new1 Pointer,
 	    bytesNeeded = NONE,
@@ -297,6 +152,443 @@
 	    return = NONE}
    end
 
+structure Name =
+   struct
+      open Prim.Name
+
+      fun cFunctionRaise (n: t): CFunction.t =
+	 let
+	    datatype z = datatype CFunction.Convention.t
+	    val vanilla = CFunction.vanilla
+	    val int = ("Int", CType.Int, IntSize.toString)
+	    val real = ("Real", CType.Real, RealSize.toString)
+	    val word = ("Word", CType.Word, WordSize.toString)
+	    fun coerce (s1, (fromName, fromType, fromString),
+			s2, (toName, toType, toString)) =
+	       vanilla {args = Vector.new1 (fromType s1),
+			name = concat [fromName, fromString s1,
+				       "_to", toName, toString s2],
+			return = SOME (toType s2)}
+	    fun coerceX (s1, (fromName, fromType, fromString),
+			 s2, (toName, toType, toString)) =
+	       vanilla {args = Vector.new1 (fromType s1),
+			name = concat [fromName, fromString s1,
+				       "_to", toName, toString s2, "X"],
+			return = SOME (toType s2)}
+	    fun intBinary (s, name) =
+	       let
+		  val t = CType.Int s
+	       in
+		  vanilla {args = Vector.new2 (t, t),
+			   name = concat ["Int", IntSize.toString s, "_", name],
+			   return = SOME t}
+	       end
+	    fun intCompare (s, name) =
+	       vanilla {args = Vector.new2 (CType.Int s, CType.Int s),
+			name = concat ["Int", IntSize.toString s, "_", name],
+			return = SOME CType.bool}
+	    fun intInfBinary name =
+	       CFunction.T {args = Vector.new3 (CType.pointer, CType.pointer,
+						CType.defaultWord),
+			    bytesNeeded = SOME 2,
+			    convention = Cdecl,
+			    ensuresBytesFree = false,
+			    mayGC = false,
+			    maySwitchThreads = false,
+			    modifiesFrontier = true,
+			    modifiesStackTop = false,
+			    name = concat ["IntInf_do_", name],
+			    return = SOME CType.pointer}
+	    fun intInfCompare name =
+	       vanilla {args = Vector.new2 (CType.pointer, CType.pointer),
+			name = concat ["IntInf_do_", name],
+			return = SOME CType.defaultInt}
+	    fun intInfShift name =
+	       CFunction.T {args = Vector.new3 (CType.pointer,
+						CType.defaultWord,
+						CType.defaultWord),
+			    bytesNeeded = SOME 2,
+			    convention = Cdecl,
+			    ensuresBytesFree = false,
+			    mayGC = false,
+			    maySwitchThreads = false,
+			    modifiesFrontier = true,
+			    modifiesStackTop = false,
+			    name = concat ["IntInf_do_", name],
+			    return = SOME CType.pointer}
+	    val intInfToString =
+	       CFunction.T {args = Vector.new3 (CType.pointer,
+						CType.defaultInt,
+						CType.defaultWord),
+			    bytesNeeded = SOME 2,
+			    convention = Cdecl,
+			    ensuresBytesFree = false,
+			    mayGC = false,
+			    maySwitchThreads = false,
+			    modifiesFrontier = true,
+			    modifiesStackTop = false,
+			    name = "IntInf_do_toString",
+			    return = SOME CType.pointer}
+	    fun intInfUnary name =
+	       CFunction.T {args = Vector.new2 (CType.pointer,
+						CType.defaultWord),
+			    bytesNeeded = SOME 1,
+			    convention = Cdecl,
+			    ensuresBytesFree = false,
+			    mayGC = false,
+			    maySwitchThreads = false,
+			    modifiesFrontier = true,
+			    modifiesStackTop = false,
+			    name = concat ["IntInf_do", name],
+			    return = SOME CType.pointer}
+	    fun wordBinary (s, name) =
+	       let
+		  val t = CType.Word s
+	       in
+		  vanilla {args = Vector.new2 (t, t),
+			   name = concat ["Word", WordSize.toString s,
+					  "_", name],
+			   return = SOME t}
+	       end
+	    fun wordCompare (s, name) =
+	       vanilla {args = Vector.new2 (CType.Word s, CType.Word s),
+			name = concat ["Word", WordSize.toString s, "_", name],
+			return = SOME CType.bool}
+	    fun wordShift (s, name) =
+	       vanilla {args = Vector.new2 (CType.Word s, CType.defaultWord),
+			name = concat ["Word", WordSize.toString s, "_", name],
+			return = SOME (CType.Word s)}
+	    fun wordUnary (s, name) =
+	       vanilla {args = Vector.new1 (CType.Word s),
+			name = concat ["Word", WordSize.toString s, "_", name],
+			return = SOME (CType.Word s)}
+	 in
+	    case n of
+	       Int_add s => intBinary (s, "add")
+	     | Int_equal s =>
+		  let
+		     val s = IntSize.roundUpToPrim s
+		  in
+		     vanilla {args = Vector.new2 (CType.Int s, CType.Int s),
+			      name = concat ["Int", IntSize.toString s,
+					     "_equal"],
+			      return = SOME CType.defaultInt}
+		  end
+	     | Int_ge s => intCompare (s, "ge")
+	     | Int_gt s => intCompare (s, "gt")
+	     | Int_le s => intCompare (s, "le")
+	     | Int_lt s => intCompare (s, "lt")
+	     | Int_mul s => intBinary (s, "mul")
+	     | Int_quot s => intBinary (s, "quot")
+	     | Int_rem s => intBinary (s, "rem")
+	     | Int_toInt (s1, s2) => coerce (s1, int, s2, int)
+	     | Int_toReal (s1, s2) => coerce (s1, int, s2, real)
+	     | Int_toWord (s1, s2) => coerce (s1, int, s2, word)
+	     | IntInf_add => intInfBinary "add"
+	     | IntInf_andb => intInfBinary "andb"
+	     | IntInf_arshift => intInfShift "arshift"
+	     | IntInf_compare => intInfCompare "compare"
+	     | IntInf_equal =>  intInfCompare "equal"
+	     | IntInf_gcd => intInfBinary "gcd"
+	     | IntInf_lshift => intInfShift "lshift"
+	     | IntInf_mul => intInfBinary "mul"
+	     | IntInf_neg => intInfUnary "neg"
+	     | IntInf_notb => intInfUnary "notb"
+	     | IntInf_orb => intInfBinary "orb"
+	     | IntInf_quot => intInfBinary "quot"
+	     | IntInf_rem => intInfBinary "rem"
+	     | IntInf_sub => intInfBinary "sub"
+	     | IntInf_toString => intInfToString
+	     | IntInf_xorb => intInfBinary "xorb"
+	     | MLton_bug => CFunction.bug
+	     | MLton_size => CFunction.size
+	     | Thread_returnToC => CFunction.returnToC
+	     | Word_add s => wordBinary (s, "add")
+	     | Word_andb s => wordBinary (s, "andb")
+	     | Word_arshift s => wordShift (s, "arshift")
+	     | Word_div s => wordBinary (s, "div")
+	     | Word_equal s => wordCompare (s, "equal")
+	     | Word_ge s => wordCompare (s, "ge")
+	     | Word_gt s => wordCompare (s, "gt")
+	     | Word_le s => wordCompare (s, "le")
+	     | Word_lshift s => wordShift (s, "lshift")
+	     | Word_lt s => wordCompare (s, "lt")
+	     | Word_mod s => wordBinary (s, "mod")
+	     | Word_mul s => wordBinary (s, "mul")
+	     | Word_neg s => wordUnary (s, "neg")
+	     | Word_notb s => wordUnary (s, "notb")
+	     | Word_orb s => wordBinary (s, "orb")
+	     | Word_rol s => wordShift (s, "rol")
+	     | Word_ror s => wordShift (s, "ror")
+	     | Word_rshift s => wordShift (s, "rshift")
+	     | Word_sub s => wordBinary (s, "sub")
+	     | Word_toInt (s1, s2) => coerce (s1, word, s2, int)
+	     | Word_toIntX (s1, s2) => coerceX (s1, word, s2, int)
+	     | Word_toWord (s1, s2) => coerce (s1, word, s2, word)
+	     | Word_toWordX (s1, s2) => coerceX (s1, word, s2, word)
+	     | Word_xorb s => wordBinary (s, "xorb")
+	     | _ => raise Fail "cFunctionRaise"
+	 end
+
+      fun cFunction n = SOME (cFunctionRaise n) handle _ => NONE
+
+      fun cCodegenImplements n =
+	 let
+	    datatype z = datatype RealSize.t
+	 in
+	    case n of
+	       FFI_Symbol _ => true
+	     | Int_add _ => true
+	     | Int_equal _ => true
+	     | Int_ge _ => true
+	     | Int_gt _ => true
+	     | Int_le _ => true
+	     | Int_lt _ => true
+	     | Int_mul _ => true
+	     | Int_neg _ => true
+	     | Int_sub _ => true
+	     | Int_toInt _ => true
+	     | Int_toReal _ => true
+	     | Int_toWord _ => true
+	     | MLton_eq => true
+	     | Real_Math_acos _ => true
+	     | Real_Math_asin _ => true
+	     | Real_Math_atan _ => true
+	     | Real_Math_atan2 _ => true
+	     | Real_Math_cos _ => true
+	     | Real_Math_exp _ => true
+	     | Real_Math_ln _ => true
+	     | Real_Math_log10 _ => true
+	     | Real_Math_sin _ => true
+	     | Real_Math_sqrt _ => true
+	     | Real_Math_tan _ => true
+	     | Real_add _ => true
+	     | Real_div _ => true
+	     | Real_equal _ => true
+	     | Real_ge _ => true
+	     | Real_gt _ => true
+	     | Real_ldexp _ => true
+	     | Real_le _ => true
+	     | Real_lt _ => true
+	     | Real_mul _ => true
+	     | Real_muladd _ => true
+	     | Real_mulsub _ => true
+	     | Real_neg _ => true
+	     | Real_round _ => true
+	     | Real_sub _ => true
+	     | Real_toInt _ => true
+	     | Real_toReal _ => true
+	     | Thread_returnToC => true
+	     | Word_add _ => true
+	     | Word_andb _ => true
+	     | Word_arshift _ => true
+	     | Word_div _ => true
+	     | Word_equal _ => true
+	     | Word_ge _ => true
+	     | Word_gt _ => true
+	     | Word_le _ => true
+	     | Word_lshift _ => true
+	     | Word_lt _ => true
+	     | Word_mod _ => true
+	     | Word_mul _ => true
+	     | Word_neg _ => true
+	     | Word_notb _ => true
+	     | Word_orb _ => true
+	     | Word_rol _ => true
+	     | Word_ror _ => true
+	     | Word_rshift _ => true
+	     | Word_sub _ => true
+	     | Word_toInt _ => true
+	     | Word_toIntX _ => true
+	     | Word_toWord _ => true
+	     | Word_toWordX _ => true
+	     | Word_xorb _ => true
+	     | _ => false
+	 end
+
+      fun x86CodegenImplements n =
+	 let
+	    datatype z = datatype IntSize.prim
+	    datatype z = datatype RealSize.t
+	    datatype z = datatype WordSize.prim
+	    fun i32168 s =
+	       case IntSize.prim s of
+		  I8 => true
+		| I16 => true
+		| I32 => true
+		| I64 => false
+	    fun w32168 s =
+	       case WordSize.prim s of
+		  W8 => true
+		| W16 => true
+		| W32 => true
+		| W64 => false
+	 in
+	    case n of
+	       FFI_Symbol _ => true
+	     | Int_add _ => true
+	     | Int_addCheck _ => true
+	     | Int_equal s => i32168 s
+	     | Int_ge s => i32168 s
+	     | Int_gt s => i32168 s
+	     | Int_le s => i32168 s
+	     | Int_lt s => i32168 s
+	     | Int_mul s => i32168 s
+	     | Int_mulCheck s => i32168 s
+	     | Int_neg _ => true
+	     | Int_negCheck _ => true
+	     | Int_quot s => i32168 s
+	     | Int_rem s => i32168 s
+	     | Int_sub _ => true
+	     | Int_subCheck _ => true
+	     | Int_toInt (s1, s2) =>
+		  (case (IntSize.prim s1, IntSize.prim s2) of
+		      (I32, I32) => true
+		    | (I32, I16) => true
+		    | (I32, I8) => true
+		    | (I16, I32) => true
+		    | (I16, I16) => true
+		    | (I16, I8) => true
+		    | (I8, I32) => true
+		    | (I8, I16) => true
+		    | _ => false)
+	     | Int_toReal (s1, s2) =>
+		  (case (IntSize.prim s1, s2) of
+		      (I32, R64) => true
+		    | (I32, R32) => true
+		    | (I16, R64) => true
+		    | (I16, R32) => true
+		    | (I8, R64) => true
+		    | (I8, R32) => true
+		    | _ => false)
+	      | Int_toWord (s1, s2) =>
+		   (case (IntSize.prim s1, WordSize.prim s2) of
+		       (I32, W32) => true
+		     | (I32, W16) => true
+		     | (I32, W8) => true
+		     | (I16, W32) => true
+		     | (I16, W16) => true
+		     | (I16, W8) => true
+		     | (I8, W32) => true
+		     | (I8, W16) => true
+		     | (I8, W8) => true
+		     | _ => false)
+	      | MLton_eq => true
+	      | Real_Math_acos _ => true
+	      | Real_Math_asin _ => true
+	      | Real_Math_atan _ => true
+	      | Real_Math_atan2 _ => true
+	      | Real_Math_cos _ => true
+	      | Real_Math_exp _ => true
+	      | Real_Math_ln _ => true
+	      | Real_Math_log10 _ => true
+	      | Real_Math_sin _ => true
+	      | Real_Math_sqrt _ => true
+	      | Real_Math_tan _ => true
+	      | Real_abs _ => true
+	      | Real_add _ => true
+	      | Real_div _ => true
+	      | Real_equal _ => true
+	      | Real_ge _ => true
+	      | Real_gt _ => true
+	      | Real_ldexp _ => true
+	      | Real_le _ => true
+	      | Real_lt _ => true
+	      | Real_mul _ => true
+	      | Real_muladd _ => true
+	      | Real_mulsub _ => true
+	      | Real_neg _ => true
+	      | Real_qequal _ => true
+	      | Real_round _ => true
+	      | Real_sub _ => true
+	      | Real_toInt (s1, s2) =>
+		   (case (s1, IntSize.prim s2) of
+		       (R64, I32) => true
+		     | (R64, I16) => true
+		     | (R64, I8) => true
+		     | (R32, I32) => true
+		     | (R32, I16) => true
+		     | (R32, I8) => true
+		     | _ => false)
+	      | Real_toReal _ => true
+	      | Word_add _ => true
+	      | Word_addCheck _ => true
+	      | Word_andb _ => true
+	      | Word_arshift s => w32168 s
+	      | Word_div s => w32168 s
+	      | Word_equal s => w32168 s
+	      | Word_ge s => w32168 s
+	      | Word_gt s => w32168 s
+	      | Word_le s => w32168 s
+	      | Word_lshift s => w32168 s
+	      | Word_lt s => w32168 s
+	      | Word_mod s => w32168 s
+	      | Word_mul s => w32168 s
+	      | Word_mulCheck s => w32168 s
+	      | Word_neg _ => true
+	      | Word_notb _ => true
+	      | Word_orb _ => true
+	      | Word_rol s => w32168 s
+	      | Word_ror s => w32168 s
+	      | Word_rshift s => w32168 s
+	      | Word_sub _ => true
+	      | Word_toInt (s1, s2) =>
+		   (case (WordSize.prim s1, IntSize.prim s2) of
+		       (W32, I32) => true
+		     | (W32, I16) => true
+		     | (W32, I8) => true
+		     | (W16, I32) => true
+		     | (W16, I16) => true
+		     | (W16, I8) => true
+		     | (W8, I32) => true
+		     | (W8, I16) => true
+		     | (W8, I8) => true
+		     | _ => false)
+	      | Word_toIntX (s1, s2) =>
+		   (case (WordSize.prim s1, IntSize.prim s2) of
+		       (W32, I32) => true
+		     | (W32, I16) => true
+		     | (W32, I8) => true
+		     | (W16, I32) => true
+		     | (W16, I16) => true
+		     | (W16, I8) => true
+		     | (W8, I32) => true
+		     | (W8, I16) => true
+		     | (W8, I8) => true
+		     | _ => false)
+	      | Word_toWord (s1, s2) =>
+		   (case (WordSize.prim s1, WordSize.prim s2) of
+		       (W32, W32) => true
+		     | (W32, W16) => true
+		     | (W32, W8) => true
+		     | (W16, W32) => true
+		     | (W16, W16) => true
+		     | (W16, W8) => true
+		     | (W8, W32) => true
+		     | (W8, W16) => true
+		     | (W8, W8) => true
+		     | _ => false)
+	      | Word_toWordX (s1, s2) =>
+		   (case (WordSize.prim s1, WordSize.prim s2) of
+		       (W32, W32) => true
+		     | (W32, W16) => true
+		     | (W32, W8) => true
+		     | (W16, W32) => true
+		     | (W16, W16) => true
+		     | (W16, W8) => true
+		     | (W8, W32) => true
+		     | (W8, W16) => true
+		     | (W8, W8) => true
+		     | _ => false)
+	      | Word_xorb _ => true
+	      | _ => false
+	 end
+
+      val x86CodegenImplements =
+	 Trace.trace ("x86CodegenImplements", layout, Bool.layout)
+	  x86CodegenImplements
+   end
+
 datatype z = datatype Operand.t
 datatype z = datatype Statement.t
 datatype z = datatype Transfer.t
@@ -801,6 +1093,7 @@
 	     | Type.Real s => c (Const.real (RealX.zero s))
 	     | Type.Word s => c (Const.word (WordX.zero s))
 	 end
+      val handlesSignals = ref false
       fun translateStatementsTransfer (statements, ss, transfer) =
 	 let
 	    fun loop (i, ss, t): Statement.t vector * Transfer.t =
@@ -939,7 +1232,6 @@
 				 add (PrimApp {dst = dst (),
 					       prim = prim,
 					       args = varOps args})
-			      fun normal () = primApp prim
 			      datatype z = datatype Prim.Name.t
 			      fun bumpCanHandle n =
 				 let
@@ -1118,7 +1410,6 @@
 						      index = varOp (a 1),
 						      ty = ty},
 				   src = varOp (a 2)})
-			      
 		     fun refAssign (ty, src) =
 		        let
 			   val addr = varOp (a 0)
@@ -1131,12 +1422,21 @@
 			      then updateCard (addr, fn ss => ss, assign)
 			   else loop (i - 1, assign::ss, t)
 			end
-		     fun int (s, f) =
-			if IntSize.equals (s, IntSize.I 64)
-			   andalso !Control.Native.native 
-			   then simpleCCall f
-			else normal ()
-			      datatype z = datatype Prim.Name.t
+		     fun nativeOrC (p: Prim.t) =
+			let
+			   val n = Prim.name p
+			in
+			   if if !Control.Native.native
+				 then Name.x86CodegenImplements n
+			      else Name.cCodegenImplements n
+			      then primApp p
+			   else (case Name.cFunction n of
+				    NONE =>
+				       Error.bug (concat ["unimplemented prim:",
+							  Name.toString n])
+				  | SOME f => simpleCCall f)
+			end
+		     datatype z = datatype Prim.Name.t
 			   in
 			      case Prim.name prim of
 				 Array_array =>
@@ -1194,81 +1494,31 @@
 				    ccall {args = Vector.new1 Operand.GCState,
 					   func = CFunction.unpack}
 			       | Int_equal s =>
-				    let
-				       val s = IntSize.roundUpToPrim s
-				    in
-				       if 64 = IntSize.bits s
-					  andalso !Control.Native.native
-					  then simpleCCall CFunction.int64Equal
-				       else primApp (Prim.intEqual s)
-				    end
-			       | Int_ge s => int (s, CFunction.intGe s)
-			       | Int_gt s => int (s, CFunction.intGt s)
-			       | Int_le s => int (s, CFunction.intLe s)
-			       | Int_lt s => int (s, CFunction.intLt s)
-			       | Int_mul s => int (s, CFunction.intMul s)
-			       | Int_quot s => int (s, CFunction.intQuot s)
-			       | Int_rem s => int (s, CFunction.intRem s)
+				    nativeOrC (Prim.intEqual
+					       (IntSize.roundUpToPrim s))
 			       | Int_toInt (s1, s2) =>
 				    let
-				       fun call () =
-					  if !Control.Native.native
-					     then
-						simpleCCall
-						(CFunction.intToInt (s1, s2))
-					  else normal ()
 				       val s1 = IntSize.roundUpToPrim s1
 				       val s2 = IntSize.roundUpToPrim s2
-				       val b1 = IntSize.bits s1
-				       val b2 = IntSize.bits s2
 				    in
-				       if b1 = b2
+				       if IntSize.equals (s1, s2)
 					  then cast ()
-				       else if b1 = 64 orelse b2 = 64
-					       then call ()
-				       else primApp (Prim.intToInt (s1, s2))
+				       else nativeOrC (Prim.intToInt (s1, s2))
 				    end
-			       | Int_toWord (s1, s2) =>
-				    if (case (IntSize.prim s1,
-					      WordSize.prim s2) of
-					   (I64, W32) => true
-					 | _ => false)
-				       andalso !Control.Native.native
-				       then simpleCCall (CFunction.intToWord (s1, s2))
-				    else normal ()
-			       | IntInf_add => simpleCCall CFunction.intInfAdd
-			       | IntInf_andb => simpleCCall CFunction.intInfAndb
-			       | IntInf_arshift =>
-				    simpleCCall CFunction.intInfArshift
-			       | IntInf_compare =>
-				    simpleCCall CFunction.intInfCompare
-			       | IntInf_equal =>
-				    simpleCCall CFunction.intInfEqual
-			       | IntInf_gcd => simpleCCall CFunction.intInfGcd
-			       | IntInf_lshift =>
-				    simpleCCall CFunction.intInfLshift
-			       | IntInf_mul => simpleCCall CFunction.intInfMul
-			       | IntInf_neg => simpleCCall CFunction.intInfNeg
-			       | IntInf_notb => simpleCCall CFunction.intInfNotb
-			       | IntInf_orb => simpleCCall CFunction.intInfOrb
-			       | IntInf_quot => simpleCCall CFunction.intInfQuot
-			       | IntInf_rem => simpleCCall CFunction.intInfRem
-			       | IntInf_sub => simpleCCall CFunction.intInfSub
-			       | IntInf_toString =>
-				    simpleCCall CFunction.intInfToString
 			       | IntInf_toVector => cast ()
 			       | IntInf_toWord => cast ()
-			       | IntInf_xorb => simpleCCall CFunction.intInfXorb
 			       | MLton_bogus =>
 				    (case toRtype ty of
 					NONE => none ()
 				      | SOME t => move (bogus t))
-			       | MLton_bug => simpleCCall CFunction.bug
 			       | MLton_eq =>
 				    (case targ () of
 					NONE => move (Operand.bool true)
-				      | SOME _ => normal ())
-			       | MLton_size => simpleCCall CFunction.size
+				      | SOME _ => primApp prim)
+			       | MLton_installSignalHandler =>
+				    (handlesSignals := true
+				     ; none ())
+			       | MLton_touch => none ()
 			       | Pointer_getInt s => pointerGet (Type.Int s)
 			       | Pointer_getPointer =>
 				    (case targ () of
@@ -1394,9 +1644,6 @@
 						   [Vector.new1 Operand.GCState,
 						    vos args]),
 					   func = CFunction.copyThread}
-			       | Thread_returnToC =>
-				    ccall {args = vos args,
-					   func = CFunction.returnToC}
 			       | Thread_switchTo =>
 				    ccall {args = (Vector.new2
 						   (varOp (a 0),
@@ -1434,52 +1681,17 @@
 				     end,
 				     none)
 			       | Word_equal s =>
-				    let
-				       val s = WordSize.roundUpToPrim s
-				    in
-				       if 64 = WordSize.bits s
-					  andalso !Control.Native.native
-					  then simpleCCall CFunction.word64Equal
-				       else primApp (Prim.wordEqual s)
-				    end
-			       | Word_toInt (s1, s2) =>
-				    if (case (WordSize.prim s1, IntSize.prim s2) of
-					   (W32, I64) => true
-					 | _ => false)
-				       andalso !Control.Native.native
-				       then simpleCCall (CFunction.wordToInt (s1, s2))
-				    else normal ()
+				    nativeOrC (Prim.wordEqual
+					       (WordSize.roundUpToPrim s))
 			       | Word_toIntInf => cast ()
 			       | Word_toWord (s1, s2) =>
 				    let
-				       fun call () =
-					  if !Control.Native.native
-					     then
-						simpleCCall
-						(CFunction.wordToWord (s1, s2))
-					  else normal ()
 				       val s1 = WordSize.roundUpToPrim s1
 				       val s2 = WordSize.roundUpToPrim s2
-				       val b1 = WordSize.bits s1
-				       val b2 = WordSize.bits s2
 				    in
-				       if b1 = b2
+				       if WordSize.equals (s1, s2)
 					  then cast ()
-				       else if b1 = 64 orelse b2 = 64
-					       then call ()
-				       else primApp (Prim.wordToWord (s1, s2))
-				    end
-			       | Word_toWordX (s1, s2) =>
-				    let
-				       val b1 = WordSize.bits s1
-				       val b2 = WordSize.bits s2
-				    in
-				       if (b1 = 64 orelse b2 = 64)
-					  andalso (!Control.Native.native)
-					  then
-					     simpleCCall
-					     (CFunction.wordToWordX (s1, s2))
-				       else normal ()
+				       else nativeOrC (Prim.wordToWord (s1, s2))
 				    end
 			       | WordVector_toIntInf => cast ()
 			       | Word8Array_subWord => sub Type.defaultWord
@@ -1491,7 +1703,7 @@
 						   (Operand.GCState,
 						    Vector.sub (vos args, 0))),
 					   func = CFunction.worldSave}
-			       | _ => normal ()
+			       | _ => nativeOrC prim
 			   end
 		      | S.Exp.Profile e => add (Statement.Profile e)
 		      | S.Exp.Select {tuple, offset} =>
@@ -1589,6 +1801,7 @@
 	  end
       val functions = List.revMap (functions, translateFunction)
       val p = Program.T {functions = functions,
+			 handlesSignals = !handlesSignals,
 			 main = main,
 			 objectTypes = objectTypes}
       val _ = Program.clear p