[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