From 6f763d9a39ea5de53fe141a0cddf55fd2af5c02a Mon Sep 17 00:00:00 2001 From: Martin Elsman Date: Thu, 30 Apr 2020 10:49:55 +0200 Subject: [PATCH] Word64 and Int64 support (#42) * first commit * some js-fixes * more work towards 64 bits words and ints * more coverage * initial work on Word64 structure support * initial work on Int64 structure support * finalize Word64/63 and Int64/63 support --- basis/INT_INF_REP.sml | 16 +- basis/Initial.sml | 58 +- basis/Int.sml | 62 +- basis/Int31.sml | 53 +- basis/Int32.sml | 38 +- basis/Int63.sml | 121 +++ basis/Int64.sml | 126 +++ basis/IntInfRep.sml | 293 ++++--- basis/WORD.sig | 26 +- basis/Word.sml | 72 +- basis/Word31.sml | 68 +- basis/Word32.sml | 70 +- basis/Word63.sml | 154 ++++ basis/Word64.sml | 164 ++++ basis/Word8.sml | 116 ++- basis/basis.mlb | 4 +- js/prims.js | 24 +- js/test/int.sml | 82 +- src/Common/EfficientElab/Environments.sml | 46 +- src/Common/EfficientElab/StatObject.sml | 608 +++++++------- src/Common/ElabDec.sml | 8 + src/Common/Flags.sml | 226 +++--- src/Common/OVERLOADING_INFO.sml | 4 + src/Common/OverloadingInfo.sml | 29 +- src/Common/SCON.sig | 6 +- src/Common/SCon.sml | 8 +- src/Common/STATOBJECT.sml | 35 +- src/Common/TYCON.sig | 4 + src/Common/TYNAME.sig | 4 + src/Common/TyCon.sml | 4 + src/Common/TyName.sml | 48 +- src/Compiler/Backend/BackendInfo.sml | 4 +- src/Compiler/Backend/CLOS_EXP.sml | 8 +- src/Compiler/Backend/ClosExp.sml | 85 +- src/Compiler/Backend/JS/ExecutionJS.sml | 43 +- src/Compiler/Backend/JS/ExpToJs2.sml | 21 +- src/Compiler/Backend/JS/JS_AST.sml | 11 +- src/Compiler/Backend/JS/JsAst.sml | 52 +- src/Compiler/Backend/JUMP_TABLES.sml | 14 +- src/Compiler/Backend/JumpTables.sml | 44 +- src/Compiler/Backend/LINE_STMT.sml | 8 +- src/Compiler/Backend/LineStmt.sml | 24 +- src/Compiler/Backend/PrimName.sml | 464 ++++++++++- src/Compiler/Backend/SUBST_AND_SIMPLIFY.sml | 14 +- src/Compiler/Backend/SubstAndSimplify.sml | 19 +- src/Compiler/Backend/X64/CodeGenUtilX64.sml | 830 +++++++++++++++----- src/Compiler/Backend/X64/CodeGenX64.sml | 518 ++++++++---- src/Compiler/Backend/X64/INSTS_X64.sml | 4 +- src/Compiler/Backend/X64/InstsX64.sml | 16 +- src/Compiler/CompBasis.sml | 12 +- src/Compiler/Lambda/CompileDec.sml | 589 ++++++++++---- src/Compiler/Lambda/CompilerEnv.sml | 56 +- src/Compiler/Lambda/EliminateEq.sml | 52 +- src/Compiler/Lambda/LAMBDA_EXP.sml | 16 +- src/Compiler/Lambda/LambdaExp.sml | 104 ++- src/Compiler/Lambda/LambdaStatSem.sml | 18 +- src/Compiler/Lambda/OptLambda.sml | 72 +- src/Compiler/Regions/MUL_EXP.sml | 8 +- src/Compiler/Regions/MulExp.sml | 16 +- src/Compiler/Regions/REGION_EXP.sml | 8 +- src/Compiler/Regions/RTYPE.sig | 4 + src/Compiler/Regions/RType.sml | 13 +- src/Compiler/Regions/RegionExp.sml | 16 +- src/Compiler/Regions/RegionStatEnv.sml | 6 +- src/Compiler/Regions/SpreadExpression.sml | 37 +- src/Manager/FreeIds.sml | 14 +- src/Manager/ManagerObjects0.sml | 8 +- src/Parsing/GRAMMAR_UTILS.sml | 2 +- src/Parsing/LEX_UTILS.sml | 2 +- src/Parsing/LexUtils.sml | 26 +- src/Parsing/Topdec.grm | 4 +- src/Parsing/Topdec.grm.sig | 2 +- src/Parsing/Topdec.grm.sml | 4 +- src/Runtime/Math.c | 228 +++++- src/Runtime/Math.h | 63 +- src/Runtime/String.c | 9 + src/Runtime/Tagging.h | 9 +- src/Runtime/Time.c | 18 +- test/Makefile | 21 +- test/all.tst | 4 + test/int.sml | 112 +-- test/int31_2.sml | 6 +- test/int32_2.sml | 31 +- test/int63.sml | 253 ++++++ test/int63.sml.out.ok | 187 +++++ test/int63_2.sml | 111 +++ test/int63_2.sml.out.ok | 54 ++ test/int64.sml | 276 +++++++ test/int64.sml.out.ok | 209 +++++ test/int_2.sml | 71 +- test/pickle.sig | 27 +- test/pickle.sml | 245 +++--- test/pickletest.sml | 83 +- test/real.sml | 175 +++-- test/real.sml.out.ok | 1 + test/real_match.sml.out.ok | 1 + test/word.sml | 118 +-- test/word31.sml | 120 +-- test/word32.sml | 147 ++-- test/word32.sml.out.ok | 7 - test/word64.sml | 395 ++++++++++ test/word64.sml.out.ok | 67 ++ 102 files changed, 6512 insertions(+), 2381 deletions(-) create mode 100644 basis/Int63.sml create mode 100644 basis/Int64.sml create mode 100644 basis/Word63.sml create mode 100644 basis/Word64.sml create mode 100644 test/int63.sml create mode 100644 test/int63.sml.out.ok create mode 100644 test/int63_2.sml create mode 100644 test/int63_2.sml.out.ok create mode 100644 test/int64.sml create mode 100644 test/int64.sml.out.ok create mode 100644 test/real_match.sml.out.ok create mode 100644 test/word64.sml create mode 100644 test/word64.sml.out.ok diff --git a/basis/INT_INF_REP.sml b/basis/INT_INF_REP.sml index 7bbbae886..5e081af31 100644 --- a/basis/INT_INF_REP.sml +++ b/basis/INT_INF_REP.sml @@ -7,7 +7,7 @@ signature INT_INF_REP = sig type intinf - + val fromInt : int -> intinf val toInt : intinf -> int @@ -17,6 +17,12 @@ signature INT_INF_REP = val fromInt32 : int32 -> intinf val toInt32 : intinf -> int32 + val fromInt63 : int63 -> intinf + val toInt63 : intinf -> int63 + + val fromInt64 : int64 -> intinf + val toInt64 : intinf -> int64 + val fromWord : word -> intinf val fromWordX : word -> intinf val toWord : intinf -> word @@ -33,6 +39,14 @@ signature INT_INF_REP = val fromWord32X : word32 -> intinf val toWord32 : intinf -> word32 + val fromWord63 : word63 -> intinf + val fromWord63X : word63 -> intinf + val toWord63 : intinf -> word63 + + val fromWord64 : word64 -> intinf + val fromWord64X : word64 -> intinf + val toWord64 : intinf -> word64 + (* for overloading *) val + : intinf * intinf -> intinf val - : intinf * intinf -> intinf diff --git a/basis/Initial.sml b/basis/Initial.sml index bd263476a..364a4ff30 100644 --- a/basis/Initial.sml +++ b/basis/Initial.sml @@ -5,9 +5,9 @@ structure Initial = struct - infix - + * + infix - + * < = - type int0 = int + type int0 = int type word0 = word (* used by WORD signature *) exception Fail of string @@ -15,7 +15,6 @@ structure Initial = (* Time structure *) val timebase : int = prim("get_time_base", 0) -(* val timebase = ~1073741820 - 4 13/04/1999, Niels*) (* Date structure *) local fun localoffset_ () : real = prim("sml_localoffset", ()) @@ -34,7 +33,7 @@ structure Initial = fun getrutime_ () : tusage = prim("sml_getrutime", ()) in val initial_realtime = getrealtime_ () val initial_rutime = getrutime_ () - end + end (* Real structure *) local @@ -50,21 +49,42 @@ structure Initial = fun sqrt (r : real) : real = prim ("sqrtFloat", r) fun ln' (r : real) : real = prim ("lnFloat", r) in - val ln10 = ln' 10.0 + val ln10 = ln' 10.0 val NaN = sqrt ~1.0 end - (* Int structure. Integers are untagged (or tagged if GC is enabled), - * and there is a limit to the size of immediate integers that the Kit - * accepts. We should change the lexer such that it does not convert a - * string representation of an integer constant into an internal - * integer, as this makes the the kit dependent on the precision of + (* Int structure. Integers are untagged (or tagged if GC is enabled), + * and there is a limit to the size of immediate integers that the Kit + * accepts. We should change the lexer such that it does not convert a + * string representation of an integer constant into an internal + * integer, as this makes the the kit dependent on the precision of * the compiler (SML/NJ) that we use to compile the Kit. *) type int0 = int + + local fun pow2 n : int63 = if n < 1 then 1 else 2 * pow2(n-1) + in val maxInt63 : int63 = pow2 61 + (pow2 61 - 1) + val minInt63 : int63 = ~maxInt63 - 1 + end + + local fun pow2 n : int64 = if n < 1 then 1 else 2 * pow2(n-1) + in val maxInt64 : int64 = pow2 62 + (pow2 62 - 1) + val minInt64 : int64 = ~maxInt64 - 1 + end + + fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) + fun fromI63 (i:int63) : int = prim("__int63_to_int", i) + fun fromI64 (i:int64) : int = prim("__int64_to_int", i) + + val precisionInt0 : int = prim("precision", 0) + val (minInt0:int,maxInt0:int) = + if precisionInt0 = 63 then (fromI63 minInt63, fromI63 maxInt63) + else (fromI64 minInt64, fromI64 maxInt64) + +(* val maxInt0 : int = prim("max_fixed_int", 0) val minInt0 : int = prim("min_fixed_int", 0) - val precisionInt0 : int = prim("precision", 0) +*) (* TextIO *) val stdIn_stream : int = prim ("stdInStream", 0) @@ -75,7 +95,7 @@ structure Initial = (* FileSys *) structure FileSys = struct - val filesys_fail : exn = Fail "FileSys" + val filesys_fail : exn = Fail "FileSys" end (* Process *) @@ -86,7 +106,7 @@ structure Initial = val clearnerAtExit = (ref []) : (unit -> unit) list ref val addedclearner = ref false exception ClosedStream - + (* Posix *) structure TextIO = @@ -101,7 +121,7 @@ structure Initial = fun getNS s = prim("@sml_findsignal", s : string) : int fun getT i = prim("@sml_getTty", i : int) : word fun getTi i = prim("@sml_getTty", i : int) : int - structure Tty = + structure Tty = struct structure V = struct @@ -169,7 +189,7 @@ structure Initial = structure Speed = struct val b0 = getT 48 - val b50 = getT 49 + val b50 = getT 49 val b75 = getT 50 val b110 = getT 51 val b134 = getT 52 @@ -261,7 +281,7 @@ structure Initial = val ttou = getNS "SIGTTOU" end - structure Process = + structure Process = struct val untraced = 0wx1 val nohang = 0wx2 @@ -272,7 +292,7 @@ structure Initial = structure Posix_File_Sys = struct val (stdin,stdout,stderr) = prim ("sml_getStdNumbers", ()) : (int * int * int) - structure O = + structure O = struct val append = 0wx1 val excl = 0wx2 @@ -285,7 +305,7 @@ structure Initial = val rdonly = 0wx100 val wronly = 0wx200 val rdwr = 0wx400 - + val all = 0wx3F (* [append,excl,noctty,nonblock,sync,trunc] *) end @@ -309,7 +329,7 @@ structure Initial = val all = 0wx3FFF end end - + end diff --git a/basis/Int.sml b/basis/Int.sml index 484462274..920f2717b 100644 --- a/basis/Int.sml +++ b/basis/Int.sml @@ -1,12 +1,12 @@ -structure Int : INTEGER = +structure Int : INTEGER = struct (*Depends on StringCvt and Char*) (* Primitives *) - fun quot(x:int,y:int) : int = if y = 0 then raise Div - else prim ("__quot_int", (x, y)) - fun rem(x:int,y:int) : int = if y = 0 then raise Div - else prim ("__rem_int", (x, y)) + fun quot (x:int,y:int) : int = if y = 0 then raise Div + else prim ("__quot_int", (x, y)) + fun rem (x:int,y:int) : int = if y = 0 then raise Div + else prim ("__rem_int", (x, y)) fun not true = false | not false = true @@ -23,10 +23,10 @@ structure Int : INTEGER = val maxInt = SOME Initial.maxInt0 val minInt = SOME Initial.minInt0 - val ~ : int -> int = ~ - val op * : (int * int) -> int = op * - val op div : (int * int) -> int = op div - val op mod : (int * int) -> int = op mod + val ~ : int -> int = ~ + val op * : (int * int) -> int = op * + val op div : (int * int) -> int = op div + val op mod : (int * int) -> int = op mod val op + : (int * int) -> int = op + val op - : (int * int) -> int = op - fun compare (x, y: int) = if xy then GREATER else EQUAL @@ -44,22 +44,21 @@ structure Int : INTEGER = else (Char.ord c - 55) mod 32 fun prhex i = if i < 10 then Char.chr(i + 48) else Char.chr(i + 55) fun skipWSget getc source = getc (dropl Char.isSpace getc source) - fun conv radix i = if SOME i = minInt then (* Be careful not to Overflow *) - let fun tag s1 s2 = if precision = SOME 31 then s1 else s2 + let fun tag s1 s2 = if precision = SOME 63 then s1 else s2 in case radix - of 2 => tag "~1000000000000000000000000000000" "~10000000000000000000000000000000" - | 8 => tag "~10000000000" "~20000000000" - | 10 => tag "~1073741824" "~2147483648" - | 16 => tag "~40000000" "~80000000" - | _ => raise Fail "conv" + of 2 => tag "~100000000000000000000000000000000000000000000000000000000000000" "~1000000000000000000000000000000000000000000000000000000000000000" + | 8 => tag "~400000000000000000000" "~1000000000000000000000" + | 10 => tag "~4611686018427387904" "~9223372036854775808" + | 16 => tag "~4000000000000000" "~8000000000000000" + | _ => raise Fail "Int.conv" end else let fun h 0 res = res | h n res = h (n div radix) (prhex (n mod radix) :: res) fun tostr n = h (n div radix) [prhex (n mod radix)] - in implode (if i < 0 then #"~" :: tostr (~i) else tostr i) + in implode (if i < 0 then #"~" :: tostr (~i) else tostr i) end in fun scan radix getc source = @@ -69,17 +68,6 @@ structure Int : INTEGER = | OCT => (fn c => (#"0" <= c andalso c <= #"7"), 8) | DEC => (Char.isDigit, 10) | HEX => (Char.isHexDigit, 16) -(* - fun dig1 sgn NONE = NONE - | dig1 sgn (SOME (c, rest)) = - let fun digr res src = - case getc src - of NONE => SOME (sgn * res, src) - | SOME (c, rest) => if isDigit c then digr (factor * res + hexval c) rest - else SOME (sgn * res, src) - in if isDigit c then digr (hexval c) rest else NONE - end -*) fun dig1 sgn NONE = NONE | dig1 sgn (SOME (c, rest)) = let fun digr (res:int) next_val src = @@ -90,10 +78,10 @@ structure Int : INTEGER = val next_val = if sgn = 1 then fn (factor, res, hv) => factor * res + hv else fn (factor, res, hv) => factor * res - hv - in if isDigit c then digr (sgn * hexval c) next_val rest else NONE + in if isDigit c then digr (sgn * hexval c) next_val rest else NONE end fun getdigs sgn after0 inp = - case dig1 sgn inp + case dig1 sgn inp of NONE => SOME(0, after0) | res => res fun hexopt sgn NONE = NONE @@ -110,17 +98,17 @@ structure Int : INTEGER = | sign (SOME (#"-", rest)) = hexopt ~1 (getc rest) | sign (SOME (#"+", rest)) = hexopt 1 (getc rest) | sign inp = hexopt 1 inp - in sign (skipWSget getc source) + in sign (skipWSget getc source) end - + fun fmt BIN = conv 2 | fmt OCT = conv 8 | fmt DEC = conv 10 | fmt HEX = conv 16 - + (* It should hold that: toString = fmt DEC = conv 10 *) fun toString (i: int): string = fmt DEC i - + fun fromString s = scanString (scan DEC) s end (*local*) @@ -128,7 +116,7 @@ structure Int : INTEGER = val op >= : int * int -> bool = op >= val op < : int * int -> bool = op < val op <= : int * int -> bool = op <= - - end; (*structure Int*) -structure Position = Int \ No newline at end of file + end (*structure Int*) + +structure Position = Int diff --git a/basis/Int31.sml b/basis/Int31.sml index a43910f31..68278161b 100644 --- a/basis/Int31.sml +++ b/basis/Int31.sml @@ -1,12 +1,12 @@ -structure Int31 : INTEGER = +structure Int31 : INTEGER = struct (*Depends on StringCvt and Char*) (* Primitives *) - fun quot(x:int31,y:int31) : int31 = if y = 0 then raise Div - else prim ("__quot_int31", (x, y)) - fun rem(x:int31,y:int31) : int31 = if y = 0 then raise Div - else prim ("__rem_int31", (x,y)) + fun quot (x:int31,y:int31) : int31 = if y = 0 then raise Div + else prim ("__quot_int31", (x, y)) + fun rem (x:int31,y:int31) : int31 = if y = 0 then raise Div + else prim ("__rem_int31", (x,y)) fun not true = false | not false = true @@ -22,10 +22,10 @@ structure Int31 : INTEGER = val maxInt : int31 option = SOME 1073741823 val minInt : int31 option = SOME ~1073741824 - val ~ : int31 -> int31 = ~ - val op * : (int31 * int31) -> int31 = op * - val op div : (int31 * int31) -> int31 = op div - val op mod : (int31 * int31) -> int31 = op mod + val ~ : int31 -> int31 = ~ + val op * : (int31 * int31) -> int31 = op * + val op div : (int31 * int31) -> int31 = op div + val op mod : (int31 * int31) -> int31 = op mod val op + : (int31 * int31) -> int31 = op + val op - : (int31 * int31) -> int31 = op - fun compare (x, y: int31) = if xy then GREATER else EQUAL @@ -45,20 +45,20 @@ structure Int31 : INTEGER = else (ord31 c - 55) mod 32 fun prhex i = if i < 10 then chr31(i + 48) else chr31(i + 55) fun skipWSget getc source = getc (dropl Char.isSpace getc source) - - fun conv (radix:int31) (i:int31) = + + fun conv radix (i:int31) = if SOME i = minInt then (* Be careful not to Overflow *) (case radix of 2 => "~1000000000000000000000000000000" | 8 => "~10000000000" | 10 => "~1073741824" | 16 => "~40000000" - | _ => raise Fail "conv") + | _ => raise Fail "Int31.conv") else let fun h 0 res = res | h n res = h (n div radix) (prhex (n mod radix) :: res) fun tostr n = h (n div radix) [prhex (n mod radix)] - in implode (if i < 0 then #"~" :: tostr (~i) else tostr i) + in implode (if i < 0 then #"~" :: tostr (~i) else tostr i) end in fun scan radix getc source = @@ -69,17 +69,6 @@ structure Int31 : INTEGER = | OCT => (fn c => (#"0" <= c andalso c <= #"7"), 8) | DEC => (Char.isDigit, 10) | HEX => (Char.isHexDigit, 16) -(* - fun dig1 sgn NONE = NONE - | dig1 sgn (SOME (c, rest)) = - let fun digr (res:int31) src = - case getc src - of NONE => SOME (sgn * res, src) - | SOME (c, rest) => if isDigit c then digr (factor * res + hexval c) rest - else SOME (sgn * res, src) - in if isDigit c then digr (hexval c) rest else NONE - end -*) fun dig1 sgn NONE = NONE | dig1 sgn (SOME (c, rest)) = let fun digr (res:int31) next_val src = @@ -90,10 +79,10 @@ structure Int31 : INTEGER = val next_val = if sgn = 1 then fn (factor, res, hv) => factor * res + hv else fn (factor, res, hv) => factor * res - hv - in if isDigit c then digr (sgn * hexval c) next_val rest else NONE + in if isDigit c then digr (sgn * hexval c) next_val rest else NONE end fun getdigs sgn after0 inp = - case dig1 sgn inp + case dig1 sgn inp of NONE => SOME(0, after0) | res => res fun hexopt sgn NONE = NONE @@ -110,17 +99,17 @@ structure Int31 : INTEGER = | sign (SOME (#"-", rest)) = hexopt ~1 (getc rest) | sign (SOME (#"+", rest)) = hexopt 1 (getc rest) | sign inp = hexopt 1 inp - in sign (skipWSget getc source) + in sign (skipWSget getc source) end - + fun fmt BIN = conv 2 | fmt OCT = conv 8 | fmt DEC = conv 10 | fmt HEX = conv 16 - + (* It should hold that: toString = fmt DEC = conv 10 *) fun toString (i: int31): string = fmt DEC i - + fun fromString s = scanString (scan DEC) s end (*local*) @@ -129,5 +118,5 @@ structure Int31 : INTEGER = val op < : int31 * int31 -> bool = op < val op <= : int31 * int31 -> bool = op <= - type int = int31 - end; (*structure Int*) + type int = int31 + end (*structure Int*) diff --git a/basis/Int32.sml b/basis/Int32.sml index ba6f3de7f..d809eb2e3 100644 --- a/basis/Int32.sml +++ b/basis/Int32.sml @@ -1,12 +1,12 @@ -structure Int32 : INTEGER = +structure Int32 : INTEGER = struct (*Depends on StringCvt and Char*) (* Primitives *) - fun quot(x:int32,y:int32) : int32 = if y = 0 then raise Div - else prim ("__quot_int32", (x,y)) - fun rem(x:int32,y:int32) : int32 = if y = 0 then raise Div - else prim ("__rem_int32", (x,y)) + fun quot (x:int32,y:int32) : int32 = if y = 0 then raise Div + else prim ("__quot_int32", (x,y)) + fun rem (x:int32,y:int32) : int32 = if y = 0 then raise Div + else prim ("__rem_int32", (x,y)) fun not true = false | not false = true @@ -22,10 +22,10 @@ structure Int32 : INTEGER = val maxInt = SOME (2147483647 : int32) val minInt = SOME (~2147483648 : int32) - val ~ : int32 -> int32 = ~ - val op * : (int32 * int32) -> int32 = op * - val op div : (int32 * int32) -> int32 = op div - val op mod : (int32 * int32) -> int32 = op mod + val ~ : int32 -> int32 = ~ + val op * : (int32 * int32) -> int32 = op * + val op div : (int32 * int32) -> int32 = op div + val op mod : (int32 * int32) -> int32 = op mod val op + : (int32 * int32) -> int32 = op + val op - : (int32 * int32) -> int32 = op - fun compare (x, y: int32) = if xy then GREATER else EQUAL @@ -45,7 +45,7 @@ structure Int32 : INTEGER = else (ord32 c - 55) mod 32 fun prhex i = if i < 10 then chr32(i + 48) else chr32(i + 55) fun skipWSget getc source = getc (dropl Char.isSpace getc source) - + fun conv radix (i:int32) = if SOME i = minInt then (* Be careful not to Overflow *) (case radix @@ -77,7 +77,7 @@ structure Int32 : INTEGER = of NONE => SOME (sgn * res, src) | SOME (c, rest) => if isDigit c then digr (factor * res + hexval c) rest else SOME (sgn * res, src) - in if isDigit c then digr (hexval c) rest else NONE + in if isDigit c then digr (hexval c) rest else NONE end *) fun dig1 sgn NONE = NONE @@ -90,11 +90,11 @@ structure Int32 : INTEGER = val next_val = if sgn = 1 then fn (factor, res, hv) => factor * res + hv else fn (factor, res, hv) => factor * res - hv - in if isDigit c then digr (sgn * hexval c) next_val rest else NONE + in if isDigit c then digr (sgn * hexval c) next_val rest else NONE end fun getdigs sgn after0 inp = - case dig1 sgn inp + case dig1 sgn inp of NONE => SOME(0, after0) | res => res fun hexopt (sgn:int32) NONE = NONE @@ -111,17 +111,17 @@ structure Int32 : INTEGER = | sign (SOME (#"-", rest)) = hexopt ~1 (getc rest) | sign (SOME (#"+", rest)) = hexopt 1 (getc rest) | sign inp = hexopt 1 inp - in sign (skipWSget getc source) + in sign (skipWSget getc source) end - + fun fmt BIN = conv 2 | fmt OCT = conv 8 | fmt DEC = conv 10 | fmt HEX = conv 16 - + (* It should hold that: toString = fmt DEC = conv 10 *) fun toString (i: int32): string = fmt DEC i - + fun fromString s = scanString (scan DEC) s end (*local*) @@ -130,8 +130,6 @@ structure Int32 : INTEGER = val op < : int32 * int32 -> bool = op < val op <= : int32 * int32 -> bool = op <= - type int = int32 + type int = int32 end (*structure Int32*) - -structure FixedInt : INTEGER = Int32 diff --git a/basis/Int63.sml b/basis/Int63.sml new file mode 100644 index 000000000..607f3ea99 --- /dev/null +++ b/basis/Int63.sml @@ -0,0 +1,121 @@ + +structure Int63 : INTEGER = + struct (*Depends on StringCvt and Char*) + + (* Primitives *) + fun quot (x:int63,y:int63) : int63 = if y = 0 then raise Div + else prim ("__quot_int63", (x, y)) + fun rem (x:int63,y:int63) : int63 = if y = 0 then raise Div + else prim ("__rem_int63", (x,y)) + + fun not true = false + | not false = true + + (* Body *) + fun toLarge (x: int63) : intinf = IntInfRep.fromInt63 x + fun fromLarge (x: intinf) : int63 = IntInfRep.toInt63 x + fun toInt (x: int63) : int = prim("__int63_to_int", x) + fun fromInt (x: int) : int63 = prim("__int_to_int63", x) + + val precision = SOME 63 + + val maxInt : int63 option = SOME Initial.maxInt63 + val minInt : int63 option = SOME Initial.minInt63 + + val ~ : int63 -> int63 = ~ + val op * : (int63 * int63) -> int63 = op * + val op div : (int63 * int63) -> int63 = op div + val op mod : (int63 * int63) -> int63 = op mod + val op + : (int63 * int63) -> int63 = op + + val op - : (int63 * int63) -> int63 = op - + fun compare (x, y: int63) = if xy then GREATER else EQUAL + val abs : int63 -> int63 = abs + fun min (x, y) = if x < y then x else y : int63 + fun max (x, y) = if x < y then y else x : int63 + fun sign (i: int63) = if i > 0 then 1 else if i < 0 then ~1 else 0 + fun sameSign (i: int63, j) = sign i = sign j + + local + open StringCvt + fun ord63 (c : char) : int63 = fromInt (Char.ord c) + fun chr63 (i : int63) : char = Char.chr (toInt i) + (* Below, 48 = Char.ord #"0" and 55 = Char.ord #"A" - 10. *) + fun decval c = ord63 c - 48 + fun hexval c = if #"0" <= c andalso c <= #"9" then ord63 c - 48 + else (ord63 c - 55) mod 32 + fun prhex i = if i < 10 then chr63(i + 48) else chr63(i + 55) + fun skipWSget getc source = getc (dropl Char.isSpace getc source) + fun conv radix (i:int63) = + if SOME i = minInt then (* Be careful not to Overflow *) + (case radix of + 2 => "~100000000000000000000000000000000000000000000000000000000000000" + | 8 => "~400000000000000000000" + | 10 => "~4611686018427387904" + | 16 => "~4000000000000000" + | _ => raise Fail "Int63.conv") + else + let fun h 0 res = res + | h n res = h (n div radix) (prhex (n mod radix) :: res) + fun tostr n = h (n div radix) [prhex (n mod radix)] + in implode (if i < 0 then #"~" :: tostr (~i) else tostr i) + end + in + fun scan radix getc source = + let open StringCvt + val (isDigit, factor) = + case radix + of BIN => (fn c => (#"0" <= c andalso c <= #"1"), 2) + | OCT => (fn c => (#"0" <= c andalso c <= #"7"), 8) + | DEC => (Char.isDigit, 10) + | HEX => (Char.isHexDigit, 16) + fun dig1 sgn NONE = NONE + | dig1 sgn (SOME (c, rest)) = + let fun digr (res:int63) next_val src = + case getc src + of NONE => SOME (res, src) + | SOME (c, rest) => if isDigit c then digr (next_val(factor, res, hexval c)) next_val rest + else SOME (res, src) + val next_val = + if sgn = 1 then fn (factor, res, hv) => factor * res + hv + else fn (factor, res, hv) => factor * res - hv + in if isDigit c then digr (sgn * hexval c) next_val rest else NONE + end + fun getdigs sgn after0 inp = + case dig1 sgn inp + of NONE => SOME(0, after0) + | res => res + fun hexopt sgn NONE = NONE + | hexopt sgn (SOME(#"0", after0)) = + if not(radix = HEX) then getdigs sgn after0 (getc after0) + else (case getc after0 + of NONE => SOME(0, after0) + | SOME(#"x", rest) => getdigs sgn after0 (getc rest) + | SOME(#"X", rest) => getdigs sgn after0 (getc rest) + | inp => getdigs sgn after0 inp) + | hexopt sgn inp = dig1 sgn inp + fun sign NONE = NONE + | sign (SOME (#"~", rest)) = hexopt ~1 (getc rest) + | sign (SOME (#"-", rest)) = hexopt ~1 (getc rest) + | sign (SOME (#"+", rest)) = hexopt 1 (getc rest) + | sign inp = hexopt 1 inp + in sign (skipWSget getc source) + end + + fun fmt BIN = conv 2 + | fmt OCT = conv 8 + | fmt DEC = conv 10 + | fmt HEX = conv 16 + + (* It should hold that: toString = fmt DEC = conv 10 *) + fun toString (i: int63): string = fmt DEC i + + fun fromString s = scanString (scan DEC) s + end (*local*) + + val op > : int63 * int63 -> bool = op > + val op >= : int63 * int63 -> bool = op >= + val op < : int63 * int63 -> bool = op < + val op <= : int63 * int63 -> bool = op <= + + type int = int63 + end (*structure Int*) diff --git a/basis/Int64.sml b/basis/Int64.sml new file mode 100644 index 000000000..b64b3eba0 --- /dev/null +++ b/basis/Int64.sml @@ -0,0 +1,126 @@ + +structure Int64 : INTEGER = + struct (*Depends on StringCvt and Char*) + + (* Primitives *) + fun quot (x:int64,y:int64) : int64 = if y = 0 then raise Div + else prim ("__quot_int64", (x,y)) + fun rem (x:int64,y:int64) : int64 = if y = 0 then raise Div + else prim ("__rem_int64", (x,y)) + + fun not true = false + | not false = true + + (* Body *) + fun toLarge (x: int64) : intinf = IntInfRep.fromInt64 x + fun fromLarge (x: intinf) : int64 = IntInfRep.toInt64 x + fun toInt (x: int64) : int = prim("__int64_to_int", x) + fun fromInt (x: int) : int64 = prim("__int_to_int64", x) + + val precision = SOME 64 + + val maxInt = SOME Initial.maxInt64 + val minInt = SOME Initial.minInt64 + + val ~ : int64 -> int64 = ~ + val op * : (int64 * int64) -> int64 = op * + val op div : (int64 * int64) -> int64 = op div + val op mod : (int64 * int64) -> int64 = op mod + val op + : (int64 * int64) -> int64 = op + + val op - : (int64 * int64) -> int64 = op - + fun compare (x, y: int64) = if xy then GREATER else EQUAL + val abs : int64 -> int64 = abs + fun min (x, y) = if x < y then x else y : int64 + fun max (x, y) = if x < y then y else x : int64 + fun sign (i: int64) : int = if i > 0 then 1 else if i < 0 then ~1 else 0 + fun sameSign (i: int64, j) = sign i = sign j + + local + open StringCvt + fun ord64 (c:char) : int64 = fromInt(Char.ord c) + fun chr64 (i:int64) : char = Char.chr(toInt i) + + (* Below, 48 = Char.ord #"0" and 55 = Char.ord #"A" - 10. *) + fun hexval c = if #"0" <= c andalso c <= #"9" then ord64 c - 48 + else (ord64 c - 55) mod 32 + fun prhex i = if i < 10 then chr64(i + 48) else chr64(i + 55) + fun skipWSget getc source = getc (dropl Char.isSpace getc source) + + fun conv radix (i:int64) = + if SOME i = minInt then (* Be careful not to Overflow *) + (case radix + of 2 => "~1000000000000000000000000000000000000000000000000000000000000000" + | 8 => "~1000000000000000000000" + | 10 => "~9223372036854775808" + | 16 => "~8000000000000000" + | _ => raise Fail "conv") + else + let fun h 0 res = res + | h n res = h (n div radix) (prhex (n mod radix) :: res) + fun tostr n = h (n div radix) [prhex (n mod radix)] + in implode (if i < 0 then #"~" :: tostr (~i) else tostr i) + end + in + fun scan radix getc source = + let open StringCvt + val (isDigit, factor:int64) = + case radix + of BIN => (fn c => (#"0" <= c andalso c <= #"1"), 2) + | OCT => (fn c => (#"0" <= c andalso c <= #"7"), 8) + | DEC => (Char.isDigit, 10) + | HEX => (Char.isHexDigit, 16) + fun dig1 sgn NONE = NONE + | dig1 sgn (SOME (c, rest)) = + let fun digr (res:int64) next_val src = + case getc src + of NONE => SOME (res, src) + | SOME (c, rest) => if isDigit c then digr (next_val(factor, res, hexval c)) next_val rest + else SOME (res, src) + val next_val = + if sgn = 1 then fn (factor, res, hv) => factor * res + hv + else fn (factor, res, hv) => factor * res - hv + in if isDigit c then digr (sgn * hexval c) next_val rest else NONE + end + + fun getdigs sgn after0 inp = + case dig1 sgn inp + of NONE => SOME(0, after0) + | res => res + fun hexopt (sgn:int64) NONE = NONE + | hexopt sgn (SOME(#"0", after0)) = + if not(radix = HEX) then getdigs sgn after0 (getc after0) + else (case getc after0 + of NONE => SOME(0, after0) + | SOME(#"x", rest) => getdigs sgn after0 (getc rest) + | SOME(#"X", rest) => getdigs sgn after0 (getc rest) + | inp => getdigs sgn after0 inp) + | hexopt sgn inp = dig1 sgn inp + fun sign NONE = NONE + | sign (SOME (#"~", rest)) = hexopt ~1 (getc rest) + | sign (SOME (#"-", rest)) = hexopt ~1 (getc rest) + | sign (SOME (#"+", rest)) = hexopt 1 (getc rest) + | sign inp = hexopt 1 inp + in sign (skipWSget getc source) + end + + fun fmt BIN = conv 2 + | fmt OCT = conv 8 + | fmt DEC = conv 10 + | fmt HEX = conv 16 + + (* It should hold that: toString = fmt DEC = conv 10 *) + fun toString (i: int64): string = fmt DEC i + + fun fromString s = scanString (scan DEC) s + end (*local*) + + val op > : int64 * int64 -> bool = op > + val op >= : int64 * int64 -> bool = op >= + val op < : int64 * int64 -> bool = op < + val op <= : int64 * int64 -> bool = op <= + + type int = int64 + + end (*structure Int64*) + +structure FixedInt : INTEGER = Int64 diff --git a/basis/IntInfRep.sml b/basis/IntInfRep.sml index 0d80f9256..4073d2eae 100644 --- a/basis/IntInfRep.sml +++ b/basis/IntInfRep.sml @@ -1,56 +1,77 @@ (* Internal representation of IntInf.int including conversion functions to be used in the Int/IntN/Word/WordN implementations. This signature, as well as its matching structure - is declared before any of the Int/IntN/Word/WordN modules. mael - 2005-12-14 *) + is declared before any of the Int/IntN/Word/WordN modules. +*) -structure IntInfRep : INT_INF_REP = +structure IntInfRep (* : INT_INF_REP *) = struct (* Some primitive conversions *) fun cast_wi (a: word) : int = prim("id", a) fun cast_iw (a: int) : word = prim("id", a) - fun i32_i (x: int32) : int = prim("__int32_to_int", x) - fun i_i32 (x: int) : int32 = prim("__int_to_int32", x) + fun i64_i (x: int64) : int = prim("__int64_to_int", x) + fun i_i64 (x: int) : int64 = prim("__int_to_int64", x) fun i31_i32 (x: int31) : int32 = prim("__int31_to_int32", x) fun i32_i31 (x: int32) : int31 = prim("__int32_to_int31", x) - fun i31_i (x: int31) : int = prim("__int31_to_int", x) - fun i_i31 (x: int) : int31 = prim("__int_to_int31", x) - fun w32_w (w : word32) : word = cast_iw(prim("__word32_to_int", w)) - fun w32_w_X (w : word32) : int = prim("__word32_to_int_X", w) + fun i64_i63 (x: int64) : int63 = prim("__int64_to_int63", x) + fun i63_i64 (x: int63) : int64 = prim("__int63_to_int64", x) +(* fun i31_i (x: int31) : int = prim("__int31_to_int", x) *) +(* fun i_i31 (x: int) : int31 = prim("__int_to_int31", x) *) + + fun i32_i64 (x: int32) : int64 = prim("__int32_to_int64", x) + +(* fun w32_w (w : word32) : word = cast_iw(prim("__word32_to_int", w)) *) +(* fun w32_w_X (w : word32) : int = prim("__word32_to_int_X", w) *) fun w_w32 (w : word) : word32 = prim("__word_to_word32", w) - fun w_w32_X (w : word) : word32 = prim("__word_to_word32_X", w) +(* fun w_w32_X (w : word) : word32 = prim("__word_to_word32_X", w) *) fun w31_w32 (w : word31) : word32 = prim("__word31_to_word32", w) + fun w63_w64 (w : word63) : word64 = prim("__word63_to_word64", w) fun w31_w32_X (w : word31) : word32 = prim("__word31_to_word32_X", w) + fun w63_w64_X (w : word63) : word64 = prim("__word63_to_word64_X", w) fun w32_w31 (w : word32) : word31 = prim("__word32_to_word31", w) - + fun w_i_X (w : word) : int = prim("id", w) - fun w_i (w : word) : int = + fun w_i (w : word) : int = let val i = w_i_X w in if i < 0 then raise Overflow else i end fun i_w (i : int) : word = prim("id", i) - fun w31_i (w : word31) : int = w_i(prim("__word31_to_word", w)) +(* fun w31_i (w : word31) : int = w_i(prim("__word31_to_word", w)) *) fun w31_i_X (w : word31) : int = cast_wi(prim("__word31_to_word_X", w)) - fun i_w31 (i : int) : word31 = prim("__word_to_word31", cast_iw i) - fun i_w32 (i : int) : word32 = prim("__word_to_word32", cast_iw i) +(* fun i_w31 (i : int) : word31 = prim("__word_to_word31", cast_iw i) *) +(* fun i_w32 (i : int) : word32 = prim("__word_to_word32", cast_iw i) *) fun w32_i32 (w : word32) : int32 = prim("__word32_to_int32", w) fun w32_i32_X (w : word32) : int32 = prim("__word32_to_int32_X", w) fun i32_w32 (i : int32) : word32 = prim("__int32_to_word32", i) fun i31_w32 (i : int31) : word32 = i32_w32(i31_i32 i) - fun i31_w (i : int31) : word = w32_w(i32_w32(i31_i32 i)) +(* fun i31_w (i : int31) : word = w32_w(i32_w32(i31_i32 i)) *) fun i31_w31 (i : int31) : word31 = prim("id", i) + fun i63_w63 (i : int63) : word63 = prim("id", i) fun w31_i31 (i : word31) : int31 = prim("id", i) + fun w64_i64 (w : word64) : int64 = prim("__word64_to_int64", w) + fun w64_i64_X (w : word64) : int64 = prim("__word64_to_int64_X", w) + + fun i64_w64 (i : int64) : word64 = prim("__int64_to_word64", i) + fun w64_w32 (w : word64) : word32 = prim("__word64_to_word32", w) + + fun w64_w (w: word64) : word = prim("__word64_to_word", w) + fun w_w64 (w: word) : word64 = prim("__word_to_word64", w) - fun rshiftW32 (w : word32, k : word) : word32 = + fun rshiftW32 (w : word32, k : word) : word32 = if k >= 0w32 then 0w0 else prim("__shift_right_unsigned_word32", (w,k)) fun andbW32 (x : word32, y : word32) : word32 = prim("__andb_word32", (x, y)) fun andbW31 (x : word31, y : word31) : word31 = prim("__andb_word31", (x, y)) fun andbW (x : word, y : word) : word = prim("__andb_word", (x, y)) + fun andbW64 (x : word64, y : word64) : word64 = prim("__andb_word64", (x, y)) + fun rshiftW64 (w : word64, k : word) : word64 = + if k >= 0w64 then 0w0 + else prim("__shift_right_unsigned_word64", (w,k)) + local fun w_w8 (w : word) : word8 = prim("id", w) fun norm (w: word) : word = andbW (0w255, w) @@ -60,10 +81,13 @@ structure IntInfRep : INT_INF_REP = fun w8_w32 (w: word8) : word32 = w_w32(w8_w w) end - fun quoti31(x:int31,y:int31) : int31 = + fun quot (x:int,y:int) : int = if y = 0 then raise Div + else prim ("__quot_int", (x, y)) + + fun quoti31 (x:int31,y:int31) : int31 = if y = 0 then raise Div - else prim ("__quot_int31", (x, y)) - fun remi31(x:int31,y:int31) : int31 = + else prim ("__quot_int31", (x, y)) + fun remi31 (x:int31,y:int31) : int31 = if y = 0 then raise Div else prim ("__rem_int31", (x,y)) @@ -71,50 +95,51 @@ structure IntInfRep : INT_INF_REP = if k >= cast_iw 31 then 0w0 else prim("__shift_left_word31", (w,k)) - fun rshiftw31X (w : word31, k) : word31 = - if k >= cast_iw 31 then + fun rshiftw31X (w : word31, k) : word31 = + if k >= cast_iw 31 then if cast_wi(prim("__word31_to_word_X", w)) >= 0 then 0w0 (* msbit = 0 *) else prim("__word_to_word31", cast_iw ~1) (* msbit = 1 *) else prim("__shift_right_signed_word31", (w,k)) - + (* BigNat operations - IntInf is based on bignat = int31 list *) type bignat = int31 list structure BN = - struct + struct (* digits are 31 bits *) val nbase : int31 = ~0x40000000 (* = ~2^lgBase *) val nbaseI32 : int32 = ~0x40000000 - val nbaseW32Not : word32 = 0wx3fffffff - val lgBase : int31 = 30 (* No. of bits per digit; must be even *) + val nbaseW32Not : word32 = 0wx3fffffff + val nbaseW64Not : word64 = 0wx3fffffff + val lgBase : int = 30 (* No. of bits per digit; must be even *) val lgBaseW : word = 0w30 - fun maxDigit() : int31 = 1073741823 + fun maxDigit () : int31 = 1073741823 val maxDigitI32 : int32 = 1073741823 - fun lgHBase() : int31 = quoti31 (lgBase, 2) (* half digits *) - fun hbase() : word31 = lshiftw31(0w1, i31_w (lgHBase())) - fun hmask() : word31 = (hbase())-0w1 + fun lgHBase () : int = quot (lgBase, 2) (* half digits *) + fun hbase () : word31 = lshiftw31(0w1, i_w (lgHBase())) + fun hmask () : word31 = (hbase())-0w1 - fun zero() : bignat = [] + fun zero () : bignat = [] - fun hl i = + fun hl i = let val w = i31_w31 i - in (w31_i31(rshiftw31X(w, i31_w (lgHBase()))), (* MUST sign-extend *) + in (w31_i31(rshiftw31X(w, i_w (lgHBase()))), (* MUST sign-extend *) w31_i31(andbW31(w, hmask()))) end - fun sh i = w31_i31(lshiftw31 (i31_w31 i, i31_w (lgHBase()))) + fun sh i = w31_i31(lshiftw31 (i31_w31 i, i_w (lgHBase()))) fun addOne [] : bignat = [1] - | addOne (m::rm) = + | addOne (m::rm) = let val c = nbase+m+1 - in if c < 0 then (c-nbase)::rm + in if c < 0 then (c-nbase)::rm else c::(addOne rm) end fun add ([], digits) : bignat = digits | add (digits, []) = digits | add (dm::rm, dn::rn) = addd (nbase+dm+dn, rm, rn) - and addd (s, m, n) : bignat = - if s < 0 then (s-nbase) :: add (m, n) + and addd (s, m, n) : bignat = + if s < 0 then (s-nbase) :: add (m, n) else (s :: addc (m, n)) and addc (m, []) : bignat = addOne m | addc ([], n) = addOne n @@ -134,12 +159,12 @@ structure IntInfRep : INT_INF_REP = and subb ([], n) = raise Negative | subb (dm::rm, []) = subd (dm-1, rm, []) | subb (dm::rm, dn::rn) = subd (dm-dn-1, rm, rn) - and subd (d:int31, m:bignat, n:bignat) = - if d >= 0 then consd(d, subt (m, n)) + and subd (d:int31, m:bignat, n:bignat) = + if d >= 0 then consd(d, subt (m, n)) else consd(d-nbase, subb (m, n)) (* multiply 2 digits *) - fun mul2 (m:int31, n:int31) = + fun mul2 (m:int31, n:int31) = let val (mh, ml) = hl m val (nh, nl) = hl n val x = mh*nh @@ -147,32 +172,32 @@ structure IntInfRep : INT_INF_REP = val z = ml*nl val (zh, zl) = hl z val (uh,ul) = hl (nbase+x+z-y+zh) (* can't overflow *) - in (x+uh+ w31_i31 (hbase()), sh ul+zl) + in (x+uh+ w31_i31 (hbase()), sh ul+zl) end - + (* multiply bigint by digit *) fun muld (m, 0) = [] | muld (m, 1) = m (* speedup *) - | muld (m, i) = + | muld (m, i) = let fun muldc ([], 0) = [] | muldc ([], c) = [c] - | muldc (d::r, c) = + | muldc (d::r, c) = let val (h, l) = mul2 (d, i) val l1 = l+nbase+c in if l1 >= 0 then l1::muldc (r, h+1) - else (l1-nbase)::muldc (r, h) + else (l1-nbase)::muldc (r, h) end - in muldc (m, 0) + in muldc (m, 0) end fun mult (m, []) = [] | mult (m, [d]) = muld (m, d) (* speedup *) | mult (m, 0::r) = consd (0, mult (m, r)) (* speedup *) - | mult (m, n) = + | mult (m, n) = let fun muln [] = [] | muln (d::r) = add (muld (n, d), consd (0, muln r)) - in muln m - end + in muln m + end fun quotrem (i, j) = (quoti31 (i, j), remi31 (i, j)) fun scale i : int31 = if i = maxDigit() then 1 else (nbase div (~(i+1))) @@ -195,7 +220,7 @@ structure IntInfRep : INT_INF_REP = val i' = i * scale val m' = muld (m, scale) fun dmi [] = ([], 0) - | dmi (d::r) = let + | dmi (d::r) = let val (qt,rm) = dmi r val (q1,r1) = divmod2 ((rm,d), i') in (consd (q1,qt), r1) end @@ -206,10 +231,10 @@ structure IntInfRep : INT_INF_REP = (* From Knuth Vol II, 4.3.1, but without opt. in step D3 *) fun divmod (m, []) = raise Div | divmod ([], n) = ([], []) (* speedup *) - | divmod (d::r, 0::s) = let + | divmod (d::r, 0::s) = let val (qt,rm) = divmod (r,s) in (qt, consd (d, rm)) end (* speedup *) - | divmod (m, [d]) = let + | divmod (m, [d]) = let val (qt, rm) = divmodd (m, d) in (qt, if rm=0 then [] else [rm]) end | divmod (m, n) = let @@ -242,67 +267,120 @@ structure IntInfRep : INT_INF_REP = | cmp ([],_) = LESS | cmp ((i : int31)::ri,j::rj) = case cmp (ri,rj) of - EQUAL => if i = j then EQUAL - else if i < j then LESS + EQUAL => if i = j then EQUAL + else if i < j then LESS else GREATER | c => c end - (* the IntInf datatype *) - datatype intinf = datatype intinf + (* the IntInf datatype *) + datatype intinf = datatype intinf (* = _IntInf of {negative : bool, digits : int31 list} *) local - fun minNeg() : int32 = ~2147483648 - fun maxDigit() : int32 = 1073741823 (* int31 *) - fun nbase() = BN.nbaseI32 - fun lgBase() = BN.lgBaseW + fun minNeg () : int32 = ~2147483648 + fun minNeg64 () : int64 = (~(7*7*73*127*337*92737*649657)-1 : int64) (* = ~9223372036854775808 = ~2^63 *) + fun maxDigit () : int32 = 1073741823 (* int31 *) + fun maxDigit64 () : int64 = 1073741823 (* int31 *) + fun nbase () = BN.nbaseI32 + fun lgBase () = BN.lgBaseW val notNbase = BN.nbaseW32Not + val notNbase64 = BN.nbaseW64Not fun natInfFromI32 (0 : int32) : int31 list = [] - | natInfFromI32 i = + | natInfFromI32 i = let fun bn (0w0 : word32) = [] - | bn i = + | bn i = let fun dmbase n = (rshiftW32(n, lgBase()), andbW32 (n, notNbase)) val (q,r) = dmbase i in (i32_i31(w32_i32 r)) :: bn q end - in if i <= maxDigit() then [i32_i31 i] + in if i <= maxDigit() then [i32_i31 i] else bn (i32_w32 i) end + fun natInfFromI64 (0 : int64) : int31 list = [] + | natInfFromI64 i = + let + fun bn (0w0 : word64) = [] + | bn i = + let fun dmbase n = (rshiftW64(n, lgBase()), andbW64 (n, notNbase64)) + val (q,r) = dmbase i + val r1 = w64_w32 r + val r2 = w32_i32 r1 + val r3 = i32_i31 r2 + in r3 :: bn q + end + in if i <= maxDigit64() then + [i32_i31(w32_i32(w64_w32(i64_w64 i)))] + else bn (i64_w64 i) + end + fun natInfToI32 [] : int32 = 0 | natInfToI32 [d] = i31_i32 d | natInfToI32 [d,e] = ~(nbase()*(i31_i32 e)) + i31_i32 d | natInfToI32 (d::r) = ~(nbase()*natInfToI32 r) + i31_i32 d - fun bigNatMinNeg() = BN.addOne (natInfFromI32 (~(minNeg()+1))) + fun natInfToI64 [] : int64 = 0 + | natInfToI64 [d] = i32_i64(i31_i32 d) + | natInfToI64 [d,e] = let val x00 = i32_i64(i31_i32 e) + val x01 = i32_i64(nbase())*x00 + val x1 = ~ x01 + val x2 = i32_i64(i31_i32 d) + in x1 + x2 + end + | natInfToI64 (d::r) = ~(i32_i64(nbase())*natInfToI64 r) + i32_i64(i31_i32 d) + + fun bigNatMinNeg () = BN.addOne (natInfFromI32 (~(minNeg()+1))) + fun bigNatMinNeg64 () = BN.addOne (natInfFromI64 (~(minNeg64()+1))) fun negi digits = _IntInf{negative=true, digits=digits} - fun bigIntMinNeg() = negi (bigNatMinNeg()) + fun bigIntMinNeg () = negi (bigNatMinNeg()) + fun bigIntMinNeg64 () = negi (bigNatMinNeg64()) fun intInfToI32 (_IntInf{digits=[], ...}) = 0 | intInfToI32 (_IntInf{negative=false, digits}) = natInfToI32 digits | intInfToI32 (_IntInf{negative=true, digits}) = (~(natInfToI32 digits)) handle _ => - if digits = bigNatMinNeg() then minNeg() + if digits = bigNatMinNeg() then minNeg() else raise Overflow - fun zero() = _IntInf{negative=false, digits=BN.zero()} + fun intInfToI64 (_IntInf{digits=[], ...}) = 0 + | intInfToI64 (_IntInf{negative=false, digits}) = natInfToI64 digits + | intInfToI64 (_IntInf{negative=true, digits}) = + let val i = natInfToI64 digits + in ~ i + end handle _ => + if digits = bigNatMinNeg64() then minNeg64() + else raise Overflow + + + fun zero () = _IntInf{negative=false, digits=BN.zero()} fun i32ToIntInf (0:int32) = zero() | i32ToIntInf i = - if i < 0 then + if i < 0 then if (i = minNeg()) then bigIntMinNeg() else _IntInf{negative=true, digits= natInfFromI32 (~i)} else _IntInf{negative=false, digits= natInfFromI32 i} + fun i64ToIntInf (0:int64) = zero() + | i64ToIntInf i = + if i < 0 then + if (i = minNeg64()) then bigIntMinNeg64() + else _IntInf{negative=true, digits= natInfFromI64 (~i)} + else _IntInf{negative=false, digits= natInfFromI64 i} in val zero = zero fun toInt31 x = i32_i31(intInfToI32 x) fun toInt32 x = intInfToI32 x - fun toInt x = i32_i(intInfToI32 x) - - fun fromInt x = i32ToIntInf(i_i32 x) + fun toInt63 x = i64_i63(intInfToI64 x) + fun toInt x = i64_i(intInfToI64 x) + + fun toInt64 x = intInfToI64 x + + fun fromInt x = i64ToIntInf(i_i64 x) fun fromInt32 x = i32ToIntInf x + fun fromInt64 x = i64ToIntInf x fun fromInt31 x = i32ToIntInf (i31_i32 x) + fun fromInt63 x = i64ToIntInf (i63_i64 x) end fun subtNat (m, []) = {negative=false, digits=m} @@ -320,17 +398,36 @@ structure IntInfRep : INT_INF_REP = | IntInfPlus (_IntInf{negative, digits=d1}, _IntInf{digits=d2, ...}) = _IntInf{negative=negative, digits=BN.add(d1, d2)} + fun IntInfMul (_,_IntInf{digits=[], ...}) = zero() + | IntInfMul (_IntInf{digits=[], ...},_) = zero() + | IntInfMul (_IntInf{negative=false, digits=d1}, _IntInf{negative=true, digits=d2}) = + _IntInf{negative=true,digits=BN.mult(d1,d2)} + | IntInfMul (_IntInf{negative=true, digits=d1}, _IntInf{negative=false, digits=d2}) = + _IntInf{negative=true,digits=BN.mult(d1,d2)} + | IntInfMul (_IntInf{digits=d1,...}, _IntInf{digits=d2,...}) = + _IntInf{negative=false,digits=BN.mult(d1,d2)} + fun negSign false = true | negSign true = false - + fun neg (i as _IntInf{digits=[], ...}) = i | neg (_IntInf{negative=false, digits}) = _IntInf{negative=true, digits=digits} | neg (_IntInf{negative=true, digits}) = _IntInf{negative=false, digits=digits} - val maxInt32W : word32 = 0w2147483647 - fun fromWord32 (w : word32) : intinf = + val maxInt64W : word64 = 0w7*0w7*0w73*0w127*0w337*0w92737*0w649657 (* = 9223372036854775807 = 2^63-1 *) + fun fromWord64 (w : word64) : intinf = + if w <= maxInt64W then fromInt64 (w64_i64 w) + else + let val w2 = fromInt64(w64_i64 (w div 0w3)) + val rest = fromInt64(w64_i64 (w mod 0w3)) + val op + = IntInfPlus + in w2 + w2 + w2 + rest + end + + val maxInt32W : word32 = 0w2147483647 + fun fromWord32 (w : word32) : intinf = if w <= maxInt32W then fromInt32 (w32_i32 w) - else + else let val w2 = fromInt32(w32_i32 (w div 0w3)) val rest = fromInt32(w32_i32 (w mod 0w3)) val op + = IntInfPlus @@ -340,24 +437,39 @@ structure IntInfRep : INT_INF_REP = fun fromWord32X (w:word32) : intinf = fromInt32(w32_i32_X w) + fun fromWord64X (w:word64) : intinf = + fromInt64(w64_i64_X w) + fun fromWord31X (w:word31) : intinf = fromWord32X(w31_w32_X w) + fun fromWord63X (w:word63) : intinf = + fromWord64X(w63_w64_X w) + fun fromWordX (w:word) : intinf = - fromWord32X(w_w32_X w) + fromInt(w_i_X w) fun toWord32 (x : intinf) : word32 = - i32_w32(toInt32 x) + i32_w32(toInt32 x) handle _ => raise Fail "IntInfRep.toWord32" + fun toWord63 (x : intinf) : word63 = + i63_w63(toInt63 x) + handle _ => raise Fail "IntInfRep.toWord32" + + fun toWord64 (x : intinf) : word64 = + let val y = toInt64 x + in i64_w64 y + end handle X => raise Fail ("IntInfRef.toWord64: " ^ exnMessage X) + fun fromWord (w : word) : intinf = - fromWord32 (w_w32 w) + fromWord64 (w_w64 w) fun toWord (x : intinf) : word = - w32_w(toWord32 x) + w64_w(toWord64 x) fun fromWord8 (w8 : word8) : intinf = - fromWord32 (w8_w32 w8) + fromWord (w8_w w8) fun fromWord8X (w:word8) : intinf = if w < 0w128 then fromWord8 w @@ -365,25 +477,20 @@ structure IntInfRep : INT_INF_REP = fun toWord8 (x : intinf) : word8 = w32_w8(toWord32 x) - + fun fromWord31 (w31 : word31) : intinf = fromWord32 (w31_w32 w31) + fun fromWord63 (w63 : word63) : intinf = + fromWord64 (w63_w64 w63) + fun toWord31 (x : intinf) : word31 = w32_w31(toWord32 x) (* for overloading *) val ~ = neg - fun op * (_,_IntInf{digits=[], ...}) = zero() - | op * (_IntInf{digits=[], ...},_) = zero() - | op * (_IntInf{negative=false, digits=d1}, _IntInf{negative=true, digits=d2}) = - _IntInf{negative=true,digits=BN.mult(d1,d2)} - | op * (_IntInf{negative=true, digits=d1}, _IntInf{negative=false, digits=d2}) = - _IntInf{negative=true,digits=BN.mult(d1,d2)} - | op * (_IntInf{digits=d1,...}, _IntInf{digits=d2,...}) = - _IntInf{negative=false,digits=BN.mult(d1,d2)} - + val op * = IntInfMul val op + = IntInfPlus fun op - (i1, _IntInf{digits=[], ...}) = i1 @@ -418,7 +525,7 @@ structure IntInfRep : INT_INF_REP = fun abs (_IntInf{negative=true, digits}) = _IntInf{negative=false, digits=digits} | abs i = i - + fun compare (_IntInf{negative=true,...},_IntInf{negative=false,...}) = LESS | compare (_IntInf{negative=false,...},_IntInf{negative=true,...}) = GREATER | compare (_IntInf{negative=false,digits=d},_IntInf{negative=false,digits=d'}) = BN.cmp (d,d') @@ -428,4 +535,4 @@ structure IntInfRep : INT_INF_REP = fun op > arg = case compare arg of GREATER => true | _ => false fun op <= arg = case compare arg of GREATER => false | _ => true fun op >= arg = case compare arg of LESS => false | _ => true - end \ No newline at end of file + end diff --git a/basis/WORD.sig b/basis/WORD.sig index dfe038d60..424f83f01 100644 --- a/basis/WORD.sig +++ b/basis/WORD.sig @@ -1,15 +1,15 @@ -signature WORD = +signature WORD = sig eqtype word val wordSize : int - val toLarge : word -> word32 - val toLargeX : word -> word32 - val toLargeWord : word -> word32 - val toLargeWordX : word -> word32 - val fromLarge : word32 -> word - val fromLargeWord : word32 -> word + val toLarge : word -> word64 + val toLargeX : word -> word64 + val toLargeWord : word -> word64 + val toLargeWordX : word -> word64 + val fromLarge : word64 -> word + val fromLargeWord : word64 -> word val toLargeInt : word -> intinf val toLargeIntX : word -> intinf val fromLargeInt : intinf -> word @@ -30,17 +30,17 @@ signature WORD = val * : word * word -> word val div : word * word -> word val mod : word * word -> word - + val compare : word * word -> order val < : word * word -> bool val <= : word * word -> bool val > : word * word -> bool val >= : word * word -> bool - + val ~ : word -> word val min : word * word -> word val max : word * word -> word - + val fmt : StringCvt.radix -> word -> string val toString : word -> string val scan : StringCvt.radix @@ -165,7 +165,7 @@ i - j returns the difference of i and j modulo (2(wordSize)): - (2(wordSize) + i - j)(mod (2(wordSize))) + (2(wordSize) + i - j)(mod (2(wordSize))) when i and j are interpreted as unsigned binary numbers. It does not raise Overflow. @@ -186,7 +186,7 @@ i mod j returns the remainder of the division of i by j: - i - j * floor((i / j)) + i - j * floor((i / j)) when i and j are interpreted as unsigned binary numbers. It raises Div when j = 0. @@ -255,4 +255,4 @@ fromString s word. It is equivalent to StringCvt.scanString (scan StringCvt.HEX) -*) \ No newline at end of file +*) diff --git a/basis/Word.sml b/basis/Word.sml index a34175971..5bab8b6ea 100644 --- a/basis/Word.sml +++ b/basis/Word.sml @@ -6,7 +6,7 @@ structure Word : WORD = val wordSize = Initial.precisionInt0 fun toIntX (w : word) : int = prim("id", w) - fun toInt (w : word) : int = + fun toInt (w : word) : int = let val i = toIntX w in if i < 0 then raise Overflow else i @@ -14,23 +14,23 @@ structure Word : WORD = fun fromInt (i : int) : word = prim("id", i) - fun wordSize_w() = fromInt wordSize + fun wordSize_w () = fromInt wordSize - fun toLargeWord (w : word) : word32 = prim("__word_to_word32", w) + fun toLargeWord (w : word) : word64 = prim("__word_to_word64", w) val toLarge = toLargeWord - fun toLargeInt (w : word) : intinf = + fun toLargeInt (w : word) : intinf = IntInfRep.fromWord w - fun toLargeIntX (w : word) : intinf = + fun toLargeIntX (w : word) : intinf = IntInfRep.fromWordX w - fun fromLargeInt (i : intinf) : word = + fun fromLargeInt (i : intinf) : word = IntInfRep.toWord i - fun toLargeWordX (w : word) : word32 = prim("__word_to_word32_X", w) + fun toLargeWordX (w : word) : word64 = prim("__word_to_word64_X", w) val toLargeX = toLargeWordX - fun fromLargeWord (w : word32) : word = prim("__word32_to_word", w) + fun fromLargeWord (w : word64) : word = prim("__word64_to_word", w) val fromLarge = fromLargeWord fun orb (x : word, y : word) : word = prim("__orb_word", (x, y)) @@ -40,9 +40,9 @@ structure Word : WORD = local fun lshift_ (w : word, k : word) : word = prim("__shift_left_word", (w,k)) - fun rshiftsig_ (w : word, k : word) : word = + fun rshiftsig_ (w : word, k : word) : word = prim("__shift_right_signed_word", (w,k)) - fun rshiftuns_ (w : word, k : word) : word = + fun rshiftuns_ (w : word, k : word) : word = prim("__shift_right_unsigned_word", (w,k)) in fun << (w, k) = if k >= wordSize_w() then 0w0 @@ -51,8 +51,8 @@ structure Word : WORD = fun >> (w, k) = if k >= wordSize_w() then 0w0 else rshiftuns_ (w, k) - fun ~>> (w, k) = - if k >= wordSize_w() then + fun ~>> (w, k) = + if k >= wordSize_w() then if toIntX w >= 0 then 0w0 (* msbit = 0 *) else fromInt ~1 (* msbit = 1 *) else rshiftsig_(w, k) @@ -65,26 +65,26 @@ structure Word : WORD = val op div = fn (w1:word,w2) => w1 div w2 val op mod = fn (w1:word,w2) => w1 mod w2 - val ~ = fn w => fromInt(~(toInt w)) + val ~ = fn w => fromInt(~(toInt w)) - local + local open StringCvt fun skipWSget getc source = getc (dropl Char.isSpace getc source) (* Below, 48 = Char.ord #"0" and 55 = Char.ord #"A" - 10. *) fun decval c = fromInt (Char.ord c) - fromInt 48; - fun hexval c = - if #"0" <= c andalso c <= #"9" then + fun hexval c = + if #"0" <= c andalso c <= #"9" then fromInt (Char.ord c) - fromInt 48 - else + else (fromInt (Char.ord c) - fromInt 55) mod (fromInt 32); - fun prhex i = + fun prhex i = if toInt i < 10 then Char.chr(toInt (i + fromInt 48)) else Char.chr(toInt (i + fromInt 55)); - fun conv radix i = - let fun h n res = + fun conv radix i = + let fun h n res = if n = fromInt 0 then res else h (n div radix) (prhex (n mod radix) :: res) fun tostr n = h (n div radix) [prhex (n mod radix)] @@ -94,27 +94,27 @@ structure Word : WORD = fun scan radix getc source = let open StringCvt val source = skipWS getc source - val (isDigit, factor) = + val (isDigit, factor) = case radix of BIN => (fn c => (#"0" <= c andalso c <= #"1"), 2) | OCT => (fn c => (#"0" <= c andalso c <= #"7"), 8) | DEC => (Char.isDigit, 10) | HEX => (Char.isHexDigit, 16) fun dig1 NONE = NONE - | dig1 (SOME (c1, src1)) = - let fun digr res src = + | dig1 (SOME (c1, src1)) = + let fun digr res src = case getc src of NONE => SOME (res, src) - | SOME (c, rest) => - if isDigit c then - digr (fromInt factor * res + hexval c) + | SOME (c, rest) => + if isDigit c then + digr (fromInt factor * res + hexval c) rest else SOME (res, src) - in - if isDigit c1 then digr (hexval c1) src1 - else NONE + in + if isDigit c1 then digr (hexval c1) src1 + else NONE end - fun getdigs after0 src = + fun getdigs after0 src = case dig1 (getc src) of NONE => SOME(fromInt 0, after0) | res => res @@ -126,15 +126,15 @@ structure Word : WORD = | SOME(#"X", rest) => getdigs after0 rest | SOME _ => getdigs after0 src | NONE => SOME(fromInt 0, after0) - in + in case getc source of - SOME(#"0", after0) => - (case getc after0 of - SOME(#"w", src2) => hexprefix after0 src2 - | SOME _ => hexprefix after0 after0 + SOME(#"0", after0) => + (case getc after0 of + SOME(#"w", src2) => hexprefix after0 src2 + | SOME _ => hexprefix after0 after0 | NONE => SOME(fromInt 0, after0)) | SOME _ => dig1 (getc source) - | NONE => NONE + | NONE => NONE end; fun fmt BIN = conv (fromInt 2) diff --git a/basis/Word31.sml b/basis/Word31.sml index e04f5c234..c0efd7b8a 100644 --- a/basis/Word31.sml +++ b/basis/Word31.sml @@ -1,4 +1,4 @@ -(* Requires Word32 to be defined *) +(* Requires Word64 to be defined *) structure Word31 : WORD = struct @@ -11,18 +11,18 @@ structure Word31 : WORD = fun toIntX (w : word31) : int = cast_wi(prim("__word31_to_word_X", w)) fun fromInt (i : int) : word31 = prim("__word_to_word31", cast_iw i) - fun toLargeWord (w : word31) : word32 = prim("__word31_to_word32", w) + fun toLargeWord (w : word31) : word64 = prim("__word31_to_word64", w) val toLarge = toLargeWord - fun toLargeWordX (w : word31) : word32 = prim("__word31_to_word32_X", w) + fun toLargeWordX (w : word31) : word64 = prim("__word31_to_word64_X", w) val toLargeX = toLargeWordX - fun fromLargeWord (w : word32) : word31 = prim("__word32_to_word31", w) + fun fromLargeWord (w : word64) : word31 = prim("__word64_to_word31", w) val fromLarge = fromLargeWord - fun toLargeInt (w : word31) : intinf = + fun toLargeInt (w : word31) : intinf = IntInfRep.fromWord31 w - fun toLargeIntX (w : word31) : intinf = + fun toLargeIntX (w : word31) : intinf = IntInfRep.fromWord31X w - fun fromLargeInt (i : intinf) : word31 = + fun fromLargeInt (i : intinf) : word31 = IntInfRep.toWord31 i fun orb (x : word31, y : word31) : word31 = prim("__orb_word31", (x, y)) @@ -31,23 +31,23 @@ structure Word31 : WORD = fun notb (x : word31) : word31 = prim("__xorb_word31", (x, fromInt ~1)) local - fun lshift_ (w : word31, k : word) : word31 = + fun lshift_ (w : word31, k : word) : word31 = prim("__shift_left_word31", (w,k)) - fun rshiftsig_ (w : word31, k : word) : word31 = + fun rshiftsig_ (w : word31, k : word) : word31 = prim("__shift_right_signed_word31", (w,k)) - fun rshiftuns_ (w : word31, k : word) : word31 = + fun rshiftuns_ (w : word31, k : word) : word31 = prim("__shift_right_unsigned_word31", (w,k)) in - fun << (w, k) = + fun << (w, k) = if k >= cast_iw wordSize then 0w0 else lshift_(w, k); - fun >> (w, k) = + fun >> (w, k) = if k >= cast_iw wordSize then 0w0 else rshiftuns_ (w, k) - fun ~>> (w, k) = - if k >= cast_iw wordSize then + fun ~>> (w, k) = + if k >= cast_iw wordSize then if toIntX w >= 0 then 0w0 (* msbit = 0 *) else fromInt ~1 (* msbit = 1 *) else rshiftsig_(w, k) @@ -59,23 +59,23 @@ structure Word31 : WORD = val op div = fn (w1:word31,w2) => w1 div w2 val op mod = fn (w1:word31,w2) => w1 mod w2 - val ~ = fn w => fromInt(~(toInt w)) + val ~ = fn w => fromInt(~(toInt w)) - local + local open StringCvt fun skipWSget getc source = getc (dropl Char.isSpace getc source) fun ord31 c = fromInt(Char.ord c) fun chr31 w = Char.chr (toInt w) (* Below, 48 = Char.ord #"0" and 55 = Char.ord #"A" - 10. *) - fun hexval c = + fun hexval c = if #"0" <= c andalso c <= #"9" then ord31 c - 0w48 else (ord31 c - 0w55) mod 0w32; fun prhex i = if toInt i < 10 then chr31(i + 0w48) else chr31(i + 0w55); - fun conv radix i = - let fun h n res = + fun conv radix i = + let fun h n res = if n = fromInt 0 then res else h (n div radix) (prhex (n mod radix) :: res) fun tostr n = h (n div radix) [prhex (n mod radix)] @@ -85,18 +85,18 @@ structure Word31 : WORD = fun scan radix getc source = let open StringCvt val source = skipWS getc source - val (isDigit, factor : word31) = + val (isDigit, factor : word31) = case radix of BIN => (fn c => (#"0" <= c andalso c <= #"1"), 0w2) | OCT => (fn c => (#"0" <= c andalso c <= #"7"), 0w8) | DEC => (Char.isDigit, 0w10) | HEX => (Char.isHexDigit, 0w16) fun dig1 NONE = NONE - | dig1 (SOME (c1, src1)) = - let fun digr res src = + | dig1 (SOME (c1, src1)) = + let fun digr res src = case getc src of NONE => SOME (res, src) - | SOME (c, rest) => + | SOME (c, rest) => if isDigit c then let val res1 = factor * res val res2 = res1 + hexval c @@ -104,11 +104,11 @@ structure Word31 : WORD = else digr res2 rest end else SOME (res, src) - in - if isDigit c1 then digr (hexval c1) src1 - else NONE + in + if isDigit c1 then digr (hexval c1) src1 + else NONE end - fun getdigs after0 src = + fun getdigs after0 src = case dig1 (getc src) of NONE => SOME(fromInt 0, after0) | res => res @@ -120,15 +120,15 @@ structure Word31 : WORD = | SOME(#"X", rest) => getdigs after0 rest | SOME _ => getdigs after0 src | NONE => SOME(fromInt 0, after0) - in + in case getc source of - SOME(#"0", after0) => - (case getc after0 of - SOME(#"w", src2) => hexprefix after0 src2 - | SOME _ => hexprefix after0 after0 + SOME(#"0", after0) => + (case getc after0 of + SOME(#"w", src2) => hexprefix after0 src2 + | SOME _ => hexprefix after0 after0 | NONE => SOME(fromInt 0, after0)) | SOME _ => dig1 (getc source) - | NONE => NONE + | NONE => NONE end; fun fmt BIN = conv 0w2 @@ -151,4 +151,4 @@ structure Word31 : WORD = type word = word31 - end \ No newline at end of file + end diff --git a/basis/Word32.sml b/basis/Word32.sml index ba8092f7c..6ee68a7bf 100644 --- a/basis/Word32.sml +++ b/basis/Word32.sml @@ -10,20 +10,20 @@ structure Word32 : WORD = fun toIntX (w : word32) : int = prim("__word32_to_int_X", w) fun fromInt (i : int) : word32 = prim("__word_to_word32", cast_iw i) - fun toLargeWord (w : word32) : word32 = w + fun toLargeWord (w : word32) : word64 = prim("__word32_to_word64", w) val toLarge = toLargeWord - fun toLargeWordX (w : word32) : word32 = w + fun toLargeWordX (w : word32) : word64 = prim("__word32_to_word64_X", w) val toLargeX = toLargeWordX - fun fromLargeWord (w : word32) : word32 = w + fun fromLargeWord (w : word64) : word32 = prim("__word64_to_word32", w) val fromLarge = fromLargeWord fun toLargeInt (w : word32) : intinf = IntInfRep.fromWord32 w - fun toLargeIntX (w : word32) : intinf = + fun toLargeIntX (w : word32) : intinf = IntInfRep.fromWord32X w - fun fromLargeInt (i : intinf) : word32 = + fun fromLargeInt (i : intinf) : word32 = IntInfRep.toWord32 i fun orb (x : word32, y : word32) : word32 = prim("__orb_word32", (x, y)) @@ -32,11 +32,11 @@ structure Word32 : WORD = fun notb (x : word32) : word32 = prim("__xorb_word32", (x, 0wxFFFFFFFF)) local - fun lshift_ (w : word32, k : word) : word32 = + fun lshift_ (w : word32, k : word) : word32 = prim("__shift_left_word32", (w,k)) - fun rshiftsig_ (w : word32, k : word) : word32 = + fun rshiftsig_ (w : word32, k : word) : word32 = prim("__shift_right_signed_word32", (w,k)) - fun rshiftuns_ (w : word32, k : word) : word32 = + fun rshiftuns_ (w : word32, k : word) : word32 = prim("__shift_right_unsigned_word32", (w,k)) fun toInt32X (w : word32) : int32 = prim("__word32_to_int32_X", w) @@ -47,8 +47,8 @@ structure Word32 : WORD = fun >> (w, k) = if k >= wordSize_w then 0w0 else rshiftuns_(w, k) - fun ~>> (w, k) = - if k >= wordSize_w then + fun ~>> (w, k) = + if k >= wordSize_w then if toInt32X w >= 0 then 0w0 (* msbit = 0 *) else fromInt ~1 (* msbit = 1 *) else rshiftsig_(w, k) @@ -60,26 +60,26 @@ structure Word32 : WORD = val op div = fn (w1:word32,w2) => w1 div w2 val op mod = fn (w1:word32,w2) => w1 mod w2 - val ~ = fn w => fromInt(~(toInt w)) + val ~ = fn w => fromInt(~(toInt w)) - local + local open StringCvt fun skipWSget getc source = getc (dropl Char.isSpace getc source) (* Below, 48 = Char.ord #"0" and 55 = Char.ord #"A" - 10. *) fun decval c = fromInt (Char.ord c) - fromInt 48; - fun hexval c = - if #"0" <= c andalso c <= #"9" then + fun hexval c = + if #"0" <= c andalso c <= #"9" then fromInt (Char.ord c) - fromInt 48 - else + else (fromInt (Char.ord c) - fromInt 55) mod (fromInt 32); - fun prhex i = + fun prhex i = if toInt i < 10 then Char.chr(toInt (i + fromInt 48)) else Char.chr(toInt (i + fromInt 55)); - fun conv radix i = - let fun h n res = + fun conv radix i = + let fun h n res = if n = fromInt 0 then res else h (n div radix) (prhex (n mod radix) :: res) fun tostr n = h (n div radix) [prhex (n mod radix)] @@ -89,30 +89,30 @@ structure Word32 : WORD = fun scan radix getc source = let open StringCvt val source = skipWS getc source - val (isDigit, factor) = + val (isDigit, factor) = case radix of BIN => (fn c => (#"0" <= c andalso c <= #"1"), 0w2) | OCT => (fn c => (#"0" <= c andalso c <= #"7"), 0w8) | DEC => (Char.isDigit, 0w10) | HEX => (Char.isHexDigit, 0w16) fun dig1 NONE = NONE - | dig1 (SOME (c1, src1)) = - let fun digr (res:word32) src = + | dig1 (SOME (c1, src1)) = + let fun digr (res:word32) src = case getc src of NONE => SOME (res, src) - | SOME (c, rest) => - if isDigit c then + | SOME (c, rest) => + if isDigit c then let val res1 = factor * res - val res2 = res1 + hexval c + val res2 = res1 + hexval c in if res1 < res orelse res2 < res1 then raise Overflow else digr res2 rest end else SOME (res, src) - in - if isDigit c1 then digr (hexval c1) src1 - else NONE + in + if isDigit c1 then digr (hexval c1) src1 + else NONE end - fun getdigs after0 src = + fun getdigs after0 src = case dig1 (getc src) of NONE => SOME(fromInt 0, after0) | res => res @@ -124,15 +124,15 @@ structure Word32 : WORD = | SOME(#"X", rest) => getdigs after0 rest | SOME _ => getdigs after0 src | NONE => SOME(fromInt 0, after0) - in + in case getc source of - SOME(#"0", after0) => - (case getc after0 of - SOME(#"w", src2) => hexprefix after0 src2 - | SOME _ => hexprefix after0 after0 + SOME(#"0", after0) => + (case getc after0 of + SOME(#"w", src2) => hexprefix after0 src2 + | SOME _ => hexprefix after0 after0 | NONE => SOME(fromInt 0, after0)) | SOME _ => dig1 (getc source) - | NONE => NONE + | NONE => NONE end; fun fmt BIN = conv (fromInt 2) @@ -155,5 +155,3 @@ structure Word32 : WORD = type word = word32 end - -structure LargeWord : WORD = Word32 diff --git a/basis/Word63.sml b/basis/Word63.sml new file mode 100644 index 000000000..c6c6c87de --- /dev/null +++ b/basis/Word63.sml @@ -0,0 +1,154 @@ +(* Requires Word64 to be defined *) + +structure Word63 : WORD = + struct + val wordSize = 63 + + fun cast_wi (a: word) : int = prim("id", a) + fun cast_iw (a: int) : word = prim("id", a) + + fun toInt (w : word63) : int = Word.toInt(prim("__word63_to_word", w)) + fun toIntX (w : word63) : int = cast_wi(prim("__word63_to_word_X", w)) + fun fromInt (i : int) : word63 = prim("__word_to_word63", cast_iw i) + + fun toLargeWord (w : word63) : word64 = prim("__word63_to_word64", w) + val toLarge = toLargeWord + fun toLargeWordX (w : word63) : word64 = prim("__word63_to_word64_X", w) + val toLargeX = toLargeWordX + fun fromLargeWord (w : word64) : word63 = prim("__word64_to_word63", w) + val fromLarge = fromLargeWord + + fun toLargeInt (w : word63) : intinf = + IntInfRep.fromWord63 w + fun toLargeIntX (w : word63) : intinf = + IntInfRep.fromWord63X w + fun fromLargeInt (i : intinf) : word63 = + IntInfRep.toWord63 i + + fun orb (x : word63, y : word63) : word63 = prim("__orb_word63", (x, y)) + fun andb (x : word63, y : word63) : word63 = prim("__andb_word63", (x, y)) + fun xorb (x : word63, y : word63) : word63 = prim("__xorb_word63", (x, y)) + fun notb (x : word63) : word63 = prim("__xorb_word63", (x, fromInt ~1)) + + local + fun lshift_ (w : word63, k : word) : word63 = + prim("__shift_left_word63", (w,k)) + fun rshiftsig_ (w : word63, k : word) : word63 = + prim("__shift_right_signed_word63", (w,k)) + fun rshiftuns_ (w : word63, k : word) : word63 = + prim("__shift_right_unsigned_word63", (w,k)) + in + fun << (w, k) = + if k >= cast_iw wordSize then 0w0 + else lshift_(w, k); + + fun >> (w, k) = + if k >= cast_iw wordSize then 0w0 + else rshiftuns_ (w, k) + + fun ~>> (w, k) = + if k >= cast_iw wordSize then + if toIntX w >= 0 then 0w0 (* msbit = 0 *) + else fromInt ~1 (* msbit = 1 *) + else rshiftsig_(w, k) + end + + val op + = fn (w1:word63,w2) => w1 + w2 + val op - = fn (w1:word63,w2) => w1 - w2 + val op * = fn (w1:word63,w2) => w1 * w2 + val op div = fn (w1:word63,w2) => w1 div w2 + val op mod = fn (w1:word63,w2) => w1 mod w2 + + val ~ = fn w => fromInt(~(toInt w)) + + local + open StringCvt + fun skipWSget getc source = getc (dropl Char.isSpace getc source) + fun ord63 c = fromInt(Char.ord c) + fun chr63 w = Char.chr (toInt w) + (* Below, 48 = Char.ord #"0" and 55 = Char.ord #"A" - 10. *) + fun hexval c = + if #"0" <= c andalso c <= #"9" then ord63 c - 0w48 + else (ord63 c - 0w55) mod 0w32; + + fun prhex i = if toInt i < 10 then chr63(i + 0w48) + else chr63(i + 0w55); + + fun conv radix i = + let fun h n res = + if n = fromInt 0 then res + else h (n div radix) (prhex (n mod radix) :: res) + fun tostr n = h (n div radix) [prhex (n mod radix)] + in String.implode (tostr i) end + + in + fun scan radix getc source = + let open StringCvt + val source = skipWS getc source + val (isDigit, factor : word63) = + case radix of + BIN => (fn c => (#"0" <= c andalso c <= #"1"), 0w2) + | OCT => (fn c => (#"0" <= c andalso c <= #"7"), 0w8) + | DEC => (Char.isDigit, 0w10) + | HEX => (Char.isHexDigit, 0w16) + fun dig1 NONE = NONE + | dig1 (SOME (c1, src1)) = + let fun digr res src = + case getc src of + NONE => SOME (res, src) + | SOME (c, rest) => + if isDigit c then + let val res1 = factor * res + val res2 = res1 + hexval c + in if res1 < res orelse res2 < res1 then raise Overflow + else digr res2 rest + end + else SOME (res, src) + in + if isDigit c1 then digr (hexval c1) src1 + else NONE + end + fun getdigs after0 src = + case dig1 (getc src) of + NONE => SOME(fromInt 0, after0) + | res => res + fun hexprefix after0 src = + if radix <> HEX then getdigs after0 src + else + case getc src of + SOME(#"x", rest) => getdigs after0 rest + | SOME(#"X", rest) => getdigs after0 rest + | SOME _ => getdigs after0 src + | NONE => SOME(fromInt 0, after0) + in + case getc source of + SOME(#"0", after0) => + (case getc after0 of + SOME(#"w", src2) => hexprefix after0 src2 + | SOME _ => hexprefix after0 after0 + | NONE => SOME(fromInt 0, after0)) + | SOME _ => dig1 (getc source) + | NONE => NONE + end; + + fun fmt BIN = conv 0w2 + | fmt OCT = conv 0w8 + | fmt DEC = conv 0w10 + | fmt HEX = conv 0w16 + + fun toString w = conv 0w16 w + fun fromString s = scanString (scan HEX) s + end (* local for string functions *) + + fun min (w1 : word63, w2) = if w1 > w2 then w2 else w1 + fun max (w1 : word63, w2) = if w1 > w2 then w1 else w2 + fun compare (x, y: word63) = if xy then GREATER else EQUAL + + val op > = fn (w1:word63,w2) => w1 > w2 + val op >= = fn (w1:word63,w2) => w1 >= w2 + val op < = fn (w1:word63,w2) => w1 < w2 + val op <= = fn (w1:word63,w2) => w1 <= w2 + + type word = word63 + + end diff --git a/basis/Word64.sml b/basis/Word64.sml new file mode 100644 index 000000000..0b2dc0604 --- /dev/null +++ b/basis/Word64.sml @@ -0,0 +1,164 @@ +structure Word64 : WORD = + struct + val wordSize = 64 + + val wordSize_w : word = 0w64 + + fun cast_iw (a: int) : word = prim("id", a) + + fun toInt (w : word64) : int = prim("__word64_to_int", w) + fun toIntX (w : word64) : int = prim("__word64_to_int_X", w) + fun fromInt (i : int) : word64 = prim("__word_to_word64", cast_iw i) + + fun toLargeWord (w : word64) : word64 = w + val toLarge = toLargeWord + fun toLargeWordX (w : word64) : word64 = w + val toLargeX = toLargeWordX + fun fromLargeWord (w : word64) : word64 = w + val fromLarge = fromLargeWord + + fun toLargeInt (w : word64) : intinf = + IntInfRep.fromWord64 w + + fun toLargeIntX (w : word64) : intinf = + IntInfRep.fromWord64X w + + fun fromLargeInt (i : intinf) : word64 = + IntInfRep.toWord64 i + + fun orb (x : word64, y : word64) : word64 = prim("__orb_word64", (x, y)) + fun andb (x : word64, y : word64) : word64 = prim("__andb_word64", (x, y)) + fun xorb (x : word64, y : word64) : word64 = prim("__xorb_word64", (x, y)) + fun notb (x : word64) : word64 = prim("__xorb_word64", (x, 0wxFFFFFFFF)) (* MEMO *) + + local + fun lshift_ (w : word64, k : word) : word64 = + prim("__shift_left_word64", (w,k)) + fun rshiftsig_ (w : word64, k : word) : word64 = + prim("__shift_right_signed_word64", (w,k)) + fun rshiftuns_ (w : word64, k : word) : word64 = + prim("__shift_right_unsigned_word64", (w,k)) +(* + fun toInt64X (w : word64) : int64 = + prim("__word64_to_int64_X", w) +*) + in + fun << (w, k) = if k >= wordSize_w then 0w0 + else lshift_(w, k) + + fun >> (w, k) = if k >= wordSize_w then 0w0 + else rshiftuns_(w, k) + + fun ~>> (w, k) = + if k >= wordSize_w then + rshiftsig_(w, wordSize_w-0w1) +(* + if toInt64X w >= 0 then 0w0 (* msbit = 0 *) + else fromInt ~1 (* msbit = 1 *) +*) + else rshiftsig_(w, k) + end + + val op + = fn (w1:word64,w2) => w1 + w2 + val op - = fn (w1:word64,w2) => w1 - w2 + val op * = fn (w1:word64,w2) => w1 * w2 + val op div = fn (w1:word64,w2) => w1 div w2 + val op mod = fn (w1:word64,w2) => w1 mod w2 + + val ~ = fn w => fromInt(~(toInt w)) + + local + open StringCvt + fun skipWSget getc source = getc (dropl Char.isSpace getc source) + + (* Below, 48 = Char.ord #"0" and 55 = Char.ord #"A" - 10. *) + fun decval c = fromInt (Char.ord c) - fromInt 48; + fun hexval c = + if #"0" <= c andalso c <= #"9" then + fromInt (Char.ord c) - fromInt 48 + else + (fromInt (Char.ord c) - fromInt 55) mod (fromInt 32); + + fun prhex i = + if toInt i < 10 then Char.chr(toInt (i + fromInt 48)) + else Char.chr(toInt (i + fromInt 55)); + + fun conv radix i = + let fun h n res = + if n = fromInt 0 then res + else h (n div radix) (prhex (n mod radix) :: res) + fun tostr n = h (n div radix) [prhex (n mod radix)] + in String.implode (tostr i) end + + in + fun scan radix getc source = + let open StringCvt + val source = skipWS getc source + val (isDigit, factor) = + case radix of + BIN => (fn c => (#"0" <= c andalso c <= #"1"), 0w2) + | OCT => (fn c => (#"0" <= c andalso c <= #"7"), 0w8) + | DEC => (Char.isDigit, 0w10) + | HEX => (Char.isHexDigit, 0w16) + fun dig1 NONE = NONE + | dig1 (SOME (c1, src1)) = + let fun digr (res:word64) src = + case getc src of + NONE => SOME (res, src) + | SOME (c, rest) => + if isDigit c then + let val res1 = factor * res + val res2 = res1 + hexval c + in if res1 < res orelse res2 < res1 then raise Overflow + else digr res2 rest + end + else SOME (res, src) + in + if isDigit c1 then digr (hexval c1) src1 + else NONE + end + fun getdigs after0 src = + case dig1 (getc src) of + NONE => SOME(fromInt 0, after0) + | res => res + fun hexprefix after0 src = + if radix <> HEX then getdigs after0 src + else + case getc src of + SOME(#"x", rest) => getdigs after0 rest + | SOME(#"X", rest) => getdigs after0 rest + | SOME _ => getdigs after0 src + | NONE => SOME(fromInt 0, after0) + in + case getc source of + SOME(#"0", after0) => + (case getc after0 of + SOME(#"w", src2) => hexprefix after0 src2 + | SOME _ => hexprefix after0 after0 + | NONE => SOME(fromInt 0, after0)) + | SOME _ => dig1 (getc source) + | NONE => NONE + end; + + fun fmt BIN = conv (fromInt 2) + | fmt OCT = conv (fromInt 8) + | fmt DEC = conv (fromInt 10) + | fmt HEX = conv (fromInt 16) + + fun toString w = conv (fromInt 16) w + fun fromString s = scanString (scan HEX) s + end (* local for string functions *) + + fun min (w1 : word64, w2) = if w1 > w2 then w2 else w1; + fun max (w1 : word64, w2) = if w1 > w2 then w1 else w2; + fun compare (x, y: word64) = if xy then GREATER else EQUAL; + + val op > = fn (w1:word64,w2) => w1 > w2 + val op >= = fn (w1:word64,w2) => w1 >= w2 + val op < = fn (w1:word64,w2) => w1 < w2 + val op <= = fn (w1:word64,w2) => w1 <= w2 + + type word = word64 + end + +structure LargeWord : WORD = Word64 diff --git a/basis/Word8.sml b/basis/Word8.sml index 935d37f66..a41354da6 100644 --- a/basis/Word8.sml +++ b/basis/Word8.sml @@ -14,109 +14,109 @@ structure Word8 : WORD = fun w8_w (w : word8) : word = prim("id", w) fun toInt (x : word8) : int = prim ("id", x) - fun toLargeWord (w: word8) : word32 = prim ("__word_to_word32", w8_w w) + fun toLargeWord (w: word8) : word64 = prim ("__word_to_word64", w8_w w) val toLarge = toLargeWord - fun toLargeInt (w: word8) : intinf = + fun toLargeInt (w: word8) : intinf = IntInfRep.fromWord8 w - + fun norm (w: word) : word = andb_w (0w255, w) - fun fromLargeWord (w: word32) : word8 = w_w8(norm(prim ("__word32_to_word", w))) + fun fromLargeWord (w: word64) : word8 = w_w8(norm(prim ("__word64_to_word", w))) val fromLarge = fromLargeWord - + (* The rest does not make use of prim *) val wordSize = 8 fun fromInt (x : int) : word8 = w_w8(norm(i_w x)) - val ~ = fn w => fromInt(~(toInt w)) - + val ~ = fn w => fromInt(~(toInt w)) + (* Invariant for values w of type Word8.word: 0 <= toInt w < 256 *) - fun andb (x: word8, y: word8) : word8 = + fun andb (x: word8, y: word8) : word8 = w_w8(andb_w(w8_w x, w8_w y)) - - fun orb (x: word8, y: word8) : word8 = + + fun orb (x: word8, y: word8) : word8 = w_w8(orb_w(w8_w x, w8_w y)) - fun xorb (x: word8, y: word8) : word8 = + fun xorb (x: word8, y: word8) : word8 = w_w8(norm(xorb_w (w8_w x, w8_w y))) - - fun toIntX w = if w < 0w128 then toInt w (* msbit = 0 *) + + fun toIntX w = if w < 0w128 then toInt w (* msbit = 0 *) else toInt w - 256 (* msbit = 1 *) - - fun toLargeIntX (w : word8) : intinf = + + fun toLargeIntX (w : word8) : intinf = IntInfRep.fromWord8X w - fun fromLargeInt (i:intinf) : word8 = + fun fromLargeInt (i:intinf) : word8 = w_w8 (norm (Word.fromLargeInt i)) - - fun toLargeWordX (w: word8) = + + fun toLargeWordX (w: word8) = if w < 0w128 then toLargeWord w (* msbit = 0 *) - else Word32.orb(toLargeWord w, 0wxFFFFFF00) (* msbit = 1 *) + else Word64.orb(toLargeWord w, 0wxFFFFFF00) (* msbit = 1 *) val toLargeX = toLargeWordX - fun notb x = xorb(x, 0wxFF) - - fun << (w:word8, k:word) = + fun notb x = xorb(x, 0wxFF) + + fun << (w:word8, k:word) = if k >= 0w8 then 0w0 else w_w8(norm(lshift_w (w8_w w, k))) - fun >> (w:word8, k:word) = + fun >> (w:word8, k:word) = if k >= 0w8 then 0w0 else w_w8(rshiftuns_w (w8_w w, k)) (* normalization not necessary *) - - fun ~>> (w, k) = + + fun ~>> (w, k) = if w < 0w128 then (* msbit = 0: no sign to extend *) if k >= 0w8 then 0w0 else >> (w, k) else (* msbit = 1: extend, then shift *) if k >= 0w8 then 0wxFF else w_w8(norm(rshiftuns_w ((orb_w (w8_w w, 0wxFF00)), k))) - - local + + local open StringCvt fun skipWSget getc source = getc (skipWS getc source) - + (* Below, 48 = Char.ord #"0" and 55 = Char.ord #"A" - 10. *) fun decval c = Char.ord c - 48 fun hexval c = Word.fromInt (if #"0" <= c andalso c <= #"9" then decval c else (Char.ord c - 55) mod 32) - - fun prhex i = + + fun prhex i = if i < 10 then Char.chr(i + 48) else Char.chr(i + 55); - - fun conv radix w = - let - fun h n res = + + fun conv radix w = + let + fun h n res = if n = 0 then res else h (n div radix) (prhex (n mod radix) :: res) fun tostr n = h (n div radix) [prhex (n mod radix)] - in String.implode (tostr (toInt w)) + in String.implode (tostr (toInt w)) end - + in fun scan radix getc source = let open StringCvt val source = skipWS getc source - val (isDigit, factor) = + val (isDigit, factor) = case radix of BIN => (fn c => (#"0" <= c andalso c <= #"1"), 0w2) | OCT => (fn c => (#"0" <= c andalso c <= #"7"), 0w8) | DEC => (Char.isDigit, 0w10) | HEX => (Char.isHexDigit, 0w16) - fun return res src = - if res <= 0w255 then SOME (w_w8 res, src) + fun return res src = + if res <= 0w255 then SOME (w_w8 res, src) else raise Overflow fun dig1 NONE = NONE - | dig1 (SOME (c, rest)) = - let - fun digr res src = + | dig1 (SOME (c, rest)) = + let + fun digr res src = case getc src of NONE => return res src - | SOME (c, rest) => + | SOME (c, rest) => if isDigit c then let val res1 = factor * res val res2 = res1 + hexval c @@ -124,12 +124,12 @@ structure Word8 : WORD = if res1 < res orelse res2 < res1 then raise Overflow else digr res2 rest end - else + else return res src - in - if isDigit c then digr (hexval c) rest else NONE + in + if isDigit c then digr (hexval c) rest else NONE end - fun getdigs after0 src = + fun getdigs after0 src = case dig1 (getc src) of NONE => return 0w0 after0 | res => res @@ -141,17 +141,17 @@ structure Word8 : WORD = | SOME(#"X", rest) => getdigs after0 rest | SOME _ => getdigs after0 src | NONE => return 0w0 after0 - in + in case getc source of - SOME(#"0", after0) => - (case getc after0 of - SOME(#"w", src2) => hexprefix after0 src2 - | SOME _ => hexprefix after0 after0 + SOME(#"0", after0) => + (case getc after0 of + SOME(#"w", src2) => hexprefix after0 src2 + | SOME _ => hexprefix after0 after0 | NONE => return 0w0 after0) | SOME _ => dig1 (getc source) - | NONE => NONE + | NONE => NONE end; - + fun fmt BIN = conv 2 | fmt OCT = conv 8 | fmt DEC = conv 10 @@ -159,9 +159,9 @@ structure Word8 : WORD = fun toString w = conv 16 w fun fromString s = scanString (scan HEX) s end (* local for string functions *) - + (* Redefining +, -, *, div, and mod is a horrible idea ... *) - + val op + = fn (w1:word8,w2) => w1 + w2 val op - = fn (w1:word8,w2) => w1 - w2 val op * = fn (w1:word8,w2) => w1 * w2 @@ -175,9 +175,7 @@ structure Word8 : WORD = val op >= = fn (w1:word8,w2) => w1 >= w2 val op < = fn (w1:word8,w2) => w1 < w2 val op <= = fn (w1:word8,w2) => w1 <= w2 - + type word = word8 end (*structure Word8*) - - diff --git a/basis/basis.mlb b/basis/basis.mlb index 57997ee38..a433aeea3 100644 --- a/basis/basis.mlb +++ b/basis/basis.mlb @@ -67,7 +67,7 @@ local basis Word = let open General String IntInfRep - basis W = bas WORD.sig Word.sml Word32.sml Word31.sml Word8.sml end + basis W = bas WORD.sig Word.sml Word64.sml Word63.sml Word32.sml Word31.sml Word8.sml end basis PW = let open ArrayVector W in bas PACK_WORD.sml Pack32Little.sml Pack32Big.sml end end @@ -81,7 +81,7 @@ local basis Int = let open General String IntInfRep - in bas INTEGER.sml Int.sml Int32.sml Int31.sml end + in bas INTEGER.sml Int.sml Int32.sml Int31.sml Int63.sml Int64.sml end end basis Real = diff --git a/js/prims.js b/js/prims.js index 7ac7329d4..2e35ba371 100644 --- a/js/prims.js +++ b/js/prims.js @@ -1,15 +1,15 @@ CompilerInitial = {} -CompilerInitial.en$Bind$43 = new String("Bind"); -CompilerInitial.exn$Bind$43 = Array(CompilerInitial.en$Bind$43); -CompilerInitial.en$Match$42 = new String("Match"); -CompilerInitial.exn$Match$42 = Array(CompilerInitial.en$Match$42); -CompilerInitial.en$Div$41 = new String("Div"); -CompilerInitial.exn$Div$41 = Array(CompilerInitial.en$Div$41); +CompilerInitial.en$Bind$47 = new String("Bind"); +CompilerInitial.exn$Bind$47 = Array(CompilerInitial.en$Bind$47); +CompilerInitial.en$Match$46 = new String("Match"); +CompilerInitial.exn$Match$46 = Array(CompilerInitial.en$Match$46); +CompilerInitial.en$Div$45 = new String("Div"); +CompilerInitial.exn$Div$45 = Array(CompilerInitial.en$Div$45); CompilerInitial.en$Interrupt = new String("Interrupt"); CompilerInitial.exn$Interrupt = Array(CompilerInitial.en$Interrupt); -CompilerInitial.en$Overflow$44 = new String("Overflow"); -CompilerInitial.exn$Overflow$44 = Array(CompilerInitial.en$Overflow$44); +CompilerInitial.en$Overflow$48 = new String("Overflow"); +CompilerInitial.exn$Overflow$48 = Array(CompilerInitial.en$Overflow$48); Con = {} Con.some = 0; @@ -137,14 +137,14 @@ SmlPrims.wordTableInit = function(n,x) { SmlPrims.chk_ovf_i32 = function (i) { if ( i < -2147483648 || i > 2147483647 ) { - throw(CompilerInitial.exn$Overflow$44); + throw(CompilerInitial.exn$Overflow$48); } return i; } SmlPrims.chk_ovf_i31 = function (i) { if ( i < -1073741824 || i > 1073741823 ) { - throw(CompilerInitial.exn$Overflow$44); + throw(CompilerInitial.exn$Overflow$48); } return i; } @@ -167,7 +167,7 @@ SmlPrims.mod_i32 = function (x,y,exn) { SmlPrims.div_i32 = function (x,y,exn) { if ( y == 0 ) { throw(exn); } - if ( y == -1 && x == -2147483648 ) { throw(CompilerInitial.exn$Overflow$44); } + if ( y == -1 && x == -2147483648 ) { throw(CompilerInitial.exn$Overflow$48); } return Math.floor(x / y); } @@ -181,7 +181,7 @@ SmlPrims.mod_i31 = function (x,y,exn) { SmlPrims.div_i31 = function (x,y,exn) { if ( y == 0 ) { throw(exn); } - if ( y == -1 && x == -1073741824 ) { throw(CompilerInitial.exn$Overflow$44); } + if ( y == -1 && x == -1073741824 ) { throw(CompilerInitial.exn$Overflow$48); } return Math.floor(x / y); } diff --git a/js/test/int.sml b/js/test/int.sml index 96f0c3d1a..d4299be48 100644 --- a/js/test/int.sml +++ b/js/test/int.sml @@ -3,10 +3,10 @@ infix 1 seq fun e1 seq e2 = e2; fun check b = if b then "OK" else "WRONG"; -fun check' f = (if f () then "OK" else "WRONG") handle _ => "EXN"; +fun check' f = (if f () then "OK" else "WRONG") handle X => ("EXN:" ^ exnMessage X); -fun range (from, to) p = - let open Int +fun range (from, to) p = + let open Int in (from > to) orelse (p from) andalso (range (from+1, to) p) end; @@ -17,7 +17,7 @@ fun tst0 s s' = print (s ^ " \t" ^ s' ^ "
"); fun tst s b = tst0 s (check b); fun tst' s f = tst0 s (check' f); -fun tstrange s bounds = (tst s) o range bounds +fun tstrange s bounds = (tst s) o range bounds (* test/int.sml -- here we test only the `exotic' operations @@ -29,12 +29,12 @@ use "auxil.sml"; val _ = print "

File int.sml: Testing structure Int...

" -local +local open Int infix 7 quot rem fun divmod s (i, d, q, r) = tst s (i div d = q andalso i mod d = r); fun quotrem s (i, d, q, r) = tst s (i quot d = q andalso i rem d = r); -in +in val test1a = divmod "test1a" (10, 3, 3, 1); val test1b = divmod "test1b" (~10, 3, ~4, 2); @@ -50,25 +50,25 @@ val test3 = tst "test3" (max(~5, 2) = 2 andalso max(5, 2) = 5); val test4 = tst "test4" (min(~5, 3) = ~5 andalso min(5, 2) = 2); val test5 = tst "test5" (sign ~57 = ~1 andalso sign 99 = 1 andalso sign 0 = 0); -val test6 = tst "test6" (sameSign(~255, ~256) andalso sameSign(255, 256) +val test6 = tst "test6" (sameSign(~255, ~256) andalso sameSign(255, 256) andalso sameSign(0, 0)); -val test12 = +val test12 = tst0 "test12" (case (minInt, maxInt) of - (SOME mi, SOME ma) => check(sign mi = ~1 andalso sign ma = 1 + (SOME mi, SOME ma) => check(sign mi = ~1 andalso sign ma = 1 andalso sameSign(mi, ~1) andalso sameSign(ma, 1)) | (NONE, NONE) => "OK" | _ => "WRONG") -fun chk f (s, r) = - tst' "chk" (fn _ => +fun chk f (s, r) = + tst' "chk" (fn _ => case f s of SOME res => res = r | NONE => false) fun chkScan fmt = chk (StringCvt.scanString (scan fmt)) -val test13a = +val test13a = List.map (chk fromString) [("10789", 10789), ("+10789", 10789), @@ -85,12 +85,12 @@ val test13a = ("0wx123", 0), ("0wX123", 0)]; -val test13b = +val test13b = List.map (fn s => tst0 "test13b" (case fromString s of NONE => "OK" | _ => "WRONG")) - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", - "+ 1", "~ 1", "- 1", "ff"]; + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+ 1", "~ 1", "- 1", "ff"]; -val test14a = +val test14a = List.map (chkScan StringCvt.DEC) [("10789", 10789), ("+10789", 10789), @@ -107,13 +107,13 @@ val test14a = ("0wx123", 0), ("0wX123", 0)]; -val test14b = - List.map (fn s => tst0 "test14b" (case StringCvt.scanString (scan StringCvt.DEC) s +val test14b = + List.map (fn s => tst0 "test14b" (case StringCvt.scanString (scan StringCvt.DEC) s of NONE => "OK" | _ => "WRONG")) - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", - "+ 1", "~ 1", "- 1", "ff"]; + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+ 1", "~ 1", "- 1", "ff"]; -val test15a = +val test15a = List.map (chkScan StringCvt.BIN) [("10010", 18), ("+10010", 18), @@ -130,13 +130,13 @@ val test15a = ("0wx101", 0), ("0wX101", 0)]; -val test15b = - List.map (fn s => tst0 "test15b" (case StringCvt.scanString (scan StringCvt.BIN) s +val test15b = + List.map (fn s => tst0 "test15b" (case StringCvt.scanString (scan StringCvt.BIN) s of NONE => "OK" | _ => "WRONG")) - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", "+ 1", "~ 1", "- 1", "2", "8", "ff"]; -val test16a = +val test16a = List.map (chkScan StringCvt.OCT) [("2071", 1081), ("+2071", 1081), @@ -153,13 +153,13 @@ val test16a = ("0wx123", 0), ("0wX123", 0)]; -val test16b = - List.map (fn s => tst0 "test16b" (case StringCvt.scanString (scan StringCvt.OCT) s +val test16b = + List.map (fn s => tst0 "test16b" (case StringCvt.scanString (scan StringCvt.OCT) s of NONE => "OK" | _ => "WRONG")) - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", "+ 1", "~ 1", "- 1", "8", "ff"]; -val test17a = +val test17a = List.map (chkScan StringCvt.HEX) [("20Af", 8367), ("+20Af", 8367), @@ -187,35 +187,35 @@ val test17a = ("0wx123", 0), ("0wX123", 0)]; -val test17b = - List.map (fn s => tst0 "test17b" (case StringCvt.scanString (scan StringCvt.HEX) s +val test17b = + List.map (fn s => tst0 "test17b" (case StringCvt.scanString (scan StringCvt.HEX) s of NONE => "OK" | _ => "WRONG")) - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", "+ 1", "~ 1", "- 1"]; -local - fun fromToString i = +local + fun fromToString i = fromString (toString i) = SOME i; - fun scanFmt radix i = + fun scanFmt radix i = StringCvt.scanString (scan radix) (fmt radix i) = SOME i; in -val test18 = +val test18 = (* tst' "test18" (fn _ => range (~1200, 1200) fromToString); *) tst' "test18" (fn _ => range (~100, 100) fromToString); -val test19 = +val test19 = tst' "test19" (fn _ => range (~100, 100) (scanFmt StringCvt.BIN)); -val test20 = +val test20 = tst' "test20" (fn _ => range (~100, 100) (scanFmt StringCvt.OCT)); -val test21 = +val test21 = tst' "test21" (fn _ => range (~100, 100) (scanFmt StringCvt.DEC)); -val test22 = +val test22 = tst' "test22" (fn _ => range (~100, 100) (scanFmt StringCvt.HEX)); val test23a = tst' "test23a" (fn _ => scanFmt StringCvt.HEX (valOf Int.maxInt)); @@ -233,7 +233,7 @@ val test25b = tst' "test25b" (fn _ => scanFmt StringCvt.DEC (valOf Int.minInt + val test25c = tst' "test25c" (fn _ => scanFmt StringCvt.OCT (valOf Int.minInt + 10)); val test25d = tst' "test25d" (fn _ => scanFmt StringCvt.BIN (valOf Int.minInt + 10)); -fun chk' t f s = +fun chk' t f s = tst' t (fn _ => ((f s; false) handle Overflow => true)) fun chkScanOvf t fmt = chk' t (StringCvt.scanString (scan fmt)) fun tag s1 s2 = if Int.precision = SOME 31 then s1 else s2 diff --git a/src/Common/EfficientElab/Environments.sml b/src/Common/EfficientElab/Environments.sml index 9053a71cb..d97682a14 100644 --- a/src/Common/EfficientElab/Environments.sml +++ b/src/Common/EfficientElab/Environments.sml @@ -1187,10 +1187,14 @@ old *) val TE_int31 = te (TyCon.tycon_INT31, TyName.tyName_INT31) val TE_int32 = te (TyCon.tycon_INT32, TyName.tyName_INT32) + val TE_int63 = te (TyCon.tycon_INT63, TyName.tyName_INT63) + val TE_int64 = te (TyCon.tycon_INT64, TyName.tyName_INT64) val TE_char = te (TyCon.tycon_CHAR, TyName.tyName_CHAR) val TE_word8 = te (TyCon.tycon_WORD8, TyName.tyName_WORD8) val TE_word31 = te (TyCon.tycon_WORD31, TyName.tyName_WORD31) val TE_word32 = te (TyCon.tycon_WORD32, TyName.tyName_WORD32) + val TE_word63 = te (TyCon.tycon_WORD63, TyName.tyName_WORD63) + val TE_word64 = te (TyCon.tycon_WORD64, TyName.tyName_WORD64) val TE_real = te (TyCon.tycon_REAL, TyName.tyName_REAL) val TE_string = te (TyCon.tycon_STRING, TyName.tyName_STRING) val TE_chararray = te (TyCon.tycon_CHARARRAY, TyName.tyName_CHARARRAY) @@ -1401,10 +1405,14 @@ old *) val tyvar_num = TyVar.fresh_overloaded [TyName.tyName_INT31, TyName.tyName_INT32, + TyName.tyName_INT63, + TyName.tyName_INT64, TyName.tyName_INTINF, TyName.tyName_WORD8, TyName.tyName_WORD31, TyName.tyName_WORD32, + TyName.tyName_WORD63, + TyName.tyName_WORD64, TyName.tyName_REAL] val tau_num = Type.from_TyVar tyvar_num @@ -1413,15 +1421,18 @@ old *) val tyvar_realint = TyVar.fresh_overloaded [TyName.tyName_REAL, TyName.tyName_INT31, - TyName.tyName_INT32, TyName.tyName_INTINF] + TyName.tyName_INT32, TyName.tyName_INT63, + TyName.tyName_INT64, TyName.tyName_INTINF] val tau_realint = Type.from_TyVar tyvar_realint val tau_realint_to_realint = Type.mk_Arrow (tau_realint, tau_realint) val tyvar_numtxt = TyVar.fresh_overloaded - [TyName.tyName_INT31, TyName.tyName_INT32, TyName.tyName_INTINF, + [TyName.tyName_INT31, TyName.tyName_INT32, TyName.tyName_INT63, + TyName.tyName_INT64, TyName.tyName_INTINF, TyName.tyName_WORD8, TyName.tyName_WORD31, TyName.tyName_WORD32, + TyName.tyName_WORD63, TyName.tyName_WORD64, TyName.tyName_REAL, TyName.tyName_CHAR, TyName.tyName_STRING] @@ -1431,8 +1442,10 @@ old *) Type.Bool) val tyvar_wordint = TyVar.fresh_overloaded - [TyName.tyName_INT31, TyName.tyName_INT32, TyName.tyName_INTINF, - TyName.tyName_WORD8, TyName.tyName_WORD31, TyName.tyName_WORD32] + [TyName.tyName_INT31, TyName.tyName_INT32, TyName.tyName_INT63, TyName.tyName_INT64, + TyName.tyName_INTINF, + TyName.tyName_WORD8, TyName.tyName_WORD31, TyName.tyName_WORD32, + TyName.tyName_WORD63, TyName.tyName_WORD64] val tau_wordint = Type.from_TyVar tyvar_wordint val tau_wordint_X_wordint_to_wordint = @@ -1498,22 +1511,31 @@ old *) TyStr.from_theta_and_VE (theta_unit, VE_unit)) end - val TE_initial0 = joinTE [TE_unit, TE_char, TE_real, - TE_int31, TE_int32, TE_intinf, - TE_word8, TE_word31, TE_word32, - TE_string, TE_exn, TE_ref, TE_bool, TE_list, - TE_array, TE_vector, TE_chararray, TE_foreignptr] - val tag_values = Flags.is_on0 "tag_values" + val values_64bit = Flags.is_on0 "values_64bit" + + val TE_initial0 = + joinTE [TE_unit, TE_char, TE_real, + TE_int31, TE_int32, TE_intinf, + TE_word8, TE_word31, TE_word32, + TE_string, TE_exn, TE_ref, TE_bool, TE_list, + TE_array, TE_vector, TE_chararray, TE_foreignptr] fun TE_initial () = let val (defaultTyNameInt, defaultTyNameWord) = - if tag_values() then (TyName.tyName_INT31, TyName.tyName_WORD31) - else (TyName.tyName_INT32, TyName.tyName_WORD32) + case (tag_values(), values_64bit()) of + (true, true) => (TyName.tyName_INT63, TyName.tyName_WORD63) + | (false, true) => (TyName.tyName_INT64, TyName.tyName_WORD64) + | (true, false) => (TyName.tyName_INT31, TyName.tyName_WORD31) + | (false, false) => (TyName.tyName_INT32, TyName.tyName_WORD32) + val TE_int = te (TyCon.tycon_INT, defaultTyNameInt) val TE_word = te (TyCon.tycon_WORD, defaultTyNameWord) val TEs = [TE_initial0, TE_word, TE_int] + @ (if values_64bit() then + [TE_int63, TE_int64, TE_word63, TE_word64] + else []) val TEs = if quotation() then TE_frag :: TEs else TEs in joinTE TEs diff --git a/src/Common/EfficientElab/StatObject.sml b/src/Common/EfficientElab/StatObject.sml index 61ddf3d3d..a02495a51 100644 --- a/src/Common/EfficientElab/StatObject.sml +++ b/src/Common/EfficientElab/StatObject.sml @@ -31,16 +31,16 @@ structure StatObject: STATOBJECT = type strid = Ident.strid type StringTree = PP.StringTree - (* - * New, more efficient representation of types and substitutions on types - * + (* + * New, more efficient representation of types and substitutions on types + * * -- Birkedal, nov. 1993 - * - * Major cleanup + * + * Major cleanup * * -- Elsman, nov. 1998 *) - + (* Bound type variables in type schemes have level GENERIC. For a * tree with root n, n has level GENERIC if there is a node in the * tree that represents a generic tyvar. Levels in type functions @@ -59,7 +59,7 @@ structure StatObject: STATOBJECT = fun pop () = level_ref := !level_ref - 1 fun current () = !level_ref end (*local*) - fun pr i = if i = GENERIC then "generic" + fun pr i = if i = GENERIC then "generic" else if i = NONGENERIC then "nongeneric" else Int.toString i end (*Level*) @@ -68,39 +68,39 @@ structure StatObject: STATOBJECT = type ExplicitTyVar = ExplicitTyVar.SyntaxTyVar - datatype TypeDesc = + datatype TypeDesc = TYVAR of TyVar | ARROW of Type * Type | RECTYPE of RecType | CONSTYPE of Type list * TyName.TyName - and TyLink = + and TyLink = NO_TY_LINK of TyVarDesc (* type variable *) | TY_LINK of Type (* type variable linked to type *) - and RecType = + and RecType = NILrec | VARrec of {RowVar : RowVar, level : level ref} (* a rowvar has a level *) | ROWrec of Lab.lab * Type * RecType (* labels are ordered during unification *) - and RecLink = + and RecLink = NO_REC_LINK of int (* row variable; the stamp is here to ease printing *) | REC_LINK of RecType (* row variable linked to row *) - withtype Type = {TypeDesc : TypeDesc, level : level ref} + withtype Type = {TypeDesc : TypeDesc, level : level ref} and TyVar = TyLink ref and RowVar = RecLink ref and TyVarDesc = {base: string, (* compilation unit base; (base,id) should be unique *) id : int, (* Two type variables are equal if their ids are equal and their bases are equal*) equality : bool, (* Does the tyvar admit equality *) - rank: rank ref, (* The rank field contains an updatable rank for the + rank: rank ref, (* The rank field contains an updatable rank for the * type variable. See TYNAME for further comments. *) - overloaded : TyName.Set.Set option, - (* The overloaded field contains a list of type names that - * the overloaded tyvar may be instantiated to, for instance - * [Type.Real, Type.Int, Type.Word] if the overloaded - * tyvar stands for a socalled num (e.g., in the type + overloaded : TyName.Set.Set option, + (* The overloaded field contains a list of type names that + * the overloaded tyvar may be instantiated to, for instance + * [Type.Real, Type.Int, Type.Word] if the overloaded + * tyvar stands for a socalled num (e.g., in the type * scheme for `+'). *) explicit : ExplicitTyVar option, (* Does the tyvar stem from an explicit tyvar; explicit * tyvars may not be unified with other types. *) @@ -114,15 +114,15 @@ structure StatObject: STATOBJECT = fun TyVarDesc_eq ({id,base,...}:TyVarDesc, {id=id2,base=base2,...}:TyVarDesc) = id=id2 andalso base=base2 fun findType ty = - case #TypeDesc ty + case #TypeDesc ty of TYVAR (tl as ref (TY_LINK ty')) => - (case #TypeDesc ty' + (case #TypeDesc ty' of TYVAR (tl' as ref (TY_LINK ty'')) => (tl := TY_LINK ty''; findType ty'') | _ => ty') | _ => ty fun findRecType r = - case r + case r of VARrec {RowVar = rl as ref (REC_LINK r'), ...} => let val r'' = findRecType r' in rl := REC_LINK r''; r'' end | _ => r @@ -131,9 +131,9 @@ structure StatObject: STATOBJECT = * to change a RecType into a (lab, Type) SortedMap with optional * RowVar. *) - fun sanitiseRecType r : (Lab.lab, Type) SortedFinMap.map * + fun sanitiseRecType r : (Lab.lab, Type) SortedFinMap.map * {RowVar : RowVar, level : level ref} option = - case findRecType r + case findRecType r of NILrec => (SortedFinMap.empty, NONE) | VARrec rv => (SortedFinMap.empty, SOME rv) | ROWrec(lab, tau, r') => @@ -164,10 +164,10 @@ structure StatObject: STATOBJECT = * RowVar: * (1) Does not occur *) - + fun norm_Type ty = let val {TypeDesc,level} = findType ty - val TypeDesc = + val TypeDesc = case TypeDesc of TYVAR (ref (NO_TY_LINK tvd)) => (case #inst tvd of @@ -188,11 +188,11 @@ structure StatObject: STATOBJECT = (* Pickling *) val pu_TyVarDesc = - let fun to (((id,b),e,r),ov,ex) : TyVarDesc = + let fun to (((id,b),e,r),ov,ex) : TyVarDesc = {id=id, base=b, equality=e,rank=r,overloaded=ov,explicit=ex,inst=ref NONE} fun from {id, base,equality=e,rank=r,overloaded=ov,explicit=ex,inst} = (((id,base),e,r),ov,ex) - in Pickle.convert (to,from) + in Pickle.convert (to,from) (Pickle.tup3Gen0(Pickle.tup3Gen0(Pickle.pairGen0(Pickle.int,Pickle.string), Pickle.bool, TyName.Rank.pu_rankrefOne), @@ -200,7 +200,7 @@ structure StatObject: STATOBJECT = Pickle.optionGen ExplicitTyVar.pu)) end - val pu_TyLink = + val pu_TyLink = Pickle.convert (NO_TY_LINK, fn NO_TY_LINK a => a | _ => die "pu_TyLink.NO_TY_LINK") pu_TyVarDesc @@ -209,15 +209,15 @@ structure StatObject: STATOBJECT = val pu_Type : TypeDesc Pickle.pu -> Type Pickle.pu = let fun to (td,l) = {TypeDesc=td,level=l} fun from {TypeDesc=td,level=l} = (td,l) - in Pickle.cache "Type" (fn pu_td => Pickle.convert (to,from) + in Pickle.cache "Type" (fn pu_td => Pickle.convert (to,from) (Pickle.pairGen0(pu_td,Pickle.ref0EqGen (fn (r1,r2) => !r1 = !r2) Pickle.int))) end - + val pu_Types : TypeDesc Pickle.pu -> Type list Pickle.pu = Pickle.cache "Types" (fn pu_td => Pickle.listGen (pu_Type pu_td)) fun swap (x,y) = (y,x) - + local val (pu_TypeDesc, _) = let fun TypeDescToInt (TYVAR _) = 0 @@ -246,7 +246,7 @@ structure StatObject: STATOBJECT = Pickle.con1 ROWrec (fn ROWrec a => a | _ => die "pu_RecType.ROWrec") (Pickle.tup3Gen0(Lab.pu,pu_Type pu_TypeDesc,pu_RecType)) - val TypeDescFuns = + val TypeDescFuns = [TypeDescTYVAR, TypeDescARROW, TypeDescRECTYPE, TypeDescCONSTYPE] val RecTypeFuns = [RecTypeNILrec, RecTypeROWrec] @@ -257,7 +257,7 @@ structure StatObject: STATOBJECT = val pu_Type = pu_Type pu_TypeDesc end - structure TyVar = + structure TyVar = struct (* Does a type variable admit equality; findType must have @@ -271,7 +271,7 @@ structure StatObject: STATOBJECT = * equality of type variables is tested only for non-linked * type variables, that is, we require that findType has been applied * before equality of type variables is tested. *) - + fun eq (tv,tv') = tv = tv' orelse case (tv, tv') of (ref(NO_TY_LINK tvd1), ref(NO_TY_LINK tvd2)) => TyVarDesc_eq(tvd1,tvd2) @@ -283,7 +283,7 @@ structure StatObject: STATOBJECT = (* Get overloading information; findType must have been * applied prior to calling these function. *) - + fun get_overloaded (ref (NO_TY_LINK tvd)) = #overloaded tvd | get_overloaded (ref (TY_LINK _)) = die "TyVar.get_overloaded" @@ -310,12 +310,12 @@ structure StatObject: STATOBJECT = | NONE => die "unset_instance.tyvar not instantiated") | unset_instance _ = die "unset_instance.link" - + (* Make a fresh type variable based on overloading and * eq-admit info *) - local val r = ref 0 - in + local val r = ref 0 + in fun fresh0 {equality, overloaded, explicit} = ref (NO_TY_LINK {id = (r := !r + 1 ; !r), base = Name.baseGet(), @@ -330,7 +330,7 @@ structure StatObject: STATOBJECT = overloaded=SOME (TyName.Set.fromList tynames), explicit=NONE} - fun from_ExplicitTyVar extv = fresh0 {equality=ExplicitTyVar.isEquality extv, + fun from_ExplicitTyVar extv = fresh0 {equality=ExplicitTyVar.isEquality extv, overloaded=NONE, explicit=SOME extv} end @@ -370,7 +370,7 @@ structure StatObject: STATOBJECT = end | pretty_string a pr_ty (ref (TY_LINK ty)) = let val ty = findType ty - in case #TypeDesc ty + in case #TypeDesc ty of TYVAR tv => pretty_string a pr_ty tv ^ "{" ^ Int.toString(!(#level ty)) ^ "}" | _ => pr_ty ty ^ "{" ^ Int.toString(!(#level ty)) ^ "}" end @@ -379,7 +379,7 @@ structure StatObject: STATOBJECT = fun layout' pr_ty tv = PP.LEAF(string' pr_ty tv) val pretty_string = fn a => pretty_string a (fn _ => "(ty_link)") - val string = pretty_string NONAMES + val string = pretty_string NONAMES val layout = PP.LEAF o string (* Operations on sets of type variables *) @@ -388,7 +388,7 @@ structure StatObject: STATOBJECT = fun insertTyVarSet x set = if memberTyVarSet x set then set else x::set - fun unionTyVarSet(set1, set2) = + fun unionTyVarSet(set1, set2) = set1 @ List.filter (fn x => not(memberTyVarSet x set1)) set2 fun minusTyVarSet (set1, set2) = @@ -413,7 +413,7 @@ structure StatObject: STATOBJECT = infix oo structure Substitution = struct val Id = () - val bogus = Id + val bogus = Id fun (S1 : Substitution) oo (S2 : Substitution) : Substitution = () fun on (S : Substitution, tau : Type) : Type = findType tau fun onScheme (S : Substitution, (tvs,tau)) = (tvs, findType tau) @@ -421,17 +421,17 @@ structure StatObject: STATOBJECT = - structure Type = - struct + structure Type = + struct - local val r = ref 0 + local val r = ref 0 in fun freshRow () = VARrec {RowVar = ref (NO_REC_LINK (r := !r + 1 ; !r)), level = ref (Level.current())} end - + fun layout ty = let val ty = findType ty - val st = - case #TypeDesc ty + val st = + case #TypeDesc ty of CONSTYPE ([], tyname) => TyName.layout tyname | CONSTYPE (ty_list, tyname) => PP.NODE {start="(", finish=") " ^ TyName.pr_TyName tyname, indent=1, @@ -449,9 +449,9 @@ structure StatObject: STATOBJECT = else st end - and RecType_layout r = + and RecType_layout r = let val (m, rv_opt) = sanitiseRecType r - val finish = case rv_opt + val finish = case rv_opt of SOME {RowVar=rv,...} => " ... " ^ pr_RowVar rv ^ "}" | NONE => "}" in SortedFinMap.layoutMap {start="{", eq=" : ", sep=", ", finish=finish} @@ -460,7 +460,7 @@ structure StatObject: STATOBJECT = and pr_RowVar (ref (NO_REC_LINK rho)) = "'r" ^ Int.toString rho | pr_RowVar _ = die "pr_RowVar" - + local fun Type_eq0 eq_significant (ty,ty') = let val (ty,ty') = (findType ty, findType ty') @@ -468,37 +468,37 @@ structure StatObject: STATOBJECT = (* We could check here that the levels are different from Level.GENERIC *) in !level = !level' andalso - (case (TypeDesc, TypeDesc') + (case (TypeDesc, TypeDesc') of (TYVAR (tv as ref (NO_TY_LINK _)), TYVAR (tv' as ref (NO_TY_LINK _))) => TyVar.eq' eq_significant (tv,tv') - | (ARROW (ty1,ty1'), ARROW (ty2,ty2')) => + | (ARROW (ty1,ty1'), ARROW (ty2,ty2')) => Type_eq0 eq_significant (ty1,ty2) andalso Type_eq0 eq_significant (ty1',ty2') | (RECTYPE r1, RECTYPE r2) => RecType_eq0 eq_significant (r1,r2) - | (CONSTYPE (tys1,tyname1), CONSTYPE (tys2,tyname2)) => + | (CONSTYPE (tys1,tyname1), CONSTYPE (tys2,tyname2)) => TyName.eq (tyname1, tyname2) andalso TypeList_eq0 eq_significant (tys1,tys2) | _ => false) end - + and RecType_eq0 eq_significant (r1,r2) = let val (r1,r2) = (findRecType r1, findRecType r2) - in case (r1,r2) + in case (r1,r2) of (NILrec, NILrec) => true | (VARrec {RowVar,level}, VARrec {RowVar=RowVar',level=level'}) => !level = !level' andalso RowVar = RowVar' - | (ROWrec (l1,ty1,r1'), ROWrec (l2,ty2,r2')) => + | (ROWrec (l1,ty1,r1'), ROWrec (l2,ty2,r2')) => l1 = l2 andalso Type_eq0 eq_significant (ty1,ty2) andalso RecType_eq0 eq_significant (r1',r2') | _ => false end and TypeList_eq0 eq_significant (tys1,tys2) = - List.foldl (fn ((ty1,ty2),b) => b andalso + List.foldl (fn ((ty1,ty2),b) => b andalso Type_eq0 eq_significant (ty1,ty2)) true (BasisCompat.ListPair.zipEq (tys1,tys2)) handle BasisCompat.ListPair.UnequalLengths => false in val RecType_eq = RecType_eq0 EQ_SIGNIFICANT - val eq = Type_eq0 EQ_SIGNIFICANT + val eq = Type_eq0 EQ_SIGNIFICANT val eq_equality_not_significant = Type_eq0 EQ_NOT_SIGNIFICANT (* only used by TypeFcn.eq *) end (*local*) @@ -506,14 +506,14 @@ structure StatObject: STATOBJECT = local (* Precedence levels of operators: tycon : 4 * : 3 - -> : 2 + -> : 2 {}(), : 1 *) fun parenthesize (operator_precedence : int, context_precedence, s : string) = if operator_precedence < context_precedence then concat ["(", s, ")"] else s - fun is_tuple_type (m, rv) = + fun is_tuple_type (m, rv) = (SortedFinMap.matches (fn (i, lab) => Lab.is_LabN(lab, i+1)) m, rv) @@ -533,11 +533,11 @@ structure StatObject: STATOBJECT = * NONE otherwise*) fun fields_of_other_record (ty'_opt : Type option, fields : Type list) = - case ty'_opt of + case ty'_opt of SOME {TypeDesc = RECTYPE r', ...} => let val r' = findRecType r' - val (m', rv') = sanitiseRecType r' - in + val (m', rv') = sanitiseRecType r' + in ziptypes (SortedFinMap.rangeSORTED m') fields end | _ => map (fn field => NONE) fields @@ -547,16 +547,16 @@ structure StatObject: STATOBJECT = * are the same. If the type names are different, they are * printed differently, even if they have the same tycon. *) - fun full_works tyname = + fun full_works tyname = let val (i,b) = TyName.id tyname - in concat [TyName.pr_TyName tyname, "<", + in concat [TyName.pr_TyName tyname, "<", Int.toString i , "-", b, ">"] end fun TyName_string_as_opt (tyname, tyname'_opt) = - case tyname'_opt of - SOME tyname' => - if TyName.eq (tyname,tyname') then TyName.pr_TyName tyname + case tyname'_opt of + SOME tyname' => + if TyName.eq (tyname,tyname') then TyName.pr_TyName tyname else if TyName.tycon tyname = TyName.tycon tyname' then full_works tyname else TyName.pr_TyName tyname @@ -566,14 +566,14 @@ structure StatObject: STATOBJECT = let val ty = findType ty val ty'_opt = map_opt findType ty'_opt val st_ty = - case #TypeDesc ty + case #TypeDesc ty of TYVAR tv => TyVar.pretty_string names tv - + | RECTYPE r => (* See if we can print it as `a * b * ...' * rather than `{1: a, 2: b, ...}' *) let val r = findRecType r val (m, rv) = sanitiseRecType r - in case is_tuple_type(m, rv) + in case is_tuple_type(m, rv) of (true, NONE) => (* A possible (t1 * t2 * ...) type, and * no rowvar. *) print_tuple names precedence (m, ty'_opt) @@ -589,26 +589,26 @@ structure StatObject: STATOBJECT = (ListPair.zip (labels,field_types)) end end - + | ARROW (t1, t2) => parenthesize - (2, precedence, + (2, precedence, (case ty'_opt of SOME {TypeDesc = ARROW(t1', t2'), ...} => pretty_string_as_opt names 3 (t1, SOME t1') ^ "->" - ^ pretty_string_as_opt names 2 (t2, SOME t2') + ^ pretty_string_as_opt names 2 (t2, SOME t2') | _ => pretty_string_as_opt names 3 (t1, NONE) ^ "->" ^ pretty_string_as_opt names 2 (t2, NONE))) - + | CONSTYPE (tys, tyname) => - let val (tys'_opt, tyname'_opt) = - case ty'_opt - of SOME {TypeDesc = CONSTYPE(tys', tyname'), ...} => + let val (tys'_opt, tyname'_opt) = + case ty'_opt + of SOME {TypeDesc = CONSTYPE(tys', tyname'), ...} => (ziptypes tys' tys, SOME tyname') | _ => (map (fn _ => NONE) tys, NONE) in - case (tys, tys'_opt) + case (tys, tys'_opt) of (nil,_) => TyName_string_as_opt (tyname, tyname'_opt) | ([ty], [ty']) => concat [pretty_string_as_opt names 4 (ty,ty'), " ", @@ -616,7 +616,7 @@ structure StatObject: STATOBJECT = | _ => concat [ListUtils.stringSep "(" ") " ", " (pretty_string_as_opt names 1) - (ListPair.zip (tys,tys'_opt)), + (ListPair.zip (tys,tys'_opt)), " ", TyName_string_as_opt (tyname, tyname'_opt)] end @@ -633,12 +633,12 @@ structure StatObject: STATOBJECT = let val fields = SortedFinMap.rangeSORTED m - val fields' = - (case ty'_opt of + val fields' = + (case ty'_opt of SOME {TypeDesc = RECTYPE r', ...} => let val r' = findRecType r' - val (m', rv') = sanitiseRecType r' - in (case (SortedFinMap.matches + val (m', rv') = sanitiseRecType r' + in (case (SortedFinMap.matches (fn (i,lab) => Lab.is_LabN (lab, i+1)) m', rv') of (true, NONE) => @@ -653,7 +653,7 @@ structure StatObject: STATOBJECT = | ([x], [x']) => "{1: " ^ pretty_string_as_opt names 1 (x,x') ^ "}" | _ => parenthesize (3, precedence, ListUtils.stringSep "" "" " * " - (pretty_string_as_opt names 4) + (pretty_string_as_opt names 4) (ListPair.zip(fields, fields')))) end in @@ -668,7 +668,7 @@ structure StatObject: STATOBJECT = fun from_TyVar tyvar = {TypeDesc = TYVAR tyvar, level = ref (Level.current ())} - fun to_TyVar ty = case #TypeDesc (findType ty) + fun to_TyVar ty = case #TypeDesc (findType ty) of TYVAR tyvar => SOME tyvar | _ => NONE @@ -676,7 +676,7 @@ structure StatObject: STATOBJECT = val fresh_normal = from_TyVar o TyVar.fresh_normal fun from_RecType r = {TypeDesc = RECTYPE r, level = ref Level.NONGENERIC} - fun to_RecType ty = case #TypeDesc (findType ty) + fun to_RecType ty = case #TypeDesc (findType ty) of RECTYPE t => SOME t | _ => NONE @@ -684,14 +684,14 @@ structure StatObject: STATOBJECT = * variable in tau. *) fun contains_row_variable t = - case #TypeDesc (findType t) + case #TypeDesc (findType t) of TYVAR _ => false | ARROW (t1, t2) => contains_row_variable t1 orelse contains_row_variable t2 | RECTYPE r => RecType_contains_row_variable r | CONSTYPE (tylist, _) => List.exists contains_row_variable tylist and RecType_contains_row_variable r = - case findRecType r + case findRecType r of NILrec => false | VARrec _ => true | ROWrec (_, ty, r') => contains_row_variable ty orelse RecType_contains_row_variable r' @@ -745,7 +745,7 @@ structure StatObject: STATOBJECT = fun sorted_labs r = (case sanitiseRecType r of (m, _) => SortedFinMap.domSORTED m) - fun to_list r = + fun to_list r = let val m = #1 (sanitiseRecType r) in BasisCompat.ListPair.zipEq (SortedFinMap.domSORTED m, SortedFinMap.rangeSORTED m) @@ -782,24 +782,24 @@ structure StatObject: STATOBJECT = * level different from GENERIC then it is not necessary to look * for bound variables in the type. *) - local + local datatype free_or_bound = FREE | BOUND val bucket = ref ([] : TyVar list) fun insert tv = if List.exists (fn tv' => TyVar.eq(tv,tv')) (!bucket) then () else bucket := (tv :: (!bucket)) - fun tyvars0 f_b ty : unit = - let val ty = findType ty - in case #TypeDesc ty - of TYVAR (tl as ref (NO_TY_LINK _)) => - (case f_b + fun tyvars0 f_b ty : unit = + let val ty = findType ty + in case #TypeDesc ty + of TYVAR (tl as ref (NO_TY_LINK _)) => + (case f_b of FREE => if !(#level ty) = Level.GENERIC then () else insert tl | BOUND => if !(#level ty) = Level.GENERIC then insert tl else ()) | TYVAR (ref (TY_LINK _)) => die "tyvars0" | RECTYPE r => RecType.fold (fn (ty, ()) => tyvars0 f_b ty) () (findRecType r) | ARROW (ty,ty') => (* For the compilation of value constructors, we - * extract the tyvars of ty' before those of ty. + * extract the tyvars of ty' before those of ty. * Martin-15/11/1998 *) (tyvars0 f_b ty'; tyvars0 f_b ty) @@ -814,15 +814,15 @@ structure StatObject: STATOBJECT = * depend on the exact order the bound variables are * extracted from a type - so expect things to blow up if you * modify this very code. *) - + fun tyvars ty : TyVar list = tyvars1 FREE ty fun generic_tyvars ty : TyVar list = tyvars1 BOUND ty end fun tynames ty = let val ty = findType ty - in case #TypeDesc ty - of TYVAR _ => TyName.Set.empty + in case #TypeDesc ty + of TYVAR _ => TyName.Set.empty | RECTYPE r => RecType.fold (fn (ty, T) => TyName.Set.union (tynames ty) T) TyName.Set.empty r @@ -851,9 +851,9 @@ structure StatObject: STATOBJECT = (case #TypeDesc (findType ty) of ARROW (ty',ty'') => SOME ty | _ => NONE) - fun mk_FunType (ty,ty') = + fun mk_FunType (ty,ty') = {TypeDesc = ARROW (ty,ty'), level = ref Level.NONGENERIC} - fun un_FunType ty = + fun un_FunType ty = (case #TypeDesc (findType ty) of ARROW (ty,ty') => SOME (ty,ty') | _ => NONE) @@ -867,23 +867,23 @@ structure StatObject: STATOBJECT = CONSTYPE (types, tyname) => SOME ty | _ => NONE) - fun mk_ConsType (typel, name) = + fun mk_ConsType (typel, name) = {TypeDesc = CONSTYPE (typel,name), level = ref Level.NONGENERIC} - fun un_ConsType ty = + fun un_ConsType ty = (case #TypeDesc (findType ty) of CONSTYPE (typel,name) => SOME (typel,name) | _ => NONE) val Exn = mk_ConsType ([], TyName.tyName_EXN) - fun is_Exn ty = - (case #TypeDesc (findType ty) of + fun is_Exn ty = + (case #TypeDesc (findType ty) of CONSTYPE ([], name) => TyName.eq (name, TyName.tyName_EXN) | _ => false) fun mk_Arrow (ty,ty') = {TypeDesc = ARROW (ty,ty'), level = ref Level.NONGENERIC} fun un_Arrow ty = - (case #TypeDesc (findType ty) of + (case #TypeDesc (findType ty) of ARROW (t, t') => SOME (t, t') | _ => NONE) - fun is_Arrow ty = + fun is_Arrow ty = (case #TypeDesc (findType ty) of ARROW _ => true | _ => false) @@ -893,11 +893,19 @@ structure StatObject: STATOBJECT = (* Special constants *) val tag_values = Flags.is_on0 "tag_values" + val values_64bit = Flags.is_on0 "values_64bit" val Int31 = mk_ConsType ([], TyName.tyName_INT31) val Int32 = mk_ConsType ([], TyName.tyName_INT32) + val Int63 = mk_ConsType ([], TyName.tyName_INT63) + val Int64 = mk_ConsType ([], TyName.tyName_INT64) val IntInf = mk_ConsType ([], TyName.tyName_INTINF) - fun IntDefault() = if tag_values() then Int31 else Int32 + fun IntDefault () = + case (tag_values(), values_64bit()) of + (true, true) => Int63 + | (true, false) => Int31 + | (false, true) => Int64 + | (false, false) => Int32 val Real = mk_ConsType ([], TyName.tyName_REAL) val String = mk_ConsType ([], TyName.tyName_STRING) @@ -907,37 +915,90 @@ structure StatObject: STATOBJECT = val Word8 = mk_ConsType ([], TyName.tyName_WORD8) val Word31 = mk_ConsType ([], TyName.tyName_WORD31) val Word32 = mk_ConsType ([], TyName.tyName_WORD32) - fun WordDefault() = if tag_values() then Word31 else Word32 + val Word63 = mk_ConsType ([], TyName.tyName_WORD63) + val Word64 = mk_ConsType ([], TyName.tyName_WORD64) + fun WordDefault () = + case (tag_values(), values_64bit()) of + (true, true) => Word63 + | (true, false) => Word31 + | (false, true) => Word64 + | (false, false) => Word32 fun simple_scon ty = {type_scon = ty, overloading = NONE} + + (* MEMO: For bootstrapping, we don't want the source code to + depend on us having Int63 and Int64 and friends in scope... *) + + fun fits31bits (i:IntInf.int) : bool = + IntInf.<=(IntInf.fromLarge(Int31.toLarge(valOf Int31.minInt)), i) andalso + IntInf.<=(i, IntInf.fromLarge(Int31.toLarge(valOf Int31.maxInt))) + + fun fits32bits (i:IntInf.int) : bool = + IntInf.<=(IntInf.fromLarge(Int32.toLarge(valOf Int32.minInt)), i) andalso + IntInf.<=(i, IntInf.fromLarge(Int32.toLarge(valOf Int32.maxInt))) + + fun fits64bits (i:IntInf.int) : bool = + let val maxi64 : IntInf.int = 7*7*73*127*337*92737*649657 (* = 9223372036854775807 = 2^63-1 *) + val mini64 : IntInf.int = ~ maxi64 - 1 (* = ~9223372036854775808 = ~2^63 *) + in IntInf.<=(mini64, i) andalso IntInf.<=(i, maxi64) + end + + fun fits63bits (i:IntInf.int) : bool = + let val maxi63 : IntInf.int = 7*7*73*127*337*92737*649657 (* = 9223372036854775807 = 2^63-1 *) + val mini63 : IntInf.int = ~ maxi63 - 1 (* = ~9223372036854775808 = ~2^63 *) + in IntInf.<=(mini63, i) andalso IntInf.<=(i, maxi63) + end + fun of_scon sc = - case sc - of SCon.INTEGER i => - if IntInf.>(i, IntInf.fromLarge(Int32.toLarge(valOf Int32.maxInt))) orelse - IntInf.<(i, IntInf.fromLarge(Int32.toLarge(valOf Int32.minInt))) - then - simple_scon IntInf - else if IntInf.>(i, IntInf.fromLarge(Int31.toLarge(valOf Int31.maxInt))) orelse - IntInf.<(i, IntInf.fromLarge(Int31.toLarge(valOf Int31.minInt))) - then - let val tv = TyVar.fresh_overloaded [TyName.tyName_INT32,TyName.tyName_INTINF] - in {type_scon=from_TyVar tv, overloading=SOME tv} - end - else - let val tv = TyVar.fresh_overloaded [TyName.tyName_INT31,TyName.tyName_INT32,TyName.tyName_INTINF] - in {type_scon=from_TyVar tv, overloading=SOME tv} - end + case sc of + SCon.INTEGER i => + let fun mk tns = + let val tv = TyVar.fresh_overloaded tns + in {type_scon=from_TyVar tv, overloading=SOME tv} + end + open TyName + in if fits31bits i then + mk ([tyName_INTINF, tyName_INT32, tyName_INT31] @ + (if values_64bit() then [tyName_INT64, tyName_INT63] else [])) + else if fits32bits i then + mk ([tyName_INTINF, tyName_INT32] @ + (if values_64bit() then [tyName_INT64, tyName_INT63] else [])) + else if fits63bits i then + mk ([tyName_INTINF] @ + (if values_64bit() then [tyName_INT64, tyName_INT63] else [])) + else if fits64bits i then + mk ([tyName_INTINF] @ + (if values_64bit() then [tyName_INT64] else [])) + else simple_scon IntInf + end | SCon.STRING _ => simple_scon String | SCon.REAL _ => simple_scon Real | SCon.CHAR _ => simple_scon Char - | SCon.WORD w => - if w > 0wx7FFFFFFF then simple_scon Word32 - else let - val tv = TyVar.fresh_overloaded - (if w > 0w255 (* 2^8 *) then [TyName.tyName_WORD31, TyName.tyName_WORD32] - else [TyName.tyName_WORD8, TyName.tyName_WORD31, TyName.tyName_WORD32]) - in {type_scon=from_TyVar tv, overloading=SOME tv} - end + | SCon.WORD w => + let fun mk tns = + let val tv = TyVar.fresh_overloaded tns + in {type_scon=from_TyVar tv, overloading=SOME tv} + end + fun pow2 (x:IntInf.int) : IntInf.int = + if x < 1 then 1 + else 2 * pow2 (x - 1) + open TyName + in if w <= 0xFF then + mk ([tyName_WORD32, tyName_WORD31, tyName_WORD8] @ + (if values_64bit() then [tyName_WORD64, tyName_WORD63] else [])) + else if w <= 0x7FFFFFFF then + mk ([tyName_WORD32, tyName_WORD31] @ + (if values_64bit() then [tyName_WORD64, tyName_WORD63] else [])) + else if w <= (0x7FFFFFFF*2+1) then + mk ([tyName_WORD32] @ + (if values_64bit() then [tyName_WORD64, tyName_WORD63] else [])) + else if w <= pow2 63 - 1 andalso values_64bit() then + mk [tyName_WORD64, tyName_WORD63] + else if w <= pow2 64 - 1 andalso values_64bit() then + simple_scon Word64 + else die ("immediate word constant 0w" ^ IntInf.toString w ^ " is not representable in " ^ + (if values_64bit() then "64 bits" else "32 bits")) + end local @@ -945,7 +1006,7 @@ structure StatObject: STATOBJECT = * current_level. generalise imperative type variables iff * (imp and level > current_level). *) - fun generalise {ov, imp, tau} = + fun generalise {ov, imp, tau} = let val tau = findType tau val {TypeDesc, level} = tau in @@ -954,34 +1015,34 @@ structure StatObject: STATOBJECT = (case TypeDesc of TYVAR tv => if !level > Level.current () - then if (ov orelse not (TyVar.is_overloaded tv)) andalso imp - then level := Level.GENERIC + then if (ov orelse not (TyVar.is_overloaded tv)) andalso imp + then level := Level.GENERIC else level := Level.current () else () | ARROW (tau1, tau2) => - level := Int.min (generalise {ov=ov, imp=imp, tau=tau1}, + level := Int.min (generalise {ov=ov, imp=imp, tau=tau1}, generalise {ov=ov, imp=imp, tau=tau2}) - | RECTYPE r => + | RECTYPE r => level := generaliseRecType {ov=ov, imp=imp, r=r} - | CONSTYPE (taus, tyname) => + | CONSTYPE (taus, tyname) => level := foldl Int.min Level.NONGENERIC (map (fn tau => generalise {ov=ov, imp=imp, tau=tau}) (rev taus)) ); !level end - + and generaliseRecType {ov, imp, r} = - let val r = findRecType r - in case r + let val r = findRecType r + in case r of NILrec => Level.NONGENERIC - | VARrec {level,...} => (if !level > Level.current() then level := Level.current() + | VARrec {level,...} => (if !level > Level.current() then level := Level.current() else (); Level.NONGENERIC) | ROWrec (l,tau,r') => Int.min (generalise {ov=ov, imp=imp, tau=tau}, generaliseRecType {ov=ov, imp=imp, r=r'}) end in - val generalise : {ov:bool,imp:bool,tau:Type} -> unit = + val generalise : {ov:bool,imp:bool,tau:Type} -> unit = fn a => (generalise a; ()) end (*local*) @@ -993,8 +1054,8 @@ structure StatObject: STATOBJECT = local exception NotEquality - fun make_equality0 ty = - case #TypeDesc (findType ty) + fun make_equality0 ty = + case #TypeDesc (findType ty) of TYVAR (tv as (ref (NO_TY_LINK ({explicit=SOME ExplicitTyVar,...})))) => if ExplicitTyVar.isEquality ExplicitTyVar then () else raise NotEquality | TYVAR (tv as (ref (NO_TY_LINK ({equality, overloaded, id, base, rank, explicit=NONE, inst, ...})))) => @@ -1019,7 +1080,7 @@ structure StatObject: STATOBJECT = (************************ * - * Unification of types + * Unification of types * ************************) @@ -1050,8 +1111,8 @@ structure StatObject: STATOBJECT = fun occurs_tv_in_Type (tv: TyVar, ty: Type) : bool = let - fun occursType ty = - case findType ty + fun occursType ty = + case findType ty of {TypeDesc = TYVAR tv', ...} => TyVar.eq(tv,tv') | {TypeDesc = ARROW(ty1, ty2), ...} => occursType ty1 orelse occursType ty2 | {TypeDesc = CONSTYPE(tys, tn), ...} => foldl (fn (ty, b) => b orelse occursType ty) false tys @@ -1060,13 +1121,13 @@ structure StatObject: STATOBJECT = end fun occurs_rv_in_RecType(rv, r) = - case findRecType r + case findRecType r of NILrec => false | VARrec {RowVar=rv',...} => (rv = rv') | ROWrec(_, ty, r') => occurs_rv_in_Type(rv, ty) orelse occurs_rv_in_RecType(rv, r') and occurs_rv_in_Type(rv, ty) = - case #TypeDesc (findType ty) + case #TypeDesc (findType ty) of TYVAR _ => false | ARROW(ty1, ty2) => occurs_rv_in_Type(rv, ty1) orelse occurs_rv_in_Type(rv, ty2) | RECTYPE r => occurs_rv_in_RecType(rv, r) @@ -1085,7 +1146,7 @@ structure StatObject: STATOBJECT = | {TypeDesc = RECTYPE r, ...} => decr_level_RecType lev r end and decr_level_RecType (lev : level) (r : RecType) : unit = - let val r = findRecType r + let val r = findRecType r in case r of NILrec => () | VARrec {level,...} => if !level > lev then level := lev else () @@ -1106,7 +1167,7 @@ structure StatObject: STATOBJECT = | RECTYPE r => decr_rank_RecType p r end and decr_rank_RecType (p as (tv,rnk : rank)) (r : RecType) : unit = - let val r = findRecType r + let val r = findRecType r in case r of NILrec => () | VARrec _ => () @@ -1128,23 +1189,23 @@ structure StatObject: STATOBJECT = * `overloaded' fields on the two unified tyvars. If tau is * not overloaded, we must not change the set `tynames1'. *) - fun unify_with_overloaded_tyvar tynames1 tau = - case #TypeDesc (findType tau) - of TYVAR (ref (NO_TY_LINK {explicit=SOME _,...})) => + fun unify_with_overloaded_tyvar tynames1 tau = + case #TypeDesc (findType tau) + of TYVAR (ref (NO_TY_LINK {explicit=SOME _,...})) => raise Unify "unify_with_overloaded_tyvar: explicit tyvar" - | TYVAR (tv as (ref (NO_TY_LINK {equality, id, base, overloaded=NONE, + | TYVAR (tv as (ref (NO_TY_LINK {equality, id, base, overloaded=NONE, rank, inst, ...}))) => - let val tvd = {equality = equality, id = id, base = base, rank = rank, + let val tvd = {equality = equality, id = id, base = base, rank = rank, overloaded=SOME tynames1, explicit = NONE, inst = inst} in tv := NO_TY_LINK tvd end - | TYVAR (tv as (ref (NO_TY_LINK {equality, id, base, overloaded=SOME tynames2, + | TYVAR (tv as (ref (NO_TY_LINK {equality, id, base, overloaded=SOME tynames2, rank, inst, ...}))) => - let val overloadSet = TyName.Set.intersect tynames1 tynames2 - val _ = if TyName.Set.isEmpty overloadSet then + let val overloadSet = TyName.Set.intersect tynames1 tynames2 + val _ = if TyName.Set.isEmpty overloadSet then raise Unify "unify_with_overloaded_tyvar: tyvars overloaded with distinct tynames" else () - val tvd = {equality = equality, id = id, base = base, rank = rank, + val tvd = {equality = equality, id = id, base = base, rank = rank, overloaded = SOME overloadSet, explicit = NONE, inst = inst} in tv := NO_TY_LINK tvd end @@ -1153,7 +1214,7 @@ structure StatObject: STATOBJECT = else raise Unify "unify_with_overloaded_tyvar: not overloaded to this tyname" | _ => raise Unify "unify_with_overloaded_tyvar: only overloaded to tynames" - + (* unify_with_tyvar tv; Check the attributes of an ordinary * TyVar are satisfied. We assume the `occurs' check has * already been done. *) @@ -1161,13 +1222,13 @@ structure StatObject: STATOBJECT = fun unify_with_tyvar (tv as ref (NO_TY_LINK {equality, overloaded, ...}), tau) = let val S = - if equality then - case make_equality tau + if equality then + case make_equality tau of SOME S => S | NONE => raise Unify "unify_with_tyvar.1" else Substitution.Id - val S' = case overloaded + val S' = case overloaded of SOME tynames => unify_with_overloaded_tyvar tynames (Substitution.on (S, tau)) | NONE => Substitution.Id @@ -1187,31 +1248,31 @@ structure StatObject: STATOBJECT = level=level}, ty' as {TypeDesc = TYVAR (tv' as ref (NO_TY_LINK {explicit=SOME ExplicitTyVar',...})), level=level'}) = - if TyVar.eq(tv,tv') then + if TyVar.eq(tv,tv') then if !level = !level' then () else raise Unify "unifyExplicit.level" else raise Unify "unifyExplicit.eq" - + | unifyExplicit (ty as {TypeDesc = TYVAR (tv as ref (NO_TY_LINK {explicit=SOME ExplicitTyVar,...})), level=level}, ty' as {TypeDesc = TYVAR(tv' as ref (NO_TY_LINK r)), level=level'}) = - + (* Notice below that unification of overloaded type * variable and explicit type variable is not allowed *) let val {equality, overloaded, ...} = r in - case (equality, ExplicitTyVar.isEquality ExplicitTyVar) + case (equality, ExplicitTyVar.isEquality ExplicitTyVar) of (false, _ ) => () | (true , true) => () | ( _ , _ ) => raise Unify "unifyExplicit.2"; if ListUtils.member tv' restricted_tyvars then raise Unify "unifyExplicit.3" else if TyVar.is_overloaded tv' then raise Unify "unifyExplicit.4" - else if !level' < !level then + else if !level' < !level then - (*Test example: + (*Test example: (fn x => let val f = fn (y: ''a) => x = y in 2 end);*) (*This exception is raised if an explicit type variable is @@ -1220,7 +1281,7 @@ structure StatObject: STATOBJECT = 15 in the Definition is not satisfied*) raise Unify "unifyExplicit.5" - else + else tv' := TY_LINK ty end | unifyExplicit (_, _) = raise Unify "unifyExplicit.7" @@ -1239,9 +1300,9 @@ structure StatObject: STATOBJECT = level=level}, ty' as {TypeDesc = TYVAR(tv' as ref(NO_TY_LINK{rank=rank_ref' as ref r', ...})), level=level'}) = - if TyVar.eq (tv,tv') then + if TyVar.eq (tv,tv') then if !level = !level' then () else die "unifyTyVar" - else + else let val rank = Rank.min(r,r') in rank_ref := rank ; rank_ref' := rank ; @@ -1260,7 +1321,7 @@ structure StatObject: STATOBJECT = else (decr_level_Type (!level) ty' ; decr_rank_Type (tv,!rank) ty' ; (* the tv is for the error reporting *) - if occurs_tv_in_Type (tv, ty') orelse ListUtils.member tv restricted_tyvars + if occurs_tv_in_Type (tv, ty') orelse ListUtils.member tv restricted_tyvars then raise Unify "unifyTyVar.2" else unify_with_tyvar(tv, ty')) @@ -1272,10 +1333,10 @@ structure StatObject: STATOBJECT = *******************) fun unifyType(ty,ty') = - let + let val (ty,ty') = (findType ty,findType ty') in - case (#TypeDesc ty, #TypeDesc ty') + case (#TypeDesc ty, #TypeDesc ty') of (TYVAR _, _) => unifyTyVar (ty, ty') | (_, TYVAR _) => unifyTyVar (ty', ty) | (RECTYPE r, RECTYPE r') => unifyRecType(r, r') @@ -1303,7 +1364,7 @@ structure StatObject: STATOBJECT = end and unifyRow(row1: RecType, row2: RecType): Substitution = - let val (row1,row2) = (RecType.sort row1, RecType.sort row2) + let val (row1,row2) = (RecType.sort row1, RecType.sort row2) in unifyRow' (row1, row2) end @@ -1323,7 +1384,7 @@ structure StatObject: STATOBJECT = | (ROWrec(lab1, ty1, row1'), ROWrec(lab2, ty2, row2')) => if lab1 = lab2 then (unifyType(ty1, ty2); unifyRow(row1',row2')) - else + else if Lab.<(lab1, lab2) then (* Pad out row2, try again *) (extract(lab1,row2); unifyRow(row1,row2)) else (* Pad out row1, try again *) @@ -1336,7 +1397,7 @@ structure StatObject: STATOBJECT = and unifyConsType((ty_list, tyname), (ty_list', tyname')) = if TyName.eq(tyname, tyname') then (* Note that tyname=tyname' implies *) - List.app unifyType (ListPair.zip(ty_list, ty_list')) (* length(ty_list)=length(ty_list') *) + List.app unifyType (ListPair.zip(ty_list, ty_list')) (* length(ty_list)=length(ty_list') *) else raise Unify "unifyConsType" in (unifyType (tau,tau'); UnifyOk) @@ -1344,7 +1405,7 @@ structure StatObject: STATOBJECT = | Rank(tv,tn) => UnifyRankError(tv,tn) end - fun unify (ty1,ty2) = + fun unify (ty1,ty2) = restricted_unify {restricted_tyvars=nil} (ty1,ty2) (* Matching functions for compilation manager *) @@ -1352,23 +1413,23 @@ structure StatObject: STATOBJECT = local fun match_Type (ty,ty0) : unit = let val (ty, ty0) = (findType ty, findType ty0) - in case (#TypeDesc ty,#TypeDesc ty0) + in case (#TypeDesc ty,#TypeDesc ty0) of (ARROW (tau,tau'), ARROW (tau0,tau0')) => (match_Type(tau,tau0); match_Type (tau',tau0')) | (RECTYPE rect, RECTYPE rect0) => match_RecType (rect,rect0) | (CONSTYPE (taus,tn), CONSTYPE (taus0,tn0)) => (match_Types (taus, taus0) ; TyName.match (tn, tn0)) - | _ => () + | _ => () end and match_Types ([],_) = () | match_Types (_,[]) = () | match_Types (tau::taus, tau0::taus0) = (match_Type (tau, tau0) ; match_Types (taus, taus0)) - + and match_RecType(rect,rect0) = - case (findRecType rect, findRecType rect0) - of (ROWrec (l,tau,rect), ROWrec (l0,tau0,rect0)) => + case (findRecType rect, findRecType rect0) + of (ROWrec (l,tau,rect), ROWrec (l0,tau0,rect0)) => if l <> l0 then () else (match_Type (tau,tau0) ; match_RecType (rect,rect0)) | _ => () @@ -1386,7 +1447,7 @@ structure StatObject: STATOBJECT = type TypeScheme = TyVar list * Type - structure TypeScheme = + structure TypeScheme = struct (* Prettyprinting of type schemes *) @@ -1404,15 +1465,15 @@ structure StatObject: STATOBJECT = fun instance_with_types (([],tau),[]) = tau | instance_with_types ((tvs,tau),taus) = - let + let fun instanceType ty = let val ty = findType ty val {TypeDesc, level} = ty - in if !level <> Level.GENERIC then ty - else case TypeDesc - of TYVAR (tv as ref (NO_TY_LINK {inst=ref(SOME ty),...})) => ty - | TYVAR (tv as ref (NO_TY_LINK {inst=ref NONE,...})) => - die "instanceType.generic tyvar not instantiated" + in if !level <> Level.GENERIC then ty + else case TypeDesc + of TYVAR (tv as ref (NO_TY_LINK {inst=ref(SOME ty),...})) => ty + | TYVAR (tv as ref (NO_TY_LINK {inst=ref NONE,...})) => + die "instanceType.generic tyvar not instantiated" | TYVAR (ref (TY_LINK _)) => die "instanceType.findType doesn't work" | ARROW (ty1,ty2) => Type.mk_Arrow (instanceType ty1, instanceType ty2) | RECTYPE r => Type.from_RecType (instanceRecType r) @@ -1420,7 +1481,7 @@ structure StatObject: STATOBJECT = end and instanceRecType r = let val r = findRecType r - in case r + in case r of NILrec => r | VARrec rho => r | ROWrec (l,ty,r') => ROWrec (l,instanceType ty,instanceRecType r') @@ -1462,7 +1523,7 @@ structure StatObject: STATOBJECT = * used to implement equality of type functions. *) fun eq(([],ty1), ([],ty2)) = Type.eq(ty1,ty2) - | eq(sigma1 as (tvs1,_), sigma2 as (tvs2,_)) = + | eq(sigma1 as (tvs1,_), sigma2 as (tvs2,_)) = length tvs1 = length tvs2 andalso let fun fresh (tv as ref(NO_TY_LINK tvdesc)) = Type.from_TyVar(TyVar.refresh tv) | fresh _ = die ("eq.fresh: tysch= " ^ string sigma1) @@ -1493,8 +1554,8 @@ structure StatObject: STATOBJECT = (* One must use restricted unify! Consider the call * ``generalises_Type(int->int, 'a->int)''. This call * should return false! -- Martin *) - - case Type.restricted_unify {restricted_tyvars=TyVar.unionTyVarSet(fv_tau',fv_sigma)} (tau,tau') + + case Type.restricted_unify {restricted_tyvars=TyVar.unionTyVarSet(fv_tau',fv_sigma)} (tau,tau') of Type.UnifyOk => true | _ => false end @@ -1511,16 +1572,16 @@ structure StatObject: STATOBJECT = (* One must use restricted unify! Consider the call * ``generalises_TypeScheme(\/().'a->int, \/'b.'b->int)''. This call * should return false! -- mael 2004-08-05; see test/weeks6.sml *) - - case Type.restricted_unify {restricted_tyvars=TyVar.unionTyVarSet(fv_tau',fv_sigma)} (tau,tau') + + case Type.restricted_unify {restricted_tyvars=TyVar.unionTyVarSet(fv_tau',fv_sigma)} (tau,tau') of Type.UnifyOk => true | _ => false end - + (* close_overload tau; close a type and do not avoid * generalisation of overloaded type variables; this function * is used for creating type schemes for primitives. *) - + fun close_overload tau = let val tvs = (Type.generalise {ov=true, imp=true, tau=tau}; Type.generic_tyvars tau) @@ -1530,8 +1591,8 @@ structure StatObject: STATOBJECT = (* close imp sigma; close a type scheme. The tyvars list * should be empty. The boolean imp should be false if the * valbind that tau is the type of is expansive. *) - - fun close imp ([], tau) = + + fun close imp ([], tau) = let val tvs = (Type.generalise {ov=false, imp=imp, tau=tau}; Type.generic_tyvars tau) in (tvs, tau) @@ -1549,9 +1610,9 @@ structure StatObject: STATOBJECT = local fun violates_equality0 T tau = - case #TypeDesc (findType tau) + case #TypeDesc (findType tau) of TYVAR _ => false - | RECTYPE r => + | RECTYPE r => (Type.RecType.fold (fn (tau, res) => res orelse violates_equality0 T tau) false r) | CONSTYPE (taus, tyname) => @@ -1563,7 +1624,7 @@ structure StatObject: STATOBJECT = in fun violates_equality (T : TyName.Set.Set) (sigma : TypeScheme) : bool = let val (_, tau) = to_TyVars_and_Type sigma - in case Type.un_Arrow tau + in case Type.un_Arrow tau of NONE => false (*nullary constructor*) | SOME (tau', _) => violates_equality0 T tau' (*unary constructor*) end @@ -1575,7 +1636,7 @@ structure StatObject: STATOBJECT = val pu = Pickle.pairGen(Pickle.listGen TyVar.pu,Type.pu) - + end (*TypeScheme*) @@ -1585,22 +1646,22 @@ structure StatObject: STATOBJECT = datatype TypeFcn = TYPEFCN of {tyvars : TyVar list, tau : Type} - structure TypeFcn = + structure TypeFcn = struct - fun layout (TYPEFCN {tyvars, tau}) = + fun layout (TYPEFCN {tyvars, tau}) = let val tau = findType tau - in PP.NODE {start="/\\" ^ TyVar.pr_tyvars tyvars ^ ".", finish="", indent=0, + in PP.NODE {start="/\\" ^ TyVar.pr_tyvars tyvars ^ ".", finish="", indent=0, childsep=PP.NOSEP, children=[Type.layout tau]} end - fun eq (TYPEFCN {tyvars, tau}, TYPEFCN {tyvars=tyvars', tau=tau'}) = + fun eq (TYPEFCN {tyvars, tau}, TYPEFCN {tyvars=tyvars', tau=tau'}) = TypeScheme.eq((tyvars,tau),(tyvars',tau')) - + fun from_TyVars_and_Type (tyvars : TyVar list, tau : Type) = (Type.generalise {ov=false, imp=true, tau=tau}; TYPEFCN {tyvars=tyvars, tau=tau}) - + fun apply (theta as (TYPEFCN {tyvars, tau}), taus : Type list) : Type = TypeScheme.instance_with_types ((tyvars,tau),taus) @@ -1610,13 +1671,13 @@ structure StatObject: STATOBJECT = * function admits equality because the bound type variables * have already been renamed to admit equality. *) - fun admits_equality (theta as TYPEFCN {tyvars, tau}) : bool = - case Type.make_equality (TypeScheme.instance (tyvars,tau)) + fun admits_equality (theta as TYPEFCN {tyvars, tau}) : bool = + case Type.make_equality (TypeScheme.instance (tyvars,tau)) of SOME _ => true | NONE => false fun tynames (TYPEFCN {tyvars, tau}) = Type.tynames tau - + fun grounded (theta : TypeFcn, tynameset : TyName.Set.Set) : bool = TyName.Set.isEmpty (TyName.Set.difference (tynames theta) tynameset) @@ -1631,10 +1692,10 @@ structure StatObject: STATOBJECT = end fun to_TyName (TYPEFCN {tyvars, tau}) : TyName option = - case Type.un_ConsType tau + case Type.un_ConsType tau of SOME (taus,t) => let fun check ([],[]) = true - | check (tv::tvs,tau::taus) = + | check (tv::tvs,tau::taus) = (case Type.to_TyVar tau of SOME tv' => TyVar.eq (tv,tv') | NONE => false) andalso check(tvs,taus) @@ -1646,16 +1707,16 @@ structure StatObject: STATOBJECT = val is_TyName = is_Some o to_TyName - fun pretty_string names (TYPEFCN {tyvars, tau}) = - case tyvars + fun pretty_string names (TYPEFCN {tyvars, tau}) = + case tyvars of [] => {vars="", body=Type.pretty_string names tau} | [tyvar] => {vars=TyVar.pretty_string names tyvar, body=Type.pretty_string names tau} | tyvars => {vars=ListUtils.stringSep "(" ")" ", " (TyVar.pretty_string names) tyvars, body=Type.pretty_string names tau} - + fun pretty_string' names theta = #body (pretty_string names theta) - + fun match (TYPEFCN{tau,...}, TYPEFCN{tau=tau0,...}) : unit = Type.match(tau,tau0) val pu = @@ -1668,21 +1729,21 @@ structure StatObject: STATOBJECT = datatype TypeFcn' = TYNAME of TyName | EXPANDED of TypeFcn - datatype realisation = + datatype realisation = Not_Id of TypeFcn' TyName.Map.map | Realisation_Id structure Realisation = struct fun tynamesRng (Realisation_Id) = TyName.Set.empty - | tynamesRng (Not_Id m) = - TyName.Map.Fold (fn ((tn,TYNAME tn'),acc) => + | tynamesRng (Not_Id m) = + TyName.Map.Fold (fn ((tn,TYNAME tn'),acc) => if TyName.eq(tn,tn') then acc else TyName.Set.insert tn' acc - | ((tn,EXPANDED tf),acc) => - TyName.Set.union (TyName.Set.remove tn - (TypeFcn.tynames tf)) - acc) + | ((tn,EXPANDED tf),acc) => + TyName.Set.union (TyName.Set.remove tn + (TypeFcn.tynames tf)) + acc) TyName.Set.empty m fun dom Realisation_Id = TyName.Set.empty @@ -1691,24 +1752,24 @@ structure StatObject: STATOBJECT = (* correct_levels_Type ty; correct levels of non-tyvar nodes in * ty. Used by on_Type. *) - fun correct_levels_Type ty = - let val ty = findType ty + fun correct_levels_Type ty = + let val ty = findType ty in if !(#level ty) = Level.GENERIC then () else - case ty + case ty of {TypeDesc = TYVAR tv, level} => () - | {TypeDesc = ARROW (ty1,ty2), level} => + | {TypeDesc = ARROW (ty1,ty2), level} => level := Int.min (correct_levels_Type ty1, correct_levels_Type ty2) - | {TypeDesc = RECTYPE r, level} => + | {TypeDesc = RECTYPE r, level} => level := correct_levels_RecType r - | {TypeDesc = CONSTYPE (tys,tyname), level} => + | {TypeDesc = CONSTYPE (tys,tyname), level} => level := foldl Int.min Level.NONGENERIC (map correct_levels_Type tys) ; !(#level ty) end and correct_levels_RecType r = - let val r = findRecType r - in case r + let val r = findRecType r + in case r of NILrec => Level.NONGENERIC | VARrec _ => Level.NONGENERIC | ROWrec (l,ty,r') => Int.min (correct_levels_Type ty, correct_levels_RecType r') @@ -1759,10 +1820,10 @@ structure StatObject: STATOBJECT = local exception Inverse in fun inverse Realisation_Id = SOME Realisation_Id - | inverse (Not_Id m) = - (SOME(Not_Id(TyName.Map.Fold(fn ((t, theta), acc) => + | inverse (Not_Id m) = + (SOME(Not_Id(TyName.Map.Fold(fn ((t, theta), acc) => case theta - of TYNAME t' => + of TYNAME t' => if TyName.Set.member t' (TyName.Set.fromList(TyName.Map.dom acc)) then raise Inverse else TyName.Map.add(t', TYNAME t, acc) | EXPANDED theta' => raise Inverse) TyName.Map.empty m)) @@ -1786,9 +1847,9 @@ structure StatObject: STATOBJECT = | on_TyName' (Not_Id m) t = (case TyName.Map.lookup m t of SOME theta => theta | NONE => TYNAME t) - + fun on_Type Realisation_Id ty = ty - | on_Type phi ty = + | on_Type phi ty = (* NB: keep levels, so that it works for type schemes and type functions as well *) (case findType ty of {TypeDesc = TYVAR _, level} => ty @@ -1804,7 +1865,7 @@ structure StatObject: STATOBJECT = functions for type names*) let val theta = on_TyName' phi t - fun TypeFcn_apply' (TYNAME t', tau_list) = + fun TypeFcn_apply' (TYNAME t', tau_list) = {TypeDesc = CONSTYPE (tau_list,t'), level = ref (!level)} | TypeFcn_apply' (EXPANDED theta, tau_list) = @@ -1820,21 +1881,21 @@ structure StatObject: STATOBJECT = fun on_TypeScheme Realisation_Id scheme = scheme | on_TypeScheme phi (sigma as (tyvars,tau)) = if List.exists TyVar.is_overloaded tyvars then sigma (* type schemes for overloaded identifiers are rigid *) - else + else let val tau = on_Type phi tau (* (* eliminate bound tyvars that are not in tau *) val tvs = Type.generic_tyvars tau - val tyvars = foldr (fn (tv,acc) => if List.exists (fn t => t = tv) tvs then tv::acc else acc) nil tyvars + val tyvars = foldr (fn (tv,acc) => if List.exists (fn t => t = tv) tvs then tv::acc else acc) nil tyvars *) in (tyvars,tau) end - + fun on_TypeFcn Realisation_Id theta = theta | on_TypeFcn phi (theta as TYPEFCN {tyvars, tau}) = - TYPEFCN{tyvars=tyvars,tau=on_Type phi tau} (* NOTE: arity of theta should be preserved, which differ + TYPEFCN{tyvars=tyvars,tau=on_Type phi tau} (* NOTE: arity of theta should be preserved, which differ * from the case for type schemes ; mael-2007-11-07 *) -(* +(* let val (tyvars,tau) = on_TypeScheme phi (tyvars,tau) in TYPEFCN{tyvars=tyvars,tau=tau} end @@ -1857,18 +1918,18 @@ structure StatObject: STATOBJECT = fun (Realisation_Id : realisation) oo (phi : realisation) : realisation = phi | phi oo Realisation_Id = phi - | (phi1 as Not_Id m1) oo phi2 = + | (phi1 as Not_Id m1) oo phi2 = case on_Realisation phi1 phi2 of Realisation_Id => phi1 - | Not_Id m2 => + | Not_Id m2 => let (* fun member t nil = false | member t0 (t::ts) = TyName.eq (t0,t) orelse member t0 ts val d1 = TyName.Map.dom m1 fun loop nil = () - | loop (t::ts) = - if member t d1 then + | loop (t::ts) = + if member t d1 then (PP.printTree(layout phi1); PP.printTree(layout phi2) ;die ("realisation map overlay: " ^ TyName.pr_TyName t)) @@ -1879,17 +1940,17 @@ structure StatObject: STATOBJECT = end fun enrich (rea0, (rea,T)) = - TyName.Set.fold (fn t => fn acc => acc andalso + TyName.Set.fold (fn t => fn acc => acc andalso TypeFcn.eq(on_TyName rea0 t, on_TyName rea t)) true T fun eq (Realisation_Id, Realisation_Id) = true (* conservative check, thus eq is a bad word for it; * - better now ; mael 2004-04-06 *) - | eq (rea1,rea2) = + | eq (rea1,rea2) = let val T = TyName.Set.union (dom rea1) (dom rea2) in enrich (rea1,(rea2,T)) end (* - | eq (rea1,rea2) = + | eq (rea1,rea2) = let val T = dom rea1 in TyName.Set.eq T (dom rea2) andalso enrich (rea1,(rea2,T)) end @@ -1912,7 +1973,7 @@ structure StatObject: STATOBJECT = TypeFcn.pu in Pickle.dataGen("StatObject.TypeFcn'",toInt,[fun_TYNAME,fun_EXPANDED]) end - val pu = + val pu = let fun to (SOME e) = Not_Id e | to NONE = Realisation_Id fun from (Not_Id e) = SOME e @@ -1920,7 +1981,7 @@ structure StatObject: STATOBJECT = in Pickle.convert (to,from) (Pickle.optionGen(TyName.Map.pu TyName.pu pu_TypeFcn')) end - + end (*Realisation*) (* @@ -1934,13 +1995,13 @@ structure StatObject: STATOBJECT = val tau1 = Type.from_pair(a_type,a'_type) val sigma1 = (Type.generalise {ov=false, imp=true, tau=tau1}; (Type.generic_tyvars tau1,tau1)) - val sigma2 = + val sigma2 = let val tv = ref (NO_TY_LINK {id= 1, equality = false, rank=dummy_rank_ref, overloaded = NONE, explicit=NONE, inst=ref NONE}) val ty = {TypeDesc = TYVAR tv, level = ref Level.GENERIC} val ty' = {TypeDesc = TYVAR tv, level = ref Level.GENERIC} - val r = {TypeDesc = + val r = {TypeDesc = RECTYPE (Type.RecType.add_field (ONE, ty) (Type.RecType.add_field (TWO, ty') Type.RecType.empty)), @@ -1949,27 +2010,27 @@ structure StatObject: STATOBJECT = (Type.generic_tyvars r, r) end - val _ = + val _ = print(if TypeScheme.eq(sigma1,sigma2) then "***GENERALISE test succeeded***\n" else "***GENERALISE test failed***\n") val tau3 = TypeScheme.instance sigma1 - val ty = Type.Int + val ty = Type.Int and ty' = Type.fresh_normal () - val tau4 = + val tau4 = Type.from_RecType (Type.RecType.add_field (ONE, ty) (Type.RecType.add_field (TWO, ty') Type.RecType.empty)) val _ = Type.unify (tau3,tau4) in - val _ = + val _ = print(if Type.eq(ty',Type.Int) then "***INSTANCE UNIFY test succeeded***\n" else "***INSTANCE UNIFY test failed***\n") end (* Test stuff *) local - val a = TyVar.from_ExplicitTyVar(ExplicitTyVar.mk_TyVar "'a") + val a = TyVar.from_ExplicitTyVar(ExplicitTyVar.mk_TyVar "'a") and a' = TyVar.fresh_normal() val _ = Level.push () @@ -1982,13 +2043,13 @@ structure StatObject: STATOBJECT = val tau1 = Type.from_pair(a_type,a'_type) val sigma1 = (Type.generalise {ov=false, imp=true, tau=tau1}; (Type.generic_tyvars tau1, tau1)) - val sigma2 = + val sigma2 = let val tv = ref (NO_TY_LINK({id= 1, equality = false, rank=dummy_rank_ref, overloaded = NONE, explicit=NONE, inst = ref NONE})) val ty = {TypeDesc = TYVAR tv, level = ref Level.GENERIC} val ty' = {TypeDesc = TYVAR tv, level = ref Level.GENERIC} - val r = {TypeDesc = + val r = {TypeDesc = RECTYPE (Type.RecType.add_field (ONE, ty) (Type.RecType.add_field (TWO, ty') Type.RecType.empty)), @@ -2005,7 +2066,7 @@ structure StatObject: STATOBJECT = (* Test stuff *) local - val a = TyVar.from_ExplicitTyVar(ExplicitTyVar.mk_TyVar "'a") + val a = TyVar.from_ExplicitTyVar(ExplicitTyVar.mk_TyVar "'a") and b = TyVar.from_ExplicitTyVar(ExplicitTyVar.mk_TyVar "'b") val _ = Level.push () val a_type = Type.from_TyVar a @@ -2030,7 +2091,7 @@ structure StatObject: STATOBJECT = (* Test stuff *) local - val a = TyVar.from_ExplicitTyVar(ExplicitTyVar.mk_TyVar "'a") + val a = TyVar.from_ExplicitTyVar(ExplicitTyVar.mk_TyVar "'a") and b = TyVar.from_ExplicitTyVar(ExplicitTyVar.mk_TyVar "'_b") val _ = Level.push () val a_type = Type.from_TyVar a @@ -2078,7 +2139,6 @@ structure StatObject: STATOBJECT = val _ = print ("instantiation = " ^ Type.string inst ^ "\n") in end -*) +*) end (*StatObject*) - diff --git a/src/Common/ElabDec.sml b/src/Common/ElabDec.sml index b287dde99..0feda93a4 100644 --- a/src/Common/ElabDec.sml +++ b/src/Common/ElabDec.sml @@ -72,6 +72,7 @@ structure ElabDec: ELABDEC = type ElabInfo = ElabInfo.ElabInfo type TyName = TyName.TyName + val values_64bit = Flags.is_on0 "values_64bit" (*info*) @@ -1899,6 +1900,13 @@ let (Type.Word8, OverloadingInfo.RESOLVED_WORD8), (Type.Word31, OverloadingInfo.RESOLVED_WORD31), (Type.Word32, OverloadingInfo.RESOLVED_WORD32)] + @ + (if values_64bit() then + [(Type.Int63, OverloadingInfo.RESOLVED_INT63), + (Type.Int64, OverloadingInfo.RESOLVED_INT64), + (Type.Word63, OverloadingInfo.RESOLVED_WORD63), + (Type.Word64, OverloadingInfo.RESOLVED_WORD64)] + else []) fun tau_to_overloadinginfo tau = case List.find (fn (tau', oi) => Type.eq (tau, tau')) tau_to_overloadinginfo_alist diff --git a/src/Common/Flags.sml b/src/Common/Flags.sml index 1ef62724b..1dc682650 100644 --- a/src/Common/Flags.sml +++ b/src/Common/Flags.sml @@ -15,8 +15,8 @@ structure Flags: FLAGS = (a) declare a new boolean reference, r (b) add r to the menu (with a menu text) at an appropriate place - (c) add r to the `Adding initial entries' section below, together with - a search key (a string), which can be used by the modules that + (c) add r to the `Adding initial entries' section below, together with + a search key (a string), which can be used by the modules that want to access the flag. (d) recompile this functor and the functor which uses the new flag @@ -24,13 +24,13 @@ structure Flags: FLAGS = fun has_sml_source_ext (s: string) :bool = - case s of + case s of "sml" => true | "sig" => true | _ => false val install_dir = ref "You_did_not_set_path_to_install_dir" - + (* Pretty Printing *) val raggedRight = PrettyPrint.raggedRight @@ -96,7 +96,7 @@ structure Flags: FLAGS = fun warn report = warnings := report :: !warnings val warn_string = warn o Report.line - fun report_warnings () = + fun report_warnings () = (case !warnings of [] => () | reports => @@ -114,7 +114,7 @@ structure Flags: FLAGS = (* ----------------------------------- - * Parse functions + * Parse functions * ----------------------------------- *) type ('a, 'b) reader = ('a, 'b) StringCvt.reader @@ -133,7 +133,7 @@ structure Flags: FLAGS = fun getc [] = NONE | getc (c::cs) = SOME(c,cs) - + (**************************************************) (* structure Directory *) (* *) @@ -142,30 +142,30 @@ structure Flags: FLAGS = (* etc. Also, readScript is here. *) (**************************************************) - type bentry = {long: string, (* long option for use with mlkit command + type bentry = {long: string, (* long option for use with mlkit command * using `--', script files, and internally - * in the mlkit to lookup the current setting + * in the mlkit to lookup the current setting * during execution. *) short: string option, (* short option used in commands with - *) menu: string list, (* entry::path; nil means no-show*) item: bool ref, (* the actual flag *) - neg: bool, (* should negated flags be introduced? + neg: bool, (* should negated flags be introduced? * -no_opt, --no_optimiser *) - desc: string} (* description string; format manually + desc: string} (* description string; format manually * with new-lines *) - type baentry = {long: string, (* long option for use with mlkit command + type baentry = {long: string, (* long option for use with mlkit command * using `--', script files, and internally - * in the mlkit to lookup the current setting + * in the mlkit to lookup the current setting * during execution. *) short: string option, (* short option used in commands with - *) menu: string list, (* entry::path; nil means no-show*) item: bool ref, (* the actual flag *) on: unit->unit, (* function to apply to turn entry on *) off: unit->unit, (* function to apply to turn entry off; - * a toggling function can be made from + * a toggling function can be made from * these two and the item. *) - desc: string} (* description string; format manually + desc: string} (* description string; format manually * with new-lines *) type 'a entry = {long: string, @@ -182,8 +182,8 @@ structure Directory : sig val int_entry : int entry -> (unit -> int) val bool_action_entry : baentry -> unit - val is_on : string -> bool - val is_on0 : string -> unit -> bool + val is_on : string -> bool + val is_on0 : string -> unit -> bool val turn_on : string -> unit val turn_off : string -> unit val add_string_entry : string * string ref -> (unit -> string) @@ -208,14 +208,14 @@ structure Directory : sig (* help_all() provides help on all options in the directory *) val help_all : unit -> string - val getOptions : unit -> + val getOptions : unit -> {desc : string, long : string list, short : string list, kind : string option, default : string option} list end = struct - datatype entry0 = INT_ENTRY of int entry + datatype entry0 = INT_ENTRY of int entry | BOOL_ENTRY of bentry | BOOLA_ENTRY of baentry (* action entry *) | STRING_ENTRY of string entry @@ -228,10 +228,10 @@ struct val dir : entry0 M.map ref = ref M.empty fun bool_entry (e:bentry) : unit -> bool = - case M.lookup (!dir) (#long e) + case M.lookup (!dir) (#long e) of SOME _ => die ("bool_entry: entry " ^ (#long e) ^ " already in directory") | NONE => (dir := M.add(#long e, BOOL_ENTRY e, - case #short e of + case #short e of SOME s => M.add(s, BOOL_ENTRY e, !dir) | NONE => !dir); let val r = #item e @@ -239,7 +239,7 @@ struct end) fun bool_action_entry (e:baentry) : unit = - case M.lookup (!dir) (#long e) + case M.lookup (!dir) (#long e) of SOME _ => die ("bool_action_entry: entry " ^ (#long e) ^ " already in directory") | NONE => dir := M.add(#long e, BOOLA_ENTRY e, case #short e @@ -247,10 +247,10 @@ struct | NONE => !dir) fun string_entry (e:string entry) : unit -> string = - case M.lookup (!dir) (#long e) + case M.lookup (!dir) (#long e) of SOME _ => die ("string_entry: entry " ^ (#long e) ^ " already in directory") | NONE => (dir := M.add(#long e, STRING_ENTRY e, - case #short e of + case #short e of SOME s => M.add(s, STRING_ENTRY e, !dir) | NONE => !dir); let val r = #item e @@ -258,10 +258,10 @@ struct end) fun stringlist_entry (e:string list entry) : unit -> string list = - case M.lookup (!dir) (#long e) + case M.lookup (!dir) (#long e) of SOME _ => die ("stringlist_entry: entry " ^ (#long e) ^ " already in directory") | NONE => (dir := M.add(#long e, STRINGLIST_ENTRY e, - case #short e of + case #short e of SOME s => M.add(s, STRINGLIST_ENTRY e, !dir) | NONE => !dir); let val r = #item e @@ -269,10 +269,10 @@ struct end) fun int_entry (e:int entry) : unit -> int = - case M.lookup (!dir) (#long e) + case M.lookup (!dir) (#long e) of SOME _ => die ("int_entry: entry " ^ (#long e) ^ " already in directory") - | NONE => (dir := M.add(#long e, INT_ENTRY e, - case #short e of + | NONE => (dir := M.add(#long e, INT_ENTRY e, + case #short e of SOME s => M.add(s, INT_ENTRY e, !dir) | NONE => !dir); let val r = #item e @@ -307,7 +307,7 @@ struct val get_stringlist_entry = ! o lookup_stringlist_entry - fun is_on0 (key: string) : unit -> bool = + fun is_on0 (key: string) : unit -> bool = case M.lookup (!dir) key of SOME (BOOL_ENTRY {item,...}) => (fn () => !item) | SOME (BOOLA_ENTRY {item,...}) => (fn () => !item) @@ -316,31 +316,31 @@ struct fun is_on k = is_on0 k () - fun turn_on (key: string) : unit = + fun turn_on (key: string) : unit = case M.lookup (!dir) key of SOME (BOOL_ENTRY e) => #item e := true | SOME (BOOLA_ENTRY e) => #on e () | SOME _ => raise Fail ("option " ^ key ^ " is of wrong kind") | NONE => raise Fail ("invalid option: " ^ key) - fun turn_off (key: string) : unit = + fun turn_off (key: string) : unit = case M.lookup (!dir) key of SOME (BOOL_ENTRY e) => #item e := false | SOME (BOOLA_ENTRY e) => #off e () | SOME _ => die ("turn_off: entry " ^ key ^ " is of wrong kind") | NONE => die ("turn_off: no entry " ^ key ^ " in directory") - fun add_string_entry (long, item) = - string_entry {long=long, short=NONE, desc="", item=item, menu=nil} + fun add_string_entry (long, item) = + string_entry {long=long, short=NONE, desc="", item=item, menu=nil} - fun add_stringlist_entry (long, item) = - stringlist_entry {long=long, short=NONE, desc="", item=item, menu=nil} + fun add_stringlist_entry (long, item) = + stringlist_entry {long=long, short=NONE, desc="", item=item, menu=nil} - fun add_int_entry (long, item) = - int_entry {long=long, short=NONE, desc="", item=item, menu=nil} + fun add_int_entry (long, item) = + int_entry {long=long, short=NONE, desc="", item=item, menu=nil} - fun add_bool_entry (long, item) = - bool_entry {long=long, short=NONE, desc="", item=item, menu=nil, neg=false} + fun add_bool_entry (long, item) = + bool_entry {long=long, short=NONE, desc="", item=item, menu=nil, neg=false} fun lookup_notnull_menu dir key = let fun ok (BOOL_ENTRY{menu=nil,...}) = false @@ -377,58 +377,58 @@ struct fun read_options {nullary:(string*(unit->unit))list, unary:(string*(string->unit))list, options: string list} : string list = - let + let fun loop nil = nil | loop (all as s::ss) = case opt s - of SOME key => + of SOME key => (case negation key of SOME no_key => (case lookup_notnull_menu (!dir) no_key - of SOME (BOOL_ENTRY e) => + of SOME (BOOL_ENTRY e) => if #neg e then (#item e := false; loop ss) else raise Fail ("negation not allowed on option: " ^ no_key) | SOME (BOOLA_ENTRY e) => (#off e (); loop ss) | SOME _ => raise Fail ("negation not allowed on option: " ^ no_key) | NONE => raise Fail ("unknown option: " ^ s)) - | NONE => + | NONE => (case lookup_notnull_menu (!dir) key of SOME (BOOL_ENTRY e) => (#item e := true; loop ss) | SOME (BOOLA_ENTRY e) => (#on e (); loop ss) - | SOME (STRING_ENTRY e) => + | SOME (STRING_ENTRY e) => (case ss of s::ss => (#item e := s; loop ss) | _ => raise Fail ("missing argument to " ^ s)) - | SOME (STRINGLIST_ENTRY e) => + | SOME (STRINGLIST_ENTRY e) => let fun is_opt s = (String.sub(s,0) = #"-") handle _ => false - fun readToOpt (all as [s],acc) = + fun readToOpt (all as [s],acc) = if is_opt s then (rev acc, all) else (case OS.Path.ext s of SOME ext => if has_sml_source_ext ext then (rev acc, all) else (rev (s::acc),nil) | _ => (rev (s::acc),nil)) - | readToOpt (all as s::ss,acc) = + | readToOpt (all as s::ss,acc) = if is_opt s then (rev acc,all) else readToOpt(ss,s::acc) | readToOpt (nil,acc) = (rev acc,nil) val (args,rest) = readToOpt (ss,nil) in (#item e := args; loop rest) end - | SOME (INT_ENTRY e) => + | SOME (INT_ENTRY e) => (case ss - of s::ss => + of s::ss => (case Int.fromString s of SOME i => (#item e := i; loop ss) | NONE => raise Fail ("expecting integer argument to " ^ s)) | _ => raise Fail ("missing argument to " ^ s)) - | NONE => - let + | NONE => + let fun try_nullary exn = case lookup_key key nullary of SOME f => (f(); loop ss) | NONE => raise exn in case lookup_key key unary - of SOME f => + of SOME f => (case ss of s::ss => (f s; loop ss) | nil => try_nullary (Fail("missing argument to " ^ s))) @@ -442,7 +442,7 @@ struct (* help key provides help information for the key *) fun help' (key: string) = - let + let fun optToList NONE = [] | optToList (SOME a) = [a] @@ -454,29 +454,29 @@ struct fun negationNew (e:bentry, kind) = if not(#neg e) then [] else [{long = ["no_" ^ (#long e)], short = map (fn x => "no_" ^ x) (optToList (#short e)), - kind = kind, default = NONE, desc = "Opposite of --" ^ #long e ^ opt(#short e) ^ "."}] - + kind = kind, default = NONE, desc = "Opposite of --" ^ #long e ^ opt(#short e) ^ "."}] + fun negationNew' (e:baentry, kind) = [{long = ["no_" ^ (#long e)], short = map (fn x => "no_" ^ x) (optToList (#short e)), - kind = kind, default = NONE, desc = "Opposite of --" ^ #long e ^ opt(#short e) ^ "."}] + kind = kind, default = NONE, desc = "Opposite of --" ^ #long e ^ opt(#short e) ^ "."}] in - (case lookup_notnull_menu (!dir) key + (case lookup_notnull_menu (!dir) key of SOME (BOOL_ENTRY e) => - {long = [#long e], short = optToList (#short e), kind = NONE, + {long = [#long e], short = optToList (#short e), kind = NONE, default = SOME (bitem (!(#item e))), desc = #desc e} :: (negationNew (e,NONE)) - | SOME (BOOLA_ENTRY e) => + | SOME (BOOLA_ENTRY e) => {long = [#long e], short = optToList (#short e), default = SOME (bitem (!(#item e))), desc = #desc e, kind = NONE} :: negationNew' (e,NONE) - | SOME (STRING_ENTRY e) => + | SOME (STRING_ENTRY e) => {long = [#long e], short = optToList (#short e), default = let val a = (String.toString(!(#item e))) in if a = "" then NONE else SOME a end, desc = #desc e, kind = SOME "S"} :: [] - | SOME (STRINGLIST_ENTRY e) => + | SOME (STRINGLIST_ENTRY e) => {long = [#long e], short = optToList (#short e), default = NONE, desc = #desc e, kind = SOME "S"} :: [] | SOME (INT_ENTRY e) => @@ -488,7 +488,7 @@ struct fun print_help tail x = let val width = 60 - fun indent s = + fun indent s = map (fn s => " " ^ s ^ "\n") (String.tokens (fn c => c = #"\n") s) fun addBetween _ [] = [] @@ -498,12 +498,12 @@ struct fun pkind NONE = "" | pkind (SOME k) = " " ^ k - fun p {long,short,kind,default,desc} = + fun p {long,short,kind,default,desc} = let val name = String.concat ( - (addBetween ", " + (addBetween ", " (List.map (fn x => "--" ^ x ^ (pkind kind)) long)) @ - (List.map (fn x => ", -" ^ x ^ (pkind kind)) short) @ [" "]) + (List.map (fn x => ", -" ^ x ^ (pkind kind)) short) @ [" "]) val firstline = case default of NONE => name ^ "\n" | SOME default => StringCvt.padRight #" " (width - (String.size default)) name ^ "(" ^ default ^ ")\n" @@ -514,7 +514,7 @@ struct end fun help x = print_help "" (help' x) - + (* help_all() provides help on all options in the directory *) fun help_all' () = let val dom = rev(M.dom (!dir)) @@ -536,11 +536,11 @@ struct fun cmp c ([],[]) = EQUAL | cmp c ([],_) = LESS | cmp c (_,[]) = GREATER - | cmp c (x::xs,y::ys) = case c (x,y) + | cmp c (x::xs,y::ys) = case c (x,y) of EQUAL => cmp c (xs,ys) | GREATER => GREATER | LESS => LESS - in Listsort.sort + in Listsort.sort (fn ({long = l1,...},{long = l2,...}) => cmp String.compare (l1,l2)) (foldl add [] dom) end @@ -552,27 +552,27 @@ end (* Directory *) (**structure Menu = Menu(val help_topic = Directory.help)**) -fun add_bool_entry e = +fun add_bool_entry e = case #menu e of nil => Directory.bool_entry e | path => ((**Menu.add_flag_to_menu(#long e, path, #item e); **) Directory.bool_entry e) -fun add_string_entry e = +fun add_string_entry e = case #menu e - of nil => Directory.string_entry e + of nil => Directory.string_entry e | path => ((**Menu.add_string_to_menu(#long e, path, #item e);**) Directory.string_entry e) -fun add_stringlist_entry e = - case #menu e of - nil => Directory.stringlist_entry e +fun add_stringlist_entry e = + case #menu e of + nil => Directory.stringlist_entry e | path => ( (* Menu.add_string_to_menu(#long e, path, #item e); *) Directory.stringlist_entry e) -fun add_int_entry e = +fun add_int_entry e = case #menu e - of nil => Directory.int_entry e + of nil => Directory.int_entry e | path => ((**Menu.add_int_to_menu(#long e, path, #item e);**) Directory.int_entry e) @@ -599,12 +599,12 @@ fun add_bool_action_entry e = (*1. Printing of intermediate forms*) local - fun add (l, sh, s, r, desc) : unit = + fun add (l, sh, s, r, desc) : unit = (add_bool_entry {long=l, short=sh, menu=["Printing of intermediate forms",s], - item=r, neg=false, desc=desc}; + item=r, neg=false, desc=desc}; ()) in - val _ = add ("print_opt_lambda_expression", SOME "Pole", "print optimised lambda expression", + val _ = add ("print_opt_lambda_expression", SOME "Pole", "print optimised lambda expression", print_opt_lambda_expression, "Print Lambda Expression after optimisation.") end @@ -627,16 +627,16 @@ in \expressions and types.") end -val _ = add_int_entry {long="width",short=SOME "w", menu=["Layout", "text width in pretty-printing"], +val _ = add_int_entry {long="width",short=SOME "w", menu=["Layout", "text width in pretty-printing"], item=colwidth, desc="Column width used when pretty printing intermediate code."} (*3. Control*) val recompile_basislib = ref false -val _ = add_bool_entry {long="recompile_basislib",short=SOME "scratch", +val _ = add_bool_entry {long="recompile_basislib",short=SOME "scratch", menu=["Control", "recompile basis library"], - item=recompile_basislib,neg=false, + item=recompile_basislib,neg=false, desc= "Recompile basis library from scratch. This option\n\ \is useful together with other options that control\n\ @@ -672,31 +672,37 @@ val _ = add_bool_entry {long="tag_values", short=SOME"tag", item=tag_values, val _ = add_bool_entry {long="tag_pairs", short=NONE, item=ref false, menu=["Control", "tag pairs"], neg=false, desc= - "Use a tagged representation of pairs for garbage\n\ + "Use a tagged representation of pairs for garbage\n\ \collection. Garbage collection works fine with a\n\ \tag-free representation of pairs, so this option\n\ \is here for measurement purposes."} +val _ = add_bool_entry {long="values_64bit", short=NONE, item=ref true, + menu=["Control", "values 64bit"], neg=false, + desc= + "Support 64-bit values. Should be enabled for \n\ + \backends supporting 64-bit integers and words."} + local val gc = ref false val gengc = ref false - fun off() = (gc := false; + fun off() = (gc := false; preserve_tail_calls := false; dangling_pointers := true; Directory.turn_off "aggresive_opt"; - tag_values := false) - fun on() = (gc := true; - preserve_tail_calls := true; + tag_values := false) + fun on() = (gc := true; + preserve_tail_calls := true; dangling_pointers := false; Directory.turn_on "aggresive_opt"; - tag_values := true) + tag_values := true) fun off_gengc() = (off(); (* We also turn gc off *) gengc := false) fun on_gengc() = (on(); (* Gen GC needs gc to be turned on as well *) - gengc := true) + gengc := true) in val _ = add_bool_action_entry - {long="garbage_collection", menu=["Control", "garbage collection"], + {long="garbage_collection", menu=["Control", "garbage collection"], item=gc, on=on, off=off, short=SOME "gc", desc="Enable garbage collection. When enabled, regions are\n\ \garbage collected during execution of the program. When\n\ @@ -710,7 +716,7 @@ in \collection implicitly enables the preservation of tail\n\ \calls (see the option ``preserve_tail_calls''.)"} val _ = add_bool_action_entry - {long="generational_garbage_collection", menu=["Control", "generational garbage collection"], + {long="generational_garbage_collection", menu=["Control", "generational garbage collection"], item=gengc, on=on_gengc, off=off_gengc, short=SOME "gengc", desc="Enable generational garbage collection. Same as option\n\ \garbage collection except that two generations are used\n\ @@ -724,7 +730,7 @@ in val _ = app (add false) [ (* - ("all_multiplicities_infinite", NONE, "all multiplicities infinite (for POPL 96)", + ("all_multiplicities_infinite", NONE, "all multiplicities infinite (for POPL 96)", all_multiplicities_infinite, "Use only infinite regions. That is, store all values in\n\ \infinite regions, which do not reside on the stack, but\n\ @@ -774,12 +780,12 @@ val _ = app (fn (s, f) => Menu.add_action_to_menu ("", ["Control", s], f)) (*4. File menu*) -val _ = add_bool_entry - {long="log_to_file", short=NONE, menu=["File", "Log to file"], +val _ = add_bool_entry + {long="log_to_file", short=NONE, menu=["File", "Log to file"], neg=false, item=log_to_file, desc="Log to files instead of stdout."} -val _ = add_string_entry - {long="SML_LIB", short=NONE, menu=["File", "installation directory"], +val _ = add_string_entry + {long="SML_LIB", short=NONE, menu=["File", "installation directory"], item=install_dir, desc= "Installation directory for the MLKit standard library. For normal\n\ @@ -826,7 +832,7 @@ local fun add p n (l,sh,s,r,d) : unit = (add_bool_entry {long=l, short=sh, menu=p @[s], item=r, neg=n, desc=d}; ()) in - val _ = app (add ["Debug", "Lambda"] true) + val _ = app (add ["Debug", "Lambda"] true) [ ("type_check_lambda", NONE, "type check lambda expressions", type_check_lambda, "Type check lambda expression prior to performing region\n\ @@ -836,7 +842,7 @@ in \in the compiler.") ] - val _ = app (add ["Debug", "Manager"] false) + val _ = app (add ["Debug", "Manager"] false) [ ("debug_linking", NONE, "debug_linking", ref false, "Debug linking of target code by showing which object\n\ @@ -849,7 +855,7 @@ in \for which the program unit depends upon has changed.") ] - val _ = app (add ["Debug"] false) + val _ = app (add ["Debug"] false) [ ("chat", SOME "verbose", "chat", chat, "Print a message for each compilation step in the compiler."), @@ -868,8 +874,8 @@ end val _ = add_bool_entry0 ("enhanced_atbot_analysis", enhanced_atbot_analysis) val _ = add_bool_entry0 ("eliminate_polymorphic_equality", eliminate_polymorphic_equality) - val _ = add_bool_entry - {long="compile_only", short=SOME "c", + val _ = add_bool_entry + {long="compile_only", short=SOME "c", menu=["Control","compile only"], item=ref false, neg=false, desc= "Compile only. Suppresses generation of executable"} @@ -888,18 +894,18 @@ val read_options = Directory.read_options val help = Directory.help val help_all = Directory.help_all type options = {desc : string, long : string list, short : string list, - kind : string option, default : string option} + kind : string option, default : string option} val getOptions = Directory.getOptions : unit -> options list val SMLserver = ref false -datatype compiler_mode = +datatype compiler_mode = LINK_MODE of string list (* lnk-files *) | LOAD_BASES of string list (* eb-files to be loaded; nil if normal *) - + val compiler_mode : compiler_mode ref = ref (LOAD_BASES nil) - -structure Statistics = + +structure Statistics = struct val no_dangling_pointers_changes = ref 0 val no_dangling_pointers_changes_total = ref 0 @@ -907,9 +913,9 @@ structure Statistics = no_dangling_pointers_changes_total := 0) end -end (* functor Flags *) - - +end (* functor Flags *) + + structure profRegInf = struct diff --git a/src/Common/OVERLOADING_INFO.sml b/src/Common/OVERLOADING_INFO.sml index b4c48dca2..523d56fd2 100644 --- a/src/Common/OVERLOADING_INFO.sml +++ b/src/Common/OVERLOADING_INFO.sml @@ -12,6 +12,8 @@ signature OVERLOADING_INFO = | UNRESOLVED_DOTDOTDOT of RecType | RESOLVED_INT31 | RESOLVED_INT32 + | RESOLVED_INT63 + | RESOLVED_INT64 | RESOLVED_INTINF | RESOLVED_REAL | RESOLVED_STRING @@ -19,6 +21,8 @@ signature OVERLOADING_INFO = | RESOLVED_WORD8 | RESOLVED_WORD31 | RESOLVED_WORD32 + | RESOLVED_WORD63 + | RESOLVED_WORD64 val resolvedWordDefault : unit -> OverloadingInfo val resolvedIntDefault : unit -> OverloadingInfo diff --git a/src/Common/OverloadingInfo.sml b/src/Common/OverloadingInfo.sml index 7fcd5f790..182ac5484 100644 --- a/src/Common/OverloadingInfo.sml +++ b/src/Common/OverloadingInfo.sml @@ -11,28 +11,41 @@ structure OverloadingInfo: OVERLOADING_INFO = | UNRESOLVED_DOTDOTDOT of RecType | RESOLVED_INT31 | RESOLVED_INT32 + | RESOLVED_INT63 + | RESOLVED_INT64 | RESOLVED_INTINF - | RESOLVED_REAL + | RESOLVED_REAL | RESOLVED_STRING | RESOLVED_CHAR | RESOLVED_WORD8 | RESOLVED_WORD31 | RESOLVED_WORD32 + | RESOLVED_WORD63 + | RESOLVED_WORD64 + val values_64bit = Flags.is_on0 "values_64bit" val tag_values = Flags.is_on0 "tag_values" - fun resolvedIntDefault () = - if tag_values() then RESOLVED_INT31 - else RESOLVED_INT32 + fun resolvedIntDefault () = + case (tag_values(), values_64bit()) of + (true, true) => RESOLVED_INT63 + | (false, true) => RESOLVED_INT64 + | (true, false) => RESOLVED_INT31 + | (false, false) => RESOLVED_INT32 - fun resolvedWordDefault () = - if tag_values() then RESOLVED_WORD31 - else RESOLVED_WORD32 + fun resolvedWordDefault () = + case (tag_values(), values_64bit()) of + (true, true) => RESOLVED_WORD63 + | (false, true) => RESOLVED_WORD64 + | (true, false) => RESOLVED_WORD31 + | (false, false) => RESOLVED_WORD32 fun string (UNRESOLVED_IDENT tyvars) = "UNRESOLVED_IDENT" | string (UNRESOLVED_DOTDOTDOT tau) = "UNRESOLVED_DOTDOTDOT" | string RESOLVED_INT31 = "RESOLVED_INT31" | string RESOLVED_INT32 = "RESOLVED_INT32" + | string RESOLVED_INT63 = "RESOLVED_INT63" + | string RESOLVED_INT64 = "RESOLVED_INT64" | string RESOLVED_INTINF = "RESOLVED_INTINF" | string RESOLVED_REAL = "RESOLVED_REAL" | string RESOLVED_STRING = "RESOLVED_STRING" @@ -40,6 +53,8 @@ structure OverloadingInfo: OVERLOADING_INFO = | string RESOLVED_WORD8 = "RESOLVED_WORD8" | string RESOLVED_WORD31 = "RESOLVED_WORD31" | string RESOLVED_WORD32 = "RESOLVED_WORD32" + | string RESOLVED_WORD63 = "RESOLVED_WORD63" + | string RESOLVED_WORD64 = "RESOLVED_WORD64" val layout = PrettyPrint.LEAF o string diff --git a/src/Common/SCON.sig b/src/Common/SCON.sig index 729797a19..6a49991eb 100644 --- a/src/Common/SCON.sig +++ b/src/Common/SCON.sig @@ -3,10 +3,10 @@ (* I'd like two views of SCON, one with the datatype hidden, but that seems to cause Poly/ML problems with the local/sharing/open stuff. *) -signature SCON = -sig +signature SCON = +sig datatype scon = INTEGER of IntInf.int - | WORD of Word32.word + | WORD of IntInf.int | STRING of string | CHAR of int | REAL of string diff --git a/src/Common/SCon.sml b/src/Common/SCon.sml index 121019519..be9f2380e 100644 --- a/src/Common/SCon.sml +++ b/src/Common/SCon.sml @@ -4,7 +4,7 @@ structure SCon: SCON = struct datatype scon = INTEGER of IntInf.int | STRING of string | REAL of string - | WORD of Word32.word | CHAR of int + | WORD of IntInf.int | CHAR of int (*INTEGER < STRING < REAL < WORD < CHAR:*) fun ord (INTEGER _) = 0 @@ -20,7 +20,7 @@ struct | lt (scon1, scon2) = ord scon1 < ord scon2 fun pr_scon(INTEGER i) = IntInf.toString i - | pr_scon(WORD i) = Word32.toString i + | pr_scon(WORD i) = "0w" ^ IntInf.toString i | pr_scon(STRING s) = "\"" ^ String.toString s ^ "\"" | pr_scon(CHAR i) = "#\"" ^ str(chr i) ^ "\"" | pr_scon(REAL r) = r @@ -28,8 +28,8 @@ struct fun eq (INTEGER i1, INTEGER i2) = i1 = i2 | eq (WORD w1, WORD w2) = w1 = w2 | eq (STRING s1, STRING s2) = s1 = s2 - | eq (CHAR c1, CHAR c2) = c1 = c2 + | eq (CHAR c1, CHAR c2) = c1 = c2 | eq (REAL r1, REAL r2) = (r1 = r2) | eq _ = false -end; +end diff --git a/src/Common/STATOBJECT.sml b/src/Common/STATOBJECT.sml index 8a661db6c..c67ab01db 100644 --- a/src/Common/STATOBJECT.sml +++ b/src/Common/STATOBJECT.sml @@ -3,11 +3,11 @@ phi in realisation, §5.2, p. 29. Also Level and Substitution.*) signature STATOBJECT = - sig + sig (*types provided by this module:*) type level type TVNames - type TyVar + type TyVar type Type type FunType type ConsType @@ -21,7 +21,7 @@ signature STATOBJECT = type ExplicitTyVar (*the type of type variables explicit in the source*) type TyName = TyName.TyName type StringTree = TyName.Set.StringTree - type lab + type lab type scon type strid @@ -41,11 +41,11 @@ signature STATOBJECT = end (*Association list for the printing of type variables:*) - val newTVNames : unit -> TVNames + val newTVNames : unit -> TVNames structure TyVar : sig - val eq : TyVar * TyVar -> bool + val eq : TyVar * TyVar -> bool val equality : TyVar -> bool val fresh_normal : unit -> TyVar val fresh_overloaded : TyName list -> TyVar @@ -85,7 +85,7 @@ signature STATOBJECT = val from_RecType : RecType -> Type val to_RecType : Type -> RecType option val contains_row_variable : Type -> bool - (*contains_row_variable rho = true iff there exists a + (*contains_row_variable rho = true iff there exists a row variable in the type rho*) structure RecType : sig @@ -122,27 +122,31 @@ signature STATOBJECT = val mk_Ref : Type -> Type (* Special constants *) - val Int31 : Type + val Int31 : Type val Int32 : Type + val Int63 : Type + val Int64 : Type val IntInf : Type - val IntDefault : unit -> Type (* Either Int31 or Int32, - * dependent on tagging; used - * for resolving overloading. *) + val IntDefault : unit -> Type (* Either Int31 or Int32, + * dependent on tagging; used + * for resolving overloading. *) val Real : Type val Bool : Type (* needed for initial TE and VE *) val Word8 : Type val Word31 : Type val Word32 : Type - val WordDefault : unit -> Type (* Either Word31 or Word32, - * dependent on tagging; used + val Word63 : Type + val Word64 : Type + val WordDefault : unit -> Type (* Either Word31 or Word32, + * dependent on tagging; used * for resolving overloading. *) val String : Type val Char : Type - + val of_scon : scon -> {type_scon: Type, overloading : TyVar option} datatype unify_result = UnifyOk (* of Substitution *) - | UnifyFail of string + | UnifyFail of string | UnifyRankError of TyVar * TyName val unify : Type * Type -> unify_result @@ -172,7 +176,7 @@ signature STATOBJECT = * scheme have been instantiated to.*) val instance : TypeScheme -> Type - val instance' : TypeScheme -> Type * Type list + val instance' : TypeScheme -> Type * Type list val generalises_TypeScheme : TypeScheme * TypeScheme -> bool val generalises_Type : TypeScheme * Type -> bool @@ -285,4 +289,3 @@ signature STATOBJECT = end (*Realisation*) end; - diff --git a/src/Common/TYCON.sig b/src/Common/TYCON.sig index ede831ec7..5aaec5f8d 100644 --- a/src/Common/TYCON.sig +++ b/src/Common/TYCON.sig @@ -15,11 +15,15 @@ signature TYCON = val tycon_INT : tycon val tycon_INT31 : tycon val tycon_INT32 : tycon + val tycon_INT63 : tycon + val tycon_INT64 : tycon val tycon_INTINF : tycon val tycon_WORD : tycon val tycon_WORD8 : tycon val tycon_WORD31 : tycon val tycon_WORD32 : tycon + val tycon_WORD63 : tycon + val tycon_WORD64 : tycon val tycon_REAL : tycon val tycon_F64 : tycon (* Internal *) val tycon_STRING : tycon diff --git a/src/Common/TYNAME.sig b/src/Common/TYNAME.sig index d3e403ed5..b58eda38a 100644 --- a/src/Common/TYNAME.sig +++ b/src/Common/TYNAME.sig @@ -62,11 +62,15 @@ signature TYNAME = val tyName_BOOL : TyName val tyName_INT31 : TyName val tyName_INT32 : TyName + val tyName_INT63 : TyName + val tyName_INT64 : TyName val tyName_INTINF : TyName val tyName_IntDefault : unit -> TyName (* int31 or int32 dependent on tagging *) val tyName_WORD8 : TyName val tyName_WORD31 : TyName val tyName_WORD32 : TyName + val tyName_WORD63 : TyName + val tyName_WORD64 : TyName val tyName_WordDefault : unit -> TyName (* word31 or word32 dependent on tagging *) val tyName_REAL : TyName val tyName_F64 : TyName (* Internal unboxed float type *) diff --git a/src/Common/TyCon.sml b/src/Common/TyCon.sml index f93466902..687d46c63 100644 --- a/src/Common/TyCon.sml +++ b/src/Common/TyCon.sml @@ -31,11 +31,15 @@ structure TyCon: TYCON = val tycon_INT = TYCON "int" val tycon_INT31 = TYCON "int31" val tycon_INT32 = TYCON "int32" + val tycon_INT63 = TYCON "int63" + val tycon_INT64 = TYCON "int64" val tycon_INTINF = TYCON "intinf" val tycon_WORD = TYCON "word" val tycon_WORD8 = TYCON "word8" val tycon_WORD31 = TYCON "word31" val tycon_WORD32 = TYCON "word32" + val tycon_WORD63 = TYCON "word63" + val tycon_WORD64 = TYCON "word64" val tycon_REAL = TYCON "real" val tycon_F64 = TYCON "f64" val tycon_STRING = TYCON "string" diff --git a/src/Common/TyName.sml b/src/Common/TyName.sml index 7667838e3..66dc319c8 100644 --- a/src/Common/TyName.sml +++ b/src/Common/TyName.sml @@ -11,6 +11,7 @@ structure TyName :> TYNAME = fun die s = Crash.impossible ("TyName." ^ s) val tag_values = Flags.is_on0 "tag_values" + val values_64bit = Flags.is_on0 "values_64bit" (* Type names are based on names, which may be `matched'. In * particular, if two type names, n1 and n2, are successfully @@ -98,10 +99,14 @@ structure TyName :> TYNAME = val tyName_BOOL = predef true {tycon=TyCon.tycon_BOOL, arity=0, equality=true} val tyName_INT31 = predef true {tycon=TyCon.tycon_INT31, arity=0, equality=true} val tyName_INT32 = predef false{tycon=TyCon.tycon_INT32, arity=0, equality=true} + val tyName_INT63 = predef true {tycon=TyCon.tycon_INT63, arity=0, equality=true} + val tyName_INT64 = predef false{tycon=TyCon.tycon_INT64, arity=0, equality=true} val tyName_INTINF = predef true {tycon=TyCon.tycon_INTINF, arity=0, equality=true} val tyName_WORD8 = predef true {tycon=TyCon.tycon_WORD8, arity=0, equality=true} val tyName_WORD31 = predef true {tycon=TyCon.tycon_WORD31, arity=0, equality=true} val tyName_WORD32 = predef false{tycon=TyCon.tycon_WORD32, arity=0, equality=true} + val tyName_WORD63 = predef true {tycon=TyCon.tycon_WORD63, arity=0, equality=true} + val tyName_WORD64 = predef false{tycon=TyCon.tycon_WORD64, arity=0, equality=true} val tyName_REAL = predef false{tycon=TyCon.tycon_REAL, arity=0, equality=false} val tyName_F64 = predef true {tycon=TyCon.tycon_F64, arity=0, equality=false} val tyName_STRING = predef false{tycon=TyCon.tycon_STRING, arity=0, equality=true} @@ -118,8 +123,19 @@ structure TyName :> TYNAME = val tynamesPredefined = !bucket end - fun tyName_IntDefault() = if tag_values() then tyName_INT31 else tyName_INT32 - fun tyName_WordDefault() = if tag_values() then tyName_WORD31 else tyName_WORD32 + fun tyName_IntDefault () = + case (tag_values(), values_64bit()) of + (true, true) => tyName_INT63 + | (true, false) => tyName_INT31 + | (false, true) => tyName_INT64 + | (false, false) => tyName_INT32 + + fun tyName_WordDefault () = + case (tag_values(), values_64bit()) of + (true, true) => tyName_WORD63 + | (true, false) => tyName_WORD31 + | (false, true) => tyName_WORD64 + | (false, false) => tyName_WORD32 fun pr_TyName (tn: TyName) : string = let val str = TyCon.pr_TyCon (tycon tn) @@ -132,20 +148,26 @@ structure TyName :> TYNAME = end else (if tag_values() then - (if eq(tn, tyName_INT31) then "int" - else if eq(tn, tyName_WORD31) then "word" + (if eq(tn, tyName_INT63) then "int" + else if eq(tn, tyName_WORD63) then "word" else str) else - (if eq(tn, tyName_INT32) then "int" - else if eq(tn, tyName_WORD32) then "word" + (if eq(tn, tyName_INT64) then "int" + else if eq(tn, tyName_WORD64) then "word" else str)) end - fun unboxed_num32 tn = - not(tag_values()) andalso (eq(tn,tyName_INT32) - orelse eq(tn,tyName_WORD32)) + local + fun unboxed_num32 tn = + not(tag_values()) andalso (eq(tn,tyName_INT32) + orelse eq(tn,tyName_WORD32)) - fun unboxed tn = unboxed_num32 tn orelse !(#unboxed tn) + fun unboxed_num64 tn = + not(tag_values()) andalso (eq(tn,tyName_INT64) + orelse eq(tn,tyName_WORD64)) + in + fun unboxed tn = unboxed_num32 tn orelse unboxed_num64 tn orelse !(#unboxed tn) + end fun setUnboxed (tn: TyName) : unit = if unboxed tn then @@ -180,9 +202,9 @@ structure TyName :> TYNAME = type StringTree = PrettyPrint.StringTree val layout = PrettyPrint.LEAF o pr_TyName +(* structure TestMap = struct - (* val _ = print "[test begin]\n" fun error s = print ("error: " ^ s ^ "\n") fun assert s false = error s @@ -225,6 +247,6 @@ structure TyName :> TYNAME = | _ => error "test9" val _ = print "[end of test]\n" -*) end - end; + *) + end diff --git a/src/Compiler/Backend/BackendInfo.sml b/src/Compiler/Backend/BackendInfo.sml index 4099d66a6..a05143f20 100644 --- a/src/Compiler/Backend/BackendInfo.sml +++ b/src/Compiler/Backend/BackendInfo.sml @@ -99,8 +99,8 @@ functor BackendInfo(val down_growing_stack : bool) : BACKEND_INFO = val finiteRegionDescSizeP = 2 (* Number of words in a finite region descriptor when profiling is used. *) val objectDescSizeP = 2 (* Number of words in an object descriptor when profiling is used. *) - fun defaultIntPrecision () = if tag_values() then 31 else 32 - fun defaultWordPrecision () = if tag_values() then 31 else 32 + fun defaultIntPrecision () = if tag_values() then 63 else 64 + fun defaultWordPrecision () = if tag_values() then 63 else 64 val toplevel_region_withtype_top_lab = Labels.reg_top_lab val toplevel_region_withtype_bot_lab = Labels.reg_bot_lab diff --git a/src/Compiler/Backend/CLOS_EXP.sml b/src/Compiler/Backend/CLOS_EXP.sml index c61b834a8..eba766f43 100644 --- a/src/Compiler/Backend/CLOS_EXP.sml +++ b/src/Compiler/Backend/CLOS_EXP.sml @@ -57,8 +57,8 @@ signature CLOS_EXP = | DROPPED_RVAR of place | FETCH of label | STORE of ClosExp * label - | INTEGER of {value: Int32.int, precision: int} - | WORD of {value: Word32.word, precision: int} + | INTEGER of {value: IntInf.int, precision: int} + | WORD of {value: IntInf.int, precision: int} | STRING of string | REAL of string | F64 of string @@ -81,8 +81,8 @@ signature CLOS_EXP = | LET of {pat: lvar list, bind: ClosExp, scope: ClosExp} | RAISE of ClosExp | HANDLE of ClosExp * ClosExp - | SWITCH_I of {switch: Int32.int Switch, precision: int} - | SWITCH_W of {switch: Word32.word Switch, precision: int} + | SWITCH_I of {switch: IntInf.int Switch, precision: int} + | SWITCH_W of {switch: IntInf.int Switch, precision: int} | SWITCH_S of string Switch | SWITCH_C of (con*con_kind) Switch | SWITCH_E of excon Switch diff --git a/src/Compiler/Backend/ClosExp.sml b/src/Compiler/Backend/ClosExp.sml index 53d975501..3a8cc1fcd 100644 --- a/src/Compiler/Backend/ClosExp.sml +++ b/src/Compiler/Backend/ClosExp.sml @@ -74,8 +74,8 @@ struct | DROPPED_RVAR of place | FETCH of label | STORE of ClosExp * label - | INTEGER of {value: Int32.int, precision: int} - | WORD of {value: Word32.word, precision: int} + | INTEGER of {value: IntInf.int, precision: int} + | WORD of {value: IntInf.int, precision: int} | STRING of string | REAL of string | F64 of string @@ -98,8 +98,8 @@ struct | LET of {pat: lvar list, bind: ClosExp, scope: ClosExp} | RAISE of ClosExp | HANDLE of ClosExp * ClosExp - | SWITCH_I of {switch: Int32.int Switch, precision: int} - | SWITCH_W of {switch: Word32.word Switch, precision: int} + | SWITCH_I of {switch: IntInf.int Switch, precision: int} + | SWITCH_W of {switch: IntInf.int Switch, precision: int} | SWITCH_S of string Switch | SWITCH_C of (con*con_kind) Switch | SWITCH_E of excon Switch @@ -195,8 +195,8 @@ struct | layout_ce(DROPPED_RVAR place) = LEAF("D" ^ flatten1(Effect.layout_effect place)) | layout_ce(FETCH lab) = LEAF("fetch(" ^ Labels.pr_label lab ^ ")") | layout_ce(STORE(ce,lab)) = LEAF("store(" ^ flatten1(layout_ce ce) ^ "," ^ Labels.pr_label lab ^ ")") - | layout_ce(INTEGER {value,precision}) = LEAF(Int32.toString value) - | layout_ce(WORD {value,precision}) = LEAF("0x" ^ Word32.toString value) + | layout_ce(INTEGER {value,precision}) = LEAF(IntInf.toString value) + | layout_ce(WORD {value,precision}) = LEAF("0x" ^ IntInf.fmt StringCvt.HEX value) | layout_ce(STRING s) = LEAF("\"" ^ String.toString s ^ "\"") | layout_ce(REAL s) = LEAF(s) | layout_ce(F64 s) = LEAF(s ^ "f64") @@ -327,8 +327,9 @@ struct | layout_ce(RAISE ce) = PP.LEAF("raise " ^ (flatten1(layout_ce ce))) | layout_ce(HANDLE(ce1,ce2)) = NODE{start="",finish="",childsep=RIGHT " handle ",indent=1, children=[layout_ce ce1,layout_ce ce2]} - | layout_ce(SWITCH_I {switch,precision}) = layout_switch layout_ce (Int32.toString) switch - | layout_ce(SWITCH_W {switch,precision}) = layout_switch layout_ce (fn w => "0x" ^ Word32.toString w) switch + | layout_ce(SWITCH_I {switch,precision}) = layout_switch layout_ce (IntInf.toString) switch + | layout_ce(SWITCH_W {switch,precision}) = + layout_switch layout_ce (fn w => "0x" ^ IntInf.fmt StringCvt.HEX w) switch | layout_ce(SWITCH_S sw) = layout_switch layout_ce (fn s => s) sw | layout_ce(SWITCH_C sw) = layout_switch layout_ce (fn (con,con_kind) => Con.pr_con con ^ "(" ^ pr_con_kind con_kind ^ ")") sw @@ -1369,8 +1370,12 @@ struct SOME(tn,_,_,_) => if TyName.eq(tn, TyName.tyName_INT31) then 31 else if TyName.eq(tn, TyName.tyName_INT32) then 32 + else if TyName.eq(tn, TyName.tyName_INT63) then 63 + else if TyName.eq(tn, TyName.tyName_INT64) then 64 else if TyName.eq(tn, TyName.tyName_WORD31) then 31 else if TyName.eq(tn, TyName.tyName_WORD32) then 32 + else if TyName.eq(tn, TyName.tyName_WORD63) then 63 + else if TyName.eq(tn, TyName.tyName_WORD64) then 64 else die "precisionNumType.wrong tyname" | NONE => die "precisionNumType.wrong type" @@ -1559,15 +1564,9 @@ struct (case e of MulExp.VAR{lvar,...} => lookup_ve env lvar | MulExp.INTEGER(i,t,alloc) => - (INTEGER {value=i, precision=precisionNumType t}, NONE_SE) -(* - ((if BI.tag_values() then - (INTEGER(int32_to_string(2*(Int32.fromInt i)+1)),NONE_SE) - else (INTEGER (int_to_string i), NONE_SE)) - handle Overflow => die "ClosExp.INTEGER Overflow raised") -*) - | MulExp.WORD(w,t,alloc) => (WORD {value=w, precision=precisionNumType t}, NONE_SE) - + (INTEGER {value=i, precision=precisionNumType t}, NONE_SE) + | MulExp.WORD(w,t,alloc) => + (WORD {value=w, precision=precisionNumType t}, NONE_SE) | MulExp.STRING(s,alloc) => (STRING s,NONE_SE) | MulExp.REAL(r,alloc) => (REAL (convert_real r),NONE_SE) | MulExp.F64(r,alloc) => (F64 (convert_real r),NONE_SE) @@ -1925,10 +1924,10 @@ struct (* When tagging is enabled, integers in SWITCH_I are converted in * CodeGenX86.sml - so in that case we must use an untagged representation * of true, which is 1 (given that BI.ml_true is 3). *) - val True = Int32.fromInt (if BI.ml_true = 3 then - if BI.tag_values() then 1 - else BI.ml_true - else die "True") + val True = IntInf.fromInt (if BI.ml_true = 3 then + if BI.tag_values() then 1 + else BI.ml_true + else die "True") fun compile_seq_switch(ce,[],default) = default | compile_seq_switch(ce,(s,ce')::rest,default) = let @@ -1992,7 +1991,7 @@ struct scope=LET{pat=[lv_sw], bind=CCALL{name="__equal_int32ub", args=[ce,VAR lv_exn2],rhos_for_result=[]}, - scope=SWITCH_I {switch=SWITCH(VAR lv_sw,[(Int32.fromInt BI.ml_true,ce')], + scope=SWITCH_I {switch=SWITCH(VAR lv_sw,[(IntInf.fromInt BI.ml_true,ce')], compile_seq_switch(ce,rest,default)), precision=BI.defaultIntPrecision()}}}} | UNARY_EXCON => @@ -2001,7 +2000,7 @@ struct scope=LET{pat=[lv_sw], bind=CCALL{name="__equal_int32ub", args=[ce,VAR lv_exn1],rhos_for_result=[]}, - scope=SWITCH_I {switch=SWITCH(VAR lv_sw,[(Int32.fromInt BI.ml_true,ce')], + scope=SWITCH_I {switch=SWITCH(VAR lv_sw,[(IntInf.fromInt BI.ml_true,ce')], compile_seq_switch(ce,rest,default)), precision=BI.defaultIntPrecision()}}}) end @@ -2169,11 +2168,21 @@ struct else if TyName.eq(tn,TyName.tyName_INT32) then (if BI.tag_values() then eq_prim "__equal_int32b" else eq_prim "__equal_int32ub") + else if TyName.eq(tn,TyName.tyName_INT63) then + eq_prim "__equal_int63" + else if TyName.eq(tn,TyName.tyName_INT64) then + (if BI.tag_values() then eq_prim "__equal_int64b" + else eq_prim "__equal_int64ub") else if TyName.eq(tn,TyName.tyName_WORD31) then eq_prim "__equal_word31" else if TyName.eq(tn,TyName.tyName_WORD32) then (if BI.tag_values() then eq_prim "__equal_word32b" else eq_prim "__equal_word32ub") + else if TyName.eq(tn,TyName.tyName_WORD63) then + eq_prim "__equal_word63" + else if TyName.eq(tn,TyName.tyName_WORD64) then + (if BI.tag_values() then eq_prim "__equal_word64b" + else eq_prim "__equal_word64ub") else if TyName.eq(tn,TyName.tyName_STRING) then eq_prim "equalStringML" else if TyName.eq(tn,TyName.tyName_VECTOR) then @@ -2210,7 +2219,7 @@ struct (case i_opt of SOME 0 => die "get_pp_for_profiling (CCALL ...): argument region with size 0" | SOME i => add_pp_for_profiling(rest,args) - | NONE => (name ^ "Prof", args @ [INTEGER {value=Int32.fromInt(get_pp sma), + | NONE => (name ^ "Prof", args @ [INTEGER {value=IntInf.fromInt(get_pp sma), precision=BI.defaultIntPrecision()}])) (*get any arbitrary pp (they are the same):*) else (name, args) @@ -2445,12 +2454,6 @@ struct (case e of MulExp.VAR{lvar,...} => lookup_ve env lvar | MulExp.INTEGER(i,t,alloc) => INTEGER{value=i, precision=precisionNumType t} -(* - ((if BI.tag_values() then - INTEGER(int32_to_string(2*(Int32.fromInt i)+1)) - else INTEGER (int_to_string i)) - handle Overflow => die "ClosExp.INTEGER Overflow raised") -*) | MulExp.WORD(w,t,alloc) => WORD{value=w, precision=precisionNumType t} | MulExp.STRING(s,alloc) => STRING s | MulExp.REAL(r,alloc) => REAL (convert_real r) @@ -2757,10 +2760,10 @@ struct (* When tagging is enabled, integers in SWITCH_I are converted in * CodeGenX86.sml - so in that case we must use an untagged representation * of true, which is 1 (given that BI.ml_true is 3). *) - val True = Int32.fromInt (if BI.ml_true = 3 then - if BI.tag_values() then 1 - else BI.ml_true - else die "True") + val True = IntInf.fromInt (if BI.ml_true = 3 then + if BI.tag_values() then 1 + else BI.ml_true + else die "True") fun compile_seq_switch(ce,[],default) = default | compile_seq_switch(ce,(s,ce')::rest,default) = SWITCH_I {switch=SWITCH(CCALL{name="equalStringML",args=[ce,STRING s],rhos_for_result=[]}, @@ -2809,13 +2812,13 @@ struct SWITCH_I{switch=SWITCH(CCALL{name="__equal_int32ub", args=[ce,SELECT(0,SELECT(0,ce_e))], rhos_for_result=[]}, - [(Int32.fromInt BI.ml_true,ce')], + [(IntInf.fromInt BI.ml_true,ce')], compile_seq_switch(ce,rest,default)), precision=BI.defaultIntPrecision()} | UNARY_EXCON => SWITCH_I{switch=SWITCH(CCALL{name="__equal_int32ub", args=[ce,SELECT(0,ce_e)],rhos_for_result=[]}, - [(Int32.fromInt BI.ml_true,ce')], + [(IntInf.fromInt BI.ml_true,ce')], compile_seq_switch(ce,rest,default)), precision=BI.defaultIntPrecision()}) val lv_exn_arg = fresh_lvar("exn_arg") @@ -2900,6 +2903,16 @@ struct else if TyName.eq(tn,TyName.tyName_WORD32) then (if BI.tag_values() then eq_prim "__equal_word32b" else eq_prim "__equal_word32ub") + else if TyName.eq(tn,TyName.tyName_INT63) then + eq_prim "__equal_int63" + else if TyName.eq(tn,TyName.tyName_INT64) then + (if BI.tag_values() then eq_prim "__equal_int64b" + else eq_prim "__equal_int64ub") + else if TyName.eq(tn,TyName.tyName_WORD63) then + eq_prim "__equal_word63" + else if TyName.eq(tn,TyName.tyName_WORD64) then + (if BI.tag_values() then eq_prim "__equal_word64b" + else eq_prim "__equal_word64ub") else if TyName.eq(tn,TyName.tyName_STRING) then eq_prim "equalStringML" else if TyName.eq(tn,TyName.tyName_VECTOR) then diff --git a/src/Compiler/Backend/JS/ExecutionJS.sml b/src/Compiler/Backend/JS/ExecutionJS.sml index 961070097..58bba9f74 100644 --- a/src/Compiler/Backend/JS/ExecutionJS.sml +++ b/src/Compiler/Backend/JS/ExecutionJS.sml @@ -30,16 +30,16 @@ structure ExecutionJS : EXECUTION = val dummy_label = "__DUMMYDUMMY" val code_label_of_linkinfo : linkinfo -> lab = fn _ => dummy_label - fun imports_of_linkinfo (li: linkinfo) : lab list * lab list = + fun imports_of_linkinfo (li: linkinfo) : lab list * lab list = (#imports li,nil) - fun exports_of_linkinfo (li: linkinfo) : lab list * lab list = + fun exports_of_linkinfo (li: linkinfo) : lab list * lab list = (#exports li,nil) fun unsafe_linkinfo (li: linkinfo) : bool = #unsafe li (* Hook to be run before any compilation *) val preHook = Compile.preHook - + (* Hook to be run after all compilations (for one compilation unit) *) val postHook = Compile.postHook @@ -50,10 +50,10 @@ structure ExecutionJS : EXECUTION = in case Compile.compile fe (ce, cb, strdecs) of Compile.CEnvOnlyRes ce => CEnvOnlyRes ce - | Compile.CodeRes(ce,cb,target,safe) => - let + | Compile.CodeRes(ce,cb,target,safe) => + let val {imports,exports} = #2 target - val linkinfo : linkinfo = {unsafe=not(safe),imports=imports,exports=exports} + val linkinfo : linkinfo = {unsafe=not(safe),imports=imports,exports=exports} val CB = CompileBasis.mk_CompileBasis(cb,()) in CodeRes(ce,CB,target,linkinfo) end @@ -66,14 +66,14 @@ structure ExecutionJS : EXECUTION = val op ## = OS.Path.concat infix ## - val js_dom_mode = Flags.add_bool_entry - {long="js_dom_mode", short=NONE, + val js_dom_mode = Flags.add_bool_entry + {long="js_dom_mode", short=NONE, menu=["File","js dom mode"], - item=ref false, neg=false, + item=ref false, neg=false, desc= "Generate a full HTML document including\n\ \a proper HTML DOCTYPE specification."} - val get_jslibs = Flags.add_stringlist_entry + val get_jslibs = Flags.add_stringlist_entry {long="javascript_library_paths", short=SOME "jslibs", menu=["Control","JavaScript library paths"], @@ -82,26 +82,28 @@ structure ExecutionJS : EXECUTION = \to the generated html and thereby allow for SML\n\ \code to reference existing JavaScript libraries."} - val js_path_compress = Flags.add_bool_entry - {long="js_path_compress", short=NONE, + val js_path_compress = Flags.add_bool_entry + {long="js_path_compress", short=NONE, menu=["File","js path compress"], - item=ref false, neg=false, + item=ref false, neg=false, desc= "Compress (make canonical) Javascript file path\n\ \references in the resulting run.html file."} - val js_path_prefix = Flags.add_string_entry - {long="js_path_prefix", short=NONE, menu=["File", "js path prefix"], + val js_path_prefix = Flags.add_string_entry + {long="js_path_prefix", short=NONE, menu=["File", "js path prefix"], item=ref "", desc= "Prefix to add to each non-absolute Javascript\n\ \file path in the resulting run.html file."} - val js_path_relative_to = Flags.add_string_entry - {long="js_path_relative_to", short=NONE, menu=["File", "js path relative to"], + val js_path_relative_to = Flags.add_string_entry + {long="js_path_relative_to", short=NONE, menu=["File", "js path relative to"], item=ref "", desc= "Absolute directory for which each absolute\n\ \Javascript file path is made relative to in\n\ \the resulting run.html file."} + val () = Flags.turn_off "values_64bit" + fun link_files_with_runtime_system files run = let val html_file = run ^ ".html" val os = TextIO.openOut html_file @@ -117,7 +119,7 @@ structure ExecutionJS : EXECUTION = (out "\n"; out "\n"; out "\n") - else () + else () fun outJsFile f = let val f = if OS.Path.isAbsolute f then @@ -126,13 +128,13 @@ structure ExecutionJS : EXECUTION = handle OS.Path.Path => die "link: outJsFile") else f else js_path_prefix() ## f - val f = if js_path_compress() then OS.Path.mkCanonical f + val f = if js_path_compress() then OS.Path.mkCanonical f else f in out ("\n") end val jslibs = get_jslibs() val files = jslibs @ files - in + in (out ("\n"); out ("\n"); maybe_out_DOCTYPE(); @@ -154,4 +156,3 @@ structure ExecutionJS : EXECUTION = (Pickle.tup3Gen(pu_sList,pu_sList,Pickle.bool)) end end - diff --git a/src/Compiler/Backend/JS/ExpToJs2.sml b/src/Compiler/Backend/JS/ExpToJs2.sml index d2bcd8336..e5c64f78c 100644 --- a/src/Compiler/Backend/JS/ExpToJs2.sml +++ b/src/Compiler/Backend/JS/ExpToJs2.sml @@ -273,7 +273,7 @@ fun resolveS (arg: J.stmt option * 'a) (f: 'a -> cont -> J.stmt) : ret = (SOME s,es') => S(fn k => s & f es' k) | (NONE,es') => S(fn k => f es' k) -fun jint i = J.Cnst(J.Int(Int32.fromInt i)) +fun jint i = J.Cnst(J.Int(IntInf.fromInt i)) val jcnst0 = jint 0 val jcnst1 = jint 1 val junit = jcnst0 @@ -284,8 +284,8 @@ val jnull = J.Cnst J.Null (* Compilation of value constructors *) fun ppCon C c : J.cnst = case Env.M.lookup (Context.envOf C) c of - SOME(STD i) => J.Int(Int32.fromInt i) - | SOME(ENUM i) => J.Int(Int32.fromInt i) + SOME(STD i) => J.Int(IntInf.fromInt i) + | SOME(ENUM i) => J.Int(IntInf.fromInt i) | SOME(BOOL true) => J.Bool true | SOME(BOOL false) => J.Bool false | SOME UNBOXED_NULL => J.Null @@ -331,9 +331,9 @@ arithmentic operations must consider signs explicitly. fun jandw e w = J.Prim("&",[e,J.Cnst(J.Word w)]) fun jorw e w = J.Prim("|",[e,J.Cnst(J.Word w)]) -fun wrapWord31 (e: J.exp) : J.exp = jandw e 0wx7FFFFFFF +fun wrapWord31 (e: J.exp) : J.exp = jandw e 0x7FFFFFFF -fun wrapWord32 (e: J.exp) : J.exp = jandw e 0wxFFFFFFFF +fun wrapWord32 (e: J.exp) : J.exp = jandw e 0xFFFFFFFF fun callPrim0 n = J.App(J.Id n,[]) @@ -415,11 +415,11 @@ fun pToJs2 name e1 e2 : J.exp = | "__shift_right_signed_word32ub" => J.Prim(">>", [e1,e2]) | "__shift_right_signed_word31" => J.IfExp(J.Prim("&", [e1,J.Id "-0x40000000"]), - jandw (J.Prim(">>", [jorw e1 0wx80000000, e2])) 0wx7FFFFFFF, + jandw (J.Prim(">>", [jorw e1 0x80000000, e2])) 0x7FFFFFFF, J.Prim(">>", [e1,e2])) - | "__shift_left_word31" => wrapWord31(J.Prim("<<",[e1,jandw e2 0wx1F])) - | "__shift_left_word32ub" => wrapWord32(J.Prim("<<",[e1,jandw e2 0wx1F])) + | "__shift_left_word31" => wrapWord31(J.Prim("<<",[e1,jandw e2 0x1F])) + | "__shift_left_word32ub" => wrapWord32(J.Prim("<<",[e1,jandw e2 0x1F])) | "__andb_word32ub" => J.Prim("&",[e1,e2]) | "__andb_word31" => J.Prim("&",[e1,e2]) @@ -750,7 +750,7 @@ fun toj C (P:{clos_p:bool}) (e:Exp) : ret = | L.PRIM(L.UB_RECORDprim, es) => die ("UB_RECORD unimplemented. size(args) = " ^ Int.toString (List.length es)) | L.PRIM(L.SELECTprim i,[e]) => - resolveE (toj1 C P e) (fn e' => J.Sub(e',J.Cnst(J.Int(Int32.fromInt i)))) + resolveE (toj1 C P e) (fn e' => J.Sub(e',J.Cnst(J.Int(IntInf.fromInt i)))) | L.PRIM(L.DEREFprim _, [e]) => resolveE (toj1 C P e) (fn e' => J.Sub(e', jcnst0)) | L.PRIM(L.REFprim _, [e]) => @@ -774,7 +774,8 @@ fun toj C (P:{clos_p:bool}) (e:Exp) : ret = val env_id = prLvar C (Lvars.new_named_lvar "env") val rep : rep = (fromList o map (fn (lv,lv',_) => (lv,lv'))) lvs_lvs'_idxs val body' = replace_lvs rep body - val binds = map (fn (_,lv',i) => J.Var(prLvar C lv', SOME(J.Sub(J.Id env_id,J.Cnst(J.Int i))))) lvs_lvs'_idxs + val binds = map (fn (_,lv',i) => J.Var(prLvar C lv', SOME(J.Sub(J.Id env_id,J.Cnst(J.Int i))))) + lvs_lvs'_idxs val g = J.Fun(ids, J.Seq (binds@[wrapRet(RetCont NONE) (toj C P body')])) val f = J.Fun([env_id], J.Return g) val es = map (J.Id o prLvar C) fvs diff --git a/src/Compiler/Backend/JS/JS_AST.sml b/src/Compiler/Backend/JS/JS_AST.sml index 8a4498172..460aaf1a9 100644 --- a/src/Compiler/Backend/JS/JS_AST.sml +++ b/src/Compiler/Backend/JS/JS_AST.sml @@ -2,8 +2,8 @@ signature JS_AST = sig type id = string (* labels and identifiers *) - datatype cnst = Int of Int32.int | Str of string | Real of string - | Bool of bool | Word of Word32.word | Null + datatype cnst = Int of IntInf.int | Str of string | Real of string + | Bool of bool | Word of IntInf.int | Null datatype stmt = Var of id * exp option @@ -23,7 +23,7 @@ signature JS_AST = sig Prim of string * exp list (* string determines if it is infix *) | Array of exp list | IfExp of exp * exp * exp - | Fun of id list * stmt + | Fun of id list * stmt | App of exp * exp list | Id of id | Cnst of cnst @@ -31,10 +31,9 @@ signature JS_AST = sig | New of id * exp list | Sub of exp * exp - val is_infix : string -> bool + val is_infix : string -> bool val pr_cnst : cnst -> string val pr_stmt : stmt -> string - val pr_exp : exp -> string + val pr_exp : exp -> string end - diff --git a/src/Compiler/Backend/JS/JsAst.sml b/src/Compiler/Backend/JS/JsAst.sml index 68e03a6df..9f8caeffd 100644 --- a/src/Compiler/Backend/JS/JsAst.sml +++ b/src/Compiler/Backend/JS/JsAst.sml @@ -20,15 +20,15 @@ struct | concatWith tsep [t] = t | concatWith tsep (t::ts) = t & tsep & concatWith tsep ts end - + structure JsAst : JS_AST = struct fun die s = (print("Error: " ^ s ^ "\n"); raise Fail s) type id = string (* labels and identifiers *) - datatype cnst = Int of Int32.int | Str of string | Real of string - | Bool of bool | Word of Word32.word | Null + datatype cnst = Int of IntInf.int | Str of string | Real of string + | Bool of bool | Word of IntInf.int | Null datatype stmt = Var of id * exp option @@ -41,14 +41,14 @@ structure JsAst : JS_AST = struct | IfStmt of exp * stmt * stmt option | Break | Try of stmt * id * stmt - | Throw of exp + | Throw of exp | Embed of string and exp = Prim of string * exp list (* string determines if it is infix *) | Array of exp list | IfExp of exp * exp * exp - | Fun of id list * stmt + | Fun of id list * stmt | App of exp * exp list | Id of id | Cnst of cnst @@ -56,7 +56,7 @@ structure JsAst : JS_AST = struct | New of id * exp list | Sub of exp * exp - fun is_infix p = + fun is_infix p = case p of "=" => true (* assign *) | "==" => true @@ -79,7 +79,7 @@ structure JsAst : JS_AST = struct | _ => false fun mlToJsString s = - let + let fun digit n = chr(48 + n); fun toJSescape (c:char) : string = case c of @@ -98,12 +98,12 @@ structure JsAst : JS_AST = struct | _ => let val n = ord c in implode[#"\\", digit(n div 64), digit(n div 8 mod 8), digit(n mod 8)] - end) - + end) + in "\"" ^ String.translate toJSescape s ^ "\"" end - fun mlToJsInt i = + fun mlToJsInt i = String.translate (fn #"~" => "-" | c => Char.toString c) i fun mlToJsReal s = @@ -114,14 +114,14 @@ structure JsAst : JS_AST = struct fun wrap (s1,s2) cs = $s1 & cs & $s2 fun par b cs = if b then wrap ("(",")") cs else cs - fun pp_cnst p c = + fun pp_cnst p c = case c of - Int i => par (p andalso i < 0) ($(mlToJsInt (Int32.toString i))) + Int i => par (p andalso i < 0) ($(mlToJsInt (IntInf.toString i))) | Str s => $ (mlToJsString s) | Real s => par (p andalso String.sub(s,0) = #"~") ($(mlToJsReal s)) | Bool true => $"true" | Bool false => $"false" - | Word w => $(Word32.fmt StringCvt.DEC w) + | Word w => $(IntInf.fmt StringCvt.DEC w) | Null => $"null" fun pr_cnst c = Cs.toString (pp_cnst false c) @@ -131,16 +131,16 @@ structure JsAst : JS_AST = struct val end_stmt = $";\n" - fun pp_varid id = - if CharVector.exists (fn #"." => true | _ => false) id then $id - else $"var " & $id + fun pp_varid id = + if CharVector.exists (fn #"." => true | _ => false) id then $id + else $"var " & $id fun pp_exp p e = case e of Prim ("Infinity",[]) => $"Infinity" | Prim ("-Infinity",[]) => $"-Infinity" | Prim (",",es) => pp_list ("(",",",")") (pp_exp false) es - | Prim (n,es) => + | Prim (n,es) => let fun default() = par p ($n & pp_list ("(",",",")") (pp_exp false) es) in case es of [e1,e2] => @@ -155,11 +155,11 @@ structure JsAst : JS_AST = struct | App (e1,es) => par p (pp_exp true e1 & pp_list ("(",",",")") (pp_exp false) es) | Id id => $ id | Cnst c => pp_cnst p c - | Prop (e0,id) => pp_exp true e0 & ($".") & ($id) + | Prop (e0,id) => pp_exp true e0 & ($".") & ($id) | New (id, es) => par p ($"new " & $id & pp_list ("(",",",")") (pp_exp false) es) | Sub (e1, e2) => pp_exp true e1 & ($"[") & pp_exp false e2 & ($"]") - and pp_stmt s = + and pp_stmt s = case s of Var (id, NONE) => pp_varid id & end_stmt | Var (id, SOME e) => pp_varid id & $" = " & pp_exp false e & end_stmt @@ -168,23 +168,23 @@ structure JsAst : JS_AST = struct | Sw (e,cases,defopt) => $"switch (" & pp_exp false e & $") { " & CSeq (List.map (fn (c,s) => $"case " & pp_cnst false c & $": " & pp_bblock s) cases) & - (case defopt of SOME def => $"default: " & pp_block def | NONE => $"") & + (case defopt of SOME def => $"default: " & pp_block def | NONE => $"") & $" }" & end_stmt | Return e => $"return " & pp_exp false e & end_stmt | Continue id => $"continue " & $id & end_stmt - | While (idopt, e, s) => + | While (idopt, e, s) => let val lab = case idopt of SOME id => $id & $": " | NONE => CSeq nil in lab & $"while (" & pp_exp false e & $") " & pp_block s & end_stmt end - | IfStmt (e,s1,s2opt) => - $"if (" & pp_exp false e & $") " & pp_block s1 & - (case s2opt of - SOME s2 => $" else " & pp_block s2 & end_stmt + | IfStmt (e,s1,s2opt) => + $"if (" & pp_exp false e & $") " & pp_block s1 & + (case s2opt of + SOME s2 => $" else " & pp_block s2 & end_stmt | NONE => end_stmt) | Break => $"break" & end_stmt - | Try (s0,id,s) => $"try " & pp_block s0 & $" catch(" & $id & $") " & pp_block s & end_stmt + | Try (s0,id,s) => $"try " & pp_block s0 & $" catch(" & $id & $") " & pp_block s & end_stmt | Throw e => $"throw " & pp_exp false e & end_stmt | Embed s => $s and pp_block s = wrap ("{","}") (pp_stmt s) diff --git a/src/Compiler/Backend/JUMP_TABLES.sml b/src/Compiler/Backend/JUMP_TABLES.sml index 6c29c9a8b..335f81d7d 100644 --- a/src/Compiler/Backend/JUMP_TABLES.sml +++ b/src/Compiler/Backend/JUMP_TABLES.sml @@ -12,23 +12,23 @@ sig (*inline_cont*) ('inst list -> ('inst list -> 'inst list) option) * (*C*) 'inst list -> 'inst list - val binary_search_new : (*sels *) (Int32.int*'sinst) list * + val binary_search_new : (*sels *) (IntInf.int*'sinst) list * (*default*) 'sinst * (*comment*) (string * 'inst list -> 'inst list) * (*new_label*) (string -> 'label) * - (*if_not_equal_go_lab_sel*) ('label * Int32.int * 'inst list -> 'inst list) * - (*if_less_than_go_lab_sel*) ('label * Int32.int * 'inst list -> 'inst list) * - (*if_greater_than_go_lab_sel*) ('label * Int32.int * 'inst list -> 'inst list) * + (*if_not_equal_go_lab_sel*) ('label * IntInf.int * 'inst list -> 'inst list) * + (*if_less_than_go_lab_sel*) ('label * IntInf.int * 'inst list -> 'inst list) * + (*if_greater_than_go_lab_sel*) ('label * IntInf.int * 'inst list -> 'inst list) * (*compile_insts*) ('sinst * 'inst list -> 'inst list) * (*label*) ('label * 'inst list -> 'inst list) * (*jmp*) ('label * 'inst list -> 'inst list) * - (*sel_dist*) (Int32.int * Int32.int -> Int32.int) * + (*sel_dist*) (IntInf.int * IntInf.int -> IntInf.int) * (*start*) (*length*) - (*jump_table_header*) ('label * Int32.int * Int32.int * 'inst list -> 'inst list) * + (*jump_table_header*) ('label * IntInf.int * IntInf.int * 'inst list -> 'inst list) * (*add_label_to_jump_tab*) ('label * 'inst list -> 'inst list) * (*eq_lab*) ('label * 'label -> bool) * (*inline_cont*) ('inst list -> ('inst list -> 'inst list) option) * (*C*) 'inst list -> 'inst list -end \ No newline at end of file +end diff --git a/src/Compiler/Backend/JumpTables.sml b/src/Compiler/Backend/JumpTables.sml index 0c3a0c7b7..50527ddd5 100644 --- a/src/Compiler/Backend/JumpTables.sml +++ b/src/Compiler/Backend/JumpTables.sml @@ -17,7 +17,7 @@ functor JumpTables(BI : BACKEND_INFO) : JUMP_TABLES = inline_cont: 'inst list -> ('inst list -> 'inst list) option, C: 'inst list) = let - (* To avoid jump-to-jumps, jump-to-returns, etc., we look at the continuation to + (* To avoid jump-to-jumps, jump-to-returns, etc., we look at the continuation to * see if parts of the continuation can be inlined instead of jumped to. *) val (endsel, endswitch) = @@ -42,18 +42,18 @@ functor JumpTables(BI : BACKEND_INFO) : JUMP_TABLES = comment("end linear switch",C)))) sels) end - fun binary_search_new(sels:(Int32.int*'sinst) list, + fun binary_search_new(sels:(IntInf.int*'sinst) list, default: 'sinst, comment: string * 'inst list -> 'inst list, new_label : string -> 'label, - if_not_equal_go_lab_sel: 'label * Int32.int * 'inst list -> 'inst list, - if_less_than_go_lab_sel: 'label * Int32.int * 'inst list -> 'inst list, - if_greater_than_go_lab_sel: 'label * Int32.int * 'inst list -> 'inst list, + if_not_equal_go_lab_sel: 'label * IntInf.int * 'inst list -> 'inst list, + if_less_than_go_lab_sel: 'label * IntInf.int * 'inst list -> 'inst list, + if_greater_than_go_lab_sel: 'label * IntInf.int * 'inst list -> 'inst list, compile_insts: 'sinst * 'inst list -> 'inst list, label: 'label * 'inst list -> 'inst list, jmp: 'label * 'inst list -> 'inst list, - sel_dist: Int32.int * Int32.int -> Int32.int, - jump_table_header: 'label * Int32.int * Int32.int * 'inst list -> 'inst list, + sel_dist: IntInf.int * IntInf.int -> IntInf.int, + jump_table_header: 'label * IntInf.int * IntInf.int * 'inst list -> 'inst list, add_label_to_jump_tab: 'label * 'inst list -> 'inst list, eq_lab : 'label * 'label -> bool, inline_cont: 'inst list -> ('inst list -> 'inst list) option, @@ -65,7 +65,7 @@ functor JumpTables(BI : BACKEND_INFO) : JUMP_TABLES = (* Compilation functions for the binary switch with jump tables. *) (* Switch([(const,is),...,(const,is)],default) *) (*-----------------------------------------------------------------*) - + fun add_group(startSel,finishSel,accGrp) acc = let val lenAccGrp = length accGrp @@ -87,13 +87,13 @@ functor JumpTables(BI : BACKEND_INFO) : JUMP_TABLES = | group_sel_list(NONE, NONE, (sel, selCode)::rest, [], acc) = group_sel_list(SOME sel, SOME sel, rest, [(sel,selCode)], acc) | group_sel_list(SOME startSel, SOME finishSel, (sel,selCode)::rest, accGrp, acc) = - if sel_dist(startSel,sel) <= Int32.fromInt BI.maxDiff then + if sel_dist(startSel,sel) <= IntInf.fromInt BI.maxDiff then group_sel_list(SOME sel, SOME finishSel, rest, (sel,selCode)::accGrp, acc) else group_sel_list(SOME sel, SOME sel, rest, [(sel,selCode)], add_group (startSel,finishSel,accGrp) acc) | group_sel_list _ = die "JumpTables.group_sel_list" - + (* The lists returned may not be reversed! *) fun split_list [] = (NONE, NONE, NONE) | split_list xs = @@ -105,7 +105,7 @@ functor JumpTables(BI : BACKEND_INFO) : JUMP_TABLES = val xsLeft = case xs1 of [] => NONE | _ => SOME xs1 - val xsRight = case rest + val xsRight = case rest of [] => NONE | _ => SOME rest in @@ -117,8 +117,8 @@ functor JumpTables(BI : BACKEND_INFO) : JUMP_TABLES = in split_list' (lenxs div 2) [] xs end - - (* To avoid jump-to-jumps, jump-to-returns, etc., we look at the continuation to + + (* To avoid jump-to-jumps, jump-to-returns, etc., we look at the continuation to * see if parts of the continuation can be inlined instead of jumped to. *) val (endsel, endswitch) = @@ -129,7 +129,7 @@ functor JumpTables(BI : BACKEND_INFO) : JUMP_TABLES = fn C => label(lab_exit, C)) end | SOME f => (f, fn C => C) - + fun switch_with_jump_table([],defaultLab,C) = die "JumpTables: switch_with_jump_table has no selections." | switch_with_jump_table([(sel, selCode)],defaultLab,C) = compile_insts(selCode, endsel C) | switch_with_jump_table(sels as (sel,selCode)::rest, defaultLab,C) = @@ -154,12 +154,12 @@ functor JumpTables(BI : BACKEND_INFO) : JUMP_TABLES = end fun merge([],C) = C | merge(x::xs,C) = x::merge(xs,C) - + val (jumpTableCode, switchCode) = make_sel_code(sel,sels,C) - val jumpTableCode' = label(jumpTableLab,merge(jumpTableCode,switchCode)) + val jumpTableCode' = label(jumpTableLab,merge(jumpTableCode,switchCode)) val len = (* there may be holes in the jumptable; count these in the length, also *) - case rev sels + case rev sels of ((last_sel,_)::_) => last_sel - sel + 1 | _ => die ("switch_with_jump_table.len") in @@ -168,7 +168,7 @@ functor JumpTables(BI : BACKEND_INFO) : JUMP_TABLES = else jump_table_header(jumpTableLab,sel,len,jumpTableCode') end - + fun bin_search_code (leftLab,start,finish,rightLab,C) = if start = finish then if eq_lab(leftLab,rightLab) then @@ -215,11 +215,11 @@ functor JumpTables(BI : BACKEND_INFO) : JUMP_TABLES = switch_with_jump_table(sels,defaultLab,C)) | gen_binary_switch ((NONE, NONE, NONE),defaultLab,C) = die "JumpTables. genBinarySwitch, no selections." | gen_binary_switch _ = die "JumpTables.genBinarySwitch" - - val sels_sorted = ListSort.sort - (fn (i1, is1) => + + val sels_sorted = ListSort.sort + (fn (i1, is1) => (fn (i2, is2) => i1 > i2)) sels - + val group_sels = group_sel_list (NONE, NONE, sels_sorted, [], []) val default_lab = new_label "defaultLab" in diff --git a/src/Compiler/Backend/LINE_STMT.sml b/src/Compiler/Backend/LINE_STMT.sml index 7761e5808..2f8389dfb 100644 --- a/src/Compiler/Backend/LINE_STMT.sml +++ b/src/Compiler/Backend/LINE_STMT.sml @@ -63,8 +63,8 @@ signature LINE_STMT = | RVAR of place | DROPPED_RVAR of place | PHREG of lvar - | INTEGER of {value:Int32.int, precision:int} - | WORD of {value:Word32.word, precision:int} + | INTEGER of {value:IntInf.int, precision:int} + | WORD of {value:IntInf.int, precision:int} | UNIT datatype StoreType = @@ -113,8 +113,8 @@ signature LINE_STMT = handl_return: ('sty,'offset,'aty) LineStmt list * 'aty * (Word32.word list), offset: 'offset} | RAISE of {arg: 'aty,defined_atys: 'aty list} - | SWITCH_I of {switch: (Int32.int,'sty,'offset,'aty) Switch, precision: int} - | SWITCH_W of {switch: (Word32.word,'sty,'offset,'aty) Switch, precision: int} + | SWITCH_I of {switch: (IntInf.int,'sty,'offset,'aty) Switch, precision: int} + | SWITCH_W of {switch: (IntInf.int,'sty,'offset,'aty) Switch, precision: int} | SWITCH_S of (string,'sty,'offset,'aty) Switch | SWITCH_C of ((con*con_kind),'sty,'offset,'aty) Switch | SWITCH_E of (excon,'sty,'offset,'aty) Switch diff --git a/src/Compiler/Backend/LineStmt.sml b/src/Compiler/Backend/LineStmt.sml index 1ab988249..293ab5f3b 100644 --- a/src/Compiler/Backend/LineStmt.sml +++ b/src/Compiler/Backend/LineStmt.sml @@ -80,8 +80,8 @@ struct | RVAR of place | DROPPED_RVAR of place | PHREG of lvar - | INTEGER of {value: Int32.int, precision: int} - | WORD of {value: Word32.word, precision: int} + | INTEGER of {value: IntInf.int, precision: int} + | WORD of {value: IntInf.int, precision: int} | UNIT datatype StoreType = @@ -130,8 +130,8 @@ struct handl_return: ('sty,'offset,'aty) LineStmt list * 'aty * (Word32.word list), offset: 'offset} | RAISE of {arg: 'aty,defined_atys: 'aty list} - | SWITCH_I of {switch: (Int32.int,'sty,'offset,'aty) Switch, precision: int} - | SWITCH_W of {switch: (Word32.word,'sty,'offset,'aty) Switch, precision: int} + | SWITCH_I of {switch: (IntInf.int,'sty,'offset,'aty) Switch, precision: int} + | SWITCH_W of {switch: (IntInf.int,'sty,'offset,'aty) Switch, precision: int} | SWITCH_S of (string,'sty,'offset,'aty) Switch | SWITCH_C of ((con*con_kind),'sty,'offset,'aty) Switch | SWITCH_E of (excon,'sty,'offset,'aty) Switch @@ -185,8 +185,8 @@ struct | pr_atom (RVAR place) = PP.flatten1(Effect.layout_effect place) | pr_atom (DROPPED_RVAR place) = "D" ^ PP.flatten1(Effect.layout_effect place) | pr_atom (PHREG phreg) = pr_phreg phreg - | pr_atom (INTEGER {value,precision}) = Int32.toString value - | pr_atom (WORD {value,precision}) = "0x" ^ Word32.toString value + | pr_atom (INTEGER {value,precision}) = IntInf.toString value + | pr_atom (WORD {value,precision}) = "0x" ^ IntInf.fmt StringCvt.HEX value | pr_atom (UNIT) = "()" fun pr_sty (V lv) = Lvars.pr_lvar lv @@ -437,11 +437,13 @@ struct in PP.LEAF("raise " ^ pr_aty arg ^ "(defined: " ^ lay_stys ^ ")") (* Defined atys not written 08/12/1998, Niels*) end - | SWITCH_I {switch,precision} => layout_switch pr_aty layout_lss_local (Int32.toString) switch - | SWITCH_W {switch,precision} => layout_switch pr_aty layout_lss_local (fn w => "0x" ^ Word32.toString w) switch + | SWITCH_I {switch,precision} => layout_switch pr_aty layout_lss_local (IntInf.toString) switch + | SWITCH_W {switch,precision} => + layout_switch pr_aty layout_lss_local (fn w => "0x" ^ IntInf.fmt StringCvt.HEX w) switch | SWITCH_S sw => layout_switch pr_aty layout_lss_local (fn s => s) sw | SWITCH_C sw => - layout_switch pr_aty layout_lss_local (fn (con,con_kind) => Con.pr_con con ^ "(" ^ pr_con_kind con_kind ^ ")") sw + layout_switch pr_aty layout_lss_local (fn (con,con_kind) => + Con.pr_con con ^ "(" ^ pr_con_kind con_kind ^ ")") sw | SWITCH_E sw => layout_switch pr_aty layout_lss_local Excon.pr_excon sw | RESET_REGIONS{force=true,regions_for_resetting} => HNODE{start="force reset regions(", @@ -1260,8 +1262,8 @@ struct (* Pattern: case lv of 3 => lss | _ => lss *) (* Pattern: case lv of 1 => lss | _ => lss *) | SWITCH_I {switch=sw as SWITCH(VAR lv,[(sel_val,lss)],default), precision} => - if (sel_val = Int32.fromInt BI.ml_true - orelse sel_val = Int32.fromInt BI.ml_false) then + if (sel_val = IntInf.fromInt BI.ml_true + orelse sel_val = IntInf.fromInt BI.ml_false) then let val (OKset',notOKset',_) = FV_CalcSets_lss(default,(OKset,notOKset,prev_use_lv)) in diff --git a/src/Compiler/Backend/PrimName.sml b/src/Compiler/Backend/PrimName.sml index 8ea6b08a9..5d5948a2f 100644 --- a/src/Compiler/Backend/PrimName.sml +++ b/src/Compiler/Backend/PrimName.sml @@ -4,48 +4,155 @@ datatype prim = (* flow primitives *) Equal_int31 | Equal_int32ub | Equal_int32b | Equal_word31 | Equal_word32ub | Equal_word32b | + Equal_int63 | Equal_int64ub | Equal_int64b | + Equal_word63 | Equal_word64ub | Equal_word64b | + Less_int31 | Less_int32ub | Less_int32b | Less_word31 | Less_word32ub | Less_word32b | + Less_int63 | Less_int64ub | Less_int64b | + Less_word63 | Less_word64ub | Less_word64b | + Lesseq_int31 | Lesseq_int32ub | Lesseq_int32b | Lesseq_word31 | Lesseq_word32ub | Lesseq_word32b | + Lesseq_int63 | Lesseq_int64ub | Lesseq_int64b | + Lesseq_word63 | Lesseq_word64ub | Lesseq_word64b | + Greater_int31 | Greater_int32ub | Greater_int32b | Greater_word31 | Greater_word32ub | Greater_word32b | + Greater_int63 | Greater_int64ub | Greater_int64b | + Greater_word63 | Greater_word64ub | Greater_word64b | + Greatereq_int31 | Greatereq_int32ub | Greatereq_int32b | Greatereq_word31 | Greatereq_word32ub | Greatereq_word32b | + Greatereq_int63 | Greatereq_int64ub | Greatereq_int64b | + Greatereq_word63 | Greatereq_word64ub | Greatereq_word64b | (* other primitives *) Less_real | Lesseq_real | Greater_real | Greatereq_real | Less_f64 | Lesseq_f64 | Greater_f64 | Greatereq_f64 | + Plus_int31 | Plus_int32ub | Plus_int32b | - Plus_word31 | Plus_word32ub | Plus_word32b | Plus_real | + Plus_word31 | Plus_word32ub | Plus_word32b | + Plus_int63 | Plus_int64ub | Plus_int64b | + Plus_word63 | Plus_word64ub | Plus_word64b | + Plus_real | Plus_f64 | + Minus_int31 | Minus_int32ub | Minus_int32b | - Minus_word31 | Minus_word32ub | Minus_word32b | Minus_real | + Minus_word31 | Minus_word32ub | Minus_word32b | + Minus_int63 | Minus_int64ub | Minus_int64b | + Minus_word63 | Minus_word64ub | Minus_word64b | + Minus_real | Minus_f64 | + Mul_int31 | Mul_int32ub | Mul_int32b | - Mul_word31 | Mul_word32ub | Mul_word32b | Mul_real | - Div_real | - Neg_int31 | Neg_int32ub | Neg_int32b | Neg_real | - Abs_int31 | Abs_int32ub | Abs_int32b | Abs_real | + Mul_word31 | Mul_word32ub | Mul_word32b | + Mul_int63 | Mul_int64ub | Mul_int64b | + Mul_word63 | Mul_word64ub | Mul_word64b | + Mul_real | Mul_f64 | + + Div_real | Div_f64 | + + Neg_int31 | Neg_int32ub | Neg_int32b | + Neg_int63 | Neg_int64ub | Neg_int64b | + Neg_real | Neg_f64 | + + Abs_int31 | Abs_int32ub | Abs_int32b | + Abs_int63 | Abs_int64ub | Abs_int64b | + Abs_real | Abs_f64 | + Andb_word31 | Andb_word32ub | Andb_word32b | + Andb_word63 | Andb_word64ub | Andb_word64b | + Orb_word31 | Orb_word32ub | Orb_word32b | + Orb_word63 | Orb_word64ub | Orb_word64b | + Xorb_word31 | Xorb_word32ub | Xorb_word32b | + Xorb_word63 | Xorb_word64ub | Xorb_word64b | + Shift_left_word31 | Shift_left_word32ub | Shift_left_word32b | - Shift_right_signed_word31 | - Shift_right_signed_word32ub | Shift_right_signed_word32b | - Shift_right_unsigned_word31 | - Shift_right_unsigned_word32ub | Shift_right_unsigned_word32b | + Shift_left_word63 | Shift_left_word64ub | Shift_left_word64b | + + Shift_right_signed_word31 | Shift_right_signed_word32ub | Shift_right_signed_word32b | + Shift_right_signed_word63 | Shift_right_signed_word64ub | Shift_right_signed_word64b | + + Shift_right_unsigned_word31 | Shift_right_unsigned_word32ub | Shift_right_unsigned_word32b | + Shift_right_unsigned_word63 | Shift_right_unsigned_word64ub | Shift_right_unsigned_word64b | + Int31_to_int32b | Int31_to_int32ub | Int32b_to_int31 | Int32b_to_word32b | Int32ub_to_int31 | + Int31_to_int64b | Int31_to_int64ub | Int64b_to_int31 | + Word31_to_word32b | Word31_to_word32ub | Word32b_to_word31 | Word32ub_to_word31 | Word31_to_word32ub_X | Word31_to_word32b_X | Word32b_to_int32b | Word32b_to_int32b_X | Word32ub_to_int32ub | Word31_to_int31 | Word32b_to_int31 | Int32b_to_word31 | Word32b_to_int31_X | + + Word64ub_to_int32ub | + Word32ub_to_word64ub | + Word64ub_to_word32ub | + Word64ub_to_int64ub | + Word64ub_to_int64ub_X | + + Word31_to_word64b | + Word31_to_word64b_X | + Word64b_to_int31 | + Word64b_to_int64b_X | + Word64b_to_int64b | + Word32b_to_word64b | + Word32b_to_word64b_X | + Word64b_to_word32b | + Word64b_to_int31_X | + + Int32b_to_int64b | + Int32ub_to_int64ub | + Int64b_to_word64b | + Int64ub_to_word64ub | + Int64ub_to_int32ub | + + Int63_to_int64b | (* sarq |> box *) + Int64b_to_int63 | (* check ovf |> salq >> (+1) *) + Word32b_to_word63 | (* unbox |> salq >> (+1) *) + Word63_to_word32b | (* shrq |> mov |> box *) + Word63_to_word31 | (* mov *) + Word31_to_word63 | (* mov *) + Word31_to_word63_X | (* movslq *) + Word63_to_word64b | (* shrq |> box *) + Word63_to_word64b_X | (* sarq |> box *) + Word64b_to_word63 | (* sal >> (+1) *) + + Int31_to_int63 | + Int63_to_int31 | + Int32b_to_int63 | + Int63_to_int32b | + Word32b_to_int63 | + Word32b_to_int63_X | + Word64b_to_word31 | + + Word64b_to_int63 | + Word64b_to_int63_X | + Int63_to_int64ub | + Int64ub_to_int63 | + Word63_to_word64ub | + Word63_to_word64ub_X | + + Word64ub_to_word31 | + Int64ub_to_int31 | + Word31_to_word64ub | + Word31_to_word64ub_X | + Word32ub_to_int64ub | + Word32ub_to_int64ub_X | + Word32ub_to_word64ub_X | + Exn_ptr | Fresh_exname | + Bytetable_sub | Bytetable_size | Bytetable_update | Word_sub0 | Word_update0 | Table_size | + Is_null | + ServerGetCtx | - Plus_f64 | Minus_f64 | Mul_f64 | Div_f64 | Max_f64 | Min_f64 | - Real_to_f64 | F64_to_real | - Sqrt_f64 | Neg_f64 | Abs_f64 | Int_to_f64 | + + Max_f64 | Min_f64 | Real_to_f64 | F64_to_real | Sqrt_f64 | + Int_to_f64 | + Blockf64_update_real | Blockf64_sub_real | Blockf64_size | Blockf64_alloc | Blockf64_update_f64 | Blockf64_sub_f64 @@ -57,14 +164,28 @@ local val flow_pairs = [("__equal_int31", Equal_int31), ("__equal_int32ub", Equal_int32ub), ("__equal_int32b", Equal_int32b), ("__equal_word31", Equal_word31), ("__equal_word32ub", Equal_word32ub), ("__equal_word32b", Equal_word32b), + ("__equal_int63", Equal_int63), ("__equal_int64ub", Equal_int64ub), ("__equal_int64b", Equal_int64b), + ("__equal_word63", Equal_word63), ("__equal_word64ub", Equal_word64ub), ("__equal_word64b", Equal_word64b), + ("__less_int31", Less_int31), ("__less_int32ub", Less_int32ub), ("__less_int32b", Less_int32b), ("__less_word31", Less_word31), ("__less_word32ub", Less_word32ub), ("__less_word32b", Less_word32b), + ("__less_int63", Less_int63), ("__less_int64ub", Less_int64ub), ("__less_int64b", Less_int64b), + ("__less_word63", Less_word63), ("__less_word64ub", Less_word64ub), ("__less_word64b", Less_word64b), + ("__lesseq_int31", Lesseq_int31), ("__lesseq_int32ub", Lesseq_int32ub), ("__lesseq_int32b", Lesseq_int32b), ("__lesseq_word31", Lesseq_word31), ("__lesseq_word32ub", Lesseq_word32ub), ("__lesseq_word32b", Lesseq_word32b), + ("__lesseq_int63", Lesseq_int63), ("__lesseq_int64ub", Lesseq_int64ub), ("__lesseq_int64b", Lesseq_int64b), + ("__lesseq_word63", Lesseq_word63), ("__lesseq_word64ub", Lesseq_word64ub), ("__lesseq_word64b", Lesseq_word64b), + ("__greater_int31", Greater_int31), ("__greater_int32ub", Greater_int32ub), ("__greater_int32b", Greater_int32b), ("__greater_word31", Greater_word31), ("__greater_word32ub", Greater_word32ub), ("__greater_word32b", Greater_word32b), + ("__greater_int63", Greater_int63), ("__greater_int64ub", Greater_int64ub), ("__greater_int64b", Greater_int64b), + ("__greater_word63", Greater_word63), ("__greater_word64ub", Greater_word64ub), ("__greater_word64b", Greater_word64b), + ("__greatereq_int31", Greatereq_int31), ("__greatereq_int32ub", Greatereq_int32ub), ("__greatereq_int32b", Greatereq_int32b), - ("__greatereq_word31", Greatereq_word31), ("__greatereq_word32ub", Greatereq_word32ub), ("__greatereq_word32b", Greatereq_word32b) + ("__greatereq_word31", Greatereq_word31), ("__greatereq_word32ub", Greatereq_word32ub), ("__greatereq_word32b", Greatereq_word32b), + ("__greatereq_int63", Greatereq_int63), ("__greatereq_int64ub", Greatereq_int64ub), ("__greatereq_int64b", Greatereq_int64b), + ("__greatereq_word63", Greatereq_word63), ("__greatereq_word64ub", Greatereq_word64ub), ("__greatereq_word64b", Greatereq_word64b) ] val M_flow = M.fromList flow_pairs @@ -72,44 +193,132 @@ local val pairs = [("__less_real", Less_real), ("__lesseq_real", Lesseq_real), ("__greater_real", Greater_real), ("__greatereq_real", Greatereq_real), ("__less_f64", Less_f64), ("__lesseq_f64", Lesseq_f64), ("__greater_f64", Greater_f64), ("__greatereq_f64", Greatereq_f64), + ("__plus_int31", Plus_int31), ("__plus_int32ub", Plus_int32ub), ("__plus_int32b", Plus_int32b), - ("__plus_word31", Plus_word31), ("__plus_word32ub", Plus_word32ub), ("__plus_word32b", Plus_word32b), ("__plus_real", Plus_real), + ("__plus_word31", Plus_word31), ("__plus_word32ub", Plus_word32ub), ("__plus_word32b", Plus_word32b), + ("__plus_int63", Plus_int63), ("__plus_int64ub", Plus_int64ub), ("__plus_int64b", Plus_int64b), + ("__plus_word63", Plus_word63), ("__plus_word64ub", Plus_word64ub), ("__plus_word64b", Plus_word64b), + ("__plus_real", Plus_real), ("__plus_f64", Plus_f64), + ("__minus_int31", Minus_int31), ("__minus_int32ub", Minus_int32ub), ("__minus_int32b", Minus_int32b), - ("__minus_word31", Minus_word31), ("__minus_word32ub", Minus_word32ub), ("__minus_word32b", Minus_word32b), ("__minus_real", Minus_real), + ("__minus_word31", Minus_word31), ("__minus_word32ub", Minus_word32ub), ("__minus_word32b", Minus_word32b), + ("__minus_int63", Minus_int63), ("__minus_int64ub", Minus_int64ub), ("__minus_int64b", Minus_int64b), + ("__minus_word63", Minus_word63), ("__minus_word64ub", Minus_word64ub), ("__minus_word64b", Minus_word64b), + ("__minus_real", Minus_real), ("__minus_f64", Minus_f64), + ("__mul_int31", Mul_int31), ("__mul_int32ub", Mul_int32ub), ("__mul_int32b", Mul_int32b), - ("__mul_word31", Mul_word31), ("__mul_word32ub", Mul_word32ub), ("__mul_word32b", Mul_word32b), ("__mul_real", Mul_real), - ("__div_real", Div_real), - ("__neg_int31", Neg_int31), ("__neg_int32ub", Neg_int32ub), ("__neg_int32b", Neg_int32b), ("__neg_real", Neg_real), - ("__abs_int31", Abs_int31), ("__abs_int32ub", Abs_int32ub), ("__abs_int32b", Abs_int32b), ("__abs_real", Abs_real), + ("__mul_word31", Mul_word31), ("__mul_word32ub", Mul_word32ub), ("__mul_word32b", Mul_word32b), + ("__mul_int63", Mul_int63), ("__mul_int64ub", Mul_int64ub), ("__mul_int64b", Mul_int64b), + ("__mul_word63", Mul_word63), ("__mul_word64ub", Mul_word64ub), ("__mul_word64b", Mul_word64b), + ("__mul_real", Mul_real), ("__mul_f64", Mul_f64), + + ("__div_real", Div_real), ("__div_f64", Div_f64), + + ("__neg_int31", Neg_int31), ("__neg_int32ub", Neg_int32ub), ("__neg_int32b", Neg_int32b), + ("__neg_int63", Neg_int63), ("__neg_int64ub", Neg_int64ub), ("__neg_int64b", Neg_int64b), + ("__neg_real", Neg_real), ("__neg_f64", Neg_f64), + + ("__abs_int31", Abs_int31), ("__abs_int32ub", Abs_int32ub), ("__abs_int32b", Abs_int32b), + ("__abs_int63", Abs_int63), ("__abs_int64ub", Abs_int64ub), ("__abs_int64b", Abs_int64b), + ("__abs_real", Abs_real), ("__abs_f64", Abs_f64), + ("__andb_word31", Andb_word31), ("__andb_word32ub", Andb_word32ub), ("__andb_word32b", Andb_word32b), + ("__andb_word63", Andb_word63), ("__andb_word64ub", Andb_word64ub), ("__andb_word64b", Andb_word64b), + ("__orb_word31", Orb_word31), ("__orb_word32ub", Orb_word32ub), ("__orb_word32b", Orb_word32b), + ("__orb_word63", Orb_word63), ("__orb_word64ub", Orb_word64ub), ("__orb_word64b", Orb_word64b), + ("__xorb_word31", Xorb_word31), ("__xorb_word32ub", Xorb_word32ub), ("__xorb_word32b", Xorb_word32b), + ("__xorb_word63", Xorb_word63), ("__xorb_word64ub", Xorb_word64ub), ("__xorb_word64b", Xorb_word64b), + ("__shift_left_word31", Shift_left_word31), ("__shift_left_word32ub", Shift_left_word32ub), ("__shift_left_word32b", Shift_left_word32b), + ("__shift_left_word63", Shift_left_word63), ("__shift_left_word64ub", Shift_left_word64ub), ("__shift_left_word64b", Shift_left_word64b), + ("__shift_right_signed_word31", Shift_right_signed_word31), ("__shift_right_signed_word32ub", Shift_right_signed_word32ub), ("__shift_right_signed_word32b", Shift_right_signed_word32b), + ("__shift_right_signed_word63", Shift_right_signed_word63), + ("__shift_right_signed_word64ub", Shift_right_signed_word64ub), ("__shift_right_signed_word64b", Shift_right_signed_word64b), + ("__shift_right_unsigned_word31", Shift_right_unsigned_word31), ("__shift_right_unsigned_word32ub", Shift_right_unsigned_word32ub), ("__shift_right_unsigned_word32b", Shift_right_unsigned_word32b), + ("__shift_right_unsigned_word63", Shift_right_unsigned_word63), + ("__shift_right_unsigned_word64ub", Shift_right_unsigned_word64ub), ("__shift_right_unsigned_word64b", Shift_right_unsigned_word64b), + ("__int31_to_int32b", Int31_to_int32b), ("__int31_to_int32ub", Int31_to_int32ub), ("__int32b_to_int31", Int32b_to_int31), ("__int32b_to_word32b", Int32b_to_word32b), ("__int32ub_to_int31", Int32ub_to_int31), + ("__int31_to_int64b",Int31_to_int64b), ("__int31_to_int64ub",Int31_to_int64ub), ("__int64b_to_int31",Int64b_to_int31), + ("__word31_to_word32b", Word31_to_word32b), ("__word31_to_word32ub", Word31_to_word32ub), ("__word32b_to_word31", Word32b_to_word31), ("__word32ub_to_word31", Word32ub_to_word31), ("__word31_to_word32ub_X", Word31_to_word32ub_X), ("__word31_to_word32b_X", Word31_to_word32b_X), ("__word32b_to_int32b", Word32b_to_int32b), ("__word32b_to_int32b_X", Word32b_to_int32b_X), ("__word32ub_to_int32ub", Word32ub_to_int32ub), ("__word31_to_int31", Word31_to_int31), ("__word32b_to_int31", Word32b_to_int31), ("__int32b_to_word31", Int32b_to_word31), ("__word32b_to_int31_X", Word32b_to_int31_X), + + ("__word64ub_to_int32ub", Word64ub_to_int32ub), ("__word32ub_to_word64ub", Word32ub_to_word64ub), ("__word64ub_to_word32ub", Word64ub_to_word32ub), + ("__word64ub_to_int64ub", Word64ub_to_int64ub), + ("__word64ub_to_int64ub_X", Word64ub_to_int64ub_X), + + ("__word31_to_word64b", Word31_to_word64b), + ("__word31_to_word64b_X", Word31_to_word64b_X), + ("__word64b_to_int31", Word64b_to_int31), + ("__word64b_to_int64b_X", Word64b_to_int64b_X), + ("__word64b_to_int64b", Word64b_to_int64b), + ("__word32b_to_word64b", Word32b_to_word64b), + ("__word32b_to_word64b_X", Word32b_to_word64b_X), + ("__word64b_to_word32b", Word64b_to_word32b), + ("__word64b_to_int31_X", Word64b_to_int31_X), + + ("__int32b_to_int64b", Int32b_to_int64b), + ("__int32ub_to_int64ub", Int32ub_to_int64ub), + ("__int64b_to_word64b", Int64b_to_word64b), + ("__int64ub_to_word64ub", Int64ub_to_word64ub), + + ("__int64ub_to_int32ub", Int64ub_to_int32ub), + + ("__int63_to_int64b", Int63_to_int64b), + ("__int64b_to_int63", Int64b_to_int63), + ("__word32b_to_word63", Word32b_to_word63), + ("__word63_to_word32b", Word63_to_word32b), + ("__word63_to_word31", Word63_to_word31), + ("__word31_to_word63", Word31_to_word63), + ("__word31_to_word63_X", Word31_to_word63_X), + ("__word63_to_word64b", Word63_to_word64b), + ("__word63_to_word64b_X", Word63_to_word64b_X), + ("__word64b_to_word63", Word64b_to_word63), + + ("__int31_to_int63", Int31_to_int63), + ("__int63_to_int31", Int63_to_int31), + ("__int32b_to_int63", Int32b_to_int63), + ("__int63_to_int32b", Int63_to_int32b), + ("__word32b_to_int63", Word32b_to_int63), + ("__word32b_to_int63_X", Word32b_to_int63_X), + ("__word64b_to_word31", Word64b_to_word31), + + ("__word64b_to_int63", Word64b_to_int63), + ("__word64b_to_int63_X", Word64b_to_int63_X), + + ("__int63_to_int64ub", Int63_to_int64ub), + + ("__int64ub_to_int63", Int64ub_to_int63), + ("__word63_to_word64ub", Word63_to_word64ub), + ("__word63_to_word64ub_X", Word63_to_word64ub_X), + + ("__word64ub_to_word31", Word64ub_to_word31), + ("__int64ub_to_int31", Int64ub_to_int31), + ("__word31_to_word64ub", Word31_to_word64ub), + ("__word31_to_word64ub_X", Word31_to_word64ub_X), + ("__word32ub_to_int64ub", Word32ub_to_int64ub), + ("__word32ub_to_int64ub_X", Word32ub_to_int64ub_X), + ("__word32ub_to_word64ub_X", Word32ub_to_word64ub_X), + ("__exn_ptr", Exn_ptr), ("__fresh_exname", Fresh_exname), ("__bytetable_sub", Bytetable_sub), ("__bytetable_size", Bytetable_size), ("__bytetable_update", Bytetable_update), ("word_sub0", Word_sub0), ("word_update0", Word_update0), ("table_size", Table_size), ("__is_null", Is_null), ("__serverGetCtx", ServerGetCtx), - ("__plus_f64", Plus_f64), - ("__minus_f64", Minus_f64), - ("__mul_f64", Mul_f64), - ("__div_f64", Div_f64), ("__max_f64", Max_f64), ("__min_f64", Min_f64), ("__real_to_f64", Real_to_f64), ("__f64_to_real", F64_to_real), ("__sqrt_f64", Sqrt_f64), - ("__neg_f64", Neg_f64), - ("__abs_f64", Abs_f64), ("__int_to_f64", Int_to_f64), ("__blockf64_update_real", Blockf64_update_real), ("__blockf64_sub_real", Blockf64_sub_real), @@ -136,30 +345,65 @@ fun is_flow_prim (p:prim) : bool = | Equal_word31 => true | Equal_word32ub => true | Equal_word32b => true + | Equal_int63 => true + | Equal_int64ub => true + | Equal_int64b => true + | Equal_word63 => true + | Equal_word64ub => true + | Equal_word64b => true + | Less_int31 => true | Less_int32ub => true | Less_int32b => true | Less_word31 => true | Less_word32ub => true | Less_word32b => true + | Less_int63 => true + | Less_int64ub => true + | Less_int64b => true + | Less_word63 => true + | Less_word64ub => true + | Less_word64b => true + | Lesseq_int31 => true | Lesseq_int32ub => true | Lesseq_int32b => true | Lesseq_word31 => true | Lesseq_word32ub => true | Lesseq_word32b => true + | Lesseq_int63 => true + | Lesseq_int64ub => true + | Lesseq_int64b => true + | Lesseq_word63 => true + | Lesseq_word64ub => true + | Lesseq_word64b => true + | Greater_int31 => true | Greater_int32ub => true | Greater_int32b => true | Greater_word31 => true | Greater_word32ub => true | Greater_word32b => true + | Greater_int63 => true + | Greater_int64ub => true + | Greater_int64b => true + | Greater_word63 => true + | Greater_word64ub => true + | Greater_word64b => true + | Greatereq_int31 => true | Greatereq_int32ub => true | Greatereq_int32b => true | Greatereq_word31 => true | Greatereq_word32ub => true | Greatereq_word32b => true + | Greatereq_int63 => true + | Greatereq_int64ub => true + | Greatereq_int64b => true + | Greatereq_word63 => true + | Greatereq_word64ub => true + | Greatereq_word64b => true + | Less_f64 => true | Lesseq_f64 => true | Greater_f64 => true @@ -174,91 +418,193 @@ fun pp_prim (p:prim) : string = | Equal_word31 => "Equal_word31" | Equal_word32ub => "Equal_word32ub" | Equal_word32b => "Equal_word32b" + | Equal_int63 => "Equal_int63" + | Equal_int64ub => "Equal_int64ub" + | Equal_int64b => "Equal_int64b" + | Equal_word63 => "Equal_word63" + | Equal_word64ub => "Equal_word64ub" + | Equal_word64b => "Equal_word64b" + | Less_int31 => "Less_int31" | Less_int32ub => "Less_int32ub" | Less_int32b => "Less_int32b" | Less_word31 => "Less_word31" | Less_word32ub => "Less_word32ub" | Less_word32b => "Less_word32b" + | Less_int63 => "Less_int63" + | Less_int64ub => "Less_int64ub" + | Less_int64b => "Less_int64b" + | Less_word63 => "Less_word63" + | Less_word64ub => "Less_word64ub" + | Less_word64b => "Less_word64b" + | Lesseq_int31 => "Lesseq_int31" | Lesseq_int32ub => "Lesseq_int32ub" | Lesseq_int32b => "Lesseq_int32b" | Lesseq_word31 => "Lesseq_word31" | Lesseq_word32ub => "Lesseq_word32ub" | Lesseq_word32b => "Lesseq_word32b" + | Lesseq_int63 => "Lesseq_int63" + | Lesseq_int64ub => "Lesseq_int64ub" + | Lesseq_int64b => "Lesseq_int64b" + | Lesseq_word63 => "Lesseq_word63" + | Lesseq_word64ub => "Lesseq_word64ub" + | Lesseq_word64b => "Lesseq_word64b" + | Greater_int31 => "Greater_int31" | Greater_int32ub => "Greater_int32ub" | Greater_int32b => "Greater_int32b" | Greater_word31 => "Greater_word31" | Greater_word32ub => "Greater_word32ub" | Greater_word32b => "Greater_word32b" + | Greater_int63 => "Greater_int63" + | Greater_int64ub => "Greater_int64ub" + | Greater_int64b => "Greater_int64b" + | Greater_word63 => "Greater_word63" + | Greater_word64ub => "Greater_word64ub" + | Greater_word64b => "Greater_word64b" + | Greatereq_int31 => "Greatereq_int31" | Greatereq_int32ub => "Greatereq_int32ub" | Greatereq_int32b => "Greatereq_int32b" | Greatereq_word31 => "Greatereq_word31" | Greatereq_word32ub => "Greatereq_word32ub" | Greatereq_word32b => "Greatereq_word32b" + | Greatereq_int63 => "Greatereq_int63" + | Greatereq_int64ub => "Greatereq_int64ub" + | Greatereq_int64b => "Greatereq_int64b" + | Greatereq_word63 => "Greatereq_word63" + | Greatereq_word64ub => "Greatereq_word64ub" + | Greatereq_word64b => "Greatereq_word64b" + | Less_real => "Less_real" | Lesseq_real => "Lesseq_real" | Greater_real => "Greater_real" | Greatereq_real => "Greatereq_real" + | Less_f64 => "Less_f64" | Lesseq_f64 => "Lesseq_f64" | Greater_f64 => "Greater_f64" | Greatereq_f64 => "Greatereq_f64" + | Plus_int31 => "Plus_int31" | Plus_int32ub => "Plus_int32ub" | Plus_int32b => "Plus_int32b" | Plus_word31 => "Plus_word31" | Plus_word32ub => "Plus_word32ub" | Plus_word32b => "Plus_word32b" + | Plus_int63 => "Plus_int63" + | Plus_int64ub => "Plus_int64ub" + | Plus_int64b => "Plus_int64b" + | Plus_word63 => "Plus_word63" + | Plus_word64ub => "Plus_word64ub" + | Plus_word64b => "Plus_word64b" | Plus_real => "Plus_real" + | Plus_f64 => "Plus_f64" + | Minus_int31 => "Minus_int31" | Minus_int32ub => "Minus_int32ub" | Minus_int32b => "Minus_int32b" | Minus_word31 => "Minus_word31" | Minus_word32ub => "Minus_word32ub" | Minus_word32b => "Minus_word32b" + | Minus_int63 => "Minus_int63" + | Minus_int64ub => "Minus_int64ub" + | Minus_int64b => "Minus_int64b" + | Minus_word63 => "Minus_word63" + | Minus_word64ub => "Minus_word64ub" + | Minus_word64b => "Minus_word64b" | Minus_real => "Minus_real" + | Minus_f64 => "Minus_f64" + | Mul_int31 => "Mul_int31" | Mul_int32ub => "Mul_int32ub" | Mul_int32b => "Mul_int32b" | Mul_word31 => "Mul_word31" | Mul_word32ub => "Mul_word32ub" | Mul_word32b => "Mul_word32b" + | Mul_int63 => "Mul_int63" + | Mul_int64ub => "Mul_int64ub" + | Mul_int64b => "Mul_int64b" + | Mul_word63 => "Mul_word63" + | Mul_word64ub => "Mul_word64ub" + | Mul_word64b => "Mul_word64b" | Mul_real => "Mul_real" + | Mul_f64 => "Mul_f64" + | Div_real => "Div_real" + | Div_f64 => "Div_f64" + | Neg_int31 => "Neg_int31" | Neg_int32ub => "Neg_int32ub" | Neg_int32b => "Neg_int32b" + | Neg_int63 => "Neg_int63" + | Neg_int64ub => "Neg_int64ub" + | Neg_int64b => "Neg_int64b" | Neg_real => "Neg_real" + | Neg_f64 => "Neg_f64" + | Abs_int31 => "Abs_int31" | Abs_int32ub => "Abs_int32ub" | Abs_int32b => "Abs_int32b" + | Abs_int63 => "Abs_int63" + | Abs_int64ub => "Abs_int64ub" + | Abs_int64b => "Abs_int64b" | Abs_real => "Abs_real" + | Abs_f64 => "Abs_f64" + | Andb_word31 => "Andb_word31" | Andb_word32ub => "Andb_word32ub" | Andb_word32b => "Andb_word32b" + | Andb_word63 => "Andb_word63" + | Andb_word64ub => "Andb_word64ub" + | Andb_word64b => "Andb_word64b" + | Orb_word31 => "Orb_word31" | Orb_word32ub => "Orb_word32ub" | Orb_word32b => "Orb_word32b" + | Orb_word63 => "Orb_word63" + | Orb_word64ub => "Orb_word64ub" + | Orb_word64b => "Orb_word64b" + | Xorb_word31 => "Xorb_word31" | Xorb_word32ub => "Xorb_word32ub" | Xorb_word32b => "Xorb_word32b" + | Xorb_word63 => "Xorb_word63" + | Xorb_word64ub => "Xorb_word64ub" + | Xorb_word64b => "Xorb_word64b" + | Shift_left_word31 => "Shift_left_word31" | Shift_left_word32ub => "Shift_left_word32ub" | Shift_left_word32b => "Shift_left_word32b" + | Shift_left_word63 => "Shift_left_word63" + | Shift_left_word64ub => "Shift_left_word64ub" + | Shift_left_word64b => "Shift_left_word64b" + | Shift_right_signed_word31 => "Shift_right_signed_word31" | Shift_right_signed_word32ub => "Shift_right_signed_word32ub" | Shift_right_signed_word32b => "Shift_right_signed_word32b" + | Shift_right_signed_word63 => "Shift_right_signed_word63" + | Shift_right_signed_word64ub => "Shift_right_signed_word64ub" + | Shift_right_signed_word64b => "Shift_right_signed_word64b" + | Shift_right_unsigned_word31 => "Shift_right_unsigned_word31" | Shift_right_unsigned_word32ub => "Shift_right_unsigned_word32ub" | Shift_right_unsigned_word32b => "Shift_right_unsigned_word32b" + | Shift_right_unsigned_word63 => "Shift_right_unsigned_word63" + | Shift_right_unsigned_word64ub => "Shift_right_unsigned_word64ub" + | Shift_right_unsigned_word64b => "Shift_right_unsigned_word64b" + | Int31_to_int32b => "Int31_to_int32b" | Int31_to_int32ub => "Int31_to_int32ub" | Int32b_to_int31 => "Int32b_to_int31" | Int32b_to_word32b => "Int32b_to_word32b" | Int32ub_to_int31 => "Int32ub_to_int31" + + | Int31_to_int64b => "Int31_to_int64b" + | Int31_to_int64ub => "Int31_to_int64ub" + | Int64b_to_int31 => "Int64b_to_int31" + | Word31_to_word32b => "Word31_to_word32b" | Word31_to_word32ub => "Word31_to_word32ub" | Word32b_to_word31 => "Word32b_to_word31" @@ -272,6 +618,66 @@ fun pp_prim (p:prim) : string = | Word32b_to_int31 => "Word32b_to_int31" | Int32b_to_word31 => "Int32b_to_word31" | Word32b_to_int31_X => "Word32b_to_int31_X" + + | Word64ub_to_int32ub => "Word64ub_to_int32ub" + | Word32ub_to_word64ub => "Word32ub_to_word64ub" + | Word64ub_to_word32ub => "Word64ub_to_word32ub" + | Word64ub_to_int64ub => "Word64ub_to_int64ub" + | Word64ub_to_int64ub_X => "Word64ub_to_int64ub_X" + + | Word31_to_word64b => "Word31_to_word64b" + | Word31_to_word64b_X => "Word31_to_word64b_X" + | Word64b_to_int31 => "Word64b_to_int31" + | Word64b_to_int64b_X => "Word64b_to_int64b_X" + | Word64b_to_int64b => "Word64b_to_int64b" + | Word32b_to_word64b => "Word32b_to_word64b" + | Word32b_to_word64b_X => "Word32b_to_word64b_X" + | Word64b_to_word32b => "Word64b_to_word32b" + | Word64b_to_int31_X => "Word64b_to_int31_X" + + | Int32b_to_int64b => "Int32b_to_int64b" + | Int32ub_to_int64ub => "Int32ub_to_int64ub" + | Int64b_to_word64b => "Int64b_to_word64b" + | Int64ub_to_word64ub => "Int64ub_to_word64ub" + + | Int64ub_to_int32ub => "Int64ub_to_int32ub" + + | Int63_to_int64b => "Int63_to_int64b" + | Int64b_to_int63 => "Int64b_to_int63" + | Word32b_to_word63 => "Word32b_to_word63" + | Word63_to_word32b => "Word63_to_word32b" + | Word63_to_word31 => "Word63_to_word31" + | Word31_to_word63 => "Word31_to_word63" + | Word31_to_word63_X => "Word31_to_word63_X" + | Word63_to_word64b => "Word63_to_word64b" + | Word63_to_word64b_X => "Word63_to_word64b_X" + | Word64b_to_word63 => "Word64b_to_word63" + + | Int31_to_int63 => "Int31_to_int63" + | Int63_to_int31 => "Int63_to_int31" + | Int32b_to_int63 => "Int32b_to_int63" + | Int63_to_int32b => "Int63_to_int32b" + | Word32b_to_int63 => "Word32b_to_int63" + | Word32b_to_int63_X => "Word32b_to_int63_X" + | Word64b_to_word31 => "Word64b_to_word31" + + | Word64b_to_int63 => "Word64b_to_int63" + | Word64b_to_int63_X => "Word64b_to_int63_X" + + | Int63_to_int64ub => "Int63_to_int64ub" + + | Int64ub_to_int63 => "Int64ub_to_int63" + | Word63_to_word64ub => "Word63_to_word64ub" + | Word63_to_word64ub_X => "Word63_to_word64ub_X" + + | Word64ub_to_word31 => "Word64ub_to_word31" + | Int64ub_to_int31 => "Int64ub_to_int31" + | Word31_to_word64ub => "Word31_to_word64ub" + | Word31_to_word64ub_X => "Word31_to_word64ub_X" + | Word32ub_to_int64ub => "Word32ub_to_int64ub" + | Word32ub_to_int64ub_X => "Word32ub_to_int64ub_X" + | Word32ub_to_word64ub_X => "Word32ub_to_word64ub_X" + | Exn_ptr => "Exn_ptr" | Fresh_exname => "Fresh_exname" | Bytetable_sub => "Bytetable_sub" @@ -282,17 +688,11 @@ fun pp_prim (p:prim) : string = | Table_size => "Table_size" | Is_null => "Is_null" | ServerGetCtx => "ServerGetCtx" - | Plus_f64 => "Plus_f64" - | Minus_f64 => "Minus_f64" - | Mul_f64 => "Mul_f64" - | Div_f64 => "Div_f64" | Max_f64 => "Max_f64" | Min_f64 => "Min_f64" | Real_to_f64 => "Real_to_f64" | F64_to_real => "F64_to_real" | Sqrt_f64 => "Sqrt_f64" - | Neg_f64 => "Neg_f64" - | Abs_f64 => "Abs_f64" | Int_to_f64 => "Int_to_f64" | Blockf64_update_real => "Blockf64_update_real" | Blockf64_sub_real => "Blockf64_sub_real" diff --git a/src/Compiler/Backend/SUBST_AND_SIMPLIFY.sml b/src/Compiler/Backend/SUBST_AND_SIMPLIFY.sml index f4a87c9f7..f78851cf8 100644 --- a/src/Compiler/Backend/SUBST_AND_SIMPLIFY.sml +++ b/src/Compiler/Backend/SUBST_AND_SIMPLIFY.sml @@ -6,7 +6,7 @@ signature SUBST_AND_SIMPLIFY = *) - type place + type place type phsize type pp = int type lvar @@ -27,8 +27,8 @@ signature SUBST_AND_SIMPLIFY = | FLOW_VAR_ATY of lvar * label * label | DROPPED_RVAR_ATY | PHREG_ATY of reg - | INTEGER_ATY of {value: Int32.int, precision: int} - | WORD_ATY of {value: Word32.word, precision: int} + | INTEGER_ATY of {value: IntInf.int, precision: int} + | WORD_ATY of {value: IntInf.int, precision: int} | UNIT_ATY val eq_aty : Aty * Aty -> bool @@ -43,11 +43,3 @@ signature SUBST_AND_SIMPLIFY = val pr_offset : offset -> string val pr_aty : Aty -> string end - - - - - - - - diff --git a/src/Compiler/Backend/SubstAndSimplify.sml b/src/Compiler/Backend/SubstAndSimplify.sml index c696a63c8..d7aeab39f 100644 --- a/src/Compiler/Backend/SubstAndSimplify.sml +++ b/src/Compiler/Backend/SubstAndSimplify.sml @@ -69,8 +69,8 @@ struct | FLOW_VAR_ATY of lvar * label * label | DROPPED_RVAR_ATY | PHREG_ATY of reg - | INTEGER_ATY of {value: Int32.int, precision: int} - | WORD_ATY of {value: Word32.word, precision: int} + | INTEGER_ATY of {value: IntInf.int, precision: int} + | WORD_ATY of {value: IntInf.int, precision: int} | UNIT_ATY fun pr_offset offset = CalcOffset.pr_offset offset @@ -82,8 +82,8 @@ struct | pr_aty(FLOW_VAR_ATY(lv,l1,l2)) = "FV(" ^ Lvars.pr_lvar lv ^ ")" | pr_aty(DROPPED_RVAR_ATY) = "DROPPED_RVAR" | pr_aty(PHREG_ATY phreg) = pr_phreg phreg - | pr_aty(INTEGER_ATY {value, precision}) = Int32.toString value - | pr_aty(WORD_ATY {value, precision}) = Word32.toString value + | pr_aty(INTEGER_ATY {value, precision}) = IntInf.toString value + | pr_aty(WORD_ATY {value, precision}) = "0w" ^ IntInf.toString value | pr_aty(UNIT_ATY) = "(.)" fun eq_aty(REG_I_ATY offset1,REG_I_ATY offset2) = offset1 = offset2 @@ -145,17 +145,6 @@ struct fun atom_to_aty_opt(NONE,ATYmap,RHOmap) = NONE | atom_to_aty_opt(SOME atom,ATYmap,RHOmap) = SOME(atom_to_aty(atom,ATYmap,RHOmap)) -(*defined above ; mael 2001-04-10 - fun eq_aty(REG_I_ATY offset1,REG_I_ATY offset2) = offset1 = offset2 - | eq_aty(REG_F_ATY offset1,REG_F_ATY offset2) = offset1 = offset2 - | eq_aty(STACK_ATY offset1,STACK_ATY offset2) = offset1 = offset2 - | eq_aty(DROPPED_RVAR_ATY,DROPPED_RVAR_ATY) = true - | eq_aty(PHREG_ATY phreg1,PHREG_ATY phreg2) = RI.reg_eq(phreg1,phreg2) - | eq_aty(INTEGER_ATY i1,INTEGER_ATY i2) = i1 = i2 - | eq_aty(WORD_ATY i1,WORD_ATY i2) = i1 = i2 - | eq_aty(UNIT_ATY,UNIT_ATY) = true - | eq_aty _ = false -*) fun sma_to_sma(LS.ATTOP_LI(atom,pp),ATYmap,RHOmap) = LS.ATTOP_LI(atom_to_aty(atom,ATYmap,RHOmap),pp) | sma_to_sma(LS.ATTOP_LF(atom,pp),ATYmap,RHOmap) = LS.ATTOP_LF(atom_to_aty(atom,ATYmap,RHOmap),pp) | sma_to_sma(LS.ATTOP_FI(atom,pp),ATYmap,RHOmap) = LS.ATTOP_FI(atom_to_aty(atom,ATYmap,RHOmap),pp) diff --git a/src/Compiler/Backend/X64/CodeGenUtilX64.sml b/src/Compiler/Backend/X64/CodeGenUtilX64.sml index f27e18585..993d700b6 100644 --- a/src/Compiler/Backend/X64/CodeGenUtilX64.sml +++ b/src/Compiler/Backend/X64/CodeGenUtilX64.sml @@ -69,12 +69,12 @@ struct (****************************************************************) (* Add Dynamic Flags *) (****************************************************************) - val _ = Flags.add_bool_entry {long="comments_in_x64_asmcode", short=NONE, item=ref false, - menu=["Debug", "comments in x64 assembler code"], neg=false, - desc="Insert comments in x64 assembler code."} + val _ = Flags.add_bool_entry {long="comments_in_asmcode", short=NONE, item=ref false, + menu=["Debug", "comments in assembler code"], neg=false, + desc="Insert comments in assembler code."} val jump_tables = true - val comments_in_asmcode = Flags.lookup_flag_entry "comments_in_x64_asmcode" + val comments_in_asmcode = Flags.lookup_flag_entry "comments_in_asmcode" val gc_p = Flags.is_on0 "garbage_collection" val tag_pairs_p = Flags.is_on0 "tag_pairs" @@ -145,15 +145,15 @@ struct | r => die ("lv_to_reg.no: " ^ I.pr_reg r) (* Convert ~n to -n; works for all int32 values including Int32.minInt *) - fun intToStr (i : Int32.int) : string = + fun intToStr (i : IntInf.int) : string = let fun tr s = case explode s of #"~"::rest => implode (#"-"::rest) | _ => s - in tr (Int32.toString i) + in tr (IntInf.toString i) end - fun wordToStr (w : Word32.word) : string = - "0x" ^ Word32.toString w + fun wordToStr (w : IntInf.int) : string = + "0x" ^ IntInf.fmt StringCvt.HEX w (* Convert ~n to -n *) fun i2s i = if i >= 0 then Int.toString i @@ -199,33 +199,23 @@ struct if d = b andalso isZeroOffset n then C else I.leaq(D(offset_bytes n, b), R d) :: C - fun mkIntAty i = SS.INTEGER_ATY {value=Int32.fromInt i, - precision=if BI.tag_values() then 31 else 32} - - fun maybeTagInt {value: Int32.int, precision:int} : Int32.int = - case precision - of 31 => ((2 * value + 1) (* use tagged-unboxed representation *) - handle Overflow => die "maybeTagInt.Overflow") - | 32 => value (* use untagged representation - maybe boxed *) - | _ => die "maybeTagInt" - - fun maybeTagWord {value: Word32.word, precision:int} : Word32.word = - case precision - of 31 => (* use tagged representation *) - let val w = 0w2 * value + 0w1 - in if w < value then die "maybeTagWord.Overflow" - else w - end - | 32 => value (* use untagged representation - maybe boxed *) - | _ => die "maybeTagWord" + fun mkIntAty i = SS.INTEGER_ATY {value=IntInf.fromInt i, + precision=if BI.tag_values() then 63 else 64} + + fun maybeTagIntOrWord {value: IntInf.int, precision:int} : IntInf.int = + if precision = 31 orelse precision = 63 + then 2 * value + 1 (* use tagged-unboxed representation *) + else if precision = 32 orelse precision = 64 + then value (* use untagged representation - maybe boxed *) + else die "maybeTagIntOrWord" (* formatting of immediate integer and word values *) - fun fmtInt a : string = intToStr(maybeTagInt a) - fun fmtWord a : string = wordToStr(maybeTagWord a) + fun fmtInt a : string = intToStr(maybeTagIntOrWord a) + fun fmtWord a : string = wordToStr(maybeTagIntOrWord a) (* Store a constant *) fun store_immed (w:Word32.word,r:reg,offset:Offset,C) = - I.movq(I (wordToStr w), D(offset_bytes offset,r)) :: C + I.movq(I (wordToStr (Word32.toLargeInt w)), D(offset_bytes offset,r)) :: C fun move_immed (0,R d,C) = I.xorq(R d, R d) :: C | move_immed (x,d:ea,C) = I.movq(I (intToStr x), d) :: C @@ -250,7 +240,7 @@ struct (* returns true if boxed representation is used for * integers of the given precision *) fun boxedNum (precision:int) : bool = - precision > 31 andalso BI.tag_values() + (precision = 32 orelse precision = 64) andalso BI.tag_values() (* Find a register for aty and generate code to store into the aty *) fun resolve_aty_def (SS.STACK_ATY offset,t:reg,size_ff,C) = @@ -265,7 +255,7 @@ struct fun move_unit (ea,C) = if BI.tag_values() then - move_immed(Int32.fromInt BI.ml_unit,ea,C) (* gc needs value! *) + move_immed(IntInf.fromInt BI.ml_unit,ea,C) (* gc needs value! *) else C (* Make sure that the aty ends up in register dst_reg *) @@ -381,17 +371,21 @@ struct fun default () = move_aty_into_reg(aty,t,size_ff, store_indexed(b,n,R t,C)) - fun direct_word (w:{value: Word32.word, precision:int}) : bool = + fun direct_word (w:{value: IntInf.int, precision:int}) : bool = not(boxedNum(#precision w)) andalso case #precision w of - 32 => #value w <= 0wxFFFF - | 31 => #value w <= 0wx7FFF + 31 => #value w <= 0x7FFF + | 32 => #value w <= 0xFFFF + | 63 => #value w <= 0x7FFF + | 64 => #value w <= 0xFFFF | _ => die "store_aty_indexed.direct_word - weird precision" - fun direct_int (i:{value: Int32.int, precision:int}) = + fun direct_int (i:{value: IntInf.int, precision:int}) = not(boxedNum(#precision i)) andalso case #precision i of - 32 => #value i <= 0x7FFF andalso #value i > ~0x8000 - | 31 => #value i <= 0x3FFF andalso #value i > ~0x4000 + 31 => #value i <= 0x3FFF andalso #value i > ~0x4000 + | 32 => #value i <= 0x7FFF andalso #value i > ~0x8000 + | 63 => #value i <= 0x3FFF andalso #value i > ~0x4000 + | 64 => #value i <= 0x7FFF andalso #value i > ~0x8000 | _ => die "store_aty_indexed.direct_int - weird precision" in case aty of @@ -871,7 +865,7 @@ struct in copy(t,tmp_reg1, I.push(LA l) :: - move_immed(Int32.fromInt n, R tmp_reg0, + move_immed(IntInf.fromInt n, R tmp_reg0, I.jmp(L(NameLab "__allocate")) :: (* assumes args in tmp_reg1 and tmp_reg0; result in tmp_reg1 *) I.lab l :: post_prof @@ -899,7 +893,7 @@ struct in copy(t,tmp_reg1, I.push(LA l) :: - move_immed(Int32.fromInt n, R tmp_reg0, + move_immed(IntInf.fromInt n, R tmp_reg0, I.jmp(L(NameLab "__allocate")) :: (* assumes args in tmp_reg1 and tmp_reg0; result in tmp_reg1 *) I.lab l :: post (t,C))) @@ -1180,7 +1174,7 @@ struct default, opr: I.ea, compile_insts, - toInt : 'a -> Int32.int, + toInt : 'a -> IntInf.int, C) = let val sels = map (fn (i,e) => (toInt i, e)) sels @@ -1200,7 +1194,7 @@ struct compile_insts, label, jmp, - fn (sel1,sel2) => Int32.abs(sel1-sel2), (* sel_dist *) + fn (sel1,sel2) => IntInf.abs(sel1-sel2), (* sel_dist *) fn (lab,sel,_,C) => (I.movq(opr, R tmp_reg0) :: I.salq(I "3", R tmp_reg0) :: I.push(R tmp_reg1) :: @@ -1245,20 +1239,24 @@ struct C)) end - fun cmpi_kill_tmp01 {box} (jump,x,y,d,size_ff,C) = + fun cmpi_kill_tmp01 {box,quad} jump (x,y,d,size_ff,C) = let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) val true_lab = new_local_lab "true" val cont_lab = new_local_lab "cont" + val (inst_cmp, maybeDoubleOfQuadReg) = + if quad + then (I.cmpq, fn r => r) + else (I.cmpl, I.doubleOfQuadReg) fun compare C = if box then I.movq(D("8",y_reg), R tmp_reg1) :: I.movq(D("8",x_reg), R tmp_reg0) :: - I.cmpl(R (I.doubleOfQuadReg tmp_reg1), - R (I.doubleOfQuadReg tmp_reg0)) :: C - else I.cmpl(R (I.doubleOfQuadReg y_reg), - R (I.doubleOfQuadReg x_reg)) :: C + inst_cmp(R (maybeDoubleOfQuadReg tmp_reg1), + R (maybeDoubleOfQuadReg tmp_reg0)) :: C + else inst_cmp(R (maybeDoubleOfQuadReg y_reg), + R (maybeDoubleOfQuadReg x_reg)) :: C in x_C( y_C( @@ -1271,28 +1269,37 @@ struct I.lab cont_lab :: C'))) end - fun cmpi_and_jmp_kill_tmp01 (jump,x,y,lab_t,lab_f,size_ff,C) = + fun cmpi_and_jmp_kill_tmp01 {quad} (jump,x,y,lab_t,lab_f,size_ff,C) = let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) + val (inst_cmp, maybeDoubleOfQuadReg) = + if quad + then (I.cmpq, fn r => r) + else (I.cmpl, I.doubleOfQuadReg) in x_C(y_C( - I.cmpl(R (I.doubleOfQuadReg y_reg), R (I.doubleOfQuadReg x_reg)) :: + inst_cmp(R (maybeDoubleOfQuadReg y_reg), + R (maybeDoubleOfQuadReg x_reg)) :: jump lab_t :: I.jmp (L lab_f) :: rem_dead_code C)) end (* version with boxed arguments; assume tagging is enabled *) - fun cmpbi_and_jmp_kill_tmp01 (jump,x,y,lab_t,lab_f,size_ff,C) = + fun cmpbi_and_jmp_kill_tmp01 {quad} (jump,x,y,lab_t,lab_f,size_ff,C) = if BI.tag_values() then let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) + val (inst_cmp, maybeDoubleOfQuadReg) = + if quad + then (I.cmpq, fn r => r) + else (I.cmpl, I.doubleOfQuadReg) in x_C(y_C( I.movq(D("8", y_reg), R tmp_reg1) :: I.movq(D("8", x_reg), R tmp_reg0) :: - I.cmpl(R (I.doubleOfQuadReg tmp_reg1), - R (I.doubleOfQuadReg tmp_reg0)) :: + inst_cmp(R (maybeDoubleOfQuadReg tmp_reg1), + R (maybeDoubleOfQuadReg tmp_reg0)) :: jump lab_t :: I.jmp (L lab_f) :: rem_dead_code C)) end @@ -1318,44 +1325,52 @@ struct fun jump_overflow C = I.jo (NameLab "__raise_overflow") :: C - fun sub_num_kill_tmp01 {ovf : bool, tag: bool} (x,y,d,size_ff,C) = + fun sub_num_kill_tmp01 {ovf,tag,quad} (x,y,d,size_ff,C) = let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) fun check_ovf C = if ovf then jump_overflow C else C fun do_tag C = if tag then I.addq(I "1",R d_reg) :: check_ovf C (* check twice *) else C + val (inst_sub, maybeDoubleOfQuadReg) = + if quad + then (I.subq, fn r => r) + else (I.subl, I.doubleOfQuadReg) in x_C(y_C( copy(y_reg, tmp_reg1, copy(x_reg, d_reg, - I.subl(R (I.doubleOfQuadReg tmp_reg1), - R (I.doubleOfQuadReg d_reg)) :: + inst_sub(R (maybeDoubleOfQuadReg tmp_reg1), + R (maybeDoubleOfQuadReg d_reg)) :: check_ovf (do_tag C'))))) end - fun add_num_kill_tmp01 {ovf,tag} (x,y,d,size_ff,C) = (* Be careful - when tag and ovf, add may - * raise overflow when it is not supposed - * to, if one is not careful! sub_num above - * is ok, I think! mael 2001-05-19 *) - let fun default () = + fun add_num_kill_tmp01 {ovf,tag,quad} (x,y,d,size_ff,C) = (* Be careful - when tag and ovf, add may + * raise overflow when it is not supposed + * to, if one is not careful! sub_num above + * is ok, I think! mael 2001-05-19 *) + let val (inst_add, inst_sar, inst_cmp, maybeDoubleOfQuadReg) = + if quad + then (I.addq, I.sarq, I.cmpq, fn r => r) + else (I.addl, I.sarl, I.cmpl, I.doubleOfQuadReg) + fun default () = let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) fun check_ovf C = if ovf then jump_overflow C else C - fun do_tag C = if tag then I.addl(I "-1", R (I.doubleOfQuadReg d_reg)) :: check_ovf C + fun do_tag C = if tag then inst_add(I "-1", R (maybeDoubleOfQuadReg d_reg)) :: check_ovf C else C in if tag andalso ovf then (x_C(y_C( - copy(y_reg, tmp_reg1, I.sarl(I "1", R (I.doubleOfQuadReg tmp_reg1)) :: (* t1 = untag y *) - copy(x_reg, tmp_reg0, I.sarl(I "1", R (I.doubleOfQuadReg tmp_reg0)) :: (* t0 = untag x *) - I.addl(R (I.doubleOfQuadReg tmp_reg0), - R (I.doubleOfQuadReg tmp_reg1)) :: (* t1 = t1 + t0 *) + copy(y_reg, tmp_reg1, inst_sar(I "1", R (maybeDoubleOfQuadReg tmp_reg1)) :: (* t1 = untag y *) + copy(x_reg, tmp_reg0, inst_sar(I "1", R (maybeDoubleOfQuadReg tmp_reg0)) :: (* t0 = untag x *) + inst_add(R (maybeDoubleOfQuadReg tmp_reg0), + R (maybeDoubleOfQuadReg tmp_reg1)) :: (* t1 = t1 + t0 *) copy(tmp_reg1, d_reg, I.leaq(DD("1", d_reg, d_reg, ""), R d_reg) :: (* d = tag d *) - I.sarl(I "1", R (I.doubleOfQuadReg d_reg)) :: (* d = untag d *) - I.cmpl(R (I.doubleOfQuadReg d_reg), - R (I.doubleOfQuadReg tmp_reg1)) :: + inst_sar(I "1", R (maybeDoubleOfQuadReg d_reg)) :: (* d = untag d *) + inst_cmp(R (maybeDoubleOfQuadReg d_reg), + R (maybeDoubleOfQuadReg tmp_reg1)) :: I.jne (NameLab "__raise_overflow") :: I.leaq(DD("1", d_reg, d_reg, ""), R d_reg) :: (* d = tag d *) C')))))) @@ -1363,8 +1378,8 @@ struct (x_C(y_C( copy(y_reg, tmp_reg1, copy(x_reg, d_reg, - I.addl(R (I.doubleOfQuadReg tmp_reg1), - R (I.doubleOfQuadReg d_reg)) :: + inst_add(R (maybeDoubleOfQuadReg tmp_reg1), + R (maybeDoubleOfQuadReg d_reg)) :: check_ovf (do_tag C')))))) end in case y of @@ -1374,89 +1389,112 @@ struct val (x_reg,x_C) = resolve_arg_aty(x,d_reg,size_ff) in x_C( copy(x_reg,d_reg, - I.addl(I (intToStr (2*value)), R (I.doubleOfQuadReg d_reg)) :: + inst_add(I (intToStr (2*value)), R (maybeDoubleOfQuadReg d_reg)) :: jump_overflow C')) end else default() | _ => default() end - fun mul_num_kill_tmp01 {ovf,tag} (x,y,d,size_ff,C) = (* does (1 * valOf Int31.minInt) raise Overflow ? *) + fun mul_num_kill_tmp01 {ovf,tag,quad} (x,y,d,size_ff,C) = (* does (1 * valOf Int31.minInt) raise Overflow ? *) let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) fun check_ovf C = if ovf then jump_overflow C else C + val (inst_imul, inst_add, inst_sub, inst_sar, inst_cmp, maybeDoubleOfQuadReg) = + if quad + then (I.imulq, I.addq, I.subq, I.sarq, I.cmpq, fn r => r) + else (I.imull, I.addl, I.subl, I.sarl, I.cmpl, I.doubleOfQuadReg) + in x_C(y_C( copy(y_reg, tmp_reg1, copy(x_reg, d_reg, if tag then (* A[i*j] = 1 + (A[i] >> 1) * (A[j]-1) *) - I.sarl(I "1", R (I.doubleOfQuadReg d_reg)) :: - I.subl(I "1", R (I.doubleOfQuadReg tmp_reg1)) :: - I.imull(R (I.doubleOfQuadReg tmp_reg1), - R (I.doubleOfQuadReg d_reg)) :: + inst_sar(I "1", R (maybeDoubleOfQuadReg d_reg)) :: + inst_sub(I "1", R (maybeDoubleOfQuadReg tmp_reg1)) :: + inst_imul(R (maybeDoubleOfQuadReg tmp_reg1), + R (maybeDoubleOfQuadReg d_reg)) :: check_ovf ( - I.addl(I "1", R (I.doubleOfQuadReg d_reg)) :: + inst_add(I "1", R (maybeDoubleOfQuadReg d_reg)) :: check_ovf C') else - I.imull(R (I.doubleOfQuadReg tmp_reg1), - R (I.doubleOfQuadReg d_reg)) :: + inst_imul(R (maybeDoubleOfQuadReg tmp_reg1), + R (maybeDoubleOfQuadReg d_reg)) :: check_ovf C')))) end - fun neg_int_kill_tmp0 {tag} (x,d,size_ff,C) = + fun neg_int_kill_tmp0 {tag,quad} (x,d,size_ff,C) = let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) - fun do_tag C = if tag then I.addl(I "2", R (I.doubleOfQuadReg d_reg)) :: + val (inst_add, inst_neg, maybeDoubleOfQuadReg) = + if quad + then (I.addq, I.negq, fn r => r) + else (I.addl, I.negl, I.doubleOfQuadReg) + fun do_tag C = if tag then inst_add (I "2", R (maybeDoubleOfQuadReg d_reg)) :: jump_overflow C else C in x_C(copy(x_reg, d_reg, - I.negl (R (I.doubleOfQuadReg d_reg)) :: + inst_neg (R (maybeDoubleOfQuadReg d_reg)) :: jump_overflow ( do_tag C'))) end - fun neg_int32b_kill_tmp0 (b,x,d,size_ff,C) = - if not(BI.tag_values()) then die "neg_int32b_kill_tmp0.tagging required" + fun neg_int_boxed_kill_tmp0 {quad:bool} (b,x,d,size_ff,C) = + if not(BI.tag_values()) then die "neg_int_boxed_kill_tmp0.tagging required" else let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) + val (inst_neg, maybeDoubleOfQuadReg) = + if quad + then (I.negq, fn r => r) + else (I.negl, I.doubleOfQuadReg) in x_C( load_indexed(R tmp_reg0,x_reg,WORDS 1, - I.negl(R (I.doubleOfQuadReg tmp_reg0)) :: + inst_neg(R (maybeDoubleOfQuadReg tmp_reg0)) :: jump_overflow ( move_aty_into_reg(b,d_reg,size_ff, store_indexed(d_reg,WORDS 1, R tmp_reg0, (* store negated value *) store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, C')))))) (* store tag *) end - fun abs_int_kill_tmp0 {tag} (x,d,size_ff,C) = + fun abs_int_kill_tmp0 {tag,quad} (x,d,size_ff,C) = let val cont_lab = new_local_lab "cont" val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) - fun do_tag C = if tag then I.addl(I "2", R (I.doubleOfQuadReg d_reg)) :: + val (inst_add, inst_cmp, inst_neg, maybeDoubleOfQuadReg) = + if quad + then (I.addq, I.cmpq, I.negq, fn r => r) + else (I.addl, I.cmpl, I.negl, I.doubleOfQuadReg) + fun do_tag C = if tag then inst_add(I "2", R (maybeDoubleOfQuadReg d_reg)) :: jump_overflow C else C in x_C(copy(x_reg,d_reg, - I.cmpl(I "0", R (I.doubleOfQuadReg d_reg)) :: + inst_cmp (I "0", R (maybeDoubleOfQuadReg d_reg)) :: I.jge cont_lab :: - I.negl (R (I.doubleOfQuadReg d_reg)) :: + inst_neg (R (maybeDoubleOfQuadReg d_reg)) :: jump_overflow ( do_tag ( I.lab cont_lab :: C')))) end - fun abs_int32b_kill_tmp0 (b,x,d,size_ff,C) = + fun abs_int_boxed_kill_tmp0 {quad} (b,x,d,size_ff,C) = + if not(BI.tag_values()) then die "abs_int_boxed_kill_tmp0.tagging required" + else let val cont_lab = new_local_lab "cont" val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff, C) + val (inst_cmp, inst_neg, maybeDoubleOfQuadReg) = + if quad + then (I.cmpq, I.negq, fn r => r) + else (I.cmpl, I.negl, I.doubleOfQuadReg) in x_C( load_indexed(R tmp_reg0,x_reg,WORDS 1, - I.cmpl(I "0", R (I.doubleOfQuadReg tmp_reg0)) :: + inst_cmp (I "0", R (maybeDoubleOfQuadReg tmp_reg0)) :: I.jge cont_lab :: - I.negl (R (I.doubleOfQuadReg tmp_reg0)) :: + inst_neg (R (maybeDoubleOfQuadReg tmp_reg0)) :: jump_overflow ( I.lab cont_lab :: move_aty_into_reg(b,d_reg,size_ff, @@ -1478,6 +1516,14 @@ struct in x_C(copy(x_reg, d_reg, I.sarl (I "1", R (I.doubleOfQuadReg d_reg)) :: C')) end + fun int31_to_int64ub (x,d,size_ff,C) = + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + in x_C(copy(x_reg, d_reg, I.sarl (I "1", R (I.doubleOfQuadReg d_reg)) :: + I.movslq (R (I.doubleOfQuadReg d_reg), + R d_reg) :: C')) + end + fun int32_to_int31 {boxedarg} (x,d,size_ff,C) = let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) @@ -1494,6 +1540,22 @@ struct * largest integer is odd! mael 2001-04-29 *) end + fun int64_to_int31 {boxedarg} (x,d,size_ff,C) = + let + val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + fun maybe_unbox C = if boxedarg then load_indexed(R d_reg,x_reg,WORDS 1,C) + else copy(x_reg,d_reg,C) + in x_C( + maybe_unbox( (* MEMO: we should raise Overflow more often *) + I.imull(I "2", R (I.doubleOfQuadReg d_reg)) :: + jump_overflow ( + I.addq(I "1", R d_reg) :: C'))) (* No need to check for overflow after adding 1; the + * intermediate result is even (after multiplying + * with 2) so adding one cannot give Overflow because the + * largest integer is odd! mael 2001-04-29 *) + end + fun word32_to_int31 {boxedarg,ovf} (x,d,size_ff,C) = let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) @@ -1517,6 +1579,29 @@ struct * largest integer is odd! mael 2001-04-29 *) end + fun word64_to_int31 {boxedarg,ovf} (x,d,size_ff,C) = + let + val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + fun maybe_unbox C = if boxedarg then load_indexed(R d_reg,x_reg,WORDS 1,C) + else copy(x_reg,d_reg,C) + fun check_ovf C = + if ovf then + I.btq(I "30", R d_reg) :: + I.jc (NameLab "__raise_overflow") :: + C + else C + in x_C( + maybe_unbox( + check_ovf( + I.imull(I "2", R (I.doubleOfQuadReg d_reg)) :: + jump_overflow ( + I.addq(I "1", R d_reg) :: C')))) (* No need to check for overflow after adding 1; the + * intermediate result is even (after multiplying + * with 2) so adding one cannot give Overflow because the + * largest integer is odd! mael 2001-04-29 *) + end + fun word32_to_word31 {boxedarg} (x,d,size_ff,C) = let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) @@ -1525,13 +1610,203 @@ struct else copy(x_reg,d_reg,C) in x_C( maybe_unbox( -(* - I.salq(I "1", R d_reg) :: - I.addq(I "1", R d_reg) :: -*) I.leaq(DD("1", d_reg, d_reg, ""), R d_reg) :: + I.leaq(DD("1", d_reg, d_reg, ""), R d_reg) :: C')) end + (* Conversions involving 64bit ints and words *) + + fun word64ub_to_word32ub (x,d,size_ff,C) = + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + in x_C(copy(x_reg, d_reg, C')) (* just do a copy *) + end + + fun word64ub_to_int32ub (x,d,size_ff,C) = + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff, C) + (* to test whether the argument can be represented in 32 bits, we copy with + * zero-extension and compare *) + in x_C(copy(x_reg,tmp_reg0, + I.mov(R (I.doubleOfQuadReg tmp_reg0), R (I.doubleOfQuadReg d_reg)) :: + I.btq(I "31", R d_reg) :: (* sign bit set? *) + I.jc (NameLab "__raise_overflow") :: + I.cmpq(R tmp_reg0, R d_reg) :: + I.jne (NameLab "__raise_overflow") :: C')) + end + + fun int64ub_to_int32ub (x,d,size_ff,C) = + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + (* to test whether the argument can be represented in 32 bits, we copy with + * sign-extension and compare *) + in x_C(copy(x_reg,tmp_reg0, + I.movslq(R (I.doubleOfQuadReg tmp_reg0), R d_reg) :: + I.cmpq(R tmp_reg0, R d_reg) :: + I.jne (NameLab "__raise_overflow") :: C')) + end + + fun int32ub_to_int64ub (x,d,size_ff,C) = + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + in x_C(I.movslq(R (I.doubleOfQuadReg x_reg), + R d_reg) :: C') (* sign-extend *) + end + + fun num64ub_to_num64ub {ovf} (x,d,size_ff,C) = + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + val C'' = if ovf then + I.btq(I "63", R d_reg) :: (* sign bit set? *) + I.jc (NameLab "__raise_overflow") :: C' + else C' + in x_C(copy(x_reg, d_reg, C'')) + end + + fun int64_to_int63 {boxedarg} (x,d,size_ff,C) = + let + val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + fun maybe_unbox C = if boxedarg then load_indexed(R d_reg,x_reg,WORDS 1,C) + else copy(x_reg,d_reg,C) + in x_C( + maybe_unbox( + I.imulq(I "2", R d_reg) :: + jump_overflow ( + I.addq(I "1", R d_reg) :: C'))) (* No need to check for overflow after adding 1; the + * intermediate result is even (after multiplying + * with 2) so adding one cannot give Overflow because the + * largest integer is odd! mael 2001-04-29 *) + end + + fun word64_to_num63 {boxedarg,ovf} (x,d,size_ff,C) = + let + val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + fun maybe_unbox C = if boxedarg then load_indexed(R d_reg,x_reg,WORDS 1,C) + else copy(x_reg,d_reg,C) + fun check_ovf C = + if ovf then + I.btq(I "62", R d_reg) :: + I.jc (NameLab "__raise_overflow") :: + C + else C + in x_C( + maybe_unbox( + check_ovf( + I.imulq(I "2", R d_reg) :: + jump_overflow ( (* memo: why is this needed? *) + I.addq(I "1", R d_reg) :: C')))) (* No need to check for overflow after adding 1; the + * intermediate result is even (after multiplying + * with 2) so adding one cannot give Overflow because the + * largest integer is odd! mael 2001-04-29 *) + end + + fun word32_to_word63 {boxedarg,signext} (x,d,size_ff,C) = + let + val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + fun maybe_unbox C = if boxedarg then load_indexed(R d_reg,x_reg,WORDS 1,C) + else copy(x_reg,d_reg,C) + fun maybe_signext C = + if signext then + I.movslq(R (I.doubleOfQuadReg d_reg), R d_reg) :: C + else C + in x_C( + maybe_unbox( + maybe_signext( + I.leaq(DD("1", d_reg, d_reg, ""), R d_reg) :: + C'))) + end + + fun word63_to_word31 (x,d,size_ff,C) = + let + val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + in x_C( + I.mov(R (I.doubleOfQuadReg x_reg), R (I.doubleOfQuadReg d_reg)) :: + C') + end + + fun num31_to_num63 {signext} (x,d,size_ff,C) = + let + val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + in x_C(if signext then + I.movslq(R (I.doubleOfQuadReg x_reg), R d_reg) :: C' + else + I.mov(R (I.doubleOfQuadReg x_reg), R (I.doubleOfQuadReg d_reg)) :: + C' + ) + end + + fun int63_to_int31 (x,d,size_ff,C) = + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff, C) + (* to test whether the argument can be represented in 32 (31) bits, we copy with + * sign-extension and compare *) + in x_C(copy(x_reg,tmp_reg0, + I.movslq(R (I.doubleOfQuadReg tmp_reg0), R d_reg) :: + I.cmpq(R tmp_reg0, R d_reg) :: + I.jne (NameLab "__raise_overflow") :: C')) + end + + fun word64_to_word31 {boxedarg} (x,d,size_ff,C) = + let + val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + fun maybe_unbox C = if boxedarg then load_indexed(R d_reg,x_reg,WORDS 1,C) + else copy(x_reg,d_reg,C) + in x_C( + maybe_unbox( + I.mov(R (I.doubleOfQuadReg d_reg), R (I.doubleOfQuadReg d_reg)) :: + I.leaq(DD("1", d_reg, d_reg, ""), R d_reg) :: + C')) + end + + fun num63_to_num64ub {shr_inst} (x,d,size_ff,C) = + if BI.tag_values() then die "num63_to_num64ub.tagging_enabled" + else + (* shr_inst is either I.sarq (sign extend) or I.shrq *) + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff, C) + in + x_C (copy(x_reg, d_reg, + shr_inst (I "1", R d_reg) :: + C')) + end + + fun word31_to_word64ub {signext} (x,d,size_ff,C) = + if BI.tag_values() then die "word31_to_word64ub.tagging_enabled" + else + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff, C) + fun maybe_signext C = + if signext then + I.sarl (I "1", R (I.doubleOfQuadReg d_reg)) :: + I.movslq(R (I.doubleOfQuadReg d_reg), R d_reg) :: C + else I.shrq (I "1", R d_reg) :: C + in + x_C ( + copy(x_reg, d_reg, + maybe_signext C')) + end + + fun word32ub_to_word64ub {signext} (x,d,size_ff,C) = + if BI.tag_values() then die "word32ub_to_word64ub.tagging_enabled" + else + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff, C) + in + x_C (if signext then + I.movslq(R (I.doubleOfQuadReg x_reg), + R d_reg) :: C' + else (* zero-extend the rest of d_reg *) + I.mov(R (I.doubleOfQuadReg x_reg), + R (I.doubleOfQuadReg d_reg)) :: C' + ) + end + (* unboxed f64 operations *) fun copy_f64 (x,y,C) = @@ -1621,7 +1896,7 @@ struct | pp_cond LESSEQUAL = "LESSEQUAL" | pp_cond GREATERTHAN = "GREATERTHAN" | pp_cond GREATEREQUAL = "GREATEREQUAL" - fun cmpf64_kill_tmp0 (cond,x,y,d,size_ff,C) = (* ME MEMO *) + fun cmpf64_kill_tmp0 cond (x,y,d,size_ff,C) = (* ME MEMO *) let val (x, x_C) = resolve_arg_aty(x,tmp_freg0,size_ff) val (y, y_C) = resolve_arg_aty(y,tmp_freg1,size_ff) val (d_reg, C') = resolve_aty_def(d, tmp_reg0, size_ff, C) @@ -1643,26 +1918,27 @@ struct C')) end - fun mov_int ((aty,r),size_ff,C) = - if BI.tag_values() then - move_aty_into_reg(aty,r,size_ff, - I.sarl(I "1", R (I.doubleOfQuadReg r)) :: C) - else - move_aty_into_reg(aty,r,size_ff,C) - - fun int_to_f64 (x,d,size_ff,C) = - let val (d, C') = resolve_aty_def(d,tmp_freg0,size_ff,C) - val tmp_reg0_double = I.doubleOfQuadReg tmp_reg0 - in mov_int ((x,tmp_reg0),size_ff, - I.cvtsi2sdl(R tmp_reg0_double, R d) :: C') - end + local + fun mov_int ((aty,r),size_ff,C) = + if BI.tag_values() then + move_aty_into_reg(aty,r,size_ff, + I.sarq(I "1", R r) :: C) + else + move_aty_into_reg(aty,r,size_ff,C) + in + fun int_to_f64 (x,d,size_ff,C) = + let val (d, C') = resolve_aty_def(d,tmp_freg0,size_ff,C) + in mov_int ((x,tmp_reg0),size_ff, + I.cvtsi2sdq(R tmp_reg0, R d) :: C') + end + end fun real_to_f64 (x,d,size_ff,C) = let val (d, C') = resolve_aty_def(d,tmp_freg0,size_ff,C) in load_real (x, tmp_reg0, size_ff, d) C' end - fun f64_to_real_kill_tmp01 (x,b,d,size_ff,C) = + fun f64_to_real_kill_tmp01 (b,x,d,size_ff,C) = let val (x, x_C) = resolve_arg_aty(x,tmp_freg0,size_ff) val (b_reg, b_C) = resolve_arg_aty(b, tmp_reg0, size_ff) val (d_reg, C') = resolve_aty_def(d, tmp_reg0, size_ff, C) @@ -1709,7 +1985,7 @@ struct copy(b_reg,d_reg, C')))) end - fun cmpf_kill_tmp01 (cond,x,y,d,size_ff,C) = (* ME MEMO *) + fun cmpf_kill_tmp01 cond (x,y,d,size_ff,C) = (* ME MEMO *) let val x_C = load_real(x, tmp_reg0, size_ff, tmp_freg0) val y_C = load_real(y, tmp_reg0, size_ff, tmp_freg1) val (d_reg, C') = resolve_aty_def(d, tmp_reg0, size_ff, C) @@ -1733,96 +2009,142 @@ struct C') end - fun bin_op_kill_tmp01 inst (x,y,d,size_ff,C) = + fun bin_op_kill_tmp01 {quad} inst (x,y,d,size_ff,C) = let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) + val maybeDoubleOfQuadReg = if quad then fn r => r + else I.doubleOfQuadReg in x_C(y_C( copy(y_reg, tmp_reg1, copy(x_reg, d_reg, - inst(R (I.doubleOfQuadReg tmp_reg1), - R (I.doubleOfQuadReg d_reg)) :: C')))) + inst(R (maybeDoubleOfQuadReg tmp_reg1), + R (maybeDoubleOfQuadReg d_reg)) :: C')))) end (* andb and orb are the same for 31 bit (tagged) and - * 32 bit (untagged) representations *) - fun andb_word_kill_tmp01 a = bin_op_kill_tmp01 I.andl a (* A[x&y] = A[x] & A[y] tagging *) - fun orb_word_kill_tmp01 a = bin_op_kill_tmp01 I.orl a (* A[x|y] = A[x] | A[y] tagging *) + * 32 bit (untagged) representations; same for 63/64 bits *) + fun andb_word_kill_tmp01 {quad:bool} a = + let val inst = if quad then I.andq else I.andl + in bin_op_kill_tmp01 {quad=quad} inst a (* A[x&y] = A[x] & A[y] tagging *) + end - (* xorb needs to set the lowest bit for the 31 bit (tagged) version *) - fun xorb_word_kill_tmp01 {tag} (x,y,d,size_ff,C) = + fun orb_word_kill_tmp01 {quad:bool} a = + let val inst = if quad then I.orq else I.orl + in bin_op_kill_tmp01 {quad=quad} inst a (* A[x|y] = A[x] | A[y] tagging *) + end + + (* xorb needs to set the lowest bit for the 31 bit (tagged) version and for the 63 bit (tagged) version *) + fun xorb_word_kill_tmp01 {tag,quad} (x,y,d,size_ff,C) = let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) fun do_tag C = if tag then I.orq(I "1", R d_reg) :: C else C + val (inst_xor, maybeDoubleOfQuadReg) = + if quad + then (I.xorq, fn r => r) + else (I.xorl, I.doubleOfQuadReg) in x_C(y_C( copy(y_reg, tmp_reg1, copy(x_reg, d_reg, - I.xorl(R (I.doubleOfQuadReg tmp_reg1), - R (I.doubleOfQuadReg d_reg)) :: + inst_xor(R (maybeDoubleOfQuadReg tmp_reg1), + R (maybeDoubleOfQuadReg d_reg)) :: do_tag C')))) end - fun bin_op_w32boxed__ {ovf} inst (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) - if not(BI.tag_values()) then die "bin_op_w32boxed__.tagging_disabled" + fun binop_word_boxed__ {ovf,quad} inst (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) + if not(BI.tag_values()) then die "binop_word_boxed__.tagging_disabled" else let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) fun check_ovf C = if ovf then jump_overflow C else C + val maybeDoubleOfQuadReg = if quad then fn r => r + else I.doubleOfQuadReg in x_C( load_indexed(R tmp_reg0,x_reg,WORDS 1, y_C( load_indexed(R tmp_reg1,y_reg,WORDS 1, - inst(R (I.doubleOfQuadReg tmp_reg0), - R (I.doubleOfQuadReg tmp_reg1)) :: + inst(R (maybeDoubleOfQuadReg tmp_reg0), + R (maybeDoubleOfQuadReg tmp_reg1)) :: check_ovf ( move_aty_into_reg(r,d_reg,size_ff, store_indexed(d_reg,WORDS 1,R tmp_reg1, store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, C')))))))) (* store tag *) end - fun addw32boxed(r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) - bin_op_w32boxed__ {ovf=false} I.addl (r,x,y,d,size_ff,C) + fun addw32boxed (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) + binop_word_boxed__ {ovf=false,quad=false} I.addl (r,x,y,d,size_ff,C) + + fun addw64boxed (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word64.sml *) + binop_word_boxed__ {ovf=false,quad=true} I.addq (r,x,y,d,size_ff,C) + + fun subw32boxed (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) + binop_word_boxed__ {ovf=false,quad=false} I.subl (r,y,x,d,size_ff,C) (* x and y swapped, see spec for subq *) - fun subw32boxed(r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) - bin_op_w32boxed__ {ovf=false} I.subl (r,y,x,d,size_ff,C) (* x and y swapped, see spec for subq *) + fun subw64boxed (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word64.sml *) + binop_word_boxed__ {ovf=false,quad=true} I.subq (r,y,x,d,size_ff,C) (* x and y swapped, see spec for subq *) - fun mulw32boxed(r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) - bin_op_w32boxed__ {ovf=false} I.imull (r,x,y,d,size_ff,C) + fun mulw32boxed (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) + binop_word_boxed__ {ovf=false,quad=false} I.imull (r,x,y,d,size_ff,C) + + fun mulw64boxed (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word64.sml *) + binop_word_boxed__ {ovf=false,quad=true} I.imulq (r,x,y,d,size_ff,C) fun orw32boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) - bin_op_w32boxed__ {ovf=false} I.orl (r,x,y,d,size_ff,C) + binop_word_boxed__ {ovf=false,quad=false} I.orl (r,x,y,d,size_ff,C) + + fun orw64boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word64.sml *) + binop_word_boxed__ {ovf=false,quad=true} I.orq (r,x,y,d,size_ff,C) fun andw32boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) - bin_op_w32boxed__ {ovf=false} I.andl (r,x,y,d,size_ff,C) + binop_word_boxed__ {ovf=false,quad=false} I.andl (r,x,y,d,size_ff,C) + + fun andw64boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word64.sml *) + binop_word_boxed__ {ovf=false,quad=true} I.andq (r,x,y,d,size_ff,C) fun xorw32boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) - bin_op_w32boxed__ {ovf=false} I.xorl (r,x,y,d,size_ff,C) + binop_word_boxed__ {ovf=false,quad=false} I.xorl (r,x,y,d,size_ff,C) + + fun xorw64boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word64.sml *) + binop_word_boxed__ {ovf=false,quad=true} I.xorq (r,x,y,d,size_ff,C) fun mul_int32b (b,x,y,d,size_ff,C) = - bin_op_w32boxed__ {ovf=true} I.imull (b,x,y,d,size_ff,C) + binop_word_boxed__ {ovf=true,quad=false} I.imull (b,x,y,d,size_ff,C) + + fun mul_int64b (b,x,y,d,size_ff,C) = + binop_word_boxed__ {ovf=true,quad=true} I.imulq (b,x,y,d,size_ff,C) fun sub_int32b (b,x,y,d,size_ff,C) = - bin_op_w32boxed__ {ovf=true} I.subl (b,y,x,d,size_ff,C) + binop_word_boxed__ {ovf=true,quad=false} I.subl (b,y,x,d,size_ff,C) + + fun sub_int64b (b,x,y,d,size_ff,C) = + binop_word_boxed__ {ovf=true,quad=true} I.subq (b,y,x,d,size_ff,C) fun add_int32b (b,x,y,d,size_ff,C) = - bin_op_w32boxed__ {ovf=true} I.addl (b,x,y,d,size_ff,C) + binop_word_boxed__ {ovf=true,quad=false} I.addl (b,x,y,d,size_ff,C) - fun num31_to_num32b (b,x,d,size_ff,C) = (* a boxed word is tagged as a scalar record *) + fun add_int64b (b,x,y,d,size_ff,C) = + binop_word_boxed__ {ovf=true,quad=true} I.addq (b,x,y,d,size_ff,C) + + fun num31_to_num_boxed {quad} (b,x,d,size_ff,C) = (* a boxed word is tagged as a scalar record *) if BI.tag_values() then let val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) + val (inst_sar, maybeDoubleOfQuadReg) = + if quad + then (I.sarq, fn r => r) + else (I.sarl, I.doubleOfQuadReg) in move_aty_into_reg(x,tmp_reg0,size_ff, - I.sarl(I "1", R (I.doubleOfQuadReg tmp_reg0)) :: + inst_sar (I "1", R (maybeDoubleOfQuadReg tmp_reg0)) :: move_aty_into_reg(b,d_reg,size_ff, store_indexed(d_reg,WORDS 1, R tmp_reg0, store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, C')))) (* store tag *) end - else die "num31_to_num32b.tagging_disabled" + else die "num31_to_num_boxed.tagging_disabled" fun num32b_to_num32b {ovf:bool} (b,x,d,size_ff,C) = if not(BI.tag_values()) then die "num32b_to_num32b.tagging_disabled" @@ -1843,13 +2165,146 @@ struct store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, C')))))) (* store tag *) end - fun shift_w32boxed__ inst (r,x,y,d,size_ff,C) = - if not(BI.tag_values()) then die "shift_w32boxed__.tagging is not enabled as required" + fun num64b_to_num64b {ovf:bool} (b,x,d,size_ff,C) = + if not(BI.tag_values()) then die "num64b_to_num64b.tagging_disabled" + else + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff, C) + fun check_ovf C = + if ovf then + I.btq(I "63", R tmp_reg0) :: (* sign bit set? *) + I.jc (NameLab "__raise_overflow") :: C + else C + in + x_C ( + load_indexed(R tmp_reg0,x_reg,WORDS 1, + check_ovf ( + move_aty_into_reg(b,d_reg,size_ff, + store_indexed(d_reg, WORDS 1, R tmp_reg0, + store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, C')))))) (* store tag *) + end + + fun word32b_to_word64b {signext} (b,x,d,size_ff,C) = + if not(BI.tag_values()) then die "num32b_to_num64b.tagging_disabled" + else + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff, C) + fun maybe_signext C = + if signext then + I.movslq(R (I.doubleOfQuadReg tmp_reg0), R tmp_reg0) :: C + else C + in + x_C ( + load_indexed(R tmp_reg0,x_reg,WORDS 1, + maybe_signext( + move_aty_into_reg(b,d_reg,size_ff, + store_indexed(d_reg, WORDS 1, R tmp_reg0, + store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, C')))))) (* store tag *) + end + + fun int32b_to_int64b (b,x,d,size_ff,C) = + if not(BI.tag_values()) then die "int32b_to_int64b.tagging_disabled" + else + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff, C) + in + x_C ( + load_indexed(R tmp_reg0,x_reg,WORDS 1, + I.movslq(R (I.doubleOfQuadReg tmp_reg0), R tmp_reg0) :: (* sign-extend *) + move_aty_into_reg(b,d_reg,size_ff, + store_indexed(d_reg, WORDS 1, R tmp_reg0, + store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, C'))))) (* store tag *) + end + + fun num64b_to_num32b (b,x,d,size_ff,C) = + if not(BI.tag_values()) then die "num64b_to_num32b.tagging_disabled" + else + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff, C) + in + x_C ( + load_indexed(R tmp_reg0,x_reg,WORDS 1, + I.mov(R (I.doubleOfQuadReg tmp_reg0),R (I.doubleOfQuadReg tmp_reg0)) :: (* clears the upper bits *) + move_aty_into_reg(b,d_reg,size_ff, + store_indexed(d_reg, WORDS 1, R tmp_reg0, + store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, C'))))) (* store tag *) + end + + fun num63_to_num64b {shr_inst} (b,x,d,size_ff,C) = + if not(BI.tag_values()) then die "int63_to_int64b.tagging_disabled" + else + (* shr_inst is either I.sarq (sign extend) or I.shrq *) + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff, C) + in + x_C (copy(x_reg, tmp_reg0, + shr_inst (I "1", R tmp_reg0) :: + move_aty_into_reg(b,d_reg,size_ff, + store_indexed(d_reg, WORDS 1, R tmp_reg0, + store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, C'))))) (* store tag *) + end + + fun word63_to_word32b (b,x,d,size_ff,C) = + if not(BI.tag_values()) then die "word63_to_word32b.tagging_disabled" + else + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff, C) + in + x_C (copy(x_reg, tmp_reg0, + I.shrq (I "1", R tmp_reg0) :: + I.mov(R (I.doubleOfQuadReg tmp_reg0), R (I.doubleOfQuadReg tmp_reg0)) :: + move_aty_into_reg(b,d_reg,size_ff, + store_indexed(d_reg, WORDS 1, R tmp_reg0, + store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, C'))))) (* store tag *) + end + + fun int63_to_int32b (b,x,d,size_ff,C) = + if not(BI.tag_values()) then die "int63_to_int32b.tagging_disabled" + else + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff, C) + (* to test whether the argument can be represented in 32 (31) bits, we copy with + * sign-extension and compare *) + in x_C(copy(x_reg, tmp_reg0, + I.sarq (I "1", R tmp_reg0) :: + I.movslq(R (I.doubleOfQuadReg tmp_reg0), R tmp_reg1) :: + I.cmpq(R tmp_reg0, R tmp_reg1) :: + I.jne (NameLab "__raise_overflow") :: + copy(tmp_reg1, tmp_reg0, + move_aty_into_reg(b,d_reg,size_ff, + store_indexed(d_reg, WORDS 1, R tmp_reg0, + store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, + C')))))) + end + + fun word31_to_word64b {signext} (b,x,d,size_ff,C) = + if not(BI.tag_values()) then die "word31_to_word64b.tagging_disabled" + else + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff, C) + fun maybe_signext C = + if signext then + I.sarl (I "1", R (I.doubleOfQuadReg tmp_reg0)) :: + I.movslq(R (I.doubleOfQuadReg tmp_reg0), R tmp_reg0) :: C + else I.shrq (I "1", R tmp_reg0) :: C + in + x_C ( + copy(x_reg, tmp_reg0, + maybe_signext( + move_aty_into_reg(b,d_reg,size_ff, + store_indexed(d_reg, WORDS 1, R tmp_reg0, + store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, C')))))) (* store tag *) + end + + fun shift_word_boxed__ {quad} inst (r,x,y,d,size_ff,C) = + if not(BI.tag_values()) then die "shift_word_boxed__.tagging is not enabled as required" else (* y is unboxed and tagged *) let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg1,size_ff) val (y_reg,y_C) = resolve_arg_aty(y,rcx,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) + val maybeDoubleOfQuadReg = if quad then fn r => r + else I.doubleOfQuadReg in x_C( load_indexed(R tmp_reg1,x_reg,WORDS 1, @@ -1857,7 +2312,7 @@ struct y_C( copy(y_reg,rcx, (* tmp_reg0 = %r10, see InstsX64.sml *) I.sarq (I "1", R rcx) :: (* untag y: y >> 1 *) - inst(R cl, R (I.doubleOfQuadReg tmp_reg1)) :: + inst(R cl, R (maybeDoubleOfQuadReg tmp_reg1)) :: copy(tmp_reg0, rcx, (* restore rcx *) move_aty_into_reg(r,d_reg,size_ff, store_indexed(d_reg,WORDS 1, R tmp_reg1, @@ -1865,21 +2320,34 @@ struct end fun shift_leftw32boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) - shift_w32boxed__ I.sall (r,x,y,d,size_ff,C) + shift_word_boxed__ {quad=false} I.sall (r,x,y,d,size_ff,C) + + fun shift_leftw64boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word64.sml *) + shift_word_boxed__ {quad=true} I.salq (r,x,y,d,size_ff,C) fun shift_right_signedw32boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) - shift_w32boxed__ I.sarl (r,x,y,d,size_ff,C) + shift_word_boxed__ {quad=false} I.sarl (r,x,y,d,size_ff,C) + + fun shift_right_signedw64boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word64.sml *) + shift_word_boxed__ {quad=true} I.sarq (r,x,y,d,size_ff,C) fun shift_right_unsignedw32boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) - shift_w32boxed__ I.shrl (r,x,y,d,size_ff,C) + shift_word_boxed__ {quad=false} I.shrl (r,x,y,d,size_ff,C) + + fun shift_right_unsignedw64boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word64.sml *) + shift_word_boxed__ {quad=true} I.shrq (r,x,y,d,size_ff,C) - fun shift_left_word_kill_tmp01 {tag} (x,y,d,size_ff,C) = (*tmp_reg0 = %r10*) + fun shift_left_word_kill_tmp01 {tag,quad} (x,y,d,size_ff,C) = (*tmp_reg0 = %r10*) let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg1,size_ff) val (y_reg,y_C) = resolve_arg_aty(y,rcx,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) (* y is represented tagged only when BI.tag_values() is true *) fun untag_y C = if BI.tag_values() then I.sarq (I "1", R rcx) :: C (* y >> 1 *) else C + val (inst_sal, maybeDoubleOfQuadReg) = + if quad + then (I.salq, fn r => r) + else (I.sall, I.doubleOfQuadReg) in if tag then (* 1 + ((x - 1) << (y >> 1)) *) x_C( @@ -1887,10 +2355,10 @@ struct copy(x_reg, tmp_reg1, y_C( copy(y_reg, rcx, - I.decq (R tmp_reg1) :: (* x - 1 *) - untag_y ( (* y >> 1 *) - I.sall (R cl, R (I.doubleOfQuadReg tmp_reg1)) :: (* << *) - I.movq (R tmp_reg0, R rcx) :: (* restore rcx *) + I.decq (R tmp_reg1) :: (* x - 1 *) + untag_y ( (* y >> 1 *) + inst_sal (R cl, R (maybeDoubleOfQuadReg tmp_reg1)) :: (* << *) + I.movq (R tmp_reg0, R rcx) :: (* restore rcx *) I.incq (R tmp_reg1) :: (* 1 + *) copy(tmp_reg1, d_reg, C')))))) else @@ -1899,18 +2367,22 @@ struct copy(x_reg, tmp_reg1, y_C( copy(y_reg, rcx, - I.sall(R cl, R (I.doubleOfQuadReg tmp_reg1)) :: + inst_sal(R cl, R (maybeDoubleOfQuadReg tmp_reg1)) :: copy(tmp_reg0, rcx, (* restore rcx *) copy(tmp_reg1, d_reg, C'))))))) end - fun shift_right_signed_word_kill_tmp01 {tag} (x,y,d,size_ff,C) = (*tmp_reg0 = %r10*) + fun shift_right_signed_word_kill_tmp01 {tag,quad} (x,y,d,size_ff,C) = (*tmp_reg0 = %r10*) let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg1,size_ff) val (y_reg,y_C) = resolve_arg_aty(y,rcx,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) (* y is represented tagged only when BI.tag_values() is true *) fun untag_y C = if BI.tag_values() then I.sarq (I "1", R rcx) :: C (* y >> 1 *) else C + val (inst_sar, maybeDoubleOfQuadReg) = + if quad + then (I.sarq, fn r => r) + else (I.sarl, I.doubleOfQuadReg) in if tag then (* 1 | ((x) >> (y >> 1)) *) x_C( @@ -1918,11 +2390,11 @@ struct copy(x_reg, tmp_reg1, y_C( copy(y_reg, rcx, - I.decq (R tmp_reg1) :: (* x - 1 *) - untag_y ( (* y >> 1 *) - I.sarl (R cl, R (I.doubleOfQuadReg tmp_reg1)) :: (* x >> *) - copy(tmp_reg0, rcx, (* restore rcx *) - I.orq (I "1", R tmp_reg1) :: (* 1 | *) + I.decq (R tmp_reg1) :: (* x - 1 *) + untag_y ( (* y >> 1 *) + inst_sar (R cl, R (maybeDoubleOfQuadReg tmp_reg1)) :: (* x >> *) + copy(tmp_reg0, rcx, (* restore rcx *) + I.orq (I "1", R tmp_reg1) :: (* 1 | *) copy(tmp_reg1, d_reg, C'))))))) else x_C( @@ -1930,18 +2402,22 @@ struct copy(x_reg, tmp_reg1, y_C( copy(y_reg, rcx, - I.sarl(R cl, R (I.doubleOfQuadReg tmp_reg1)) :: + inst_sar (R cl, R (maybeDoubleOfQuadReg tmp_reg1)) :: copy(tmp_reg0, rcx, (* restore rcx *) copy(tmp_reg1, d_reg, C'))))))) end - fun shift_right_unsigned_word_kill_tmp01 {tag} (x,y,d,size_ff,C) = (*tmp_reg0 = %r10 *) + fun shift_right_unsigned_word_kill_tmp01 {tag,quad} (x,y,d,size_ff,C) = (*tmp_reg0 = %r10 *) let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg1,size_ff) val (y_reg,y_C) = resolve_arg_aty(y,rcx,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) (* y is represented tagged only when BI.tag_values() is true *) fun untag_y C = if BI.tag_values() then I.sarq (I "1", R rcx) :: C (* y >> 1 *) else C + val (inst_shr, maybeDoubleOfQuadReg) = + if quad + then (I.shrq, fn r => r) + else (I.shrl, I.doubleOfQuadReg) in if tag then (* 1 | ((unsigned long)(x) >> (y >> 1)) *) x_C( @@ -1949,9 +2425,9 @@ struct copy(x_reg, tmp_reg1, y_C( copy(y_reg, rcx, - untag_y ( (* y >> 1 *) - I.shrl (R cl, R (I.doubleOfQuadReg tmp_reg1)) :: (* (unsigned long)x >> *) - I.orq (I "1", R tmp_reg1) :: (* 1 | *) + untag_y ( (* y >> 1 *) + inst_shr (R cl, R (maybeDoubleOfQuadReg tmp_reg1)) :: (* (unsigned long)x >> *) + I.orq (I "1", R tmp_reg1) :: (* 1 | *) copy(tmp_reg0, rcx, copy(tmp_reg1, d_reg, C')))))))) else @@ -1960,12 +2436,12 @@ struct copy(x_reg, tmp_reg1, y_C( copy(y_reg, rcx, - I.shrl(R cl, R (I.doubleOfQuadReg tmp_reg1)) :: + inst_shr (R cl, R (maybeDoubleOfQuadReg tmp_reg1)) :: copy(tmp_reg0, rcx, (* restore rcx *) copy(tmp_reg1, d_reg, C'))))))) end - fun bytetable_sub(t,i,d,size_ff,C) = + fun bytetable_sub (t,i,d,size_ff,C) = let val (t_reg,t_C) = resolve_arg_aty(t,tmp_reg1,size_ff) val (i_reg,i_C) = resolve_arg_aty(i,tmp_reg0,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) @@ -1983,7 +2459,7 @@ struct C')) end - fun resolve_args(atys,ts,size_ff) = + fun resolve_args (atys,ts,size_ff) = case atys of nil => SOME (nil, fn C => C) | SS.PHREG_ATY r :: atys => @@ -1998,7 +2474,7 @@ struct of SOME (rs,F) => SOME (t::rs, fn C => F(move_aty_into_reg(aty,t,size_ff,C))) | NONE => NONE)) - fun bytetable_update(t,i,x,d,size_ff,C) = + fun bytetable_update (t,i,x,d,size_ff,C) = if BI.tag_values() then let (* i, x are represented tagged only when BI.tag_values() is true *) @@ -2011,7 +2487,7 @@ struct move_aty_into_reg(x,tmp_reg0,size_ff, (* tmp_reg0 (%r10) = x *) I.sarq (I "1", R tmp_reg0) :: (* untag x: tmp_reg0 >> 1 *) I.movb(R r10b, D("8", tmp_reg1)) :: (* *(tmp_reg1+8) = %r10b *) - move_immed(Int32.fromInt BI.ml_unit, R d_reg, (* d = () *) + move_immed(IntInf.fromInt BI.ml_unit, R d_reg, (* d = () *) C')))) end else @@ -2030,7 +2506,7 @@ struct I.movb(R r10b, D("8", tmp_reg1)) :: (* *(tmp_reg1+8) = %r10b *) C)))) - fun bytetable_size(t,d,size_ff,C) = + fun bytetable_size (t,d,size_ff,C) = let val (t_reg,t_C) = resolve_arg_aty(t,tmp_reg0,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) in if BI.tag_values() then @@ -2049,7 +2525,7 @@ struct C') end - fun word_sub0(t,i,d,size_ff,C) = + fun word_sub0 (t,i,d,size_ff,C) = let val (t_reg,t_C) = resolve_arg_aty(t,tmp_reg1,size_ff) val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) (* i is represented tagged only when BI.tag_values() is true *) @@ -2068,7 +2544,7 @@ struct end end - fun word_update0(t,i,x,d,size_ff,C) = + fun word_update0 (t,i,x,d,size_ff,C) = if BI.tag_values() then let (* i, x are represented tagged only when BI.tag_values() is true *) @@ -2079,7 +2555,7 @@ struct F(move_aty_into_reg(i,tmp_reg0,size_ff, I.sarq (I "1", R tmp_reg0) :: I.movq(R x_reg, DD("8", t_reg, tmp_reg0, "8")) :: - move_immed(Int32.fromInt BI.ml_unit, R d_reg, + move_immed(IntInf.fromInt BI.ml_unit, R d_reg, C'))) | SOME _ => die "word_update0_1" | NONE => @@ -2090,7 +2566,7 @@ struct I.addq(R tmp_reg0, R tmp_reg1) :: (* tmp_reg1 += tmp_reg0 *) move_aty_into_reg(x,tmp_reg0,size_ff, (* tmp_reg0 = x *) I.movq(R tmp_reg0, D("8", tmp_reg1)) :: (* *(tmp_reg1+8) = tmp_reg0 *) - move_immed(Int32.fromInt BI.ml_unit, R d_reg, (* d = () *) + move_immed(IntInf.fromInt BI.ml_unit, R d_reg, (* d = () *) C'))))) end else @@ -2140,7 +2616,7 @@ struct I.sarq (I "1", R tmp_reg0) :: I.movsd(D("8", x_reg), R tmp_freg0) :: (* x points to a real *) I.movsd(R tmp_freg0, DD("8", t_reg, tmp_reg0, "8")) :: - move_immed(Int32.fromInt BI.ml_unit, R d_reg, + move_immed(IntInf.fromInt BI.ml_unit, R d_reg, C'))) | SOME _ => die "blockf64_update_real_1" | NONE => @@ -2151,7 +2627,7 @@ struct I.addq(R tmp_reg0, R tmp_reg1) :: (* tmp_reg1 += tmp_reg0 *) load_real(x,tmp_reg0,size_ff,tmp_freg0) (* tmp_freg0 = !x *) (I.movsd(R tmp_freg0, D("8", tmp_reg1)) :: (* *(tmp_reg1+8) = tmp_freg0 *) - move_immed(Int32.fromInt BI.ml_unit, R d_reg, (* d = () *) + move_immed(IntInf.fromInt BI.ml_unit, R d_reg, (* d = () *) C'))))) end else @@ -2198,7 +2674,7 @@ struct I.sarq(I "1", R tmp_reg1) :: (* untag i: tmp_reg1 >> 1 *) move_aty_into_reg(t,tmp_reg0,size_ff, (* tmp_reg0 = t *) (I.movsd(R x, DD("8",tmp_reg0,tmp_reg1,"8")) :: (* *(8+tmp_reg1+8*tmp_reg1) = freg *) - move_immed(Int32.fromInt BI.ml_unit, R d_reg, (* d = () *) + move_immed(IntInf.fromInt BI.ml_unit, R d_reg, (* d = () *) C')))) end else diff --git a/src/Compiler/Backend/X64/CodeGenX64.sml b/src/Compiler/Backend/X64/CodeGenX64.sml index 8129f8726..b5eb9a408 100644 --- a/src/Compiler/Backend/X64/CodeGenX64.sml +++ b/src/Compiler/Backend/X64/CodeGenX64.sml @@ -236,7 +236,7 @@ struct else i val (reg_for_result,C') = resolve_aty_def(pat,tmp_reg1,size_ff,C) in - move_immed(Int32.fromInt tag, R reg_for_result,C') + move_immed(IntInf.fromInt tag, R reg_for_result,C') end | LS.UNBOXED i => let @@ -247,7 +247,7 @@ struct maybe_reset_aux_region_kill_tmp0(alloc,tmp_reg1,size_ff,C)) C aux_regions in - reset_regions(move_immed(Int32.fromInt tag, R reg_for_result,C')) + reset_regions(move_immed(IntInf.fromInt tag, R reg_for_result,C')) end | LS.BOXED i => let @@ -340,7 +340,7 @@ struct in store_aty_in_aty_record(aty2,aty1,WORDS offset,tmp_reg1,tmp_reg0,size_ff, if BI.tag_values() then - move_immed(Int32.fromInt BI.ml_unit, R reg_for_result,C') + move_immed(IntInf.fromInt BI.ml_unit, R reg_for_result,C') else C') end | LS.PASS_PTR_TO_MEM(alloc,i,untagged_value) => @@ -645,7 +645,8 @@ struct | LS.SWITCH_I{switch=LS.SWITCH(SS.FLOW_VAR_ATY(lv,lab_t,lab_f),[(sel_val,lss)],default), precision} => let - val (t_lab,f_lab) = if sel_val = Int32.fromInt BI.ml_true then (lab_t,lab_f) else (lab_f,lab_t) + val (t_lab,f_lab) = if sel_val = IntInf.fromInt BI.ml_true then (lab_t,lab_f) + else (lab_f,lab_t) val lab_exit = new_local_lab "lab_exit" in I.lab(LocalLab t_lab) :: @@ -659,7 +660,7 @@ struct compileNumSwitch {size_ff=size_ff, size_ccf=size_ccf, CG_lss=CG_lss, - toInt=fn i => maybeTagInt{value=i, precision=precision}, + toInt=fn i => maybeTagIntOrWord{value=i, precision=precision}, opr_aty=opr_aty, oprBoxed=boxedNum precision, sels=sels, @@ -669,7 +670,7 @@ struct compileNumSwitch {size_ff=size_ff, size_ccf=size_ccf, CG_lss=CG_lss, - toInt=fn w => Int32.fromLarge(Word32.toLargeIntX (maybeTagWord{value=w, precision=precision})), + toInt=fn w => maybeTagIntOrWord{value=w, precision=precision}, opr_aty=opr_aty, oprBoxed=boxedNum precision, sels=sels, @@ -697,9 +698,9 @@ struct | ((con,con_kind),_)::rest => con_kind val sels' = map (fn ((con,con_kind),sel_insts) => case con_kind - of LS.ENUM i => (Int32.fromInt i,sel_insts) - | LS.UNBOXED i => (Int32.fromInt i,sel_insts) - | LS.BOXED i => (Int32.fromInt i,sel_insts)) sels + of LS.ENUM i => (IntInf.fromInt i,sel_insts) + | LS.UNBOXED i => (IntInf.fromInt i,sel_insts) + | LS.BOXED i => (IntInf.fromInt i,sel_insts)) sels fun UbTagCon(src_aty,C) = let val cont_lab = new_local_lab "cont" in move_aty_into_reg(src_aty,tmp_reg0,size_ff, @@ -722,7 +723,7 @@ struct F (compileNumSwitch {size_ff=size_ff, size_ccf=size_ccf, CG_lss=CG_lss, - toInt=fn i => i, (* tagging already done in ClosExp *) + toInt=fn x => x, (* tagging already done in ClosExp *) opr_aty=opr_aty, oprBoxed=false, sels=sels', @@ -742,46 +743,88 @@ struct val (x,y) = case args of [x,y] => (x,y) | _ => die "CG_ls: Expecting two arguments for flow primitive" - fun cmp i = cmpi_and_jmp_kill_tmp01(i,x,y,lab_t,lab_f,size_ff,C) - fun cmp_boxed i = cmpbi_and_jmp_kill_tmp01(i,x,y,lab_t,lab_f,size_ff,C) + fun cmp i = cmpi_and_jmp_kill_tmp01 {quad=false} (i,x,y,lab_t,lab_f,size_ff,C) + fun cmp_boxed i = cmpbi_and_jmp_kill_tmp01 {quad=false} (i,x,y,lab_t,lab_f,size_ff,C) + fun cmp_quad i = cmpi_and_jmp_kill_tmp01 {quad=true} (i,x,y,lab_t,lab_f,size_ff,C) + fun cmp_boxed_quad i = cmpbi_and_jmp_kill_tmp01 {quad=true} (i,x,y,lab_t,lab_f,size_ff,C) fun cmpf64 i = cmpf64_and_jmp(i,x,y,lab_t,lab_f,size_ff,C) open PrimName - in case name - of Equal_int32ub => cmp I.je - | Equal_int32b => cmp_boxed I.je - | Equal_int31 => cmp I.je - | Equal_word31 => cmp I.je - | Equal_word32ub => cmp I.je - | Equal_word32b => cmp_boxed I.je - | Less_int32ub => cmp I.jl - | Less_int32b => cmp_boxed I.jl - | Less_int31 => cmp I.jl - | Less_word31 => cmp I.jb - | Less_word32ub => cmp I.jb - | Less_word32b => cmp_boxed I.jb - | Lesseq_int32ub => cmp I.jle - | Lesseq_int32b => cmp_boxed I.jle - | Lesseq_int31 => cmp I.jle - | Lesseq_word31 => cmp I.jbe - | Lesseq_word32ub => cmp I.jbe - | Lesseq_word32b => cmp_boxed I.jbe - | Greater_int32ub => cmp I.jg - | Greater_int32b => cmp_boxed I.jg - | Greater_int31 => cmp I.jg - | Greater_word31 => cmp I.ja - | Greater_word32ub => cmp I.ja - | Greater_word32b => cmp_boxed I.ja - | Greatereq_int32ub => cmp I.jge - | Greatereq_int32b => cmp_boxed I.jge - | Greatereq_int31 => cmp I.jge - | Greatereq_word31 => cmp I.jae - | Greatereq_word32ub => cmp I.jae - | Greatereq_word32b => cmp_boxed I.jae - | Less_f64 => cmpf64 I.jb - | Lesseq_f64 => cmpf64 I.jbe - | Greater_f64 => cmpf64 I.ja - | Greatereq_f64 => cmpf64 I.jae - | _ => die "CG_ls: Unsupported PRIM used with Flow Variable" + in case name of + Equal_int32ub => cmp I.je + | Equal_int32b => cmp_boxed I.je + | Equal_int31 => cmp I.je + | Equal_word31 => cmp I.je + | Equal_word32ub => cmp I.je + | Equal_word32b => cmp_boxed I.je + + | Equal_int64ub => cmp_quad I.je + | Equal_int64b => cmp_boxed_quad I.je + | Equal_int63 => cmp_quad I.je + | Equal_word63 => cmp_quad I.je + | Equal_word64ub => cmp_quad I.je + | Equal_word64b => cmp_boxed_quad I.je + + | Less_int32ub => cmp I.jl + | Less_int32b => cmp_boxed I.jl + | Less_int31 => cmp I.jl + | Less_word31 => cmp I.jb + | Less_word32ub => cmp I.jb + | Less_word32b => cmp_boxed I.jb + + | Less_int64ub => cmp_quad I.jl + | Less_int64b => cmp_boxed_quad I.jl + | Less_int63 => cmp_quad I.jl + | Less_word63 => cmp_quad I.jb + | Less_word64ub => cmp_quad I.jb + | Less_word64b => cmp_boxed_quad I.jb + + | Lesseq_int32ub => cmp I.jle + | Lesseq_int32b => cmp_boxed I.jle + | Lesseq_int31 => cmp I.jle + | Lesseq_word31 => cmp I.jbe + | Lesseq_word32ub => cmp I.jbe + | Lesseq_word32b => cmp_boxed I.jbe + + | Lesseq_int64ub => cmp_quad I.jle + | Lesseq_int64b => cmp_boxed_quad I.jle + | Lesseq_int63 => cmp_quad I.jle + | Lesseq_word63 => cmp_quad I.jbe + | Lesseq_word64ub => cmp_quad I.jbe + | Lesseq_word64b => cmp_boxed_quad I.jbe + + | Greater_int32ub => cmp I.jg + | Greater_int32b => cmp_boxed I.jg + | Greater_int31 => cmp I.jg + | Greater_word31 => cmp I.ja + | Greater_word32ub => cmp I.ja + | Greater_word32b => cmp_boxed I.ja + + | Greater_int64ub => cmp_quad I.jg + | Greater_int64b => cmp_boxed_quad I.jg + | Greater_int63 => cmp_quad I.jg + | Greater_word63 => cmp_quad I.ja + | Greater_word64ub => cmp_quad I.ja + | Greater_word64b => cmp_boxed_quad I.ja + + | Greatereq_int32ub => cmp I.jge + | Greatereq_int32b => cmp_boxed I.jge + | Greatereq_int31 => cmp I.jge + | Greatereq_word31 => cmp I.jae + | Greatereq_word32ub => cmp I.jae + | Greatereq_word32b => cmp_boxed I.jae + + | Greatereq_int64ub => cmp_quad I.jge + | Greatereq_int64b => cmp_boxed_quad I.jge + | Greatereq_int63 => cmp_quad I.jge + | Greatereq_word63 => cmp_quad I.jae + | Greatereq_word64ub => cmp_quad I.jae + | Greatereq_word64b => cmp_boxed_quad I.jae + + | Less_f64 => cmpf64 I.jb + | Lesseq_f64 => cmpf64 I.jbe + | Greater_f64 => cmpf64 I.ja + | Greatereq_f64 => cmpf64 I.jae + | _ => die "CG_ls: Unsupported PRIM used with Flow Variable" end) | LS.PRIM{name,args,res} => let val d = case res of nil => SS.UNIT_ATY @@ -802,25 +845,84 @@ struct | _ => die ("unsupported prim with 0 args: " ^ PrimName.pp_prim name)) | [x] => (case name of - Neg_int32ub => neg_int_kill_tmp0 {tag=false} (x,d,size_ff,C) - | Neg_int31 => neg_int_kill_tmp0 {tag=true} (x,d,size_ff,C) - | Abs_int32ub => abs_int_kill_tmp0 {tag=false} (x,d,size_ff,C) - | Abs_int31 => abs_int_kill_tmp0 {tag=true} (x,d,size_ff,C) + Neg_int32ub => neg_int_kill_tmp0 {tag=false, quad=false} (x,d,size_ff,C) + | Neg_int31 => neg_int_kill_tmp0 {tag=true, quad=false} (x,d,size_ff,C) + | Neg_int64ub => neg_int_kill_tmp0 {tag=false, quad=true} (x,d,size_ff,C) + | Neg_int63 => neg_int_kill_tmp0 {tag=true, quad=true} (x,d,size_ff,C) + + | Abs_int32ub => abs_int_kill_tmp0 {tag=false, quad=false} (x,d,size_ff,C) + | Abs_int31 => abs_int_kill_tmp0 {tag=true, quad=false} (x,d,size_ff,C) + | Abs_int64ub => abs_int_kill_tmp0 {tag=false, quad=true} (x,d,size_ff,C) + | Abs_int63 => abs_int_kill_tmp0 {tag=true, quad=true} (x,d,size_ff,C) + | Int31_to_int32ub => num31_to_num32ub(x,d,size_ff,C) | Int32b_to_int31 => int32_to_int31 {boxedarg=true} (x,d,size_ff,C) | Int32ub_to_int31 => int32_to_int31 {boxedarg=false} (x,d,size_ff,C) | Word31_to_word32ub => num31_to_num32ub(x,d,size_ff,C) | Word32b_to_word31 => word32_to_word31 {boxedarg=true} (x,d,size_ff,C) | Word32ub_to_word31 => word32_to_word31 {boxedarg=false} (x,d,size_ff,C) - | Word31_to_word32ub_X => num31_to_num32ub(x,d,size_ff,C) - | Word32ub_to_int32ub => word32ub_to_int32ub(x,d,size_ff,C) + | Word31_to_word32ub_X => num31_to_num32ub (x,d,size_ff,C) + | Word32ub_to_int32ub => word32ub_to_int32ub (x,d,size_ff,C) | Word32b_to_int31 => word32_to_int31 {boxedarg=true,ovf=true} (x,d,size_ff,C) | Int32b_to_word31 => word32_to_word31 {boxedarg=true} (x,d,size_ff,C) | Word32b_to_int31_X => word32_to_int31 {boxedarg=true,ovf=false} (x,d,size_ff,C) + + | Word64ub_to_word32ub => word64ub_to_word32ub (x,d,size_ff,C) + | Word32ub_to_word64ub => word32ub_to_word64ub {signext=false} (x,d,size_ff,C) + | Word64ub_to_int32ub => word64ub_to_int32ub (x,d,size_ff,C) + | Word64ub_to_int64ub => num64ub_to_num64ub {ovf=true} (x,d,size_ff,C) + | Word64ub_to_int64ub_X => num64ub_to_num64ub {ovf=false} (x,d,size_ff,C) + + | Word64b_to_int31 => word64_to_int31 {boxedarg=true,ovf=true} (x,d,size_ff,C) + | Word64b_to_int31_X => word64_to_int31 {boxedarg=true,ovf=false} (x,d,size_ff,C) + + | Int32ub_to_int64ub => int32ub_to_int64ub (x,d,size_ff,C) + | Int64ub_to_word64ub => num64ub_to_num64ub {ovf=false} (x,d,size_ff,C) + + | Int64b_to_int31 => int64_to_int31 {boxedarg=true} (x,d,size_ff,C) + + | Int64ub_to_int32ub => int64ub_to_int32ub (x,d,size_ff,C) + + | Int31_to_int64ub => int31_to_int64ub(x,d,size_ff,C) + + | Int64b_to_int63 => int64_to_int63 {boxedarg=true} (x,d,size_ff,C) + | Word64b_to_word63 => word64_to_num63 {boxedarg=true,ovf=false} (x,d,size_ff,C) + | Word32b_to_word63 => word32_to_word63 {boxedarg=true,signext=false} (x,d,size_ff,C) + | Word63_to_word31 => word63_to_word31 (x,d,size_ff,C) + | Word31_to_word63_X => num31_to_num63 {signext=true} (x,d,size_ff,C) + | Word31_to_word63 => num31_to_num63 {signext=false} (x,d,size_ff,C) + + | Int32b_to_int63 => word32_to_word63 {boxedarg=true,signext=true} (x,d,size_ff,C) + | Int63_to_int31 => int63_to_int31 (x,d,size_ff,C) + | Int31_to_int63 => num31_to_num63 {signext=true} (x,d,size_ff,C) + | Word32b_to_int63 => word32_to_word63 {boxedarg=true,signext=false} (x,d,size_ff,C) + | Word32b_to_int63_X => word32_to_word63 {boxedarg=true,signext=true} (x,d,size_ff,C) + | Word64b_to_word31 => word64_to_word31 {boxedarg=true} (x,d,size_ff,C) + + | Word64b_to_int63 => word64_to_num63 {boxedarg=true,ovf=true} (x,d,size_ff,C) + | Word64b_to_int63_X => word64_to_num63 {boxedarg=true,ovf=false} (x,d,size_ff,C) + + | Int63_to_int64ub => num63_to_num64ub {shr_inst=I.sarq} (x,d,size_ff,C) + + | Int64ub_to_int63 => int64_to_int63 {boxedarg=false} (x,d,size_ff,C) + + | Word63_to_word64ub => num63_to_num64ub {shr_inst=I.shrq} (x,d,size_ff,C) + | Word63_to_word64ub_X => num63_to_num64ub {shr_inst=I.sarq} (x,d,size_ff,C) + + | Word64ub_to_word31 => word64_to_word31 {boxedarg=false} (x,d,size_ff,C) + | Int64ub_to_int31 => int64_to_int31 {boxedarg=false} (x,d,size_ff,C) + + | Word31_to_word64ub => word31_to_word64ub {signext=false} (x,d,size_ff,C) + | Word31_to_word64ub_X => word31_to_word64ub {signext=true} (x,d,size_ff,C) + + | Word32ub_to_int64ub => word32ub_to_word64ub {signext=false} (x,d,size_ff,C) + | Word32ub_to_int64ub_X => word32ub_to_word64ub {signext=true} (x,d,size_ff,C) + | Word32ub_to_word64ub_X => word32ub_to_word64ub {signext=true} (x,d,size_ff,C) + | Bytetable_size => bytetable_size(x,d,size_ff,C) | Table_size => table_size(x,d,size_ff,C) - | Is_null => cmpi_kill_tmp01 {box=false} (I.je,x, SS.INTEGER_ATY{value=Int32.fromInt 0, - precision=32},d,size_ff,C) + | Is_null => cmpi_kill_tmp01 {box=false,quad=false} I.je (x, SS.INTEGER_ATY{value=IntInf.fromInt 0, + precision=32},d,size_ff,C) | Real_to_f64 => real_to_f64(x,d,size_ff,C) | Sqrt_f64 => sqrt_f64(x,d,size_ff,C) | Neg_f64 => neg_f64(x,d,size_ff,C) @@ -830,113 +932,221 @@ struct | _ => die ("unsupported prim with 1 arg: " ^ PrimName.pp_prim name)) | [x,y] => (case name of - Equal_int32ub => cmpi_kill_tmp01 {box=false} (I.je,x,y,d,size_ff,C) - | Equal_int32b => cmpi_kill_tmp01 {box=true} (I.je,x,y,d,size_ff,C) - | Equal_int31 => cmpi_kill_tmp01 {box=false} (I.je,x,y,d,size_ff,C) - | Equal_word31 => cmpi_kill_tmp01 {box=false} (I.je,x,y,d,size_ff,C) - | Equal_word32ub => cmpi_kill_tmp01 {box=false} (I.je,x,y,d,size_ff,C) - | Equal_word32b => cmpi_kill_tmp01 {box=true} (I.je,x,y,d,size_ff,C) - | Plus_int32ub => add_num_kill_tmp01 {ovf=true,tag=false} (x,y,d,size_ff,C) - | Plus_int31 => add_num_kill_tmp01 {ovf=true,tag=true} (x,y,d,size_ff,C) - | Plus_word31 => add_num_kill_tmp01 {ovf=false,tag=true} (x,y,d,size_ff,C) - | Plus_word32ub => add_num_kill_tmp01 {ovf=false,tag=false} (x,y,d,size_ff,C) - | Minus_int32ub => sub_num_kill_tmp01 {ovf=true,tag=false} (x,y,d,size_ff,C) - | Minus_int31 => sub_num_kill_tmp01 {ovf=true,tag=true} (x,y,d,size_ff,C) - | Minus_word31 => sub_num_kill_tmp01 {ovf=false,tag=true} (x,y,d,size_ff,C) - | Minus_word32ub => sub_num_kill_tmp01 {ovf=false,tag=false} (x,y,d,size_ff,C) - | Mul_int32ub => mul_num_kill_tmp01 {ovf=true,tag=false} (x,y,d,size_ff,C) - | Mul_int31 => mul_num_kill_tmp01 {ovf=true,tag=true} (x,y,d,size_ff,C) - | Mul_word31 => mul_num_kill_tmp01 {ovf=false,tag=true} (x,y,d,size_ff,C) - | Mul_word32ub => mul_num_kill_tmp01 {ovf=false,tag=false} (x,y,d,size_ff,C) - | Neg_int32b => neg_int32b_kill_tmp0 (x,y,d,size_ff,C) - | Neg_real => negf_kill_tmp01(x,y,d,size_ff,C) - | Abs_int32b => abs_int32b_kill_tmp0 (x,y,d,size_ff,C) - | Abs_real => absf_kill_tmp01(x,y,d,size_ff,C) - | Less_int32ub => cmpi_kill_tmp01 {box=false} (I.jl,x,y,d,size_ff,C) - | Less_int32b => cmpi_kill_tmp01 {box=true} (I.jl,x,y,d,size_ff,C) - | Less_int31 => cmpi_kill_tmp01 {box=false} (I.jl,x,y,d,size_ff,C) - | Less_word31 => cmpi_kill_tmp01 {box=false} (I.jb,x,y,d,size_ff,C) - | Less_word32ub => cmpi_kill_tmp01 {box=false} (I.jb,x,y,d,size_ff,C) - | Less_word32b => cmpi_kill_tmp01 {box=true} (I.jb,x,y,d,size_ff,C) - | Less_real => cmpf_kill_tmp01(LESSTHAN,x,y,d,size_ff,C) - | Less_f64 => cmpf64_kill_tmp0(LESSTHAN,x,y,d,size_ff,C) - | Lesseq_int32ub => cmpi_kill_tmp01 {box=false} (I.jle,x,y,d,size_ff,C) - | Lesseq_int32b => cmpi_kill_tmp01 {box=true} (I.jle,x,y,d,size_ff,C) - | Lesseq_int31 => cmpi_kill_tmp01 {box=false} (I.jle,x,y,d,size_ff,C) - | Lesseq_word31 => cmpi_kill_tmp01 {box=false} (I.jbe,x,y,d,size_ff,C) - | Lesseq_word32ub => cmpi_kill_tmp01 {box=false} (I.jbe,x,y,d,size_ff,C) - | Lesseq_word32b => cmpi_kill_tmp01 {box=true} (I.jbe,x,y,d,size_ff,C) - | Lesseq_real => cmpf_kill_tmp01(LESSEQUAL,x,y,d,size_ff,C) - | Lesseq_f64 => cmpf64_kill_tmp0(LESSEQUAL,x,y,d,size_ff,C) - | Greater_int32ub => cmpi_kill_tmp01 {box=false} (I.jg,x,y,d,size_ff,C) - | Greater_int32b => cmpi_kill_tmp01 {box=true} (I.jg,x,y,d,size_ff,C) - | Greater_int31 => cmpi_kill_tmp01 {box=false} (I.jg,x,y,d,size_ff,C) - | Greater_word31 => cmpi_kill_tmp01 {box=false} (I.ja,x,y,d,size_ff,C) - | Greater_word32ub => cmpi_kill_tmp01 {box=false} (I.ja,x,y,d,size_ff,C) - | Greater_word32b => cmpi_kill_tmp01 {box=true} (I.ja,x,y,d,size_ff,C) - | Greater_real => cmpf_kill_tmp01(GREATERTHAN,x,y,d,size_ff,C) - | Greater_f64 => cmpf64_kill_tmp0(GREATERTHAN,x,y,d,size_ff,C) - | Greatereq_int32ub => cmpi_kill_tmp01 {box=false} (I.jge,x,y,d,size_ff,C) - | Greatereq_int32b => cmpi_kill_tmp01 {box=true} (I.jge,x,y,d,size_ff,C) - | Greatereq_int31 => cmpi_kill_tmp01 {box=false} (I.jge,x,y,d,size_ff,C) - | Greatereq_word31 => cmpi_kill_tmp01 {box=false} (I.jae,x,y,d,size_ff,C) - | Greatereq_word32ub => cmpi_kill_tmp01 {box=false} (I.jae,x,y,d,size_ff,C) - | Greatereq_word32b => cmpi_kill_tmp01 {box=true} (I.jae,x,y,d,size_ff,C) - | Greatereq_real => cmpf_kill_tmp01(GREATEREQUAL,x,y,d,size_ff,C) - | Greatereq_f64 => cmpf64_kill_tmp0(GREATEREQUAL,x,y,d,size_ff,C) - | Andb_word31 => andb_word_kill_tmp01(x,y,d,size_ff,C) - | Andb_word32ub => andb_word_kill_tmp01(x,y,d,size_ff,C) - | Orb_word31 => orb_word_kill_tmp01(x,y,d,size_ff,C) - | Orb_word32ub => orb_word_kill_tmp01(x,y,d,size_ff,C) - | Xorb_word31 => xorb_word_kill_tmp01 {tag=true} (x,y,d,size_ff,C) - | Xorb_word32ub => xorb_word_kill_tmp01 {tag=false} (x,y,d,size_ff,C) - | Shift_left_word31 => shift_left_word_kill_tmp01 {tag=true} (x,y,d,size_ff,C) - | Shift_left_word32ub => shift_left_word_kill_tmp01 {tag=false} (x,y,d,size_ff,C) - | Shift_right_signed_word31 => shift_right_signed_word_kill_tmp01 {tag=true} (x,y,d,size_ff,C) - | Shift_right_signed_word32ub => shift_right_signed_word_kill_tmp01 {tag=false} (x,y,d,size_ff,C) - | Shift_right_unsigned_word31 => shift_right_unsigned_word_kill_tmp01 {tag=true} (x,y,d,size_ff,C) - | Shift_right_unsigned_word32ub => shift_right_unsigned_word_kill_tmp01 {tag=false} (x,y,d,size_ff,C) - | Int31_to_int32b => num31_to_num32b(x,y,d,size_ff,C) - | Word31_to_word32b => num31_to_num32b(x,y,d,size_ff,C) - | Word31_to_word32b_X => num31_to_num32b(x,y,d,size_ff,C) + Equal_int32ub => cmpi_kill_tmp01 {box=false, quad=false} I.je (x,y,d,size_ff,C) + | Equal_int32b => cmpi_kill_tmp01 {box=true, quad=false} I.je (x,y,d,size_ff,C) + | Equal_int31 => cmpi_kill_tmp01 {box=false, quad=false} I.je (x,y,d,size_ff,C) + | Equal_word31 => cmpi_kill_tmp01 {box=false, quad=false} I.je (x,y,d,size_ff,C) + | Equal_word32ub => cmpi_kill_tmp01 {box=false, quad=false} I.je (x,y,d,size_ff,C) + | Equal_word32b => cmpi_kill_tmp01 {box=true, quad=false} I.je (x,y,d,size_ff,C) + | Equal_int64ub => cmpi_kill_tmp01 {box=false, quad=true} I.je (x,y,d,size_ff,C) + | Equal_int64b => cmpi_kill_tmp01 {box=true, quad=true} I.je (x,y,d,size_ff,C) + | Equal_int63 => cmpi_kill_tmp01 {box=false, quad=true} I.je (x,y,d,size_ff,C) + | Equal_word63 => cmpi_kill_tmp01 {box=false, quad=true} I.je (x,y,d,size_ff,C) + | Equal_word64ub => cmpi_kill_tmp01 {box=false, quad=true} I.je (x,y,d,size_ff,C) + | Equal_word64b => cmpi_kill_tmp01 {box=true, quad=true} I.je (x,y,d,size_ff,C) + + | Plus_int32ub => add_num_kill_tmp01 {ovf=true, tag=false, quad=false} (x,y,d,size_ff,C) + | Plus_int31 => add_num_kill_tmp01 {ovf=true, tag=true, quad=false} (x,y,d,size_ff,C) + | Plus_word31 => add_num_kill_tmp01 {ovf=false, tag=true, quad=false} (x,y,d,size_ff,C) + | Plus_word32ub => add_num_kill_tmp01 {ovf=false, tag=false, quad=false} (x,y,d,size_ff,C) + | Plus_int64ub => add_num_kill_tmp01 {ovf=true, tag=false, quad=true} (x,y,d,size_ff,C) + | Plus_int63 => add_num_kill_tmp01 {ovf=true, tag=true, quad=true} (x,y,d,size_ff,C) + | Plus_word63 => add_num_kill_tmp01 {ovf=false, tag=true, quad=true} (x,y,d,size_ff,C) + | Plus_word64ub => add_num_kill_tmp01 {ovf=false, tag=false, quad=true} (x,y,d,size_ff,C) + + | Minus_int32ub => sub_num_kill_tmp01 {ovf=true, tag=false, quad=false} (x,y,d,size_ff,C) + | Minus_int31 => sub_num_kill_tmp01 {ovf=true, tag=true, quad=false} (x,y,d,size_ff,C) + | Minus_word31 => sub_num_kill_tmp01 {ovf=false, tag=true, quad=false} (x,y,d,size_ff,C) + | Minus_word32ub => sub_num_kill_tmp01 {ovf=false, tag=false, quad=false} (x,y,d,size_ff,C) + | Minus_int64ub => sub_num_kill_tmp01 {ovf=true, tag=false, quad=true} (x,y,d,size_ff,C) + | Minus_int63 => sub_num_kill_tmp01 {ovf=true, tag=true, quad=true} (x,y,d,size_ff,C) + | Minus_word63 => sub_num_kill_tmp01 {ovf=false, tag=true, quad=true} (x,y,d,size_ff,C) + | Minus_word64ub => sub_num_kill_tmp01 {ovf=false, tag=false, quad=true} (x,y,d,size_ff,C) + + | Mul_int32ub => mul_num_kill_tmp01 {ovf=true, tag=false, quad=false} (x,y,d,size_ff,C) + | Mul_int31 => mul_num_kill_tmp01 {ovf=true, tag=true, quad=false} (x,y,d,size_ff,C) + | Mul_word31 => mul_num_kill_tmp01 {ovf=false, tag=true, quad=false} (x,y,d,size_ff,C) + | Mul_word32ub => mul_num_kill_tmp01 {ovf=false, tag=false, quad=false} (x,y,d,size_ff,C) + | Mul_int64ub => mul_num_kill_tmp01 {ovf=true, tag=false, quad=true} (x,y,d,size_ff,C) + | Mul_int63 => mul_num_kill_tmp01 {ovf=true, tag=true, quad=true} (x,y,d,size_ff,C) + | Mul_word63 => mul_num_kill_tmp01 {ovf=false, tag=true, quad=true} (x,y,d,size_ff,C) + | Mul_word64ub => mul_num_kill_tmp01 {ovf=false, tag=false, quad=true} (x,y,d,size_ff,C) + + | Neg_int32b => neg_int_boxed_kill_tmp0 {quad=false} (x,y,d,size_ff,C) + | Neg_int64b => neg_int_boxed_kill_tmp0 {quad=true} (x,y,d,size_ff,C) + | Neg_real => negf_kill_tmp01 (x,y,d,size_ff,C) + | Abs_int32b => abs_int_boxed_kill_tmp0 {quad=false} (x,y,d,size_ff,C) + | Abs_int64b => abs_int_boxed_kill_tmp0 {quad=true} (x,y,d,size_ff,C) + | Abs_real => absf_kill_tmp01 (x,y,d,size_ff,C) + + | Less_int32ub => cmpi_kill_tmp01 {box=false, quad=false} I.jl (x,y,d,size_ff,C) + | Less_int32b => cmpi_kill_tmp01 {box=true, quad=false} I.jl (x,y,d,size_ff,C) + | Less_int31 => cmpi_kill_tmp01 {box=false, quad=false} I.jl (x,y,d,size_ff,C) + | Less_word31 => cmpi_kill_tmp01 {box=false, quad=false} I.jb (x,y,d,size_ff,C) + | Less_word32ub => cmpi_kill_tmp01 {box=false, quad=false} I.jb (x,y,d,size_ff,C) + | Less_word32b => cmpi_kill_tmp01 {box=true, quad=false} I.jb (x,y,d,size_ff,C) + | Less_int64ub => cmpi_kill_tmp01 {box=false, quad=true} I.jl (x,y,d,size_ff,C) + | Less_int64b => cmpi_kill_tmp01 {box=true, quad=true} I.jl (x,y,d,size_ff,C) + | Less_int63 => cmpi_kill_tmp01 {box=false, quad=true} I.jl (x,y,d,size_ff,C) + | Less_word63 => cmpi_kill_tmp01 {box=false, quad=true} I.jb (x,y,d,size_ff,C) + | Less_word64ub => cmpi_kill_tmp01 {box=false, quad=true} I.jb (x,y,d,size_ff,C) + | Less_word64b => cmpi_kill_tmp01 {box=true, quad=true} I.jb (x,y,d,size_ff,C) + + | Less_real => cmpf_kill_tmp01 LESSTHAN (x,y,d,size_ff,C) + | Less_f64 => cmpf64_kill_tmp0 LESSTHAN (x,y,d,size_ff,C) + + | Lesseq_int32ub => cmpi_kill_tmp01 {box=false, quad=false} I.jle (x,y,d,size_ff,C) + | Lesseq_int32b => cmpi_kill_tmp01 {box=true, quad=false} I.jle (x,y,d,size_ff,C) + | Lesseq_int31 => cmpi_kill_tmp01 {box=false, quad=false} I.jle (x,y,d,size_ff,C) + | Lesseq_word31 => cmpi_kill_tmp01 {box=false, quad=false} I.jbe (x,y,d,size_ff,C) + | Lesseq_word32ub => cmpi_kill_tmp01 {box=false, quad=false} I.jbe (x,y,d,size_ff,C) + | Lesseq_word32b => cmpi_kill_tmp01 {box=true, quad=false} I.jbe (x,y,d,size_ff,C) + | Lesseq_int64ub => cmpi_kill_tmp01 {box=false, quad=true} I.jle (x,y,d,size_ff,C) + | Lesseq_int64b => cmpi_kill_tmp01 {box=true, quad=true} I.jle (x,y,d,size_ff,C) + | Lesseq_int63 => cmpi_kill_tmp01 {box=false, quad=true} I.jle (x,y,d,size_ff,C) + | Lesseq_word63 => cmpi_kill_tmp01 {box=false, quad=true} I.jbe (x,y,d,size_ff,C) + | Lesseq_word64ub => cmpi_kill_tmp01 {box=false, quad=true} I.jbe (x,y,d,size_ff,C) + | Lesseq_word64b => cmpi_kill_tmp01 {box=true, quad=true} I.jbe (x,y,d,size_ff,C) + + | Lesseq_real => cmpf_kill_tmp01 LESSEQUAL (x,y,d,size_ff,C) + | Lesseq_f64 => cmpf64_kill_tmp0 LESSEQUAL (x,y,d,size_ff,C) + + | Greater_int32ub => cmpi_kill_tmp01 {box=false, quad=false} I.jg (x,y,d,size_ff,C) + | Greater_int32b => cmpi_kill_tmp01 {box=true, quad=false} I.jg (x,y,d,size_ff,C) + | Greater_int31 => cmpi_kill_tmp01 {box=false, quad=false} I.jg (x,y,d,size_ff,C) + | Greater_word31 => cmpi_kill_tmp01 {box=false, quad=false} I.ja (x,y,d,size_ff,C) + | Greater_word32ub => cmpi_kill_tmp01 {box=false, quad=false} I.ja (x,y,d,size_ff,C) + | Greater_word32b => cmpi_kill_tmp01 {box=true, quad=false} I.ja (x,y,d,size_ff,C) + | Greater_int64ub => cmpi_kill_tmp01 {box=false, quad=true} I.jg (x,y,d,size_ff,C) + | Greater_int64b => cmpi_kill_tmp01 {box=true, quad=true} I.jg (x,y,d,size_ff,C) + | Greater_int63 => cmpi_kill_tmp01 {box=false, quad=true} I.jg (x,y,d,size_ff,C) + | Greater_word63 => cmpi_kill_tmp01 {box=false, quad=true} I.ja (x,y,d,size_ff,C) + | Greater_word64ub => cmpi_kill_tmp01 {box=false, quad=true} I.ja (x,y,d,size_ff,C) + | Greater_word64b => cmpi_kill_tmp01 {box=true, quad=true} I.ja (x,y,d,size_ff,C) + + | Greater_real => cmpf_kill_tmp01 GREATERTHAN (x,y,d,size_ff,C) + | Greater_f64 => cmpf64_kill_tmp0 GREATERTHAN (x,y,d,size_ff,C) + + | Greatereq_int32ub => cmpi_kill_tmp01 {box=false, quad=false} I.jge (x,y,d,size_ff,C) + | Greatereq_int32b => cmpi_kill_tmp01 {box=true, quad=false} I.jge (x,y,d,size_ff,C) + | Greatereq_int31 => cmpi_kill_tmp01 {box=false, quad=false} I.jge (x,y,d,size_ff,C) + | Greatereq_word31 => cmpi_kill_tmp01 {box=false, quad=false} I.jae (x,y,d,size_ff,C) + | Greatereq_word32ub => cmpi_kill_tmp01 {box=false, quad=false} I.jae (x,y,d,size_ff,C) + | Greatereq_word32b => cmpi_kill_tmp01 {box=true, quad=false} I.jae (x,y,d,size_ff,C) + | Greatereq_int64ub => cmpi_kill_tmp01 {box=false, quad=true} I.jge (x,y,d,size_ff,C) + | Greatereq_int64b => cmpi_kill_tmp01 {box=true, quad=true} I.jge (x,y,d,size_ff,C) + | Greatereq_int63 => cmpi_kill_tmp01 {box=false, quad=true} I.jge (x,y,d,size_ff,C) + | Greatereq_word63 => cmpi_kill_tmp01 {box=false, quad=true} I.jae (x,y,d,size_ff,C) + | Greatereq_word64ub => cmpi_kill_tmp01 {box=false, quad=true} I.jae (x,y,d,size_ff,C) + | Greatereq_word64b => cmpi_kill_tmp01 {box=true, quad=true} I.jae (x,y,d,size_ff,C) + + | Greatereq_real => cmpf_kill_tmp01 GREATEREQUAL (x,y,d,size_ff,C) + | Greatereq_f64 => cmpf64_kill_tmp0 GREATEREQUAL (x,y,d,size_ff,C) + + | Andb_word31 => andb_word_kill_tmp01 {quad=false} (x,y,d,size_ff,C) + | Andb_word32ub => andb_word_kill_tmp01 {quad=false} (x,y,d,size_ff,C) + | Andb_word63 => andb_word_kill_tmp01 {quad=true} (x,y,d,size_ff,C) + | Andb_word64ub => andb_word_kill_tmp01 {quad=true} (x,y,d,size_ff,C) + + | Orb_word31 => orb_word_kill_tmp01 {quad=false} (x,y,d,size_ff,C) + | Orb_word32ub => orb_word_kill_tmp01 {quad=false} (x,y,d,size_ff,C) + | Orb_word63 => orb_word_kill_tmp01 {quad=true} (x,y,d,size_ff,C) + | Orb_word64ub => orb_word_kill_tmp01 {quad=true} (x,y,d,size_ff,C) + + | Xorb_word31 => xorb_word_kill_tmp01 {tag=true, quad=false} (x,y,d,size_ff,C) + | Xorb_word32ub => xorb_word_kill_tmp01 {tag=false, quad=false} (x,y,d,size_ff,C) + | Xorb_word63 => xorb_word_kill_tmp01 {tag=true, quad=true} (x,y,d,size_ff,C) + | Xorb_word64ub => xorb_word_kill_tmp01 {tag=false, quad=true} (x,y,d,size_ff,C) + + | Shift_left_word31 => shift_left_word_kill_tmp01 {tag=true, quad=false} (x,y,d,size_ff,C) + | Shift_left_word32ub => shift_left_word_kill_tmp01 {tag=false, quad=false} (x,y,d,size_ff,C) + | Shift_left_word63 => shift_left_word_kill_tmp01 {tag=true, quad=true} (x,y,d,size_ff,C) + | Shift_left_word64ub => shift_left_word_kill_tmp01 {tag=false, quad=true} (x,y,d,size_ff,C) + + | Shift_right_signed_word31 => shift_right_signed_word_kill_tmp01 {tag=true, quad=false} (x,y,d,size_ff,C) + | Shift_right_signed_word32ub => shift_right_signed_word_kill_tmp01 {tag=false, quad=false} (x,y,d,size_ff,C) + | Shift_right_signed_word63 => shift_right_signed_word_kill_tmp01 {tag=true, quad=true} (x,y,d,size_ff,C) + | Shift_right_signed_word64ub => shift_right_signed_word_kill_tmp01 {tag=false, quad=true} (x,y,d,size_ff,C) + + | Shift_right_unsigned_word31 => shift_right_unsigned_word_kill_tmp01 {tag=true, quad=false} (x,y,d,size_ff,C) + | Shift_right_unsigned_word32ub => shift_right_unsigned_word_kill_tmp01 {tag=false, quad=false} (x,y,d,size_ff,C) + | Shift_right_unsigned_word63 => shift_right_unsigned_word_kill_tmp01 {tag=true, quad=true} (x,y,d,size_ff,C) + | Shift_right_unsigned_word64ub => shift_right_unsigned_word_kill_tmp01 {tag=false, quad=true} (x,y,d,size_ff,C) + + | Int31_to_int32b => num31_to_num_boxed {quad=false} (x,y,d,size_ff,C) + | Word31_to_word32b => num31_to_num_boxed {quad=false} (x,y,d,size_ff,C) + | Word31_to_word32b_X => num31_to_num_boxed {quad=false} (x,y,d,size_ff,C) | Word32b_to_int32b => num32b_to_num32b {ovf=true} (x,y,d,size_ff,C) | Word32b_to_int32b_X => num32b_to_num32b {ovf=false} (x,y,d,size_ff,C) | Int32b_to_word32b => num32b_to_num32b {ovf=false} (x,y,d,size_ff,C) - | Bytetable_sub => bytetable_sub(x,y,d,size_ff,C) - | Word_sub0 => word_sub0(x,y,d,size_ff,C) - | Plus_f64 => plus_f64(x,y,d,size_ff,C) - | Minus_f64 => minus_f64(x,y,d,size_ff,C) - | Mul_f64 => mul_f64(x,y,d,size_ff,C) - | Div_f64 => div_f64(x,y,d,size_ff,C) - | Max_f64 => max_f64(x,y,d,size_ff,C) - | Min_f64 => min_f64(x,y,d,size_ff,C) - | F64_to_real => f64_to_real_kill_tmp01(y,x,d,size_ff,C) - | Blockf64_alloc => blockf64_alloc(x,y,d,size_ff,C) - | Blockf64_sub_f64 => blockf64_sub_f64(x,y,d,size_ff,C) + + | Word64b_to_int64b_X => num64b_to_num64b {ovf=false} (x,y,d,size_ff,C) + | Word64b_to_int64b => num64b_to_num64b {ovf=true} (x,y,d,size_ff,C) + | Word32b_to_word64b => word32b_to_word64b {signext=false} (x,y,d,size_ff,C) + | Word32b_to_word64b_X => word32b_to_word64b {signext=true} (x,y,d,size_ff,C) + | Word64b_to_word32b => num64b_to_num32b (x,y,d,size_ff,C) + | Word31_to_word64b => word31_to_word64b {signext=false} (x,y,d,size_ff,C) + | Word31_to_word64b_X => word31_to_word64b {signext=true} (x,y,d,size_ff,C) + + | Int32b_to_int64b => int32b_to_int64b (x,y,d,size_ff,C) + | Int64b_to_word64b => num64b_to_num64b {ovf=false} (x,y,d,size_ff,C) + + | Int31_to_int64b => num31_to_num_boxed {quad=true} (x,y,d,size_ff,C) + + | Int63_to_int64b => num63_to_num64b {shr_inst=I.sarq} (x,y,d,size_ff,C) + | Word63_to_word32b => word63_to_word32b (x,y,d,size_ff,C) + | Word63_to_word64b => num63_to_num64b {shr_inst=I.shrq} (x,y,d,size_ff,C) + | Word63_to_word64b_X => num63_to_num64b {shr_inst=I.sarq} (x,y,d,size_ff,C) + + | Int63_to_int32b => int63_to_int32b (x,y,d,size_ff,C) + + | Bytetable_sub => bytetable_sub (x,y,d,size_ff,C) + | Word_sub0 => word_sub0 (x,y,d,size_ff,C) + | Plus_f64 => plus_f64 (x,y,d,size_ff,C) + | Minus_f64 => minus_f64 (x,y,d,size_ff,C) + | Mul_f64 => mul_f64 (x,y,d,size_ff,C) + | Div_f64 => div_f64 (x,y,d,size_ff,C) + | Max_f64 => max_f64 (x,y,d,size_ff,C) + | Min_f64 => min_f64 (x,y,d,size_ff,C) + | F64_to_real => f64_to_real_kill_tmp01 (x,y,d,size_ff,C) + | Blockf64_alloc => blockf64_alloc (x,y,d,size_ff,C) + | Blockf64_sub_f64 => blockf64_sub_f64 (x,y,d,size_ff,C) | _ => die ("unsupported prim with 2 args: " ^ PrimName.pp_prim name)) | [b,x,y] => (case name of Plus_int32b => add_int32b (b,x,y,d,size_ff,C) - | Plus_word32b => addw32boxed(b,x,y,d,size_ff,C) - | Plus_real => addf_kill_tmp01(x,y,b,d,size_ff,C) + | Plus_int64b => add_int64b (b,x,y,d,size_ff,C) + | Plus_word32b => addw32boxed (b,x,y,d,size_ff,C) + | Plus_word64b => addw64boxed (b,x,y,d,size_ff,C) + | Plus_real => addf_kill_tmp01 (x,y,b,d,size_ff,C) | Minus_int32b => sub_int32b (b,x,y,d,size_ff,C) - | Minus_word32b => subw32boxed(b,x,y,d,size_ff,C) - | Minus_real => subf_kill_tmp01(x,y,b,d,size_ff,C) + | Minus_int64b => sub_int64b (b,x,y,d,size_ff,C) + | Minus_word32b => subw32boxed (b,x,y,d,size_ff,C) + | Minus_word64b => subw64boxed (b,x,y,d,size_ff,C) + | Minus_real => subf_kill_tmp01 (x,y,b,d,size_ff,C) | Mul_int32b => mul_int32b (b,x,y,d,size_ff,C) - | Mul_word32b => mulw32boxed(b,x,y,d,size_ff,C) - | Mul_real => mulf_kill_tmp01(x,y,b,d,size_ff,C) - | Div_real => divf_kill_tmp01(x,y,b,d,size_ff,C) - | Andb_word32b => andw32boxed__(b,x,y,d,size_ff,C) - | Orb_word32b => orw32boxed__(b,x,y,d,size_ff,C) - | Xorb_word32b => xorw32boxed__(b,x,y,d,size_ff,C) - | Shift_left_word32b => shift_leftw32boxed__(b,x,y,d,size_ff,C) - | Shift_right_signed_word32b => shift_right_signedw32boxed__(b,x,y,d,size_ff,C) - | Shift_right_unsigned_word32b => shift_right_unsignedw32boxed__(b,x,y,d,size_ff,C) - | Bytetable_update => bytetable_update(b,x,y,d,size_ff,C) - | Word_update0 => word_update0(b,x,y,d,size_ff,C) - | Blockf64_update_real => blockf64_update_real(b,x,y,d,size_ff,C) - | Blockf64_sub_real => blockf64_sub_real(b,x,y,d,size_ff,C) - | Blockf64_update_f64 => blockf64_update_f64(b,x,y,d,size_ff,C) + | Mul_int64b => mul_int64b (b,x,y,d,size_ff,C) + | Mul_word32b => mulw32boxed (b,x,y,d,size_ff,C) + | Mul_word64b => mulw64boxed (b,x,y,d,size_ff,C) + | Mul_real => mulf_kill_tmp01 (x,y,b,d,size_ff,C) + | Div_real => divf_kill_tmp01 (x,y,b,d,size_ff,C) + | Andb_word32b => andw32boxed__ (b,x,y,d,size_ff,C) + | Andb_word64b => andw64boxed__ (b,x,y,d,size_ff,C) + | Orb_word32b => orw32boxed__ (b,x,y,d,size_ff,C) + | Orb_word64b => orw64boxed__ (b,x,y,d,size_ff,C) + | Xorb_word32b => xorw32boxed__ (b,x,y,d,size_ff,C) + | Xorb_word64b => xorw64boxed__ (b,x,y,d,size_ff,C) + | Shift_left_word32b => shift_leftw32boxed__ (b,x,y,d,size_ff,C) + | Shift_left_word64b => shift_leftw64boxed__ (b,x,y,d,size_ff,C) + | Shift_right_signed_word32b => shift_right_signedw32boxed__ (b,x,y,d,size_ff,C) + | Shift_right_signed_word64b => shift_right_signedw64boxed__ (b,x,y,d,size_ff,C) + | Shift_right_unsigned_word32b => shift_right_unsignedw32boxed__ (b,x,y,d,size_ff,C) + | Shift_right_unsigned_word64b => shift_right_unsignedw64boxed__ (b,x,y,d,size_ff,C) + | Bytetable_update => bytetable_update (b,x,y,d,size_ff,C) + | Word_update0 => word_update0 (b,x,y,d,size_ff,C) + | Blockf64_update_real => blockf64_update_real (b,x,y,d,size_ff,C) + | Blockf64_sub_real => blockf64_sub_real (b,x,y,d,size_ff,C) + | Blockf64_update_f64 => blockf64_update_f64 (b,x,y,d,size_ff,C) | _ => die ("unsupported prim with 3 args: " ^ PrimName.pp_prim name)) | _ => die ("PRIM(" ^ PrimName.pp_prim name ^ ") not implemented"))) end diff --git a/src/Compiler/Backend/X64/INSTS_X64.sml b/src/Compiler/Backend/X64/INSTS_X64.sml index ff84fd317..296a3c1a0 100644 --- a/src/Compiler/Backend/X64/INSTS_X64.sml +++ b/src/Compiler/Backend/X64/INSTS_X64.sml @@ -51,8 +51,10 @@ signature INSTS_X64 = datatype inst = (* general instructions *) movq of ea * ea + | mov of ea * ea (* e.g. for zero extension for moving 32-bit values into 64-bit registers *) | movb of ea * ea | movzbq of ea * ea + | movslq of ea * ea | push of ea | leaq of ea * ea | pop of ea @@ -102,7 +104,7 @@ signature INSTS_X64 = | ucomisd of ea * ea | xorps of ea * ea | sqrtsd of ea * ea - | cvtsi2sdl of ea * ea + | cvtsi2sdq of ea * ea | fstpq of ea (* store float and pop float stack *) | fldq of ea (* push float onto the float stack *) diff --git a/src/Compiler/Backend/X64/InstsX64.sml b/src/Compiler/Backend/X64/InstsX64.sml index cb34e8986..fe0c98d0f 100644 --- a/src/Compiler/Backend/X64/InstsX64.sml +++ b/src/Compiler/Backend/X64/InstsX64.sml @@ -69,8 +69,10 @@ structure InstsX64: INSTS_X64 = datatype inst = (* general instructions *) movq of ea * ea + | mov of ea * ea | movb of ea * ea | movzbq of ea * ea + | movslq of ea * ea | push of ea | leaq of ea * ea | pop of ea @@ -120,7 +122,7 @@ structure InstsX64: INSTS_X64 = | ucomisd of ea * ea | xorps of ea * ea | sqrtsd of ea * ea - | cvtsi2sdl of ea * ea + | cvtsi2sdq of ea * ea | fstpq of ea (* store float and pop float stack *) | fldq of ea (* push float onto the float stack *) @@ -305,10 +307,12 @@ structure InstsX64: INSTS_X64 = fun emit_nullary0 s = (emit s; emit_nl()) fun emit_jump (s,l) = (emit "\t"; emit s; emit " "; emit(pr_lab l); emit_nl()) fun emit_inst i = - case i - of movq a => emit_bin ("movq", a) + case i of + movq a => emit_bin ("movq", a) + | mov a => emit_bin ("mov", a) | movb a => emit_bin ("movb", a) | movzbq a => emit_bin ("movzbq", a) + | movslq a => emit_bin ("movslq", a) | leaq a => emit_bin ("leaq", a) | push ea => emit_unary ("push", ea) | pop ea => emit_unary ("pop", ea) @@ -358,7 +362,7 @@ structure InstsX64: INSTS_X64 = | ucomisd a => emit_bin("ucomisd", a) | xorps a => emit_bin("xorps", a) | sqrtsd a => emit_bin("sqrtsd", a) - | cvtsi2sdl a => emit_bin("cvtsi2sdl", a) + | cvtsi2sdq a => emit_bin("cvtsi2sdq", a) | fstpq ea => emit_unary("fstpq", ea) | fldq ea => emit_unary("fldq", ea) @@ -565,8 +569,10 @@ structure InstsX64: INSTS_X64 = | DD (s1,r1,r2,s2) => DD(s1,Rm r1, Rm r2,s2) in case i of movq (ea1,ea2) => movq (Em ea1,Em ea2) + | mov (ea1,ea2) => mov (Em ea1,Em ea2) | movb (ea1,ea2) => movb (Em ea1,Em ea2) | movzbq (ea1,ea2) => movzbq (Em ea1,Em ea2) + | movslq (ea1,ea2) => movslq (Em ea1,Em ea2) | push ea => push (Em ea) | leaq (ea1,ea2) => leaq (Em ea1,Em ea2) | pop ea => pop (Em ea) @@ -613,7 +619,7 @@ structure InstsX64: INSTS_X64 = | ucomisd (ea1,ea2) => ucomisd (Em ea1,Em ea2) | xorps (ea1,ea2) => xorps (Em ea1,Em ea2) | sqrtsd (ea1,ea2) => sqrtsd (Em ea1,Em ea2) - | cvtsi2sdl (ea1,ea2) => cvtsi2sdl (Em ea1,Em ea2) + | cvtsi2sdq (ea1,ea2) => cvtsi2sdq (Em ea1,Em ea2) | fstpq ea => fstpq (Em ea) | fldq ea => fldq (Em ea) | jmp ea => jmp (Em ea) diff --git a/src/Compiler/CompBasis.sml b/src/Compiler/CompBasis.sml index 8c21ccf0e..4e2f034b1 100644 --- a/src/Compiler/CompBasis.sml +++ b/src/Compiler/CompBasis.sml @@ -56,9 +56,9 @@ structure CompBasis: COMP_BASIS = drop_env=DropRegions.init, psi_env=PhysSizeInf.init} - fun plus({NEnv,TCEnv,EqEnv,OEnv,rse,mulenv,mularefmap,drop_env,psi_env}, - {NEnv=NEnv',TCEnv=TCEnv',EqEnv=EqEnv',OEnv=OEnv',rse=rse',mulenv=mulenv', - mularefmap=mularefmap',drop_env=drop_env',psi_env=psi_env'}) = + fun plus ({NEnv,TCEnv,EqEnv,OEnv,rse,mulenv,mularefmap,drop_env,psi_env}, + {NEnv=NEnv',TCEnv=TCEnv',EqEnv=EqEnv',OEnv=OEnv',rse=rse',mulenv=mulenv', + mularefmap=mularefmap',drop_env=drop_env',psi_env=psi_env'}) = {NEnv=Normalize.plus(NEnv,NEnv'), TCEnv=LambdaStatSem.plus(TCEnv,TCEnv'), EqEnv=EliminateEq.plus(EqEnv,EqEnv'), @@ -84,12 +84,12 @@ structure CompBasis: COMP_BASIS = ] } - fun debug(s, b) = if !debug_man_enrich then + fun debug (s, b) = if !debug_man_enrich then (if b then log("\n" ^ s ^ ": enrich succeeded.") else log("\n" ^ s ^ ": enrich failed."); b) - else b + else b - fun debug1(s, b,oenv,oenv1) = + fun debug1 (s, b,oenv,oenv1) = if !debug_man_enrich then (if b then log("\n" ^ s ^ ": enrich succeeded.") else (log("\n" ^ s ^ ": enrich failed."); diff --git a/src/Compiler/Lambda/CompileDec.sml b/src/Compiler/Lambda/CompileDec.sml index d068b71de..750c6e13a 100644 --- a/src/Compiler/Lambda/CompileDec.sml +++ b/src/Compiler/Lambda/CompileDec.sml @@ -19,6 +19,7 @@ structure CompileDec: COMPILE_DEC = o ElabInfo.to_ParseInfo val tag_values = Flags.is_on0 "tag_values" + val values_64bit = Flags.is_on0 "values_64bit" fun chat s = if !Flags.chat then print (s ^ "\n") else () @@ -113,11 +114,11 @@ structure CompileDec: COMPILE_DEC = in val TLEunit = PRIM(RECORDprim NONE,[]) - fun monoLet((lv,tau,lamb1),lamb2) = + fun monoLet ((lv,tau,lamb1),lamb2) = LET{pat=[(lv,[],tau)], bind=lamb1, scope=lamb2} - fun If(e,e1,e2) = + fun If (e,e1,e2) = SWITCH_C(SWITCH(e,[((Con.con_TRUE,NONE),e1)],SOME e2)) end @@ -125,7 +126,7 @@ structure CompileDec: COMPILE_DEC = | new_lvar_from_string_opt (SOME string) = Lvars.new_named_lvar string val new_lvar_from_id = Lvars.new_named_lvar o Ident.pr_id val new_lvar_from_pat = - new_lvar_from_string_opt o DecGrammar.find_topmost_id_in_pat + new_lvar_from_string_opt o DecGrammar.find_topmost_id_in_pat fun new_lvar_from_pats [pat] = new_lvar_from_pat pat | new_lvar_from_pats _ = Lvars.newLvar () @@ -160,8 +161,8 @@ structure CompileDec: COMPILE_DEC = struct val datbindss : datbind_list list ref = ref [] fun add datbinds = datbindss := (datbinds :: (! datbindss)) - fun extract() = rev(!datbindss) - fun reset() = datbindss := [] + fun extract () = rev(!datbindss) + fun reset () = datbindss := [] end (* --------------------- *) @@ -288,24 +289,24 @@ structure CompileDec: COMPILE_DEC = NONE => die errmsg | SOME y => y - fun zip3(hd :: tl, hd' :: tl', hd'' :: tl'') = - (hd, hd', hd'') :: zip3(tl, tl', tl'') - | zip3(nil, nil, nil) = nil + fun zip3 (hd :: tl, hd' :: tl', hd'' :: tl'') = + (hd, hd', hd'') :: zip3(tl, tl', tl'') + | zip3 (nil, nil, nil) = nil | zip3 _ = die "zip3" - +(* local - fun unzip3'((x, y, z) :: rest, xs, ys, zs) = + fun unzip3' ((x, y, z) :: rest, xs, ys, zs) = unzip3'(rest, x :: xs, y :: ys, z :: zs) - | unzip3'(nil, xs, ys, zs) = (xs, ys, zs) + | unzip3' (nil, xs, ys, zs) = (xs, ys, zs) in fun unzip3 triples = unzip3'(rev triples, nil, nil, nil) end - fun zip4(hd :: tl, hd' :: tl', hd'' :: tl'', hd''' :: tl''') = + fun zip4 (hd :: tl, hd' :: tl', hd'' :: tl'', hd''' :: tl''') = (hd, hd', hd'', hd''') :: zip4(tl, tl', tl'', tl''') - | zip4(nil, nil, nil, nil) = nil + | zip4 (nil, nil, nil, nil) = nil | zip4 _ = die "zip4" - +*) fun mk_env declare (xs,ys) = foldr (fn ((x,y), env) => declare(x,y,env)) CE.emptyCEnv @@ -318,10 +319,10 @@ structure CompileDec: COMPILE_DEC = in "[" ^ pr_l l ^ "]" end +(* fun hd s (x::xs) = x | hd s [] = die (s ^ ".hd") - - +*) (* ---------------------------------------------------------------------- *) (* Utility functions used to compile constructors *) @@ -464,13 +465,13 @@ structure CompileDec: COMPILE_DEC = (* Constructing intinfs *) - fun digits (x:IntInf.int) : Int32.int list = + fun digits (x:IntInf.int) : IntInf.int list = if x = IntInf.fromInt 0 then nil else - let val maxdigit = IntInf.fromLarge (Int32.toLarge 1073741824) (* 2^30 *) + let val maxdigit = 1073741824 (* 2^30 *) val rest = IntInf.div(x,maxdigit) val d = IntInf.mod(x,maxdigit) - in Int32.fromLarge (IntInf.toLarge d) :: digits rest + in d :: digits rest end fun buildIntInf (x : IntInf.int) = @@ -911,7 +912,7 @@ Report: Opt: | string_from_con (Scon (SCon.STRING s, _)) = "a_string" | string_from_con (Scon (SCon.REAL r, _)) = "a_real" | string_from_con (Scon (SCon.CHAR c, _)) = "a_char" - | string_from_con (Scon (SCon.WORD w, _)) = Word32.toString w + | string_from_con (Scon (SCon.WORD w, _)) = "0w" ^ IntInf.toString w | string_from_con (Excon {longid, ...}) = Ident.pr_longid longid | string_from_con (Tuple {arity}) = "a_tuple" @@ -1342,6 +1343,8 @@ in in if eq (tn, tyName_INTINF) then ~1 else if eq (tn, tyName_INT31) orelse eq (tn, tyName_WORD31) then 31 else if eq (tn, tyName_INT32) orelse eq (tn, tyName_WORD32) then 32 + else if eq (tn, tyName_INT63) orelse eq (tn, tyName_WORD63) then 63 + else if eq (tn, tyName_INT64) orelse eq (tn, tyName_WORD64) then 64 else die ("precision. tn = " ^ pr_TyName tn ^ " not expected") end in @@ -1358,20 +1361,17 @@ in | _ => die "compile_node: fn Con =>") | Scon (SCon.INTEGER _, tau) => (case precision tau of - ~1 => (* intinf *) - switch (switch_ii, - fn (Scon (SCon.INTEGER i,_),env) => (i,env) - | _ => die "compile_node: fn Scon (SCon.INTEGER i) =>") - | p => - switch - (fn sw => SWITCH_I{switch=sw,precision=p}, - fn (Scon (SCon.INTEGER i,_),env) => - ((Int32.fromLarge(IntInf.toLarge i),env) - handle _ => die "IntInf in patterns not implemented") - | _ => die "compile_node: fn Scon (SCon.INTEGER i) =>")) + ~1 => (* intinf *) + switch (switch_ii, + fn (Scon (SCon.INTEGER i,_),env) => (i,env) + | _ => die "compile_node: fn Scon (SCon.INTEGER i) =>") + | p => switch + (fn sw => SWITCH_I{switch=sw,precision=p}, + fn (Scon (SCon.INTEGER i,_),env) => (i,env) + | _ => die "compile_node: fn Scon (SCon.INTEGER i) =>")) | Scon (SCon.CHAR _, tau) => switch (fn sw => SWITCH_W {switch=sw, precision=precision tau}, - fn (Scon (SCon.CHAR i,_),env) => (Word32.fromInt i,env) + fn (Scon (SCon.CHAR i,_),env) => (IntInf.fromInt i,env) | _ => die "compile_node: fn Scon (SCon.CHAR i) =>") | Scon (SCon.WORD _, tau) => switch (fn sw => SWITCH_W{switch=sw, precision=precision tau}, @@ -1632,26 +1632,27 @@ end; (*match compiler local*) (* Compilation of CCall names *) (* ---------------------------------------------------------------------- *) - (* The flag "tag_values" determines whether 32-bit integer - values and 32-bit word values are implemented boxed or - unboxed. When "tag_values" is enabled, 32-bit integers and - 32-bit words are represented boxed and the default integer type + (* The flag "tag_values" determines whether 32/64-bit integer + values and 32/64-bit word values are implemented boxed or + unboxed. When "tag_values" is enabled, 32/64-bit integers and + 32/64-bit words are represented boxed and the default integer type (int) is defined, internally, to be int31 and the default word type is defined to be word31. Contrary, when "tag_values" is - disabled, 32-bit integers and 32-bit words are represented + disabled, 32/64-bit integers and 32/64-bit words are represented unboxed-untagged and the default integer type (int) is defined, - internally, to be int32 and the default word type is defined to - be word32. + internally, to be int32/64 and the default word type is defined to + be word32/64. - The function compileCName transforms 32-bit primitives into + The function compileCName transforms 32/64-bit primitives into primitives on either boxed or unboxed representations dependent on the value of the "tag_values" flag. The function also transforms operations on integers and words into operations on - either 32-bit representations or 31-bit representations. + either 32/64-bit representations or 31/63-bit representations. - Overloading is dealt with independently, but whether 32-bit + Overloading is dealt with independently, but whether 32/64-bit primitives work on boxed or unboxed representations is resolved - here. *) + here. + *) local structure CNameMap = OrderFinMap(struct @@ -1659,61 +1660,156 @@ end; (*match compiler local*) val lt : T -> T -> bool = fn a => fn b => a < b end) - (* 32-bit primitives are resolved to primitives working on either + (* 32-bit and 64-bit primitives are resolved to primitives working on either * boxed or unboxed representations *) - fun resolve_32bit_prim p = (p, (p ^ "b", p ^ "ub")) + fun resolve_boxity p = (p, (p ^ "b", p ^ "ub")) (* primitives on integers and words are resolved to primitives working - * on either 31-bit or 32-bit unboxed representations. *) - fun resolve_default p = (p, (p ^ "31", p ^ "32ub")) - - val M = CNameMap.fromList - (map resolve_32bit_prim + * on either 31-bit or 32-bit unboxed representations (63-bit or 64-bit + * unboxed representations if supported). *) + fun resolve_default p = + (p, if values_64bit() + then (p ^ "63", p ^ "64ub") + else (p ^ "31", p ^ "32ub")) + + fun mkM () = + CNameMap.fromList + (map resolve_boxity ["__shift_left_word32", "__shift_right_signed_word32", "__shift_right_unsigned_word32", "__andb_word32", "__orb_word32", "__xorb_word32", "__quot_int32", "__rem_int32", "__max_int32", "__min_int32", "__int31_to_int32", "__word31_to_word32", - "__plus_int32", "__plus_word32", "__minus_int32", "__minus_word32", (* overloaded primitives *) "__mul_int32", "__mul_word32", "__div_int32", "__div_word32", "__mod_int32", "__mod_word32", "__less_int32", "__less_word32", "__greater_int32", "__greater_word32", "__lesseq_int32", "__lesseq_word32", "__greatereq_int32", "__greatereq_word32", "__neg_int32", "__abs_int32", - "__equal_int32", "__equal_word32" - ] + ] + @ + (if values_64bit() then + map resolve_boxity + ["__shift_left_word64", "__shift_right_signed_word64", + "__shift_right_unsigned_word64", "__andb_word64", "__orb_word64", + "__xorb_word64", "__quot_int64", "__rem_int64", "__max_int64", "__min_int64", + "__int63_to_int64", "__word63_to_word64", + "__plus_int64", "__plus_word64", "__minus_int64", "__minus_word64", (* overloaded primitives *) + "__mul_int64", "__mul_word64", "__div_int64", "__div_word64", "__mod_int64", "__mod_word64", + "__less_int64", "__less_word64", "__greater_int64", "__greater_word64", + "__lesseq_int64", "__lesseq_word64", "__greatereq_int64", "__greatereq_word64", + "__neg_int64", "__abs_int64", + "__equal_int64", "__equal_word64" + ] + else []) @ map resolve_default ["__quot_int", "__rem_int", "__max_int", "__min_int", "__equal_word", "__shift_left_word", "__shift_right_signed_word", "__shift_right_unsigned_word", "__orb_word", "__andb_word", "__xorb_word"] - @ - [("__int_to_int32", ("__int31_to_int32b", "id")), - ("__int31_to_int", ("id", "__int31_to_int32ub")), - ("__int32_to_int", ("__int32b_to_int31", "id")), - ("__int32_to_word", ("__int32b_to_word31", "id")), - ("__int32_to_word32", ("__int32b_to_word32b", "id")), - ("__int32_to_int31", ("__int32b_to_int31", "__int32ub_to_int31")), - ("__int_to_int31", ("id", "__int32ub_to_int31")), - ("__word_to_word32", ("__word31_to_word32b", "id")), - ("__word_to_word32_X", ("__word31_to_word32b_X", "id")), - ("__word31_to_word", ("id", "__word31_to_word32ub")), - ("__word32_to_word", ("__word32b_to_word31", "id")), - ("__word32_to_word31", ("__word32b_to_word31", "__word32ub_to_word31")), - ("__word_to_word31", ("id", "__word32ub_to_word31")), - ("__word31_to_word_X", ("id", "__word31_to_word32ub_X")), - ("__word31_to_word32_X", ("__word31_to_word32b_X", "__word31_to_word32ub_X")), - ("__word32_to_int32", ("__word32b_to_int32b", "__word32ub_to_int32ub")), - ("__word32_to_int32_X", ("__word32b_to_int32b_X", "id")), - ("__word32_to_int", ("__word32b_to_int31", "__word32ub_to_int32ub")), - ("__word32_to_int_X", ("__word32b_to_int31_X", "id")) - ]) + @ + let fun T t = + case t of + "int" => if values_64bit() + then ("int63", "int64ub") + else ("int31", "int32ub") + | "word" => if values_64bit() + then ("word63", "word64ub") + else ("word31", "word32ub") + | "int64" => ("int64b", "int64ub") + | "word64" => ("word64b", "word64ub") + | "int32" => ("int32b", "int32ub") + | "word32" => ("word32b", "word32ub") + | _ => (t,t) + fun prune "__int63_to_int63" = "id" + | prune "__int63_to_int63_X" = "id" + | prune "__int64ub_to_int64ub" = "id" + | prune "__word64ub_to_word64ub" = "id" + | prune "__word64ub_to_word64ub_X" = "id" + | prune "__word32ub_to_int32ub_X" = "id" + | prune "__int32ub_to_word32ub" = "id" + | prune "__int31_to_int31" = "id" + | prune "__int32ub_to_int32ub" = "id" + | prune "__word31_to_word31" = "id" + | prune "__word32ub_to_word32ub" = "id" + | prune "__word32ub_to_word32ub_X" = "id" + | prune s = s + fun conv0 pr t1 t2 = + (pr (t1,t2), let val (a1,b1) = T t1 + val (a2,b2) = T t2 + in (prune(pr (a1,a2)), prune(pr (b1,b2))) + end) + val conv = conv0 (fn (t1,t2) => "__" ^ t1 ^ "_to_" ^ t2) + val convX = conv0 (fn (t1,t2) => "__" ^ t1 ^ "_to_" ^ t2 ^ "_X") + in + [conv "int" "int31", + conv "int" "int32", + + conv "int31" "int", + + conv "int32" "int", + conv "int32" "word", + conv "int32" "word32", + conv "int32" "int31", + conv "word" "word32", + convX "word" "word32", + conv "word" "word31", + conv "word31" "word", + convX "word31" "word", + convX "word31" "word32", + conv "word32" "int", + convX "word32" "int", + conv "word32" "word", + conv "word32" "int32", + convX "word32" "int32", + conv "word32" "word31"] + @ (if values_64bit() then + [conv "int" "int63", + conv "int" "int64", + conv "int32" "int64", + conv "int63" "int", + + conv "int64" "int", + conv "int64" "word", + conv "int64" "word64", + conv "int64" "int63", + + conv "word" "word63", + conv "word" "word64", + convX "word" "word64", + + conv "word31" "word64", + convX "word31" "word64", + + conv "word32" "word64", + convX "word32" "word64", + + conv "word63" "word", + convX "word63" "word", + convX "word63" "word64", + + conv "word64" "int", + convX "word64" "int", + conv "word64" "int64", + convX "word64" "int64", + conv "word64" "word", + conv "word64" "word31", + conv "word64" "word32" + ] + else []) + end + ) + val M : (string*string) CNameMap.map option ref = ref NONE in - fun compileCName name = - case CNameMap.lookup M name - of SOME (tagged, untagged) => - if tag_values() then tagged - else untagged - | NONE => name + fun compileCName name = + let val m = case !M of + NONE => let val m = mkM() + in M := SOME m; m + end + | SOME m => m + in case CNameMap.lookup m name of + SOME (tagged, untagged) => if tag_values() then tagged + else untagged + | NONE => name + end end @@ -1728,43 +1824,55 @@ end; (*match compiler local*) local - fun resolve err_str i args {int31, int32, intinf, word8, word31, word32, real, string} = + fun resolve err_str i args {int31, int32, int63, int64, intinf, + word8, word31, word32, word63, word64, + real, string} = let fun no s (SOME e) = e args | no s NONE = die (err_str ^ ": " ^ s) - (* int resolved to int31 or int32 and word resolved to - * word31 or word32 in ElabDec. *) - in case NoSome err_str (ElabInfo.to_OverloadingInfo i) - of OverloadingInfo.RESOLVED_INT31 => no "int31" int31 - | OverloadingInfo.RESOLVED_INT32 => no "int32" int32 - | OverloadingInfo.RESOLVED_INTINF => no "intinf" intinf - | OverloadingInfo.RESOLVED_REAL => no "real" real - | OverloadingInfo.RESOLVED_WORD8 => no "word8" word8 - | OverloadingInfo.RESOLVED_WORD31 => no "word31" word31 - | OverloadingInfo.RESOLVED_WORD32 => no "word32" word32 - | OverloadingInfo.RESOLVED_CHAR => no "char" word8 - | OverloadingInfo.RESOLVED_STRING => no "string" string - | _ => die (err_str ^ ": unresolved") + (* int resolved to int31, int32, int63, or int64 and word resolved to + * word31, word32, word63, or word64 in ElabDec. *) + in case NoSome err_str (ElabInfo.to_OverloadingInfo i) of + OverloadingInfo.RESOLVED_INT31 => no "int31" int31 + | OverloadingInfo.RESOLVED_INT32 => no "int32" int32 + | OverloadingInfo.RESOLVED_INT63 => no "int63" int63 + | OverloadingInfo.RESOLVED_INT64 => no "int64" int64 + | OverloadingInfo.RESOLVED_INTINF => no "intinf" intinf + | OverloadingInfo.RESOLVED_REAL => no "real" real + | OverloadingInfo.RESOLVED_WORD8 => no "word8" word8 + | OverloadingInfo.RESOLVED_WORD31 => no "word31" word31 + | OverloadingInfo.RESOLVED_WORD32 => no "word32" word32 + | OverloadingInfo.RESOLVED_WORD63 => no "word63" word63 + | OverloadingInfo.RESOLVED_WORD64 => no "word64" word64 + | OverloadingInfo.RESOLVED_CHAR => no "char" word8 + | OverloadingInfo.RESOLVED_STRING => no "string" string + | _ => die (err_str ^ ": unresolved") end - fun int_or_real i args {int31, int32, intinf, real} = + fun int_or_real i args {int31, int32, int63, int64, intinf, real} = resolve "int_or_word" i args - {int31=SOME int31, int32=SOME int32, intinf=SOME intinf, word8=NONE, word31=NONE, - word32=NONE, real=SOME real, string=NONE} + {int31=SOME int31, int32=SOME int32, int63=SOME int63, int64=SOME int64, intinf=SOME intinf, + word8=NONE, word31=NONE, word32=NONE, word63=NONE, word64=NONE, + real=SOME real, string=NONE} - fun int_or_word i args {int31, int32, intinf, word8, word31, word32} = + fun int_or_word i args {int31, int32, int63, int64, intinf, word8, word31, word32, word63, word64} = resolve "int_or_word" i args - {int31=SOME int31, int32=SOME int32, intinf=SOME intinf, word8=SOME word8, word31=SOME word31, - word32=SOME word32, real=NONE, string=NONE} + {int31=SOME int31, int32=SOME int32, int63=SOME int63, int64=SOME int64, intinf=SOME intinf, + word8=SOME word8, word31=SOME word31, word32=SOME word32, word63=SOME word63, + word64=SOME word64, real=NONE, string=NONE} - fun int_or_word_or_real i args {int31, int32, intinf, word8, word31, word32, real} = + fun int_or_word_or_real i args {int31, int32, int63, int64, intinf, word8, word31, + word32, word63, word64, real} = resolve "int_or_word_or_real" i args - {int31=SOME int31, int32=SOME int32, intinf=SOME intinf, word8=SOME word8, word31=SOME word31, - word32=SOME word32, real=SOME real, string=NONE} + {int31=SOME int31, int32=SOME int32, int63=SOME int63, int64=SOME int64, intinf=SOME intinf, + word8=SOME word8, word31=SOME word31, word32=SOME word32, word63=SOME word63, + word64=SOME word64, real=SOME real, string=NONE} - fun string_or_int_or_word_or_real i args {string, int31, int32, intinf, word8, word31, word32, real} = + fun string_or_int_or_word_or_real i args {string, int31, int32, int63, int64, intinf, + word8, word31, word32, word63, word64, real} = resolve "string_or_int_or_word_or_real" i args - {int31=SOME int31, int32=SOME int32, intinf=SOME intinf, word8=SOME word8, word31=SOME word31, - word32=SOME word32, real=SOME real, string=SOME string} + {int31=SOME int31, int32=SOME int32, int63=SOME int63, int64=SOME int64, intinf=SOME intinf, + word8=SOME word8, word31=SOME word31, word32=SOME word32, word63=SOME word63, + word64=SOME word64, real=SOME real, string=SOME string} fun binary_ccall t n args = let val c = ccall n [t,t] t @@ -1790,73 +1898,156 @@ end; (*match compiler local*) fun norm31 e = binary_ccall word31Type "__andb_word31" - [WORD(0wxFF: Word32.word, word31Type), e] + [WORD(0xFF, word31Type), e] fun norm32 e = binary_ccall word32Type "__andb_word32" - [WORD(0wxFF: Word32.word, word32Type), e] + [WORD(0xFF, word32Type), e] + + fun norm63 e = + binary_ccall word63Type "__andb_word63" + [WORD(0xFF, word63Type), e] + + fun norm64 e = + binary_ccall word64Type "__andb_word64" + [WORD(0xFF, word64Type), e] val plus_word31 = binary_ccall word31Type "__plus_word31" val plus_word32 = binary_ccall word32Type "__plus_word32" - fun plus_word8 args = if tag_values() then norm31 (plus_word31 args) - else norm32 (plus_word32 args) + val plus_word63 = binary_ccall word63Type "__plus_word63" + val plus_word64 = binary_ccall word64Type "__plus_word64" + fun plus_word8 args = + case (tag_values(), values_64bit()) of + (true, true) => norm63 (plus_word63 args) + | (false, true) => norm64 (plus_word64 args) + | (true, false) => norm31 (plus_word31 args) + | (false, false) => norm32 (plus_word32 args) val minus_word31 = binary_ccall word31Type "__minus_word31" val minus_word32 = binary_ccall word32Type "__minus_word32" - fun minus_word8 args = if tag_values() then norm31 (minus_word31 args) - else norm32 (minus_word32 args) + val minus_word63 = binary_ccall word63Type "__minus_word63" + val minus_word64 = binary_ccall word64Type "__minus_word64" + fun minus_word8 args = + case (tag_values(), values_64bit()) of + (true, true) => norm63 (minus_word63 args) + | (false, true) => norm64 (minus_word64 args) + | (true, false) => norm31 (minus_word31 args) + | (false, false) => norm32 (minus_word32 args) val mul_word31 = binary_ccall word31Type "__mul_word31" val mul_word32 = binary_ccall word32Type "__mul_word32" - fun mul_word8 args = if tag_values() then norm31 (mul_word31 args) - else norm32 (mul_word32 args) + val mul_word63 = binary_ccall word63Type "__mul_word63" + val mul_word64 = binary_ccall word64Type "__mul_word64" + fun mul_word8 args = + case (tag_values(), values_64bit()) of + (true, true) => norm63 (mul_word63 args) + | (false, true) => norm64 (mul_word64 args) + | (true, false) => norm31 (mul_word31 args) + | (false, false) => norm32 (mul_word32 args) val div_word31 = binary_ccall_exn word31Type "__div_word31" val div_word32 = binary_ccall_exn word32Type "__div_word32" - fun div_word8 args = if tag_values() then div_word31 args - else div_word32 args + val div_word63 = binary_ccall_exn word63Type "__div_word63" + val div_word64 = binary_ccall_exn word64Type "__div_word64" + fun div_word8 args = + case (tag_values(), values_64bit()) of + (true, true) => norm63 (div_word63 args) + | (false, true) => norm64 (div_word64 args) + | (true, false) => norm31 (div_word31 args) + | (false, false) => norm32 (div_word32 args) val mod_word31 = binary_ccall_exn word31Type "__mod_word31" val mod_word32 = binary_ccall_exn word32Type "__mod_word32" - fun mod_word8 args = if tag_values() then mod_word31 args - else mod_word32 args + val mod_word63 = binary_ccall_exn word63Type "__mod_word63" + val mod_word64 = binary_ccall_exn word64Type "__mod_word64" + fun mod_word8 args = + case (tag_values(), values_64bit()) of + (true, true) => norm63 (mod_word63 args) + | (false, true) => norm64 (mod_word64 args) + | (true, false) => norm31 (mod_word31 args) + | (false, false) => norm32 (mod_word32 args) val less_word31 = cmp_ccall word31Type "__less_word31" val less_word32 = cmp_ccall word32Type "__less_word32" - fun less_word8 args = if tag_values() then less_word31 args - else less_word32 args + val less_word63 = cmp_ccall word63Type "__less_word63" + val less_word64 = cmp_ccall word64Type "__less_word64" + fun less_word8 args = + case (tag_values(), values_64bit()) of + (true, true) => less_word63 args + | (false, true) => less_word64 args + | (true, false) => less_word31 args + | (false, false) => less_word32 args + val greater_word31 = cmp_ccall word31Type "__greater_word31" val greater_word32 = cmp_ccall word32Type "__greater_word32" - fun greater_word8 args = if tag_values() then greater_word31 args - else greater_word32 args + val greater_word63 = cmp_ccall word63Type "__greater_word63" + val greater_word64 = cmp_ccall word64Type "__greater_word64" + fun greater_word8 args = + case (tag_values(), values_64bit()) of + (true, true) => greater_word63 args + | (false, true) => greater_word64 args + | (true, false) => greater_word31 args + | (false, false) => greater_word32 args + val lesseq_word31 = cmp_ccall word31Type "__lesseq_word31" val lesseq_word32 = cmp_ccall word32Type "__lesseq_word32" - fun lesseq_word8 args = if tag_values() then lesseq_word31 args - else lesseq_word32 args + val lesseq_word63 = cmp_ccall word63Type "__lesseq_word63" + val lesseq_word64 = cmp_ccall word64Type "__lesseq_word64" + fun lesseq_word8 args = + case (tag_values(), values_64bit()) of + (true, true) => lesseq_word63 args + | (false, true) => lesseq_word64 args + | (true, false) => lesseq_word31 args + | (false, false) => lesseq_word32 args + val greatereq_word31 = cmp_ccall word31Type "__greatereq_word31" val greatereq_word32 = cmp_ccall word32Type "__greatereq_word32" - fun greatereq_word8 args = if tag_values() then greatereq_word31 args - else greatereq_word32 args - - (* Operations on Integers (int31, int32) *) + val greatereq_word63 = cmp_ccall word63Type "__greatereq_word63" + val greatereq_word64 = cmp_ccall word64Type "__greatereq_word64" + fun greatereq_word8 args = + case (tag_values(), values_64bit()) of + (true, true) => greatereq_word63 args + | (false, true) => greatereq_word64 args + | (true, false) => greatereq_word31 args + | (false, false) => greatereq_word32 args + + (* Operations on Integers (int31, int32, int63, int64) *) val plus_int31 = binary_ccall int31Type "__plus_int31" val plus_int32 = binary_ccall int32Type "__plus_int32" + val plus_int63 = binary_ccall int63Type "__plus_int63" + val plus_int64 = binary_ccall int64Type "__plus_int64" val minus_int31 = binary_ccall int31Type "__minus_int31" val minus_int32 = binary_ccall int32Type "__minus_int32" + val minus_int63 = binary_ccall int63Type "__minus_int63" + val minus_int64 = binary_ccall int64Type "__minus_int64" val mul_int31 = binary_ccall int31Type "__mul_int31" val mul_int32 = binary_ccall int32Type "__mul_int32" + val mul_int63 = binary_ccall int63Type "__mul_int63" + val mul_int64 = binary_ccall int64Type "__mul_int64" val div_int31 = binary_ccall_exn int31Type "__div_int31" val div_int32 = binary_ccall_exn int32Type "__div_int32" + val div_int63 = binary_ccall_exn int63Type "__div_int63" + val div_int64 = binary_ccall_exn int64Type "__div_int64" val mod_int31 = binary_ccall_exn int31Type "__mod_int31" val mod_int32 = binary_ccall_exn int32Type "__mod_int32" + val mod_int63 = binary_ccall_exn int63Type "__mod_int63" + val mod_int64 = binary_ccall_exn int64Type "__mod_int64" val less_int31 = cmp_ccall int31Type "__less_int31" val less_int32 = cmp_ccall int32Type "__less_int32" + val less_int63 = cmp_ccall int63Type "__less_int63" + val less_int64 = cmp_ccall int64Type "__less_int64" val greater_int31 = cmp_ccall int31Type "__greater_int31" val greater_int32 = cmp_ccall int32Type "__greater_int32" + val greater_int63 = cmp_ccall int63Type "__greater_int63" + val greater_int64 = cmp_ccall int64Type "__greater_int64" val lesseq_int31 = cmp_ccall int31Type "__lesseq_int31" val lesseq_int32 = cmp_ccall int32Type "__lesseq_int32" + val lesseq_int63 = cmp_ccall int63Type "__lesseq_int63" + val lesseq_int64 = cmp_ccall int64Type "__lesseq_int64" val greatereq_int31 = cmp_ccall int31Type "__greatereq_int31" val greatereq_int32 = cmp_ccall int32Type "__greatereq_int32" + val greatereq_int63 = cmp_ccall int63Type "__greatereq_int63" + val greatereq_int64 = cmp_ccall int64Type "__greatereq_int64" (* Operations on Strings *) val less_string = cmp_ccall stringType "lessStringML" @@ -1867,9 +2058,13 @@ end; (*match compiler local*) (* Unary Operations *) val abs_int31 = unary_ccall int31Type "__abs_int31" val abs_int32 = unary_ccall int32Type "__abs_int32" + val abs_int63 = unary_ccall int63Type "__abs_int63" + val abs_int64 = unary_ccall int64Type "__abs_int64" val abs_real = unary_ccall realType "__abs_real" val neg_int31 = unary_ccall int31Type "__neg_int31" val neg_int32 = unary_ccall int32Type "__neg_int32" + val neg_int63 = unary_ccall int63Type "__neg_int63" + val neg_int64 = unary_ccall int64Type "__neg_int64" val neg_real = unary_ccall realType "__neg_real" (* Real operations *) @@ -1905,34 +2100,82 @@ end; (*match compiler local*) val greatereq_intinf = intInfOp ">=" fun unoverload env i p args = - case p - of CE.ABS => int_or_real i args {int31=abs_int31, int32=abs_int32, intinf=abs_intinf env, real=abs_real} - | CE.NEG => int_or_real i args {int31=neg_int31, int32=neg_int32, intinf=neg_intinf env, real=neg_real} - | CE.PLUS => int_or_word_or_real i args {int31=plus_int31, int32=plus_int32, intinf=plus_intinf env, - word8=plus_word8, word31=plus_word31, - word32=plus_word32, real=plus_real} - | CE.MINUS => int_or_word_or_real i args {int31=minus_int31, int32=minus_int32, intinf=minus_intinf env, - word8=minus_word8, word31=minus_word31, - word32=minus_word32, real=minus_real} - | CE.MUL => int_or_word_or_real i args {int31=mul_int31, int32=mul_int32, intinf=mul_intinf env, - word8=mul_word8, word31=mul_word31, - word32=mul_word32, real=mul_real} - | CE.DIV => int_or_word i args {int31=div_int31, int32=div_int32, intinf=div_intinf env, - word8=div_word8, word31=div_word31, word32=div_word32} - | CE.MOD => int_or_word i args {int31=mod_int31, int32=mod_int32, intinf=mod_intinf env, - word8=mod_word8, word31=mod_word31, word32=mod_word32} - | CE.LESS => string_or_int_or_word_or_real i args - {string=less_string, int31=less_int31, int32=less_int32, intinf=less_intinf env, - word8=less_word8, word31=less_word31, word32=less_word32, real=less_real} - | CE.GREATER => string_or_int_or_word_or_real i args - {string=greater_string, int31=greater_int31, int32=greater_int32, intinf=greater_intinf env, - word8=greater_word8, word31=greater_word31, word32=greater_word32, real=greater_real} - | CE.LESSEQ => string_or_int_or_word_or_real i args - {string=lesseq_string, int31=lesseq_int31, int32=lesseq_int32, intinf=lesseq_intinf env, - word8=lesseq_word8, word31=lesseq_word31, word32=lesseq_word32, real=lesseq_real} - | CE.GREATEREQ => string_or_int_or_word_or_real i args - {string=greatereq_string, int31=greatereq_int31, int32=greatereq_int32, intinf=greatereq_intinf env, - word8=greatereq_word8, word31=greatereq_word31, word32=greatereq_word32, real=greatereq_real} + case p of + CE.ABS => + int_or_real i args {int31=abs_int31, int32=abs_int32, int63=abs_int63, int64=abs_int64, + intinf=abs_intinf env, real=abs_real} + | CE.NEG => + int_or_real i args {int31=neg_int31, int32=neg_int32, int63=neg_int63, int64=neg_int64, + intinf=neg_intinf env, real=neg_real} + | CE.PLUS => + int_or_word_or_real i args {int31=plus_int31, int32=plus_int32, + int63=plus_int63, int64=plus_int64, + intinf=plus_intinf env, word8=plus_word8, + word31=plus_word31, word32=plus_word32, + word63=plus_word63, word64=plus_word64, + real=plus_real} + | CE.MINUS => + int_or_word_or_real i args {int31=minus_int31, int32=minus_int32, + int63=minus_int63, int64=minus_int64, + intinf=minus_intinf env, word8=minus_word8, + word31=minus_word31, word32=minus_word32, + word63=minus_word63, word64=minus_word64, + real=minus_real} + | CE.MUL => + int_or_word_or_real i args {int31=mul_int31, int32=mul_int32, + int63=mul_int63, int64=mul_int64, + intinf=mul_intinf env, word8=mul_word8, + word31=mul_word31, word32=mul_word32, + word63=mul_word63, word64=mul_word64, + real=mul_real} + | CE.DIV => + int_or_word i args {int31=div_int31, int32=div_int32, + int63=div_int63, int64=div_int64, + intinf=div_intinf env, word8=div_word8, + word31=div_word31, word32=div_word32, + word63=div_word63, word64=div_word64} + | CE.MOD => + int_or_word i args {int31=mod_int31, int32=mod_int32, + int63=mod_int63, int64=mod_int64, + intinf=mod_intinf env, word8=mod_word8, + word31=mod_word31, word32=mod_word32, + word63=mod_word63, word64=mod_word64} + | CE.LESS => + string_or_int_or_word_or_real i args + {string=less_string, + int31=less_int31, int32=less_int32, + int63=less_int63, int64=less_int64, + intinf=less_intinf env, word8=less_word8, + word31=less_word31, word32=less_word32, + word63=less_word63, word64=less_word64, + real=less_real} + | CE.GREATER => + string_or_int_or_word_or_real i args + {string=greater_string, + int31=greater_int31, int32=greater_int32, + int63=greater_int63, int64=greater_int64, + intinf=greater_intinf env, word8=greater_word8, + word31=greater_word31, word32=greater_word32, + word63=greater_word63, word64=greater_word64, + real=greater_real} + | CE.LESSEQ => + string_or_int_or_word_or_real i args + {string=lesseq_string, + int31=lesseq_int31, int32=lesseq_int32, + int63=lesseq_int63, int64=lesseq_int64, + intinf=lesseq_intinf env, word8=lesseq_word8, + word31=lesseq_word31, word32=lesseq_word32, + word63=lesseq_word63, word64=lesseq_word64, + real=lesseq_real} + | CE.GREATEREQ => + string_or_int_or_word_or_real i args + {string=greatereq_string, + int31=greatereq_int31, int32=greatereq_int32, + int63=greatereq_int63, int64=greatereq_int64, + intinf=greatereq_intinf env, word8=greatereq_word8, + word31=greatereq_word31, word32=greatereq_word32, + word63=greatereq_word63, word64=greatereq_word64, + real=greatereq_real} | _ => die "unoverload" in fun overloaded_prim env info result (*e.g., CE.ABS*) @@ -1963,10 +2206,12 @@ end; (*match compiler local*) takes_one_argument exn_args = let val ty = int_or_word_or_real info () - {int31=fn() => int31Type, int32=fn() => int32Type, - intinf=fn() => intinfType, - word8=wordDefaultType, word31=fn() => word31Type, - word32=fn() => word32Type, real=fn() => realType} + {int31=fn() => int31Type, int32=fn() => int32Type, + int63=fn() => int63Type, int64=fn() => int64Type, + intinf=fn() => intinfType, word8=wordDefaultType, + word31=fn() => word31Type, word32=fn() => word32Type, + word63=fn() => word63Type, word64=fn() => word64Type, + real=fn() => realType} val exn_args = if LambdaBasics.eq_Type(LambdaExp.intinfType,ty) then nil else exn_args val lvar1 = Lvars.newLvar () @@ -1988,10 +2233,14 @@ end; (*match compiler local*) {string=fn()=>TyName.tyName_STRING, int31=fn()=>TyName.tyName_INT31, int32=fn()=>TyName.tyName_INT32, + int63=fn()=>TyName.tyName_INT63, + int64=fn()=>TyName.tyName_INT64, intinf=fn()=>TyName.tyName_INTINF, word8=TyName.tyName_WordDefault, word31=fn()=>TyName.tyName_WORD31, word32=fn()=>TyName.tyName_WORD32, + word63=fn()=>TyName.tyName_WORD63, + word64=fn()=>TyName.tyName_WORD64, real=fn()=>TyName.tyName_REAL}) val lvar1 = Lvars.newLvar () in (*takes two arguments*) @@ -2011,9 +2260,13 @@ end; (*match compiler local*) in fun equal_int31() = equal int31Type "__equal_int31" fun equal_int32() = equal int32Type "__equal_int32" + fun equal_int63() = equal int63Type "__equal_int63" + fun equal_int64() = equal int64Type "__equal_int64" fun equal_word8() = equal (wordDefaultType()) "__equal_word" fun equal_word31() = equal word31Type "__equal_word31" fun equal_word32() = equal word32Type "__equal_word32" + fun equal_word63() = equal word63Type "__equal_word63" + fun equal_word64() = equal word64Type "__equal_word64" end (* ----------------------------------------------------------------------- *) @@ -2059,7 +2312,7 @@ end; (*match compiler local*) *) val t = typeScon info in if typeIsIntInf t then buildIntInf x - else INTEGER (Int32.fromLarge (IntInf.toLarge x), t) + else INTEGER (x, t) end | SCONatexp(_, SCon.STRING x, rv_opt) => (attach_loc_info rv_opt; STRING (x, Option.map #2 rv_opt)) @@ -2067,7 +2320,7 @@ end; (*match compiler local*) REAL (x, Option.map #2 rv_opt)) | SCONatexp(info, SCon.CHAR x, rv_opt) => if x < 0 orelse x > 255 then die "compileAtexp.CHAR" - else WORD(Word32.fromInt x, typeScon info) + else WORD(IntInf.fromInt x, typeScon info) | SCONatexp(info, SCon.WORD x, rv_opt) => let (* @@ -2303,12 +2556,20 @@ end; (*match compiler local*) PRIM(equal_int31(), l) else if TyName.eq(tyname, TyName.tyName_INT32) then PRIM(equal_int32(), l) + else if TyName.eq(tyname, TyName.tyName_INT63) then + PRIM(equal_int63(), l) + else if TyName.eq(tyname, TyName.tyName_INT64) then + PRIM(equal_int64(), l) else if TyName.eq(tyname, TyName.tyName_WORD8) then PRIM(equal_word8(), l) else if TyName.eq(tyname, TyName.tyName_WORD31) then PRIM(equal_word31(), l) else if TyName.eq(tyname, TyName.tyName_WORD32) then PRIM(equal_word32(), l) + else if TyName.eq(tyname, TyName.tyName_WORD63) then + PRIM(equal_word63(), l) + else if TyName.eq(tyname, TyName.tyName_WORD64) then + PRIM(equal_word64(), l) else default()) | _ => default() else default() @@ -2417,9 +2678,13 @@ end; (*match compiler local*) (true,CONStype([], tyname)) => if TyName.eq(tyname,TyName.tyName_INT31) then equal_int31() else if TyName.eq(tyname,TyName.tyName_INT32) then equal_int32() + else if TyName.eq(tyname,TyName.tyName_INT63) then equal_int63() + else if TyName.eq(tyname,TyName.tyName_INT64) then equal_int64() else if TyName.eq(tyname,TyName.tyName_WORD8) then equal_word8() else if TyName.eq(tyname,TyName.tyName_WORD31) then equal_word31() else if TyName.eq(tyname,TyName.tyName_WORD32) then equal_word32() + else if TyName.eq(tyname,TyName.tyName_WORD63) then equal_word63() + else if TyName.eq(tyname,TyName.tyName_WORD64) then equal_word64() else prim {instance=instance'} | _ => prim {instance=instance'} in TLE.PRIM (prim', args') diff --git a/src/Compiler/Lambda/CompilerEnv.sml b/src/Compiler/Lambda/CompilerEnv.sml index 433c6c569..2a19bcd77 100644 --- a/src/Compiler/Lambda/CompilerEnv.sml +++ b/src/Compiler/Lambda/CompilerEnv.sml @@ -191,10 +191,14 @@ structure CompilerEnv: COMPILER_ENV = fun initialTyEnv() : TyEnv = TYENV (initMap [(tycon_INT31, ([tyName_INT31], emptyCEnv)), (tycon_INT32, ([tyName_INT32], emptyCEnv)), + (tycon_INT63, ([tyName_INT63], emptyCEnv)), + (tycon_INT64, ([tyName_INT64], emptyCEnv)), (tycon_INT, ([tyName_IntDefault()], emptyCEnv)), (tycon_WORD8, ([tyName_WORD8], emptyCEnv)), (tycon_WORD31, ([tyName_WORD31], emptyCEnv)), (tycon_WORD32, ([tyName_WORD32], emptyCEnv)), + (tycon_WORD63, ([tyName_WORD63], emptyCEnv)), + (tycon_WORD64, ([tyName_WORD64], emptyCEnv)), (tycon_WORD, ([tyName_WordDefault()], emptyCEnv)), (tycon_REAL, ([tyName_REAL], emptyCEnv)), (tycon_STRING, ([tyName_STRING], emptyCEnv)), @@ -230,29 +234,29 @@ structure CompilerEnv: COMPILER_ENV = fun clearPathEnv (CENV{StrEnv,VarEnv,TyEnv,PathEnv}) = CENV{StrEnv=StrEnv,VarEnv=VarEnv,TyEnv=TyEnv,PathEnv=emptyPathEnv} - fun declareVar(id, (lv, tyvars, tau), CENV{StrEnv,VarEnv=m,TyEnv,PathEnv}) = + fun declareVar (id, (lv, tyvars, tau), CENV{StrEnv,VarEnv=m,TyEnv,PathEnv}) = let val il0 = map LambdaExp.TYVARtype tyvars in CENV{StrEnv=StrEnv, TyEnv=TyEnv, VarEnv=VarEnv.add(id, LVAR (lv,tyvars,tau,il0), m), PathEnv=PathEnv} end - fun declareCon(id, (con,tyvars,tau), CENV{StrEnv,VarEnv=m,TyEnv,PathEnv}) = + fun declareCon (id, (con,tyvars,tau), CENV{StrEnv,VarEnv=m,TyEnv,PathEnv}) = let val il0 = map LambdaExp.TYVARtype tyvars in CENV{StrEnv=StrEnv, TyEnv=TyEnv, VarEnv=VarEnv.add(id,CON (con,tyvars,tau,il0), m), PathEnv=PathEnv} end - fun declareExcon(id, excon, CENV{StrEnv,VarEnv=map,TyEnv,PathEnv}) = + fun declareExcon (id, excon, CENV{StrEnv,VarEnv=map,TyEnv,PathEnv}) = CENV{StrEnv=StrEnv,VarEnv=VarEnv.add(id,EXCON excon,map),TyEnv=TyEnv, PathEnv=PathEnv} - fun declare_strid(strid, env, CENV{StrEnv=STRENV m,VarEnv,TyEnv,PathEnv}) = + fun declare_strid (strid, env, CENV{StrEnv=STRENV m,VarEnv,TyEnv,PathEnv}) = CENV{StrEnv=STRENV (FinMap.add(strid,env,m)),VarEnv=VarEnv,TyEnv=TyEnv, PathEnv=PathEnv} - fun declare_tycon(tycon, a, CENV{StrEnv,VarEnv,TyEnv=TYENV m,PathEnv}) = + fun declare_tycon (tycon, a, CENV{StrEnv,VarEnv,TyEnv=TYENV m,PathEnv}) = CENV{StrEnv=StrEnv,VarEnv=VarEnv,TyEnv=TYENV(FinMap.add(tycon,a,m)),PathEnv=PathEnv} fun plus (CENV{StrEnv,VarEnv,TyEnv,PathEnv}, @@ -361,7 +365,7 @@ structure CompilerEnv: COMPILER_ENV = * Restriction * ------------- *) - fun restrictFinMap(error_str, env : (''a,'b) FinMap.map, dom : ''a list) = + fun restrictFinMap (error_str, env : (''a,'b) FinMap.map, dom : ''a list) = foldl (fn (id, acc) => let val res = case FinMap.lookup env id of SOME res => res @@ -369,7 +373,7 @@ structure CompilerEnv: COMPILER_ENV = in FinMap.add(id,res,acc) end) FinMap.empty dom - fun restrictVarEnv(m: VarEnv, ids) : VarEnv = + fun restrictVarEnv (m: VarEnv, ids) : VarEnv = foldl (fn (id, acc) => let val res = case VarEnv.lookup m id of SOME res => res @@ -378,10 +382,10 @@ structure CompilerEnv: COMPILER_ENV = end) VarEnv.empty ids - fun restrictTyEnv(TYENV m, tycons) : TyEnv = + fun restrictTyEnv (TYENV m, tycons) : TyEnv = TYENV (restrictFinMap(fn tc => ("restrictCEnv.tycon " ^ TyCon.pr_TyCon tc ^ " not in env"), m, tycons)) - fun restrictStrEnv(STRENV m, strid_restrs) : StrEnv = + fun restrictStrEnv (STRENV m, strid_restrs) : StrEnv = STRENV (foldl (fn ((strid,restr:Environments.restricter), acc) => let val res = case FinMap.lookup m strid of SOME res => restrictCEnv(res,restr) @@ -389,8 +393,8 @@ structure CompilerEnv: COMPILER_ENV = in FinMap.add(strid,res,acc) end) FinMap.empty strid_restrs) - and restrictCEnv(ce,Environments.Whole) = ce - | restrictCEnv(CENV{StrEnv,VarEnv,TyEnv,PathEnv}, Environments.Restr{strids,vids,tycons}) = + and restrictCEnv (ce,Environments.Whole) = ce + | restrictCEnv (CENV{StrEnv,VarEnv,TyEnv,PathEnv}, Environments.Restr{strids,vids,tycons}) = CENV{StrEnv=restrictStrEnv(StrEnv,strids), VarEnv=restrictVarEnv(VarEnv,vids), TyEnv=restrictTyEnv(TyEnv,tycons), @@ -408,10 +412,10 @@ structure CompilerEnv: COMPILER_ENV = val debug_man_enrich = Flags.lookup_flag_entry "debug_man_enrich" fun log s = TextIO.output(TextIO.stdOut,s) - fun debug(s, b) = if !debug_man_enrich then + fun debug (s, b) = if !debug_man_enrich then (if b then log("\n" ^ s ^ ": enrich succeeded.") else log("\n" ^ s ^ ": enrich failed."); b) - else b + else b fun eq_res (LVAR (lv1,tvs1,tau1,il1), LVAR (lv2,tvs2,tau2,il2)) = @@ -440,31 +444,31 @@ structure CompilerEnv: COMPILER_ENV = | eq_res (EXPORT,EXPORT) = true | eq_res _ = false - fun enrichVarEnv(env1: VarEnv, env2: VarEnv) : bool = + fun enrichVarEnv (env1: VarEnv, env2: VarEnv) : bool = VarEnv.Fold (fn ((id2,res2),b) => b andalso case VarEnv.lookup env1 id2 of SOME res1 => eq_res(res1,res2) | NONE => false) true env2 - fun eq_tynames(res1,res2) = TyName.Set.eq (TyName.Set.fromList res1) (TyName.Set.fromList res2) + fun eq_tynames (res1,res2) = TyName.Set.eq (TyName.Set.fromList res1) (TyName.Set.fromList res2) - fun enrichTyEnv(TYENV m1, TYENV m2) : bool = + fun enrichTyEnv (TYENV m1, TYENV m2) : bool = FinMap.Fold (fn ((id2,(res2,ce2)),b) => b andalso case FinMap.lookup m1 id2 of SOME (res1,ce1) => eq_tynames(res1,res2) andalso eqCEnv(ce1,ce2) | NONE => false) true m2 - and enrichCEnv(CENV{StrEnv,VarEnv,TyEnv,PathEnv}, - CENV{StrEnv=StrEnv',VarEnv=VarEnv',TyEnv=TyEnv', - PathEnv=PathEnv'}) = + and enrichCEnv (CENV{StrEnv,VarEnv,TyEnv,PathEnv}, + CENV{StrEnv=StrEnv',VarEnv=VarEnv',TyEnv=TyEnv', + PathEnv=PathEnv'}) = debug("StrEnv", enrichStrEnv(StrEnv,StrEnv')) andalso debug("VarEnv", enrichVarEnv(VarEnv,VarEnv')) andalso debug("TyEnv", enrichTyEnv(TyEnv,TyEnv')) andalso PathEnv.isEmpty PathEnv andalso PathEnv.isEmpty PathEnv' - and eqCEnv(ce1,ce2) = enrichCEnv(ce1,ce2) andalso enrichCEnv(ce2,ce1) + and eqCEnv (ce1,ce2) = enrichCEnv(ce1,ce2) andalso enrichCEnv(ce2,ce1) - and enrichStrEnv(STRENV se1, STRENV se2) = + and enrichStrEnv (STRENV se1, STRENV se2) = FinMap.Fold (fn ((strid,env2),b) => b andalso case FinMap.lookup se1 strid of SOME env1 => enrichCEnv(env1,env2) @@ -486,17 +490,17 @@ structure CompilerEnv: COMPILER_ENV = | matchRes (EXCON (excon,_), EXCON (excon0,_)) = Excon.match(excon,excon0) | matchRes _ = () - fun matchVarEnv(env: VarEnv, env0: VarEnv) = + fun matchVarEnv (env: VarEnv, env0: VarEnv) = VarEnv.Fold(fn ((id,res),_) => case VarEnv.lookup env0 id of SOME res0 => matchRes(res,res0) | NONE => ()) () env - fun matchEnv(CENV{StrEnv,VarEnv, ...}, - CENV{StrEnv=StrEnv0,VarEnv=VarEnv0, ...}) = - (matchStrEnv(StrEnv,StrEnv0); matchVarEnv(VarEnv,VarEnv0)) + fun matchEnv (CENV{StrEnv,VarEnv, ...}, + CENV{StrEnv=StrEnv0,VarEnv=VarEnv0, ...}) = + (matchStrEnv(StrEnv,StrEnv0); matchVarEnv(VarEnv,VarEnv0)) - and matchStrEnv(STRENV se, STRENV se0) = + and matchStrEnv (STRENV se, STRENV se0) = FinMap.Fold(fn ((strid,env),_) => case FinMap.lookup se0 strid of SOME env0 => matchEnv(env,env0) diff --git a/src/Compiler/Lambda/EliminateEq.sml b/src/Compiler/Lambda/EliminateEq.sml index 900168cde..fe435bd54 100644 --- a/src/Compiler/Lambda/EliminateEq.sml +++ b/src/Compiler/Lambda/EliminateEq.sml @@ -203,8 +203,9 @@ structure EliminateEq: ELIMINATE_EQ = fun is_eq_prim_tn tn = List.exists (fn tn' => TyName.eq(tn',tn)) - [TyName.tyName_INT31, TyName.tyName_INT32, + [TyName.tyName_INT31, TyName.tyName_INT32,TyName.tyName_INT63, TyName.tyName_INT64, TyName.tyName_WORD8, TyName.tyName_WORD31, TyName.tyName_WORD32, + TyName.tyName_WORD63, TyName.tyName_WORD64, TyName.tyName_BOOL, TyName.tyName_STRING, TyName.tyName_REF, TyName.tyName_ARRAY, TyName.tyName_FOREIGNPTR, TyName.tyName_CHARARRAY] (*not tyName_REAL*) @@ -552,27 +553,36 @@ structure EliminateEq: ELIMINATE_EQ = [var_tableX, var_j]) end - fun INTEGER' i = INTEGER(Int32.fromInt i, intDefaultType()) + fun INTEGER' i = INTEGER(IntInf.fromInt i, intDefaultType()) val tag_values = Flags.is_on0 "tag_values" + val values_64bit = Flags.is_on0 "values_64bit" fun ccall name argtypes restype = CCALLprim {name = name, instances = [], tyvars = [], Type = ARROWtype (argtypes, [restype])} - fun MINUS_INTprim() = - let val n = if tag_values() then "__minus_int31" else "__minus_int32ub" + fun MINUS_INTprim () = + let val n = case (tag_values(),values_64bit()) of + (true, true) => "__minus_int63" + | (false, true) => "__minus_int64ub" + | (true, false) => "__minus_int31" + | (false, false) => "__minus_int32ub" val t = intDefaultType() - in ccall n [t, t] t - end - - fun LESS_INTprim() = - let val n = if tag_values() then "__less_int31" else "__less_int32ub" + in ccall n [t, t] t + end + + fun LESS_INTprim () = + let val n = case (tag_values(),values_64bit()) of + (true, true) => "__less_int63" + | (false, true) => "__less_int64ub" + | (true, false) => "__less_int31" + | (false, false) => "__less_int32ub" val t = intDefaultType() in ccall n [t,t] boolType end - fun bind_loop() = + fun bind_loop () = FN {pat = [(lvar_j, intDefaultType())], body = SWITCH_C (SWITCH (PRIM (LESS_INTprim(), [var_j, INTEGER' 0]), [((Con.con_TRUE,NONE), lamb_true)], @@ -581,12 +591,12 @@ structure EliminateEq: ELIMINATE_EQ = [((Con.con_TRUE,NONE), APP (var_loop, PRIM (MINUS_INTprim(), [var_j, INTEGER' 1]),NONE))], SOME lamb_false)))))} - fun function_loop() = {lvar = lvar_loop, - regvars = [], - tyvars = [], Type = ARROWtype ([intDefaultType()], [boolType]), - bind = bind_loop()} + fun function_loop () = {lvar = lvar_loop, + regvars = [], + tyvars = [], Type = ARROWtype ([intDefaultType()], [boolType]), + bind = bind_loop()} - fun bind_eq_table() = + fun bind_eq_table () = FN {pat = [(lvar_eq_alpha, tau_for_eq_fun tau_alpha)], body = FN {pat = [(lvar_table_pair, RECORDtype [tau_tyname, tau_tyname])], body = monolet {lvar = lvar_table1, Type = tau_tyname, bind = @@ -604,12 +614,12 @@ structure EliminateEq: ELIMINATE_EQ = APP (var_loop, PRIM (MINUS_INTprim(), [var_n2, INTEGER' 1]),NONE))], SOME lamb_false))}))}}}} - fun function_eq_table() = {lvar = lvar_eq_table, - regvars = [], - tyvars = [alpha], - Type = ARROWtype ([tau_for_eq_fun tau_alpha], - [tau_for_eq_fun tau_tyname]), - bind = bind_eq_table()} + fun function_eq_table () = {lvar = lvar_eq_table, + regvars = [], + tyvars = [alpha], + Type = ARROWtype ([tau_for_eq_fun tau_alpha], + [tau_for_eq_fun tau_tyname]), + bind = bind_eq_table()} val f = fn scope => FIX {functions = [function_eq_table()], scope = scope} val env = add_tyname (tyname, POLYLVAR lvar_eq_table, empty) diff --git a/src/Compiler/Lambda/LAMBDA_EXP.sml b/src/Compiler/Lambda/LAMBDA_EXP.sml index e36493d88..fa472cfe5 100644 --- a/src/Compiler/Lambda/LAMBDA_EXP.sml +++ b/src/Compiler/Lambda/LAMBDA_EXP.sml @@ -46,11 +46,15 @@ signature LAMBDA_EXP = val exnType : Type val int31Type : Type val int32Type : Type + val int63Type : Type + val int64Type : Type val intinfType : Type - val intDefaultType : unit -> Type (* int31 if tag_values, otherwise int32 *) + val intDefaultType : unit -> Type (* int63 if tag_values, otherwise int64 *) val word31Type : Type val word32Type : Type - val wordDefaultType : unit -> Type (* word31 if tag_values, otherwise word32 *) + val word63Type : Type + val word64Type : Type + val wordDefaultType : unit -> Type (* word63 if tag_values, otherwise word64 *) val realType: Type val f64Type: Type val stringType: Type @@ -95,8 +99,8 @@ signature LAMBDA_EXP = and LambdaExp = VAR of {lvar: lvar, instances : Type list, regvars: regvar list} - | INTEGER of Int32.int * Type - | WORD of Word32.word * Type + | INTEGER of IntInf.int * Type + | WORD of IntInf.int * Type | STRING of string * regvar option | REAL of string * regvar option | F64 of string @@ -116,8 +120,8 @@ signature LAMBDA_EXP = | EXCEPTION of excon * Type option * LambdaExp | RAISE of LambdaExp * TypeList | HANDLE of LambdaExp * LambdaExp - | SWITCH_I of {switch: Int32.int Switch, precision: int} - | SWITCH_W of {switch: Word32.word Switch, precision: int} + | SWITCH_I of {switch: IntInf.int Switch, precision: int} + | SWITCH_W of {switch: IntInf.int Switch, precision: int} | SWITCH_S of string Switch | SWITCH_C of (con*lvar option) Switch | SWITCH_E of (excon*lvar option) Switch diff --git a/src/Compiler/Lambda/LambdaExp.sml b/src/Compiler/Lambda/LambdaExp.sml index 6a1e900da..d4d24b652 100644 --- a/src/Compiler/Lambda/LambdaExp.sml +++ b/src/Compiler/Lambda/LambdaExp.sml @@ -56,10 +56,14 @@ structure LambdaExp: LAMBDA_EXP = val int31Type = CONStype([], TyName.tyName_INT31) val int32Type = CONStype([], TyName.tyName_INT32) + val int63Type = CONStype([], TyName.tyName_INT63) + val int64Type = CONStype([], TyName.tyName_INT64) val intinfType = CONStype([], TyName.tyName_INTINF) fun intDefaultType() = CONStype([], TyName.tyName_IntDefault()) val word31Type = CONStype([], TyName.tyName_WORD31) val word32Type = CONStype([], TyName.tyName_WORD32) + val word63Type = CONStype([], TyName.tyName_WORD63) + val word64Type = CONStype([], TyName.tyName_WORD64) fun wordDefaultType() = CONStype([], TyName.tyName_WordDefault()) val boolType = CONStype([], TyName.tyName_BOOL) val foreignptrType = CONStype([], TyName.tyName_FOREIGNPTR) @@ -113,8 +117,8 @@ structure LambdaExp: LAMBDA_EXP = and LambdaExp = VAR of {lvar: lvar, instances : Type list, regvars: regvar list} - | INTEGER of Int32.int * Type - | WORD of Word32.word * Type + | INTEGER of IntInf.int * Type + | WORD of IntInf.int * Type | STRING of string * regvar option | REAL of string * regvar option | F64 of string @@ -134,8 +138,8 @@ structure LambdaExp: LAMBDA_EXP = | EXCEPTION of excon * Type option * LambdaExp | RAISE of LambdaExp * TypeList | HANDLE of LambdaExp * LambdaExp - | SWITCH_I of {switch: Int32.int Switch, precision: int} - | SWITCH_W of {switch: Word32.word Switch, precision: int} + | SWITCH_I of {switch: IntInf.int Switch, precision: int} + | SWITCH_W of {switch: IntInf.int Switch, precision: int} | SWITCH_S of string Switch | SWITCH_C of (con*lvar option) Switch | SWITCH_E of (excon*lvar option) Switch @@ -238,7 +242,20 @@ structure LambdaExp: LAMBDA_EXP = "__greater_int31", "__greater_int32ub", "__greater_int32b", "__lesseq_int31", "__lesseq_int32ub", "__lesseq_int32b", "__greatereq_int31", "__greatereq_int32ub", "__greatereq_int32b", - "lessStringML", + + "__plus_word63", "__plus_word64ub", "__plus_word64b", + "__minus_word63", "__minus_word64ub", "__minus_word64b", + "__mul_word63", "__mul_word64ub", "__mul_word64b", + "__less_word63", "__less_word64ub", "__less_word64b", + "__greater_word63", "__greater_word64ub", "__greater_word64b", + "__lesseq_word63", "__lesseq_word64ub", "__lesseq_word64b", + "__greatereq_word63", "__greatereq_word64ub", "__greatereq_word64b", + "__less_int63", "__less_int64ub", "__less_int64b", + "__greater_int63", "__greater_int64ub", "__greater_int64b", + "__lesseq_int63", "__lesseq_int64ub", "__lesseq_int64b", + "__greatereq_int63", "__greatereq_int64ub", "__greatereq_int64b", + + "lessStringML", "greaterStringML", "lesseqStringML", "greatereqStringML", @@ -496,9 +513,13 @@ structure LambdaExp: LAMBDA_EXP = | DROPprim => PP.LEAF("DROP") | CCALLprim{name="__neg_int31",...} => PP.LEAF("~" ) | CCALLprim{name="__neg_int32ub",...} => PP.LEAF("~" ) + | CCALLprim{name="__neg_int63",...} => PP.LEAF("~" ) + | CCALLprim{name="__neg_int64ub",...} => PP.LEAF("~" ) | CCALLprim{name="__neg_real",...} => PP.LEAF("~" ) | CCALLprim{name="__abs_int31",...} => PP.LEAF("abs" ) | CCALLprim{name="__abs_int32ub",...} => PP.LEAF("abs" ) + | CCALLprim{name="__abs_int63",...} => PP.LEAF("abs" ) + | CCALLprim{name="__abs_int64ub",...} => PP.LEAF("abs" ) | CCALLprim{name="__abs_real",...} => PP.LEAF("abs" ) | CCALLprim{name="floorFloat",...} => PP.LEAF("floor" ) | CCALLprim{name="realInt",...} => PP.LEAF("real" ) @@ -523,18 +544,27 @@ structure LambdaExp: LAMBDA_EXP = | CCALLprim{name="__mul_real", ...} => PP.LEAF("*") | CCALLprim{name="__mul_int31", ...} => PP.LEAF("*") | CCALLprim{name="__mul_int32", ...} => PP.LEAF("*") + | CCALLprim{name="__mul_int63", ...} => PP.LEAF("*") + | CCALLprim{name="__mul_int64", ...} => PP.LEAF("*") | CCALLprim{name="__mul_f64", ...} => PP.LEAF("*") | CCALLprim{name="__plus_real", ...} => PP.LEAF("+") | CCALLprim{name="__plus_int31", ...} => PP.LEAF("+") | CCALLprim{name="__plus_int32", ...} => PP.LEAF("+") + | CCALLprim{name="__plus_int63", ...} => PP.LEAF("+") + | CCALLprim{name="__plus_int64", ...} => PP.LEAF("+") | CCALLprim{name="__plus_f64", ...} => PP.LEAF("+") | CCALLprim{name="__minus_real", ...} => PP.LEAF("-") | CCALLprim{name="__minus_int31", ...} => PP.LEAF("-") | CCALLprim{name="__minus_int32", ...} => PP.LEAF("-") + | CCALLprim{name="__minus_int63", ...} => PP.LEAF("-") + | CCALLprim{name="__minus_int64", ...} => PP.LEAF("-") | CCALLprim{name="__minus_f64", ...} => PP.LEAF("-") | CCALLprim{name="__equal_int31", ...} => if !Flags.print_types then PP.LEAF("=[int31]") else PP.LEAF("=") + | CCALLprim{name="__equal_int63", ...} => + if !Flags.print_types then PP.LEAF("=[int63]") + else PP.LEAF("=") | EQUALprim {instance} => if !Flags.print_types then PP.NODE{start="=(",finish=")",indent=2, @@ -544,33 +574,49 @@ structure LambdaExp: LAMBDA_EXP = | CCALLprim{name="__less_f64", ...} => PP.LEAF("<") | CCALLprim{name="__less_int31", ...} => PP.LEAF("<") | CCALLprim{name="__less_int32", ...} => PP.LEAF("<") + | CCALLprim{name="__less_int63", ...} => PP.LEAF("<") + | CCALLprim{name="__less_int64", ...} => PP.LEAF("<") | CCALLprim{name="__less_string", ...} => PP.LEAF("<") | CCALLprim{name="__less_word31", ...} => PP.LEAF("<") | CCALLprim{name="__less_word32", ...} => PP.LEAF("<") + | CCALLprim{name="__less_word63", ...} => PP.LEAF("<") + | CCALLprim{name="__less_word64", ...} => PP.LEAF("<") | CCALLprim{name="__greater_real", ...} => PP.LEAF(">") | CCALLprim{name="__greater_f64", ...} => PP.LEAF(">") | CCALLprim{name="__greater_int31", ...} => PP.LEAF(">") | CCALLprim{name="__greater_int32", ...} => PP.LEAF(">") + | CCALLprim{name="__greater_int63", ...} => PP.LEAF(">") + | CCALLprim{name="__greater_int64", ...} => PP.LEAF(">") | CCALLprim{name="__greater_string", ...} => PP.LEAF(">") | CCALLprim{name="__greater_word31", ...} => PP.LEAF(">") | CCALLprim{name="__greater_word32", ...} => PP.LEAF(">") + | CCALLprim{name="__greater_word63", ...} => PP.LEAF(">") + | CCALLprim{name="__greater_word64", ...} => PP.LEAF(">") | CCALLprim{name="__lesseq_real", ...} => PP.LEAF("<=") | CCALLprim{name="__lesseq_f64", ...} => PP.LEAF("<=") | CCALLprim{name="__lesseq_int31", ...} => PP.LEAF("<=") | CCALLprim{name="__lesseq_int32", ...} => PP.LEAF("<=") + | CCALLprim{name="__lesseq_int63", ...} => PP.LEAF("<=") + | CCALLprim{name="__lesseq_int64", ...} => PP.LEAF("<=") | CCALLprim{name="__lesseq_string", ...} => PP.LEAF("<=") | CCALLprim{name="__lesseq_word31", ...} => PP.LEAF("<=") | CCALLprim{name="__lesseq_word32", ...} => PP.LEAF("<=") + | CCALLprim{name="__lesseq_word63", ...} => PP.LEAF("<=") + | CCALLprim{name="__lesseq_word64", ...} => PP.LEAF("<=") | CCALLprim{name="__greatereq_real", ...} => PP.LEAF(">=") | CCALLprim{name="__greatereq_f64", ...} => PP.LEAF(">=") | CCALLprim{name="__greatereq_int31", ...} => PP.LEAF(">=") | CCALLprim{name="__greatereq_int32", ...} => PP.LEAF(">=") + | CCALLprim{name="__greatereq_int63", ...} => PP.LEAF(">=") + | CCALLprim{name="__greatereq_int64", ...} => PP.LEAF(">=") | CCALLprim{name="__greatereq_string", ...} => PP.LEAF(">=") | CCALLprim{name="__greatereq_word31", ...} => PP.LEAF(">=") | CCALLprim{name="__greatereq_word32", ...} => PP.LEAF(">=") + | CCALLprim{name="__greatereq_word63", ...} => PP.LEAF(">=") + | CCALLprim{name="__greatereq_word64", ...} => PP.LEAF(">=") | CCALLprim {name, instances, tyvars, Type} => if !Flags.print_types then @@ -789,16 +835,16 @@ structure LambdaExp: LAMBDA_EXP = end | INTEGER (i,tau) => if !Flags.print_types then - PP.NODE{start=Int32.toString i ^ ":", finish=" ",indent=0, + PP.NODE{start=IntInf.toString i ^ ":", finish=" ",indent=0, children=[layoutType tau], childsep=PP.NOSEP} - else PP.LEAF(Int32.toString i) + else PP.LEAF(IntInf.toString i) | WORD (w,tau) => if !Flags.print_types then - PP.NODE{start="0x" ^ Word32.toString w ^ ":", finish=" ",indent=0, + PP.NODE{start="0xw" ^ IntInf.fmt StringCvt.HEX w ^ ":", finish=" ",indent=0, children=[layoutType tau], childsep=PP.NOSEP} - else PP.LEAF("0x" ^ Word32.toString w) + else PP.LEAF("0xw" ^ IntInf.fmt StringCvt.HEX w) | STRING (s,NONE) => PP.LEAF(quote s) | STRING (s,SOME rv) => PP.LEAF(quote s ^ "`" ^ RegVar.pr rv) @@ -881,9 +927,9 @@ structure LambdaExp: LAMBDA_EXP = childsep=PP.LEFT " handle " } | SWITCH_I {switch, precision} => - layoutSwitch layoutLambdaExp Int32.toString switch + layoutSwitch layoutLambdaExp IntInf.toString switch | SWITCH_W {switch, precision} => - layoutSwitch layoutLambdaExp (fn w => "0x" ^ Word32.toString w) switch + layoutSwitch layoutLambdaExp (fn w => "0x" ^ IntInf.fmt StringCvt.HEX w) switch | SWITCH_S sw => layoutSwitch layoutLambdaExp (fn x => x) sw | SWITCH_C sw => @@ -965,14 +1011,20 @@ structure LambdaExp: LAMBDA_EXP = | (CCALLprim{name="__mul_real", ...}, [_,_]) => layout_infix context 7 " * " lambs | (CCALLprim{name="__mul_int31", ...}, [_,_]) => layout_infix context 7 " * " lambs | (CCALLprim{name="__mul_int32ub", ...}, [_,_]) => layout_infix context 7 " * " lambs + | (CCALLprim{name="__mul_int63", ...}, [_,_]) => layout_infix context 7 " * " lambs + | (CCALLprim{name="__mul_int64ub", ...}, [_,_]) => layout_infix context 7 " * " lambs | (CCALLprim{name="__mul_f64", ...}, [_,_]) => layout_infix context 7 " * " lambs | (CCALLprim{name="__plus_real", ...}, [_,_]) => layout_infix context 6 " + " lambs | (CCALLprim{name="__plus_int31", ...}, [_,_]) => layout_infix context 6 " + " lambs | (CCALLprim{name="__plus_int32ub", ...}, [_,_]) => layout_infix context 6 " + " lambs + | (CCALLprim{name="__plus_int63", ...}, [_,_]) => layout_infix context 6 " + " lambs + | (CCALLprim{name="__plus_int64ub", ...}, [_,_]) => layout_infix context 6 " + " lambs | (CCALLprim{name="__plus_f64", ...}, [_,_]) => layout_infix context 6 " + " lambs | (CCALLprim{name="__minus_real", ...}, [_,_]) => layout_infix context 6 " - " lambs | (CCALLprim{name="__minus_int31", ...}, [_,_]) => layout_infix context 6 " - "lambs | (CCALLprim{name="__minus_int32ub", ...}, [_,_]) => layout_infix context 6 " - "lambs + | (CCALLprim{name="__minus_int63", ...}, [_,_]) => layout_infix context 6 " - "lambs + | (CCALLprim{name="__minus_int64ub", ...}, [_,_]) => layout_infix context 6 " - "lambs | (CCALLprim{name="__minus_f64", ...}, [_,_]) => layout_infix context 6 " - " lambs | (CCALLprim{name="divFloat", ...}, [_,_]) => layout_infix context 7 " / "lambs @@ -982,32 +1034,48 @@ structure LambdaExp: LAMBDA_EXP = | (CCALLprim{name="__less_word31", ...}, [_,_]) => layout_infix context 4 " < "lambs | (CCALLprim{name="__less_word32ub", ...}, [_,_]) => layout_infix context 4 " < "lambs + | (CCALLprim{name="__less_word63", ...}, [_,_]) => layout_infix context 4 " < "lambs + | (CCALLprim{name="__less_word64ub", ...}, [_,_]) => layout_infix context 4 " < "lambs | (CCALLprim{name="__less_int31", ...}, [_,_]) => layout_infix context 4 " < "lambs | (CCALLprim{name="__less_int32ub", ...}, [_,_]) => layout_infix context 4 " < "lambs + | (CCALLprim{name="__less_int63", ...}, [_,_]) => layout_infix context 4 " < "lambs + | (CCALLprim{name="__less_int64ub", ...}, [_,_]) => layout_infix context 4 " < "lambs | (CCALLprim{name="__less_real", ...}, [_,_]) => layout_infix context 4 " < "lambs | (CCALLprim{name="__less_f64", ...}, [_,_]) => layout_infix context 4 " < "lambs | (CCALLprim{name="__less_string", ...}, [_,_]) => layout_infix context 4 " < "lambs | (CCALLprim{name="__greater_word31", ...}, [_,_]) => layout_infix context 4 " > "lambs | (CCALLprim{name="__greater_word32ub", ...}, [_,_]) => layout_infix context 4 " > "lambs + | (CCALLprim{name="__greater_word63", ...}, [_,_]) => layout_infix context 4 " > "lambs + | (CCALLprim{name="__greater_word64ub", ...}, [_,_]) => layout_infix context 4 " > "lambs | (CCALLprim{name="__greater_int31", ...}, [_,_]) => layout_infix context 4 " > "lambs | (CCALLprim{name="__greater_int32ub", ...}, [_,_]) => layout_infix context 4 " > "lambs + | (CCALLprim{name="__greater_int63", ...}, [_,_]) => layout_infix context 4 " > "lambs + | (CCALLprim{name="__greater_int64ub", ...}, [_,_]) => layout_infix context 4 " > "lambs | (CCALLprim{name="__greater_real", ...}, [_,_]) => layout_infix context 4 " > "lambs | (CCALLprim{name="__greater_f64", ...}, [_,_]) => layout_infix context 4 " > "lambs | (CCALLprim{name="__greater_string", ...}, [_,_]) => layout_infix context 4 " > "lambs | (CCALLprim{name="__lesseq_word31", ...}, [_,_]) => layout_infix context 4 " <= "lambs | (CCALLprim{name="__lesseq_word32ub", ...}, [_,_]) => layout_infix context 4 " <= "lambs + | (CCALLprim{name="__lesseq_word63", ...}, [_,_]) => layout_infix context 4 " <= "lambs + | (CCALLprim{name="__lesseq_word64ub", ...}, [_,_]) => layout_infix context 4 " <= "lambs | (CCALLprim{name="__lesseq_int31", ...}, [_,_]) => layout_infix context 4 " <= "lambs | (CCALLprim{name="__lesseq_int32ub", ...}, [_,_]) => layout_infix context 4 " <= "lambs + | (CCALLprim{name="__lesseq_int63", ...}, [_,_]) => layout_infix context 4 " <= "lambs + | (CCALLprim{name="__lesseq_int64ub", ...}, [_,_]) => layout_infix context 4 " <= "lambs | (CCALLprim{name="__lesseq_real", ...}, [_,_]) => layout_infix context 4 " <= "lambs | (CCALLprim{name="__lesseq_f64", ...}, [_,_]) => layout_infix context 4 " <= "lambs | (CCALLprim{name="__lesseq_string", ...}, [_,_]) => layout_infix context 4 " <= "lambs | (CCALLprim{name="__greatereq_word31", ...}, [_,_]) => layout_infix context 4 " >= "lambs | (CCALLprim{name="__greatereq_word32ub", ...}, [_,_]) => layout_infix context 4 " >= "lambs + | (CCALLprim{name="__greatereq_word63", ...}, [_,_]) => layout_infix context 4 " >= "lambs + | (CCALLprim{name="__greatereq_word64ub", ...}, [_,_]) => layout_infix context 4 " >= "lambs | (CCALLprim{name="__greatereq_int31", ...}, [_,_]) => layout_infix context 4 " >= "lambs | (CCALLprim{name="__greatereq_int32ub", ...}, [_,_]) => layout_infix context 4 " >= "lambs + | (CCALLprim{name="__greatereq_int63", ...}, [_,_]) => layout_infix context 4 " >= "lambs + | (CCALLprim{name="__greatereq_int64ub", ...}, [_,_]) => layout_infix context 4 " >= "lambs | (CCALLprim{name="__greatereq_real", ...}, [_,_]) => layout_infix context 4 " >= "lambs | (CCALLprim{name="__greatereq_f64", ...}, [_,_]) => layout_infix context 4 " >= "lambs | (CCALLprim{name="__greatereq_string", ...}, [_,_]) => layout_infix context 4 " >= "lambs @@ -1469,6 +1537,12 @@ structure LambdaExp: LAMBDA_EXP = | toInt (LETREGION _) = 19 | toInt (F64 _) = 20 + val pu_intinf : IntInf.int Pickle.pu = + Pickle.convert (fn s => case IntInf.fromString s of SOME i => i + | NONE => die "pu_intinf", + IntInf.toString) + Pickle.string + fun fun_VAR pu_LambdaExp = Pickle.con1 VAR (fn VAR a => a | _ => die "pu_LambdaExp.VAR") (Pickle.convert (fn (lv,il,rvs) => {lvar=lv,instances=il,regvars=rvs}, @@ -1476,10 +1550,10 @@ structure LambdaExp: LAMBDA_EXP = (Pickle.tup3Gen0(Lvars.pu,pu_Types,Pickle.listGen RegVar.pu))) fun fun_INTEGER pu_LambdaExp = Pickle.con1 INTEGER (fn INTEGER a => a | _ => die "pu_LambdaExp.INTEGER") - (Pickle.pairGen0(Pickle.int32,pu_Type)) + (Pickle.pairGen0(pu_intinf,pu_Type)) fun fun_WORD pu_LambdaExp = Pickle.con1 WORD (fn WORD a => a | _ => die "pu_LambdaExp.WORD") - (Pickle.pairGen0(Pickle.word32,pu_Type)) + (Pickle.pairGen0(pu_intinf,pu_Type)) fun fun_STRING pu_LambdaExp = Pickle.con1 STRING (fn STRING a => a | _ => die "pu_LambdaExp.STRING") (Pickle.pairGen0(Pickle.string,Pickle.optionGen RegVar.pu)) @@ -1520,11 +1594,11 @@ structure LambdaExp: LAMBDA_EXP = fun fun_SWITCH_I pu_LambdaExp = Pickle.con1 SWITCH_I (fn SWITCH_I a => a | _ => die "pu_LambdaExp.SWITCH_I") (Pickle.convert (fn (sw,p) => {switch=sw,precision=p}, fn {switch=sw,precision=p} => (sw,p)) - (Pickle.pairGen0(pu_Switch Pickle.int32 pu_LambdaExp,Pickle.int))) + (Pickle.pairGen0(pu_Switch pu_intinf pu_LambdaExp,Pickle.int))) fun fun_SWITCH_W pu_LambdaExp = Pickle.con1 SWITCH_W (fn SWITCH_W a => a | _ => die "pu_LambdaExp.SWITCH_W") (Pickle.convert (fn (sw,p) => {switch=sw,precision=p}, fn {switch=sw,precision=p} => (sw,p)) - (Pickle.pairGen0(pu_Switch Pickle.word32 pu_LambdaExp,Pickle.int))) + (Pickle.pairGen0(pu_Switch pu_intinf pu_LambdaExp,Pickle.int))) fun fun_SWITCH_S pu_LambdaExp = Pickle.con1 SWITCH_S (fn SWITCH_S a => a | _ => die "pu_LambdaExp.SWITCH_S") (pu_Switch Pickle.string pu_LambdaExp) diff --git a/src/Compiler/Lambda/LambdaStatSem.sml b/src/Compiler/Lambda/LambdaStatSem.sml index 0fa542ea4..026be04bb 100644 --- a/src/Compiler/Lambda/LambdaStatSem.sml +++ b/src/Compiler/Lambda/LambdaStatSem.sml @@ -10,6 +10,7 @@ structure LambdaStatSem: LAMBDA_STAT_SEM = * --------------------------------------------------------- *) val letrec_polymorphism_only = ref false (* see the main function below. *) + val tag_values = Flags.is_on0 "tag_values" open LambdaExp TyName @@ -168,10 +169,14 @@ structure LambdaStatSem: LAMBDA_STAT_SEM = TyNameMap.fromList [(tyName_BOOL, [Con.con_TRUE, Con.con_FALSE]), (tyName_INT31, []), (tyName_INT32, []), + (tyName_INT63, []), + (tyName_INT64, []), (tyName_INTINF, [Con.con_INTINF]), (tyName_WORD8, []), (tyName_WORD31, []), (tyName_WORD32, []), + (tyName_WORD63, []), + (tyName_WORD64, []), (tyName_REAL, []), (tyName_F64, []), (tyName_STRING, []), @@ -329,9 +334,9 @@ structure LambdaStatSem: LAMBDA_STAT_SEM = fun restrict (env as {ftv,con_env,tyname_env,lvar_env,excon_env}: env,{cons,tynames,lvars,excons}) = let fun say s = print(s^"\n"); - fun sayenv() = PP.outputTree(print,layout_env env, !Flags.colwidth) - fun sayset() = PP.outputTree(print,NatSet.layoutSet {start="{",finish="}", - sep=","} (PP.LEAF o pr_tyvar) ftv, + fun sayenv () = PP.outputTree(print,layout_env env, !Flags.colwidth) + fun sayset () = PP.outputTree(print,NatSet.layoutSet {start="{",finish="}", + sep=","} (PP.LEAF o pr_tyvar) ftv, !Flags.colwidth) val _ = if NatSet.isEmpty ftv then () (* there can no-longer be free type variables in * a topdec - see EfficientElab/ElabTopdec.sml; mael 2007-11-05 *) @@ -656,7 +661,10 @@ structure LambdaStatSem: LAMBDA_STAT_SEM = of ([ta], [tr]) => let open LambdaExp val unboxed_types = [boolType, unitType, int31Type, word31Type, + int63Type, word63Type, intDefaultType(), wordDefaultType(), foreignptrType] + @ (if tag_values() then [] + else [int32Type, word32Type]) fun ok t = List.exists (fn t' => LambdaBasics.eq_Type(t,t')) unboxed_types in if ok ta andalso ok tr then () else die "c function `id' is used to cast to or from a boxed type; \ @@ -814,6 +822,8 @@ structure LambdaStatSem: LAMBDA_STAT_SEM = let val tn = case precision of 31 => tyName_INT31 | 32 => tyName_INT32 + | 63 => tyName_INT63 + | 64 => tyName_INT64 (* | ~1 => tyName_INTINF *) (* IntInf's have been compiled away at this point *) | _ => die ("SWITCH_I.precision = " ^ Int.toString precision) in type_switch (type_lexp env) (fn _ => tn) switch @@ -822,6 +832,8 @@ structure LambdaStatSem: LAMBDA_STAT_SEM = let val tn = case precision of 31 => tyName_WORD31 (* word8 type translated into default word type in CompileDec *) | 32 => tyName_WORD32 + | 63 => tyName_WORD63 + | 64 => tyName_WORD64 | _ => die "SWITCH_I" in type_switch (type_lexp env) (fn _ => tn) switch end diff --git a/src/Compiler/Lambda/OptLambda.sml b/src/Compiler/Lambda/OptLambda.sml index 5f57d0962..e44f14480 100644 --- a/src/Compiler/Lambda/OptLambda.sml +++ b/src/Compiler/Lambda/OptLambda.sml @@ -722,7 +722,7 @@ structure OptLambda: OPT_LAMBDA = fun simple_nonexpanding e = case e of VAR{instances=[],regvars=[],...} => true - | INTEGER (_,t) => if tag_values() then eq_Type(t,int31Type) else true + | INTEGER (_,t) => if tag_values() then eq_Type(t,int31Type) orelse eq_Type(t,int63Type) else true | F64 _ => true | LET{pat,bind,scope} => simple_nonexpanding bind andalso simple_nonexpanding scope | PRIM(SELECTprim _, [e]) => simple_nonexpanding e @@ -1070,13 +1070,15 @@ structure OptLambda: OPT_LAMBDA = Con.eq(Con.con_TRUE, con) orelse Con.eq(Con.con_FALSE, con) fun is_unboxed_value lamb = - case lamb - of INTEGER (v,t) => if tag_values() then not(eq_Type(t, int32Type)) - else true - | WORD (v,t) => if tag_values() then not(eq_Type(t, word32Type)) - else true - | PRIM(CONprim {con,...},nil) => is_boolean con - | _ => false + case lamb of + INTEGER (_,t) => if tag_values() then (eq_Type(t, int31Type) orelse + eq_Type(t, int63Type)) + else true + | WORD (_,t) => if tag_values() then (not(eq_Type(t, word32Type)) andalso + not(eq_Type(t, word64Type))) + else true + | PRIM(CONprim {con,...},nil) => is_boolean con + | _ => false fun constantFolding lamb fail = if not(aggressive_opt()) then fail @@ -1113,6 +1115,21 @@ structure OptLambda: OPT_LAMBDA = | "__equal_int31" => opp (op =) | "__equal_int32b" => opp (op =) | "__equal_int32ub" => opp (op =) + | "__less_int63" => opp (op <) + | "__less_int64b" => opp (op <) + | "__less_int64ub" => opp (op <) + | "__lesseq_int63" => opp (op <=) + | "__lesseq_int64b" => opp (op <=) + | "__lesseq_int64ub" => opp (op <=) + | "__greater_int63" => opp (op >) + | "__greater_int64b" => opp (op >) + | "__greater_int64ub" => opp (op >) + | "__greatereq_int63" => opp (op >=) + | "__greatereq_int64b" => opp (op >=) + | "__greatereq_int64ub" => opp (op >=) + | "__equal_int63" => opp (op =) + | "__equal_int64b" => opp (op =) + | "__equal_int64ub" => opp (op =) | _ => NONE end | [WORD(v1,t),WORD(v2,_)] => @@ -1121,27 +1138,48 @@ structure OptLambda: OPT_LAMBDA = "__less_word31" => opp (op <) | "__less_word32b" => opp (op <) | "__less_word32ub" => opp (op <) + | "__less_word63" => opp (op <) + | "__less_word64b" => opp (op <) + | "__less_word64ub" => opp (op <) | "__lesseq_word31" => opp (op <=) | "__lesseq_word32b" => opp (op <=) | "__lesseq_word32ub" => opp (op <=) + | "__lesseq_word63" => opp (op <=) + | "__lesseq_word64b" => opp (op <=) + | "__lesseq_word64ub" => opp (op <=) | "__greater_word31" => opp (op >) | "__greater_word32b" => opp (op >) | "__greater_word32ub" => opp (op >) + | "__greater_word63" => opp (op >) + | "__greater_word64b" => opp (op >) + | "__greater_word64ub" => opp (op >) | "__greatereq_word31" => opp (op >=) | "__greatereq_word32b" => opp (op >=) | "__greatereq_word32ub" => opp (op >=) + | "__greatereq_word63" => opp (op >=) + | "__greatereq_word64b" => opp (op >=) + | "__greatereq_word64ub" => opp (op >=) | "__equal_word" => opp (op =) | "__equal_word31" => opp (op =) | "__equal_word32b" => opp (op =) | "__equal_word32ub" => opp (op =) - | "__andb_word" => SOME(WORD(Word32.andb(v1,v2),t)) - | "__andb_word31" => SOME(WORD(Word32.andb(v1,v2),t)) - | "__andb_word32b" => SOME(WORD(Word32.andb(v1,v2),t)) - | "__andb_word32ub" => SOME(WORD(Word32.andb(v1,v2),t)) - | "__orb_word" => SOME(WORD(Word32.orb(v1,v2),t)) - | "__orb_word31" => SOME(WORD(Word32.orb(v1,v2),t)) - | "__orb_word32b" => SOME(WORD(Word32.orb(v1,v2),t)) - | "__orb_word32ub" => SOME(WORD(Word32.orb(v1,v2),t)) + | "__equal_word63" => opp (op =) + | "__equal_word64b" => opp (op =) + | "__equal_word64ub" => opp (op =) + | "__andb_word" => SOME(WORD(IntInf.andb(v1,v2),t)) + | "__andb_word31" => SOME(WORD(IntInf.andb(v1,v2),t)) + | "__andb_word32b" => SOME(WORD(IntInf.andb(v1,v2),t)) + | "__andb_word32ub" => SOME(WORD(IntInf.andb(v1,v2),t)) + | "__andb_word63" => SOME(WORD(IntInf.andb(v1,v2),t)) + | "__andb_word64b" => SOME(WORD(IntInf.andb(v1,v2),t)) + | "__andb_word64ub" => SOME(WORD(IntInf.andb(v1,v2),t)) + | "__orb_word" => SOME(WORD(IntInf.orb(v1,v2),t)) + | "__orb_word31" => SOME(WORD(IntInf.orb(v1,v2),t)) + | "__orb_word32b" => SOME(WORD(IntInf.orb(v1,v2),t)) + | "__orb_word32ub" => SOME(WORD(IntInf.orb(v1,v2),t)) + | "__orb_word63" => SOME(WORD(IntInf.orb(v1,v2),t)) + | "__orb_word64b" => SOME(WORD(IntInf.orb(v1,v2),t)) + | "__orb_word64ub" => SOME(WORD(IntInf.orb(v1,v2),t)) | _ => NONE end | _ => NONE) @@ -1790,7 +1828,7 @@ structure OptLambda: OPT_LAMBDA = of PRIM(CCALLprim{name="__blockf64_sub_f64",...}, [VAR{lvar,instances=[],regvars=[],...},INTEGER (i32,_)]) => (case LvarMap.lookup env lvar of SOME lvars => - let val i = Int32.toInt i32 + let val i = IntInf.toInt i32 handle Overflow => die "eliminate_explicit_blockf64s: expecting small int" val lvar' = List.nth(lvars, i) handle Subscript => die "eliminate_explicit_blockf64s: subscript error" diff --git a/src/Compiler/Regions/MUL_EXP.sml b/src/Compiler/Regions/MUL_EXP.sml index 0e68cf6ae..d2f4dda7f 100644 --- a/src/Compiler/Regions/MUL_EXP.sml +++ b/src/Compiler/Regions/MUL_EXP.sml @@ -73,8 +73,8 @@ signature MUL_EXP = and ('a,'b,'c)LambdaExp = VAR of {lvar: lvar, il : il, plain_arreffs: (effectvar * ateffect list) list, fix_bound: bool, rhos_actuals: 'a list ref, other: 'c} - | INTEGER of Int32.int * Type * 'a - | WORD of Word32.word * Type * 'a + | INTEGER of IntInf.int * Type * 'a + | WORD of IntInf.int * Type * 'a | STRING of string * 'a | REAL of string * 'a (* reals are represented as strings * for the precision to be preserved. *) @@ -118,8 +118,8 @@ signature MUL_EXP = bool: true if exception is nullary *) | RAISE of ('a,'b,'c)trip | HANDLE of ('a,'b,'c)trip * ('a,'b,'c)trip - | SWITCH_I of {switch: ('a,'b,'c,Int32.int) Switch, precision: int} - | SWITCH_W of {switch: ('a,'b,'c,Word32.word) Switch, precision: int} + | SWITCH_I of {switch: ('a,'b,'c,IntInf.int) Switch, precision: int} + | SWITCH_W of {switch: ('a,'b,'c,IntInf.int) Switch, precision: int} | SWITCH_S of ('a,'b,'c,string) Switch | SWITCH_C of ('a,'b,'c,con) Switch | SWITCH_E of ('a,'b,'c,excon) Switch diff --git a/src/Compiler/Regions/MulExp.sml b/src/Compiler/Regions/MulExp.sml index a717843ea..cda2550b6 100644 --- a/src/Compiler/Regions/MulExp.sml +++ b/src/Compiler/Regions/MulExp.sml @@ -96,8 +96,8 @@ struct and ('a,'b,'c)LambdaExp = VAR of {lvar: lvar, il: il, plain_arreffs: (effectvar * ateffect list) list, fix_bound: bool, rhos_actuals: 'a list ref, other: 'c} - | INTEGER of Int32.int * Type * 'a - | WORD of Word32.word * Type * 'a + | INTEGER of IntInf.int * Type * 'a + | WORD of IntInf.int * Type * 'a | STRING of string * 'a | REAL of string * 'a | F64 of string * 'a @@ -139,8 +139,8 @@ struct bool: true if exception is nullary *) | RAISE of ('a,'b,'c)trip | HANDLE of ('a,'b,'c)trip * ('a,'b,'c)trip - | SWITCH_I of {switch:('a,'b,'c,Int32.int) Switch, precision: int} - | SWITCH_W of {switch:('a,'b,'c,Word32.word) Switch, precision: int} + | SWITCH_I of {switch:('a,'b,'c,IntInf.int) Switch, precision: int} + | SWITCH_W of {switch:('a,'b,'c,IntInf.int) Switch, precision: int} | SWITCH_S of ('a,'b,'c,string) Switch | SWITCH_C of ('a,'b,'c,con) Switch | SWITCH_E of ('a,'b,'c,excon) Switch @@ -807,8 +807,8 @@ struct | VAR{lvar, il, fix_bound=true, rhos_actuals = ref rhos_actuals, plain_arreffs,other} => lay_il(Lvar.pr_lvar lvar, "", il, rhos_actuals) ^^^ layout_other other - | INTEGER(i, t, a) => LEAF(Int32.toString i ^^ layout_alloc a) - | WORD(w, t, a) => LEAF("0x" ^ Word32.toString w ^^ layout_alloc a) + | INTEGER(i, t, a) => LEAF(IntInf.toString i ^^ layout_alloc a) + | WORD(w, t, a) => LEAF("0x" ^ IntInf.fmt StringCvt.HEX w ^^ layout_alloc a) | STRING(s, a) => LEAF(quote s ^^ layout_alloc a) | REAL(r, a) => LEAF(r ^^ layout_alloc a) | F64(r, a) => LEAF((r^"f64") ^^ layout_alloc a) @@ -1055,8 +1055,8 @@ struct end ) else layTrip(body,n) - | SWITCH_I {switch,precision} => layoutSwitch layTrip Int32.toString switch - | SWITCH_W {switch,precision} => layoutSwitch layTrip (fn w => "0x" ^ Word32.toString w) switch + | SWITCH_I {switch,precision} => layoutSwitch layTrip IntInf.toString switch + | SWITCH_W {switch,precision} => layoutSwitch layTrip (fn w => "0x" ^ IntInf.fmt StringCvt.HEX w) switch | SWITCH_S(sw) => layoutSwitch layTrip (fn s => s) sw | SWITCH_C(sw) => layoutSwitch layTrip Con.pr_con sw | SWITCH_E(sw) => layoutSwitch layTrip Excon.pr_excon sw diff --git a/src/Compiler/Regions/REGION_EXP.sml b/src/Compiler/Regions/REGION_EXP.sml index 6a998d8ac..fb09a962f 100644 --- a/src/Compiler/Regions/REGION_EXP.sml +++ b/src/Compiler/Regions/REGION_EXP.sml @@ -49,8 +49,8 @@ signature REGION_EXP = and ('a,'b)trip = TR of ('a,'b)LambdaExp * metaType * effect and ('a,'b)LambdaExp = VAR of {lvar: lvar, il_r : (il * (il * cone -> il * cone)) ref, fix_bound: bool} - | INTEGER of Int32.int * Type * 'a - | WORD of Word32.word * Type * 'a + | INTEGER of IntInf.int * Type * 'a + | WORD of IntInf.int * Type * 'a | STRING of string * 'a | REAL of string * 'a | F64 of string * 'a @@ -79,8 +79,8 @@ signature REGION_EXP = bool: true if exception is nullary *) | RAISE of ('a,'b)trip | HANDLE of ('a,'b)trip * ('a,'b)trip - | SWITCH_I of {switch: ('a,'b,Int32.int) Switch, precision: int} - | SWITCH_W of {switch: ('a,'b,Word32.word) Switch, precision: int} + | SWITCH_I of {switch: ('a,'b,IntInf.int) Switch, precision: int} + | SWITCH_W of {switch: ('a,'b,IntInf.int) Switch, precision: int} | SWITCH_S of ('a,'b,string) Switch | SWITCH_C of ('a,'b,con) Switch | SWITCH_E of ('a,'b,excon) Switch diff --git a/src/Compiler/Regions/RTYPE.sig b/src/Compiler/Regions/RTYPE.sig index 782d404ed..be172e831 100644 --- a/src/Compiler/Regions/RTYPE.sig +++ b/src/Compiler/Regions/RTYPE.sig @@ -27,9 +27,13 @@ sig val exnType : Type val int31Type : Type val int32Type : Type + val int63Type : Type + val int64Type : Type val word8Type : Type val word31Type : Type val word32Type : Type + val word63Type : Type + val word64Type : Type val boolType : Type val realType : Type val f64Type : Type diff --git a/src/Compiler/Regions/RType.sml b/src/Compiler/Regions/RType.sml index 374359e09..61b0c1355 100644 --- a/src/Compiler/Regions/RType.sml +++ b/src/Compiler/Regions/RType.sml @@ -1245,13 +1245,20 @@ struct * inference, integer and word types are resolved to be either word8, * word31, word32, int31, or int32. The default integer type is * dynamically determined to be the largest integer type that fits - * in 32 bits; similarly for words. *) + * in 32 bits; similarly for words. + * + * MEMO: we will later modify this to 64 bits... + *) val int31Type: Type = CONSTYPE(TyName.tyName_INT31,[],[],[]) val int32Type: Type = CONSTYPE(TyName.tyName_INT32,[],[],[]) + val int63Type: Type = CONSTYPE(TyName.tyName_INT63,[],[],[]) + val int64Type: Type = CONSTYPE(TyName.tyName_INT64,[],[],[]) val word8Type: Type = CONSTYPE(TyName.tyName_WORD8,[],[],[]) val word31Type: Type = CONSTYPE(TyName.tyName_WORD31,[],[],[]) val word32Type: Type = CONSTYPE(TyName.tyName_WORD32,[],[],[]) + val word63Type: Type = CONSTYPE(TyName.tyName_WORD63,[],[],[]) + val word64Type: Type = CONSTYPE(TyName.tyName_WORD64,[],[],[]) val exnType: Type = CONSTYPE(TyName.tyName_EXN,[],[],[]) val boolType: Type = CONSTYPE(TyName.tyName_BOOL,[],[],[]) @@ -1314,7 +1321,9 @@ struct else if TyName.eq (tyname, TyName.tyName_REAL) then SOME (RegConst.size_of_real ()) else if (TyName.eq (tyname, TyName.tyName_WORD32) - orelse TyName.eq (tyname, TyName.tyName_INT32)) then + orelse TyName.eq (tyname, TyName.tyName_INT32) + orelse TyName.eq (tyname, TyName.tyName_INT64) + orelse TyName.eq (tyname, TyName.tyName_WORD64)) then (* boxed because RegConst.unboxed_tyname(tyname) returned false! *) SOME (RegConst.size_of_record [1]) (* 2001-02-17, Niels - dummy list [1] with one element! *) else if (TyName.eq (tyname, TyName.tyName_STRING) diff --git a/src/Compiler/Regions/RegionExp.sml b/src/Compiler/Regions/RegionExp.sml index 98ff0f51f..0abce07b1 100644 --- a/src/Compiler/Regions/RegionExp.sml +++ b/src/Compiler/Regions/RegionExp.sml @@ -58,8 +58,8 @@ struct and ('a,'b)trip = TR of ('a,'b)LambdaExp * metaType * effect and ('a,'b)LambdaExp = VAR of {lvar: lvar, il_r : (il * (il * cone -> il * cone)) ref, fix_bound: bool} - | INTEGER of Int32.int * Type * 'a - | WORD of Word32.word * Type * 'a + | INTEGER of IntInf.int * Type * 'a + | WORD of IntInf.int * Type * 'a | STRING of string * 'a | REAL of string * 'a | F64 of string * 'a @@ -88,8 +88,8 @@ struct bool: true if exception is nullary *) | RAISE of ('a,'b)trip | HANDLE of ('a,'b)trip * ('a,'b)trip - | SWITCH_I of {switch: ('a,'b,Int32.int) Switch, precision: int} - | SWITCH_W of {switch: ('a,'b,Word32.word) Switch, precision: int} + | SWITCH_I of {switch: ('a,'b,IntInf.int) Switch, precision: int} + | SWITCH_W of {switch: ('a,'b,IntInf.int) Switch, precision: int} | SWITCH_S of ('a,'b,string) Switch | SWITCH_C of ('a,'b,con) Switch | SWITCH_E of ('a,'b,excon) Switch @@ -390,8 +390,8 @@ old*) | VAR{lvar, il_r, fix_bound=true} => lay_il(Lvar.pr_lvar lvar, "", #1(! il_r)) - | INTEGER(i,t,a) => LEAF(Int32.toString i ^^ layout_alloc a) - | WORD(w,t,a) => LEAF("0x" ^ Word32.toString w ^^ layout_alloc a) + | INTEGER(i,t,a) => LEAF(IntInf.toString i ^^ layout_alloc a) + | WORD(w,t,a) => LEAF("0x" ^ IntInf.fmt StringCvt.HEX w ^^ layout_alloc a) | STRING(s, a) => LEAF(quote s ^^ layout_alloc a) | REAL(r, a) => LEAF(r ^^ layout_alloc a) | F64(r, a) => LEAF((r ^ "f64") ^^ layout_alloc a) @@ -560,8 +560,8 @@ old*) in NODE{start = "", finish = "", indent = 0, childsep = NOSEP, children = [t1,t2,t3]} end ) - | SWITCH_I {switch,precision} => layoutSwitch layTrip Int32.toString switch - | SWITCH_W {switch,precision} => layoutSwitch layTrip (fn w => "0x" ^ Word32.toString w) switch + | SWITCH_I {switch,precision} => layoutSwitch layTrip IntInf.toString switch + | SWITCH_W {switch,precision} => layoutSwitch layTrip (fn w => "0x" ^ IntInf.fmt StringCvt.HEX w) switch | SWITCH_S(sw) => layoutSwitch layTrip (fn s => s) sw | SWITCH_C(sw) => layoutSwitch layTrip Con.pr_con sw | SWITCH_E(sw) => layoutSwitch layTrip Excon.pr_excon sw diff --git a/src/Compiler/Regions/RegionStatEnv.sml b/src/Compiler/Regions/RegionStatEnv.sml index 543f42dc1..817e1dbbd 100644 --- a/src/Compiler/Regions/RegionStatEnv.sml +++ b/src/Compiler/Regions/RegionStatEnv.sml @@ -65,10 +65,14 @@ structure RegionStatEnv: REGION_STAT_ENV = TyNameMap.add(TyName.tyName_BOOL, (0,[],0), TyNameMap.add(TyName.tyName_INT31, (0,[],0), TyNameMap.add(TyName.tyName_INT32, (0,[],0), + TyNameMap.add(TyName.tyName_INT63, (0,[],0), + TyNameMap.add(TyName.tyName_INT64, (0,[],0), TyNameMap.add(TyName.tyName_CHAR, (0,[],0), TyNameMap.add(TyName.tyName_WORD8, (0,[],0), TyNameMap.add(TyName.tyName_WORD31, (0,[],0), TyNameMap.add(TyName.tyName_WORD32, (0,[],0), + TyNameMap.add(TyName.tyName_WORD63, (0,[],0), + TyNameMap.add(TyName.tyName_WORD64, (0,[],0), TyNameMap.add(TyName.tyName_LIST, (1,[E.PAIR_RT],0), (* the auxiliary region is for a pair; hence PAIR_RT *) TyNameMap.add(TyName.tyName_FRAG, (1,[E.STRING_RT],0), @@ -80,7 +84,7 @@ structure RegionStatEnv: REGION_STAT_ENV = TyNameMap.add(TyName.tyName_FOREIGNPTR, (0,[],0), TyNameMap.add(TyName.tyName_ARRAY, (1,[],0), TyNameMap.add(TyName.tyName_VECTOR, (1,[],0), - TyNameMap.empty))))))))))))))))))) + TyNameMap.empty))))))))))))))))))))))) local diff --git a/src/Compiler/Regions/SpreadExpression.sml b/src/Compiler/Regions/SpreadExpression.sml index a487fcbc5..d60f4e15b 100644 --- a/src/Compiler/Regions/SpreadExpression.sml +++ b/src/Compiler/Regions/SpreadExpression.sml @@ -465,49 +465,16 @@ struct end | NONE => die "spreadExp: free lvar" ) - | E.INTEGER (i,tau_ml) => let val (mu as (tau,rho), B) = freshMu(tau_ml,B) in (B,E'.TR(E'.INTEGER(i, tau, rho),E'.Mus[mu], Eff.mkPut rho), NOTAIL) end -(* - let - val rt = if ( (precision = 32 andalso tag_values()) - orelse (*for the future*) - precision > 32 ) then Eff.TOP_RT - else Eff.WORD_RT - val (rho, B) = Eff.freshRhoWithTy(rt, B) - val tau = - case precision - of 31 => R.int31Type - | 32 => R.int32Type - | _ => die "spreadExp: INTEGER" - in - (B,E'.TR(E'.INTEGER(i, rho),E'.Mus[(tau,rho)], Eff.mkPut rho)) - end -*) | E.WORD (i, tau_ml) => let val (mu as (tau,rho), B) = freshMu(tau_ml,B) in (B,E'.TR(E'.WORD(i, tau, rho),E'.Mus[mu], Eff.mkPut rho), NOTAIL) end -(* - val rt = if ( (precision = 32 andalso tag_values()) - orelse (*for the future*) - precision > 32 ) then Eff.TOP_RT - else Eff.WORD_RT - val (rho, B) = Eff.freshRhoWithTy(rt, B) - val tau = - case precision - of 8 => R.word8Type - | 31 => R.word31Type - | 32 => R.word32Type - | _ => die "spreadExp: INTEGER" - in - (B,E'.TR(E'.WORD(i, rho),E'.Mus[(tau,rho)], Eff.mkPut rho)) - end -*) | E.STRING(s: string,rv_opt)=> let val (rho, B) = maybe_explicit_rho rse B Eff.STRING_RT rv_opt val tau = R.stringType @@ -857,9 +824,9 @@ good *) retract(B, E'.TR(E'.DROP t1, E'.Mus [], phi1), NOTAIL) end - | E.SWITCH_I {switch: Int32.int E.Switch, precision} => + | E.SWITCH_I {switch: IntInf.int E.Switch, precision} => (spreadSwitch B S (fn sw => E'.SWITCH_I{switch=sw,precision=precision}) [] (switch,toplevel,cont)) - | E.SWITCH_W {switch: Word32.word E.Switch, precision} => + | E.SWITCH_W {switch: IntInf.int E.Switch, precision} => (spreadSwitch B S (fn sw => E'.SWITCH_W{switch=sw,precision=precision}) [] (switch,toplevel,cont)) | E.SWITCH_S(stringsw: string E.Switch) => (spreadSwitch B S E'.SWITCH_S [] (stringsw,toplevel,cont)) diff --git a/src/Manager/FreeIds.sml b/src/Manager/FreeIds.sml index 78e50d7f1..bdfe18bf0 100644 --- a/src/Manager/FreeIds.sml +++ b/src/Manager/FreeIds.sml @@ -65,8 +65,8 @@ structure FreeIds: FREE_IDS = longstrids: longstrid list, longtycons: longtycon list, longvids: longid list} - fun mem(y,[]) = false - | mem(y,x::xs) = y=x orelse mem(y,xs) + fun mem (y,[]) = false + | mem (y,x::xs) = y=x orelse mem(y,xs) local val bucket_longvids = ref ([] : longid list) @@ -101,25 +101,25 @@ structure FreeIds: FREE_IDS = * Functions to apply on uses of ids * ------------------------------------- *) - fun use_longvid({vids,strids,...}:ids,longvid:longid): unit = + fun use_longvid ({vids,strids,...}:ids,longvid:longid): unit = case Ident.decompose longvid of ([], vid) => if mem(vid,vids) then () else mk_free_longvid longvid | (strid::_,_) => if mem(strid,strids) then () else mk_free_longvid longvid - fun use_longstrid({strids,...}:ids,longstrid:longstrid): unit = + fun use_longstrid ({strids,...}:ids,longstrid:longstrid): unit = case StrId.explode_longstrid longstrid of ([],strid) => if mem(strid,strids) then () else mk_free_longstrid longstrid | (strid::_,_) => if mem(strid,strids) then () else mk_free_longstrid longstrid - fun use_longtycon({tycons,strids,...}:ids,longtycon:longtycon): unit = + fun use_longtycon ({tycons,strids,...}:ids,longtycon:longtycon): unit = case TyCon.explode_LongTyCon longtycon of ([], tycon) => if mem(tycon,tycons) then () else mk_free_longtycon longtycon | (strid::_,_) => if mem(strid,strids) then () else mk_free_longtycon longtycon - fun use_funid({funids,...}:ids,funid:funid): unit = + fun use_funid ({funids,...}:ids,funid:funid): unit = if mem(funid,funids) then () else mk_free_funid funid - fun use_sigid({sigids,...}:ids,sigid:sigid): unit = + fun use_sigid ({sigids,...}:ids,sigid:sigid): unit = if mem(sigid,sigids) then () else mk_free_sigid sigid fun use_longids (ids:ids, {longvids,longtycons,longstrids,funids,sigids}) : unit = diff --git a/src/Manager/ManagerObjects0.sml b/src/Manager/ManagerObjects0.sml index 2aed4a165..10b66d79a 100644 --- a/src/Manager/ManagerObjects0.sml +++ b/src/Manager/ManagerObjects0.sml @@ -233,12 +233,16 @@ functor ManagerObjects0(structure Execution : EXECUTION) fun restrict (ib, ids, tynames) = let val tynames = [TyName.tyName_EXN, (* exn is used explicitly in CompileDec *) - TyName.tyName_INT31, (* int31, int32, intinf, word8, word31, word32 needed *) - TyName.tyName_INT32, (* because of overloading *) + TyName.tyName_INT31, (* int31, int32, int63, int64, intinf, word8, word31, *) + TyName.tyName_INT32, (* word32, word63, word64 needed because of overloading *) + TyName.tyName_INT63, + TyName.tyName_INT64, TyName.tyName_INTINF, TyName.tyName_WORD8, TyName.tyName_WORD31, TyName.tyName_WORD32, + TyName.tyName_WORD63, + TyName.tyName_WORD64, TyName.tyName_STRING, (* string is needed for string constants *) TyName.tyName_CHAR, (* char is needed for char constants *) TyName.tyName_REF, diff --git a/src/Parsing/GRAMMAR_UTILS.sml b/src/Parsing/GRAMMAR_UTILS.sml index 23ea596b4..24ea2ffd6 100644 --- a/src/Parsing/GRAMMAR_UTILS.sml +++ b/src/Parsing/GRAMMAR_UTILS.sml @@ -68,7 +68,7 @@ signature GRAMMAR_UTILS = val mk_TyCon: string -> M.DecGrammar.tycon val mk_LongTyCon: string list -> M.longtycon val mk_IntSCon: IntInf.int -> M.DecGrammar.scon - val mk_WordSCon: Word32.word -> M.DecGrammar.scon + val mk_WordSCon: IntInf.int -> M.DecGrammar.scon val mk_StringSCon: string -> M.DecGrammar.scon val mk_CharSCon: int -> M.DecGrammar.scon val mk_RealSCon: string -> M.DecGrammar.scon diff --git a/src/Parsing/LEX_UTILS.sml b/src/Parsing/LEX_UTILS.sml index 0096d24c6..b8c6c67d8 100644 --- a/src/Parsing/LEX_UTILS.sml +++ b/src/Parsing/LEX_UTILS.sml @@ -19,7 +19,7 @@ signature LEX_UTILS = val asQualId: string -> string list val asDigit: string -> int val asInteger: string -> IntInf.int option - val asWord: string -> Word32.word option + val asWord: string -> IntInf.int option val asReal: string -> string option val initArg: SourceReader -> LexArgument diff --git a/src/Parsing/LexUtils.sml b/src/Parsing/LexUtils.sml index ec2c2e59d..f1a7e9c5b 100644 --- a/src/Parsing/LexUtils.sml +++ b/src/Parsing/LexUtils.sml @@ -35,32 +35,30 @@ functor LexUtils(Token: Topdec_TOKENS): LEX_UTILS = | _ => false (* We can't get nil (or [_]). *) local - fun ordw c = Word32.fromInt(ord c) + fun ordw c = IntInf.fromInt(ord c) - fun chars_to_w (#"0" :: #"x" :: chars) = chars_to_w_in_base 0w16 chars - | chars_to_w chars = chars_to_w_in_base 0w10 chars - and chars_to_w_in_base base chars = chars_to_w_in_base0 base 0w0 chars + fun chars_to_w (#"0" :: #"x" :: chars) = chars_to_w_in_base 16 chars + | chars_to_w chars = chars_to_w_in_base 10 chars + and chars_to_w_in_base base chars = chars_to_w_in_base0 base 0 chars and chars_to_w_in_base0 base n [] = n | chars_to_w_in_base0 base n (char :: chars) = (case char_to_w_opt base char of - SOME i => (* a new digit is added; manually raise Overflow if - * new value is smaller than old value *) + SOME i => let val new = n * base + i - in if new < n then raise Overflow - else chars_to_w_in_base0 base new chars + in chars_to_w_in_base0 base new chars end | NONE => n) and char_to_w_opt base char = - let val i = if Char.isUpper char then ordw char - ordw #"A" + 0w10 - else if Char.isLower char then ordw char - ordw #"a" + 0w10 + let val i = if Char.isUpper char then ordw char - ordw #"A" + 10 + else if Char.isLower char then ordw char - ordw #"a" + 10 else if Char.isDigit char then ordw char - ordw #"0" else base (*hack*) in if i NONE - fun asWord0 (#"0" :: #"w" :: #"x" :: chars) = chars_to_w_in_base 0w16 chars - | asWord0 (#"0" :: #"w" :: chars) = chars_to_w_in_base 0w10 chars + fun asWord0 (#"0" :: #"w" :: #"x" :: chars) = chars_to_w_in_base 16 chars + | asWord0 (#"0" :: #"w" :: chars) = chars_to_w_in_base 10 chars | asWord0 _ = impossible "asWord0" fun exception_to_opt p x = SOME (p x) handle Overflow => NONE @@ -136,7 +134,7 @@ functor LexUtils(Token: Topdec_TOKENS): LEX_UTILS = fun addAsciiChar (pos, text) arg = add_numbered_char (pos, text) arg 255 (case explode text - of [#"\\", c1, c2, c3] => (Word32.toInt(chars_to_w_in_base 0w10 [c1, c2, c3]) + of [#"\\", c1, c2, c3] => (IntInf.toInt(chars_to_w_in_base 10 [c1, c2, c3]) handle _ => impossible "addAsciiChar.Overflow") | _ => impossible "addAsciiChar") @@ -147,7 +145,7 @@ functor LexUtils(Token: Topdec_TOKENS): LEX_UTILS = add_numbered_char (pos, text) arg 255 (case explode text of [#"\\", #"u", c1, c2, c3, c4] => - (Word32.toInt(chars_to_w_in_base 0w16 [c1, c2, c3, c4]) + (IntInf.toInt(chars_to_w_in_base 16 [c1, c2, c3, c4]) handle _ => impossible "addUnicodeChar.Overflow") | _ => impossible "addUnicodeChar") diff --git a/src/Parsing/Topdec.grm b/src/Parsing/Topdec.grm index a95336646..0f53352d0 100644 --- a/src/Parsing/Topdec.grm +++ b/src/Parsing/Topdec.grm @@ -139,7 +139,7 @@ type arg = unit | DECPOSINTEGER of IntInf.int option | DECNEGINTEGER of IntInf.int option | HEXINTEGER of IntInf.int option | DIGIT of int - | WORD of Word32.word option + | WORD of IntInf.int option | REAL of string option | STRING of string | BEGINQ | ENDQ of string | OBJL of string | AQID of string | ID of string | TYVAR of string @@ -157,7 +157,7 @@ type arg = unit %value DECPOSINTEGER (SOME (IntInf.fromInt 0)) %value DECNEGINTEGER (SOME (IntInf.fromInt 0)) %value HEXINTEGER (SOME (IntInf.fromInt 0)) -%value WORD (SOME 0w0) +%value WORD (SOME 0) %value REAL (SOME "0.0") %value STRING ("") %value ID ("bogus") diff --git a/src/Parsing/Topdec.grm.sig b/src/Parsing/Topdec.grm.sig index 2e346838c..0251650f0 100644 --- a/src/Parsing/Topdec.grm.sig +++ b/src/Parsing/Topdec.grm.sig @@ -13,7 +13,7 @@ val ENDQ: (string) * 'a * 'a -> (svalue,'a) token val BEGINQ: 'a * 'a -> (svalue,'a) token val STRING: (string) * 'a * 'a -> (svalue,'a) token val REAL: (string option) * 'a * 'a -> (svalue,'a) token -val WORD: (Word32.word option) * 'a * 'a -> (svalue,'a) token +val WORD: (IntInf.int option) * 'a * 'a -> (svalue,'a) token val DIGIT: (int) * 'a * 'a -> (svalue,'a) token val HEXINTEGER: (IntInf.int option) * 'a * 'a -> (svalue,'a) token val DECNEGINTEGER: (IntInf.int option) * 'a * 'a -> (svalue,'a) token diff --git a/src/Parsing/Topdec.grm.sml b/src/Parsing/Topdec.grm.sml index 6a4a27487..062257da9 100644 --- a/src/Parsing/Topdec.grm.sml +++ b/src/Parsing/Topdec.grm.sml @@ -1517,7 +1517,7 @@ datatype svalue = VOID | ntVOID of unit -> unit | AQID of unit -> (string) | OBJL of unit -> (string) | ENDQ of unit -> (string) | STRING of unit -> (string) | REAL of unit -> (string option) - | WORD of unit -> (Word32.word option) | DIGIT of unit -> (int) + | WORD of unit -> (IntInf.int option) | DIGIT of unit -> (int) | HEXINTEGER of unit -> (IntInf.int option) | DECNEGINTEGER of unit -> (IntInf.int option) | DECPOSINTEGER of unit -> (IntInf.int option) @@ -1736,7 +1736,7 @@ fn (T 8) => MlyValue.QUAL_ID(fn () => (["bogus"])) | (T 61) => MlyValue.DECPOSINTEGER(fn () => (SOME (IntInf.fromInt 0))) | (T 62) => MlyValue.DECNEGINTEGER(fn () => (SOME (IntInf.fromInt 0))) | (T 63) => MlyValue.HEXINTEGER(fn () => (SOME (IntInf.fromInt 0))) | -(T 65) => MlyValue.WORD(fn () => (SOME 0w0)) | +(T 65) => MlyValue.WORD(fn () => (SOME 0)) | (T 66) => MlyValue.REAL(fn () => (SOME "0.0")) | (T 67) => MlyValue.STRING(fn () => ("")) | (T 72) => MlyValue.ID(fn () => ("bogus")) | diff --git a/src/Runtime/Math.c b/src/Runtime/Math.c index 53d8ba571..620a92776 100644 --- a/src/Runtime/Math.c +++ b/src/Runtime/Math.c @@ -54,6 +54,29 @@ __div_int31(ssize_t x0, ssize_t y0, uintptr_t exn) /* ML */ else return (2*((x-1)/(y-1))+1); } +ssize_t +__div_int63(ssize_t x0, ssize_t y0, uintptr_t exn) /* ML */ +{ + long int x = (long int)x0; + long int y = (long int)y0; + if (y == 1) + { + raise_exn(exn); + return 0; // never reached + } + if ( y == -1 && x == ( 2 * (-4611686018427387904) + 1 ) ) // = 2 * Int63.minInt + 1 + { + raise_exn((uintptr_t)&exn_OVERFLOW); + return 0; // never reached + } + if (x == 1) return 1; + if (x < 1 && y > 1) + return (2*((x+1)/(y-1))-1); + else if (x > 1 && y < 1) + return (2*((x-3)/(y-1))-1); + else return (2*((x-1)/(y-1))+1); +} + ssize_t __div_int32ub(ssize_t x0, ssize_t y0, uintptr_t exn) /* ML */ { @@ -76,6 +99,28 @@ __div_int32ub(ssize_t x0, ssize_t y0, uintptr_t exn) /* ML */ else return x / y; } +ssize_t +__div_int64ub(ssize_t x0, ssize_t y0, uintptr_t exn) /* ML */ +{ + long int x = (long int)x0; + long int y = (long int)y0; + if (y == 0) + { + raise_exn(exn); + return 0; // never reached + } + if ( y == -1 && x == (-9223372036854775807 - 1) ) + { + raise_exn((uintptr_t)&exn_OVERFLOW); + return 0; // never reached + } + if (x < 0 && y > 0) + return ((x + 1) / y) - 1; + else if (x > 0 && y < 0) + return ((x - 1) / y) - 1; + else return x / y; +} + size_t __div_word32ub(size_t x0, size_t y0, uintptr_t exn) /* ML */ { @@ -89,6 +134,19 @@ __div_word32ub(size_t x0, size_t y0, uintptr_t exn) /* ML */ return (x / y); } +size_t +__div_word64ub(size_t x0, size_t y0, uintptr_t exn) /* ML */ +{ + unsigned long int x = (unsigned long int)x0; + unsigned long int y = (unsigned long int)y0; + if ( y == 0 ) + { + raise_exn(exn); + return 0; // never reached + } + return (x / y); +} + size_t __div_word31(size_t x, size_t y, uintptr_t exn) /* ML */ { @@ -103,6 +161,20 @@ __div_word31(size_t x, size_t y, uintptr_t exn) /* ML */ return i32ub_to_i31(xC / yC); } +size_t +__div_word63(size_t x, size_t y, uintptr_t exn) /* ML */ +{ + unsigned long int xC = i63_to_i64ub((unsigned long int)x); + unsigned long int yC = i63_to_i64ub((unsigned long int)y); + + if ( yC == 0 ) + { + raise_exn(exn); + return 0; // never reached + } + return i64ub_to_i63(xC / yC); +} + ssize_t __mod_int31(ssize_t x0ML, ssize_t y0ML, uintptr_t exn) { @@ -120,6 +192,23 @@ __mod_int31(ssize_t x0ML, ssize_t y0ML, uintptr_t exn) return ((xML-1)%(yML-1))+yML; } +ssize_t +__mod_int63(ssize_t x0ML, ssize_t y0ML, uintptr_t exn) +{ + long int xML = (long int)x0ML; + long int yML = (long int)y0ML; + + if ( yML == 1 ) + { + raise_exn(exn); + return 0; // never reached + } + if ((xML-1)%(yML-1) == 0 || (xML>1 && yML>1) || (xML<1 && yML<1)) + return ((xML-1)%(yML-1))+1; + else + return ((xML-1)%(yML-1))+yML; +} + ssize_t __mod_int32ub(ssize_t x0, ssize_t y0, uintptr_t exn) { @@ -137,6 +226,23 @@ __mod_int32ub(ssize_t x0, ssize_t y0, uintptr_t exn) return (x % y) + y; } +ssize_t +__mod_int64ub(ssize_t x0, ssize_t y0, uintptr_t exn) +{ + long int x = (long int)x0; + long int y = (long int)y0; + if ( y == 0 ) + { + raise_exn(exn); + return 0; // never reached + } + if ( (x > 0 && y > 0) || (x < 0 && y < 0) || (x % y == 0) ) + { + return x % y; + } + return (x % y) + y; +} + size_t __mod_word32ub(size_t x0, size_t y0, uintptr_t exn) { @@ -150,6 +256,19 @@ __mod_word32ub(size_t x0, size_t y0, uintptr_t exn) return (x % y); } +size_t +__mod_word64ub(size_t x0, size_t y0, uintptr_t exn) +{ + unsigned long int x = (unsigned long int)x0; + unsigned long int y = (unsigned long int)y0; + if ( y == 0 ) + { + raise_exn(exn); + return 0; // never reached + } + return (x % y); +} + size_t __mod_word31(size_t x, size_t y, uintptr_t exn) { @@ -164,12 +283,32 @@ __mod_word31(size_t x, size_t y, uintptr_t exn) return i32ub_to_i31(xC % yC); } +size_t +__mod_word63(size_t x, size_t y, uintptr_t exn) +{ + unsigned long int xC = i63_to_i64ub((unsigned long int)x); + unsigned long int yC = i63_to_i64ub((unsigned long int)y); + + if ( yC == 0 ) + { + raise_exn(exn); + return 0; // never reached + } + return i64ub_to_i63(xC % yC); +} + ssize_t __quot_int32ub(ssize_t xML, ssize_t yML) { return ((int)xML)/((int)yML); } +ssize_t +__quot_int64ub(ssize_t xML, ssize_t yML) +{ + return ((long int)xML)/((long int)yML); +} + ssize_t __quot_int31(ssize_t xML, ssize_t yML) { @@ -180,12 +319,28 @@ __quot_int31(ssize_t xML, ssize_t yML) return i32ub_to_i31(xC / yC); } +ssize_t +__quot_int63(ssize_t xML, ssize_t yML) +{ + long int xC,yC; + + xC = i63_to_i64ub((long int)xML); + yC = i63_to_i64ub((long int)yML); + return i64ub_to_i63(xC / yC); +} + ssize_t __rem_int32ub(ssize_t xML, ssize_t yML) { return ((int)xML) % ((int)yML); } +ssize_t +__rem_int64ub(ssize_t xML, ssize_t yML) +{ + return ((long int)xML) % ((long int)yML); +} + ssize_t __rem_int31(ssize_t xML, ssize_t yML) { @@ -197,6 +352,17 @@ __rem_int31(ssize_t xML, ssize_t yML) return i32ub_to_i31(xC % yC); } +ssize_t +__rem_int63(ssize_t xML, ssize_t yML) +{ + long int xC,yC; + + xC = i63_to_i64ub((long int)xML); + yC = i63_to_i64ub((long int)yML); + + return i64ub_to_i63(xC % yC); +} + #ifdef TAG_VALUES size_t* @@ -249,13 +415,63 @@ __rem_int32b(size_t* b, size_t* x, size_t* y) return b; } +size_t* +__div_int64b(size_t* b, size_t* x, size_t* y, uintptr_t exn) +{ + get_i64b(b) = __div_int64ub(get_i64b(x), get_i64b(y), exn); + set_i64b_tag(b); + return b; +} + +size_t* +__div_word64b(size_t* b, size_t* x, size_t* y, uintptr_t exn) +{ + get_i64b(b) = __div_word64ub(get_i64b(x), get_i64b(y), exn); + set_i64b_tag(b); + return b; +} + +size_t* +__mod_int64b(size_t* b, size_t* x, size_t* y, uintptr_t exn) +{ + get_i64b(b) = __mod_int64ub(get_i64b(x), get_i64b(y), exn); + set_i64b_tag(b); + return b; +} + +size_t* +__mod_word64b(size_t* b, size_t* x, size_t* y, uintptr_t exn) +{ + get_i64b(b) = __mod_word64ub(get_i64b(x), get_i64b(y), exn); + set_i64b_tag(b); + return b; +} + +// quot need not check for y being 0; this is checked for in Int64 +size_t* +__quot_int64b(size_t* b, size_t* x, size_t* y) +{ + get_i64b(b) = __quot_int64ub(get_i64b(x), get_i64b(y)); + set_i64b_tag(b); + return b; +} + +// rem need not check for y being 0; this is checked for in Int64 +size_t* +__rem_int64b(size_t* b, size_t* x, size_t* y) +{ + get_i64b(b) = __rem_int64ub(get_i64b(x), get_i64b(y)); + set_i64b_tag(b); + return b; +} + #endif /*TAG_VALUES*/ ssize_t realInt(ssize_t d, ssize_t x) { debug(printf("[realInt: d = %zu, x = %zu\n", d, x)); - get_d(d) = (double) (convertIntToC((int)x)); + get_d(d) = (double) (convertIntToC((long int)x)); set_dtag(d); debug(printf("]\n")); return d; @@ -273,11 +489,11 @@ divFloat(ssize_t d, ssize_t x, ssize_t y) return d; } -ssize_t +long int floorFloat(ssize_t f) { double r; - ssize_t i; + long int i; r = get_d(f); if( r >= 0.0 ) @@ -286,16 +502,16 @@ floorFloat(ssize_t f) { raise_exn((uintptr_t)&exn_OVERFLOW); } - return (convertIntToML((ssize_t) r)); + return (convertIntToML((long int) r)); } if( r < Min_Int_d ) { raise_exn((uintptr_t)&exn_OVERFLOW); } - i = (ssize_t) r; + i = (long int) r; if( r < ((double) i) ) { - i -= 1; + i -= 1L; } return convertIntToML(i); } diff --git a/src/Runtime/Math.h b/src/Runtime/Math.h index 54a2989de..db95bea4a 100644 --- a/src/Runtime/Math.h +++ b/src/Runtime/Math.h @@ -28,11 +28,11 @@ #define minDefine(A,B) ((A> 1) #define Min_Int (INTPTR_MIN >> 1) @@ -41,11 +41,11 @@ #define val_precision (__WORDSIZE - 1) */ #else -#define Max_Int 2147483647 -#define Min_Int (-2147483647-1) -#define Max_Int_d 2147483647.0 -#define Min_Int_d -2147483648.0 -#define val_precision 32 +#define Max_Int 9223372036854775807 +#define Min_Int (-9223372036854775807-1) +#define Max_Int_d 9223372036854775807.0 +#define Min_Int_d -9223372036854775808.0 +#define val_precision 64 /* #define Max_Int INTPTR_MAX #define Min_Int INTPTR_MIN @@ -61,18 +61,20 @@ ssize_t max_fixed_int(ssize_t dummy); ssize_t min_fixed_int(ssize_t dummy); ssize_t precision(ssize_t dummy); -ssize_t __div_int32ub(ssize_t x, ssize_t y, uintptr_t exn); ssize_t __div_int31(ssize_t x, ssize_t y, uintptr_t exn); -size_t __div_word32ub(size_t x, size_t y, uintptr_t exn); -size_t __div_word31(size_t x, size_t y, uintptr_t exn); -ssize_t __mod_int32ub(ssize_t x, ssize_t y, uintptr_t exn); +ssize_t __div_int63(ssize_t x, ssize_t y, uintptr_t exn); ssize_t __mod_int31(ssize_t x, ssize_t y, uintptr_t exn); -size_t __mod_word32ub(size_t x, size_t y, uintptr_t exn); -size_t __mod_word31(size_t x, size_t y, uintptr_t exn); -ssize_t __quot_int32ub(ssize_t x, ssize_t y); +ssize_t __mod_int63(ssize_t x, ssize_t y, uintptr_t exn); ssize_t __quot_int31(ssize_t x, ssize_t y); -ssize_t __rem_int32ub(ssize_t x, ssize_t y); +ssize_t __quot_int63(ssize_t x, ssize_t y); ssize_t __rem_int31(ssize_t x, ssize_t y); +ssize_t __rem_int63(ssize_t x, ssize_t y); + +size_t __div_word31(size_t x, size_t y, uintptr_t exn); +size_t __div_word63(size_t x, size_t y, uintptr_t exn); +size_t __mod_word31(size_t x, size_t y, uintptr_t exn); +size_t __mod_word63(size_t x, size_t y, uintptr_t exn); + ssize_t realInt(ssize_t d, ssize_t x); ssize_t floorFloat(ssize_t f); ssize_t ceilFloat(ssize_t f); @@ -119,12 +121,37 @@ size_t sml_bytes_to_real(size_t d, String s); void printReal(size_t f); #ifdef TAG_VALUES + size_t* __div_int32b(size_t* b, size_t* x, size_t* y, uintptr_t exn); size_t* __div_word32b(size_t* b, size_t* x, size_t* y, uintptr_t exn); size_t* __mod_int32b(size_t* b, size_t* x, size_t* y, uintptr_t exn); size_t* __mod_word32b(size_t* b, size_t* x, size_t* y, uintptr_t exn); size_t* __quot_int32b(size_t* b, size_t* x, size_t* y); size_t* __rem_int32b(size_t* b, size_t* x, size_t* y); + +size_t* __div_int64b(size_t* b, size_t* x, size_t* y, uintptr_t exn); +size_t* __div_word64b(size_t* b, size_t* x, size_t* y, uintptr_t exn); +size_t* __mod_int64b(size_t* b, size_t* x, size_t* y, uintptr_t exn); +size_t* __mod_word64b(size_t* b, size_t* x, size_t* y, uintptr_t exn); +size_t* __quot_int64b(size_t* b, size_t* x, size_t* y); +size_t* __rem_int64b(size_t* b, size_t* x, size_t* y); + +#else + +ssize_t __div_int32ub(ssize_t x, ssize_t y, uintptr_t exn); +ssize_t __div_int64ub(ssize_t x, ssize_t y, uintptr_t exn); +ssize_t __mod_int32ub(ssize_t x, ssize_t y, uintptr_t exn); +ssize_t __mod_int64ub(ssize_t x, ssize_t y, uintptr_t exn); +ssize_t __quot_int32ub(ssize_t x, ssize_t y); +ssize_t __quot_int64ub(ssize_t x, ssize_t y); +ssize_t __rem_int32ub(ssize_t x, ssize_t y); +ssize_t __rem_int64ub(ssize_t x, ssize_t y); + +size_t __div_word32ub(size_t x, size_t y, uintptr_t exn); +size_t __div_word64ub(size_t x, size_t y, uintptr_t exn); +size_t __mod_word32ub(size_t x, size_t y, uintptr_t exn); +size_t __mod_word64ub(size_t x, size_t y, uintptr_t exn); + #endif #endif /*__MATH_H*/ diff --git a/src/Runtime/String.c b/src/Runtime/String.c index 902c31f43..80f1a8fcd 100644 --- a/src/Runtime/String.c +++ b/src/Runtime/String.c @@ -398,3 +398,12 @@ printNum(ssize_t n) */ return; } + +// for debugging */ +void +printLong(ssize_t n) +{ + printf("Long unsigned: %lu\n", convertIntToC((long int)n)); + printf("Long signed: %ld\n", convertIntToC((long int)n)); + return; +} diff --git a/src/Runtime/Tagging.h b/src/Runtime/Tagging.h index b7ea66ddb..6085f5eba 100644 --- a/src/Runtime/Tagging.h +++ b/src/Runtime/Tagging.h @@ -58,7 +58,8 @@ #define val_tag_exname (gen_record_tag(2,2,0,6)) #define val_tag_excon0 (gen_record_tag(1,0,0,6)) #define val_tag_excon1 (gen_record_tag(2,0,0,6)) -#define val_tag_i32b (gen_record_tag(1,1,0,6)) /*hmmm; mael 2001-04-23 */ +#define val_tag_i32b (gen_record_tag(1,1,0,6)) +#define val_tag_i64b (gen_record_tag(1,1,0,6)) #endif #define mlTRUE 3 @@ -76,12 +77,16 @@ #define i32ub_to_i31(i) (((i) << 1) + 1) #define i31_to_i32ub(i) ((i) >> 1) +#define i64ub_to_i63(i) (((i) << 1) + 1) +#define i63_to_i64ub(i) ((i) >> 1) #ifdef TAG_VALUES #define convertIntToC(i) ((i) >> 1) -#define convertIntToML(i) (signed int)(((unsigned int)(i) << 1) + 1) +#define convertIntToML(i) (signed long int)(((unsigned long int)(i) << 1) + 1) #define get_i32b(b) (* (((size_t *)b)+1)) #define set_i32b_tag(b) (* (size_t *)(b) = val_tag_i32b) +#define get_i64b(b) (* (((size_t *)b)+1)) +#define set_i64b_tag(b) (* (size_t *)(b) = val_tag_i64b) #else #define convertIntToC(i) (i) #define convertIntToML(i) (i) diff --git a/src/Runtime/Time.c b/src/Runtime/Time.c index 3a4e1c1c8..a7c0874da 100644 --- a/src/Runtime/Time.c +++ b/src/Runtime/Time.c @@ -14,18 +14,18 @@ #define tm2cal(tptr) mktime(tptr) -// FIXME -/* The following must agree with timebase in basislib/Time.sml */ -#ifdef TAG_VALUES -#define TIMEBASE (-1073741824) -#else -#define TIMEBASE (Min_Int) -#endif +/* The following must agree with timebase in basislib/Time.sml, + * which is assured by having basis/Initial.sml call "get_time_base". + * Now that we have at least 63 bits available, we can just use a + * timebase value of 0. + */ -uintptr_t +#define TIMEBASE 0 + +ssize_t get_time_base(int dummy) { - return convertIntToML((int)TIMEBASE); + return convertIntToML((long int)TIMEBASE); } uintptr_t diff --git a/test/Makefile b/test/Makefile index cd2303329..33ee8cbda 100644 --- a/test/Makefile +++ b/test/Makefile @@ -1,27 +1,43 @@ DATE=$(shell /bin/date -u '+%Y-%m-%dT-%H:%M:%S') +.PHONY: test +test: test_mlkit_no_gc + +.PHONY: all all: test_kam test_mlkit +.PHONY: test_mlkit test_mlkit: prepare (export SML_LIB=`(cd ..; pwd)`; ../bin/kittester ../bin/mlkit all.tst) /bin/mv test_report.html test_report-native-$(DATE).html +.PHONY: test_mlkit_no_gc test_mlkit_no_gc: prepare (export SML_LIB=`(cd ..; pwd)`; ../bin/kittester ../bin/mlkit all.tst -no_gc) /bin/mv test_report.html test_report-native-nogc-$(DATE).html +.PHONY: test_mlkit_gengc test_mlkit_gengc: prepare (export SML_LIB=`(cd ..; pwd)`; ../bin/kittester ../bin/mlkit all.tst -gengc) /bin/mv test_report.html test_report-native-gengc-$(DATE).html +.PHONY: test_mlkit_gengc_pickle test_mlkit_gengc_pickle: (export SML_LIB=`(cd ..; pwd)`; ../bin/kittester ../bin/mlkit pickle.tst -gengc) /bin/mv test_report.html test_report-native-gengc-$(DATE).html +.PHONY: test_kam test_kam: prepare (export SML_LIB=`(cd ..; pwd)`; ../bin/kittester ../bin/mlkit_kam all.tst) /bin/mv test_report.html test_report-kam-$(DATE).html +.PHONY: prepare +prepare: testlink hardlinkA hardlinkB + rm -f testcycl testbadl + ln -sf testcycl testcycl + ln -s exists.not testbadl + +.PHONY: clean clean: rm -f *.exe.x86-linux *.exe.out.txt *.exe.png *.exe run *~ */*~ *.exe.out.*.txt rm -f runexe *.log *.outgcp *.outgengcp *.out *.outgc *.outgengc *.outp profile.rp @@ -37,8 +53,3 @@ hardlinkA: hardlinkB: ln hardlinkA hardlinkB - -prepare: testlink hardlinkA hardlinkB - rm -f testcycl testbadl - ln -sf testcycl testcycl - ln -s exists.not testbadl diff --git a/test/all.tst b/test/all.tst index acbd0135d..132cbc4d0 100644 --- a/test/all.tst +++ b/test/all.tst @@ -110,6 +110,9 @@ int31.sml int31_2.sml int32.sml int32_2.sml +int63.sml +int63_2.sml +int64.sml intinf.sml intinf2.sml list.sml @@ -140,6 +143,7 @@ word.sml word8.sml word31.sml word32.sml +word64.sml pickletest.mlb packreal.sml packreal2.sml diff --git a/test/int.sml b/test/int.sml index fe9fe7f55..32e89d945 100644 --- a/test/int.sml +++ b/test/int.sml @@ -5,8 +5,8 @@ fun e1 seq e2 = e2; fun check b = if b then "OK" else "WRONG"; fun check' f = (if f () then "OK" else "WRONG") handle _ => "EXN"; -fun range (from, to) p = - let open Int +fun range (from, to) p = + let open Int in (from > to) orelse (p from) andalso (range (from+1, to) p) end; @@ -17,7 +17,7 @@ fun tst0 s s' = print (s ^ " \t" ^ s' ^ "\n"); fun tst s b = tst0 s (check b); fun tst' s f = tst0 s (check' f); -fun tstrange s bounds = (tst s) o range bounds +fun tstrange s bounds = (tst s) o range bounds (* test/int.sml -- here we test only the `exotic' operations @@ -29,12 +29,12 @@ use "auxil.sml"; val _ = print "\nFile int.sml: Testing structure Int...\n" -local +local open Int infix 7 quot rem fun divmod s (i, d, q, r) = tst s (i div d = q andalso i mod d = r); fun quotrem s (i, d, q, r) = tst s (i quot d = q andalso i rem d = r); -in +in val test1a = divmod "test1a" (10, 3, 3, 1); val test1b = divmod "test1b" (~10, 3, ~4, 2); @@ -50,25 +50,25 @@ val test3 = tst "test3" (max(~5, 2) = 2 andalso max(5, 2) = 5); val test4 = tst "test4" (min(~5, 3) = ~5 andalso min(5, 2) = 2); val test5 = tst "test5" (sign ~57 = ~1 andalso sign 99 = 1 andalso sign 0 = 0); -val test6 = tst "test6" (sameSign(~255, ~256) andalso sameSign(255, 256) +val test6 = tst "test6" (sameSign(~255, ~256) andalso sameSign(255, 256) andalso sameSign(0, 0)); -val test12 = +val test12 = tst0 "test12" (case (minInt, maxInt) of - (SOME mi, SOME ma) => check(sign mi = ~1 andalso sign ma = 1 + (SOME mi, SOME ma) => check(sign mi = ~1 andalso sign ma = 1 andalso sameSign(mi, ~1) andalso sameSign(ma, 1)) | (NONE, NONE) => "OK" | _ => "WRONG") -fun chk f (s, r) = - tst' "chk" (fn _ => +fun chk f (s, r) = + tst' "chk" (fn _ => case f s of SOME res => res = r | NONE => false) fun chkScan fmt = chk (StringCvt.scanString (scan fmt)) -val test13a = +val test13a = List.map (chk fromString) [("10789", 10789), ("+10789", 10789), @@ -85,12 +85,12 @@ val test13a = ("0wx123", 0), ("0wX123", 0)]; -val test13b = +val test13b = List.map (fn s => tst0 "test13b" (case fromString s of NONE => "OK" | _ => "WRONG")) - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", - "+ 1", "~ 1", "- 1", "ff"]; + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+ 1", "~ 1", "- 1", "ff"]; -val test14a = +val test14a = List.map (chkScan StringCvt.DEC) [("10789", 10789), ("+10789", 10789), @@ -107,13 +107,13 @@ val test14a = ("0wx123", 0), ("0wX123", 0)]; -val test14b = - List.map (fn s => tst0 "test14b" (case StringCvt.scanString (scan StringCvt.DEC) s +val test14b = + List.map (fn s => tst0 "test14b" (case StringCvt.scanString (scan StringCvt.DEC) s of NONE => "OK" | _ => "WRONG")) - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", - "+ 1", "~ 1", "- 1", "ff"]; + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+ 1", "~ 1", "- 1", "ff"]; -val test15a = +val test15a = List.map (chkScan StringCvt.BIN) [("10010", 18), ("+10010", 18), @@ -130,13 +130,13 @@ val test15a = ("0wx101", 0), ("0wX101", 0)]; -val test15b = - List.map (fn s => tst0 "test15b" (case StringCvt.scanString (scan StringCvt.BIN) s +val test15b = + List.map (fn s => tst0 "test15b" (case StringCvt.scanString (scan StringCvt.BIN) s of NONE => "OK" | _ => "WRONG")) - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", "+ 1", "~ 1", "- 1", "2", "8", "ff"]; -val test16a = +val test16a = List.map (chkScan StringCvt.OCT) [("2071", 1081), ("+2071", 1081), @@ -153,13 +153,13 @@ val test16a = ("0wx123", 0), ("0wX123", 0)]; -val test16b = - List.map (fn s => tst0 "test16b" (case StringCvt.scanString (scan StringCvt.OCT) s +val test16b = + List.map (fn s => tst0 "test16b" (case StringCvt.scanString (scan StringCvt.OCT) s of NONE => "OK" | _ => "WRONG")) - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", "+ 1", "~ 1", "- 1", "8", "ff"]; -val test17a = +val test17a = List.map (chkScan StringCvt.HEX) [("20Af", 8367), ("+20Af", 8367), @@ -187,34 +187,34 @@ val test17a = ("0wx123", 0), ("0wX123", 0)]; -val test17b = - List.map (fn s => tst0 "test17b" (case StringCvt.scanString (scan StringCvt.HEX) s +val test17b = + List.map (fn s => tst0 "test17b" (case StringCvt.scanString (scan StringCvt.HEX) s of NONE => "OK" | _ => "WRONG")) - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", "+ 1", "~ 1", "- 1"]; -local - fun fromToString i = +local + fun fromToString i = fromString (toString i) = SOME i; - fun scanFmt radix i = + fun scanFmt radix i = StringCvt.scanString (scan radix) (fmt radix i) = SOME i; in -val test18 = +val test18 = tst' "test18" (fn _ => range (~1200, 1200) fromToString); -val test19 = +val test19 = tst' "test19" (fn _ => range (~1200, 1200) (scanFmt StringCvt.BIN)); -val test20 = +val test20 = tst' "test20" (fn _ => range (~1200, 1200) (scanFmt StringCvt.OCT)); -val test21 = +val test21 = tst' "test21" (fn _ => range (~1200, 1200) (scanFmt StringCvt.DEC)); -val test22 = +val test22 = tst' "test22" (fn _ => range (~1200, 1200) (scanFmt StringCvt.HEX)); val test23a = tst' "test23a" (fn _ => scanFmt StringCvt.HEX (valOf Int.maxInt)); @@ -232,25 +232,25 @@ val test25b = tst' "test25b" (fn _ => scanFmt StringCvt.DEC (valOf Int.minInt + val test25c = tst' "test25c" (fn _ => scanFmt StringCvt.OCT (valOf Int.minInt + 10)); val test25d = tst' "test25d" (fn _ => scanFmt StringCvt.BIN (valOf Int.minInt + 10)); -fun chk' t f s = +fun chk' t f s = tst' t (fn _ => ((f s; false) handle Overflow => true)) fun chkScanOvf t fmt = chk' t (StringCvt.scanString (scan fmt)) -fun tag s1 s2 = if Int.precision = SOME 31 then s1 else s2 -val test26a = chkScanOvf "test26a" StringCvt.HEX (tag "~40000001" "~80000001") -val test26b = chkScanOvf "test26b" StringCvt.DEC (tag "~1073741825" "~2147483649") -val test26c = chkScanOvf "test26c" StringCvt.OCT (tag "~10000000001" "~20000000001") -val test26d = chkScanOvf "test26d" StringCvt.BIN (tag "~1000000000000000000000000000001" "~10000000000000000000000000000001") - -val test27a = chkScanOvf "test27a" StringCvt.HEX (tag "40000000" "80000000") -val test27b = chkScanOvf "test27b" StringCvt.DEC (tag "1073741824" "2147483648") -val test27c = chkScanOvf "test27c" StringCvt.OCT (tag "10000000000" "20000000000") -val test27d = chkScanOvf "test27d" StringCvt.BIN (tag "1000000000000000000000000000000" "10000000000000000000000000000000") - -val test28a = tst' "test28a" (fn () => toString (valOf maxInt) = tag "1073741823" "2147483647") -val test28b = tst' "test28b" (fn () => toString (valOf minInt) = tag "~1073741824" "~2147483648") - -val test29a = tst' "test29a" (fn () => fromString (tag "1073741823" "2147483647") = maxInt) -val test29b = tst' "test29b" (fn () => fromString (tag "~1073741824" "~2147483648") = minInt) +fun tag s1 s2 = if Int.precision = SOME 63 then s1 else s2 +val test26a = chkScanOvf "test26a" StringCvt.HEX (tag "~4000000000000001" "~8000000000000001") +val test26b = chkScanOvf "test26b" StringCvt.DEC (tag "~4611686018427387905" "~9223372036854775809") +val test26c = chkScanOvf "test26c" StringCvt.OCT (tag "~400000000000000000001" "~1000000000000000000001") +val test26d = chkScanOvf "test26d" StringCvt.BIN (tag "~100000000000000000000000000000000000000000000000000000000000001" "~1000000000000000000000000000000000000000000000000000000000000001") + +val test27a = chkScanOvf "test27a" StringCvt.HEX (tag "4000000000000000" "8000000000000000") +val test27b = chkScanOvf "test27b" StringCvt.DEC (tag "4611686018427387904" "9223372036854775808") +val test27c = chkScanOvf "test27c" StringCvt.OCT (tag "400000000000000000000" "1000000000000000000000") +val test27d = chkScanOvf "test27d" StringCvt.BIN (tag "100000000000000000000000000000000000000000000000000000000000000" "1000000000000000000000000000000000000000000000000000000000000000") + +val test28a = tst' "test28a" (fn () => toString (valOf maxInt) = tag "4611686018427387903" "9223372036854775807") +val test28b = tst' "test28b" (fn () => toString (valOf minInt) = tag "~4611686018427387904" "~9223372036854775808") + +val test29a = tst' "test29a" (fn () => fromString (tag "4611686018427387903" "9223372036854775807") = maxInt) +val test29b = tst' "test29b" (fn () => fromString (tag "~4611686018427387904" "~9223372036854775808") = minInt) end diff --git a/test/int31_2.sml b/test/int31_2.sml index 8575d92d4..491dc17bb 100644 --- a/test/int31_2.sml +++ b/test/int31_2.sml @@ -39,8 +39,8 @@ val test11 = test "test11" ((prod (minint,~1) seq "WRONG") handle Overflow => "O fun checkDivMod i d = let val q = i div d val r = i mod d - in -(* printVal i seq TextIO.output(TextIO.stdOut, " "); + in +(* printVal i seq TextIO.output(TextIO.stdOut, " "); printVal d seq TextIO.output(TextIO.stdOut, " "); *) if (d * q + r = i) andalso ((0 <= r andalso r < d) orelse (d < r andalso r <= 0)) @@ -105,4 +105,4 @@ val test51 = test'' "test51" (fn _ => valOf maxInt + ~3 = 1073741820) val test52 = test'' "test52" (fn _ => ~1073741821 - 3 = valOf minInt) val test53 = test'' "test53" (fn _ => valOf minInt + 3 = ~1073741821) -end \ No newline at end of file +end diff --git a/test/int32_2.sml b/test/int32_2.sml index 261941b92..87f9e58e3 100644 --- a/test/int32_2.sml +++ b/test/int32_2.sml @@ -1,7 +1,7 @@ (* This test works only for 32-bit implementations! *) -local +local open Int32 in val maxint : int32 = 2147483647 @@ -44,8 +44,8 @@ val test11 = test "test11" ((prod (minint,~1) seq "WRONG") handle Overflow => "O fun checkDivMod i d = let val q = i div d val r = i mod d - in -(* printVal i seq TextIO.output(TextIO.stdOut, " "); + in +(* printVal i seq TextIO.output(TextIO.stdOut, " "); printVal d seq TextIO.output(TextIO.stdOut, " "); *) if (d * q + r = i) andalso ((0 <= r andalso r < d) orelse (d < r andalso r <= 0)) @@ -73,20 +73,17 @@ val test26 = test "test26" ((minint div ~1 seq "WRONG") handle Overflow => "OK" (* toInt *) -fun iftag yes no = - if Int.precision = SOME 31 then yes else no - -val test27 = test "test27" ((toInt maxint seq (iftag "WRONG" "OK")) - handle Overflow => iftag "OK" "WRONG") -val test27a = test "test27a" ((toInt (maxint-10) seq (iftag "WRONG" "OK")) - handle Overflow => iftag "OK" "WRONG") -val test28 = test "test28" ((toInt minint seq (iftag "WRONG" "OK")) - handle Overflow => iftag "OK" "WRONG") -val test28a = test "test28a" ((toInt (minint+10) seq (iftag "WRONG" "OK")) - handle Overflow => iftag "OK" "WRONG") -val test29 = test "test29" ((check (SOME(toInt (maxint div 2)) = Option.map Int31.toInt Int31.maxInt)) +val test27 = test "test27" ((toInt maxint seq "OK") + handle Overflow => "WRONG") +val test27a = test "test27a" ((toInt (maxint-10) seq "OK") + handle Overflow => "WRONG") +val test28 = test "test28" ((toInt minint seq "OK") + handle Overflow => "WRONG") +val test28a = test "test28a" ((toInt (minint+10) seq "OK") + handle Overflow => "WRONG") +val test29 = test "test29" ((check (SOME(toInt (maxint div 2)) = Option.map Int31.toInt Int31.maxInt)) handle Overflow => "EXN") -val test29a = test "test29a" ((check (SOME(toInt (minint div 2)) = Option.map Int31.toInt Int31.minInt)) +val test29a = test "test29a" ((check (SOME(toInt (minint div 2)) = Option.map Int31.toInt Int31.minInt)) handle Overflow => "EXN") -end \ No newline at end of file +end diff --git a/test/int63.sml b/test/int63.sml new file mode 100644 index 000000000..8f2a56118 --- /dev/null +++ b/test/int63.sml @@ -0,0 +1,253 @@ +(* Auxiliary functions for test cases *) + +infix 1 seq +fun e1 seq e2 = e2; +fun check b = if b then "OK" else "WRONG"; +fun check' f = (if f () then "OK" else "WRONG") handle _ => "EXN"; + +fun range (from, to) p = + let open Int63 + in + (from > to) orelse (p from) andalso (range (from+1, to) p) + end; + +fun checkrange bounds = check o range bounds; + +fun tst0 s s' = print (s ^ " \t" ^ s' ^ "\n"); +fun tst s b = tst0 s (check b); +fun tst' s f = tst0 s (check' f); + +fun tstrange s bounds = (tst s) o range bounds + + +(* test/int.sml -- here we test only the `exotic' operations + PS 1995-02-25, 1996-07-02 *) + +val _ = print "\nFile int63.sml: Testing structure Int63...\n" + +local + open Int63 + infix 7 quot rem + fun divmod s (i, d, q, r) = tst s (i div d = q andalso i mod d = r); + fun quotrem s (i, d, q, r) = tst s (i quot d = q andalso i rem d = r); +in + +val test1a = divmod "test1a" (10, 3, 3, 1); +val test1b = divmod "test1b" (~10, 3, ~4, 2); +val test1c = divmod "test1c" (~10, ~3, 3, ~1); +val test1d = divmod "test1d" (10, ~3, ~4, ~2); + +val test2a = quotrem "test2a" (10, 3, 3, 1); +val test2b = quotrem "test2b" (~10, 3, ~3, ~1); +val test2c = quotrem "test2c" (~10, ~3, 3, ~1); +val test2d = quotrem "test2d" (10, ~3, ~3, 1); + +val test3 = tst "test3" (max(~5, 2) = 2 andalso max(5, 2) = 5); +val test4 = tst "test4" (min(~5, 3) = ~5 andalso min(5, 2) = 2); + +val test5 = tst "test5" (sign ~57 = ~1 andalso sign 99 = 1 andalso sign 0 = 0); +val test6 = tst "test6" (sameSign(~255, ~256) andalso sameSign(255, 256) + andalso sameSign(0, 0)); + +val test12 = + tst0 "test12" (case (minInt, maxInt) of + (SOME mi, SOME ma) => check(sign mi = ~1 andalso sign ma = 1 + andalso sameSign(mi, ~1) andalso sameSign(ma, 1)) + | (NONE, NONE) => "OK" + | _ => "WRONG") + +fun chk f (s, r) = + tst' "chk" (fn _ => + case f s of + SOME res => res = r + | NONE => false) + +fun chkScan fmt = chk (StringCvt.scanString (scan fmt)) + +val test13a = + List.map (chk fromString) + [("10789", 10789), + ("+10789", 10789), + ("~10789", ~10789), + ("-10789", ~10789), + (" \n\t10789crap", 10789), + (" \n\t+10789crap", 10789), + (" \n\t~10789crap", ~10789), + (" \n\t-10789crap", ~10789), + ("0w123", 0), + ("0W123", 0), + ("0x123", 0), + ("0X123", 0), + ("0wx123", 0), + ("0wX123", 0)]; + +val test13b = + List.map (fn s => tst0 "test13b" (case fromString s of NONE => "OK" | _ => "WRONG")) + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+ 1", "~ 1", "- 1", "ff"]; + +val test14a = + List.map (chkScan StringCvt.DEC) + [("10789", 10789), + ("+10789", 10789), + ("~10789", ~10789), + ("-10789", ~10789), + (" \n\t10789crap", 10789), + (" \n\t+10789crap", 10789), + (" \n\t~10789crap", ~10789), + (" \n\t-10789crap", ~10789), + ("0w123", 0), + ("0W123", 0), + ("0x123", 0), + ("0X123", 0), + ("0wx123", 0), + ("0wX123", 0)]; + +val test14b = + List.map (fn s => tst0 "test14b" (case StringCvt.scanString (scan StringCvt.DEC) s + of NONE => "OK" | _ => "WRONG")) + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+ 1", "~ 1", "- 1", "ff"]; + +val test15a = + List.map (chkScan StringCvt.BIN) + [("10010", 18), + ("+10010", 18), + ("~10010", ~18), + ("-10010", ~18), + (" \n\t10010crap", 18), + (" \n\t+10010crap", 18), + (" \n\t~10010crap", ~18), + (" \n\t-10010crap", ~18), + ("0w101", 0), + ("0W101", 0), + ("0x101", 0), + ("0X101", 0), + ("0wx101", 0), + ("0wX101", 0)]; + +val test15b = + List.map (fn s => tst0 "test15b" (case StringCvt.scanString (scan StringCvt.BIN) s + of NONE => "OK" | _ => "WRONG")) + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+ 1", "~ 1", "- 1", "2", "8", "ff"]; + +val test16a = + List.map (chkScan StringCvt.OCT) + [("2071", 1081), + ("+2071", 1081), + ("~2071", ~1081), + ("-2071", ~1081), + (" \n\t2071crap", 1081), + (" \n\t+2071crap", 1081), + (" \n\t~2071crap", ~1081), + (" \n\t-2071crap", ~1081), + ("0w123", 0), + ("0W123", 0), + ("0x123", 0), + ("0X123", 0), + ("0wx123", 0), + ("0wX123", 0)]; + +val test16b = + List.map (fn s => tst0 "test16b" (case StringCvt.scanString (scan StringCvt.OCT) s + of NONE => "OK" | _ => "WRONG")) + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+ 1", "~ 1", "- 1", "8", "ff"]; + +val test17a = + List.map (chkScan StringCvt.HEX) + [("20Af", 8367), + ("+20Af", 8367), + ("~20Af", ~8367), + ("-20Af", ~8367), + (" \n\t20AfGrap", 8367), + (" \n\t+20AfGrap", 8367), + (" \n\t~20AfGrap", ~8367), + (" \n\t-20AfGrap", ~8367), + ("0w123", 0), + ("0W123", 0), + ("0x", 0), + ("0x ", 0), + ("0xG", 0), + ("0X", 0), + ("0XG", 0), + ("0x123", 291), + ("0X123", 291), + ("-0x123", ~291), + ("-0X123", ~291), + ("~0x123", ~291), + ("~0X123", ~291), + ("+0x123", 291), + ("+0X123", 291), + ("0wx123", 0), + ("0wX123", 0)]; + +val test17b = + List.map (fn s => tst0 "test17b" (case StringCvt.scanString (scan StringCvt.HEX) s + of NONE => "OK" | _ => "WRONG")) + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+ 1", "~ 1", "- 1"]; + + +local + fun fromToString i = + fromString (toString i) = SOME i; + + fun scanFmt radix i = + StringCvt.scanString (scan radix) (fmt radix i) = SOME i; + +in +val test18 = + tst' "test18" (fn _ => range (~1200, 1200) fromToString); + +val test19 = + tst' "test19" (fn _ => range (~1200, 1200) (scanFmt StringCvt.BIN)); + +val test20 = + tst' "test20" (fn _ => range (~1200, 1200) (scanFmt StringCvt.OCT)); + +val test21 = + tst' "test21" (fn _ => range (~1200, 1200) (scanFmt StringCvt.DEC)); + +val test22 = + tst' "test22" (fn _ => range (~1200, 1200) (scanFmt StringCvt.HEX)); + +val test23a = tst' "test23a" (fn _ => scanFmt StringCvt.HEX (valOf Int63.maxInt)); +val test23b = tst' "test23b" (fn _ => scanFmt StringCvt.DEC (valOf Int63.maxInt)); +val test23c = tst' "test23c" (fn _ => scanFmt StringCvt.OCT (valOf Int63.maxInt)); +val test23d = tst' "test23d" (fn _ => scanFmt StringCvt.BIN (valOf Int63.maxInt)); + +val test24a = tst' "test24a" (fn _ => scanFmt StringCvt.HEX (valOf Int63.minInt)); +val test24b = tst' "test24b" (fn _ => scanFmt StringCvt.DEC (valOf Int63.minInt)); +val test24c = tst' "test24c" (fn _ => scanFmt StringCvt.OCT (valOf Int63.minInt)); +val test24d = tst' "test24d" (fn _ => scanFmt StringCvt.BIN (valOf Int63.minInt)); + +val test25a = tst' "test25a" (fn _ => scanFmt StringCvt.HEX (valOf Int63.minInt + 10)); +val test25b = tst' "test25b" (fn _ => scanFmt StringCvt.DEC (valOf Int63.minInt + 10)); +val test25c = tst' "test25c" (fn _ => scanFmt StringCvt.OCT (valOf Int63.minInt + 10)); +val test25d = tst' "test25d" (fn _ => scanFmt StringCvt.BIN (valOf Int63.minInt + 10)); + +fun chk' t f s = + tst' t (fn _ => ((f s; false) handle Overflow => true)) +fun chkScanOvf t fmt = chk' t (StringCvt.scanString (scan fmt)) + +val test26a = chkScanOvf "test26a" StringCvt.HEX "~4000000000000001" +val test26b = chkScanOvf "test26b" StringCvt.DEC "~4611686018427387905" +val test26c = chkScanOvf "test26c" StringCvt.OCT "~400000000000000000001" +val test26d = chkScanOvf "test26d" StringCvt.BIN "~100000000000000000000000000000000000000000000000000000000000001" + +val test27a = chkScanOvf "test27a" StringCvt.HEX "4000000000000000" +val test27b = chkScanOvf "test27b" StringCvt.DEC "4611686018427387904" +val test27c = chkScanOvf "test27c" StringCvt.OCT "400000000000000000000" +val test27d = chkScanOvf "test27d" StringCvt.BIN "100000000000000000000000000000000000000000000000000000000000000" + +val test28a = tst' "test28a" (fn () => toString (valOf maxInt) = "4611686018427387903") +val test28b = tst' "test28b" (fn () => toString (valOf minInt) = "~4611686018427387904") + +val test29a = tst' "test29a" (fn () => fromString "4611686018427387903" = maxInt) +val test29b = tst' "test29b" (fn () => fromString "~4611686018427387904" = minInt) + +end + +end diff --git a/test/int63.sml.out.ok b/test/int63.sml.out.ok new file mode 100644 index 000000000..22d4194b3 --- /dev/null +++ b/test/int63.sml.out.ok @@ -0,0 +1,187 @@ + +File int63.sml: Testing structure Int63... +test1a OK +test1b OK +test1c OK +test1d OK +test2a OK +test2b OK +test2c OK +test2d OK +test3 OK +test4 OK +test5 OK +test6 OK +test12 OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +test13b OK +test13b OK +test13b OK +test13b OK +test13b OK +test13b OK +test13b OK +test13b OK +test13b OK +test13b OK +test13b OK +test13b OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +test14b OK +test14b OK +test14b OK +test14b OK +test14b OK +test14b OK +test14b OK +test14b OK +test14b OK +test14b OK +test14b OK +test14b OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +test17b OK +test17b OK +test17b OK +test17b OK +test17b OK +test17b OK +test17b OK +test17b OK +test17b OK +test17b OK +test17b OK +test18 OK +test19 OK +test20 OK +test21 OK +test22 OK +test23a OK +test23b OK +test23c OK +test23d OK +test24a OK +test24b OK +test24c OK +test24d OK +test25a OK +test25b OK +test25c OK +test25d OK +test26a OK +test26b OK +test26c OK +test26d OK +test27a OK +test27b OK +test27c OK +test27d OK +test28a OK +test28b OK +test29a OK +test29b OK diff --git a/test/int63_2.sml b/test/int63_2.sml new file mode 100644 index 000000000..7fc5e50a8 --- /dev/null +++ b/test/int63_2.sml @@ -0,0 +1,111 @@ +(* This test works only for 64/63-bit implementations! *) + +local fun pow2 n : int63 = if n < 1 then 1 else 2 * pow2(n-1) +in val maxint : int63 = pow2 61 + (pow2 61 - 1) + val minint : int63 = ~maxint - 1 +end + +local open Int63 +in +val real = fn i => real (toInt i) +val floor = fn r => fromInt(floor r) +infix seq +fun e1 seq e2 = e2; +fun test t s = print (t ^ ": " ^ s ^ "\n") +fun check true = "OK" + | check false = "ERR" +fun test' t b = test t (check b) +fun test'' t f = test t ((check (f())) handle _ => "EXN") + +val test1 = test "test1" ((~minint seq "WRONG") handle Overflow => "OK") + +val test2 = test "test2" ((abs minint seq "WRONG") handle Overflow => "OK") +val test3 = test "test3" ((maxint+1 seq "WRONG") handle Overflow => "OK") +val test4 = test "test4" ((minint-1 seq "WRONG") handle Overflow => "OK") + +val test5 = test "test5" (if maxint = 0x3fffffffffffffff then "OK" else "WRONG") +val test6 = test "test6" (if maxint = 0x3FFFFFFFFFFFFFFF then "OK" else "WRONG") +val test7 = test "test7" (if minint = ~0x4000000000000000 then "OK" else "WRONG") + +val sum = (op+) : int * int -> int +val diff = (op-) : int * int -> int + +val test8 = test "test8" ((sum (maxint,1) seq "WRONG") handle Overflow => "OK") +val test9 = test "test9" ((diff (minint,1) seq "WRONG") handle Overflow => "OK") + +val test10 = test "test10" ((minint * ~1 seq "WRONG") handle Overflow => "OK") + +val prod = (op * ) : int * int -> int + +val test11 = test "test11" ((prod (minint,~1) seq "WRONG") handle Overflow => "OK") + +fun checkDivMod i d = + let val q = i div d + val r = i mod d + in +(* printVal i seq TextIO.output(TextIO.stdOut, " "); + printVal d seq TextIO.output(TextIO.stdOut, " "); *) + if (d * q + r = i) andalso + ((0 <= r andalso r < d) orelse (d < r andalso r <= 0)) + then "OK" else "WRONG: problems with div, mod" + end; + +val test12 = test "test12" (checkDivMod 23 10) +val test13 = test "test13" (checkDivMod ~23 10) +val test14 = test "test14" (checkDivMod 23 ~10) +val test15 = test "test15" (checkDivMod ~23 ~10) + +val test16 = test "test16" (checkDivMod 100 10) +val test17 = test "test17" (checkDivMod ~100 10) +val test18 = test "test18" (checkDivMod 100 ~10) +val test19 = test "test19" (checkDivMod ~100 ~10) + +val test20 = test "test20" (checkDivMod 100 1) +val test21 = test "test21" (checkDivMod 100 ~1) +val test22 = test "test22" (checkDivMod 0 1) +val test23 = test "test23" (checkDivMod 0 ~1) + +val test24 = test "test24" ((100 div 0 seq "WRONG") handle Div => "OK") +val test25 = test "test25" ((100 mod 0 seq "WRONG") handle Div => "OK") +val test26 = test "test26" ((minint div ~1 seq "WRONG") handle Overflow => "OK") + +val maxri = real maxint +val minri = real minint + +val test27 = test "test27" (if floor 3.0 = 3 then "OK" else "WRONG") +val test28 = test "test28" (if floor 3.14 = 3 then "OK" else "WRONG") +val test29 = test "test29" (if floor ~3.0 = ~3 then "OK" else "WRONG") +val test30 = test "test30" (if floor ~3.14 = ~4 then "OK" else "WRONG") +(*val test31 = test "test31" (if floor(Real.+(maxri, 0.9)) = maxint then "OK" else "WRONG")*) +val test32 = test "test32" (if floor minri = minint then "OK" else "WRONG") +val test33 = test "test33" ((floor (Real.-(minri, 1000.1)) seq "WRONG") handle Overflow => "OK") +val test34 = test "test34" ((floor (Real.+(maxri, 1.0)) seq "WRONG") handle Overflow => "OK") + +val test35 = test' "test35" (toLarge ~1 = ~1) +val test36 = test' "test36" (toLarge 1 = 1) +val test37 = test' "test37" (toLarge 0 = 0) +val test38 = test' "test38" (toLarge maxint = 4611686018427387903) +val test39 = test' "test39" (toLarge minint = ~4611686018427387904) + +val test40 = test'' "test40" (fn _ => fromLarge(toLarge ~1) = ~1) +val test41 = test'' "test41" (fn _ => fromLarge(toLarge maxint) = maxint) +val test42 = test'' "test42" (fn _ => fromLarge(toLarge 0) = 0) +val test42 = test'' "test42" (fn _ => fromLarge(toLarge minint) = minint) + +val test43 = test "test43" ((fromLarge(Int64.toLarge(Int64.+(Int64.fromLarge(toLarge maxint), 1))) seq "WRONG") handle Overflow => "OK") +val test44 = test "test44" ((fromLarge(Int64.toLarge(Int64.-(Int64.fromLarge(toLarge minint), 1))) seq "WRONG") handle Overflow => "OK") +val test45 = test "test45" ((fromLarge(Int64.toLarge(valOf Int64.maxInt)) seq "WRONG") handle Overflow => "OK") +val test46 = test "test46" ((fromLarge(Int64.toLarge(valOf Int64.minInt)) seq "WRONG") handle Overflow => "OK") + +val test47a = test'' "test47a" (fn _ => valOf (fromString "1") * valOf minInt = valOf minInt) +val test47b = test'' "test47b" (fn _ => valOf minInt * valOf (fromString "1") = valOf minInt) +val test48 = test'' "test48" (fn _ => 4611686018427387900 + 3 = valOf maxInt) +val test49 = test'' "test49" (fn _ => valOf maxInt - 3 = 4611686018427387900) + +val test50 = test'' "test50" (fn _ => 4611686018427387900 - ~3 = valOf maxInt) +val test51 = test'' "test51" (fn _ => valOf maxInt + ~3 = 4611686018427387900) + +val test52 = test'' "test52" (fn _ => ~4611686018427387901 - 3 = valOf minInt) +val test53 = test'' "test53" (fn _ => valOf minInt + 3 = ~4611686018427387901) + +end diff --git a/test/int63_2.sml.out.ok b/test/int63_2.sml.out.ok new file mode 100644 index 000000000..e9a30182c --- /dev/null +++ b/test/int63_2.sml.out.ok @@ -0,0 +1,54 @@ +test1: OK +test2: OK +test3: OK +test4: OK +test5: OK +test6: OK +test7: OK +test8: OK +test9: OK +test10: OK +test11: OK +test12: OK +test13: OK +test14: OK +test15: OK +test16: OK +test17: OK +test18: OK +test19: OK +test20: OK +test21: OK +test22: OK +test23: OK +test24: OK +test25: OK +test26: OK +test27: OK +test28: OK +test29: OK +test30: OK +test32: OK +test33: OK +test34: OK +test35: OK +test36: OK +test37: OK +test38: OK +test39: OK +test40: OK +test41: OK +test42: OK +test42: OK +test43: OK +test44: OK +test45: OK +test46: OK +test47a: OK +test47b: OK +test48: OK +test49: OK +test50: OK +test51: OK +test52: OK +test53: OK diff --git a/test/int64.sml b/test/int64.sml new file mode 100644 index 000000000..859735c1c --- /dev/null +++ b/test/int64.sml @@ -0,0 +1,276 @@ +(* Auxiliary functions for test cases *) + +infix 1 seq +fun e1 seq e2 = e2 +fun check b = if b then "OK" else "WRONG" +fun check' f = (if f () then "OK" else "WRONG") handle _ => "EXN" + +fun range (from, to) p = + let open Int64 + in + (from > to) orelse (p from) andalso (range (from+1, to) p) + end + +fun checkrange bounds = check o range bounds + +fun tst0 s s' = print (s ^ " \t" ^ s' ^ "\n") +fun tst s b = tst0 s (check b) +fun tst' s f = tst0 s (check' f) + +fun tstrange s bounds = (tst s) o range bounds + +(* test/int.sml -- here we test only the `exotic' operations + PS 1995-02-25, 1996-07-02 *) + +val _ = print "\nFile int64.sml: Testing structure Int64...\n" + +local + open Int64 + infix 7 quot rem + fun divmod s (i, d, q, r) = tst s (i div d = q andalso i mod d = r); + fun quotrem s (i, d, q, r) = tst s (i quot d = q andalso i rem d = r); +in + +val test0a = tst "test0a" (toInt (34:int) = (34:Int.int)) +val test0b = tst "test0b" (toInt (12:int) = (12:Int.int)) +val test0c = tst "test0c" (toInt (~12:int) = (~12:Int.int)) +val test0d = tst "test0d" (fromInt (~12:Int.int) = (~12:int)) +val test0e = tst "test0e" (fromInt (~12:Int.int) <> (~3:int)) +val test0f = tst "test0f" ((~12:int) = (~ 12:int)) +val test0g = tst "test0g" ((~24:int) = (~ 12 * 2:int)) +val test0h = tst "test0h" (abs(~24:int) = (24:int)) +val test0i = tst "test0i" (abs(12:int) = (12:int)) +val test0j = tst "test0j" (~(12:int) = (~12:int)) +val test0k = tst "test0k" (~(~14:int) = (14:int)) +val test0l = tst "test0l" (abs(~12:int) <> (~12:int)) +val test0m0 = tst "test0m0" ((~12:int) < (12:int)) +val test0m1 = tst "test0m1" ((~12:int) <= (12:int)) +val test0m2 = tst "test0m2" ((13:int) > (4:int)) +val test0m3 = tst "test0m3" ((13:int) >= (12:int)) +val test0n0 = tst "test0n0" ((~12:int) + 25 = (13:int)) +val test0n1 = tst "test0n1" ((~12:int) - 13 = (~25:int)) +val test0n2 = tst "test0n2" ((1222:int) * 10 = (12220:int)) + +val test0p0 = tst "test0p0" (case 34:Int64.int of 34 => true | _ => false) +val test0p1 = tst "test0p1" (case 34:Int64.int of 32 => false | _ => true) +val test0p2 = tst "test0p2" (case ~34:Int64.int of ~34 => true | _ => false) + +val test1a = divmod "test1a" (10, 3, 3, 1); +val test1b = divmod "test1b" (~10, 3, ~4, 2); +val test1c = divmod "test1c" (~10, ~3, 3, ~1); +val test1d = divmod "test1d" (10, ~3, ~4, ~2); + +val test2a = quotrem "test2a" (10, 3, 3, 1); +val test2b = quotrem "test2b" (~10, 3, ~3, ~1); +val test2c = quotrem "test2c" (~10, ~3, 3, ~1); +val test2d = quotrem "test2d" (10, ~3, ~3, 1); + +val test3 = tst "test3" (max(~5, 2) = 2 andalso max(5, 2) = 5); +val test4 = tst "test4" (min(~5, 3) = ~5 andalso min(5, 2) = 2); + +val test5 = tst "test5" (sign ~57 = ~1 andalso sign 99 = 1 andalso sign 0 = 0); +val test6 = tst "test6" (sameSign(~255, ~256) andalso sameSign(255, 256) + andalso sameSign(0, 0)); + +val test12 = + tst0 "test12" (case (minInt, maxInt) of + (SOME mi, SOME ma) => check(sign mi = ~1 andalso sign ma = 1 + andalso sameSign(mi, ~1) andalso sameSign(ma, 1)) + | (NONE, NONE) => "OK" + | _ => "WRONG") + +fun chk f (s, r) = + tst' "chk" (fn _ => + case f s of + SOME res => res = r + | NONE => false) + +fun chkScan fmt = chk (StringCvt.scanString (scan fmt)) + +val test13a = + List.map (chk fromString) + [("10789", 10789), + ("+10789", 10789), + ("~10789", ~10789), + ("-10789", ~10789), + (" \n\t10789crap", 10789), + (" \n\t+10789crap", 10789), + (" \n\t~10789crap", ~10789), + (" \n\t-10789crap", ~10789), + ("0w123", 0), + ("0W123", 0), + ("0x123", 0), + ("0X123", 0), + ("0wx123", 0), + ("0wX123", 0)]; + +val test13b = + List.map (fn s => tst0 "test13b" (case fromString s of NONE => "OK" | _ => "WRONG")) + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+ 1", "~ 1", "- 1", "ff"]; + +val test14a = + List.map (chkScan StringCvt.DEC) + [("10789", 10789), + ("+10789", 10789), + ("~10789", ~10789), + ("-10789", ~10789), + (" \n\t10789crap", 10789), + (" \n\t+10789crap", 10789), + (" \n\t~10789crap", ~10789), + (" \n\t-10789crap", ~10789), + ("0w123", 0), + ("0W123", 0), + ("0x123", 0), + ("0X123", 0), + ("0wx123", 0), + ("0wX123", 0)]; + +val test14b = + List.map (fn s => tst0 "test14b" (case StringCvt.scanString (scan StringCvt.DEC) s + of NONE => "OK" | _ => "WRONG")) + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+ 1", "~ 1", "- 1", "ff"]; + +val test15a = + List.map (chkScan StringCvt.BIN) + [("10010", 18), + ("+10010", 18), + ("~10010", ~18), + ("-10010", ~18), + (" \n\t10010crap", 18), + (" \n\t+10010crap", 18), + (" \n\t~10010crap", ~18), + (" \n\t-10010crap", ~18), + ("0w101", 0), + ("0W101", 0), + ("0x101", 0), + ("0X101", 0), + ("0wx101", 0), + ("0wX101", 0)]; + +val test15b = + List.map (fn s => tst0 "test15b" (case StringCvt.scanString (scan StringCvt.BIN) s + of NONE => "OK" | _ => "WRONG")) + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+ 1", "~ 1", "- 1", "2", "8", "ff"]; + +val test16a = + List.map (chkScan StringCvt.OCT) + [("2071", 1081), + ("+2071", 1081), + ("~2071", ~1081), + ("-2071", ~1081), + (" \n\t2071crap", 1081), + (" \n\t+2071crap", 1081), + (" \n\t~2071crap", ~1081), + (" \n\t-2071crap", ~1081), + ("0w123", 0), + ("0W123", 0), + ("0x123", 0), + ("0X123", 0), + ("0wx123", 0), + ("0wX123", 0)]; + +val test16b = + List.map (fn s => tst0 "test16b" (case StringCvt.scanString (scan StringCvt.OCT) s + of NONE => "OK" | _ => "WRONG")) + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+ 1", "~ 1", "- 1", "8", "ff"]; + +val test17a = + List.map (chkScan StringCvt.HEX) + [("20Af", 8367), + ("+20Af", 8367), + ("~20Af", ~8367), + ("-20Af", ~8367), + (" \n\t20AfGrap", 8367), + (" \n\t+20AfGrap", 8367), + (" \n\t~20AfGrap", ~8367), + (" \n\t-20AfGrap", ~8367), + ("0w123", 0), + ("0W123", 0), + ("0x", 0), + ("0x ", 0), + ("0xG", 0), + ("0X", 0), + ("0XG", 0), + ("0x123", 291), + ("0X123", 291), + ("-0x123", ~291), + ("-0X123", ~291), + ("~0x123", ~291), + ("~0X123", ~291), + ("+0x123", 291), + ("+0X123", 291), + ("0wx123", 0), + ("0wX123", 0)]; + +val test17b = + List.map (fn s => tst0 "test17b" (case StringCvt.scanString (scan StringCvt.HEX) s + of NONE => "OK" | _ => "WRONG")) + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+ 1", "~ 1", "- 1"]; + + +local + fun fromToString i = + fromString (toString i) = SOME i; + + fun scanFmt radix i = + StringCvt.scanString (scan radix) (fmt radix i) = SOME i; + +in +val test18 = + tst' "test18" (fn _ => range (~1200, 1200) fromToString); + +val test19 = + tst' "test19" (fn _ => range (~1200, 1200) (scanFmt StringCvt.BIN)); + +val test20 = + tst' "test20" (fn _ => range (~1200, 1200) (scanFmt StringCvt.OCT)); + +val test21 = + tst' "test21" (fn _ => range (~1200, 1200) (scanFmt StringCvt.DEC)); + +val test22 = + tst' "test22" (fn _ => range (~1200, 1200) (scanFmt StringCvt.HEX)); + +val test23a = tst' "test23a" (fn _ => scanFmt StringCvt.HEX (valOf Int64.maxInt)); +val test23b = tst' "test23b" (fn _ => scanFmt StringCvt.DEC (valOf Int64.maxInt)); +val test23c = tst' "test23c" (fn _ => scanFmt StringCvt.OCT (valOf Int64.maxInt)); +val test23d = tst' "test23d" (fn _ => scanFmt StringCvt.BIN (valOf Int64.maxInt)); + +val test24a = tst' "test24a" (fn _ => scanFmt StringCvt.HEX (valOf Int64.minInt)); +val test24b = tst' "test24b" (fn _ => scanFmt StringCvt.DEC (valOf Int64.minInt)); +val test24c = tst' "test24c" (fn _ => scanFmt StringCvt.OCT (valOf Int64.minInt)); +val test24d = tst' "test24d" (fn _ => scanFmt StringCvt.BIN (valOf Int64.minInt)); + +val test25a = tst' "test25a" (fn _ => scanFmt StringCvt.HEX (valOf Int64.minInt + 10)); +val test25b = tst' "test25b" (fn _ => scanFmt StringCvt.DEC (valOf Int64.minInt + 10)); +val test25c = tst' "test25c" (fn _ => scanFmt StringCvt.OCT (valOf Int64.minInt + 10)); +val test25d = tst' "test25d" (fn _ => scanFmt StringCvt.BIN (valOf Int64.minInt + 10)); + +fun chk' t f s = + tst' t (fn _ => ((f s; false) handle Overflow => true)) +fun chkScanOvf t fmt = chk' t (StringCvt.scanString (scan fmt)) + +val test26a = chkScanOvf "test26a" StringCvt.HEX "~8000000000000001" +val test26b = chkScanOvf "test26b" StringCvt.DEC "~9223372036854775809" +val test26c = chkScanOvf "test26c" StringCvt.OCT "~1000000000000000000001" +val test26d = chkScanOvf "test26d" StringCvt.BIN "~1000000000000000000000000000000000000000000000000000000000000001" + +val test27a = chkScanOvf "test27a" StringCvt.HEX "10000000000000000" +val test27b = chkScanOvf "test27b" StringCvt.DEC "9223372036854775808" +val test27c = chkScanOvf "test27c" StringCvt.OCT "1000000000000000000000" +val test27d = chkScanOvf "test27d" StringCvt.BIN "1000000000000000000000000000000000000000000000000000000000000000" + +val test28a = tst' "test28a" (fn () => toString (valOf maxInt) = "9223372036854775807") +val test28b = tst' "test28b" (fn () => toString (valOf minInt) = "~9223372036854775808") + +val test29a = tst' "test29a" (fn () => fromString "9223372036854775807" = maxInt) +val test29b = tst' "test29b" (fn () => fromString "~9223372036854775808" = minInt) + +end + +end diff --git a/test/int64.sml.out.ok b/test/int64.sml.out.ok new file mode 100644 index 000000000..addc60784 --- /dev/null +++ b/test/int64.sml.out.ok @@ -0,0 +1,209 @@ + +File int64.sml: Testing structure Int64... +test0a OK +test0b OK +test0c OK +test0d OK +test0e OK +test0f OK +test0g OK +test0h OK +test0i OK +test0j OK +test0k OK +test0l OK +test0m0 OK +test0m1 OK +test0m2 OK +test0m3 OK +test0n0 OK +test0n1 OK +test0n2 OK +test0p0 OK +test0p1 OK +test0p2 OK +test1a OK +test1b OK +test1c OK +test1d OK +test2a OK +test2b OK +test2c OK +test2d OK +test3 OK +test4 OK +test5 OK +test6 OK +test12 OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +test13b OK +test13b OK +test13b OK +test13b OK +test13b OK +test13b OK +test13b OK +test13b OK +test13b OK +test13b OK +test13b OK +test13b OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +test14b OK +test14b OK +test14b OK +test14b OK +test14b OK +test14b OK +test14b OK +test14b OK +test14b OK +test14b OK +test14b OK +test14b OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +test15b OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +test16b OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +chk OK +test17b OK +test17b OK +test17b OK +test17b OK +test17b OK +test17b OK +test17b OK +test17b OK +test17b OK +test17b OK +test17b OK +test18 OK +test19 OK +test20 OK +test21 OK +test22 OK +test23a OK +test23b OK +test23c OK +test23d OK +test24a OK +test24b OK +test24c OK +test24d OK +test25a OK +test25b OK +test25c OK +test25d OK +test26a OK +test26b OK +test26c OK +test26d OK +test27a OK +test27b OK +test27c OK +test27d OK +test28a OK +test28b OK +test29a OK +test29b OK diff --git a/test/int_2.sml b/test/int_2.sml index 96dfbe041..e03d048e2 100644 --- a/test/int_2.sml +++ b/test/int_2.sml @@ -1,17 +1,30 @@ -(* This test works only for 32-bit implementations! *) - +(* This test works only for 64-bit implementations! *) + +local fun pow2 n : int = if n < 1 then 1 else 2 * pow2(n-1) +in val maxInt63 : int = pow2 61 + (pow2 61 - 1) + val minInt63 : int = ~maxInt63 - 1 + fun maxInt64 () : int = pow2 62 + (pow2 62 - 1) + fun minInt64 () : int = ~(maxInt64()) - 1 +end + +local fun pow2 n : LargeInt.int = if n < 1 then 1 else 2 * pow2(n-1) +in val maxInt63L : LargeInt.int = pow2 61 + (pow2 61 - 1) + val minInt63L : LargeInt.int = ~maxInt63L - 1 + fun maxInt64L () : LargeInt.int = pow2 62 + (pow2 62 - 1) + fun minInt64L () : LargeInt.int = ~(maxInt64L()) - 1 +end local open Int in -val maxint : int = - case precision - of SOME 32 => 2 * 1073741823 + 1 - | SOME 31 => 1073741823 - | NONE => raise Fail "maxint" - +val maxint : int = + case precision + of SOME 64 => maxInt64() + | SOME 63 => maxInt63 + | SOME i => raise Fail ("maxint.SOME(" ^ Int.toString i ^ ")") + | NONE => raise Fail "maxint.NONE" val minint = ~maxint -1 -fun tagging() = precision = SOME 31 +fun tagging () = precision = SOME 63 infix seq fun e1 seq e2 = e2; @@ -28,20 +41,20 @@ val test3 = test "test3" ((maxint+1 seq "WRONG") handle Overflow => "OK") val test4 = test "test4" ((minint-1 seq "WRONG") handle Overflow => "OK") val test5 = test "test5" (case precision - of SOME 32 => ((if maxint = 2 * 0x3fffffff + 1 then "OK" else "WRONG") + of SOME 64 => ((if maxint = 2 * 0x3fffffffffffffff + 1 then "OK" else "WRONG") handle Overflow => "EXN") - | SOME 31 => if maxint = 0x3fffffff then "OK" else "WRONG" + | SOME 63 => if maxint = 0x3fffffffffffffff then "OK" else "WRONG" | _ => "WRONG") val test6 = test "test6" (case precision - of SOME 32 => ((if maxint = 2 * 0x3FFFFFFF + 1 then "OK" else "WRONG") + of SOME 64 => ((if maxint = 2 * 0x3FFFFFFFFFFFFFFF + 1 then "OK" else "WRONG") handle Overflow => "EXN") - | SOME 31 => if maxint = 0x3FFFFFFF then "OK" else "WRONG" + | SOME 63 => if maxint = 0x3FFFFFFFFFFFFFFF then "OK" else "WRONG" | _ => "WRONG") val test7 = test "test7" (case precision - of SOME 32 => ((if minint = 2 * ~0x40000000 then "OK" else "WRONG") + of SOME 64 => ((if minint = 2 * ~0x4000000000000000 then "OK" else "WRONG") handle Overflow => "EXN") - | SOME 31 => if minint = ~0x40000000 then "OK" else "WRONG" - | _ => "WRONG") + | SOME 63 => if minint = ~0x4000000000000000 then "OK" else "WRONG" + | _ => "WRONG") val sum = (op+) : int * int -> int val diff = (op-) : int * int -> int @@ -58,8 +71,8 @@ val test11 = test "test11" ((prod (minint,~1) seq "WRONG") handle Overflow => "O fun checkDivMod i d = let val q = i div d val r = i mod d - in -(* printVal i seq TextIO.output(TextIO.stdOut, " "); + in +(* printVal i seq TextIO.output(TextIO.stdOut, " "); printVal d seq TextIO.output(TextIO.stdOut, " "); *) if (d * q + r = i) andalso ((0 <= r andalso r < d) orelse (d < r andalso r <= 0)) @@ -88,20 +101,24 @@ val test26 = test "test26" ((minint div ~1 seq "WRONG") handle Overflow => "OK" val test35 = test' "test35" (toLarge ~1 = ~1) val test36 = test' "test36" (toLarge 1 = 1) val test37 = test' "test37" (toLarge 0 = 0) -val test38 = test' "test38" (tagging() andalso (toLarge maxint = 1073741823) - orelse (toLarge maxint = 2147483647)) -val test39 = test' "test39" (tagging() andalso (toLarge minint = ~1073741824) - orelse (toLarge minint = ~2147483648)) +val test38 = test' "test38" (tagging() andalso (toLarge maxint = maxInt63L) + orelse (toLarge maxint = maxInt64L())) +val test39 = test' "test39" (tagging() andalso (toLarge minint = minInt63L) + orelse (toLarge minint = minInt64L())) val test40 = test'' "test40" (fn _ => fromLarge(toLarge ~1) = ~1) val test41 = test'' "test41" (fn _ => fromLarge(toLarge maxint) = maxint) val test42 = test'' "test42" (fn _ => fromLarge(toLarge 0) = 0) val test42 = test'' "test42" (fn _ => fromLarge(toLarge minint) = minint) -val test43 = test "test43" ((fromLarge(Int32.toLarge(Int32.+(Int32.fromLarge(toLarge maxint), 1))) seq "WRONG") handle Overflow => "OK") -val test44 = test "test44" ((fromLarge(Int32.toLarge(Int32.-(Int32.fromLarge(toLarge minint), 1))) seq "WRONG") handle Overflow => "OK") -val test45 = test "test45" ((fromLarge(Int32.toLarge(valOf Int32.maxInt)) seq (if tagging() then "WRONG" else "OK")) +val test43 = test "test43" ((fromLarge(Int64.toLarge(Int64.+(Int64.fromLarge(toLarge maxint), 1))) seq "WRONG") + handle Overflow => "OK") +val test44 = test "test44" ((fromLarge(Int64.toLarge(Int64.-(Int64.fromLarge(toLarge minint), 1))) seq "WRONG") + handle Overflow => "OK") +val test45 = test "test45" ((fromLarge(Int64.toLarge(valOf Int64.maxInt)) seq (if tagging() then "WRONG" + else "OK")) handle Overflow => if tagging() then "OK" else "WRONG") -val test46 = test "test46" ((fromLarge(Int32.toLarge(valOf Int32.minInt)) seq (if tagging() then "WRONG" else "OK")) +val test46 = test "test46" ((fromLarge(Int64.toLarge(valOf Int64.minInt)) seq (if tagging() then "WRONG" + else "OK")) handle Overflow => if tagging() then "OK" else "WRONG") -end \ No newline at end of file +end diff --git a/test/pickle.sig b/test/pickle.sig index f2799108a..a4ad8177a 100644 --- a/test/pickle.sig +++ b/test/pickle.sig @@ -1,12 +1,12 @@ (* Generic pickle module - * Copyright, Martin Elsman 2003-01-07 + * Copyright, Martin Elsman 2003-01-07 * GPL Licence *) signature PICKLE = sig type instream and outstream - + type 'a pickler = 'a -> outstream -> outstream type 'a unpickler = instream -> 'a * instream @@ -16,8 +16,10 @@ signature PICKLE = val unpickler : 'a pu -> 'a unpickler val word : word pu + val word31 : Word31.word pu val word32 : Word32.word pu val int : int pu + val int31 : Int31.int pu val int32 : Int32.int pu val bool : bool pu val string : string pu @@ -41,16 +43,16 @@ signature PICKLE = val optionGen : 'a pu -> 'a option pu val vectorGen : 'a pu -> 'a Vector.vector pu val shareGen : 'a pu -> 'a pu - val enumGen : string * ''a list -> ''a pu + val enumGen : string * ''a list -> ''a pu val dataGen : string * ('a->int) * ('a pu -> 'a pu) list -> 'a pu - val data2Gen : string * ('a->int) * ('a pu * 'b pu -> 'a pu) list - * string * ('b->int) * ('a pu * 'b pu -> 'b pu) list + val data2Gen : string * ('a->int) * ('a pu * 'b pu -> 'a pu) list + * string * ('b->int) * ('a pu * 'b pu -> 'b pu) list -> 'a pu * 'b pu - val data3Gen : string * ('a->int) * ('a pu * 'b pu * 'c pu -> 'a pu) list - * string * ('b->int) * ('a pu * 'b pu * 'c pu -> 'b pu) list - * string * ('c->int) * ('a pu * 'b pu * 'c pu -> 'c pu) list + val data3Gen : string * ('a->int) * ('a pu * 'b pu * 'c pu -> 'a pu) list + * string * ('b->int) * ('a pu * 'b pu * 'c pu -> 'b pu) list + * string * ('c->int) * ('a pu * 'b pu * 'c pu -> 'c pu) list -> 'a pu * 'b pu * 'c pu val con0 : 'a -> 'b -> 'a pu @@ -70,7 +72,7 @@ signature PICKLE = val register : string -> 'a list -> 'a pu -> 'a pu - val registerEq: ('a*'a->bool) -> ('a->int) + val registerEq: ('a*'a->bool) -> ('a->int) -> string -> 'a list -> 'a pu -> 'a pu val hashCons : 'a pu -> 'a pu @@ -93,11 +95,11 @@ signature PICKLE = [outstream] type of an outstream. ['a pickler] parameterized pickler type. - + ['a unpickler] parameterized unpickler type. - + ['a pu] parameterized type of a pair of a pickler and an unpickler. - + [word] pickler-unpickler pair for word values. [int] pickler-unpickler pair for int values. @@ -164,4 +166,3 @@ signature PICKLE = that a pickled value equal to a value in vs is equal to the value in vs when unpickled. *) - diff --git a/test/pickle.sml b/test/pickle.sml index 10077e121..542488509 100644 --- a/test/pickle.sml +++ b/test/pickle.sml @@ -1,13 +1,13 @@ (* Generic pickle module - * Copyright, Martin Elsman 2003-01-07 + * Copyright, Martin Elsman 2003-01-07 * GPL Licence *) structure Listsort = struct fun sort ordr xs = - let - fun merge [] ys = ys + let + fun merge [] ys = ys | merge xs [] = xs | merge (x::xs) (y::ys) = if ordr(x, y) <> GREATER then x :: merge xs (y::ys) @@ -23,9 +23,9 @@ structure Listsort = fun sorting [] ls r = List.hd(mergepairs [] ls 0) | sorting (x::xs) ls r = let val (revrun, tail) = nextrun [x] xs - in sorting tail (mergepairs (List.rev revrun) ls (r+1)) (r+1) + in sorting tail (mergepairs (List.rev revrun) ls (r+1)) (r+1) end - in sorting xs [] 0 + in sorting xs [] 0 end end @@ -38,7 +38,7 @@ structure Pickle :> PICKLE = (* was : *) val comments_p = false datatype 'a cache = NoCache | Cached of 'a | Caching - + infix == fun a == b : bool = false (* @@ -51,7 +51,7 @@ structure Pickle :> PICKLE = (* was : *) structure H = Polyhash structure Dyn = EqHashDyn - fun fail s = let val s = "Pickle." ^ s + fun fail s = let val s = "Pickle." ^ s in print (s ^ "\n") ; raise Fail s end @@ -75,17 +75,17 @@ structure Pickle :> PICKLE = (* was : *) end local val hashCount = ref 0w100 - in fun newHashCount() = + in fun newHashCount() = !hashCount before hashCount := !hashCount + 0w1 end - fun stringHash acc s = + fun stringHash acc s = let val sz = size s val sz = if sz > maxLength then maxLength else sz - fun loop (n,a) = + fun loop (n,a) = if n >= sz then a - else loop (n+1, - hashAddSmall0 + else loop (n+1, + hashAddSmall0 (Word.fromInt(Char.ord(String.sub(s,n)))) a) in loop (0,acc) end @@ -93,8 +93,8 @@ structure Pickle :> PICKLE = (* was : *) type dyn = Dyn.dyn exception PickleExn - structure PickleEnv :> - sig + structure PickleEnv :> + sig type pe val empty : unit -> pe val lookup : pe -> dyn -> S.loc option @@ -104,17 +104,17 @@ structure Pickle :> PICKLE = (* was : *) end = struct type pe = (dyn, S.loc) H.hash_table - fun empty () = + fun empty () = H.mkTable (Word.toIntX o Dyn.hash maxDepth, Dyn.eq) (10,PickleExn) fun lookup pe d = H.peek pe d - fun insert pe (d,loc) = H.insert pe (d,loc) - fun reportBucket s (pe,d,typ) : unit = + fun insert pe (d,loc) = H.insert pe (d,loc) + fun reportBucket s (pe,d,typ) : unit = if true then () else let val (c,h) = H.peekSameHash pe d val maxBucket = 10 - in if c > maxBucket then - print ("** " ^ s ^ ".Bucket > " ^ Int.toString maxBucket - ^ " (c=" ^ Int.toString c ^ ",h=" + in if c > maxBucket then + print ("** " ^ s ^ ".Bucket > " ^ Int.toString maxBucket + ^ " (c=" ^ Int.toString c ^ ",h=" ^ Int.toString h ^") **: " ^ typ ^ "\n") else () end @@ -143,7 +143,7 @@ structure Pickle :> PICKLE = (* was : *) end = struct type hce = (dyn, dyn) H.hash_table - fun empty() = + fun empty() = H.mkTable (Word.toIntX o Dyn.hash maxDepth, Dyn.eq) (10,PickleExn) fun add hce d = case H.peek hce d of @@ -166,7 +166,7 @@ structure Pickle :> PICKLE = (* was : *) (* Datatype to force region inference in the ML Kit to infer fewer * region parameters for the polymorphic combinators... *) - datatype 'a pu = PU of {pickler : 'a pickler, + datatype 'a pu = PU of {pickler : 'a pickler, unpickler : 'a unpickler, hasher : 'a hasher, eq : 'a eq, @@ -181,7 +181,10 @@ structure Pickle :> PICKLE = (* was : *) fun w32_to_w w32 = (Word.fromLargeWord o Word32.toLargeWord) w32 fun w_to_w32 w = (Word32.fromLargeWord o Word.toLargeWord) w - local + fun w32_to_w31 w = (Word31.fromLargeWord o Word32.toLargeWord) w + fun w31_to_w32 w = (Word32.fromLargeWord o Word31.toLargeWord) w + + local val counter : Word32.word ref = ref 0w0 fun new() : Word32.word= !counter before counter := !counter + 0w1 in @@ -189,12 +192,12 @@ structure Pickle :> PICKLE = (* was : *) if not debug_p then pu else let val c = new() - in PU + in PU {pickler = (fn v => fn (s,pe) => let val s = S.outw (c,s) in pickler pu v (s,pe) end), - unpickler = (fn (s,upe,hce) => + unpickler = (fn (s,upe,hce) => let val (w,s) = S.getw s in if w <> c then fail ("debug.expected " ^ str) else unpickler pu (s,upe,hce) @@ -214,25 +217,28 @@ structure Pickle :> PICKLE = (* was : *) hasher = fn a => hashComb (fn p => hashAdd (w32_to_w(toWord a)) p), eq = op =, typ = s}) - + val word = wordGen "word" (w_to_w32, w32_to_w) + val word31 = wordGen "word" (w31_to_w32, w32_to_w31) val word32 = wordGen "word32" (fn x => x, fn x => x) val int = wordGen "int" (Word32.fromInt, Word32.toIntX) - val int32 = wordGen "int32" (Word32.fromLargeInt o Int32.toLarge, + val int31 = wordGen "int31" (Word32.fromLargeInt o Int31.toLarge, + Int31.fromLarge o Word32.toLargeIntX) + val int32 = wordGen "int32" (Word32.fromLargeInt o Int32.toLarge, Int32.fromLarge o Word32.toLargeIntX) - + val bool = wordGen "bool" (fn true => 0w1 | false => 0w0, fn 0w0 => false | _ => true) - val char = wordGen "char" (Word32.fromInt o Char.ord, + val char = wordGen "char" (Word32.fromInt o Char.ord, Char.chr o Word32.toIntX) fun shareGen0 (pp: 'a -> string) (pu:'a pu) : 'a pu = if not sharing_p then pu else debug "shareGen0" - let val REF = 0w0 and DEF = 0w1 + let val REF = 0w0 and DEF = 0w1 val hash_share = newHashCount() val typ = "SH(" ^ typ pu ^ ")" - val (toDyn,fromDyn) = + val (toDyn,fromDyn) = Dyn.new (fn v => fn d => #1 (hasher pu v (hash_share,d))) (eQ pu) fun h2 v = hashComb (fn p => hasher pu v (hashAddSmallNoCount hash_share p)) @@ -240,7 +246,7 @@ structure Pickle :> PICKLE = (* was : *) {pickler = (fn v => fn (s, pe:pe) => let val d = toDyn v in case PickleEnv.lookup pe d of - SOME loc => + SOME loc => let val s = S.outcw(REF,s) val s = S.outw(w_to_w32 loc,s) in (s,pe) @@ -251,21 +257,21 @@ structure Pickle :> PICKLE = (* was : *) (* do insert after the pickling *) (* - otherwise there are problems *) (* with cycles. *) - val res = pickler pu v (s, pe) - in case PickleEnv.lookup pe d of - SOME _ => res + val res = pickler pu v (s, pe) + in case PickleEnv.lookup pe d of + SOME _ => res | NONE => let (* val (c,h) = H.peekSameHash pe d val maxBucket = 10 - val _ = if c > maxBucket then - print ("** Bucket > " ^ Int.toString maxBucket - ^ " (c=" ^ Int.toString c ^ ",h=" + val _ = if c > maxBucket then + print ("** Bucket > " ^ Int.toString maxBucket + ^ " (c=" ^ Int.toString c ^ ",h=" ^ Int.toString h ^") **: " ^ typ ^ "\n" ^ "** Value = " ^ pp v ^ "\n") else () *) - in PickleEnv.insert pe (d,loc) + in PickleEnv.insert pe (d,loc) ; res end end @@ -277,8 +283,8 @@ structure Pickle :> PICKLE = (* was : *) val loc' = w32_to_w loc in case UnpickleEnv.lookup upe loc' of SOME d => (fromDyn d, (s,upe,hce)) - | NONE => fail ("shareGen.impossible, loc=" - ^ Word32.toString loc ^ ", loc'=" + | NONE => fail ("shareGen.impossible, loc=" + ^ Word32.toString loc ^ ", loc'=" ^ Word.toString loc') end else if tag = DEF then @@ -286,8 +292,8 @@ structure Pickle :> PICKLE = (* was : *) val (v,(s,upe,hce)) = unpickler pu (s,upe,hce) val _ = case UnpickleEnv.lookup upe loc of NONE => () - | SOME _ => fail ("shareGen.Location " - ^ Word.toString loc + | SOME _ => fail ("shareGen.Location " + ^ Word.toString loc ^ " already there!") in UnpickleEnv.insert upe (loc,toDyn v) ; (v, (s,upe,hce)) @@ -313,7 +319,7 @@ structure Pickle :> PICKLE = (* was : *) let val (sz,s) = S.getcw s val sz = Word32.toInt sz fun read (0,s,acc) = (implode(rev acc), s) - | read (n,s,acc) = + | read (n,s,acc) = let val (c,s) = S.get s in read (n-1, s, c :: acc) end @@ -324,7 +330,7 @@ structure Pickle :> PICKLE = (* was : *) eq = op =, typ = "string"} - fun pairGen0 (pu1 :'a pu, pu2 :'b pu) : ('a * 'b) pu = + fun pairGen0 (pu1 :'a pu, pu2 :'b pu) : ('a * 'b) pu = let val hash_pair = newHashCount() in debug "pair" (PU @@ -337,25 +343,25 @@ structure Pickle :> PICKLE = (* was : *) val (v2,is) = unpickler pu2 is in ((v1,v2), is) end), - hasher = (fn (a,b) => - hashComb (fn p => - let val p = hashAddSmallNoCount + hasher = (fn (a,b) => + hashComb (fn p => + let val p = hashAddSmallNoCount hash_pair (hasher pu1 a p) in hashComb (hasher pu2 b) p end)), - eq = fn (p1 as (a1,a2),p2 as (b1,b2)) => - p1==p2 + eq = fn (p1 as (a1,a2),p2 as (b1,b2)) => + p1==p2 orelse eQ pu1 (a1,b1) andalso eQ pu2 (a2,b2), typ = "P(" ^ typ pu1 ^ "," ^ typ pu2 ^ ")"}) end fun pairGen pu = shareGen(pairGen0 pu) - fun refEqGen (eq: 'a ref * 'a ref -> bool) + fun refEqGen (eq: 'a ref * 'a ref -> bool) (v_dummy:'a) (pu:'a pu) : 'a ref pu = debug "refEqGen" let (*val eq = if very_safe_p then op = else eq *) - val REF_LOC = 0w0 and REF_DEF = 0w1 + val REF_LOC = 0w0 and REF_DEF = 0w1 val hash_ref = newHashCount() fun href (ref a) = hashComb (fn p => hashAddSmall hash_ref (hasher pu a p)) val typ = "ref(" ^ typ pu ^ ")" @@ -364,7 +370,7 @@ structure Pickle :> PICKLE = (* was : *) {pickler = (fn r as ref v => fn (s, pe:pe) => let val d = toDyn r in case PickleEnv.lookup pe d of - SOME loc => + SOME loc => let val s = S.outcw(REF_LOC,s) val s = S.outw(w_to_w32 loc,s) in (s,pe) @@ -399,12 +405,12 @@ structure Pickle :> PICKLE = (* was : *) end fun refGen (v_dummy:'a) (pu:'a pu) : 'a ref pu = - refEqGen (op =) v_dummy pu + refEqGen (op =) v_dummy pu - fun ref0EqGen (eq: 'a ref * 'a ref ->bool) (pu:'a pu) : 'a ref pu = + fun ref0EqGen (eq: 'a ref * 'a ref ->bool) (pu:'a pu) : 'a ref pu = debug "ref0EqGen" let val eq = if very_safe_p then op = else eq - val REF_LOC = 0w0 and REF_DEF = 0w1 + val REF_LOC = 0w0 and REF_DEF = 0w1 val hash_ref = newHashCount() fun href (ref a) = hashComb (fn p => hashAddSmall hash_ref (hasher pu a p)) val typ = "ref0(" ^ typ pu ^ ")" @@ -413,7 +419,7 @@ structure Pickle :> PICKLE = (* was : *) {pickler = (fn r as ref v => fn (s, pe:pe) => let val d = toDyn r in case PickleEnv.lookup pe d of - SOME loc => + SOME loc => let val s = S.outcw(REF_LOC,s) val s = S.outw(w_to_w32 loc,s) in (s,pe) @@ -438,7 +444,7 @@ structure Pickle :> PICKLE = (* was : *) let val loc = S.getLoc s val (v,(s,upe,hce)) = unpickler pu (s,upe,hce) val r = ref v - in UnpickleEnv.insert upe (loc,toDyn r) + in UnpickleEnv.insert upe (loc,toDyn r) ; (r, (s,upe,hce)) end end), @@ -447,12 +453,12 @@ structure Pickle :> PICKLE = (* was : *) typ = typ} end - fun ref0Gen (pu:'a pu) : 'a ref pu = + fun ref0Gen (pu:'a pu) : 'a ref pu = ref0EqGen (op =) pu - fun ref0ShGen (pu:'a pu) : 'a ref pu = + fun ref0ShGen (pu:'a pu) : 'a ref pu = if very_safe_p then ref0Gen pu - else ref0EqGen (fn (ref a,ref b) => eQ pu (a,b)) pu + else ref0EqGen (fn (ref a,ref b) => eQ pu (a,b)) pu fun refOneGen (pu:'a pu) : 'a ref pu = (* Only works when sharing is enabled! *) if not sharing_p orelse not linear_refs_p then ref0Gen pu @@ -490,7 +496,7 @@ structure Pickle :> PICKLE = (* was : *) let val n = toInt a1 in n = toInt a2 andalso eQ (getPUPI n) (a1,a2) end - and getPUP() = + and getPUP() = case !res of NONE => let val typ = name ^ "_" ^ Int.toString (length fs) fun pp v = "Con" ^ Int.toString (toInt v) @@ -507,7 +513,7 @@ structure Pickle :> PICKLE = (* was : *) val psv = Vector.fromList ps0 in ps := Cached psv ; Vector.sub(psv,i) - end + end | Cached psv => Vector.sub(psv,i) | Caching => fail ("dataGen.Caching: " ^ name) and h v = @@ -521,7 +527,7 @@ structure Pickle :> PICKLE = (* was : *) end fun data2Gen (aname, aToInt: 'a -> int, afs : ('a pu * 'b pu -> 'a pu) list, - bname, bToInt: 'b -> int, bfs : ('a pu * 'b pu -> 'b pu) list) + bname, bToInt: 'b -> int, bfs : ('a pu * 'b pu -> 'b pu) list) : 'a pu * 'b pu = let (* val _ = print ("Generated pickler for " ^ aname ^ "/" ^ bname ^ "\n") *) val aHashData = newHashCount() @@ -544,7 +550,7 @@ structure Pickle :> PICKLE = (* was : *) let val n = aToInt a1 in n = aToInt a2 andalso eQ (aGetPUPI n) (a1,a2) end - and aGetPUP() = + and aGetPUP() = case !aRes of NONE => let val typ = aname ^ "_" ^ Int.toString (length afs) fun pp v = "Con" ^ Int.toString (aToInt v) @@ -561,8 +567,8 @@ structure Pickle :> PICKLE = (* was : *) val psv = Vector.fromList ps0 in aPs := Cached psv ; Vector.sub(psv,i) - end - | Cached psv => Vector.sub(psv,i) + end + | Cached psv => Vector.sub(psv,i) | Caching => fail ("dataGen2.Caching.a: " ^ aname) and bP v (s,pe) = let val i = bToInt v @@ -578,7 +584,7 @@ structure Pickle :> PICKLE = (* was : *) let val n = bToInt b1 in n = bToInt b2 andalso eQ (bGetPUPI n) (b1,b2) end - and bGetPUP() = + and bGetPUP() = case !bRes of NONE => let val typ = bname ^ "_" ^ Int.toString (length bfs) fun pp v = "Con" ^ Int.toString (bToInt v) @@ -595,7 +601,7 @@ structure Pickle :> PICKLE = (* was : *) val psv = Vector.fromList ps0 in bPs := Cached psv ; Vector.sub(psv,i) - end + end | Cached psv => Vector.sub(psv,i) | Caching => fail ("dataGen2.Caching.b: " ^ bname) and aH v = @@ -617,7 +623,7 @@ structure Pickle :> PICKLE = (* was : *) fun data3Gen (aname, aToInt: 'a->int, afs : ('a pu*'b pu*'c pu->'a pu)list, bname, bToInt: 'b->int, bfs : ('a pu*'b pu*'c pu->'b pu)list, - cname, cToInt: 'c->int, cfs : ('a pu*'b pu*'c pu->'c pu)list) + cname, cToInt: 'c->int, cfs : ('a pu*'b pu*'c pu->'c pu)list) : 'a pu * 'b pu * 'c pu = let (* val _ = print ("Generated pickler for " ^ aname ^ "/" ^ bname ^ "/" ^ cname ^ "\n") *) val aHashData = newHashCount() @@ -643,7 +649,7 @@ structure Pickle :> PICKLE = (* was : *) let val n = aToInt a1 in n = aToInt a2 andalso eQ (aGetPUPI n) (a1,a2) end - and aGetPUP() = + and aGetPUP() = case !aRes of NONE => let val typ = aname ^ "_" ^ Int.toString (length afs) fun pp v = "Con" ^ Int.toString (aToInt v) @@ -661,8 +667,8 @@ structure Pickle :> PICKLE = (* was : *) val psv = Vector.fromList ps0 in aPs := Cached psv ; Vector.sub(psv,i) - end - | Cached psv => Vector.sub(psv,i) + end + | Cached psv => Vector.sub(psv,i) | Caching => fail ("dataGen3.Caching.a: " ^ aname) and bP v (s,pe) = let val i = bToInt v @@ -678,7 +684,7 @@ structure Pickle :> PICKLE = (* was : *) let val n = bToInt b1 in n = bToInt b2 andalso eQ (bGetPUPI n) (b1,b2) end - and bGetPUP() = + and bGetPUP() = case !bRes of NONE => let val typ = bname ^ "_" ^ Int.toString (length bfs) fun pp v = "Con" ^ Int.toString (bToInt v) @@ -696,7 +702,7 @@ structure Pickle :> PICKLE = (* was : *) val psv = Vector.fromList ps0 in bPs := Cached psv ; Vector.sub(psv,i) - end + end | Cached psv => Vector.sub(psv,i) | Caching => fail ("dataGen3.Caching.b: " ^ bname) and cP v (s,pe) = @@ -713,7 +719,7 @@ structure Pickle :> PICKLE = (* was : *) let val n = cToInt c1 in n = cToInt c2 andalso eQ (cGetPUPI n) (c1,c2) end - and cGetPUP() = + and cGetPUP() = case !cRes of NONE => let val typ = cname ^ "_" ^ Int.toString (length cfs) fun pp v = "Con" ^ Int.toString (cToInt v) @@ -731,7 +737,7 @@ structure Pickle :> PICKLE = (* was : *) val psv = Vector.fromList ps0 in cPs := Cached psv ; Vector.sub(psv,i) - end + end | Cached psv => Vector.sub(psv,i) | Caching => fail ("dataGen3.Caching.c: " ^ cname) and aH v = @@ -755,8 +761,8 @@ structure Pickle :> PICKLE = (* was : *) in hashAddSmallNoCount (Word.fromInt i) (hashAddSmallNoCount cHashData (h_arg v p)) end) - in (debug "data3Gen.a" (aGetPUP()), - debug "data3Gen.b" (bGetPUP()), + in (debug "data3Gen.a" (aGetPUP()), + debug "data3Gen.b" (bGetPUP()), debug "data3Gen.c" (cGetPUP())) end @@ -765,11 +771,11 @@ structure Pickle :> PICKLE = (* was : *) unpickler = fn is => (b,is), hasher = fn _ => fn p => p, eq = fn _ => true, (* tag is checked with toInt in dataNGen *) - typ = "con0"} + typ = "con0"} fun con1 (con:'a->'b) (decon: 'b->'a) (pu: 'a pu) = PU {pickler = fn b:'b => pickler pu (decon b), - unpickler = (fn is => + unpickler = (fn is => let val (a,is) = unpickler pu is in (con a,is) end), @@ -787,7 +793,7 @@ structure Pickle :> PICKLE = (* was : *) fun maybeNewHash (f: 'a -> int option) (pu: 'a pu) : 'a pu = PU {pickler= pickler pu, unpickler = unpickler pu, - hasher = fn a => hashComb (fn p => + hasher = fn a => hashComb (fn p => case f a of SOME i => hashAdd (Word.fromInt i) p | NONE => hasher pu a p), @@ -820,16 +826,16 @@ structure Pickle :> PICKLE = (* was : *) let fun toInt NONE = 0 | toInt (SOME _) = 1 val fun_NONE = con0 NONE - fun fun_SOME _ = + fun fun_SOME _ = con1 SOME (fn SOME v => v | NONE => fail "option") pu_a in dataGen("(" ^ typ pu_a ^ ")option",toInt,[fun_NONE,fun_SOME]) end fun enumGen (name, xs: ''a list) : ''a pu = (*inefficient*) debug "enum" - let val (wxs,n) = - List.foldl (fn (x, (wxs, n)) => - ((x,Word.fromInt n)::wxs, n+1)) + let val (wxs,n) = + List.foldl (fn (x, (wxs, n)) => + ((x,Word.fromInt n)::wxs, n+1)) (nil,0) xs fun lookupw nil _ = fail "enumGen.unknown constructor" | lookupw ((x,w)::xs) v = if x=v then w else lookupw xs v @@ -848,14 +854,14 @@ structure Pickle :> PICKLE = (* was : *) typ = "enum(" ^ name ^ "," ^ Int.toString (length xs) ^ ")"} end - fun fromString (s : string) : instream = + fun fromString (s : string) : instream = (S.openIn s, UnpickleEnv.empty(), HashConsEnv.empty()) fun fromStringHashCons ((_,_,hce) : instream) (s : string) : instream = (S.openIn s, UnpickleEnv.empty(), hce) val ptest = false - fun toString ((os,pe):outstream) : string = + fun toString ((os,pe):outstream) : string = let val res = S.toString os val _ = if not ptest then () else let @@ -868,9 +874,9 @@ structure Pickle :> PICKLE = (* was : *) end in res end - - fun empty() : outstream = - (S.openOut(), + + fun empty() : outstream = + (S.openOut(), PickleEnv.empty()) fun convert0 (to: 'a->'b ,back: 'b->'a) (pu:'a pu) : 'b pu = @@ -880,7 +886,7 @@ structure Pickle :> PICKLE = (* was : *) unpickler = (fn is => let val (v,is) = unpickler pu is in (to v,is) end), - hasher = fn v => hashComb (fn p => hashAddSmallNoCount + hasher = fn v => hashComb (fn p => hashAddSmallNoCount hash_conv ((hasher pu o back) v p)), eq = fn (x,y) => eQ pu (back x, back y), typ = "conv(" ^ typ pu ^ ")"} @@ -909,13 +915,13 @@ structure Pickle :> PICKLE = (* was : *) convert (Vector.fromList,Vector.foldr (op ::) nil) (listGen pu) - val real = + val real = debug "real" (convert (fn s => PackRealBig.fromBytes(Byte.stringToBytes s), fn r => Byte.bytesToString(PackRealBig.toBytes r)) string) - val time = + val time = debug "time" (convert (Time.fromReal,Time.toReal) real) val unit : unit pu = @@ -932,11 +938,11 @@ structure Pickle :> PICKLE = (* was : *) fn a : 'a => case !C of Cached v => v - | NoCache => + | NoCache => (C := Caching; let val v : 'b = f a in case !C of - Caching => + Caching => ( C := Cached v ; v) | _ => fail "cacheNew impossible" @@ -948,19 +954,19 @@ structure Pickle :> PICKLE = (* was : *) fun cache (s:string) : ('a -> 'b pu) -> 'a -> 'b pu = cache0 s fun cache2 (s:string) : ('a -> 'b pu * 'c pu) -> 'a -> 'b pu * 'c pu = cache0 s - fun registerEq (eq: 'a * 'a -> bool) (key : 'a -> int) + fun registerEq (eq: 'a * 'a -> bool) (key : 'a -> int) (debug_str:string) (vs: 'a list) (pu : 'a pu) : 'a pu = let val h : ('a,word) H.hash_table = H.mkTable (key, eq) (10,PickleExn) (* val _ = print ("registerEq: " ^ debug_str ^ "\n") *) val _ = List.foldl (fn (e,n) => (H.insert h (e,n); n + 0w1)) 0w1 vs val v = Vector.fromList vs - fun lookup w = + fun lookup w = let val i = Word.toInt w - 1 in Vector.sub(v,i) - end + end val NOT_THERE : word = 0w0 - in PU - {pickler = (fn v => fn (s,pe) => + in PU + {pickler = (fn v => fn (s,pe) => case H.peek h v of SOME w => (S.outcw(w_to_w32 w,s),pe) | NONE => let val s = S.outcw(w_to_w32 NOT_THERE,s) @@ -980,17 +986,17 @@ structure Pickle :> PICKLE = (* was : *) end fun register s (vs: 'a list) (pu : 'a pu) : 'a pu = - registerEq - (eQ pu) + registerEq + (eQ pu) (fn v => Word.toIntX (#1(hasher pu v (0w0,maxDepth)))) s vs pu fun hashConsEq (eq:'a*'a->bool) (pu: 'a pu) : 'a pu = let val hash = newHashCount() - val (toDyn,fromDyn) = + val (toDyn,fromDyn) = Dyn.new (fn v => fn d => #1 (hasher pu v (hash,d))) eq in PU {pickler= pickler pu, - unpickler= fn is => + unpickler= fn is => let val (v,is) = unpickler pu is val d = HashConsEnv.add (#3 is) (toDyn v) in (fromDyn d, is) @@ -1000,9 +1006,9 @@ structure Pickle :> PICKLE = (* was : *) typ= typ pu} end - fun hashCons (pu: 'a pu) : 'a pu = + fun hashCons (pu: 'a pu) : 'a pu = hashConsEq (eQ pu) pu - + fun nameGen s (pu: 'a pu) : 'a pu = let fun decorate s = "(" ^ s ^ " = " ^ typ pu ^ ")" in PU @@ -1016,16 +1022,16 @@ structure Pickle :> PICKLE = (* was : *) fun comment s (pu:'a pu) : 'a pu = if not comments_p then pu else PU - {pickler = (fn a => fn spe => + {pickler = (fn a => fn spe => let val pos = (S.getLoc o #1) spe - val _ = print ("\n[Begin pickling: " ^ s ^ " - pos=" - ^ (Int.toString o Word.toInt) pos ^ "]\n") + val _ = print ("\n[Begin pickling: " ^ s ^ " - pos=" + ^ (Int.toString o Word.toInt) pos ^ "]\n") val spe = pickler pu a spe val pos' = (S.getLoc o #1) spe - val _ = print ("\n[End pickling : " ^ s ^ " - pos=" - ^ (Int.toString o Word.toInt) pos' ^ ", diff=" - ^ Int.toString(Word.toInt pos' - Word.toInt pos) - ^ "]\n") + val _ = print ("\n[End pickling : " ^ s ^ " - pos=" + ^ (Int.toString o Word.toInt) pos' ^ ", diff=" + ^ Int.toString(Word.toInt pos' - Word.toInt pos) + ^ "]\n") in spe end), unpickler = unpickler pu, @@ -1033,26 +1039,26 @@ structure Pickle :> PICKLE = (* was : *) eq = eQ pu, typ = typ pu} - fun checkUnpickle (f: 'a -> unit) + fun checkUnpickle (f: 'a -> unit) (pu as PU {pickler,unpickler,eq,typ,hasher} : 'a pu) : 'a pu = pu (* PU {pickler=pickler, - unpickler=fn is => + unpickler=fn is => let val p as (v,is) = unpickler is in f v ; p end, eq=eq, typ=typ, - hasher=hasher} + hasher=hasher} *) - fun debugUnpickle (s : string) + fun debugUnpickle (s : string) (pu as PU {pickler,unpickler,eq,typ,hasher} : 'a pu) : 'a pu = pu (* PU {pickler=pickler, - unpickler=fn is => + unpickler=fn is => let val _ = print ("unpickling[" ^ s ^ "] begin...\n") val p = unpickler is val _ = print ("unpickling[" ^ s ^ "] end...\n") @@ -1063,4 +1069,3 @@ structure Pickle :> PICKLE = (* was : *) hasher=hasher} *) end - diff --git a/test/pickletest.sml b/test/pickletest.sml index 30a39089f..a443f3bb9 100644 --- a/test/pickletest.sml +++ b/test/pickletest.sml @@ -2,36 +2,43 @@ (* test/pickletest.sml; Martin Elsman 2003-07-01 *) -local +type word = Word31.word +type int = Int31.int +structure Word = Word31 +structure Int = Int31 + +local infix 1 seq fun e1 seq e2 = e2; fun check b = if b then "OK" else "WRONG"; fun check' f = (if f () then "OK" else "WRONG") handle _ => "EXN" - - fun range (from, to) p = - let open Int + + fun range (from, to) p = + let open Int in (from > to) orelse (p from) andalso (range (from+1, to) p) end fun checkrange bounds = check o range bounds - + fun tst0 s s' = print (s ^ " \t" ^ s' ^ "\n") fun tst s b = tst0 s (check b) fun tst' s f = tst0 s (check' f) - - fun tstrange s bounds = (tst s) o range bounds + + fun tstrange s bounds = (tst s) o range bounds val _ = print "\nFile pickle.sml: Testing structure Pickle...\n" open Pickle + val int = int31 + val word = word31 fun tm_eq(t1,t2) = Time.<(Time.-(t1,t2),Time.fromSeconds 2) handle _ => Time.<(Time.-(t2,t1),Time.fromSeconds 2) fun okEq' eq s_tst (pu: 'a pu) (v1 : 'a) = - tst' s_tst - (fn () => + tst' s_tst + (fn () => let val s = toString (pickler pu v1 (empty())) val (v2,is) = unpickler pu (fromString s) in eq(v1,v2) @@ -39,38 +46,38 @@ local fun okEq a = okEq' (op =) a - val maxInt = - case Int.maxInt of + val maxInt = + case Int.maxInt of SOME i => i | _ => raise Fail "maxInt" val maxWord = - 0w2 * Word.fromInt maxInt + 0w1 + 0w2 * Word.fromLargeInt (Int.toLarge maxInt) + 0w1 - val minInt = - case Int.minInt of + val minInt = + case Int.minInt of SOME i => i | _ => raise Fail "minInt" - val maxInt32 = - case Int32.maxInt of + val maxInt32 = + case Int32.maxInt of SOME i => i | _ => raise Fail "maxInt32" val maxWord32 = 0w2 * Word32.fromLargeInt (Int32.toLarge maxInt32) + 0w1 - val minInt32 = - case Int32.minInt of + val minInt32 = + case Int32.minInt of SOME i => i | _ => raise Fail "minInt32" -in +in (* Word *) val _ = okEq "test1a" word 0w0 val _ = okEq "test1b" word 0w7 -val _ = okEq "test1c" word (Word.fromInt maxInt) -val _ = okEq "test1d" word (Word.fromInt minInt) +val _ = okEq "test1c" word (Word.fromLargeInt (Int.toLarge maxInt)) +val _ = okEq "test1d" word (Word.fromLargeInt (Int.toLarge minInt)) val _ = okEq "test1e" word maxWord (* Word32 *) @@ -99,7 +106,7 @@ val _ = okEq "test5a" bool true val _ = okEq "test5b" bool false (* String *) -fun mkS (n,acc) = +fun mkS (n,acc) = if n < 0 then acc else mkS (n-1, chr (n mod 256) :: acc) @@ -165,7 +172,7 @@ val _ = okEq' (fn (a,b) => !a = !b) "test14a" (refGen 0 int) (ref 0) val _ = okEq' (fn (a,b) => !a = !b) "test14b" (refGen 0 int) (ref 7) val _ = okEq' (fn (a,b) => !a = !b) "test14c" (refGen 0 int) (ref ~7) val _ = okEq' (fn (a,b) => !a = !b) "test14d" (refGen (0,false) (pairGen(int,bool))) (ref (~7,true)) -val _ = okEq' (fn ((a1,a2),(b1,b2)) => !a1 = !b1 andalso !a2 = !b2) "test14e" +val _ = okEq' (fn ((a1,a2),(b1,b2)) => !a1 = !b1 andalso !a2 = !b2) "test14e" (pairGen(refGen 0 int, refGen true bool)) (ref ~7,ref false) (* ref0Gen *) @@ -173,7 +180,7 @@ val _ = okEq' (fn (a,b) => !a = !b) "test15a" (ref0Gen int) (ref 0) val _ = okEq' (fn (a,b) => !a = !b) "test15b" (ref0Gen int) (ref 7) val _ = okEq' (fn (a,b) => !a = !b) "test15c" (ref0Gen int) (ref ~7) val _ = okEq' (fn (a,b) => !a = !b) "test15d" (ref0Gen (pairGen(int,bool))) (ref (~7,true)) -val _ = okEq' (fn ((a1,a2),(b1,b2)) => !a1 = !b1 andalso !a2 = !b2) "test15e" +val _ = okEq' (fn ((a1,a2),(b1,b2)) => !a1 = !b1 andalso !a2 = !b2) "test15e" (pairGen(ref0Gen int, ref0Gen bool)) (ref ~7,ref false) (* listGen *) @@ -189,7 +196,7 @@ val _ = okEq "test20i" (pairGen(int,listGen char)) (~2333,mkS(100,nil)) val _ = okEq "test20j" (pairGen(int,listGen char)) (2333,mkS(1000,nil)) (* val _ = okEq "test20k" (pairGen(int,listGen char)) (~2333,mkS(2000,nil)) -val _ = okEq "test20l" (pairGen(int,listGen char)) (~2333,mkS(100000,nil)) +val _ = okEq "test20l" (pairGen(int,listGen char)) (~2333,mkS(100000,nil)) *) val _ = okEq "test20m" (pairGen(int,listGen char)) (~2333,nil) @@ -262,8 +269,8 @@ local fun fun_Lb (pu_a,pu_b) = con1 Lb (fn Lb s => s | _ => raise Fail "Lb") int val fun_Nb = con0 Nb in - val (pu_atree,pu_btree) = - data2Gen("atree", toInta, [fun_Ta,fun_La], + val (pu_atree,pu_btree) = + data2Gen("atree", toInta, [fun_Ta,fun_La], "btree", toIntb, [fun_Tb,fun_Lb,fun_Nb]) end @@ -279,7 +286,7 @@ val _ = okEq "test26i" pu_btree (Tb(Lb 1,La "a")) val _ = okEq "test26j" pu_btree (Tb(Nb,La "a")) (* Convert *) -val pu_record = +val pu_record = convert (fn (a,b,c) => {a=a,b=b,c=c}, fn {a=a,b=b,c=c} => (a,b,c)) (tup3Gen(int,bool,int)) @@ -303,11 +310,11 @@ local | sel _ = raise Fail "sel" fun sel_eq(xs,ys,n) = sel(xs,n) = sel(ys,n) fun sel_noteq(xs,ys,n) = sel(xs,n) <> sel(ys,n) - fun eq (xs,ys) = + fun eq (xs,ys) = eq0(xs,ys) andalso sel_eq(xs,ys,2) andalso sel_eq(xs,ys,3) andalso - sel_eq(xs,ys,4) andalso + sel_eq(xs,ys,4) andalso sel_noteq(xs,ys,0) andalso sel_noteq(xs,ys,1) andalso sel_noteq(xs,ys,5) andalso @@ -325,39 +332,39 @@ local type graph = node list fun eval f (seen, nil, acc) = (seen,acc) - | eval f (seen, Node(i,ref nodes)::ns, acc) = + | eval f (seen, Node(i,ref nodes)::ns, acc) = let fun member x nil = false | member x (y::ys) = x = y orelse member x ys - val (seen,acc) = + val (seen,acc) = if member i seen then (seen,acc) else eval f (i::seen,nodes,f(i,acc)) in eval f (seen,ns,acc) end val pu_node = - let fun fun_node pu = con1 Node (fn Node a => a) + let fun fun_node pu = con1 Node (fn Node a => a) (pairGen(int,refGen nil (listGen pu))) in dataGen("node",fn _ => 0, [fun_node]) - end + end val node : unit -> node = let val c = ref 0 in fn () => Node(!c,ref nil) before c := !c + 1 end infix -- - fun n1 -- n2 = + fun n1 -- n2 = let val Node(_,r1) = n1 val Node(_,r2) = n2 - in r1 := n2 :: !r1 + in r1 := n2 :: !r1 ; r2 := n1 :: !r2 end - + val n1 = node() val n2 = node() val n3 = node() val n4 = node() - fun sum n = eval (op +) (nil,[n],0) + fun sum n = eval (op +) (nil,[n],0) fun nodeEquiv (n1,n2) = sum n1 = sum n2 in val _ = okEq' nodeEquiv "40a" pu_node n1 diff --git a/test/real.sml b/test/real.sml index be146e733..c19527011 100644 --- a/test/real.sml +++ b/test/real.sml @@ -5,8 +5,8 @@ fun e1 seq e2 = e2; fun check b = if b then "OK" else "WRONG"; fun check' f = (if f () then "OK" else "WRONG") handle _ => "EXN"; -fun range (from, to) p = - let open Int +fun range (from, to) p = + let open Int in (from > to) orelse (p from) andalso (range (from+1, to) p) end; @@ -17,7 +17,7 @@ fun tst0 s s' = print (s ^ " \t" ^ s' ^ "\n"); fun tst s b = tst0 s (check b); fun tst' s f = tst0 s (check' f); -fun tstrange s bounds = (tst s) o range bounds +fun tstrange s bounds = (tst s) o range bounds (* test/real.sml -- PS 1995-03-24, 1996-05-16, 1996-07-02, 1996-09-25 *) @@ -27,24 +27,28 @@ use "auxil.sml"; val _ = print "Testing structure Real...\n" -local +local open Real infix == -in +in -val test1 = tst "test1" (sign ~57.0 = ~1 andalso sign 99.0 = 1 andalso sign 0.0 = 0); -val test2 = tst "test2" (sameSign(~255.0, ~256.0) andalso sameSign(255.0, 256.0) - andalso sameSign(0.0, 0.0)); +val test1 = tst "test1" (sign ~57.0 = ~1 andalso sign 99.0 = 1 andalso sign 0.0 = 0) +val test2 = tst "test2" (sameSign(~255.0, ~256.0) andalso sameSign(255.0, 256.0) + andalso sameSign(0.0, 0.0)) val test3 = tst "test3" (sign 1E~300 = 1 andalso sign ~1E~300 = ~1 - andalso sign 1E300 = 1 andalso sign ~1E300 = ~1); - -local - val args = [0.0, 99.0, ~5.0, 1.1, ~1.1, 1.9, ~1.9, 2.5, ~2.5, - 1000001.4999, ~1000001.4999]; - val minInt = valOf Int.minInt; - val maxInt = valOf Int.maxInt; - val rminInt = real minInt; - val rmaxInt = real maxInt; + andalso sign 1E300 = 1 andalso sign ~1E300 = ~1) + +local + val args = [0.0, 99.0, ~5.0, 1.1, ~1.1, 1.9, ~1.9, 2.5, ~2.5, + 1000001.4999, ~1000001.4999] + val smallInt : int = Int.*(~1073741824, 10) (* smaller than what fits in 32 bits *) + val bigInt : int = Int.*(1073741823, 10) (* larger than what fits in 32 bits *) + val rsmallInt = real smallInt + val rbigInt = real bigInt + val minInt : int = valOf Int.minInt + val maxInt : int = valOf Int.maxInt + val rminInt = real minInt + val rmaxInt = real maxInt (* val _ = (print ("minInt = " ^ Int.toString minInt); @@ -52,51 +56,54 @@ local print ("\nrminInt = " ^ Real.toString rminInt); print ("\nrmaxInt = " ^ Real.toString rmaxInt); print ("\n")) -*) - fun chkminmax s f min max = - tst' s (fn _ => - List.all (fn r => f r = minInt) (rminInt :: min) - andalso List.all (fn r => f r = maxInt) (rmaxInt :: max)); +*) + fun chksmallbig s f min max = + tst' s (fn _ => + List.all (fn r => f r = smallInt) (rsmallInt :: min) + andalso List.all (fn r => f r = bigInt) (rbigInt :: max)); fun chkfail s f r = - tst0 s ((f r; "WRONG") + tst0 s ((f r; "WRONG") handle Overflow => "OK" | _ => "WRONG") in -val test4a = tst "test4a" (map ceil args - = [0, 99, ~5, 2, ~1, 2, ~1, 3, ~2, 1000002, ~1000001]); -val test4b = chkminmax "test4b" ceil [rminInt-0.9] [rmaxInt-0.1]; +val test4a = tst "test4a" (map ceil args + = [0, 99, ~5, 2, ~1, 2, ~1, 3, ~2, 1000002, ~1000001]) + +val test4b = chksmallbig "test4b" ceil [rsmallInt-0.9] [rbigInt-0.1] +val test4c = map (chkfail "test4c" ceil) [rminInt-2000.0, rmaxInt+2000.0] -val test4c = map (chkfail "test4c" ceil) [rminInt-1.0, rmaxInt+0.1]; +val test5a = check(map floor args + = [0, 99, ~5, 1, ~2, 1, ~2, 2, ~3, 1000001, ~1000002]) -val test5a = check(map floor args - = [0, 99, ~5, 1, ~2, 1, ~2, 2, ~3, 1000001, ~1000002]); -val test5b = chkminmax "test5b" floor [rminInt+0.1] [rmaxInt+0.9]; -val test5c = map (chkfail "test5c" floor) [rminInt-0.1, rmaxInt+1.0]; +val test5b = chksmallbig "test5b" floor [rsmallInt+0.1] [rbigInt+0.9] +val test5c = map (chkfail "test5c" floor) [rminInt-2000.0, rmaxInt+2000.0] -val test6a = tst "test6a" (map trunc args - = [0, 99, ~5, 1, ~1, 1, ~1, 2, ~2, 1000001, ~1000001]); -val test6b = chkminmax "test6b" trunc [rminInt-0.9] [rmaxInt+0.9]; +val test6a = tst "test6a" (map trunc args + = [0, 99, ~5, 1, ~1, 1, ~1, 2, ~2, 1000001, ~1000001]) + +val test6b = chksmallbig "test6b" trunc [rsmallInt-0.9] [rbigInt+0.9]; val test6c = map (chkfail "test6c" trunc) [rminInt-1.0, rmaxInt+1.0]; val test7a = tst "test7a" (map round args = [0, 99, ~5, 1, ~1, 2, ~2, 2, ~2, 1000001, ~1000001]); -val test7b = chkminmax "test7b" round [rminInt-0.5, rmaxInt+0.4] -val test7c = map (chkfail "test7c" round) [rminInt-0.6, rmaxInt+0.5]; + +val test7b = chksmallbig "test7b" round [rsmallInt-0.5] [rbigInt+0.4] +val test7c = map (chkfail "test7c" round) [rminInt-2000.0, rmaxInt+2000.0]; end val test8 = tst "test8" (0.0 == real 0 andalso 2.0 == real 2 andalso ~2.0 == real ~2); -fun chk(s, r) = - let val eps = abs r * 1E~10 - in - tst' "chk" (fn _ => +fun chk(s, r) = + let val eps = abs r * 1E~10 + in + tst' "chk" (fn _ => case fromString s of SOME res => abs(res - r) <= eps | NONE => false) end -val test9a = +val test9a = List.map chk[("12.", 12.0), ("12.E", 12.0), ("12.E+", 12.0), @@ -107,22 +114,22 @@ val test9a = ("12E+", 12.0), ("12E-", 12.0)]; -val test9b = +val test9b = List.map chk[("0", 0.0), ("156", 156.0), - ("+156", 156.0), - ("~156", ~156.0), - ("-156", ~156.0), - ("156.25", 156.25), - ("+156.25", 156.25), - ("~156.25", ~156.25), + ("+156", 156.0), + ("~156", ~156.0), + ("-156", ~156.0), + ("156.25", 156.25), + ("+156.25", 156.25), + ("~156.25", ~156.25), ("-156.25", ~156.25), (".25", 0.25), ("+.25", 0.25), ("~.25", ~0.25), ("-.25", ~0.25)]; -val test9c = +val test9c = List.map chk[ ("156E024", 156E024), ("+156E024", 156E024), ("~156E024", ~156E024), @@ -136,7 +143,7 @@ val test9c = ("~.25E024", ~0.25E024), ("-.25E024", ~0.25E024)]; -val test9d = +val test9d = List.map chk[ ("156E+024", 156E024), ("+156E+024", 156E024), ("~156E+024", ~156E024), @@ -150,7 +157,7 @@ val test9d = ("~.25E+024", ~0.25E024), ("-.25E+024", ~0.25E024)]; -val test9e = +val test9e = List.map chk[ ("156E~024", 156E~024), ("+156E~024", 156E~024), ("~156E~024", ~156E~024), @@ -164,7 +171,7 @@ val test9e = ("~.25E~024", ~0.25E~024), ("-.25E~024", ~0.25E~024)]; -val test9f = +val test9f = List.map chk[ ("156E-024", 156E~024), ("+156E-024", 156E~024), ("~156E-024", ~156E~024), @@ -178,7 +185,7 @@ val test9f = ("~.25E-024", ~0.25E~024), ("-.25E-024", ~0.25E~024)]; -val test9g = +val test9g = List.map chk[ ("156e024", 156e024), ("+156e024", 156e024), ("~156e024", ~156e024), @@ -192,7 +199,7 @@ val test9g = ("~.25e024", ~0.25e024), ("-.25e024", ~0.25e024)]; -val test9h = +val test9h = List.map chk[ ("156e+024", 156e024), ("+156e+024", 156e024), ("~156e+024", ~156e024), @@ -206,7 +213,7 @@ val test9h = ("~.25e+024", ~0.25e024), ("-.25e+024", ~0.25e024)]; -val test9i = +val test9i = List.map chk[ ("156e~024", 156e~024), ("+156e~024", 156e~024), ("~156e~024", ~156e~024), @@ -220,7 +227,7 @@ val test9i = ("~.25e~024", ~0.25e~024), ("-.25e~024", ~0.25e~024)]; -val test9j = +val test9j = List.map chk[ ("156e-024", 156e~024), ("+156e-024", 156e~024), ("~156e-024", ~156e~024), @@ -236,38 +243,38 @@ val test9j = fun chk2 s = tst0 "chk2" (case fromString s of NONE => "OK" | _ => "WRONG") -val test10 = - List.map chk2 - ["e10", "E10", - "+e10", "+E10", - "~e10", "~E10", +val test10 = + List.map chk2 + ["e10", "E10", + "+e10", "+E10", + "~e10", "~E10", "-e10", "-E10"]; (* Note: There is some unclarity concerning rounding. Should 1.45, rounded to two significant digits, be "1.4" (nearest even digit) or "1.5" (new greater digit) in case of a tie? PS 1996-05-16 *) -val test11a = +val test11a = tst0 "test11a" ((fmt (StringCvt.FIX (SOME ~1)) 12.3456; "WRONG") handle Size => "OK" | _ => "WRONG") -val test11b = +val test11b = tst0 "test11b" ((fmt (StringCvt.FIX (SOME 100000)) 12.3456) handle Size => "OK" | _ => "WRONG") -fun chkFIX (s,r, s0, s1, s2, s6) = +fun chkFIX (s,r, s0, s1, s2, s6) = tst ("chkFIX."^s)(fmt (StringCvt.FIX (SOME 0)) r = s0 andalso fmt (StringCvt.FIX (SOME 1)) r = s1 andalso fmt (StringCvt.FIX (SOME 2)) r = s2 andalso fmt (StringCvt.FIX (SOME 6)) r = s6 andalso fmt (StringCvt.FIX NONE) r = s6) -fun chkFIX' (s,r, s0, s1, s2, s6) = +fun chkFIX' (s,r, s0, s1, s2, s6) = (chkFIX(s,r, s0, s1, s2, s6); if r == 0.0 then () else chkFIX(s^"~",~r, "~"^s0, "~"^s1, "~"^s2, "~"^s6)) -val test11c = +val test11c = List.app chkFIX' [("a",0.0, "0", "0.0", "0.00", "0.000000"), ("b",1.0, "1", "1.0", "1.00", "1.000000"), @@ -277,7 +284,7 @@ val test11c = ("f",1.6, "2", "1.6", "1.60", "1.600000"), ("g",1.45, "1", "1.4", "1.45", "1.450000"), ("h",3.141592653589, "3", "3.1", "3.14", "3.141593"), - ("j",91827364509182.0, "91827364509182", "91827364509182.0", + ("j",91827364509182.0, "91827364509182", "91827364509182.0", "91827364509182.00", "91827364509182.000000")] local val r = 91827364509182.0 @@ -295,27 +302,27 @@ in val test11h = tst "test11h" (fmt (StringCvt.FIX NONE) r = s6) end -val test12a = +val test12a = tst0 "test12a" ((fmt (StringCvt.SCI (SOME ~1)) 12.3456; "WRONG") handle Size => "OK" | _ => "WRONG") -val test12b = +val test12b = tst0 "test12b" ((fmt (StringCvt.SCI (SOME 100000)) 12.3456) handle Size => "OK" | _ => "WRONG") -fun chkSCI (r, s0, s1, s2, s6) = +fun chkSCI (r, s0, s1, s2, s6) = fmt (StringCvt.SCI (SOME 0)) r = s0 andalso fmt (StringCvt.SCI (SOME 1)) r = s1 andalso fmt (StringCvt.SCI (SOME 2)) r = s2 andalso fmt (StringCvt.SCI (SOME 6)) r = s6 andalso fmt (StringCvt.SCI NONE) r = s6; -fun chkSCI' (r, s0, s1, s2, s6) = - chkSCI(r, s0, s1, s2, s6) +fun chkSCI' (r, s0, s1, s2, s6) = + chkSCI(r, s0, s1, s2, s6) andalso (r == 0.0 orelse chkSCI(~r, "~"^s0, "~"^s1, "~"^s2, "~"^s6)); -val test12c = - tst' "test12c" (fn _ => +val test12c = + tst' "test12c" (fn _ => List.all chkSCI' [(0.0, "0E00", "0.0E00", "0.00E00", "0.000000E00"), (0.0012345678, "1E~03", "1.2E~03", "1.23E~03", "1.234568E~03"), @@ -328,15 +335,15 @@ val test12c = (3.141592653589, "3E00", "3.1E00", "3.14E00", "3.141593E00"), (91827364509182.0, "9E13", "9.2E13", "9.18E13", "9.182736E13")]); -val test13a = +val test13a = tst0 "test13a" ((fmt (StringCvt.GEN (SOME 0)) 12.3456; "WRONG") handle Size => "OK" | _ => "WRONG") -val test13b = +val test13b = tst0 "test13b" ((fmt (StringCvt.GEN (SOME 100000)) 12.3456) handle Size => "OK" | _ => "WRONG") -fun chkGEN (r, s1, s2, s6, s12) = +fun chkGEN (r, s1, s2, s6, s12) = fmt (StringCvt.GEN (SOME 1)) r = s1 andalso fmt (StringCvt.GEN (SOME 2)) r = s2 andalso fmt (StringCvt.GEN (SOME 6)) r = s6 @@ -344,16 +351,16 @@ fun chkGEN (r, s1, s2, s6, s12) = andalso fmt (StringCvt.GEN NONE) r = s12 andalso toString r = s12; -fun chkGEN' (r, s1, s2, s6, s12) = - chkGEN(r, s1, s2, s6, s12) - andalso (r == 0.0 orelse +fun chkGEN' (r, s1, s2, s6, s12) = + chkGEN(r, s1, s2, s6, s12) + andalso (r == 0.0 orelse chkGEN(~r, "~"^s1, "~"^s2, "~"^s6, "~"^s12)); -val test13c = +val test13c = tst' "test13c" (fn _ => List.all chkGEN' [(0.0, "0.0", "0.0", "0.0", "0.0"), - (0.0012345678, "0.001", "0.0012", "0.00123457", + (0.0012345678, "0.001", "0.0012", "0.00123457", "0.0012345678"), (1.0, "1.0", "1.0", "1.0", "1.0"), (1.4, "1.0", "1.4", "1.4", "1.4"), @@ -362,11 +369,11 @@ val test13c = (1.6, "2.0", "1.6", "1.6", "1.6"), (1.45, "1.0", "1.4", "1.45", "1.45"), (3.141592653589, "3.0", "3.1", "3.14159", "3.14159265359"), - (91827364509182.0, "9E13", "9.2E13", "9.18274E13", + (91827364509182.0, "9E13", "9.2E13", "9.18274E13", "9.18273645092E13")]); end -(* +(* fun f r n = Real.fmt (StringCvt.GEN (SOME n)) r; fun ff r = map (f r) [1,2,6,12]; *) diff --git a/test/real.sml.out.ok b/test/real.sml.out.ok index c2f3d74c3..b63ce0890 100644 --- a/test/real.sml.out.ok +++ b/test/real.sml.out.ok @@ -14,6 +14,7 @@ test6b OK test6c OK test6c OK test7a OK +test7b OK test7c OK test7c OK test8 OK diff --git a/test/real_match.sml.out.ok b/test/real_match.sml.out.ok new file mode 100644 index 000000000..6ee43617b --- /dev/null +++ b/test/real_match.sml.out.ok @@ -0,0 +1 @@ +test: OK diff --git a/test/word.sml b/test/word.sml index f08c863a2..de11afa95 100644 --- a/test/word.sml +++ b/test/word.sml @@ -5,8 +5,8 @@ fun e1 seq e2 = e2; fun check b = if b then "OK" else "WRONG"; fun check' f = (if f () then "OK" else "WRONG") handle _ => "EXN"; -fun range (from, to) p = - let open Int +fun range (from, to) p = + let open Int in (from > to) orelse (p from) andalso (range (from+1, to) p) end; @@ -17,11 +17,11 @@ fun tst0 s s' = print (s ^ " \t" ^ s' ^ "\n"); fun tst s b = tst0 s (check b); fun tst' s f = tst0 s (check' f); -fun tstrange s bounds = (tst s) o range bounds +fun tstrange s bounds = (tst s) o range bounds (* test/word.sml -- some test cases for Word, appropriate for a two's - complement machine whose Int.precision = SOME 31 - PS 1995-03-19, 1995-07-12, 1995-11-06, 1996-04-01, 1996-10-01 + complement machine whose Int.precision = SOME 31 + PS 1995-03-19, 1995-07-12, 1995-11-06, 1996-04-01, 1996-10-01 modified to work for Int.precision = SOME 32 -- ME 1998-10-07 *) @@ -30,15 +30,15 @@ fun tstrange s bounds = (tst s) o range bounds use "auxil.sml"; *) -local +local (* Isn't this disgusting: *) - val [gt, lt, ge, le] = + val [gt, lt, ge, le] = [op>, op<, op>=, op<=] : (int * int -> bool) list - val [add, sub, mul, idiv, imod] = + val [add, sub, mul, idiv, imod] = [op+, op-, op*, op div, op mod] : (int * int -> int) list open Word; val op > = gt and op < = lt and op >= = ge and op <= = le; - val op + = add and op - = sub and op * = mul + val op + = add and op - = sub and op * = mul and op div = idiv and op mod = imod; val i2w = fromInt and w2i = toIntX; @@ -49,24 +49,24 @@ val test1 = checkrange (0, 1025) (fn i => i = w2i (i2w i)); val _ = pr_ln "test1" test1 -val test3 = checkrange (~1000, 1000) +val test3 = checkrange (~1000, 1000) (fn i => i = toIntX (i2w i)); val _ = pr_ln "test3" test3 -val test5a = checkrange (0,15) +val test5a = checkrange (0,15) (fn i => (i+960) div 2 * 2 + 1 = w2i (orb (i2w i, i2w 961))); val _ = pr_ln "test5a" test5a val test5b = checkrange (0,513) (fn i => i = w2i (orb (i2w i, i2w i))); val _ = pr_ln "test5b" test5b -val test6a = checkrange (0,15) +val test6a = checkrange (0,15) (fn i => i div 2 * 2 = w2i (andb (i2w i, i2w ~2))); val _ = pr_ln "test6a" test6a val test6b = checkrange (0,513) (fn i => i = w2i (andb (i2w i, i2w i))); val _ = pr_ln "test6b" test6b -val test7a = checkrange (0,15) +val test7a = checkrange (0,15) (fn i => i+960 = w2i (xorb (i2w i, i2w 960))); val _ = pr_ln "test7a" test7a val test7b = checkrange (0, 513) @@ -78,7 +78,7 @@ val test8b = check (0 = w2i (notb (i2w ~1))); val _ = pr_ln "test8b" test8b val maxposint = valOf Int.maxInt; val maxnegint = Int.~ maxposint - 1; -fun pwr2 0 = 1 +fun pwr2 0 = 1 | pwr2 n = 2 * pwr2 (n-1); fun rwp i 0 = i | rwp i n = rwp i (n-1) div 2; @@ -86,7 +86,7 @@ fun rwp i 0 = i val test9a = checkrange (0,29) (fn k => pwr2 k = w2i (<< (i2w 1, i2w k))); val _ = pr_ln "test9a" test9a -val test9b = checkrange (32,65) +val test9b = checkrange (64,127) (fn k => 0 = w2i (<< (i2w 1, i2w k))); val _ = pr_ln "test9b" test9b val test9c = check (maxnegint = w2i (<< (i2w 1, i2w (wordSize-1)))); (* wordSize-1 was 31 14/04/1999, Niels *) @@ -100,7 +100,7 @@ val _ = pr_ln "test9e" test9e val test9f = checkrange (0,65) (fn k => rwp maxposint k = w2i (>> (i2w maxposint, i2w k))); val _ = pr_ln "test9f" test9f -val test9g = checkrange (32,65) +val test9g = checkrange (64,127) (fn k => 0 = w2i (<< (i2w ~1, i2w k))); val _ = pr_ln "test9g" test9g val test9h = checkrange (1,65) @@ -119,7 +119,7 @@ val _ = pr_ln "test10c" test10c val test10d = checkrange (0,65) (fn k => rwp maxnegint k = toIntX (~>> (i2w maxnegint, i2w k))); val _ = pr_ln "test10d" test10d -local +local open Word in val test11a = check (i2w 256 > i2w 255); @@ -142,7 +142,7 @@ val test11i = check (i2w maxnegint < i2w ~1); val _ = pr_ln "test11i" test11i end; -local +local open Word in val test12a = checkrange(0, 300) (fn k => w2i (i2w k + i2w 17) = add(k, 17)); @@ -151,28 +151,28 @@ val test12b = checkrange(0, 300) (fn k => w2i (i2w k - i2w 17) = sub(k, 17)); val _ = pr_ln "test12b" test12b val test12c = checkrange(0, 300) (fn k => w2i (i2w k * i2w 17) = mul(k, 17)); val _ = pr_ln "test12c" test12c -val test12d = checkrange(0, 300) +val test12d = checkrange(0, 300) (fn k => w2i (i2w k div i2w 17) = idiv(k, 17)); val _ = pr_ln "test12d" test12d -val test12e = checkrange(0, 300) +val test12e = checkrange(0, 300) (fn k => w2i (i2w k mod i2w 17) = imod(k, 17)); val _ = pr_ln "test12e" test12e -val test12f = checkrange(0, 300) +val test12f = checkrange(0, 300) (fn k => w2i (i2w k + i2w maxnegint) = add(k, maxnegint)); val _ = pr_ln "test12f" test12f -val test12g = checkrange(0, 300) +val test12g = checkrange(0, 300) (fn k => w2i (i2w maxnegint - i2w k - i2w 1) = sub(maxposint,k)); val _ = pr_ln "test12g" test12g -val test12h = checkrange(0, 300) +val test12h = checkrange(0, 300) (fn k => w2i (i2w k * i2w maxnegint) = mul(imod(k, 2), maxnegint)); val _ = pr_ln "test12h" test12h -val test12i = checkrange(0, 300) +val test12i = checkrange(0, 300) (fn k => w2i (i2w k * i2w maxposint + i2w k) = mul(imod(k, 2), maxnegint)); val _ = pr_ln "test12i" test12i -val test12j = checkrange(0, 300) +val test12j = checkrange(0, 300) (fn k => w2i (i2w k div i2w ~1) = 0); val _ = pr_ln "test12j" test12j -val test12k = checkrange(0, 300) +val test12k = checkrange(0, 300) (fn k => w2i (i2w k mod i2w ~1) = k); val _ = pr_ln "test12k" test12k val test12l = check(w2i (i2w maxposint + i2w 1) = maxnegint); @@ -189,21 +189,21 @@ val _ = pr_ln "test12p" test12p val test12q = check(w2i (i2w ~1 mod i2w 10) = 7); val _ = pr_ln "test12q" test12q *) -val test12r = (i2w 17 div i2w 0 seq "WRONG") +val test12r = (i2w 17 div i2w 0 seq "WRONG") handle Div => "OK" | _ => "WRONG"; val _ = pr_ln "test12r" test12r -val test12s = (i2w 17 mod i2w 0 seq "WRONG") +val test12s = (i2w 17 mod i2w 0 seq "WRONG") handle Div => "OK" | _ => "WRONG"; val _ = pr_ln "test12s" test12s -fun chk f (s, r) = - check'(fn _ => +fun chk f (s, r) = + check'(fn _ => case f s of SOME res => res = i2w r | NONE => false) fun chkScan fmt = chk (StringCvt.scanString (scan fmt)) -val test13a = +val test13a = List.map (chk fromString) [("20Af", 8367), (" \n\t20AfGrap", 8367), @@ -220,13 +220,13 @@ val test13a = ("0wx ", 0), ("0wX ", 0)]; val _ = pr_ln "test13a" (concat test13a) -val test13b = +val test13b = List.map (fn s => case fromString s of NONE => "OK" | _ => "WRONG") - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", - "+1", "~1", "-1", "GG"]; + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+1", "~1", "-1", "GG"]; val _ = pr_ln "test13b" (concat test13b) -val test14a = +val test14a = List.map (chkScan StringCvt.DEC) [("10789", 10789), (" \n\t10789crap", 10789), @@ -243,13 +243,13 @@ val test14a = ("0wx ", 0), ("0wX ", 0)]; val _ = pr_ln "test14a" (concat test14a) -val test14b = - List.map (fn s => case StringCvt.scanString (scan StringCvt.DEC) s +val test14b = + List.map (fn s => case StringCvt.scanString (scan StringCvt.DEC) s of NONE => "OK" | _ => "WRONG") - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", - "+1", "~1", "-1", "ff"]; + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+1", "~1", "-1", "ff"]; val _ = pr_ln "test14b" (concat test14b) -val test15a = +val test15a = List.map (chkScan StringCvt.BIN) [("10010", 18), (" \n\t10010crap", 18), @@ -266,13 +266,13 @@ val test15a = ("0wx ", 0), ("0wX ", 0)]; val _ = pr_ln "test15a" (concat test15a) -val test15b = - List.map (fn s => case StringCvt.scanString (scan StringCvt.BIN) s +val test15b = + List.map (fn s => case StringCvt.scanString (scan StringCvt.BIN) s of NONE => "OK" | _ => "WRONG") - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", "+1", "~1", "-1", "2", "8", "ff"]; val _ = pr_ln "test15b" (concat test15b) -val test16a = +val test16a = List.map (chkScan StringCvt.OCT) [("2071", 1081), (" \n\t2071crap", 1081), @@ -289,13 +289,13 @@ val test16a = ("0wx ", 0), ("0wX ", 0)]; val _ = pr_ln "test16a" (concat test16a) -val test16b = - List.map (fn s => case StringCvt.scanString (scan StringCvt.OCT) s +val test16b = + List.map (fn s => case StringCvt.scanString (scan StringCvt.OCT) s of NONE => "OK" | _ => "WRONG") - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", "+1", "~1", "-1", "8", "ff"]; val _ = pr_ln "test16b" (concat test16b) -val test17a = +val test17a = List.map (chkScan StringCvt.HEX) [("20Af", 8367), (" \n\t20AfGrap", 8367), ("0wx20Af", 8367), (" \n\t0wx20AfGrap", 8367), @@ -312,37 +312,37 @@ val test17a = ("0wx1", 1), ("0wX1", 1)]; val _ = pr_ln "test17a" (concat test17a) -val test17b = - List.map (fn s => case StringCvt.scanString (scan StringCvt.HEX) s +val test17b = + List.map (fn s => case StringCvt.scanString (scan StringCvt.HEX) s of NONE => "OK" | _ => "WRONG") - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", "+1", "~1", "-1"]; val _ = pr_ln "test17b" (concat test17b) end; -local - fun fromToString i = +local + fun fromToString i = fromString (toString (fromInt i)) = SOME (fromInt i); - fun scanFmt radix i = + fun scanFmt radix i = let val w = fromInt i val s = fmt radix w in StringCvt.scanString (scan radix) s = SOME w end; in -val test18 = +val test18 = check'(fn _ => range (0, 1200) fromToString); val _ = pr_ln "test18" test18 -val test19 = +val test19 = check'(fn _ => range (0, 1200) (scanFmt StringCvt.BIN)); val _ = pr_ln "test19" test19 -val test20 = +val test20 = check'(fn _ => range (0, 1200) (scanFmt StringCvt.OCT)); val _ = pr_ln "test20" test20 -val test21 = +val test21 = check'(fn _ => range (0, 1200) (scanFmt StringCvt.DEC)); val _ = pr_ln "test21" test21 -val test22 = +val test22 = check'(fn _ => range (0, 1200) (scanFmt StringCvt.HEX)); val _ = pr_ln "test22" test22 end diff --git a/test/word31.sml b/test/word31.sml index c55008e15..99e0d1b11 100644 --- a/test/word31.sml +++ b/test/word31.sml @@ -5,8 +5,8 @@ fun e1 seq e2 = e2; fun check b = if b then "OK" else "WRONG"; fun check' f = (if f () then "OK" else "WRONG") handle _ => "EXN"; -fun range (from, to) p = - let open Int +fun range (from, to) p = + let open Int in (from > to) orelse (p from) andalso (range (from+1, to) p) end; @@ -18,26 +18,26 @@ fun tst0 s s' = print (s ^ " \t" ^ s' ^ "\n"); fun tst s b = tst0 s (check b); fun tst' s f = tst0 s (check' f); -fun tstrange s bounds = (tst s) o range bounds +fun tstrange s bounds = (tst s) o range bounds (* test/word.sml -- some test cases for Word, appropriate for a two's complement representation with Word.wordSize = 31 - PS 1995-03-19, 1995-07-12, 1995-11-06, 1996-04-01, 1996-10-01 + PS 1995-03-19, 1995-07-12, 1995-11-06, 1996-04-01, 1996-10-01 ME 2001-04-26 *) -local +local (* Isn't this disgusting: *) - val [gt, lt, ge, le] = + val [gt, lt, ge, le] = [op>, op<, op>=, op<=] : (int * int -> bool) list - val [add, sub, mul, idiv, imod] = + val [add, sub, mul, idiv, imod] = [op+, op-, op*, op div, op mod] : (int * int -> int) list - open Word31; - val op > = gt and op < = lt and op >= = ge and op <= = le; - val op + = add and op - = sub and op * = mul - and op div = idiv and op mod = imod; + open Word31 + val op > = gt and op < = lt and op >= = ge and op <= = le + val op + = add and op - = sub and op * = mul + and op div = idiv and op mod = imod val i2w = fromInt - and w2i = toIntX; + and w2i = toIntX fun pr_ln s s' = print (s ^ ": " ^ s' ^ "\n") in @@ -45,24 +45,24 @@ val test1 = checkrange (0, 1025) (fn i => i = w2i (i2w i)); val _ = pr_ln "test1" test1 -val test3 = checkrange (~1000, 1000) +val test3 = checkrange (~1000, 1000) (fn i => i = toIntX (i2w i)); val _ = pr_ln "test3" test3 -val test5a = checkrange (0,15) +val test5a = checkrange (0,15) (fn i => (i+960) div 2 * 2 + 1 = w2i (orb (i2w i, i2w 961))); val _ = pr_ln "test5a" test5a val test5b = checkrange (0,513) (fn i => i = w2i (orb (i2w i, i2w i))); val _ = pr_ln "test5b" test5b -val test6a = checkrange (0,15) +val test6a = checkrange (0,15) (fn i => i div 2 * 2 = w2i (andb (i2w i, i2w ~2))); val _ = pr_ln "test6a" test6a val test6b = checkrange (0,513) (fn i => i = w2i (andb (i2w i, i2w i))); val _ = pr_ln "test6b" test6b -val test7a = checkrange (0,15) +val test7a = checkrange (0,15) (fn i => i+960 = w2i (xorb (i2w i, i2w 960))); val _ = pr_ln "test7a" test7a val test7b = checkrange (0, 513) @@ -74,7 +74,7 @@ val test8b = check (0 = w2i (notb (i2w ~1))); val _ = pr_ln "test8b" test8b val maxposint = 1073741823 val maxnegint = Int.~ maxposint - 1; -fun pwr2 0 = 1 +fun pwr2 0 = 1 | pwr2 n = 2 * pwr2 (n-1); fun rwp i 0 = i | rwp i n = rwp i (n-1) div 2; @@ -115,7 +115,7 @@ val _ = pr_ln "test10c" test10c val test10d = checkrange (0,65) (fn k => rwp maxnegint k = toIntX (~>> (i2w maxnegint, Word.fromInt k))); val _ = pr_ln "test10d" test10d -local +local open Word31 in val test11a = check (i2w 256 > i2w 255); @@ -138,7 +138,7 @@ val test11i = check (i2w maxnegint < i2w ~1); val _ = pr_ln "test11i" test11i end; -local +local open Word31 in val test12a = checkrange(0, 300) (fn k => w2i (i2w k + i2w 17) = add(k, 17)); @@ -147,28 +147,28 @@ val test12b = checkrange(0, 300) (fn k => w2i (i2w k - i2w 17) = sub(k, 17)); val _ = pr_ln "test12b" test12b val test12c = checkrange(0, 300) (fn k => w2i (i2w k * i2w 17) = mul(k, 17)); val _ = pr_ln "test12c" test12c -val test12d = checkrange(0, 300) +val test12d = checkrange(0, 300) (fn k => w2i (i2w k div i2w 17) = idiv(k, 17)); val _ = pr_ln "test12d" test12d -val test12e = checkrange(0, 300) +val test12e = checkrange(0, 300) (fn k => w2i (i2w k mod i2w 17) = imod(k, 17)); val _ = pr_ln "test12e" test12e -val test12f = checkrange(0, 300) +val test12f = checkrange(0, 300) (fn k => w2i (i2w k + i2w maxnegint) = add(k, maxnegint)); val _ = pr_ln "test12f" test12f -val test12g = checkrange(0, 300) +val test12g = checkrange(0, 300) (fn k => w2i (i2w maxnegint - i2w k - i2w 1) = sub(maxposint,k)); val _ = pr_ln "test12g" test12g -val test12h = checkrange(0, 300) +val test12h = checkrange(0, 300) (fn k => w2i (i2w k * i2w maxnegint) = mul(imod(k, 2), maxnegint)); val _ = pr_ln "test12h" test12h -val test12i = checkrange(0, 300) +val test12i = checkrange(0, 300) (fn k => w2i (i2w k * i2w maxposint + i2w k) = mul(imod(k, 2), maxnegint)); val _ = pr_ln "test12i" test12i -val test12j = checkrange(0, 300) +val test12j = checkrange(0, 300) (fn k => w2i (i2w k div i2w ~1) = 0); val _ = pr_ln "test12j" test12j -val test12k = checkrange(0, 300) +val test12k = checkrange(0, 300) (fn k => w2i (i2w k mod i2w ~1) = k); val _ = pr_ln "test12k" test12k val test12l = check(w2i (i2w maxposint + i2w 1) = maxnegint); @@ -183,21 +183,21 @@ val test12p = check(w2i (i2w ~1 div i2w 100) = idiv(maxposint, 50)); val _ = pr_ln "test12p" test12p val test12q = check(w2i (i2w ~1 mod i2w 10) = 7); val _ = pr_ln "test12q" test12q -val test12r = (i2w 17 div i2w 0 seq "WRONG") +val test12r = (i2w 17 div i2w 0 seq "WRONG") handle Div => "OK" | _ => "WRONG"; val _ = pr_ln "test12r" test12r -val test12s = (i2w 17 mod i2w 0 seq "WRONG") +val test12s = (i2w 17 mod i2w 0 seq "WRONG") handle Div => "OK" | _ => "WRONG"; val _ = pr_ln "test12s" test12s -fun chk f (s, r) = - check'(fn _ => +fun chk f (s, r) = + check'(fn _ => case f s of SOME res => res = i2w r | NONE => false) fun chkScan fmt = chk (StringCvt.scanString (scan fmt)) -val test13a = +val test13a = List.map (chk fromString) [("20Af", 8367), (" \n\t20AfGrap", 8367), @@ -214,13 +214,13 @@ val test13a = ("0wx ", 0), ("0wX ", 0)]; val _ = pr_ln "test13a" (concat test13a) -val test13b = +val test13b = List.map (fn s => case fromString s of NONE => "OK" | _ => "WRONG") - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", - "+1", "~1", "-1", "GG"]; + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+1", "~1", "-1", "GG"]; val _ = pr_ln "test13b" (concat test13b) -val test14a = +val test14a = List.map (chkScan StringCvt.DEC) [("10789", 10789), (" \n\t10789crap", 10789), @@ -237,13 +237,13 @@ val test14a = ("0wx ", 0), ("0wX ", 0)]; val _ = pr_ln "test14a" (concat test14a) -val test14b = - List.map (fn s => case StringCvt.scanString (scan StringCvt.DEC) s +val test14b = + List.map (fn s => case StringCvt.scanString (scan StringCvt.DEC) s of NONE => "OK" | _ => "WRONG") - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", - "+1", "~1", "-1", "ff"]; + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+1", "~1", "-1", "ff"]; val _ = pr_ln "test14b" (concat test14b) -val test15a = +val test15a = List.map (chkScan StringCvt.BIN) [("10010", 18), (" \n\t10010crap", 18), @@ -260,13 +260,13 @@ val test15a = ("0wx ", 0), ("0wX ", 0)]; val _ = pr_ln "test15a" (concat test15a) -val test15b = - List.map (fn s => case StringCvt.scanString (scan StringCvt.BIN) s +val test15b = + List.map (fn s => case StringCvt.scanString (scan StringCvt.BIN) s of NONE => "OK" | _ => "WRONG") - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", "+1", "~1", "-1", "2", "8", "ff"]; val _ = pr_ln "test15b" (concat test15b) -val test16a = +val test16a = List.map (chkScan StringCvt.OCT) [("2071", 1081), (" \n\t2071crap", 1081), @@ -283,13 +283,13 @@ val test16a = ("0wx ", 0), ("0wX ", 0)]; val _ = pr_ln "test16a" (concat test16a) -val test16b = - List.map (fn s => case StringCvt.scanString (scan StringCvt.OCT) s +val test16b = + List.map (fn s => case StringCvt.scanString (scan StringCvt.OCT) s of NONE => "OK" | _ => "WRONG") - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", "+1", "~1", "-1", "8", "ff"]; val _ = pr_ln "test16b" (concat test16b) -val test17a = +val test17a = List.map (chkScan StringCvt.HEX) [("20Af", 8367), (" \n\t20AfGrap", 8367), ("0wx20Af", 8367), (" \n\t0wx20AfGrap", 8367), @@ -306,37 +306,37 @@ val test17a = ("0wx1", 1), ("0wX1", 1)]; val _ = pr_ln "test17a" (concat test17a) -val test17b = - List.map (fn s => case StringCvt.scanString (scan StringCvt.HEX) s +val test17b = + List.map (fn s => case StringCvt.scanString (scan StringCvt.HEX) s of NONE => "OK" | _ => "WRONG") - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", "+1", "~1", "-1"]; val _ = pr_ln "test17b" (concat test17b) end; -local - fun fromToString i = +local + fun fromToString i = fromString (toString (fromInt i)) = SOME (fromInt i); - fun scanFmt radix i = + fun scanFmt radix i = let val w = fromInt i val s = fmt radix w in StringCvt.scanString (scan radix) s = SOME w end; in -val test18 = +val test18 = check'(fn _ => range (0, 1200) fromToString); val _ = pr_ln "test18" test18 -val test19 = +val test19 = check'(fn _ => range (0, 1200) (scanFmt StringCvt.BIN)); val _ = pr_ln "test19" test19 -val test20 = +val test20 = check'(fn _ => range (0, 1200) (scanFmt StringCvt.OCT)); val _ = pr_ln "test20" test20 -val test21 = +val test21 = check'(fn _ => range (0, 1200) (scanFmt StringCvt.DEC)); val _ = pr_ln "test21" test21 -val test22 = +val test22 = check'(fn _ => range (0, 1200) (scanFmt StringCvt.HEX)); val _ = pr_ln "test22" test22 end diff --git a/test/word32.sml b/test/word32.sml index cee184ce5..4c59a15b4 100644 --- a/test/word32.sml +++ b/test/word32.sml @@ -5,8 +5,8 @@ fun e1 seq e2 = e2; fun check b = if b then "OK" else "WRONG"; fun check' f = (if f () then "OK" else "WRONG") handle _ => "EXN"; -fun range (from, to) p = - let open Int32 +fun range (from, to) p = + let open Int32 in (from > to) orelse (p from) andalso (range (from+1, to) p) end; @@ -17,26 +17,26 @@ fun tst0 s s' = print (s ^ " \t" ^ s' ^ "\n"); fun tst s b = tst0 s (check b); fun tst' s f = tst0 s (check' f); -fun tstrange s bounds = (tst s) o range bounds +fun tstrange s bounds = (tst s) o range bounds (* test/word.sml -- some test cases for Word32, appropriate for a two's complement representation with Word.wordSize = 32 - PS 1995-03-19, 1995-07-12, 1995-11-06, 1996-04-01, 1996-10-01 + PS 1995-03-19, 1995-07-12, 1995-11-06, 1996-04-01, 1996-10-01 ME 2001-04-26 *) -local +local local open Int32 in (* Isn't this disgusting: *) - val [gt, lt, ge, le] = + val [gt, lt, ge, le] = [op>, op<, op>=, op<=] : (int * int -> bool) list - val [add, sub, mul, idiv, imod] = + val [add, sub, mul, idiv, imod] = [op+, op-, op*, op div, op mod] : (int * int -> int) list end open Word32 val op > = gt and op < = lt and op >= = ge and op <= = le; - val op + = add and op - = sub and op * = mul + val op + = add and op - = sub and op * = mul and op div = idiv and op mod = imod; val i2w = fromLargeInt o Int32.toLarge and w2i = Int32.fromLarge o toLargeIntX; @@ -47,24 +47,24 @@ val test1 = checkrange (0, 1025) (fn i => i = w2i (i2w i)); val _ = pr_ln "test1" test1 -val test3 = checkrange (~1000, 1000) +val test3 = checkrange (~1000, 1000) (fn i => i = Int32.fromLarge(toLargeIntX (i2w i))); val _ = pr_ln "test3" test3 -val test5a = checkrange (0,15) +val test5a = checkrange (0,15) (fn i => (i+960) div 2 * 2 + 1 = w2i (orb (i2w i, i2w 961))); val _ = pr_ln "test5a" test5a val test5b = checkrange (0,513) (fn i => i = w2i (orb (i2w i, i2w i))); val _ = pr_ln "test5b" test5b -val test6a = checkrange (0,15) +val test6a = checkrange (0,15) (fn i => i div 2 * 2 = w2i (andb (i2w i, i2w ~2))); val _ = pr_ln "test6a" test6a val test6b = checkrange (0,513) (fn i => i = w2i (andb (i2w i, i2w i))); val _ = pr_ln "test6b" test6b -val test7a = checkrange (0,15) +val test7a = checkrange (0,15) (fn i => i+960 = w2i (xorb (i2w i, i2w 960))); val _ = pr_ln "test7a" test7a val test7b = checkrange (0, 513) @@ -80,7 +80,7 @@ val maxposint = case Int32.maxInt val maxnegint = case Int32.minInt of SOME m => m | NONE => raise Fail "ERROR" -fun pwr2 0 = 1 +fun pwr2 0 = 1 | pwr2 n = 2 * pwr2 (n-1); fun rwp i 0 = i | rwp i n = rwp i (n-1) div 2; @@ -121,7 +121,7 @@ val _ = pr_ln "test10c" test10c val test10d = checkrange (0,65) (fn k => rwp maxnegint k = Int32.fromLarge(toLargeIntX (~>> (i2w maxnegint, Word.fromLargeInt (Int32.toLarge k))))); val _ = pr_ln "test10d" test10d -local +local open Word32 in val test11a = check (i2w 256 > i2w 255); @@ -144,7 +144,7 @@ val test11i = check (i2w maxnegint < i2w ~1); val _ = pr_ln "test11i" test11i end; -local +local open Word32 in val test12a = checkrange(0, 300) (fn k => w2i (i2w k + i2w 17) = add(k, 17)); @@ -153,28 +153,28 @@ val test12b = checkrange(0, 300) (fn k => w2i (i2w k - i2w 17) = sub(k, 17)); val _ = pr_ln "test12b" test12b val test12c = checkrange(0, 300) (fn k => w2i (i2w k * i2w 17) = mul(k, 17)); val _ = pr_ln "test12c" test12c -val test12d = checkrange(0, 300) +val test12d = checkrange(0, 300) (fn k => w2i (i2w k div i2w 17) = idiv(k, 17)); val _ = pr_ln "test12d" test12d -val test12e = checkrange(0, 300) +val test12e = checkrange(0, 300) (fn k => w2i (i2w k mod i2w 17) = imod(k, 17)); val _ = pr_ln "test12e" test12e -val test12f = checkrange(0, 300) +val test12f = checkrange(0, 300) (fn k => w2i (i2w k + i2w maxnegint) = add(k, maxnegint)); val _ = pr_ln "test12f" test12f -val test12g = checkrange(0, 300) +val test12g = checkrange(0, 300) (fn k => w2i (i2w maxnegint - i2w k - i2w 1) = sub(maxposint,k)); val _ = pr_ln "test12g" test12g -val test12h = checkrange(0, 300) +val test12h = checkrange(0, 300) (fn k => w2i (i2w k * i2w maxnegint) = mul(imod(k, 2), maxnegint)); val _ = pr_ln "test12h" test12h -val test12i = checkrange(0, 300) +val test12i = checkrange(0, 300) (fn k => w2i (i2w k * i2w maxposint + i2w k) = mul(imod(k, 2), maxnegint)); val _ = pr_ln "test12i" test12i -val test12j = checkrange(0, 300) +val test12j = checkrange(0, 300) (fn k => w2i (i2w k div i2w ~1) = 0); val _ = pr_ln "test12j" test12j -val test12k = checkrange(0, 300) +val test12k = checkrange(0, 300) (fn k => w2i (i2w k mod i2w ~1) = k); val _ = pr_ln "test12k" test12k val test12l = check(w2i (i2w maxposint + i2w 1) = maxnegint); @@ -190,21 +190,21 @@ val _ = pr_ln "test12p" test12p (*5 on 32bit; 7 on 31bit*) val test12q = check(w2i (i2w ~1 mod i2w 10) = 5); val _ = pr_ln "test12q" test12q -val test12r = (i2w 17 div i2w 0 seq "WRONG") +val test12r = (i2w 17 div i2w 0 seq "WRONG") handle Div => "OK" | _ => "WRONG"; val _ = pr_ln "test12r" test12r -val test12s = (i2w 17 mod i2w 0 seq "WRONG") +val test12s = (i2w 17 mod i2w 0 seq "WRONG") handle Div => "OK" | _ => "WRONG"; val _ = pr_ln "test12s" test12s -fun chk f (s, r) = - check'(fn _ => +fun chk f (s, r) = + check'(fn _ => case f s of SOME res => res = i2w r | NONE => false) fun chkScan fmt = chk (StringCvt.scanString (scan fmt)) -val test13a = +val test13a = List.map (chk fromString) [("20Af", 8367), (" \n\t20AfGrap", 8367), @@ -221,13 +221,13 @@ val test13a = ("0wx ", 0), ("0wX ", 0)]; val _ = pr_ln "test13a" (concat test13a) -val test13b = +val test13b = List.map (fn s => case fromString s of NONE => "OK" | _ => "WRONG") - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", - "+1", "~1", "-1", "GG"]; + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+1", "~1", "-1", "GG"]; val _ = pr_ln "test13b" (concat test13b) -val test14a = +val test14a = List.map (chkScan StringCvt.DEC) [("10789", 10789), (" \n\t10789crap", 10789), @@ -244,13 +244,13 @@ val test14a = ("0wx ", 0), ("0wX ", 0)]; val _ = pr_ln "test14a" (concat test14a) -val test14b = - List.map (fn s => case StringCvt.scanString (scan StringCvt.DEC) s +val test14b = + List.map (fn s => case StringCvt.scanString (scan StringCvt.DEC) s of NONE => "OK" | _ => "WRONG") - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", - "+1", "~1", "-1", "ff"]; + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+1", "~1", "-1", "ff"]; val _ = pr_ln "test14b" (concat test14b) -val test15a = +val test15a = List.map (chkScan StringCvt.BIN) [("10010", 18), (" \n\t10010crap", 18), @@ -267,13 +267,13 @@ val test15a = ("0wx ", 0), ("0wX ", 0)]; val _ = pr_ln "test15a" (concat test15a) -val test15b = - List.map (fn s => case StringCvt.scanString (scan StringCvt.BIN) s +val test15b = + List.map (fn s => case StringCvt.scanString (scan StringCvt.BIN) s of NONE => "OK" | _ => "WRONG") - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", "+1", "~1", "-1", "2", "8", "ff"]; val _ = pr_ln "test15b" (concat test15b) -val test16a = +val test16a = List.map (chkScan StringCvt.OCT) [("2071", 1081), (" \n\t2071crap", 1081), @@ -290,13 +290,13 @@ val test16a = ("0wx ", 0), ("0wX ", 0)]; val _ = pr_ln "test16a" (concat test16a) -val test16b = - List.map (fn s => case StringCvt.scanString (scan StringCvt.OCT) s +val test16b = + List.map (fn s => case StringCvt.scanString (scan StringCvt.OCT) s of NONE => "OK" | _ => "WRONG") - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", "+1", "~1", "-1", "8", "ff"]; val _ = pr_ln "test16b" (concat test16b) -val test17a = +val test17a = List.map (chkScan StringCvt.HEX) [("20Af", 8367), (" \n\t20AfGrap", 8367), ("0wx20Af", 8367), (" \n\t0wx20AfGrap", 8367), @@ -313,74 +313,39 @@ val test17a = ("0wx1", 1), ("0wX1", 1)]; val _ = pr_ln "test17a" (concat test17a) -val test17b = - List.map (fn s => case StringCvt.scanString (scan StringCvt.HEX) s +val test17b = + List.map (fn s => case StringCvt.scanString (scan StringCvt.HEX) s of NONE => "OK" | _ => "WRONG") - ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", "+1", "~1", "-1"]; val _ = pr_ln "test17b" (concat test17b) end; -local - fun fromToString i = +local + fun fromToString i = fromString (toString (fromLargeInt (Int32.toLarge i))) = SOME (fromLargeInt (Int32.toLarge i)); - fun scanFmt radix i = + fun scanFmt radix i = let val w = fromLargeInt (Int32.toLarge i) val s = fmt radix w in StringCvt.scanString (scan radix) s = SOME w end; in -val test18 = +val test18 = check'(fn _ => range (0, 1200) fromToString); val _ = pr_ln "test18" test18 -val test19 = +val test19 = check'(fn _ => range (0, 1200) (scanFmt StringCvt.BIN)); val _ = pr_ln "test19" test19 -val test20 = +val test20 = check'(fn _ => range (0, 1200) (scanFmt StringCvt.OCT)); val _ = pr_ln "test20" test20 -val test21 = +val test21 = check'(fn _ => range (0, 1200) (scanFmt StringCvt.DEC)); val _ = pr_ln "test21" test21 -val test22 = +val test22 = check'(fn _ => range (0, 1200) (scanFmt StringCvt.HEX)); val _ = pr_ln "test22" test22 end -local open Word32 - fun tagging () = Int.precision = SOME 31 -in - - val test23a = tst "test23a" ((Word32.toInt 0wxFFFFFFFF seq false) - handle Overflow => true) - - val test23b = tst "test23b" (Word32.toIntX 0wxFFFFFFFF = ~1) - - val test23c = tst "test23c" - (if tagging() then - ((Word32.toIntX 0wx7FFFFFFF seq false) - handle Overflow => true) - else - (SOME(Word32.toIntX 0wx7FFFFFFF) = Int.maxInt)) - - val test23d = tst "test23d" - (if tagging() then - ((Word32.toIntX 0wx80000000 seq false) - handle Overflow => true) - else - (SOME(Word32.toIntX 0wx80000000) = Int.minInt)) - - val test23e = tst "test23e" (Word32.toIntX 0wx3FFFFFFF = 1073741823) - - val test23f = tst "test23f" (Word32.toIntX 0wxc0000000 = ~1073741824) - - val test23g = tst "test23g" - (if tagging() then - ((Word32.toIntX 0wxbfffffff seq false) - handle Overflow => true) - else - (Word32.toIntX 0wxbfffffff = (Int.-(~1073741824, 1)))) - end -end; diff --git a/test/word32.sml.out.ok b/test/word32.sml.out.ok index d833e649b..bdfbeba12 100644 --- a/test/word32.sml.out.ok +++ b/test/word32.sml.out.ok @@ -63,10 +63,3 @@ test19: OK test20: OK test21: OK test22: OK -test23a OK -test23b OK -test23c OK -test23d OK -test23e OK -test23f OK -test23g OK diff --git a/test/word64.sml b/test/word64.sml new file mode 100644 index 000000000..9d569f1cc --- /dev/null +++ b/test/word64.sml @@ -0,0 +1,395 @@ +(* Auxiliary functions for test cases *) + +infix 1 seq +fun e1 seq e2 = e2; +fun check b = if b then "OK" else "WRONG"; +fun check' f = (if f () then "OK" else "WRONG") handle _ => "EXN"; + +fun range (from, to) p = + let open Int64 + in + (from > to) orelse (p from) andalso (range (from+1, to) p) + end; + +fun checkrange bounds f = (check o range bounds) f handle _ => "EXN" + +fun tst0 s s' = print (s ^ " \t" ^ s' ^ "\n"); +fun tst s b = tst0 s (check b); +fun tst' s f = tst0 s (check' f); + +fun tstrange s bounds = (tst s) o range bounds + +(* test/word.sml -- some test cases for Word32 and Word64 appropriate for a two's + complement representation with Word.wordSize = 32 + PS 1995-03-19, 1995-07-12, 1995-11-06, 1996-04-01, 1996-10-01 + ME 2001-04-26, mael 2020-04-22 +*) + +local + local open Int64 + in + (* Isn't this disgusting: *) + val [gt, lt, ge, le] = + [op>, op<, op>=, op<=] : (int * int -> bool) list + val [add, sub, mul, idiv, imod] = + [op+, op-, op*, op div, op mod] : (int * int -> int) list + end + open Word64 + val op > = gt and op < = lt and op >= = ge and op <= = le; + val op + = add and op - = sub and op * = mul + and op div = idiv and op mod = imod; + val i2w = fromLargeInt o Int64.toLarge + and w2i = Int64.fromLarge o toLargeIntX; + fun pr_ln s s' = print (s ^ ": " ^ s' ^ "\n") +in + +val test1 = checkrange (0, 1025) + (fn i => i = w2i (i2w i)); +val _ = pr_ln "test1" test1 + +val test3 = checkrange (~1000, 1000) + (fn i => i = Int64.fromLarge(toLargeIntX (i2w i))); +val _ = pr_ln "test3" test3 + +val test5a = checkrange (0,15) + (fn i => (i+960) div 2 * 2 + 1 + = w2i (orb (i2w i, i2w 961))); +val _ = pr_ln "test5a" test5a +val test5b = checkrange (0,513) + (fn i => i = w2i (orb (i2w i, i2w i))); +val _ = pr_ln "test5b" test5b +val test6a = checkrange (0,15) + (fn i => i div 2 * 2 = w2i (andb (i2w i, i2w ~2))); +val _ = pr_ln "test6a" test6a +val test6b = checkrange (0,513) + (fn i => i = w2i (andb (i2w i, i2w i))); +val _ = pr_ln "test6b" test6b +val test7a = checkrange (0,15) + (fn i => i+960 = w2i (xorb (i2w i, i2w 960))); +val _ = pr_ln "test7a" test7a +val test7b = checkrange (0, 513) + (fn i => 0 = w2i (xorb (i2w i, i2w i))); +val _ = pr_ln "test7b" test7b +(* +val test8a = check (~1 = w2i (notb (i2w 0))); +val _ = pr_ln "test8a" test8a + +val test8b = check (0 = w2i (notb (i2w ~1))); +val _ = pr_ln "test8b" test8b +*) +val maxposint = case Int64.maxInt + of SOME m => m + | NONE => raise Fail "ERROR" +val maxnegint = case Int64.minInt + of SOME m => m + | NONE => raise Fail "ERROR" +fun pwr2 0 = 1 + | pwr2 n = 2 * pwr2 (n-1); +fun rwp i 0 = i + | rwp i n = rwp i (n-1) div 2; + +val test9a = checkrange (0,1) + (fn k => pwr2 k = w2i (<< (i2w 1, Word.fromLargeInt (Int64.toLarge k)))); +val _ = pr_ln "test9a" test9a +(* +val test9b = checkrange (32,65) + (fn k => 0 = w2i (<< (i2w 1, Word.fromLargeInt (Int64.toLarge k)))); +val _ = pr_ln "test9b" test9b +val test9c = check (maxnegint = w2i (<< (i2w 1, Word.fromInt (Int.-(wordSize,1))))); +val _ = pr_ln "test9c" test9c +*) +val test9d = checkrange (0, 1025) + (fn i => 2 * i = w2i (<< (i2w i, Word.fromLargeInt (Int64.toLarge 1)))); +val _ = pr_ln "test9d" test9d +val test9e = checkrange (0, 1025) + (fn i => i div 2 = w2i (>> (i2w i, Word.fromLargeInt (Int64.toLarge 1)))); +val _ = pr_ln "test9e" test9e +val test9f = checkrange (0,65) + (fn k => rwp maxposint k = w2i (>> (i2w maxposint, Word.fromLargeInt (Int64.toLarge k)))); +val _ = pr_ln "test9f" test9f +(* +val test9g = checkrange (32,65) + (fn k => 0 = w2i (<< (i2w ~1, Word.fromLargeInt (Int64.toLarge k)))); +val _ = pr_ln "test9g" test9g +*) +val test9h = checkrange (1,65) + (fn k => 0 = w2i (>> (i2w 1, Word.fromLargeInt (Int64.toLarge k)))); +val _ = pr_ln "test9h" test9h + +val test10a = checkrange (1,65) + (fn k => 0 = w2i (~>> (i2w 1, Word.fromLargeInt (Int64.toLarge k)))); +val _ = pr_ln "test10a" test10a +val test10b = checkrange (1,65) + (fn k => ~1 = w2i (~>> (i2w ~1, Word.fromLargeInt (Int64.toLarge k)))); +val _ = pr_ln "test10b" test10b +val test10c = checkrange (~513, 513) + (fn i => i div 2 = Int64.fromLarge(toLargeIntX (~>> (i2w i, Word.fromLargeInt (Int64.toLarge 1))))); +val _ = pr_ln "test10c" test10c +val test10d = checkrange (0,65) + (fn k => rwp maxnegint k = Int64.fromLarge(toLargeIntX (~>> (i2w maxnegint, Word.fromLargeInt (Int64.toLarge k))))); +val _ = pr_ln "test10d" test10d +local + open Word64 +in +val test11a = check (i2w 256 > i2w 255); +val _ = pr_ln "test11a" test11a +val test11b = check (i2w 0 < i2w ~1); +val _ = pr_ln "test11b" test11b +val test11c = check (i2w maxposint >= i2w maxposint); +val _ = pr_ln "test11c" test11c +val test11d = check (i2w maxnegint >= i2w 127); +val _ = pr_ln "test11d" test11d +val test11e = check (i2w 1 <= i2w 1); +val _ = pr_ln "test11e" test11e +val test11f = check (i2w 0 <= i2w 1); +val _ = pr_ln "test11f" test11f +val test11g = check (i2w 0 < i2w maxposint); +val _ = pr_ln "test11g" test11g +val test11h = check (i2w maxposint < i2w maxnegint); +val _ = pr_ln "test11h" test11h +val test11i = check (i2w maxnegint < i2w ~1); +val _ = pr_ln "test11i" test11i +end; + +local + open Word64 +in +val test12a = checkrange(0, 300) (fn k => w2i (i2w k + i2w 17) = add(k, 17)); +val _ = pr_ln "test12a" test12a +val test12b = checkrange(0, 300) (fn k => w2i (i2w k - i2w 17) = sub(k, 17)); +val _ = pr_ln "test12b" test12b +val test12c = checkrange(0, 300) (fn k => w2i (i2w k * i2w 17) = mul(k, 17)); +val _ = pr_ln "test12c" test12c +val test12d = checkrange(0, 300) + (fn k => w2i (i2w k div i2w 17) = idiv(k, 17)); +val _ = pr_ln "test12d" test12d +val test12e = checkrange(0, 300) + (fn k => w2i (i2w k mod i2w 17) = imod(k, 17)); +val _ = pr_ln "test12e" test12e +val test12f = checkrange(0, 300) + (fn k => w2i (i2w k + i2w maxnegint) = add(k, maxnegint)); +val _ = pr_ln "test12f" test12f +val test12g = checkrange(0, 300) + (fn k => w2i (i2w maxnegint - i2w k - i2w 1) = sub(maxposint,k)); +val _ = pr_ln "test12g" test12g +val test12h = checkrange(0, 300) + (fn k => w2i (i2w k * i2w maxnegint) = mul(imod(k, 2), maxnegint)); +val _ = pr_ln "test12h" test12h +val test12i = checkrange(0, 300) + (fn k => w2i (i2w k * i2w maxposint + i2w k) = mul(imod(k, 2), maxnegint)); +val _ = pr_ln "test12i" test12i +val test12j = checkrange(0, 300) + (fn k => w2i (i2w k div i2w ~1) = 0); +val _ = pr_ln "test12j" test12j +val test12k = checkrange(0, 300) + (fn k => w2i (i2w k mod i2w ~1) = k); +val _ = pr_ln "test12k" test12k +val test12l = check(w2i (i2w maxposint + i2w 1) = maxnegint); +val _ = pr_ln "test12l" test12l +val test12m = check(w2i (i2w maxnegint - i2w 1) = maxposint); +val _ = pr_ln "test12m" test12m +val test12n = check(w2i (i2w ~1 div i2w 2) = maxposint); +val _ = pr_ln "test12n" test12n +val test12o = check(w2i (i2w ~1 mod i2w 2) = 1); +val _ = pr_ln "test12o" test12o +val test12p = check(w2i (i2w ~1 div i2w 100) = idiv(maxposint, 50)); +val _ = pr_ln "test12p" test12p +(*5 on 32bit; 7 on 31bit*) +val test12q = check(w2i (i2w ~1 mod i2w 10) = 5); +val _ = pr_ln "test12q" test12q +val test12r = (i2w 17 div i2w 0 seq "WRONG") + handle Div => "OK" | _ => "WRONG"; +val _ = pr_ln "test12r" test12r +val test12s = (i2w 17 mod i2w 0 seq "WRONG") + handle Div => "OK" | _ => "WRONG"; +val _ = pr_ln "test12s" test12s +fun chk f (s, r) = + check'(fn _ => + case f s of + SOME res => res = i2w r + | NONE => false) + +fun chkScan fmt = chk (StringCvt.scanString (scan fmt)) + +val test13a = + List.map (chk fromString) + [("20Af", 8367), + (" \n\t20AfGrap", 8367), + ("0w20Af", 8367), + (" \n\t0w20AfGrap", 8367), + ("0", 0), + ("0w", 0), + ("0W1", 0), + ("0w ", 0), + ("0wx", 0), + ("0wX", 0), + ("0wx1", 1), + ("0wX1", 1), + ("0wx ", 0), + ("0wX ", 0)]; +val _ = pr_ln "test13a" (concat test13a) +val test13b = + List.map (fn s => case fromString s of NONE => "OK" | _ => "WRONG") + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+1", "~1", "-1", "GG"]; +val _ = pr_ln "test13b" (concat test13b) + +val test14a = + List.map (chkScan StringCvt.DEC) + [("10789", 10789), + (" \n\t10789crap", 10789), + ("0w10789", 10789), + (" \n\t0w10789crap", 10789), + ("0", 0), + ("0w", 0), + ("0W1", 0), + ("0w ", 0), + ("0wx", 0), + ("0wX", 0), + ("0wx1", 0), + ("0wX1", 0), + ("0wx ", 0), + ("0wX ", 0)]; +val _ = pr_ln "test14a" (concat test14a) +val test14b = + List.map (fn s => case StringCvt.scanString (scan StringCvt.DEC) s + of NONE => "OK" | _ => "WRONG") + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+1", "~1", "-1", "ff"]; +val _ = pr_ln "test14b" (concat test14b) +val test15a = + List.map (chkScan StringCvt.BIN) + [("10010", 18), + (" \n\t10010crap", 18), + ("0w10010", 18), + (" \n\t0w10010crap", 18), + ("0", 0), + ("0w", 0), + ("0W1", 0), + ("0w ", 0), + ("0wx", 0), + ("0wX", 0), + ("0wx1", 0), + ("0wX1", 0), + ("0wx ", 0), + ("0wX ", 0)]; +val _ = pr_ln "test15a" (concat test15a) +val test15b = + List.map (fn s => case StringCvt.scanString (scan StringCvt.BIN) s + of NONE => "OK" | _ => "WRONG") + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+1", "~1", "-1", "2", "8", "ff"]; +val _ = pr_ln "test15b" (concat test15b) +val test16a = + List.map (chkScan StringCvt.OCT) + [("2071", 1081), + (" \n\t2071crap", 1081), + ("0w2071", 1081), + (" \n\t0w2071crap", 1081), + ("0", 0), + ("0w", 0), + ("0W1", 0), + ("0w ", 0), + ("0wx", 0), + ("0wX", 0), + ("0wx1", 0), + ("0wX1", 0), + ("0wx ", 0), + ("0wX ", 0)]; +val _ = pr_ln "test16a" (concat test16a) +val test16b = + List.map (fn s => case StringCvt.scanString (scan StringCvt.OCT) s + of NONE => "OK" | _ => "WRONG") + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+1", "~1", "-1", "8", "ff"]; +val _ = pr_ln "test16b" (concat test16b) +val test17a = + List.map (chkScan StringCvt.HEX) + [("20Af", 8367), (" \n\t20AfGrap", 8367), + ("0wx20Af", 8367), (" \n\t0wx20AfGrap", 8367), + ("0wX20Af", 8367), (" \n\t0wX20AfGrap", 8367), + ("0x20Af", 8367), (" \n\t0x20AfGrap", 8367), + ("0X20Af", 8367), (" \n\t0X20AfGrap", 8367), + ("0", 0), + ("0w", 0), + ("0w ", 0), + ("0w1", 1), + ("0W1", 0), + ("0wx", 0), + ("0wX", 0), + ("0wx1", 1), + ("0wX1", 1)]; +val _ = pr_ln "test17a" (concat test17a) +val test17b = + List.map (fn s => case StringCvt.scanString (scan StringCvt.HEX) s + of NONE => "OK" | _ => "WRONG") + ["", "-", "~", "+", " \n\t", " \n\t-", " \n\t~", " \n\t+", + "+1", "~1", "-1"]; +val _ = pr_ln "test17b" (concat test17b) +end; + +local + fun fromToString i = + fromString (toString (fromLargeInt (Int64.toLarge i))) = SOME (fromLargeInt (Int64.toLarge i)); + + fun scanFmt radix i = + let val w = fromLargeInt (Int64.toLarge i) + val s = fmt radix w + in StringCvt.scanString (scan radix) s = SOME w end; + +in +val test18 = + check'(fn _ => range (0, 1200) fromToString); +val _ = pr_ln "test18" test18 +val test19 = + check'(fn _ => range (0, 1200) (scanFmt StringCvt.BIN)); +val _ = pr_ln "test19" test19 +val test20 = + check'(fn _ => range (0, 1200) (scanFmt StringCvt.OCT)); +val _ = pr_ln "test20" test20 +val test21 = + check'(fn _ => range (0, 1200) (scanFmt StringCvt.DEC)); +val _ = pr_ln "test21" test21 +val test22 = + check'(fn _ => range (0, 1200) (scanFmt StringCvt.HEX)); +val _ = pr_ln "test22" test22 +end + + +local open Word64 + fun tagging () = Int.precision = SOME 63 +in + + val test23a = tst "test23a" ((Word64.toInt 0wxFFFFFFFFFFFFFFFF seq false) + handle Overflow => true) + + val test23b = tst "test23b" (Word64.toIntX 0wxFFFFFFFFFFFFFFFF = ~1) + + val test23c = tst "test23c" + (if tagging() then + ((Word64.toIntX 0wx7FFFFFFFFFFFFFFF seq false) + handle Overflow => true) + else + (SOME(Word64.toIntX 0wx7FFFFFFFFFFFFFFF) = Int.maxInt)) + + val test23d = tst "test23d" + (if tagging() then + ((Word64.toIntX 0wx8000000000000000 seq false) + handle Overflow => true) + else + (SOME(Word64.toIntX 0wx8000000000000000) = Int.minInt)) + + val test23e = tst "test23e" (Word64.toIntX 0wx3FFFFFFFFFFFFFFF = 4611686018427387903) + + val test23f = tst "test23f" (Word64.toIntX 0wxc000000000000000 = ~4611686018427387904) + + val test23g = tst "test23g" + (if tagging() then + ((Word64.toIntX 0wxbfffffffffffffff seq false) + handle Overflow => true) + else + (Word64.toIntX 0wxbfffffffffffffff = (Int.-(~4611686018427387904, 1)))) + +end + +end diff --git a/test/word64.sml.out.ok b/test/word64.sml.out.ok new file mode 100644 index 000000000..09080a816 --- /dev/null +++ b/test/word64.sml.out.ok @@ -0,0 +1,67 @@ +test1: OK +test3: OK +test5a: OK +test5b: OK +test6a: OK +test6b: OK +test7a: OK +test7b: OK +test9a: OK +test9d: OK +test9e: OK +test9f: OK +test9h: OK +test10a: OK +test10b: OK +test10c: OK +test10d: OK +test11a: OK +test11b: OK +test11c: OK +test11d: OK +test11e: OK +test11f: OK +test11g: OK +test11h: OK +test11i: OK +test12a: OK +test12b: OK +test12c: OK +test12d: OK +test12e: OK +test12f: OK +test12g: OK +test12h: OK +test12i: OK +test12j: OK +test12k: OK +test12l: OK +test12m: OK +test12n: OK +test12o: OK +test12p: OK +test12q: OK +test12r: OK +test12s: OK +test13a: OKOKOKOKOKOKOKOKOKOKOKOKOKOK +test13b: OKOKOKOKOKOKOKOKOKOKOKOK +test14a: OKOKOKOKOKOKOKOKOKOKOKOKOKOK +test14b: OKOKOKOKOKOKOKOKOKOKOKOK +test15a: OKOKOKOKOKOKOKOKOKOKOKOKOKOK +test15b: OKOKOKOKOKOKOKOKOKOKOKOKOKOK +test16a: OKOKOKOKOKOKOKOKOKOKOKOKOKOK +test16b: OKOKOKOKOKOKOKOKOKOKOKOKOK +test17a: OKOKOKOKOKOKOKOKOKOKOKOKOKOKOKOKOKOKOK +test17b: OKOKOKOKOKOKOKOKOKOKOK +test18: OK +test19: OK +test20: OK +test21: OK +test22: OK +test23a OK +test23b OK +test23c OK +test23d OK +test23e OK +test23f OK +test23g OK