[MLton-devel] cvs commit: support for multiple integer, real, and word sizes

Stephen Weeks sweeks@users.sourceforge.net
Sun, 22 Jun 2003 21:59:03 -0700


sweeks      03/06/22 21:59:02

  Modified:    basis-library/misc primitive.sml
               basis-library/real real.sml
               benchmark benchmark-stubs.cm benchmark.cm
               bin      check-basis
               include  c-chunk.h c-main.h main.h x86-main.h
               mllex    mllex-stubs.cm mllex.cm
               mlprof   mlprof-stubs.cm mlprof.cm
               mlton    mlton-stubs-1997.cm mlton-stubs.cm mlton.cm
               mlton/ast ast-atoms.fun ast-const.fun ast-const.sig
                        prim-tycons.fun prim-tycons.sig record.fun
                        record.sig sources.cm
               mlton/atoms atoms.fun atoms.sig cases.fun cases.sig
                        const.fun const.sig hash-type.fun hash-type.sig
                        prim.fun prim.sig sources.cm tycon.fun tycon.sig
                        type-ops.fun type-ops.sig type.fun type.sig
               mlton/backend allocate-registers.fun backend.fun backend.sig
                        c-function.fun chunkify.fun limit-check.fun
                        machine-atoms.fun machine-atoms.sig machine.fun
                        machine.sig mtype.fun mtype.sig profile.fun
                        representation.fun representation.sig rssa.fun
                        rssa.sig runtime.fun runtime.sig signal-check.fun
                        sources.cm ssa-to-rssa.fun switch.fun switch.sig
               mlton/closure-convert abstract-value.fun closure-convert.fun
               mlton/codegen/c-codegen c-codegen.fun
               mlton/codegen/x86-codegen x86-codegen.fun
                        x86-mlton-basic.fun x86-mlton.fun x86-translate.fun
               mlton/core-ml lookup-constant.fun lookup-constant.sig
               mlton/front-end import.cm ml.grm ml.lex
               mlton/main compile.sml
               mlton/ssa analyze.fun analyze.sig common-subexp.fun
                        constant-propagation.fun direct-exp.fun
                        direct-exp.sig poly-equal.fun redundant-tests.fun
                        remove-unused.fun shrink.fun ssa-tree.fun
                        ssa-tree.sig type-check.fun useless.fun
               mlton/type-inference infer.fun infer.sig match-compile.fun
                        match-compile.sig type-env.fun type-env.sig
               mlton/xml implement-exceptions.fun monomorphise.fun
                        polyvariance.fun shrink.fun simplify-types.fun
                        type-check.fun xml-tree.fun xml-tree.sig
               mlyacc   mlyacc-stubs.cm mlyacc.cm
               runtime  Makefile gc.c mlton-basis.h
               runtime/Posix/Process exit.c sleep.c
               runtime/Posix/Signal Signal.c isPending.c
               runtime/basis IEEEReal.c Stdio.c
               runtime/basis/Int quot.c rem.c
               runtime/basis/MLton Callback.c exit.c
               runtime/basis/PackReal subVec.c update.c
               runtime/basis/Real class.c gdtoa.c isFinite.c isNan.c
                        isNormal.c nextAfter.c real.c round.c signBit.c
                        strtod.c
  Added:       mlton/ast int-size.fun int-size.sig real-size.fun
                        real-size.sig word-size.fun word-size.sig
               mlton/atoms int-x.fun int-x.sig real-x.fun real-x.sig
                        word-x.fun word-x.sig
               runtime  types.h
  Removed:     runtime/basis/Real const.S qequal.c
  Log:
  Added compiler support for multiple integer, real, and word sizes.
  This checkin just changes the compiler infrastructure.  It does not
  add the basis library modules.  There are also some still some holes,
  especially in the x86 codegen support.  Matthew, if you could take a
  look at those, that would be great.
  
  Everything that was there before is still supported, though, and all
  regressions and self compiles pass.
  
  The main new datatypes are:
  
  	datatype IntSize.t = I8 | I16 | I32 | I64
  	datatype RealSize.t = R32 | R64
  	datatype WordSize.t = W8 | W16 | W32
  
  Tycons and types have been extended so that they are parameterized
  over the appropriate sizes.
  
        val int: IntSize.t -> t
        val real: RealSize.t -> t
        val word: WordSize.t -> t
  
  There are also default values of each size (I32, R64, W32) and the
  corresponding default types.
  
  There are new modules for representing values of the various types at
  runtime: IntX.t, RealX.t, and WordX.t.  The front end and ast
  constants have been reworked to handle arbitrary size integers and
  words.  Const has been reworked, adding variants for each of the
  values, and replacing char with words of size W8 and string with word8
  vector
  
        datatype Const.t =
  	 Int of IntX.t
         | IntInf of IntInf.t
         | Real of RealX.t
         | Word of WordX.t
         | Word8Vector of Word8.t vector
  
  I didn't treat IntInf as another size of Int because they are almost
  always handled differently.
  
  Integer, Real and Word primitives are now parameterized over the size
  of value that they operate on.  The conversion operators have also
  been generalized.
  
  	datatype Prim.t =
  		...
  	     | Int_add of IntSize.t
  		...
  	     | Real_add of RealSize.t
  		...
  	     | Word_add of WordSize.t
  		...
  	     | Word_toIntX of WordSize.t * IntSize.t
  		...
  
  For such primitives, the prim name in the basis library now always has
  the size as part of the name, e.g.
  
  	_prim "Int32_addCheck": int * int -> int;
  
  Case expressions in all the ILs have had cases on chars removed and
  had cases on ints and words generalized to handle different sizes.
  
  That's about it.  The plan now is to add support for Int8, Int16,
  Int64, Real32, and Word16.  Hopefully, with all the infrastructure of
  this checkin in place, adding those will only require writing some SML
  basis library code and mucking with the codegen to implement the
  primitives.  I would like Word64, but that will take a little more
  work since there is no Word64 to bootstrap off of.
  
  Feel free to start implementing the module of your choice, but please
  announce it on the list first to avoid duplication of effort.

Revision  Changes    Path
1.56      +159 -93   mlton/basis-library/misc/primitive.sml

Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -r1.55 -r1.56
--- primitive.sml	19 Jun 2003 15:38:04 -0000	1.55
+++ primitive.sml	23 Jun 2003 04:58:53 -0000	1.56
@@ -17,22 +17,60 @@
 datatype bool = datatype bool
 type char = char
 type exn = exn
-type int = int
+structure Int8 =
+   struct
+      type int = int8
+   end
+structure Int16 =
+   struct
+      type int = int16
+   end
+structure Int32 =
+   struct
+      type int = int32
+   end
+structure Int64 =
+   struct
+      type int = int64
+   end
 type intInf = intInf
 datatype list = datatype list
 type pointer = pointer (* C integer, not SML heap pointer *)
-type real = real
+structure Real32 =
+   struct
+      type real = real32
+   end
+structure Real64 =
+   struct
+      type real = real64
+   end
 datatype ref = datatype ref
 type preThread = preThread
 type thread = thread
-type word = word
-type word8 = word8
-type word32 = word
+structure Word8 =
+   struct
+      type word = word8
+   end
+structure Word16 =
+   struct
+      type word = word16
+   end
+structure Word32 =
+   struct
+      type word = word32
+   end
 type 'a vector = 'a vector
 type 'a weak = 'a weak
 type string = char vector
 type nullString = string
 
+structure Int = Int32
+type int = Int.int
+structure Real = Real64
+type real = Real.real
+structure Word = Word32
+type word = Word.word
+
 exception Bind = Bind
 exception Fail of string
 exception Match = Match
@@ -56,7 +94,8 @@
       val errno = _ffi "MLton_errno": unit -> int;
       val halt = _prim "MLton_halt": int -> unit;
       val handlesSignals = _prim "MLton_handlesSignals": bool;
-      val installSignalHandler = _prim "MLton_installSignalHandler": unit -> unit;
+      val installSignalHandler =
+	 _prim "MLton_installSignalHandler": unit -> unit;
       val safe = _build_const "MLton_safe": bool;
       val touch = fn z => _prim "MLton_touch": 'a -> unit; z
       val usesCallcc: bool ref = ref false;
@@ -206,39 +245,38 @@
 	    val getRoundingMode = _ffi "IEEEReal_getRoundingMode": unit -> int;
 	 end
 
-      structure Int =
+      structure Int32 =
 	 struct
-	    type int = int
+	    type int = int32
 
-	    val *? = _prim "Int_mul": int * int -> int;
+	    val *? = _prim "Int32_mul": int * int -> int;
 	    val * =
 	       if detectOverflow
-		  then _prim "Int_mulCheck": int * int -> int;
+		  then _prim "Int32_mulCheck": int * int -> int;
 	       else *?
-	    val +? = _prim "Int_add": int * int -> int;
+	    val +? = _prim "Int32_add": int * int -> int;
 	    val + =
 	       if detectOverflow
-		  then _prim "Int_addCheck": int * int -> int;
+		  then _prim "Int32_addCheck": int * int -> int;
 	       else +?
-	    val -? = _prim "Int_sub": int * int -> int;
+	    val -? = _prim "Int32_sub": int * int -> int;
 	    val - =
 	       if detectOverflow
-		  then _prim "Int_subCheck": int * int -> int;
+		  then _prim "Int32_subCheck": int * int -> int;
 	       else -?
-	    val < = _prim "Int_lt": int * int -> bool;
-	    val <= = _prim "Int_le": int * int -> bool;
-	    val > = _prim "Int_gt": int * int -> bool;
-	    val >= = _prim "Int_ge": int * int -> bool;
-	    val geu = _prim "Int_geu": int * int -> bool;
-	    val gtu = _prim "Int_gtu": int * int -> bool;
-	    val quot = _prim "Int_quot": int * int -> int;
-	    val rem = _prim "Int_rem": int * int -> int;
-	    val ~? = _prim "Int_neg": int -> int; 
+	    val < = _prim "Int32_lt": int * int -> bool;
+	    val <= = _prim "Int32_le": int * int -> bool;
+	    val > = _prim "Int32_gt": int * int -> bool;
+	    val >= = _prim "Int32_ge": int * int -> bool;
+	    val quot = _prim "Int32_quot": int * int -> int;
+	    val rem = _prim "Int32_rem": int * int -> int;
+	    val ~? = _prim "Int32_neg": int -> int; 
 	    val ~ =
 	       if detectOverflow
-		  then _prim "Int_negCheck": int -> int;
+		  then _prim "Int32_negCheck": int -> int;
 	       else ~?
 	 end
+      structure Int = Int32
 
       structure Array =
 	 struct
@@ -259,8 +297,8 @@
 	    val andb = _prim "IntInf_andb": int * int * word -> int;
 	    val ~>> = _prim "IntInf_arshift": int * word * word -> int;
 	    val compare = _prim "IntInf_compare": int * int -> Int.int;
-	    val fromVector = _prim "IntInf_fromVector": word vector -> int;
-	    val fromWord = _prim "IntInf_fromWord": word -> int;
+	    val fromVector = _prim "WordVector_toIntInf": word vector -> int;
+	    val fromWord = _prim "Word_toIntInf": word -> int;
 	    val gcd = _prim "IntInf_gcd": int * int * word -> int;
 	    val << = _prim "IntInf_lshift": int * word * word -> int;
 	    val * = _prim "IntInf_mul": int * int * word -> int;
@@ -453,10 +491,13 @@
 	    val entryAddrType = _ffi "NetHostDB_Entry_addrType": unit -> int;
 	    val entryLength = _ffi "NetHostDB_Entry_length": unit -> int;
 	    val entryNumAddrs = _ffi "NetHostDB_Entry_numAddrs": unit -> int;
-	    val entryAddrsN = _ffi "NetHostDB_Entry_addrsN": int * pre_in_addr -> unit;
-	    val getByAddress = _ffi "NetHostDB_getByAddress": in_addr * int -> bool;
+	    val entryAddrsN =
+	       _ffi "NetHostDB_Entry_addrsN": int * pre_in_addr -> unit;
+	    val getByAddress =
+	       _ffi "NetHostDB_getByAddress": in_addr * int -> bool;
 	    val getByName = _ffi "NetHostDB_getByName": nullString -> bool;
-	    val getHostName = _ffi "NetHostDB_getHostName": char array * int -> int;
+	    val getHostName =
+	       _ffi "NetHostDB_getHostName": char array * int -> int;
 	 end
 
       structure NetProtDB =
@@ -501,7 +542,8 @@
       structure PackReal =
 	 struct
 	    val subVec = _ffi "PackReal_subVec": word8 vector * int -> real;
-	    val update = _ffi "PackReal_update": word8 array * int * real -> unit;
+	    val update =
+	       _ffi "PackReal_update": word8 array * int * real -> unit;
 	 end
 
       structure Ptrace =
@@ -538,61 +580,64 @@
 
       structure Real =
 	 struct
+	    type real = real64
+
 	    structure Math =
 	       struct
 		  type real = real
 		     
-		  val acos = _prim "Real_Math_acos": real -> real;
-		  val asin = _prim "Real_Math_asin": real -> real;
-		  val atan = _prim "Real_Math_atan": real -> real;
-		  val atan2 = _prim "Real_Math_atan2": real * real -> real;
-		  val cos = _prim "Real_Math_cos": real -> real;
-		  val cosh = _prim "Real_Math_cosh": real -> real;
-		  val e = _ffi "Real_Math_e": real;
-		  val exp = _prim "Real_Math_exp": real -> real;
-		  val ln = _prim "Real_Math_ln": real -> real;
-		  val log10 = _prim "Real_Math_log10": real -> real;
-		  val pi = _ffi "Real_Math_pi": real;
-		  val pow = _prim "Real_Math_pow": real * real -> real;
-		  val sin = _prim "Real_Math_sin": real -> real;
-		  val sinh = _prim "Real_Math_sinh": real -> real;
-		  val sqrt = _prim "Real_Math_sqrt": real -> real;
-		  val tan = _prim "Real_Math_tan": real -> real;
-		  val tanh = _prim "Real_Math_tanh": real -> real;
-	       end
-
-	    val * = _prim "Real_mul": real * real -> real;
-	    val *+ = _prim "Real_muladd": real * real * real -> real;
-	    val *- = _prim "Real_mulsub": real * real * real -> real;
-	    val + = _prim "Real_add": real * real -> real;
-	    val - = _prim "Real_sub": real * real -> real;
-	    val / = _prim "Real_div": real * real -> real;
-	    val < = _prim "Real_lt": real * real -> bool;
-	    val <= = _prim "Real_le": real * real -> bool;
-	    val == = _prim "Real_equal": real * real -> bool;
-	    val > = _prim "Real_gt": real * real -> bool;
-	    val >= = _prim "Real_ge": real * real -> bool;
-	    val ?= = _prim "Real_qequal": real * real -> bool;
-	    val abs = _prim "Real_abs": real -> real;
-	    val class = _ffi "Real_class": real -> int;
-	    val copySign = _prim "Real_copysign": real * real -> real;
-	    val frexp = _prim "Real_frexp": real * int ref -> real;
-	    val gdtoa = _ffi "Real_gdtoa": real * int * int * int ref -> cstring;
-	    val fromInt = _prim "Real_fromInt": int -> real;
-	    val isFinite = _ffi "Real_isFinite": real -> bool;
-	    val isNan = _ffi "Real_isNan": real -> bool;
-	    val isNormal = _ffi "Real_isNormal": real -> bool;
-	    val ldexp = _prim "Real_ldexp": real * int -> real;
-	    val maxFinite = _ffi "Real_maxFinite": real;
-	    val minNormalPos = _ffi "Real_minNormalPos": real;
-	    val minPos = _ffi "Real_minPos": real;
-	    val modf = _prim "Real_modf": real * real ref -> real;
-	    val nextAfter = _ffi "Real_nextAfter": real * real -> real;
-	    val round = _prim "Real_round": real -> real;
-	    val signBit = _ffi "Real_signBit": real -> bool;
-	    val strtod = _ffi "Real_strtod": nullString -> real;
-	    val toInt = _prim "Real_toInt": real -> int;
-	    val ~ = _prim "Real_neg": real -> real;
+		  val acos = _prim "Real64_Math_acos": real -> real;
+		  val asin = _prim "Real64_Math_asin": real -> real;
+		  val atan = _prim "Real64_Math_atan": real -> real;
+		  val atan2 = _prim "Real64_Math_atan2": real * real -> real;
+		  val cos = _prim "Real64_Math_cos": real -> real;
+		  val cosh = _ffi "cosh": real -> real;
+		  val e = _ffi "Real64_Math_e": real;
+		  val exp = _prim "Real64_Math_exp": real -> real;
+		  val ln = _prim "Real64_Math_ln": real -> real;
+		  val log10 = _prim "Real64_Math_log10": real -> real;
+		  val pi = _ffi "Real64_Math_pi": real;
+		  val pow = _ffi "pow": real * real -> real;
+		  val sin = _prim "Real64_Math_sin": real -> real;
+		  val sinh = _ffi "sinh": real -> real;
+		  val sqrt = _prim "Real64_Math_sqrt": real -> real;
+		  val tan = _prim "Real64_Math_tan": real -> real;
+		  val tanh = _ffi "tanh": real -> real;
+	       end
+
+	    val * = _prim "Real64_mul": real * real -> real;
+	    val *+ = _prim "Real64_muladd": real * real * real -> real;
+	    val *- = _prim "Real64_mulsub": real * real * real -> real;
+	    val + = _prim "Real64_add": real * real -> real;
+	    val - = _prim "Real64_sub": real * real -> real;
+	    val / = _prim "Real64_div": real * real -> real;
+	    val < = _prim "Real64_lt": real * real -> bool;
+	    val <= = _prim "Real64_le": real * real -> bool;
+	    val == = _prim "Real64_equal": real * real -> bool;
+	    val > = _prim "Real64_gt": real * real -> bool;
+	    val >= = _prim "Real64_ge": real * real -> bool;
+	    val ?= = _prim "Real64_qequal": real * real -> bool;
+	    val abs = _prim "Real64_abs": real -> real;
+	    val class = _ffi "Real64_class": real -> int;
+	    val copySign = _ffi "copysign": real * real -> real;
+	    val frexp = _ffi "frexp": real * int ref -> real;
+	    val gdtoa =
+	       _ffi "Real64_gdtoa": real * int * int * int ref -> cstring;
+	    val fromInt = _prim "Int32_toReal64": int -> real;
+	    val isFinite = _ffi "Real64_isFinite": real -> bool;
+	    val isNan = _ffi "Real64_isNan": real -> bool;
+	    val isNormal = _ffi "Real64_isNormal": real -> bool;
+	    val ldexp = _prim "Real64_ldexp": real * int -> real;
+	    val maxFinite = _ffi "Real64_maxFinite": real;
+	    val minNormalPos = _ffi "Real64_minNormalPos": real;
+	    val minPos = _ffi "Real64_minPos": real;
+	    val modf = _ffi "modf": real * real ref -> real;
+	    val nextAfter = _ffi "Real64_nextAfter": real * real -> real;
+	    val round = _prim "Real64_round": real -> real;
+	    val signBit = _ffi "Real64_signBit": real -> bool;
+	    val strtod = _ffi "Real64_strtod": nullString -> real;
+	    val toInt = _prim "Real64_toInt": real -> int;
+	    val ~ = _prim "Real64_neg": real -> real;
 	 end
       
       structure Ref =
@@ -738,8 +783,9 @@
 		  val toAddr = _ffi "UnixSock_toAddr": nullString * int *
                                                        pre_sock_addr * int ref -> unit;
 		  val pathLen = _ffi "UnixSock_pathLen": sock_addr -> int;
-		  val fromAddr = _ffi "UnixSock_fromAddr": sock_addr * 
-                                                           char array * int -> unit;
+		  val fromAddr =
+		     _ffi "UnixSock_fromAddr"
+		     : sock_addr * char array * int -> unit;
 		  structure Strm =
 		     struct
 		     end
@@ -759,7 +805,7 @@
       structure String =
 	 struct
 	    val fromWord8Vector =
-	       _prim "String_fromWord8Vector": word8 vector -> string;
+	       _prim "Word8Vector_toString": word8 vector -> string;
 	    val toWord8Vector =
 	       _prim "String_toWord8Vector": string -> word8 vector;
 	 end
@@ -830,7 +876,7 @@
 	     * are supposed to be immutable and the optimizer depends on this.
 	     *)
 	    val fromArray =
-	       fn x => _prim "Vector_fromArray": 'a array -> 'a vector; x
+	       fn x => _prim "Array_toVector": 'a array -> 'a vector; x
 	 end
 
       structure Word8 =
@@ -841,8 +887,8 @@
 	    val andb = _prim "Word8_andb": word * word -> word;
 	    val ~>> = _prim "Word8_arshift": word * word32 -> word;
 	    val div = _prim "Word8_div": word * word -> word;
-	    val fromInt = _prim "Word8_fromInt": int -> word;
-	    val fromLargeWord = _prim "Word8_fromLargeWord": word32 -> word;
+	    val fromInt = _prim "Int32_toWord8": int -> word;
+	    val fromLargeWord = _prim "Word32_toWord8": word32 -> word;
 	    val >= = _prim "Word8_ge": word * word -> bool;
 	    val > = _prim "Word8_gt" : word * word -> bool;
 	    val <= = _prim "Word8_le": word * word -> bool;
@@ -857,10 +903,10 @@
 	    val ror = _prim "Word8_ror": word * word32 -> word;
 	    val >> = _prim "Word8_rshift": word * word32 -> word;
 	    val - = _prim "Word8_sub": word * word -> word;
-	    val toInt = _prim "Word8_toInt": word -> int;
-	    val toIntX = _prim "Word8_toIntX": word -> int;
-	    val toLargeWord = _prim "Word8_toLargeWord": word -> word32;
-	    val toLargeWordX = _prim "Word8_toLargeWordX": word -> word32;
+	    val toInt = _prim "Word8_toInt32": word -> int;
+	    val toIntX = _prim "Word8_toInt32X": word -> int;
+	    val toLargeWord = _prim "Word8_toWord32": word -> word32;
+	    val toLargeWordX = _prim "Word8_toWord32X": word -> word32;
 	    val xorb = _prim "Word8_xorb": word * word -> word;
 	 end
 
@@ -887,7 +933,7 @@
 	    val andb = _prim "Word32_andb": word * word -> word;
 	    val ~>> = _prim "Word32_arshift": word * word -> word;
 	    val div = _prim "Word32_div": word * word -> word;
-	    val fromInt = _prim "Word32_fromInt": int -> word;
+	    val fromInt = _prim "Int32_toWord32": int -> word;
 	    val >= = _prim "Word32_ge": word * word -> bool;
 	    val > = _prim "Word32_gt" : word * word -> bool;
 	    val <= = _prim "Word32_le": word * word -> bool;
@@ -903,9 +949,10 @@
 	    val ror = _prim "Word32_ror": word * word -> word;
 	    val >> = _prim "Word32_rshift": word * word -> word;
 	    val - = _prim "Word32_sub": word * word -> word;
-	    val toIntX = _prim "Word32_toIntX": word -> int;
+	    val toIntX = _prim "Word32_toInt32X": word -> int;
 	    val xorb = _prim "Word32_xorb": word * word -> word;
 	 end
+      structure Word = Word32
 
       structure World =
 	 struct
@@ -913,4 +960,23 @@
 	    val makeOriginal = _ffi "World_makeOriginal": unit -> unit;
 	    val save = _prim "World_save": word (* filedes *) -> unit;
 	 end
+   end
+
+structure Primitive =
+   struct
+      open Primitive
+
+      structure Int32 =
+	 struct
+	    open Int32
+	       
+	    local
+	       fun make f (i: int, i': int): bool =
+		  f (Primitive.Word.fromInt i, Primitive.Word.fromInt i')
+	    in
+	       val geu = make Primitive.Word.>=
+	       val gtu = make Primitive.Word.> 
+	    end
+	 end
+      structure Int = Int32
    end



1.21      +6 -1      mlton/basis-library/real/real.sml

Index: real.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/real.sml,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- real.sml	2 Jun 2003 21:17:07 -0000	1.20
+++ real.sml	23 Jun 2003 04:58:53 -0000	1.21
@@ -39,7 +39,12 @@
 	 val signBit = signBit
 	 val ~ = ~
       end
- 
+
+      val op ?= =
+	 if Primitive.MLton.native
+	    then op ?=
+	 else fn (r, r') => isNan r orelse isNan r' orelse r == r'
+	 
       val radix: int = 2
 
       val precision: int = 52



1.9       +2 -2      mlton/benchmark/benchmark-stubs.cm

Index: benchmark-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/benchmark-stubs.cm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- benchmark-stubs.cm	15 May 2003 20:12:27 -0000	1.8
+++ benchmark-stubs.cm	23 Jun 2003 04:58:54 -0000	1.9
@@ -102,8 +102,6 @@
 ../lib/mlton/basic/euclidean-ring.fun
 ../lib/mlton/basic/integer.fun
 ../lib/mlton/basic/int.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/ordered-field.sig
 ../lib/mlton/basic/field.sig
 ../lib/mlton/basic/field.fun
@@ -159,6 +157,8 @@
 ../lib/mlton/basic/file-desc.sig
 ../lib/mlton/basic/file-desc.sml
 ../lib/mlton/basic/signal.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/function.sig
 ../lib/mlton/basic/function.sml
 ../lib/mlton/basic/dir.sig



1.9       +2 -2      mlton/benchmark/benchmark.cm

Index: benchmark.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/benchmark.cm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- benchmark.cm	1 Apr 2003 06:16:12 -0000	1.8
+++ benchmark.cm	23 Jun 2003 04:58:54 -0000	1.9
@@ -68,8 +68,6 @@
 ../lib/mlton/basic/euclidean-ring.fun
 ../lib/mlton/basic/integer.fun
 ../lib/mlton/basic/int.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/ordered-field.sig
 ../lib/mlton/basic/field.sig
 ../lib/mlton/basic/field.fun
@@ -125,6 +123,8 @@
 ../lib/mlton/basic/file-desc.sig
 ../lib/mlton/basic/file-desc.sml
 ../lib/mlton/basic/signal.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/function.sig
 ../lib/mlton/basic/function.sml
 ../lib/mlton/basic/dir.sig



1.15      +9 -3      mlton/bin/check-basis

Index: check-basis
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/check-basis,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- check-basis	18 Apr 2003 22:44:54 -0000	1.14
+++ check-basis	23 Jun 2003 04:58:54 -0000	1.15
@@ -102,17 +102,23 @@
           datatype bool = datatype bool
           type char = char
           type exn = exn
-          type int = Int32.int
+          type int8 = Int32.int
+          type int16 = Int32.int
+          type int32 = Int32.int
+          type int64 = Int32.int
+	  type int = int32
           type intInf = int
           datatype list = datatype list
           datatype pointer = T
-          type real = real
+          type real32 = real
+	  type real64 = real
           datatype ref = datatype ref
           datatype preThread = T
           datatype thread = T
 	  datatype 'a weak = T of 'a
-          type word = Word32.word
           type word8 = Word8.word
+	  type word16 = Word32.word
+          type word32 = Word32.word
           type 'a vector = 'a vector
           
           datatype 'a option = T



1.6       +359 -415  mlton/include/c-chunk.h

Index: c-chunk.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-chunk.h,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- c-chunk.h	3 Jun 2003 01:06:35 -0000	1.5
+++ c-chunk.h	23 Jun 2003 04:58:54 -0000	1.6
@@ -3,6 +3,7 @@
 
 #include "my-lib.h"
 #include "c-common.h"
+#include "types.h"
 
 #define WORD_SIZE 4
 
@@ -10,31 +11,10 @@
 #define DEBUG_CCODEGEN FALSE
 #endif
 
-typedef unsigned char Char;
-typedef double Double;
-typedef int Int;
-typedef char *Pointer;
-typedef unsigned long Word32;
-typedef Word32 Word;
-typedef unsigned long long Word64;
-
-#define Bool Int
-
-extern Char CReturnC;
-extern Double CReturnD;
-extern Int CReturnI;
-extern Char *CReturnP;
-extern Word CReturnU;
 extern struct cont (*nextChunks []) ();
 extern Int nextFun;
 extern Int returnToC;
 extern struct GC_state gcState;
-extern Char globaluchar[];
-extern Double globaldouble[];
-extern Int globalint[];
-extern Pointer globalpointer[];
-extern Word globaluint[];
-extern Pointer globalpointerNonRoot[];
 
 #define GCState ((Pointer)&gcState)
 #define ExnStack *(Word*)(GCState + ExnStackOffset)
@@ -44,6 +24,21 @@
 #define StackTopMem *(Word*)(GCState + StackTopOffset)
 #define StackTop stackTop
 
+/* ------------------------------------------------- */
+/*                      Memory                       */
+/* ------------------------------------------------- */
+
+#define C(ty, x) (*(ty*)(x))
+#define G(ty, i) (global##ty [i])
+#define GPNR(i) G(PointerNonRoot, i)
+#define O(ty, b, o) (*(ty*)((b) + (o)))
+#define X(ty, b, i) (*(ty*)((b) + ((i) * sizeof(ty))))
+#define S(ty, i) *(ty*)(StackTop + (i))
+
+/* ------------------------------------------------- */
+/*                       Tests                       */
+/* ------------------------------------------------- */
+
 #define IsInt(p) (0x3 & (int)(p))
 
 #define BZ(x, l)							\
@@ -129,13 +124,13 @@
 /*                Calling SML from C                 */
 /* ------------------------------------------------- */
 
-#define Thread_returnToC()							\
-	do {									\
-		if (DEBUG_CCODEGEN)						\
+#define Thread_returnToC()						\
+	do {								\
+		if (DEBUG_CCODEGEN)					\
 			fprintf (stderr, "%s:%d: Thread_returnToC()\n",	\
-					__FILE__, __LINE__);			\
-		returnToC = TRUE;						\
-		return cont;							\
+					__FILE__, __LINE__);		\
+		returnToC = TRUE;					\
+		return cont;						\
 	} while (0)
 
 /* ------------------------------------------------- */
@@ -149,64 +144,9 @@
 	} while (0)
 
 /* ------------------------------------------------- */
-/*                      Globals                      */
-/* ------------------------------------------------- */
-
-#define Global(ty, i) (global ## ty [ i ])
-#define GC(i) Global(uchar, i)
-#define GD(i) Global(double, i)
-#define GI(i) Global(int, i)
-#define GP(i) Global(pointer, i)
-#define GPNR(i) Global(pointerNonRoot, i)
-#define GU(i) Global(uint, i)
-
-/* ------------------------------------------------- */
-/*                     Registers                     */
-/* ------------------------------------------------- */
-
-#define Declare(ty, name, i) ty Reg(name, i)
-#define DC(n) Declare(Char, c, n)
-#define DD(n) Declare(Double, d, n)
-#define DI(n) Declare(Int, i, n)
-#define DP(n) Declare(Pointer, p, n)
-#define DU(n) Declare(Word, u, n)
-
-#define Reg(name, i) local ## name ## i
-#define RC(n) Reg(c, n)
-#define RD(n) Reg(d, n)
-#define RI(n) Reg(i, n)
-#define RP(n) Reg(p, n)
-#define RU(n) Reg(u, n)
-
-/* ------------------------------------------------- */
-/*                      Memory                       */
-/* ------------------------------------------------- */
-
-#define Offset(ty, b, o) (*(ty*)((b) + (o)))
-#define OC(b, i) Offset(Char, b, i)
-#define OD(b, i) Offset(Double, b, i)
-#define OI(b, i) Offset(Int, b, i)
-#define OP(b, i) Offset(Pointer, b, i)
-#define OU(b, i) Offset(Word, b, i)
-
-#define Contents(t, x) (*(t*)(x))
-#define CC(x) Contents(Char, x)
-#define CD(x) Contents(Double, x)
-#define CI(x) Contents(Int, x)
-#define CP(x) Contents(Pointer, x)
-#define CU(x) Contents(Word, x)
-
-/* ------------------------------------------------- */
 /*                       Stack                       */
 /* ------------------------------------------------- */
 
-#define Slot(ty, i) *(ty*)(StackTop + (i))
-#define SC(i) Slot(Char, i)
-#define SD(i) Slot(Double, i)
-#define SI(i) Slot(Int, i)
-#define SP(i) Slot(Pointer, i)
-#define SU(i) Slot(Word, i)
-
 #define Push(bytes)							\
 	do {								\
 		if (DEBUG_CCODEGEN)					\
@@ -257,29 +197,6 @@
 	} while (0)
 
 /* ------------------------------------------------- */
-/*                      Arrays                       */
-/* ------------------------------------------------- */
-
-#define ArrayOffset(ty, b, i) (*(ty*)((b) + ((i) * sizeof(ty))))
-
-#define XC(b, i) ArrayOffset (Char, b, i)
-#define XD(b, i) ArrayOffset (Double, b, i)
-#define XI(b, i) ArrayOffset (Int, b, i)
-#define XP(b, i) ArrayOffset (Pointer, b, i)
-#define XU(b, i) ArrayOffset (Word, b, i)
-
-/* ------------------------------------------------- */
-/*                       Char                        */
-/* ------------------------------------------------- */
-
-#define Char_lt(c1, c2) ((c1) < (c2))
-#define Char_le(c1, c2) ((c1) <= (c2))
-#define Char_gt(c1, c2) ((c1) > (c2))
-#define Char_ge(c1, c2) ((c1) >= (c2))
-#define Char_chr(c) ((Char)(c))
-#define Char_ord(c) ((Int)(c))
-
-/* ------------------------------------------------- */
 /*                     Cpointer                      */
 /* ------------------------------------------------- */
 
@@ -289,22 +206,11 @@
 /*                        Int                        */
 /* ------------------------------------------------- */
 
-/* The old -DFAST_INT has been renamed to -DINT_JO. */
-#if (defined (FAST_INT))
-#define INT_JO
-#endif
-
 /* The default is to use INT_TEST. */
-#if (! defined (INT_NO_CHECK) && ! defined (INT_JO) && ! defined (INT_TEST) && ! defined (INT_LONG))
+#if (! defined (INT_NO_CHECK) && ! defined (INT_TEST))
 #define INT_TEST
 #endif
 
-enum {
-	MAXINT = 0x7FFFFFFF,
-	MININT = (int)0x80000000,
-	MAXWORD = 0xFFFFFFFF,
-};
-
 #if (defined (INT_NO_CHECK))
 #define Int_addCheck(dst, n1, n2, l) dst = n1 + n2
 #define Int_mulCheck(dst, n1, n2, l) dst = n1 * n2
@@ -312,92 +218,141 @@
 #define Int_subCheck(dst, n1, n2, l) dst = n1 - n2
 #define Word32_addCheck(dst, n1, n2, l) dst = n1 + n2
 #define Word32_mulCheck(dst, n1, n2, l) dst = n1 * n2
+#define Int_addCheckCX Int_addCheck
+#define Int_addCheckXC Int_addCheck
+#define Int_subCheckCX Int_subCheck
+#define Int_subCheckXC Int_subCheck
+#define Word32_addCheckCX Word32_addCheck
+#define Word32_addCheckXC Word32_addCheck
 #endif
 
 #if (defined (INT_TEST))
-#define Int_addCheckXC(dst, x, c, l) 		\
-	do {					\
-		if (c >= 0) {			\
-			if (x > MAXINT - c)	\
-				goto l;		\
-		} else if (x < MININT - c)	\
-				goto l;		\
-		dst = x + c;			\
-	} while (0)
-#define Int_addCheckCX(dst, c, x, l) Int_addCheckXC(dst, x, c, l)
-#define Int_subCheckCX(dst, c, x, l)		\
+
+#define Int8_max (Int8)0x7F
+#define	Int8_min (Int8)0x80
+#define Int16_max (Int16)0x7FFF
+#define Int16_min (Int16)0x8000
+#define Int32_max (Int32)0x7FFFFFFF
+#define Int32_min (Int32)0x80000000
+#define Int64_max (Int64)0x7FFFFFFFFFFFFFFF
+#define Int64_min (Int64)0x8000000000000000
+#define Word8_max (Word8)0xFF
+#define Word16_max (Word16)0xFFFF
+#define Word32_max (Word32)0xFFFFFFFF
+#define Word64_max (Word64)0xFFFFFFFFFFFFFFFF
+
+#define Int_addCheckXC(size, dst, x, c, l)		\
+	do {						\
+		if (c >= 0) {				\
+			if (x > Int##size##_max - c)	\
+				goto l;			\
+		} else if (x < Int##size##_min - c)	\
+				goto l;			\
+		dst = x + c;				\
+	} while (0)
+#define Int8_addCheckXC(dst, x, c, l) Int_addCheckXC(8, dst, x, c, l)
+#define Int16_addCheckXC(dst, x, c, l) Int_addCheckXC(16, dst, x, c, l)
+#define Int32_addCheckXC(dst, x, c, l) Int_addCheckXC(32, dst, x, c, l)
+#define Int64_addCheckXC(dst, x, c, l) Int_addCheckXC(64, dst, x, c, l)
+
+#define Int8_addCheckCX(dst, c, x, l) Int8_addCheckXC(dst, x, c, l)
+#define Int16_addCheckCX(dst, c, x, l) Int16_addCheckXC(dst, x, c, l)
+#define Int32_addCheckCX(dst, c, x, l) Int32_addCheckXC(dst, x, c, l)
+#define Int64_addCheckCX(dst, c, x, l) Int64_addCheckXC(dst, x, c, l)
+
+#define Int8_addCheck Int8_addCheckXC
+#define Int16_addCheck Int16_addCheckXC
+#define Int32_addCheck Int32_addCheckXC
+#define Int64_addCheck Int64_addCheckXC
+
+#define Int_negCheck(size, dst, n, l)		\
 	do {					\
- 		if (c >= 0) {			\
-			if (x < c - MAXINT)	\
-				goto l;		\
-		} else if (x > c - MININT)	\
+		if (n == Int##size##_min)	\
 			goto l;			\
-		dst = c - x;			\
+		dst = -n;			\
 	} while (0)
-#define Int_subCheckXC(dst, x, c, l)		\
-	do {					\
-		if (c <= 0) {			\
-			if (x > MAXINT + c)	\
-				goto l;		\
-		} else if (x < MININT + c)	\
-			goto l;			\
-		dst = x - c;			\
+
+#define Int8_negCheck(dst, n, l) Int_negCheck(8, dst, n, l)
+#define Int16_negCheck(dst, n, l) Int_negCheck(16, dst, n, l)
+#define Int32_negCheck(dst, n, l) Int_negCheck(32, dst, n, l)
+#define Int64_negCheck(dst, n, l) Int_negCheck(64, dst, n, l)
+
+#define Int_subCheckCX(size, dst, c, x, l)		\
+	do {						\
+ 		if (c >= 0) {				\
+			if (x < c - Int##size##_max)	\
+				goto l;			\
+		} else if (x > c - Int##size##_min)	\
+			goto l;				\
+		dst = c - x;				\
+	} while (0)
+#define Int8_subCheckCX(dst, c, x, l) Int_subCheckCX(8, dst, c, x, l)
+#define Int16_subCheckCX(dst, c, x, l) Int_subCheckCX(16, dst, c, x, l)
+#define Int32_subCheckCX(dst, c, x, l) Int_subCheckCX(32, dst, c, x, l)
+#define Int64_subCheckCX(dst, c, x, l) Int_subCheckCX(64, dst, c, x, l)
+
+#define Int_subCheckXC(size, dst, x, c, l)		\
+	do {						\
+		if (c <= 0) {				\
+			if (x > Int##size##_max + c)	\
+				goto l;			\
+		} else if (x < Int##size##_min + c)	\
+			goto l;				\
+		dst = x - c;				\
  	} while (0)
-#define Word32_addCheckXC(dst, x, c, l)		\
+#define Int8_subCheckXC(dst, c, x, l) Int_subCheckXC(8, dst, c, x, l)
+#define Int16_subCheckXC(dst, c, x, l) Int_subCheckXC(16, dst, c, x, l)
+#define Int32_subCheckXC(dst, c, x, l) Int_subCheckXC(32, dst, c, x, l)
+#define Int64_subCheckXC(dst, c, x, l) Int_subCheckXC(64, dst, c, x, l)
+
+#define Int8_subCheck Int8_subCheckXC
+#define Int16_subCheck Int16_subCheckXC
+#define Int32_subCheck Int32_subCheckXC
+#define Int64_subCheck Int64_subCheckXC
+
+#define Word_addCheckXC(size, dst, x, c, l)	\
 	do {					\
-		if (x > MAXWORD - c)		\
+		if (x > Word##size##_max - c)	\
 			goto l;			\
 		dst = x + c;			\
 	} while (0)
-#define Word32_addCheckCX(dst, c, x, l) Word32_addCheckXC(dst, x, c, l)
+#define Word8_addCheckXC(dst, x, c, l) Word_addCheckXC(8, dst, x, c, l)
+#define Word16_addCheckXC(dst, x, c, l) Word_addCheckXC(16, dst, x, c, l)
+#define Word32_addCheckXC(dst, x, c, l) Word_addCheckXC(32, dst, x, c, l)
+#define Word64_addCheckXC(dst, x, c, l) Word_addCheckXC(64, dst, x, c, l)
+#define Word8_addCheckCX(dst, c, x, l) Word_addCheckXC(8, dst, x, c, l)
+#define Word16_addCheckCX(dst, c, x, l) Word_addCheckXC(16, dst, x, c, l)
+#define Word32_addCheckCX(dst, c, x, l) Word_addCheckXC(32, dst, x, c, l)
+#define Word64_addCheckCX(dst, c, x, l) Word_addCheckXC(64, dst, x, c, l)
 
-#define Int_addCheck Int_addCheckXC
-#define Int_subCheck Int_subCheckXC
+#define Word8_addCheck Word8_addCheckXC
+#define Word16_addCheck Word16_addCheckXC
 #define Word32_addCheck Word32_addCheckXC
+#define Word64_addCheck Word64_addCheckXC
 
-#endif
-
-static inline Int Int_addOverflow (Int lhs, Int rhs, Bool *overflow) {
-	long long	tmp;
-
-	tmp = (long long)lhs + rhs;
-	*overflow = (tmp != (int)tmp);
-	return tmp;
-}
-static inline Int Int_mulOverflow (Int lhs, Int rhs, Bool *overflow) {
-	long long	tmp;
-
-	tmp = (long long)lhs * rhs;
-	*overflow = (tmp != (int)tmp);
-	return tmp;
-}
-static inline Int Int_subOverflow (Int lhs, Int rhs, Bool *overflow) {
-	long long	tmp;
-
-	tmp = (long long)lhs - rhs;
-	*overflow = (tmp != (int)tmp);
-	return tmp;
-}
-static inline Word32 Word32_addOverflow (Word32 lhs, Word32 rhs, Bool *overflow) {
-	Word64 tmp;
+#define mulOverflow(kind, small, large)						\
+	static inline kind##small kind##small##_##mulOverflow			\
+			(kind##small x1, kind##small x2, Bool *overflow) {	\
+		kind##large tmp;						\
+		kind##small res;						\
+										\
+		tmp = (kind##large)x1 * x2;					\
+		res = tmp;							\
+		*overflow = (tmp != res);					\
+		return res;							\
+	}
+mulOverflow(Int, 8, 16)
+mulOverflow(Int, 16, 32)
+mulOverflow(Int, 32, 64)
+mulOverflow(Word, 8, 16)
+mulOverflow(Word, 16, 32)
+mulOverflow(Word, 32, 64)
+#undef mulOverflow
 
-	tmp = (Word64)lhs + rhs;
-	*overflow = (tmp != (Word32)tmp);
-	return tmp;
-}
-static inline Word32 Word32_mulOverflow (Word32 lhs, Word32 rhs, Bool *overflow) {
-	Word64 tmp;
-
-	tmp = (Word64)lhs * rhs;
-	*overflow = (tmp != (Word32)tmp);
-	return tmp;
-}
-
-#if (defined (INT_TEST) || defined (INT_LONG))
 #define check(dst, n1, n2, l, f);						\
 	do {									\
 		int overflow;							\
-		dst = f(n1, n2, &overflow);					\
+		dst = f (n1, n2, &overflow);					\
 		if (DEBUG_CCODEGEN)						\
 			fprintf (stderr, "%s:%d: " #f "(%d, %d) = %d\n",	\
 					__FILE__, __LINE__, n1, n2, dst);	\
@@ -408,110 +363,69 @@
 			goto l;							\
 		}								\
 	} while (0)
-#define Int_mulCheck(dst, n1, n2, l)			\
-	check(dst, n1, n2, l, Int_mulOverflow)
-#define Int_negCheck(dst, n, l)			\
-	do {					\
-		if (n == MININT)		\
-			goto l;			\
-		dst = -n;			\
-	} while (0)
-#define Word32_mulCheck(dst, n1, n2, l)			\
-	check(dst, n1, n2, l, Word32_mulOverflow)
-#endif
-
-#if (defined (INT_LONG))
-#define Int_addCheck(dst, n1, n2, l)			\
-	check(dst, n1, n2, l, Int_addOverflow)
-#define Int_subCheck(dst, n1, n2, l)			\
-	check(dst, n1, n2, l, Int_subOverflow)
-#define Word32_addCheck(dst, n1, n2, l)			\
-	check(dst, n1, n2, l, Word32_addOverflow)
-#endif
-
-#if (defined (INT_JO))
-
-static void MLton_overflow () {
-	die("Internal overflow detected. Halt.");
-}
-
-static inline Int Int_addCheckFast (Int n1, Int n2) {
- 	__asm__ __volatile__ ("addl %1, %0\n\tjo MLton_overflow"
-			      : "+r" (n1) : "g" (n2) : "cc");
-
-	return n1;
-}
-
-static inline Int Int_mulCheckFast (Int n1, Int n2) {
- 	__asm__ __volatile__ ("imull %1, %0\n\tjo MLton_overflow"
-			      : "+r" (n1) : "g" (n2) : "cc");
-
-	return n1;
-}
-
-static inline Int Int_negCheckFast (Int n) {
-	__asm__ __volatile__ ("negl %1\n\tjo MLton_overflow"
-				: "+r" (n) : : "cc" );
-	return n;
-}
-
-static inline Int Int_subCheckFast (Int n1, Int n2) {
- 	__asm__ __volatile__ ("subl %1, %0\n\tjo MLton_overflow"
-			      : "+r" (n1) : "g" (n2) : "cc" );
-
-	return n1;
-}
-
-static inline Word Word32_addCheckFast (Word n1, Word n2) {
- 	__asm__ __volatile__ ("addl %1, %0\n\tjc MLton_overflow"
-			      : "+r" (n1) : "g" (n2) : "cc");
-
-	return n1;
-}
 
-static inline Word Word32_mulCheckFast (Word n1, Word n2) {
- 	__asm__ __volatile__ ("imull %1, %0\n\tjc MLton_overflow"
-			      : "+r" (n1) : "g" (n2) : "cc");
-
-	return n1;
-}
-
-#define check(dst,n1,n2,l,f) dst = f(n1, n2)
-
-#define Int_addCheck(dst, n1, n2, l)			\
-	check(dst, n1, n2, l, Int_addCheckFast)
-#define Int_mulCheck(dst, n1, n2, l)			\
-	check(dst, n1, n2, l, Int_mulCheckFast)
-#define Int_negCheck(dst, n, l) 			\
-	dst = Int_negCheckFast(n)
-#define Int_subCheck(dst, n1, n2, l)			\
-	check(dst, n1, n2, l, Int_subCheckFast)
-#define Word32_addCheck(dst, n1, n2, l)			\
-	check(dst, n1, n2, l, Word32_addCheckFast)
+#define Int8_mulCheck(dst, n1, n2, l)			\
+	check (dst, n1, n2, l, Int8_mulOverflow)
+#define Int16_mulCheck(dst, n1, n2, l)			\
+	check (dst, n1, n2, l, Int16_mulOverflow)
+#define Int32_mulCheck(dst, n1, n2, l)			\
+	check (dst, n1, n2, l, Int32_mulOverflow)
+#define Int64_mulCheck(dst, n1, n2, l)			\
+	fprintf (stderr, "FIXME: Int64_mulCheck\n");
+
+#define Word8_mulCheck(dst, n1, n2, l)			\
+	check (dst, n1, n2, l, Word8_mulOverflow)
+#define Word16_mulCheck(dst, n1, n2, l)			\
+	check (dst, n1, n2, l, Word16_mulOverflow)
 #define Word32_mulCheck(dst, n1, n2, l)			\
-	check(dst, n1, n2, l, Word32_mulCheckFast)
-
-#endif
-
-#if (defined (INT_NO_CHECK) || defined (INT_JO) || defined (INT_LONG))
-#define Int_addCheckCX Int_addCheck
-#define Int_addCheckXC Int_addCheck
-#define Int_subCheckCX Int_subCheck
-#define Int_subCheckXC Int_subCheck
-#define Word32_addCheckCX Word32_addCheck
-#define Word32_addCheckXC Word32_addCheck
-#endif
-
-#define Int_add(n1, n2) ((n1) + (n2))
-#define Int_mul(n1, n2) ((n1) * (n2))
-#define Int_sub(n1, n2) ((n1) - (n2))
-#define Int_lt(n1, n2) ((n1) < (n2))
-#define Int_le(n1, n2) ((n1) <= (n2))
-#define Int_gt(n1, n2) ((n1) > (n2))
-#define Int_ge(n1, n2) ((n1) >= (n2))
-#define Int_geu(x, y) ((Word)(x) >= (Word)(y))
-#define Int_gtu(x, y) ((Word)(x) > (Word)(y))
-#define Int_neg(n) (-(n))
+	check (dst, n1, n2, l, Word32_mulOverflow)
+#define Word64_mulCheck(dst, n1, n2, l)			\
+	fprintf (stderr, "FIXME: Word64_mulCheck\n");
+
+#endif /* INT_TEST */
+
+#define intBinary(name, op, size)			\
+	static inline Int##size Int##size##_##name 	\
+			(Int##size i1, Int##size i2) {	\
+		return i1 op i2;			\
+	}
+#define intAllBinary(name, op)			\
+	intBinary(name,op,8)			\
+	intBinary(name,op,16)			\
+	intBinary(name,op,32)			\
+	intBinary(name,op,64)
+intAllBinary (add, +)
+intAllBinary (mul, *)
+intAllBinary (sub, -)
+#undef intBinary
+#undef intAllBinary
+
+#define intBinaryCompare(name, op, size) 		\
+	static inline Bool Int##size##_##name 		\
+			(Int##size i1, Int##size i2) {	\
+		return i1 op i2;			\
+	}
+#define intAllBinaryCompare(name, op)		\
+	intBinaryCompare(name,op,8)		\
+	intBinaryCompare(name,op,16)		\
+	intBinaryCompare(name,op,32)		\
+	intBinaryCompare(name,op,64)
+intAllBinaryCompare (ge, >=)
+intAllBinaryCompare (gt, >)
+intAllBinaryCompare (le, <=)
+intAllBinaryCompare (lt, <)
+#undef intBinaryCompare
+#undef intAllBinaryCompare
+
+#define Int_neg(size)							\
+	static inline Int##size Int##size##_##neg (Int##size i) {	\
+		return -i;						\
+	}
+Int_neg(8)
+Int_neg(16)
+Int_neg(32)
+Int_neg(64)
+#undef Int_neg
 
 /* ------------------------------------------------- */
 /*                       MLton                       */
@@ -527,65 +441,90 @@
 /*                       Real                        */
 /* ------------------------------------------------- */
 
-Double acos (Double x);
-#define Real_Math_acos acos
-Double asin (Double x);
-#define Real_Math_asin asin
-Double atan (Double x);
-#define Real_Math_atan atan
-Double atan2 (Double x, Double y);
-#define Real_Math_atan2 atan2
-Double cos (Double x);
-#define Real_Math_cos cos
-Double cosh (Double x);
-#define Real_Math_cosh cosh
-Double exp (Double x);
-#define Real_Math_exp exp
-Double log (Double x);
-#define Real_Math_ln log
-Double log10 (Double x);
-#define Real_Math_log10 log10
-Double pow (Double x, Double y);
-#define Real_Math_pow pow
-Double sin (Double x);
-#define Real_Math_sin sin
-Double sinh (Double x);
-#define Real_Math_sinh sinh
-Double sqrt (Double x);
-#define Real_Math_sqrt sqrt
-Double tan (Double x);
-#define Real_Math_tan tan
-Double tanh (Double x);
-#define Real_Math_tanh tanh
-
-#define Real_abs fabs
-#define Real_add(x, y) ((x) + (y))
-#define Real_copysign copysign
-#define Real_div(x, y) ((x) / (y))
-#define Real_equal(x1, x2) ((x1) == (x2))
-#define Real_fromInt(n) ((Double)(n))
-#define Real_ge(x1, x2) ((x1) >= (x2))
-#define Real_gt(x1, x2) ((x1) > (x2))
-Double ldexp (Double x, Int i);
-#define Real_ldexp ldexp
-#define Real_le(x1, x2) ((x1) <= (x2))
-#define Real_lt(x1, x2) ((x1) < (x2))
-#define Real_mul(x, y) ((x) * (y))
-#define Real_muladd(x, y, z) ((x) * (y) + (z))
-#define Real_mulsub(x, y, z) ((x) * (y) - (z))
-#define Real_neg(x) (-(x))
-Int Real_qequal (Double x1, Double x2);
-Double Real_round (Double x);
-#define Real_sub(x, y) ((x) - (y))
-#define Real_toInt(x) ((int)(x))
+Real64 atan2 (Real64 x, Real64 y);
+#define Real64_Math_atan2 atan2
+static inline Real32 Real32_Math_atan2 (Real32 x, Real32 y) {
+	return (Real32)(Real64_Math_atan2 ((Real64)x, (Real64)y));
+}
+
+#define unaryReal(f,g)						\
+	Real64 g (Real64 x);					\
+	static inline Real64 Real64_Math_##f (Real64 x) {	\
+		return g (x);					\
+	}							\
+	static inline Real32 Real32_Math_##f (Real32 x) {	\
+		return (Real32)(Real64_Math_##f ((Real64)x));	\
+	}
+unaryReal(acos, acos)
+unaryReal(asin, asin)
+unaryReal(atan, atan)
+unaryReal(cos, cos)
+unaryReal(exp, exp)
+unaryReal(ln, log)
+unaryReal(log10, log10)
+unaryReal(sin, sin)
+unaryReal(sqrt, sqrt)
+unaryReal(tan, tan)
+
+Real64 fabs (Real64 x);
+static inline Real64 Real64_abs (Real64 x) {
+	return fabs (x);
+}
+Real32 fabsf (Real32 x);
+static inline Real32 Real32_abs (Real32 x) {
+	return fabsf (x);
+}
+
+#define binaryReal(name, op)						\
+	static inline Real32 Real32_##name (Real32 x, Real32 y) {	\
+		return x op y;						\
+	}								\
+	static inline Real64 Real64_##name (Real64 x, Real64 y) {	\
+		return x op y;						\
+	}
+binaryReal(add, +)
+binaryReal(div, /)
+binaryReal(mul, *)
+binaryReal(sub, -)
+
+#undef binaryReal
+#define binaryReal(name, op)					\
+	static inline Bool Real32_##name (Real32 x, Real32 y) {	\
+		return x op y;					\
+	}							\
+	static inline Bool Real64_##name (Real64 x, Real64 y) {	\
+		return x op y;					\
+	}
+binaryReal(equal, ==)
+binaryReal(ge, >=)
+binaryReal(gt, >)
+binaryReal(le, <=)
+binaryReal(lt, <)
+
+Real64 ldexp (Real64 x, Int i);
+static inline Real64 Real64_ldexp (Real64 x, Int i) {
+	return ldexp (x, i);
+}
+static inline Real32 Real32_ldexp (Real32 x, Int i) {
+	return (Real32)(Real64_ldexp ((Real64)x, i));
+}
+#define Real32_muladd(x, y, z) ((x) * (y) + (z))
+#define Real32_mulsub(x, y, z) ((x) * (y) - (z))
+#define Real64_muladd(x, y, z) ((x) * (y) + (z))
+#define Real64_mulsub(x, y, z) ((x) * (y) - (z))
+#define Real32_neg(x) (-(x))
+#define Real64_neg(x) (-(x))
+Real64 Real64_round (Real64 x);
+#define Real32_toInt(x) ((Int)(x))
+#define Real64_toInt(x) ((Int)(x))
 
 typedef volatile union {
 	Word tab[2];
-	Double d;
-} DoubleOr2Words;
+	Real64 d;
+} Real64Or2Words;
 
-static inline double Real_fetch (double *dp) {
- 	DoubleOr2Words u;
+static inline Real64 Real64_fetch (Real64 *dp) {
+ 	Real64Or2Words u;
 	Word32 *p;
 
 	p = (Word32*)dp;
@@ -594,7 +533,7 @@
  	return u.d;
 }
 
-static inline void Real_move (double *dst, double *src) {
+static inline void Real64_move (Real64 *dst, Real64 *src) {
 	Word32 *pd;
 	Word32 *ps;
 	Word32 t;
@@ -606,8 +545,8 @@
 	pd[1] = t;		
 }
 
-static inline void Real_store (double *dp, double d) {
- 	DoubleOr2Words u;
+static inline void Real64_store (Real64 *dp, Real64 d) {
+ 	Real64Or2Words u;
 	Word32 *p;
 
 	p = (Word32*)dp;
@@ -617,77 +556,82 @@
 }
 
 /* ------------------------------------------------- */
-/*                       Word8                       */
+/*                        Word                       */
 /* ------------------------------------------------- */
 
-#define Word8_add(w1, w2) ((w1) + (w2))
-#define Word8_andb(w1, w2) ((w1) & (w2))
-/* The macro for Word8_arshift isn't ANSI C, because ANSI doesn't guarantee 
- * sign extension.  We use it anyway cause it always seems to work.
- */
-#define Word8_arshift(w, s) ((signed char)(w) >> (s))
-#define Word8_div(w1, w2) ((w1) / (w2))
-#define Word8_fromInt(x) ((Char)(x))
-#define Word8_fromLargeWord(w) ((Char)(w))
-#define Word8_ge(w1, w2) ((w1) >= (w2))
-#define Word8_gt(w1, w2) ((w1) > (w2))
-#define Word8_le(w1, w2) ((w1) <= (w2))
-#define Word8_lshift(w, s)  ((w) << (s))
-#define Word8_lt(w1, w2) ((w1) < (w2))
-#define Word8_mod(w1, w2) ((w1) % (w2))
-#define Word8_mul(w1, w2) ((w1) * (w2))
-#define Word8_neg(w) (-(w))
-#define Word8_notb(w) (~(w))
-#define Word8_orb(w1, w2) ((w1) | (w2))
-#define Word8_rol(x, y) ((x)>>(8-(y)) | ((x)<<(y)))
-#define Word8_ror(x, y) ((x)>>(y) | ((x)<<(8-(y))))
-#define Word8_rshift(w, s) ((w) >> (s))
-#define Word8_sub(w1, w2) ((w1) - (w2))
-#define Word8_toInt(w) ((int)(w))
-#define Word8_toIntX(x) ((int)(signed char)(x))
-#define Word8_toLargeWord(w) ((uint)(w))
-#define Word8_toLargeWordX(x) ((uint)(signed char)(x))
-#define Word8_xorb(w1, w2) ((w1) ^ (w2))
-
-/* ------------------------------------------------- */
-/*                    Word8Array                     */
-/* ------------------------------------------------- */
-
-#define Word8Array_subWord(a, i) (((Word*)(a))[i])
-#define Word8Array_updateWord(a, i, w) ((Word*)(a))[i] = (w)
-
-/* ------------------------------------------------- */
-/*                    Word8Vector                    */
-/* ------------------------------------------------- */
-
-#define Word8Vector_subWord(a, i) (((Word*)(a))[i])
-
-/* ------------------------------------------------- */
-/*                      Word32                       */
-/* ------------------------------------------------- */
-
-#define Word32_add(w1,w2) ((w1) + (w2))
-#define Word32_andb(w1,w2) ((w1) & (w2))
-/* The macro for Word32_arshift isn't ANSI C, because ANSI doesn't guarantee 
- * sign extension.  We use it anyway cause it always seems to work.
- * We do it because using a procedure call slows down IntInf by a factor of 2.
- */
-#define Word32_arshift(w, s) ((int)(w) >> (s))
-#define Word32_div(w1, w2) ((w1) / (w2))
-#define Word32_ge(w1, w2) ((w1) >= (w2))
-#define Word32_gt(w1, w2) ((w1) > (w2))
-#define Word32_le(w1, w2) ((w1) <= (w2))
-#define Word32_lshift(w, s) ((w) << (s))
-#define Word32_lt(w1, w2) ((w1) < (w2))
-#define Word32_mod(w1, w2) ((w1) % (w2))
-#define Word32_mul(w1, w2) ((w1) * (w2))
-#define Word32_neg(w) (-(w))
-#define Word32_notb(w) (~(w))
-#define Word32_orb(w1, w2) ((w1) | (w2))
-#define Word32_ror(x, y) ((x)>>(y) | ((x)<<(32-(y))))
-#define Word32_rol(x, y) ((x)>>(32-(y)) | ((x)<<(y)))
-#define Word32_rshift(w, s) ((w) >> (s))
-#define Word32_sub(w1, w2) ((w1) - (w2))
-#define Word32_xorb(w1, w2) ((w1) ^ (w2))
+#define wordBinary(size, name, op)				\
+	static inline Word##size Word##size##_##name 		\
+			(Word##size w1, Word##size w2) {	\
+		return w1 op w2;				\
+	}
+#define wordCmp(size, name, op)					\
+	static inline Bool Word##size##_##name 			\
+			(Word##size w1, Word##size w2) {	\
+		return w1 op w2;				\
+	}
+#define wordShift(size, name, op)			\
+	static inline Word##size Word##size##_##name 	\
+			(Word##size w1, Word w2) {	\
+		return w1 op w2;			\
+	}
+#define wordUnary(size, name, op)					\
+	static inline Word##size Word##size##_##name (Word##size w) {	\
+		return op w;						\
+	}
+#define wordOps(size)								\
+	wordBinary (size, add, +)						\
+	wordBinary (size, andb, &)						\
+	wordBinary (size, div, /)						\
+	wordBinary (size, mod, %)						\
+	wordBinary (size, mul, *)						\
+	wordBinary (size, orb, |)						\
+	wordBinary (size, sub, -)						\
+	wordBinary (size, xorb, ^)						\
+	wordCmp (size, ge, >=)							\
+	wordCmp (size, gt, >)							\
+	wordCmp (size, le, <=)							\
+	wordCmp (size, lt, <)							\
+	wordShift (size, lshift, <<)						\
+	wordShift (size, rshift, >>)						\
+	wordUnary (size, neg, -)						\
+	wordUnary (size, notb, ~)						\
+	/* Word_arshift isn't ANSI C, because ANSI doesn't guarantee sign	\
+         * extension.  We use it anyway cause it always seems to work.		\
+	 */									\
+	static inline Word##size Word##size##_arshift (Word##size w, Word s) {	\
+		return (Int##size)w >> s;					\
+	}									\
+	static inline Word##size Word##size##_rol (Word##size w1, Word w2) {	\
+		return (w1 >> (size - w2)) | (w1 << w2);			\
+	}									\
+	static inline Word##size Word##size##_ror (Word##size w1, Word w2) {	\
+		return (w1 >> w2) | (w1 << (size - w2));			\
+	}
+wordOps(8)
+wordOps(16)
+wordOps(32)
+wordOps(64)
+#undef wordBinary wordCmp wordShift wordUnary
+
+#define coerce(f, t)				\
+	static inline t f##_to##t (f x) {	\
+		return (t)x;			\
+	}
+coerce (Int32, Real64)
+coerce (Int32, Word8)
+coerce (Int32, Word32)
+coerce (Word8, Int32)
+coerce (Word8, Word32)
+coerce (Word32, Word8)
+#undef coerce
+
+#define coerceX(size, t)					\
+	static inline t Word##size##_to##t##X (Word##size x) {	\
+		return (t)(Int##size)x;				\
+	}
+coerceX (8, Int32)
+coerceX (32, Int32)
+coerceX (8, Word32)
+#undef coerceX
 
 #endif /* #ifndef _C_CHUNK_H_ */



1.5       +50 -55    mlton/include/c-main.h

Index: c-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-main.h,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- c-main.h	19 Jun 2003 15:38:04 -0000	1.4
+++ c-main.h	23 Jun 2003 04:58:54 -0000	1.5
@@ -4,61 +4,56 @@
 #include "main.h"
 #include "c-common.h"
 
-#define Main(al, cs, mg, mfs, mlw, mmc, ps, mc, ml)				\
-/* Globals */									\
-char CReturnC;   /* The CReturn's must be globals and cannot be per chunk */	\
-double CReturnD; /* because they may be assigned in one chunk and read in */	\
-int CReturnI;    /* another.  See, e.g. Array_allocate. */			\
-char *CReturnP;									\
-uint CReturnU;									\
-int nextFun;									\
-bool returnToC;									\
-void MLton_callFromC () {							\
-	struct cont cont;							\
-	GC_state s;								\
-										\
-	if (DEBUG_CCODEGEN)							\
-		fprintf (stderr, "MLton_callFromC() starting\n");		\
-	s = &gcState;								\
-	s->savedThread = s->currentThread;					\
-	s->canHandle++;								\
-	/* Return to the C Handler thread. */					\
-	GC_switchToThread (s, s->callFromCHandler);				\
-	nextFun = *(int*)(s->stackTop - WORD_SIZE);				\
-	cont.nextChunk = nextChunks[nextFun];					\
-	returnToC = FALSE;							\
-	do {									\
- 		cont=(*(struct cont(*)(void))cont.nextChunk)();			\
-	} while (not returnToC);						\
-	GC_switchToThread (s, s->savedThread);					\
-	s->canHandle--;								\
-	s->savedThread = BOGUS_THREAD;						\
-	if (DEBUG_CCODEGEN)							\
-		fprintf (stderr, "MLton_callFromC done\n");			\
-}										\
-int main (int argc, char **argv) {						\
-	struct cont cont;							\
-	gcState.native = FALSE;							\
-	Initialize (al, cs, mg, mfs, mlw, mmc, ps);				\
-	if (gcState.isOriginal) {						\
-		real_Init();							\
-		PrepFarJump(mc, ml);						\
-	} else {								\
-		/* Return to the saved world */					\
-		nextFun = *(int*)(gcState.stackTop - WORD_SIZE);		\
-		cont.nextChunk = nextChunks[nextFun];				\
-	}									\
-	/* Trampoline */							\
-	while (1) {								\
- 		cont=(*(struct cont(*)(void))cont.nextChunk)();			\
- 		cont=(*(struct cont(*)(void))cont.nextChunk)();			\
- 		cont=(*(struct cont(*)(void))cont.nextChunk)();			\
- 		cont=(*(struct cont(*)(void))cont.nextChunk)();			\
- 		cont=(*(struct cont(*)(void))cont.nextChunk)();			\
- 		cont=(*(struct cont(*)(void))cont.nextChunk)();			\
- 		cont=(*(struct cont(*)(void))cont.nextChunk)();			\
- 		cont=(*(struct cont(*)(void))cont.nextChunk)();			\
-	}									\
+#define Main(al, cs, mg, mfs, mlw, mmc, ps, mc, ml)			\
+/* Globals */								\
+int nextFun;								\
+bool returnToC;								\
+void MLton_callFromC () {						\
+	struct cont cont;						\
+	GC_state s;							\
+									\
+	if (DEBUG_CCODEGEN)						\
+		fprintf (stderr, "MLton_callFromC() starting\n");	\
+	s = &gcState;							\
+	s->savedThread = s->currentThread;				\
+	s->canHandle++;							\
+	/* Return to the C Handler thread. */				\
+	GC_switchToThread (s, s->callFromCHandler);			\
+	nextFun = *(int*)(s->stackTop - WORD_SIZE);			\
+	cont.nextChunk = nextChunks[nextFun];				\
+	returnToC = FALSE;						\
+	do {								\
+ 		cont=(*(struct cont(*)(void))cont.nextChunk)();		\
+	} while (not returnToC);					\
+	GC_switchToThread (s, s->savedThread);				\
+	s->canHandle--;							\
+ 	s->savedThread = BOGUS_THREAD;					\
+	if (DEBUG_CCODEGEN)						\
+		fprintf (stderr, "MLton_callFromC done\n");		\
+}									\
+int main (int argc, char **argv) {					\
+	struct cont cont;						\
+	gcState.native = FALSE;						\
+	Initialize (al, cs, mg, mfs, mlw, mmc, ps);			\
+	if (gcState.isOriginal) {					\
+		real_Init();						\
+		PrepFarJump(mc, ml);					\
+	} else {							\
+		/* Return to the saved world */				\
+		nextFun = *(int*)(gcState.stackTop - WORD_SIZE);	\
+		cont.nextChunk = nextChunks[nextFun];			\
+	}								\
+	/* Trampoline */						\
+	while (1) {							\
+ 		cont=(*(struct cont(*)(void))cont.nextChunk)();		\
+ 		cont=(*(struct cont(*)(void))cont.nextChunk)();		\
+ 		cont=(*(struct cont(*)(void))cont.nextChunk)();		\
+ 		cont=(*(struct cont(*)(void))cont.nextChunk)();		\
+ 		cont=(*(struct cont(*)(void))cont.nextChunk)();		\
+ 		cont=(*(struct cont(*)(void))cont.nextChunk)();		\
+ 		cont=(*(struct cont(*)(void))cont.nextChunk)();		\
+ 		cont=(*(struct cont(*)(void))cont.nextChunk)();		\
+	}								\
 }
 
 #endif /* #ifndef _C_MAIN_H */



1.4       +2 -31     mlton/include/main.h

Index: main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/main.h,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- main.h	3 Jun 2003 01:03:53 -0000	1.3
+++ main.h	23 Jun 2003 04:58:54 -0000	1.4
@@ -17,38 +17,9 @@
 #define String(g, s, l) { g, s, l },
 #define EndStrings };
 
-#define BeginReals static void real_Init() {
-#define Real(c, f) globaldouble[c] = f;
-#define EndReals }
-
 #define LoadArray(a, f) sfread (a, sizeof(*a), cardof(a), f)
 #define SaveArray(a, fd) swrite (fd, a, sizeof(*a) * cardof(a))
 
-/* gcState can't be static because stuff in mlton-lib.c refers to it */
-
-#define Globals(c, d, i, p, u, nr)			\
-	struct GC_state gcState;			\
-	char globaluchar[c];				\
-	double globaldouble[d];				\
-	int globalint[i];				\
-	pointer globalpointer[p];			\
-        uint globaluint[u];				\
-	pointer globalpointerNonRoot[nr];		\
-	static void saveGlobals (int fd) {		\
-		SaveArray (globaluchar, fd);		\
-		SaveArray (globaldouble, fd);		\
-		SaveArray (globalint, fd);		\
-		SaveArray (globalpointer, fd);		\
-		SaveArray (globaluint, fd);		\
-	}						\
-	static void loadGlobals (FILE *file) {		\
-		LoadArray (globaluchar, file);		\
-		LoadArray (globaldouble, file);		\
-		LoadArray (globalint, file);		\
-		LoadArray (globalpointer, file);	\
-		LoadArray (globaluint, file);		\
-	}
-
 #define Initialize(al, cs, mg, mfs, mlw, mmc, ps)			\
 	gcState.alignment = al;						\
 	gcState.cardSizeLog2 = cs;					\
@@ -56,8 +27,8 @@
 	gcState.frameLayoutsSize = cardof(frameLayouts); 		\
 	gcState.frameSources = frameSources;				\
 	gcState.frameSourcesSize = cardof(frameSources);		\
-	gcState.globals = globalpointer;				\
-	gcState.globalsSize = cardof(globalpointer);			\
+	gcState.globals = globalPointer;				\
+	gcState.globalsSize = cardof(globalPointer);			\
 	gcState.intInfInits = intInfInits;				\
 	gcState.intInfInitsSize = cardof(intInfInits);			\
 	gcState.loadGlobals = loadGlobals;				\



1.5       +0 -7      mlton/include/x86-main.h

Index: x86-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86-main.h,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- x86-main.h	19 Jun 2003 15:38:04 -0000	1.4
+++ x86-main.h	23 Jun 2003 04:58:54 -0000	1.5
@@ -31,13 +31,6 @@
 #define DEBUG_X86CODEGEN FALSE
 #endif
 
-#define Locals(c, d, i, p, u)						\
-	char localuchar[c];						\
-	double localdouble[d];				       		\
-	int localint[i];						\
-	pointer localpointer[p];					\
-	uint localuint[u]
-
 #if (defined (__CYGWIN__))
 #define ReturnToC "_Thread_returnToC"
 #elif (defined (__FreeBSD__) || defined (__linux__) || defined (__sun__))



1.9       +2 -2      mlton/mllex/mllex-stubs.cm

Index: mllex-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mllex/mllex-stubs.cm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- mllex-stubs.cm	15 May 2003 20:12:28 -0000	1.8
+++ mllex-stubs.cm	23 Jun 2003 04:58:54 -0000	1.9
@@ -104,8 +104,6 @@
 ../lib/mlton/basic/euclidean-ring.fun
 ../lib/mlton/basic/integer.fun
 ../lib/mlton/basic/int.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/char.sig
 ../lib/mlton/basic/char.sml
 ../lib/mlton/basic/vector.sig
@@ -137,6 +135,8 @@
 ../lib/mlton/basic/function.sig
 ../lib/mlton/basic/function.sml
 ../lib/mlton/basic/signal.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/dir.sig
 ../lib/mlton/basic/dir.sml
 ../lib/mlton/basic/process.sig



1.6       +2 -2      mlton/mllex/mllex.cm

Index: mllex.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mllex/mllex.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- mllex.cm	1 Apr 2003 06:16:12 -0000	1.5
+++ mllex.cm	23 Jun 2003 04:58:54 -0000	1.6
@@ -70,8 +70,6 @@
 ../lib/mlton/basic/euclidean-ring.fun
 ../lib/mlton/basic/integer.fun
 ../lib/mlton/basic/int.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/char.sig
 ../lib/mlton/basic/char.sml
 ../lib/mlton/basic/vector.sig
@@ -103,6 +101,8 @@
 ../lib/mlton/basic/function.sig
 ../lib/mlton/basic/function.sml
 ../lib/mlton/basic/signal.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/dir.sig
 ../lib/mlton/basic/dir.sml
 ../lib/mlton/basic/process.sig



1.13      +2 -2      mlton/mlprof/mlprof-stubs.cm

Index: mlprof-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/mlprof-stubs.cm,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- mlprof-stubs.cm	15 May 2003 20:12:28 -0000	1.12
+++ mlprof-stubs.cm	23 Jun 2003 04:58:54 -0000	1.13
@@ -102,8 +102,6 @@
 ../lib/mlton/basic/euclidean-ring.fun
 ../lib/mlton/basic/integer.fun
 ../lib/mlton/basic/int.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/ordered-field.sig
 ../lib/mlton/basic/field.sig
 ../lib/mlton/basic/field.fun
@@ -156,6 +154,8 @@
 ../lib/mlton/basic/regexp.sml
 ../lib/mlton/basic/result.sig
 ../lib/mlton/basic/result.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/file-desc.sig
 ../lib/mlton/basic/file-desc.sml
 ../lib/mlton/basic/function.sig



1.15      +2 -2      mlton/mlprof/mlprof.cm

Index: mlprof.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/mlprof.cm,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- mlprof.cm	1 Apr 2003 06:16:12 -0000	1.14
+++ mlprof.cm	23 Jun 2003 04:58:54 -0000	1.15
@@ -68,8 +68,6 @@
 ../lib/mlton/basic/euclidean-ring.fun
 ../lib/mlton/basic/integer.fun
 ../lib/mlton/basic/int.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/ordered-field.sig
 ../lib/mlton/basic/field.sig
 ../lib/mlton/basic/field.fun
@@ -122,6 +120,8 @@
 ../lib/mlton/basic/regexp.sml
 ../lib/mlton/basic/result.sig
 ../lib/mlton/basic/result.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/file-desc.sig
 ../lib/mlton/basic/file-desc.sml
 ../lib/mlton/basic/function.sig



1.17      +22 -12    mlton/mlton/mlton-stubs-1997.cm

Index: mlton-stubs-1997.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs-1997.cm,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- mlton-stubs-1997.cm	15 May 2003 20:12:29 -0000	1.16
+++ mlton-stubs-1997.cm	23 Jun 2003 04:58:54 -0000	1.17
@@ -116,8 +116,6 @@
 ../lib/mlton/basic/field.sig
 ../lib/mlton/basic/field.fun
 ../lib/mlton/basic/ordered-field.fun
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/real.sig
 ../lib/mlton/basic/real.sml
 ../lib/mlton/basic/ref.sig
@@ -150,18 +148,24 @@
 control/region.sml
 ../lib/mlton/set/set.sig
 ../lib/mlton/env/mono-env.sig
-ast/field.sig
-ast/record.sig
+ast/word-size.sig
 ast/wrapped.sig
 ast/tyvar.sig
-ast/ast-const.sig
-ast/ast-id.sig
+ast/field.sig
+ast/record.sig
+ast/real-size.sig
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
+ast/int-size.sig
 ast/prim-tycons.sig
 ast/prim-cons.sig
+ast/ast-id.sig
 ast/longid.sig
+ast/ast-const.sig
 ast/ast-atoms.sig
 ast/ast-core.sig
 ast/ast.sig
+atoms/word-x.sig
 atoms/id.sig
 atoms/var.sig
 atoms/tycon.sig
@@ -170,12 +174,13 @@
 atoms/type.sig
 atoms/generic-scheme.sig
 atoms/scheme.sig
+atoms/real-x.sig
 atoms/profile-exp.sig
 atoms/cons.sig
+atoms/int-x.sig
 atoms/const.sig
 atoms/prim.sig
 atoms/atoms.sig
-atoms/cases.sig
 atoms/hash-type.sig
 xml/xml-type.sig
 xml/xml-tree.sig
@@ -224,24 +229,28 @@
 cm/parse.sml
 cm/cm.sig
 cm/cm.sml
-ast/ast-const.fun
-ast/field.fun
+ast/tyvar.fun
 ../lib/mlton/basic/quick-sort.sig
 ../lib/mlton/basic/insertion-sort.sig
 ../lib/mlton/basic/insertion-sort.sml
 ../lib/mlton/basic/quick-sort.sml
 ast/record.fun
-ast/tyvar.fun
-ast/ast-id.fun
+ast/field.fun
+ast/ast-const.fun
+ast/word-size.fun
+ast/real-size.fun
 ast/prim-tycons.fun
 ast/prim-cons.fun
 ast/longid.fun
+ast/int-size.fun
+ast/ast-id.fun
 ast/ast-atoms.fun
 ast/ast-core.fun
 ast/ast.fun
 ../lib/mlton/set/unordered.fun
 ../lib/mlton/env/basic-env-to-env.fun
 ../lib/mlton/env/mono-env.fun
+atoms/word-x.fun
 atoms/id.fun
 atoms/var.fun
 atoms/use-name.fun
@@ -249,8 +258,10 @@
 atoms/type.fun
 atoms/tycon.fun
 atoms/source-info.fun
+atoms/real-x.fun
 atoms/profile-exp.fun
 atoms/prim.fun
+atoms/int-x.fun
 atoms/generic-scheme.fun
 atoms/const.fun
 atoms/cons.fun
@@ -330,7 +341,6 @@
 ../lib/mlton/basic/clearable-promise.sig
 ../lib/mlton/basic/clearable-promise.sml
 atoms/hash-type.fun
-atoms/cases.fun
 ssa/ssa-tree.fun
 ssa/ssa.fun
 backend/mtype.sig



1.22      +22 -12    mlton/mlton/mlton-stubs.cm

Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- mlton-stubs.cm	15 May 2003 20:12:29 -0000	1.21
+++ mlton-stubs.cm	23 Jun 2003 04:58:54 -0000	1.22
@@ -115,8 +115,6 @@
 ../lib/mlton/basic/field.sig
 ../lib/mlton/basic/field.fun
 ../lib/mlton/basic/ordered-field.fun
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/real.sig
 ../lib/mlton/basic/real.sml
 ../lib/mlton/basic/ref.sig
@@ -149,18 +147,24 @@
 control/region.sml
 ../lib/mlton/set/set.sig
 ../lib/mlton/env/mono-env.sig
-ast/field.sig
-ast/record.sig
+ast/word-size.sig
 ast/wrapped.sig
 ast/tyvar.sig
-ast/ast-const.sig
-ast/ast-id.sig
+ast/field.sig
+ast/record.sig
+ast/real-size.sig
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
+ast/int-size.sig
 ast/prim-tycons.sig
 ast/prim-cons.sig
+ast/ast-id.sig
 ast/longid.sig
+ast/ast-const.sig
 ast/ast-atoms.sig
 ast/ast-core.sig
 ast/ast.sig
+atoms/word-x.sig
 atoms/id.sig
 atoms/var.sig
 atoms/tycon.sig
@@ -169,12 +173,13 @@
 atoms/type.sig
 atoms/generic-scheme.sig
 atoms/scheme.sig
+atoms/real-x.sig
 atoms/profile-exp.sig
 atoms/cons.sig
+atoms/int-x.sig
 atoms/const.sig
 atoms/prim.sig
 atoms/atoms.sig
-atoms/cases.sig
 atoms/hash-type.sig
 xml/xml-type.sig
 xml/xml-tree.sig
@@ -223,24 +228,28 @@
 cm/parse.sml
 cm/cm.sig
 cm/cm.sml
-ast/ast-const.fun
-ast/field.fun
+ast/tyvar.fun
 ../lib/mlton/basic/quick-sort.sig
 ../lib/mlton/basic/insertion-sort.sig
 ../lib/mlton/basic/insertion-sort.sml
 ../lib/mlton/basic/quick-sort.sml
 ast/record.fun
-ast/tyvar.fun
-ast/ast-id.fun
+ast/field.fun
+ast/ast-const.fun
+ast/word-size.fun
+ast/real-size.fun
 ast/prim-tycons.fun
 ast/prim-cons.fun
 ast/longid.fun
+ast/int-size.fun
+ast/ast-id.fun
 ast/ast-atoms.fun
 ast/ast-core.fun
 ast/ast.fun
 ../lib/mlton/set/unordered.fun
 ../lib/mlton/env/basic-env-to-env.fun
 ../lib/mlton/env/mono-env.fun
+atoms/word-x.fun
 atoms/id.fun
 atoms/var.fun
 atoms/use-name.fun
@@ -248,8 +257,10 @@
 atoms/type.fun
 atoms/tycon.fun
 atoms/source-info.fun
+atoms/real-x.fun
 atoms/profile-exp.fun
 atoms/prim.fun
+atoms/int-x.fun
 atoms/generic-scheme.fun
 atoms/const.fun
 atoms/cons.fun
@@ -329,7 +340,6 @@
 ../lib/mlton/basic/clearable-promise.sig
 ../lib/mlton/basic/clearable-promise.sml
 atoms/hash-type.fun
-atoms/cases.fun
 ssa/ssa-tree.fun
 ssa/ssa.fun
 backend/mtype.sig



1.67      +22 -12    mlton/mlton/mlton.cm

Index: mlton.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton.cm,v
retrieving revision 1.66
retrieving revision 1.67
diff -u -r1.66 -r1.67
--- mlton.cm	21 Apr 2003 15:16:17 -0000	1.66
+++ mlton.cm	23 Jun 2003 04:58:54 -0000	1.67
@@ -81,8 +81,6 @@
 ../lib/mlton/basic/field.sig
 ../lib/mlton/basic/field.fun
 ../lib/mlton/basic/ordered-field.fun
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/real.sig
 ../lib/mlton/basic/real.sml
 ../lib/mlton/basic/ref.sig
@@ -115,18 +113,24 @@
 control/region.sml
 ../lib/mlton/set/set.sig
 ../lib/mlton/env/mono-env.sig
-ast/field.sig
-ast/record.sig
+ast/word-size.sig
 ast/wrapped.sig
 ast/tyvar.sig
-ast/ast-const.sig
-ast/ast-id.sig
+ast/field.sig
+ast/record.sig
+ast/real-size.sig
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
+ast/int-size.sig
 ast/prim-tycons.sig
 ast/prim-cons.sig
+ast/ast-id.sig
 ast/longid.sig
+ast/ast-const.sig
 ast/ast-atoms.sig
 ast/ast-core.sig
 ast/ast.sig
+atoms/word-x.sig
 atoms/id.sig
 atoms/var.sig
 atoms/tycon.sig
@@ -135,12 +139,13 @@
 atoms/type.sig
 atoms/generic-scheme.sig
 atoms/scheme.sig
+atoms/real-x.sig
 atoms/profile-exp.sig
 atoms/cons.sig
+atoms/int-x.sig
 atoms/const.sig
 atoms/prim.sig
 atoms/atoms.sig
-atoms/cases.sig
 atoms/hash-type.sig
 xml/xml-type.sig
 xml/xml-tree.sig
@@ -189,24 +194,28 @@
 cm/parse.sml
 cm/cm.sig
 cm/cm.sml
-ast/ast-const.fun
-ast/field.fun
+ast/tyvar.fun
 ../lib/mlton/basic/quick-sort.sig
 ../lib/mlton/basic/insertion-sort.sig
 ../lib/mlton/basic/insertion-sort.sml
 ../lib/mlton/basic/quick-sort.sml
 ast/record.fun
-ast/tyvar.fun
-ast/ast-id.fun
+ast/field.fun
+ast/ast-const.fun
+ast/word-size.fun
+ast/real-size.fun
 ast/prim-tycons.fun
 ast/prim-cons.fun
 ast/longid.fun
+ast/int-size.fun
+ast/ast-id.fun
 ast/ast-atoms.fun
 ast/ast-core.fun
 ast/ast.fun
 ../lib/mlton/set/unordered.fun
 ../lib/mlton/env/basic-env-to-env.fun
 ../lib/mlton/env/mono-env.fun
+atoms/word-x.fun
 atoms/id.fun
 atoms/var.fun
 atoms/use-name.fun
@@ -214,8 +223,10 @@
 atoms/type.fun
 atoms/tycon.fun
 atoms/source-info.fun
+atoms/real-x.fun
 atoms/profile-exp.fun
 atoms/prim.fun
+atoms/int-x.fun
 atoms/generic-scheme.fun
 atoms/const.fun
 atoms/cons.fun
@@ -295,7 +306,6 @@
 ../lib/mlton/basic/clearable-promise.sig
 ../lib/mlton/basic/clearable-promise.sml
 atoms/hash-type.fun
-atoms/cases.fun
 ssa/ssa-tree.fun
 ssa/ssa.fun
 backend/mtype.sig



1.5       +8 -1      mlton/mlton/ast/ast-atoms.fun

Index: ast-atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-atoms.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- ast-atoms.fun	10 Apr 2002 07:02:18 -0000	1.4
+++ ast-atoms.fun	23 Jun 2003 04:58:55 -0000	1.5
@@ -11,13 +11,20 @@
 open S
 structure Wrap = Region.Wrap
 
+structure IntSize = IntSize ()
+structure RealSize = RealSize ()
+structure WordSize = WordSize ()
+
 structure Tycon =
    struct
       structure Id = AstId (val className = "tycon")
       open Id
 
       structure P =
-	 PrimTycons (open Id
+	 PrimTycons (structure IntSize = IntSize
+		     structure RealSize = RealSize
+		     structure WordSize = WordSize
+		     open Id
 		     val fromString = fn s => fromString (s, Region.bogus))
       open P
    end



1.4       +4 -4      mlton/mlton/ast/ast-const.fun

Index: ast-const.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-const.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- ast-const.fun	10 Apr 2002 07:02:18 -0000	1.3
+++ ast-const.fun	23 Jun 2003 04:58:55 -0000	1.4
@@ -11,10 +11,10 @@
 open Region.Wrap
 datatype node =
    Char of char
- | Int of string
+ | Int of IntInf.t
  | Real of string
  | String of string
- | Word of word
+ | Word of IntInf.t
 type t = node Region.Wrap.t
 type node' = node
 type obj = t
@@ -28,10 +28,10 @@
    fun layout c =
       case node c of
 	 Char c => wrap ("#\"", "\"", String.implode [c])
-       | Int s => str s
+       | Int s => str (IntInf.toString s)
        | Real l => String.layout l
        | String s => wrap ("\"", "\"", s)
-       | Word w => seq [str "0wx", str (Word.toString w)]
+       | Word w => str (concat ["0wx", IntInf.format (w, StringCvt.HEX)])
 end
 
 val toString = Layout.toString o layout



1.4       +2 -2      mlton/mlton/ast/ast-const.sig

Index: ast-const.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-const.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- ast-const.sig	10 Apr 2002 07:02:18 -0000	1.3
+++ ast-const.sig	23 Jun 2003 04:58:55 -0000	1.4
@@ -20,10 +20,10 @@
       type t
       datatype node =
 	 Char of char
-       | Int of string
+       | Int of IntInf.t
        | Real of string
        | String of string
-       | Word of word
+       | Word of IntInf.t
       include WRAPPED sharing type node' = node
                       sharing type obj = t
 



1.6       +87 -42    mlton/mlton/ast/prim-tycons.fun

Index: prim-tycons.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- prim-tycons.fun	18 Apr 2003 22:44:58 -0000	1.5
+++ prim-tycons.fun	23 Jun 2003 04:58:55 -0000	1.6
@@ -5,45 +5,90 @@
  * MLton is released under the GNU General Public License (GPL).
  * Please see the file MLton-LICENSE for license information.
  *)
-functor PrimTycons (S: PRIM_TYCONS_STRUCTS)
-   :> PRIM_TYCONS where type tycon = S.t =
-   struct
-      open S
-
-      type tycon = t
-
-      val array = fromString "array"
-      val arrow = fromString "->"
-      val bool = fromString "bool"
-      val char = fromString "char"
-      val exn = fromString "exn"
-      val int = fromString "int"
-      val intInf = fromString "intInf"
-      val list = fromString "list"
-      val pointer = fromString "pointer"
-      val preThread = fromString "preThread"
-      val real = fromString "real"
-      val reff = fromString "ref"
-      val thread = fromString "thread"
-      val tuple = fromString "*"
-      val vector = fromString "vector"
-      val weak = fromString "weak"
-      val word = fromString "word"
-      val word8 = fromString "word8"
-
-      val prims =
-	 [array, arrow, bool, char, exn, int, intInf, list, pointer,
-	  preThread, real, reff, thread, tuple, vector, weak, word, word8]
-
-      val defaultInt = int
-      val defaultWord = word
-
-      fun equalTo t t' = equals (t, t')
-
-      local
-	 fun is l t = List.exists (l, equalTo t)
-      in
-	 val isWordX = is [word, word8]
-	 val isIntX = is [int, intInf]
-      end
-   end
+functor PrimTycons (S: PRIM_TYCONS_STRUCTS): PRIM_TYCONS =
+struct
+
+open S
+
+datatype z = datatype IntSize.t
+datatype z = datatype RealSize.t
+datatype z = datatype WordSize.t
+
+type tycon = t
+
+val array = fromString "array"
+val arrow = fromString "->"
+val bool = fromString "bool"
+val char = fromString "char"
+val exn = fromString "exn"
+val int8 = fromString "int8"
+val int16 = fromString "int16"
+val int32 = fromString "int32"
+val int64 = fromString "int64"
+val intInf = fromString "intInf"
+val list = fromString "list"
+val pointer = fromString "pointer"
+val preThread = fromString "preThread"
+val real32 = fromString "real32"
+val real64 = fromString "real64"
+val reff = fromString "ref"
+val thread = fromString "thread"
+val tuple = fromString "*"
+val vector = fromString "vector"
+val weak = fromString "weak"
+val word8 = fromString "word8"
+val word16 = fromString "word16"
+val word32 = fromString "word32"
+
+val ints =
+   [(int8, I8),
+    (int16, I16),
+    (int32, I32),
+    (int64, I64)]
+
+val reals =
+   [(real32, R32),
+    (real64, R64)]
+
+val words =
+   [(word8, W8),
+    (word16, W16),
+    (word32, W32)]
+   
+val prims =
+   [array, arrow, bool, char, exn,
+    int8, int16, int32, int64, intInf,
+    list, pointer, preThread,
+    real32, real64,
+    reff, thread, tuple, vector, weak,
+    word8, word16, word32]
+   
+val int =
+   fn I8 => int8
+    | I16 => int16
+    | I32 => int32
+    | I64 => int64
+
+val real =
+   fn R32 => real32
+    | R64 => real64
+	
+val word =
+   fn W8 => word8
+    | W16 => word16
+    | W32 => word32
+	 
+val defaultInt = int IntSize.default
+val defaultReal = real RealSize.default
+val defaultWord = word WordSize.default
+   
+local
+   fun is l t = List.exists (l, fn t' => equals (t, t'))
+in
+   val isIntX = is [int8, int16, int32, int64, int8, intInf]
+   val isRealX = is [real32, real64]
+   val isWordX = is [word8, word16, word32]
+end
+
+end
+	  



1.6       +22 -12    mlton/mlton/ast/prim-tycons.sig

Index: prim-tycons.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- prim-tycons.sig	18 Apr 2003 22:44:58 -0000	1.5
+++ prim-tycons.sig	23 Jun 2003 04:58:55 -0000	1.6
@@ -7,39 +7,49 @@
  *)
 signature PRIM_TYCONS_STRUCTS =
    sig
+      structure IntSize: INT_SIZE
+      structure RealSize: REAL_SIZE
+      structure WordSize: WORD_SIZE
+
       type t
+
       val fromString: string -> t
       val equals: t * t -> bool
    end
 
 signature PRIM_TYCONS =
    sig
+      structure IntSize: INT_SIZE
+      structure RealSize: REAL_SIZE
+      structure WordSize: WORD_SIZE
+
       type tycon
 
       val array: tycon
       val arrow: tycon
       val bool: tycon
       val char: tycon
+      val defaultInt: tycon
+      val defaultReal: tycon
+      val defaultWord: tycon
       val exn: tycon
-      val int: tycon
+      val int: IntSize.t -> tycon
+      val ints: (tycon * IntSize.t) list
       val intInf: tycon
+      val isIntX: tycon -> bool
+      val isRealX: tycon -> bool
+      val isWordX: tycon -> bool
       val list: tycon
       val pointer: tycon
       val preThread: tycon
-      val real: tycon
+      val prims: tycon list
+      val real: RealSize.t -> tycon
+      val reals: (tycon * RealSize.t) list
       val reff: tycon
       val thread: tycon
       val tuple: tycon
       val vector: tycon
       val weak: tycon
-      val word: tycon
-      val word8: tycon
-
-      val prims: tycon list
-
-      val defaultInt: tycon
-      val defaultWord: tycon
-	 
-      val isWordX: tycon -> bool
-      val isIntX: tycon -> bool
+      val word: WordSize.t -> tycon
+      val words: (tycon * WordSize.t) list
    end



1.5       +15 -6     mlton/mlton/ast/record.fun

Index: record.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/record.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- record.fun	7 Dec 2002 02:21:51 -0000	1.4
+++ record.fun	23 Jun 2003 04:58:55 -0000	1.5
@@ -32,6 +32,9 @@
       Tuple t => SOME t
     | Record _ => NONE
 
+fun sort v =
+   QuickSort.sortVector (v, fn ((s, _), (s', _)) => Field.<= (s, s'))
+   
 fun fromVector v =
    let
       fun isTuple v : bool =
@@ -40,15 +43,21 @@
 	  case f of
 	     Field.Int i' => Int.equals (i, i')
 	   | _ => false)
-      val v =
-	 if isSorted
-	    then QuickSort.sortVector (v, fn ((s, _), (s', _)) =>
-				       Field.<= (s, s')) 
-	 else v
-   in if isTuple v
+      val v = if isSorted then sort v else v
+   in
+      if isTuple v
 	 then Tuple (Vector.map (v, #2))
       else Record v
    end
+
+fun equals (r, r', eq) =
+   case (r, r') of
+      (Tuple v, Tuple v') => Vector.equals (v, v', eq)
+    | (Record fs, Record fs') =>
+	 Vector.equals
+	 (fs, sort fs', fn ((f, v), (f', v')) =>
+	  Field.equals (f, f') andalso eq (v, v'))
+    | _ => false
 
 val peek: 'a t * Field.t -> 'a option =
    fn (r, f) =>



1.3       +1 -0      mlton/mlton/ast/record.sig

Index: record.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/record.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- record.sig	10 Apr 2002 07:02:18 -0000	1.2
+++ record.sig	23 Jun 2003 04:58:55 -0000	1.3
@@ -23,6 +23,7 @@
       val change: 'a t * ('a vector -> 'b vector * 'c) -> 'b t * 'c
       (* detuple r returns the components, if r is a tuple *)
       val detupleOpt: 'a t -> 'a vector option
+      val equals: 'a t * 'a t * ('a * 'a -> bool) -> bool
       val exists: 'a t * ('a -> bool) -> bool
       val fold: 'a t * 'b * ('a * 'b -> 'b) -> 'b
       val foldi: 'a t * 'b * (Field.t * 'a * 'b ->'b) -> 'b



1.4       +28 -19    mlton/mlton/ast/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/sources.cm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- sources.cm	16 Apr 2002 12:10:52 -0000	1.3
+++ sources.cm	23 Jun 2003 04:58:55 -0000	1.4
@@ -9,11 +9,14 @@
 
 signature AST
 signature AST_ID
+signature INT_SIZE
 signature LONGID
 signature PRIM_CONS
 signature PRIM_TYCONS
+signature REAL_SIZE
 signature RECORD
 signature TYVAR
+signature WORD_SIZE
 signature WRAPPED
 
 functor Ast
@@ -25,26 +28,32 @@
 ../../lib/mlton/sources.cm
 ../control/sources.cm
 
-wrapped.sig
-tyvar.sig
-tyvar.fun
-field.sig
-record.sig
-record.fun
-field.fun
-ast-const.sig
-ast-const.fun
-prim-tycons.sig
-prim-cons.sig
-ast-id.sig
-longid.sig
+ast-atoms.fun
 ast-atoms.sig
-ast-core.sig
+ast-const.fun
+ast-const.sig
 ast-core.fun
-prim-tycons.fun
-prim-cons.fun
-longid.fun
+ast-core.sig
 ast-id.fun
-ast-atoms.fun
-ast.sig
+ast-id.sig
 ast.fun
+ast.sig
+field.fun
+field.sig
+int-size.fun
+int-size.sig
+longid.fun
+longid.sig
+prim-cons.fun
+prim-cons.sig
+prim-tycons.fun
+prim-tycons.sig
+real-size.fun
+real-size.sig
+record.fun
+record.sig
+tyvar.fun
+tyvar.sig
+word-size.fun
+word-size.sig
+wrapped.sig



1.1                  mlton/mlton/ast/int-size.fun

Index: int-size.fun
===================================================================
functor IntSize (S: INT_SIZE_STRUCTS): INT_SIZE =
struct

datatype t = I8 | I16 | I32 | I64

val equals: t * t -> bool = op =

val all = [I8, I16, I32, I64]

val default = I32

val bytes: t -> int =
   fn I8 => 1
    | I16 => 2
    | I32 => 4
    | I64 => 8
   
fun size s = 8 * bytes s

val toString = Int.toString o size

val layout = Layout.str o toString

val memoize: (t -> 'a) -> t -> 'a =
   fn f =>
   let
      val a8 = f I8
      val a16 = f I16
      val a32 = f I32
      val a64 = f I64
   in
      fn I8 => a8
       | I16 => a16
       | I32 => a32
       | I64 => a64
   end

val range =
   memoize
   (fn s =>
    let
       val pow = IntInf.pow (IntInf.fromInt 2, size s - 1)
    in
       (IntInf.~ pow, IntInf.- (pow, IntInf.fromInt 1))
    end)

fun isInRange (s, i) =
   let
      val (min, max) = range s
   in
      IntInf.<= (min, i) andalso IntInf.<= (i, max)
   end

val min = #1 o range

val max = #2 o range

end



1.1                  mlton/mlton/ast/int-size.sig

Index: int-size.sig
===================================================================
type int = Int.t
   
signature INT_SIZE_STRUCTS =
   sig
   end

signature INT_SIZE =
   sig
      include INT_SIZE_STRUCTS
	 
      datatype t = I8 | I16 | I32 | I64

      val all: t list
      val bytes: t -> int
      val default: t
      val equals: t * t -> bool
      val isInRange: t * IntInf.t -> bool
      val layout: t -> Layout.t
      val max: t -> IntInf.t
      val memoize: (t -> 'a) -> t -> 'a
      val min: t -> IntInf.t
      val range: t -> IntInf.t * IntInf.t
      val size: t -> int
      val toString: t -> string
   end



1.1                  mlton/mlton/ast/real-size.fun

Index: real-size.fun
===================================================================
functor RealSize (S: REAL_SIZE_STRUCTS): REAL_SIZE = 
struct

open S

datatype t = R32 | R64

val all = [R32, R64]
   
val default = R64

val equals: t * t -> bool = op =

val memoize: (t -> 'a) -> t -> 'a =
   fn f =>
   let
      val r32 = f R32
      val r64 = f R64
   in
      fn R32 => r32
       | R64 => r64
   end

val toString =
   fn R32 => "32"
    | R64 => "64"

val bytes: t -> int =
   fn R32 => 4
    | R64 => 8
	 
end



1.1                  mlton/mlton/ast/real-size.sig

Index: real-size.sig
===================================================================
type int = Int.t
type word = Word.t
   
signature REAL_SIZE_STRUCTS = 
   sig
   end

signature REAL_SIZE = 
   sig
      include REAL_SIZE_STRUCTS
      
      datatype t = R32 | R64

      val all: t list
      val bytes: t -> int
      val default: t
      val equals: t * t -> bool
      val memoize: (t -> 'a) -> t -> 'a
      val toString: t -> string
   end



1.1                  mlton/mlton/ast/word-size.fun

Index: word-size.fun
===================================================================
functor WordSize (S: WORD_SIZE_STRUCTS): WORD_SIZE =
struct

datatype t = W8 | W16 | W32

val equals: t * t -> bool = op =

val all = [W8, W16, W32]

val default = W32

val max: t -> word =
   fn W8 => 0wxFF
    | W16 => 0wxFFFF
    | W32 => 0wxFFFFFFFF

val allOnes = max

val bytes: t -> int = 
   fn W8 => 1
    | W16 => 2
    | W32 => 4

fun size s = 8 * bytes s

fun toString w = Int.toString (size w)

val memoize: (t -> 'a) -> t -> 'a =
   fn f =>
   let
      val a8 = f W8
      val a16 = f W16
      val a32 = f W32
   in
      fn W8 => a8
       | W16 => a16
       | W32 => a32
   end
   
end



1.1                  mlton/mlton/ast/word-size.sig

Index: word-size.sig
===================================================================
type int = Int.t
type word = Word.t
   
signature WORD_SIZE_STRUCTS =
   sig
   end

signature WORD_SIZE =
   sig
      include WORD_SIZE_STRUCTS
	 
      datatype t = W8 | W16 | W32

      val all: t list
      val allOnes: t -> word
      val bytes: t -> int
      val default: t
      val equals: t * t -> bool
      val max: t -> word
      val memoize: (t -> 'a) -> t -> 'a
      val size: t -> int
      val toString: t -> string
   end



1.7       +20 -6     mlton/mlton/atoms/atoms.fun

Index: atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- atoms.fun	18 Apr 2003 22:44:58 -0000	1.6
+++ atoms.fun	23 Jun 2003 04:58:55 -0000	1.7
@@ -15,12 +15,18 @@
       structure SourceInfo = SourceInfo ()
       structure ProfileExp = ProfileExp (structure SourceInfo = SourceInfo)
       structure Var = Var (structure AstId = Ast.Var)
-      structure Tycon = Tycon (structure AstId = Ast.Tycon)
+      structure Tycon = Tycon (structure AstId = Ast.Tycon
+			       structure IntSize = IntSize
+			       structure RealSize = RealSize
+			       structure WordSize = WordSize)
+      fun f (x: IntSize.t): Tycon.IntSize.t = x
       structure Type =
 	 Type (structure Ast = Ast
-	      structure Record = Ast.SortedRecord
-	      structure Tyvar = Ast.Tyvar
-	      structure Tycon = Tycon)
+	       structure IntSize = IntSize
+	       structure Record = Ast.SortedRecord
+	       structure Tyvar = Ast.Tyvar
+	       structure Tycon = Tycon
+	       structure WordSize = WordSize)
       structure Scheme: SCHEME =
 	 struct
 	    structure Arg =
@@ -34,13 +40,21 @@
 	 end
       structure Con = Con (structure AstId = Ast.Con
 			  structure Var = Var)
+      structure IntX = IntX (structure IntSize = IntSize)
+      structure RealX = RealX (structure RealSize = RealSize)
+      structure WordX = WordX (structure WordSize = WordSize)
       structure Const = Const (structure Ast = Ast
-			      structure Tycon = Tycon)
+			       structure IntX = IntX
+			       structure RealX = RealX
+			       structure WordX = WordX)
       structure Prim = Prim (structure Con = Con
 			     structure Const = Const
+			     structure IntSize = IntSize
 			     structure Longid = Ast.Longvid
+			     structure RealSize = RealSize
+			     structure Scheme = Scheme
 			     structure Type = Type
-			     structure Scheme = Scheme)
+			     structure WordSize = WordSize)
       structure Record = Ast.Record
       structure SortedRecord = Ast.SortedRecord
       structure Tyvar = Ast.Tyvar



1.7       +12 -1     mlton/mlton/atoms/atoms.sig

Index: atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- atoms.sig	18 Apr 2003 22:44:58 -0000	1.6
+++ atoms.sig	23 Jun 2003 04:58:55 -0000	1.7
@@ -8,6 +8,9 @@
 signature ATOMS_STRUCTS =
    sig
       structure Ast: AST
+      structure IntSize: INT_SIZE
+      structure RealSize: REAL_SIZE
+      structure WordSize: WORD_SIZE
    end
 
 signature ATOMS' =
@@ -17,8 +20,10 @@
       structure Con: CON
       structure Cons: SET
       structure Const: CONST
+      structure IntX: INT_X
       structure Prim: PRIM 
       structure ProfileExp: PROFILE_EXP
+      structure RealX: REAL_X
       structure Record: RECORD
       structure Scheme: SCHEME
       structure SortedRecord: RECORD
@@ -39,6 +44,7 @@
             val rename: t * Tyvar.t vector -> t * Tyvar.t vector
 	 end
       structure Tyvars: SET
+      structure WordX: WORD_X
 
       sharing Ast = Const.Ast = Prim.Type.Ast
       sharing Ast.Con = Con.AstId
@@ -47,13 +53,18 @@
       sharing Ast.Var = Var.AstId
       sharing Con = Prim.Con
       sharing Const = Prim.Const
+      sharing IntSize = IntX.IntSize = Prim.IntSize = Tycon.IntSize
+      sharing IntX = Const.IntX
+      sharing RealSize = Prim.RealSize = RealX.RealSize = Tycon.RealSize
+      sharing RealX = Const.RealX
       sharing Record = Ast.Record
       sharing Scheme = Prim.Scheme
       sharing SortedRecord = Ast.SortedRecord
       sharing SourceInfo = ProfileExp.SourceInfo
-      sharing Tycon = Const.Tycon
       sharing Tycon = Scheme.Tycon
       sharing Tyvar = Ast.Tyvar
+      sharing WordSize = Prim.WordSize = Tycon.WordSize = WordX.WordSize
+      sharing WordX = Const.WordX
       sharing type Con.t = Cons.Element.t
       sharing type Tycon.t = Tycons.Element.t
       sharing type Tyvar.t = TyvarEnv.Domain.t



1.4       +1 -91     mlton/mlton/atoms/cases.fun

Index: cases.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/cases.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- cases.fun	16 Apr 2002 12:10:52 -0000	1.3
+++ cases.fun	23 Jun 2003 04:58:55 -0000	1.4
@@ -13,99 +13,9 @@
 datatype 'a t =
    Char of (char * 'a) vector
  | Con of (con * 'a) vector
- | Int of (int * 'a) vector
+ | Int of (IntInf.t * 'a) vector
  | Word of (word * 'a) vector
- | Word8 of (Word8.t * 'a) vector
 
-fun equals (c1: 'a t, c2: 'a t, eq: 'a * 'a -> bool): bool =
-   let
-      fun doit (l1, l2, eq') = 
-	 Vector.equals 
-	 (l1, l2, fn ((x1, a1), (x2, a2)) =>
-	  eq' (x1, x2) andalso eq (a1, a2))
-   in case (c1, c2) of
-      (Char l1, Char l2) => doit (l1, l2, Char.equals)
-    | (Con l1, Con l2) => doit (l1, l2, conEquals)
-    | (Int l1, Int l2) => doit (l1, l2, Int.equals)
-    | (Word l1, Word l2) => doit (l1, l2, Word.equals)
-    | (Word8 l1, Word8 l2) => doit (l1, l2, Word8.equals)
-    | _ => false
-   end
-
-fun fold (c: 'a t, b: 'b, f: 'a * 'b -> 'b): 'b =
-   let
-      fun doit l = Vector.fold (l, b, fn ((_, a), b) => f (a, b))
-   in case c of
-      Char l => doit l
-    | Con l => doit l
-    | Int l => doit l
-    | Word l => doit l
-    | Word8 l => doit l
-   end
-
-fun map (c: 'a t, f: 'a -> 'b): 'b t =
-   let
-      fun doit l = Vector.map (l, fn (i, x) => (i, f x))
-   in case c of
-      Char l => Char (doit l)
-    | Con l => Con (doit l)
-    | Int l => Int (doit l)
-    | Word l => Word (doit l)
-    | Word8 l => Word8 (doit l)
-   end
-
-fun forall (c: 'a t, f: 'a -> bool): bool =
-   let
-      fun doit l = Vector.forall (l, fn (_, x) => f x)
-   in case c of
-      Char l => doit l
-    | Con l => doit l
-    | Int l => doit l
-    | Word l => doit l
-    | Word8 l => doit l
-   end
-
-fun isEmpty (c: 'a t): bool =
-   let
-      fun doit v = 0 = Vector.length v
-   in case c of
-      Char v => doit v
-    | Con v => doit v
-    | Int v => doit v
-    | Word v => doit v
-    | Word8 v => doit v
-   end
-
-fun hd (c: 'a t): 'a =
-   let
-      fun doit v =
-	 if Vector.length v >= 1
-	    then let val (_, a) = Vector.sub (v, 0)
-		 in a
-		 end
-	 else Error.bug "Cases.hd"
-   in case c of
-      Char l => doit l
-    | Con l => doit l
-    | Int l => doit l
-    | Word l => doit l
-    | Word8 l => doit l
-   end
-
-fun length (c: 'a t): int = fold (c, 0, fn (_, i) => i + 1)
-
-fun foreach (c, f) = fold (c, (), fn (x, ()) => f x)
-
-fun foreach' (c: 'a t, f: 'a -> unit, fc: con -> unit): unit =
-   let
-      fun doit l = Vector.foreach (l, fn (_, a) => f a)
-   in case c of
-      Char l => doit l
-    | Con l => Vector.foreach (l, fn (c, a) => (fc c; f a))
-    | Int l => doit l
-    | Word l => doit l
-    | Word8 l => doit l
-   end
 
 
 end



1.4       +5 -13     mlton/mlton/atoms/cases.sig

Index: cases.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/cases.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- cases.sig	16 Apr 2002 12:10:52 -0000	1.3
+++ cases.sig	23 Jun 2003 04:58:55 -0000	1.4
@@ -6,12 +6,14 @@
  * Please see the file MLton-LICENSE for license information.
  *)
 type int = Int.t
-type word = Word.t
 
 signature CASES_STRUCTS = 
    sig
       type con
-      val conEquals : con * con -> bool
+      type word
+
+      val conEquals: con * con -> bool
+      val wordEquals: word * word -> bool
    end
 
 signature CASES = 
@@ -21,9 +23,8 @@
       datatype 'a t =
 	 Char of (char * 'a) vector
        | Con of (con * 'a) vector
-       | Int of (int * 'a) vector
+       | Int of (IntInf.t * 'a) vector
        | Word of (word * 'a) vector
-       | Word8 of (Word8.t * 'a) vector
 
       val equals: 'a t * 'a t * ('a * 'a -> bool) -> bool
       val fold: 'a t * 'b * ('a * 'b -> 'b) -> 'b
@@ -35,12 +36,3 @@
       val length: 'a t -> int
       val map: 'a t * ('a -> 'b) -> 'b t
    end
-
-functor TestCasesVector (S: CASES) =
-struct
-
-open S
-
-val _ = Assert.assert ("Cases", fn () => true)
-
-end



1.8       +80 -128   mlton/mlton/atoms/const.fun

Index: const.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/const.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- const.fun	19 May 2003 18:36:45 -0000	1.7
+++ const.fun	23 Jun 2003 04:58:55 -0000	1.8
@@ -10,146 +10,28 @@
 
 open S
 
-local open Ast
-in structure Aconst = Const
-end
-
-structure Type =
-   struct
-      type t = Tycon.t * Tycon.t vector
-      fun equals ((tc1,tcs1), (tc2,tcs2)) =
-	 Tycon.equals (tc1, tc2)
-	 andalso
-	 Vector.equals (tcs1, tcs2, Tycon.equals)
-      fun toType ((tc,tcs), con) =
-	 con (tc, Vector.map (tcs, fn tc => con (tc, Vector.new0())))
-      val layout = Ast.Type.layout o (fn t => 
-				      toType (t, fn (t, ts) => 
-					      Ast.Type.con (Tycon.toAst t, ts)))
-      val toString = Layout.toString o layout
-      fun make (tc, tcs) : t = (tc, tcs)
-      fun unary (tc, tc') = make (tc, Vector.new1 tc')
-      fun nullary tc = make (tc, Vector.new0())
-      val bool = nullary Tycon.bool
-      val char = nullary Tycon.char
-      val int = nullary Tycon.defaultInt
-      val intInf = nullary Tycon.intInf
-      val real = nullary Tycon.real
-      val word = nullary Tycon.word
-      val word8 = nullary Tycon.word8
-      val string = unary (Tycon.vector, Tycon.char)
-   end
-
-structure Node =
-   struct
-      datatype t =
-	 Char of char
-       | Int of int
-       | IntInf of IntInf.t
-       | Real of string
-       | String of string
-       | Word of word
-
-      local
-	 open Layout
-	 fun wrap (pre, post, s) = seq [str pre, String.layout s, str post]
-      in
-	 val layout =
-	    fn Char c => wrap ("#\"", "\"", String.implode [c])
-	     | Int n => str (Int.toString n)
-	     | IntInf s => IntInf.layout s
-	     | Real r => String.layout r
-	     | String s => wrap ("\"", "\"", s)
-	     | Word w => seq [str "0wx", str (Word.toString w)]
-      end
-   end
-
-datatype z = datatype Node.t
-datatype t = T of {node: Node.t,
-		   ty: Type.t}
-
 local
-   fun make sel (T r) = sel r
+   open Ast
 in
-   val node = make #node
-   val ty = make #ty
+   structure Aconst = Const
 end
-
-val layout = Node.layout o node
-val toString = Layout.toString o layout
-   
-fun make (n, t) = T {node = n, ty = t}
-
 local
-   val char = Random.word ()
-   val truee = Random.word ()
-   val falsee = Random.word ()
+   open IntX
 in
-   fun hash (c: t): word =
-      case node c of
-	 Char c => Word.xorb (char, Word.fromChar c)
-       | Int i => Word.fromInt i
-       | IntInf i => String.hash (IntInf.toString i)
-       | Real r => String.hash r
-       | String s => String.hash s
-       | Word w => w
+   structure IntSize = IntSize
 end
-   
-fun 'a toAst (make: Ast.Const.t -> 'a, constrain: 'a * Ast.Type.t -> 'a) c =
-   let
-      val make = fn n => make (Ast.Const.makeRegion (n, Region.bogus))
-      fun maybeConstrain (defaultTycon, aconst) =
-	 let
-	    val ty = ty c
-	    val con : Tycon.t * Ast.Type.t vector -> Ast.Type.t =
-	       fn (t, ts) => Ast.Type.con (Tycon.toAst t, ts)
-	 in
-	    if Type.equals (ty, Type.nullary defaultTycon)
-	       then make aconst
-	    else constrain (make aconst, Type.toType (ty, con))
-	 end
-      fun int s = maybeConstrain (Tycon.defaultInt, Aconst.Int s)
-   in
-      case node c of
-	 Char c => make (Aconst.Char c)
-       | Int n => int (Int.toString n)
-       | IntInf i => int (IntInf.toString i)
-       | Real r => make (Aconst.Real r)
-       | String s => make (Aconst.String s)
-       | Word w => maybeConstrain (Tycon.defaultWord, Aconst.Word w)
-   end
-
-val toAstExp = toAst (Ast.Exp.const, Ast.Exp.constraint)
-val toAstPat = toAst (Ast.Pat.const, Ast.Pat.constraint)
-
-fun equals (c, c') =
-   Type.equals (ty c, ty c')
-   andalso
-   case (node c, node c') of
-      (Char c, Char c') => c = c'
-    | (Int n, Int n') => n = n'
-    | (IntInf i, IntInf i') => IntInf.equals (i, i')
-    | (Real r, Real r') => String.equals (r, r')
-    | (String s, String s') => String.equals (s, s')
-    | (Word w, Word w') => w = w'
-    | _ => false
-
-val equals = Trace.trace2 ("Const.equals", layout, layout, Bool.layout) equals
-
 local
-   fun make c t x = T {node = c x, ty = t}
+   open WordX
 in
-   val fromChar = make Char Type.char
-   val fromInt = make Int Type.int
-   val fromIntInf = make IntInf Type.intInf
-   val fromReal = make Real Type.real
-   val fromString = make String Type.string
-   val fromWord = make Word Type.word
-   val fromWord8 = make (fn w => Word (Word.fromWord8 w)) Type.word8
+   structure WordSize = WordSize
 end
 
+datatype z = datatype IntSize.t
+datatype z = datatype WordSize.t
+
 structure SmallIntInf =
    struct
+      structure Word = Pervasive.Word
       (*
        * The IntInf.fromInt calls are just because SML/NJ doesn't
        * overload integer constants for IntInf.int's.
@@ -176,5 +58,75 @@
 	    then SOME (IntInf.fromInt (Word.toIntX (Word.~>> (w, 0w1))))
 	 else NONE
    end
+
+datatype t =
+   Int of IntX.t
+ | IntInf of IntInf.t
+ | Real of RealX.t
+ | Word of WordX.t
+ | Word8Vector of Word8.t vector
+
+val int = Int
+val real = Real
+val intInf = IntInf
+val word = Word
+val word8Vector = Word8Vector
+
+val word8 = word o WordX.fromWord8 
+val string = word8Vector o Word8.stringToVector
+   
+local
+   open Layout
+   fun wrap (pre, post, s) = seq [str pre, String.layout s, str post]
+in
+   val layout =
+      fn Int i => IntX.layout i
+       | IntInf i => IntInf.layout i
+       | Real r => RealX.layout r
+       | Word w => WordX.layout w
+       | Word8Vector v => wrap ("\"", "\"", Word8.vectorToString v)
+end	 
+
+val toString = Layout.toString o layout
+
+local
+   val truee = Random.word ()
+   val falsee = Random.word ()
+in
+   fun hash (c: t): word =
+      case c of
+	 Int i => String.hash (IntX.toString i)
+       | IntInf i => String.hash (IntInf.toString i)
+       | Real r => RealX.hash r
+       | Word w => WordX.toWord w
+       | Word8Vector v => String.hash (Word8.vectorToString v)
+end
+   
+fun 'a toAst (make: Ast.Const.t -> 'a, constrain: 'a * Ast.Type.t -> 'a) c =
+   let
+      val aconst =
+	 case c of
+	    Int i => Aconst.Int (IntX.toIntInf i)
+	  | IntInf i => Aconst.Int i
+	  | Real r => Aconst.Real (RealX.toString r)
+	  | Word w => Aconst.Word (WordX.toIntInf w)
+	  | Word8Vector v => Aconst.String (Word8.vectorToString v)
+   in
+      make (Ast.Const.makeRegion (aconst, Region.bogus))
+   end
+
+val toAstExp = toAst (Ast.Exp.const, Ast.Exp.constraint)
+val toAstPat = toAst (Ast.Pat.const, Ast.Pat.constraint)
+
+fun equals (c, c') =
+   case (c, c') of
+      (Int i, Int i') => IntX.equals (i, i')
+    | (IntInf i, IntInf i') => IntInf.equals (i, i')
+    | (Real r, Real r') => RealX.equals (r, r')
+    | (Word w, Word w') => WordX.equals (w, w')
+    | (Word8Vector v, Word8Vector v') => v = v'
+    | _ => false
+
+val equals = Trace.trace2 ("Const.equals", layout, layout, Bool.layout) equals
   
 end



1.7       +16 -45    mlton/mlton/atoms/const.sig

Index: const.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/const.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- const.sig	19 May 2003 18:36:45 -0000	1.6
+++ const.sig	23 Jun 2003 04:58:55 -0000	1.7
@@ -11,33 +11,15 @@
 signature CONST_STRUCTS = 
    sig
       structure Ast: AST
-      structure Tycon: TYCON
-      sharing Tycon.AstId = Ast.Tycon
-      sharing Tycon.AstId = Ast.Tycon
+      structure IntX: INT_X
+      structure RealX: REAL_X
+      structure WordX: WORD_X
    end
 
 signature CONST = 
    sig
       include CONST_STRUCTS
 
-      structure Type:
-	 sig
-	    type t
-	    val make: Tycon.t * Tycon.t vector -> t
-	    val equals: t * t -> bool
-	    val layout: t -> Layout.t
-	    val toString: t -> string
-	    val toType: t * (Tycon.t * 'a vector -> 'a) -> 'a
-	    val bool: t
-	    val char: t
-	    val int: t
-	    val intInf: t
-	    val real: t
-	    val string: t
-	    val word: t
-	    val word8: t
-	 end
-
       structure SmallIntInf:
 	 sig
 	    val isSmall: IntInf.t -> bool
@@ -45,35 +27,24 @@
 	    val fromWord: word -> IntInf.t option
 	 end
 
-      type t
-
-      structure Node:
-	 sig
-	    datatype t =
-	       Char of char
-	     | Int of int
-	     | IntInf of IntInf.t
-	     | Real of string
-	     | String of string
-	     | Word of word
-
-	    val layout: t -> Layout.t
-	 end
+      datatype t =
+	 Int of IntX.t
+       | IntInf of IntInf.t
+       | Real of RealX.t
+       | Word of WordX.t
+       | Word8Vector of Word8.t vector
 
       val equals: t * t -> bool
-      val fromChar: char -> t
-      val fromInt: int -> t
-      val fromIntInf: IntInf.t -> t
-      val fromReal: string -> t
-      val fromString: string -> t
-      val fromWord: word -> t
-      val fromWord8: Word8.t -> t
+      val int: IntX.t -> t
+      val intInf: IntInf.t -> t
       val hash: t -> word
       val layout: t -> Layout.t
-      val make: Node.t * Type.t -> t
-      val node: t -> Node.t
+      val real: RealX.t -> t
+      val string: string -> t
       val toAstExp: t -> Ast.Exp.t
       val toAstPat: t -> Ast.Pat.t
       val toString: t -> string
-      val ty: t -> Type.t
+      val word: WordX.t -> t
+      val word8: Word8.t -> t
+      val word8Vector: Word8.t vector -> t
    end



1.7       +18 -2     mlton/mlton/atoms/hash-type.fun

Index: hash-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/hash-type.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- hash-type.fun	9 May 2003 19:29:42 -0000	1.6
+++ hash-type.fun	23 Jun 2003 04:58:55 -0000	1.7
@@ -99,6 +99,8 @@
    
       val layout = Ast.Type.layout o toAst
 
+      val toString = Layout.toString o layout
+	 
       (* 	let open Layout
        * n
        *   case tree of
@@ -153,10 +155,14 @@
 				 layout) con
       end
    end
-structure Ops = TypeOps (structure Tycon = Tycon
+structure Ops = TypeOps (structure IntSize = IntSize
+			 structure Tycon = Tycon
+			 structure WordSize = WordSize
 			 open Type)
 open Type Ops
 
+val string = word8Vector
+   
 structure Plist = PropertyList
 
 local structure Type = Ast.Type
@@ -175,7 +181,17 @@
 
 fun optionToAst z = Option.map (z, toAst)
 
-fun ofConst c = Const.Type.toType (Const.ty c, con)
+fun ofConst c =
+   let
+      datatype z = datatype Const.t
+   in
+      case c of
+	 Int i => int (IntX.size i)
+       | IntInf _ => intInf
+       | Real r => real (RealX.size r)
+       | Word w => word (WordX.size w)
+       | Word8Vector _ => word8Vector
+   end
 
 fun isUnit t =
    case dest t of



1.4       +7 -1      mlton/mlton/atoms/hash-type.sig

Index: hash-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/hash-type.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- hash-type.sig	10 Apr 2002 07:02:18 -0000	1.3
+++ hash-type.sig	23 Jun 2003 04:58:55 -0000	1.4
@@ -13,7 +13,11 @@
 signature HASH_TYPE = 
    sig
       include HASH_TYPE_STRUCTS
-      include TYPE_OPS sharing type tycon = Tycon.t
+      include TYPE_OPS
+      sharing type intSize = IntSize.t
+      sharing type realSize = RealSize.t
+      sharing type tycon = Tycon.t
+      sharing type wordSize = WordSize.t
 
       structure Dest:
 	 sig
@@ -48,6 +52,7 @@
       val optionToAst: t option -> Ast.Type.t option
       val plist: t -> PropertyList.t
       val stats: unit -> Layout.t
+      val string: t (* synonym for word8Vector *)
       (* substitute (t, [(a1, t1), ..., (an, tn)]) performs simultaneous
        * substitution of the ti for ai in t.
        * The ai's are not required to contain every free variable in t
@@ -56,6 +61,7 @@
       (* conversion to Ast *)
       val toAst: t -> Ast.Type.t
       val toPrim: t -> Prim.Type.t
+      val toString: t -> string
       val tycon: t -> Tycon.t
       val var: Tyvar.t -> t
    end



1.50      +699 -736  mlton/mlton/atoms/prim.fun

Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.49
retrieving revision 1.50
diff -u -r1.49 -r1.50
--- prim.fun	20 May 2003 02:18:26 -0000	1.49
+++ prim.fun	23 Jun 2003 04:58:55 -0000	1.50
@@ -15,7 +15,18 @@
 
 open S
 
-local open Type
+datatype z = datatype IntSize.t
+datatype z = datatype RealSize.t
+datatype z = datatype WordSize.t	       
+
+local
+   open Const
+in
+   structure IntX = IntX
+   structure WordX = WordX
+end
+local
+   open Type
 in
    structure Tycon = Tycon
    structure Tyvar = Tyvar
@@ -33,236 +44,297 @@
 structure Name =
    struct
       datatype t =
-	 Array_array
-       | Array_array0Const
-       | Array_length
-       | Array_sub
-       | Array_update
-       | BuildConstant of string
-       | Byte_byteToChar
-       | Byte_charToByte
-       | C_CS_charArrayToWord8Array
-       | Char_chr
-       | Char_ge
-       | Char_gt
-       | Char_le
-       | Char_lt
-       | Char_ord
-       | Constant of string
-       | Cpointer_isNull
-       | Exn_extra
-       | Exn_keepHistory
-       | Exn_name
-       | Exn_setExtendExtra
-       | Exn_setInitExtra
-       | Exn_setTopLevelHandler
-       | FFI of string
-       | GC_collect
-       | GC_pack
-       | GC_unpack
-       | Int_add
-       | Int_addCheck
-       | Int_ge
-       | Int_geu
-       | Int_gt
-       | Int_gtu
-       | Int_le
-       | Int_lt
-       | Int_mul
-       | Int_mulCheck
-       | Int_neg
-       | Int_negCheck
-       | Int_quot
-       | Int_rem
-       | Int_sub
-       | Int_subCheck
-       | IntInf_add
-       | IntInf_andb
-       | IntInf_arshift
-       | IntInf_compare
-       | IntInf_equal
-       | IntInf_fromVector
-       | IntInf_fromWord
-       | IntInf_gcd
-       | IntInf_lshift
-       | IntInf_mul
-       | IntInf_notb
-       | IntInf_neg
-       | IntInf_orb
-       | IntInf_quot
-       | IntInf_rem
-       | IntInf_sub
-       | IntInf_toString
-       | IntInf_toVector
-       | IntInf_toWord
-       | IntInf_xorb
-       | MLton_bogus
-       | MLton_bug
-       | MLton_deserialize
-       | MLton_eq
-       | MLton_equal
-       | MLton_halt
-       | MLton_handlesSignals
-       | MLton_installSignalHandler
-       | MLton_serialize
-       | MLton_size
-       | MLton_touch
-       | Real_Math_acos
-       | Real_Math_asin
-       | Real_Math_atan
-       | Real_Math_atan2
-       | Real_Math_cos
-       | Real_Math_cosh
-       | Real_Math_exp
-       | Real_Math_ln
-       | Real_Math_log10 
-       | Real_Math_pow
-       | Real_Math_sin
-       | Real_Math_sinh
-       | Real_Math_sqrt
-       | Real_Math_tan
-       | Real_Math_tanh
-       | Real_abs
-       | Real_add
-       | Real_copysign
-       | Real_div
-       | Real_equal
-       | Real_frexp
-       | Real_fromInt
-       | Real_ge
-       | Real_gt
-       | Real_ldexp
-       | Real_le
-       | Real_lt
-       | Real_modf
-       | Real_mul
-       | Real_muladd
-       | Real_mulsub
-       | Real_neg
-       | Real_qequal
-       | Real_round
-       | Real_sub
-       | Real_toInt
-       | Ref_assign
-       | Ref_deref
-       | Ref_ref
-       | String_fromWord8Vector
-       | String_toWord8Vector
-       | Thread_atomicBegin
-       | Thread_atomicEnd
-       | Thread_canHandle
-       | Thread_copy
-       | Thread_copyCurrent
-       | Thread_returnToC
-       | Thread_switchTo
-       | Vector_fromArray
-       | Vector_length
-       | Vector_sub
-       | Weak_canGet
-       | Weak_get
-       | Weak_new
-       | Word32_add
-       | Word32_addCheck
-       | Word32_andb
-       | Word32_arshift
-       | Word32_div
-       | Word32_fromInt
-       | Word32_ge
-       | Word32_gt
-       | Word32_le
-       | Word32_lshift
-       | Word32_lt
-       | Word32_mod
-       | Word32_mul
-       | Word32_mulCheck
-       | Word32_neg
-       | Word32_notb
-       | Word32_orb
-       | Word32_rol
-       | Word32_ror
-       | Word32_rshift
-       | Word32_sub
-       | Word32_toIntX
-       | Word32_xorb
-       | Word8Array_subWord
-       | Word8Array_updateWord
-       | Word8Vector_subWord
-       | Word8_add
-       | Word8_andb
-       | Word8_arshift
-       | Word8_div
-       | Word8_fromInt
-       | Word8_fromLargeWord
-       | Word8_ge
-       | Word8_gt
-       | Word8_le
-       | Word8_lshift
-       | Word8_lt
-       | Word8_mod
-       | Word8_mul
-       | Word8_neg
-       | Word8_notb
-       | Word8_orb
-       | Word8_rol
-       | Word8_ror
-       | Word8_rshift
-       | Word8_sub
-       | Word8_toInt
-       | Word8_toIntX
-       | Word8_toLargeWord
-       | Word8_toLargeWordX
-       | Word8_xorb
-       | World_save
+	 Array_array (* backend *)
+       | Array_array0Const (* constant propagation *)
+       | Array_length (* ssa to rssa *)
+       | Array_sub (* backend *)
+       | Array_toVector (* backend *)
+       | Array_update (* backend *)
+       | BuildConstant of string (* type inference *)
+       | Byte_byteToChar (* ssa to rssa *)
+       | Byte_charToByte (* ssa to rssa *)
+       | C_CS_charArrayToWord8Array (* ssa to rssa *)
+       | Char_lt (* codegen *)
+       | Char_le (* codegen *)
+       | Char_gt (* codegen *)
+       | Char_ge (* codegen *)
+       | Char_chr (* codegen *)
+       | Char_ord (* codegen *)
+       | Constant of string (* type inference *)
+       | Cpointer_isNull (* codegen *)
+       | Exn_extra (* implement exceptions *)
+       | Exn_keepHistory (* a compile-time boolean *)
+       | Exn_name (* implement exceptions *)
+       | Exn_setExtendExtra (* implement exceptions *)
+       | Exn_setInitExtra (* implement exceptions *)
+       | Exn_setTopLevelHandler (* implement exceptions *)
+       | FFI of string (* ssa to rssa *)
+       | GC_collect (* ssa to rssa *)
+       | GC_pack (* ssa to rssa *)
+       | GC_unpack (* ssa to rssa *)
+       | Int_add of IntSize.t (* codegen *)
+       | Int_addCheck of IntSize.t (* codegen *)
+       | Int_ge of IntSize.t (* codegen *)
+       | Int_gt of IntSize.t (* codegen *)
+       | Int_le of IntSize.t (* codegen *)
+       | Int_lt of IntSize.t (* codegen *)
+       | Int_mul of IntSize.t (* codegen *)
+       | Int_mulCheck of IntSize.t (* codegen *)
+       | Int_neg of IntSize.t (* codegen *)
+       | Int_negCheck of IntSize.t (* codegen *)
+       | Int_quot of IntSize.t (* codegen *)
+       | Int_rem of IntSize.t (* codegen *)
+       | Int_sub of IntSize.t (* codegen *)
+       | Int_subCheck of IntSize.t (* codegen *)
+       | Int_toReal of IntSize.t * RealSize.t (* codegen *)
+       | Int_toWord of IntSize.t * WordSize.t (* codegen *)
+       | IntInf_add (* ssa to rssa *)
+       | IntInf_andb (* ssa to rssa *)
+       | IntInf_arshift (* ssa to rssa *)
+       | IntInf_compare (* ssa to rssa *)
+       | IntInf_equal (* ssa to rssa *)
+       | IntInf_gcd (* ssa to rssa *)
+       | IntInf_lshift (* ssa to rssa *)
+       | IntInf_mul (* ssa to rssa *)
+       | IntInf_neg (* ssa to rssa *)
+       | IntInf_notb (* ssa to rssa *)
+       | IntInf_orb (* ssa to rssa *)
+       | IntInf_quot (* ssa to rssa *)
+       | IntInf_rem (* ssa to rssa *)
+       | IntInf_sub (* ssa to rssa *)
+       | IntInf_toString (* ssa to rssa *)
+       | IntInf_toVector (* ssa to rssa *)
+       | IntInf_toWord (* ssa to rssa *)
+       | IntInf_xorb (* ssa to rssa *)
+       | MLton_bogus (* ssa to rssa *)
+       (* of type unit -> 'a.
+	* Makes a bogus value of any type.
+	*)
+       | MLton_bug (* ssa to rssa *)
+       | MLton_deserialize (* unused *)
+       | MLton_eq (* codegen *)
+       | MLton_equal (* polymorphic equality *)
+       | MLton_halt (* ssa to rssa *)
+       (* MLton_handlesSignals and MLton_installSignalHandler work together
+	* to inform the optimizer and basis library whether or not the
+	* program uses signal handlers.
+	*
+	* MLton_installSignalHandler is called by MLton.Signal.setHandler,
+	* and is effectively a noop, but is left in the program until the
+	* end of the backend, so that the optimizer can test whether or
+	* not the program installs signal handlers.
+	*
+	* MLton_handlesSignals is translated by closure conversion into
+	* a boolean, and is true iff MLton_installsSignalHandler is called.
+	*)
+       | MLton_handlesSignals (* closure conversion *)
+       | MLton_installSignalHandler (* backend *)
+       | MLton_serialize (* unused *)
+       | MLton_size (* ssa to rssa *)
+       | MLton_touch (* backend *)
+       | Real_Math_acos of RealSize.t (* codegen *)
+       | Real_Math_asin of RealSize.t (* codegen *)
+       | Real_Math_atan of RealSize.t (* codegen *)
+       | Real_Math_atan2 of RealSize.t (* codegen *)
+       | Real_Math_cos of RealSize.t (* codegen *)
+       | Real_Math_exp of RealSize.t (* codegen *)
+       | Real_Math_ln of RealSize.t (* codegen *)
+       | Real_Math_log10 of RealSize.t  (* codegen *)
+       | Real_Math_sin of RealSize.t (* codegen *)
+       | Real_Math_sqrt of RealSize.t (* codegen *)
+       | Real_Math_tan of RealSize.t (* codegen *)
+       | Real_abs of RealSize.t (* codegen *)
+       | Real_add of RealSize.t (* codegen *)
+       | Real_div of RealSize.t (* codegen *)
+       | Real_equal of RealSize.t (* codegen *)
+       | Real_ge of RealSize.t (* codegen *)
+       | Real_gt of RealSize.t (* codegen *)
+       | Real_ldexp of RealSize.t (* codegen *)
+       | Real_le of RealSize.t (* codegen *)
+       | Real_lt of RealSize.t (* codegen *)
+       | Real_mul of RealSize.t (* codegen *)
+       | Real_muladd of RealSize.t (* codegen *)
+       | Real_mulsub of RealSize.t (* codegen *)
+       | Real_neg of RealSize.t	  (* codegen *)
+       | Real_qequal of RealSize.t (* codegen *)
+       | Real_round of RealSize.t (* codegen *)
+       | Real_sub of RealSize.t (* codegen *)
+       | Real_toInt of RealSize.t (* codegen *)
+       | Ref_assign (* backend *)
+       | Ref_deref (* backend *)
+       | Ref_ref (* backend *)
+       | String_toWord8Vector (* ssa to rssa *)
+       | Thread_atomicBegin (* backend *)
+       | Thread_atomicEnd (* backend *)
+       | Thread_canHandle (* backend *)
+       | Thread_copy (* ssa to rssa *)
+       | Thread_copyCurrent (* ssa to rssa *)
+       | Thread_returnToC (* codegen *)
+       (* switchTo has to be a _prim because we have to know that it
+	* enters the runtime -- because everything must be saved
+	* on the stack.
+	*)
+       | Thread_switchTo (* ssa to rssa *)
+       | Vector_length (* ssa to rssa *)
+       | Vector_sub (* backend *)
+       | Weak_canGet (* ssa to rssa *)
+       | Weak_get (* ssa to rssa *)
+       | Weak_new (* ssa to rssa *)
+       | Word_add of WordSize.t (* codegen *)
+       | Word_addCheck of WordSize.t (* codegen *)
+       | Word_andb of WordSize.t (* codegen *)
+       | Word_arshift of WordSize.t (* codegen *)
+       | Word_div of WordSize.t (* codegen *)
+       | Word_ge of WordSize.t (* codegen *)
+       | Word_gt of WordSize.t (* codegen *)
+       | Word_le of WordSize.t (* codegen *)
+       | Word_lshift of WordSize.t (* codegen *)
+       | Word_lt of WordSize.t (* codegen *)
+       | Word_mod of WordSize.t (* codegen *)
+       | Word_mul of WordSize.t (* codegen *)
+       | Word_mulCheck of WordSize.t (* codegen *)
+       | Word_neg of WordSize.t (* codegen *)
+       | Word_notb of WordSize.t (* codegen *)
+       | Word_orb of WordSize.t (* codegen *)
+       | Word_rol of WordSize.t (* codegen *)
+       | Word_ror of WordSize.t (* codegen *)
+       | Word_rshift of WordSize.t (* codegen *)
+       | Word_sub of WordSize.t (* codegen *)
+       | Word_toInt of WordSize.t * IntSize.t (* codegen *)
+       | Word_toIntInf (* ssa to rssa *)
+       | Word_toIntX of WordSize.t * IntSize.t (* codegen *)
+       | Word_toWord of WordSize.t * WordSize.t (* codegen *)
+       | Word_toWordX of WordSize.t * WordSize.t (* codegen *)
+       | Word_xorb of WordSize.t (* codegen *)
+       | WordVector_toIntInf (* ssa to rssa *)
+       | Word8Array_subWord (* codegen *)
+       | Word8Array_updateWord (* codegen *)
+       | Word8Vector_subWord (* codegen *)
+       | Word8Vector_toString (* ssa to rssa *)
+       | World_save (* ssa to rssa *)
 
       val equals: t * t -> bool = op =
 
       val isCommutative =
-	 fn Int_add => true
-	  | Int_addCheck => true
-	  | Int_mul => true
-	  | Int_mulCheck => true
+	 fn Int_add _ => true
+	  | Int_addCheck _ => true
+	  | Int_mul _ => true
+	  | Int_mulCheck _ => true
 	  | IntInf_equal => true
 	  | MLton_eq => true
 	  | MLton_equal => true
-	  | Real_add => true
-	  | Real_mul => true
-	  | Real_qequal => true
-	  | Word32_add => true
-	  | Word32_addCheck => true
-	  | Word32_andb => true
-	  | Word32_mul => true
-	  | Word32_mulCheck => true
-	  | Word32_orb => true
-	  | Word32_xorb => true
-	  | Word8_add => true
-	  | Word8_andb => true
-	  | Word8_mul => true
-	  | Word8_orb => true
-	  | Word8_xorb => true
+	  | Real_add _ => true
+	  | Real_mul _ => true
+	  | Real_qequal _ => true
+	  | Word_add _ => true
+	  | Word_addCheck _ => true
+	  | Word_andb _ => true
+	  | Word_mul _ => true
+	  | Word_mulCheck _ => true
+	  | Word_orb _ => true
+	  | Word_xorb _ => true
 	  | _ => false
 
       val mayOverflow =
-	 fn Int_addCheck => true
-	  | Int_mulCheck => true
-	  | Int_negCheck => true
-	  | Int_subCheck => true
-	  | Word32_addCheck => true
-	  | Word32_mulCheck => true
+	 fn Int_addCheck _ => true
+	  | Int_mulCheck _ => true
+	  | Int_negCheck _ => true
+	  | Int_subCheck _ => true
+	  | Word_addCheck _ => true
+	  | Word_mulCheck _ => true
 	  | _ => false
 
       val mayRaise = mayOverflow
 
       datatype z = datatype Kind.t
-	       
       (* The values of these strings are important since they are referred to
        * in the basis library code.  See basis-library/misc/primitive.sml.
        *)
+      fun ints (s: IntSize.t) =
+	 List.map
+	 ([(Int_add, Functional, "add"),
+	   (Int_addCheck, SideEffect, "addCheck"),
+	   (Int_ge, Functional, "ge"),
+	   (Int_gt, Functional, "gt"),
+	   (Int_le, Functional, "le"),
+	   (Int_lt, Functional, "lt"),
+	   (Int_mul, Functional, "mul"),
+	   (Int_mulCheck, SideEffect, "mulCheck"),
+	   (Int_neg, Functional, "neg"),
+	   (Int_negCheck, SideEffect, "negCheck"),
+	   (Int_quot, Functional, "quot"),
+	   (Int_rem, Functional, "rem"),
+	   (Int_sub, Functional, "sub"),
+	   (Int_subCheck, SideEffect, "subCheck")],
+	  fn (makeName, kind, str) =>
+	  (makeName s, kind, concat ["Int", IntSize.toString s, "_", str]))
+
+      fun reals (s: RealSize.t) =
+	 List.map
+	 ([(Real_Math_acos, Functional, "Math_acos"),
+	   (Real_Math_asin, Functional, "Math_asin"),
+	   (Real_Math_atan, Functional, "Math_atan"),
+	   (Real_Math_atan2, Functional, "Math_atan2"),
+	   (Real_Math_cos, Functional, "Math_cos"),
+	   (Real_Math_exp, Functional, "Math_exp"),
+	   (Real_Math_ln, Functional, "Math_ln"),
+	   (Real_Math_log10, Functional, "Math_log10"),
+	   (Real_Math_sin, Functional, "Math_sin"),
+	   (Real_Math_sqrt, Functional, "Math_sqrt"),
+	   (Real_Math_tan, Functional, "Math_tan"),
+	   (Real_abs, Functional, "abs"),
+	   (Real_add, Functional, "add"),
+	   (Real_div, Functional, "div"),
+	   (Real_equal, Functional, "equal"),
+	   (Real_ge, Functional, "ge"),
+	   (Real_gt, Functional, "gt"),
+	   (Real_ldexp, Functional, "ldexp"),
+	   (Real_le, Functional, "le"),
+	   (Real_lt, Functional, "lt"),
+	   (Real_mul, Functional, "mul"),
+	   (Real_muladd, Functional, "muladd"),
+	   (Real_mulsub, Functional, "mulsub"),
+	   (Real_neg, Functional, "neg"),
+	   (Real_qequal, Functional, "qequal"),
+	   (Real_round, Functional, "round"),
+	   (Real_sub, Functional, "sub"),
+	   (Real_toInt, Functional, "toInt")],
+	 fn (makeName, kind, str) =>
+	 (makeName s, kind, concat ["Real", RealSize.toString s, "_", str]))
+
+      fun words (s: WordSize.t) =
+	 List.map
+	 ([(Word_add, Functional, "add"),
+	   (Word_addCheck, SideEffect, "addCheck"),
+	   (Word_andb, Functional, "andb"),
+	   (Word_arshift, Functional, "arshift"),
+	   (Word_div, Functional, "div"),
+	   (Word_ge, Functional, "ge"),
+	   (Word_gt, Functional, "gt"),
+	   (Word_le, Functional, "le"),
+	   (Word_lshift, Functional, "lshift"),
+	   (Word_lt, Functional, "lt"),
+	   (Word_mod, Functional, "mod"),
+	   (Word_mul, Functional, "mul"),
+	   (Word_mulCheck, SideEffect, "mulCheck"),
+	   (Word_neg, Functional, "neg"),
+	   (Word_notb, Functional, "notb"),
+	   (Word_orb, Functional, "orb"),
+	   (Word_rol, Functional, "rol"),
+	   (Word_ror, Functional, "ror"),
+	   (Word_rshift, Functional, "rshift"),
+	   (Word_sub, Functional, "sub"),
+	   (Word_xorb, Functional, "xorb")],
+	  fn (makeName, kind, str) =>
+	  (makeName s, kind, concat ["Word", WordSize.toString s, "_", str]))
+
       val strings =
 	 [
 	  (Array_array, Moveable, "Array_array"),
 	  (Array_array0Const, Moveable, "Array_array0Const"),
 	  (Array_length, Functional, "Array_length"),
 	  (Array_sub, DependsOnState, "Array_sub"),
+	  (Array_toVector, DependsOnState, "Array_toVector"),
 	  (Array_update, SideEffect, "Array_update"),
 	  (Byte_byteToChar, Functional, "Byte_byteToChar"),
 	  (Byte_charToByte, Functional, "Byte_charToByte"),
@@ -289,8 +361,6 @@
 	  (IntInf_arshift, Functional, "IntInf_arshift"),
 	  (IntInf_compare, Functional, "IntInf_compare"),
 	  (IntInf_equal, Functional, "IntInf_equal"),
-	  (IntInf_fromVector, Functional, "IntInf_fromVector"),
-	  (IntInf_fromWord, Functional, "IntInf_fromWord"),
 	  (IntInf_gcd, Functional, "IntInf_gcd"),
 	  (IntInf_lshift, Functional, "IntInf_lshift"),
 	  (IntInf_mul, Functional, "IntInf_mul"),
@@ -304,22 +374,6 @@
 	  (IntInf_toVector, Functional, "IntInf_toVector"),
 	  (IntInf_toWord, Functional, "IntInf_toWord"),
 	  (IntInf_xorb, Functional, "IntInf_xorb"),
-	  (Int_add, Functional, "Int_add"),
-	  (Int_addCheck, SideEffect, "Int_addCheck"),
-	  (Int_ge, Functional, "Int_ge"),
-	  (Int_geu, Functional, "Int_geu"),
-	  (Int_gt, Functional, "Int_gt"),
-	  (Int_gtu, Functional, "Int_gtu"),
-	  (Int_le, Functional, "Int_le"),
-	  (Int_lt, Functional, "Int_lt"),
-	  (Int_mul, Functional, "Int_mul"),
-	  (Int_mulCheck, SideEffect, "Int_mulCheck"),
-	  (Int_neg, Functional, "Int_neg"),
-	  (Int_negCheck, SideEffect, "Int_negCheck"),
-	  (Int_quot, Functional, "Int_quot"),
-	  (Int_rem, Functional, "Int_rem"),
-	  (Int_sub, Functional, "Int_sub"),
-	  (Int_subCheck, SideEffect, "Int_subCheck"),
 	  (MLton_bogus, Functional, "MLton_bogus"),
 	  (MLton_bug, SideEffect, "MLton_bug"),
 	  (MLton_deserialize, Moveable, "MLton_deserialize"),
@@ -332,46 +386,9 @@
 	  (MLton_serialize, DependsOnState, "MLton_serialize"),
 	  (MLton_size, DependsOnState, "MLton_size"),
 	  (MLton_touch, SideEffect, "MLton_touch"),
-	  (Real_Math_acos, Functional, "Real_Math_acos"),
-	  (Real_Math_asin, Functional, "Real_Math_asin"),
-	  (Real_Math_atan, Functional, "Real_Math_atan"),
-	  (Real_Math_atan2, Functional, "Real_Math_atan2"),
-	  (Real_Math_cos, Functional, "Real_Math_cos"),
-	  (Real_Math_cosh, Functional, "Real_Math_cosh"),
-	  (Real_Math_exp, Functional, "Real_Math_exp"),
-	  (Real_Math_ln, Functional, "Real_Math_ln"),
-	  (Real_Math_log10, Functional, "Real_Math_log10"),
-	  (Real_Math_pow, Functional, "Real_Math_pow"),
-	  (Real_Math_sin, Functional, "Real_Math_sin"),
-	  (Real_Math_sinh, Functional, "Real_Math_sinh"),
-	  (Real_Math_sqrt, Functional, "Real_Math_sqrt"),
-	  (Real_Math_tan, Functional, "Real_Math_tan"),
-	  (Real_Math_tanh, Functional, "Real_Math_tanh"),
-	  (Real_abs, Functional, "Real_abs"),
-	  (Real_add, Functional, "Real_add"),
-	  (Real_copysign, Functional, "Real_copysign"),
-	  (Real_div, Functional, "Real_div"),
-	  (Real_equal, Functional, "Real_equal"),
-	  (Real_frexp, SideEffect, "Real_frexp"),
-	  (Real_fromInt, Functional, "Real_fromInt"),
-	  (Real_ge, Functional, "Real_ge"),
-	  (Real_gt, Functional, "Real_gt"),
-	  (Real_ldexp, Functional, "Real_ldexp"),
-	  (Real_le, Functional, "Real_le"),
-	  (Real_lt, Functional, "Real_lt"),
-	  (Real_modf, SideEffect, "Real_modf"),
-	  (Real_mul, Functional, "Real_mul"),
-	  (Real_muladd, Functional, "Real_muladd"),
-	  (Real_mulsub, Functional, "Real_mulsub"),
-	  (Real_neg, Functional, "Real_neg"),
-	  (Real_qequal, Functional, "Real_qequal"),
-	  (Real_round, Functional, "Real_round"),
-	  (Real_sub, Functional, "Real_sub"),
-	  (Real_toInt, Functional, "Real_toInt"),
 	  (Ref_assign, SideEffect, "Ref_assign"),
 	  (Ref_deref, DependsOnState, "Ref_deref"),
 	  (Ref_ref, Moveable, "Ref_ref"),
-	  (String_fromWord8Vector, Functional, "String_fromWord8Vector"),
 	  (String_toWord8Vector, Functional, "String_toWord8Vector"),
 	  (Thread_atomicBegin, SideEffect, "Thread_atomicBegin"),
 	  (Thread_atomicEnd, SideEffect, "Thread_atomicEnd"),
@@ -380,65 +397,50 @@
 	  (Thread_copyCurrent, SideEffect, "Thread_copyCurrent"),
 	  (Thread_returnToC, SideEffect, "Thread_returnToC"),
 	  (Thread_switchTo, SideEffect, "Thread_switchTo"),
-	  (Vector_fromArray, DependsOnState, "Vector_fromArray"),
 	  (Vector_length, Functional, "Vector_length"),
 	  (Vector_sub, Functional, "Vector_sub"),
 	  (Weak_canGet, DependsOnState, "Weak_canGet"),
 	  (Weak_get, DependsOnState, "Weak_get"),
 	  (Weak_new, Moveable, "Weak_new"),
-	  (Word32_add, Functional, "Word32_add"),
-	  (Word32_addCheck, SideEffect, "Word32_addCheck"),
-	  (Word32_andb, Functional, "Word32_andb"),
-	  (Word32_arshift, Functional, "Word32_arshift"),
-	  (Word32_div, Functional, "Word32_div"),
-	  (Word32_fromInt, Functional, "Word32_fromInt"),
-	  (Word32_ge, Functional, "Word32_ge"),
-	  (Word32_gt, Functional, "Word32_gt"),
-	  (Word32_le, Functional, "Word32_le"),
-	  (Word32_lshift, Functional, "Word32_lshift"),
-	  (Word32_lt, Functional, "Word32_lt"),
-	  (Word32_mod, Functional, "Word32_mod"),
-	  (Word32_mul, Functional, "Word32_mul"),
-	  (Word32_mulCheck, SideEffect, "Word32_mulCheck"),
-	  (Word32_neg, Functional, "Word32_neg"),
-	  (Word32_notb, Functional, "Word32_notb"),
-	  (Word32_orb, Functional, "Word32_orb"),
-	  (Word32_rol, Functional, "Word32_rol"),
-	  (Word32_ror, Functional, "Word32_ror"),
-	  (Word32_rshift, Functional, "Word32_rshift"),
-	  (Word32_sub, Functional, "Word32_sub"),
-	  (Word32_toIntX, Functional, "Word32_toIntX"),
-	  (Word32_xorb, Functional, "Word32_xorb"),
+	  (Word_toIntInf, Functional, "Word_toIntInf"),
+	  (WordVector_toIntInf, Functional, "WordVector_toIntInf"),
 	  (Word8Array_subWord, DependsOnState, "Word8Array_subWord"),
 	  (Word8Array_updateWord, SideEffect, "Word8Array_updateWord"),
 	  (Word8Vector_subWord, Functional, "Word8Vector_subWord"),
-	  (Word8_add, Functional, "Word8_add"),
-	  (Word8_andb, Functional, "Word8_andb"),
-	  (Word8_arshift, Functional, "Word8_arshift"),
-	  (Word8_div, Functional, "Word8_div"),
-	  (Word8_fromInt, Functional, "Word8_fromInt"),
-	  (Word8_fromLargeWord, Functional, "Word8_fromLargeWord"),
-	  (Word8_ge, Functional, "Word8_ge"),
-	  (Word8_gt, Functional, "Word8_gt"),
-	  (Word8_le, Functional, "Word8_le"),
-	  (Word8_lshift, Functional, "Word8_lshift"),
-	  (Word8_lt, Functional, "Word8_lt"),
-	  (Word8_mod, Functional, "Word8_mod"),
-	  (Word8_mul, Functional, "Word8_mul"),
-	  (Word8_neg, Functional, "Word8_neg"),
-	  (Word8_notb, Functional, "Word8_notb"),
-	  (Word8_orb, Functional, "Word8_orb"),
-	  (Word8_rol, Functional, "Word8_rol"),
-	  (Word8_ror, Functional, "Word8_ror"),
-	  (Word8_rshift, Functional, "Word8_rshift"),
-	  (Word8_sub, Functional, "Word8_sub"),
-	  (Word8_toInt, Functional, "Word8_toInt"),
-	  (Word8_toIntX, Functional, "Word8_toIntX"),
-	  (Word8_toLargeWord, Functional, "Word8_toLargeWord"),
-	  (Word8_toLargeWordX, Functional, "Word8_toLargeWordX"),
-	  (Word8_xorb, Functional, "Word8_xorb"),
+	  (Word8Vector_toString, Functional, "Word8Vector_toString"),
 	  (World_save, SideEffect, "World_save")]
-
+	 @ List.concat [List.concatMap (IntSize.all, ints),
+			List.concatMap (RealSize.all, reals),
+			List.concatMap (WordSize.all, words)]
+	 @ let
+	      val int = ("Int", IntSize.all, IntSize.toString)
+	      val real = ("Real", RealSize.all, RealSize.toString)
+	      val word = ("Word", WordSize.all, WordSize.toString)
+	      local
+		 fun coerces' suf (name,
+				   (n, sizes, sizeToString),
+				   (n', sizes', sizeToString')) =
+		    List.fold
+		    (sizes, [], fn (s, ac) =>
+		     List.fold
+		     (sizes', ac, fn (s', ac) =>
+		      (name (s, s'), Functional,
+		       concat [n, sizeToString s, "_to", n', sizeToString' s',
+			       suf])
+		      :: ac))
+	      in
+		 val coerces = fn z => coerces' "" z
+		 val coercesX = fn z => coerces' "X" z
+	      end
+	   in
+	      List.concat [coerces (Int_toReal, int, real),
+			   coerces (Int_toWord, int, word),
+			   coerces (Word_toInt, word, int),
+			   coercesX (Word_toIntX, word, int),
+			   coerces (Word_toWord, word, word),
+			   coercesX (Word_toWordX, word, word)]
+	   end
+	 
       fun toString n =
 	 case n of
 	    BuildConstant s => s
@@ -532,42 +534,46 @@
 	     | _ => (case List.peek (Name.strings, fn (n', _, _) => n = n') of
 			NONE => Error.bug "strange name"
 		      | SOME (_, k, _) => k)
-      in new (n, k, s)
+      in
+	 new (n, k, s)
       end
-   val tuple = tuple o Vector.fromList    
+   val tuple = tuple o Vector.fromList
 in
-   val array = new (Name.Array_array, make1 (fn a => int --> array a))
-   val assign = new (Name.Ref_assign, make1 (fn a => tuple [reff a, a] --> unit))
+   val array = new (Name.Array_array, make1 (fn a => int I32 --> array a))
+   val assign =
+      new (Name.Ref_assign, make1 (fn a => tuple [reff a, a] --> unit))
    val bogus = new (Name.MLton_bogus, make1 (fn a => a))
-   val bug = new (Name.MLton_bug, make0 (string --> unit))
+   val bug = new (Name.MLton_bug, make0 (word8Vector --> unit))
    val deref = new (Name.Ref_deref, make1 (fn a => reff a --> a))
    val deserialize =
-      new (Name.MLton_deserialize, make1 (fn a => vector word8 --> a))
+      new (Name.MLton_deserialize, make1 (fn a => vector (word W8) --> a))
    val eq = new (Name.MLton_eq, makeEqual1 (fn a => tuple [a, a] --> bool))
    val equal = new (Name.MLton_equal, makeEqual1 (fn a => tuple [a, a] --> bool))
-   val gcCollect = new (Name.GC_collect, make0 (tuple [word, bool] --> unit))
+   val gcCollect = new (Name.GC_collect, make0 (tuple [word W32, bool] --> unit))
    val reff = new (Name.Ref_ref, make1 (fn a => a --> reff a))
-   val serialize = new (Name.MLton_serialize, make1 (fn a => a --> vector word8))
-   val vectorLength = new (Name.Vector_length, make1 (fn a => vector a --> int))
+   val serialize = new (Name.MLton_serialize,
+			make1 (fn a => a --> vector (word W8)))
+   val vectorLength =
+      new (Name.Vector_length, make1 (fn a => vector a --> int I32))
    val vectorSub =
-      new (Name.Vector_sub, make1 (fn a => tuple [vector a, int] --> a))
+      new (Name.Vector_sub, make1 (fn a => tuple [vector a, int I32] --> a))
 
    fun new0 (name, ty) = new (name, make0 ty)
 
-   val intNeg = new0 (Name.Int_neg, int --> int)
-   val intNegCheck = new0 (Name.Int_negCheck, int --> int)
+   fun intNeg s = new0 (Name.Int_neg s, int s --> int s)
+   fun intNegCheck s = new0 (Name.Int_negCheck s, int s --> int s)
    val intInfNeg =
-      new0 (Name.IntInf_neg, tuple [intInf, word] --> intInf)
+      new0 (Name.IntInf_neg, tuple [intInf, word W32] --> intInf)
    val intInfNotb =
-      new0 (Name.IntInf_notb, tuple [intInf, word] --> intInf)
+      new0 (Name.IntInf_notb, tuple [intInf, word W32] --> intInf)
    val intInfEqual = new0 (Name.IntInf_equal, tuple [intInf, intInf] --> bool)
-   val word8Neg = new0 (Name.Word8_neg, word8 --> word8)
-   val word8Notb = new0 (Name.Word8_notb, word8 --> word8)
-   val word32Notb = new0 (Name.Word32_notb, word --> word)
-   val word32Neg = new0 (Name.Word32_neg, word --> word)
+
+   fun wordNotb (s: WordSize.t) = new0 (Name.Word_notb s, word s --> word s)
+   fun wordNeg (s: WordSize.t) = new0 (Name.Word_neg s, word s --> word s)
 
    local
-      fun make n = new0 (n, tuple [int, int] --> int)
+      fun make n =
+	 IntSize.memoize (fn s => new0 (n s, tuple [int s, int s] --> int s))
    in
       val intAdd = make Name.Int_add
       val intAddCheck = make Name.Int_addCheck
@@ -578,25 +584,46 @@
    end
 
    local
-      fun make n = new0 (n, tuple [word, word] --> word)
+      fun make n =
+	 WordSize.memoize
+	 (fn s => new0 (n s, tuple [word s, word s] --> word s))
    in
-      val word32Add = make Name.Word32_add
-      val word32AddCheck = make Name.Word32_addCheck
-      val word32Andb = make Name.Word32_andb
-      val word32Mul = make Name.Word32_mul
-      val word32MulCheck = make Name.Word32_mulCheck
-      val word32Rshift = make Name.Word32_rshift
-      val word32Sub = make Name.Word32_sub
+      val wordAdd = make Name.Word_add
+      val wordAddCheck = make Name.Word_addCheck
+      val wordAndb = make Name.Word_andb
+      val wordMul = make Name.Word_mul
+      val wordMulCheck = make Name.Word_mulCheck
+      val wordRshift = make Name.Word_rshift
+      val wordSub = make Name.Word_sub
    end
 
    local
-      fun make n = new0 (n, tuple [word, word] --> bool)
+      fun make n =
+	 WordSize.memoize
+	 (fn s => new0 (n s, tuple [word s, word s] --> bool))
    in
-      val word32Gt = make Name.Word32_gt
+      val wordGe = make Name.Word_ge
+      val wordGt = make Name.Word_gt
+      val wordLe = make Name.Word_le
+      val wordLt = make Name.Word_lt
    end
 
-   val word32FromInt = new0 (Name.Word32_fromInt, int --> word)
-   val word32ToIntX = new0 (Name.Word32_toIntX, word --> int)
+   local
+      fun make (name, (ty, memo), (ty', memo')) =
+	 let
+	    val f =
+	       memo (fn s => memo' (fn s' => new0 (name (s, s'),
+						   ty s --> ty' s')))
+      in
+	 fn (s, s') => f s s'
+      end
+      val int = (int, IntSize.memoize)
+      val word = (word, WordSize.memoize)
+   in
+      val intToWord = make (Name.Int_toWord, int, word)
+      val wordToInt = make (Name.Word_toInt, word, int)
+      val wordToIntX = make (Name.Word_toIntX, word, int)
+   end
       
    fun ffi (name: string, s: Scheme.t) =
       new (Name.FFI name, s)
@@ -639,6 +666,14 @@
 	     ; error)
       else
 	 let
+	    val con = fn (c, ts) =>
+	       let
+		  val c = if Tycon.equals (c, Tycon.char)
+			     then Tycon.word W8
+			  else c
+	       in
+		  con (c, ts)
+	       end
 	    val env = Vector.zip (tyvars, targs)
 	    fun var a =
 	       case Vector.peek (env, fn (a', _) => Tyvar.equals (a, a')) of
@@ -691,6 +726,7 @@
 	 Array_array => one (dearray result)
        | Array_array0Const => one (dearray result)
        | Array_sub => one result
+       | Array_toVector => one (dearray (arg 0))
        | Array_update => one (arg 2)
        | Array_length => one (dearray (arg 0))
        | Exn_extra => one result
@@ -706,7 +742,6 @@
        | Ref_assign => one (arg 1)
        | Ref_deref => one result
        | Ref_ref => one (arg 0)
-       | Vector_fromArray => one (dearray (arg 0))
        | Vector_length => one (devector (arg 0))
        | Vector_sub => one result
        | Weak_canGet => one (deweak (arg 0))
@@ -721,14 +756,14 @@
    struct
       datatype 'a t =
 	 Con of {con: Con.t, hasArg: bool}
-       | Const of Const.Node.t
+       | Const of Const.t
        | Var of 'a
 
       fun layout layoutX =
 	 fn Con {con, hasArg} =>
 	      Layout.record [("con", Con.layout con),
 			     ("hasArg", Bool.layout hasArg)]
-	  | Const c => Const.Node.layout c
+	  | Const c => Const.layout c
 	  | Var x => layoutX x
    end
 
@@ -784,139 +819,114 @@
  * A = B --> false
  * A x = B y --> false
  *)
-
+   
 fun 'a apply (p, args, varEquals) =
    let
       datatype z = datatype Name.t
-      datatype z = datatype Const.Node.t
+      datatype z = datatype Const.t
       val bool = ApplyResult.Bool
-      val char = ApplyResult.Const o Const.fromChar
-      val int = ApplyResult.Const o Const.fromInt
-      val intInf = ApplyResult.Const o Const.fromIntInf
+      val int = ApplyResult.Const o Const.int
+      val intInf = ApplyResult.Const o Const.intInf
       val intInfConst = intInf o IntInf.fromInt
-      val string = ApplyResult.Const o Const.fromString
-      val word = ApplyResult.Const o Const.fromWord
-      val word32 = word
-      val word8 = ApplyResult.Const o Const.fromWord8
+      fun word (w: WordX.t): 'a ApplyResult.t =
+	 ApplyResult.Const (Const.word w)
+      val word8Vector = ApplyResult.Const o Const.word8Vector
       val t = ApplyResult.truee
       val f = ApplyResult.falsee
       local
 	 fun make from (f, c1, c2) = from (f (c1, c2))
       in
-	 fun io z = make int z
-	 val wo = make word
 	 fun pred z = make bool z
 	 val iio = make intInf
       end
-      fun iu (f, i1, i2) = bool (f (Word.fromInt i1, Word.fromInt i2))
-      fun w8w (f, w8: Word.t, w: Word.t) = word8 (f (Word8.fromWord w8, w))
-      fun w8p (p, w1, w2) = bool (p (Word8.fromWord w1, Word8.fromWord w2))
-      fun w8o (f, w1, w2) = word8 (f (Word8.fromWord w1, Word8.fromWord w2))
+      fun io (f: IntX.t * IntX.t -> IntX.t, i, i') =
+	 int (f (i, i'))
+      fun wcheck (f: IntInf.t * IntInf.t -> IntInf.t,
+		  w: WordX.t,
+		  w': WordX.t,
+		  s: WordSize.t) =
+	 let
+	    val x = f (WordX.toIntInf w, WordX.toIntInf w')
+	    val x' = IntInf.mod (x, Int.toIntInf (WordSize.size s))
+	 in
+	    if x = x'
+	       then word (WordX.fromLargeInt (x, s))
+	    else ApplyResult.Overflow
+	 end
       val eq =
- 	 fn (Char c1, Char c2) => bool (Char.equals (c1, c2))
- 	  | (Int i1, Int i2) => bool (Int.equals (i1, i2))
- 	  | (Word w1, Word w2) => bool (Word.equals (w1, w2))
+ 	 fn (Int i1, Int i2) => bool (IntX.equals (i1, i2))
+ 	  | (Word w1, Word w2) => bool (WordX.equals (w1, w2))
  	  | _ => ApplyResult.Unknown
       val equal =
-	 fn (Char c1, Char c2) => bool (Char.equals (c1, c2))
-	  | (Int i1, Int i2) => bool (Int.equals (i1, i2))
-	  | (IntInf i1, IntInf i2) => bool (IntInf.equals (i1, i2))
-	  | (String s1, String s2) => bool (String.equals (s1, s2))
-	  | (Word w1, Word w2) => bool (Word.equals (w1, w2))
+	 fn (Int i1, Int i2) => bool (IntX.equals (i1, i2))
+	  | (Word w1, Word w2) => bool (WordX.equals (w1, w2))
+	  | (Word8Vector v1, Word8Vector v2) => bool (v1 = v2)
 	  | _ => ApplyResult.Unknown
-      fun allConsts (cs: Const.Node.t list) =
+      fun allConsts (cs: Const.t list) =
 	 (case (name p, cs) of
-	     (Byte_byteToChar, [Word w]) => char (Word.toChar w)
-	   | (Byte_charToByte, [Char c]) => word8 (Word8.fromChar c)
-	   | (Char_lt, [Char c1, Char c2]) => pred (Char.<, c1, c2)
-	   | (Char_le, [Char c1, Char c2]) => pred (Char.<=, c1, c2)
-	   | (Char_gt, [Char c1, Char c2]) => pred (Char.>, c1, c2)
-	   | (Char_ge, [Char c1, Char c2]) => pred (Char.>=, c1, c2)
-	   | (Char_chr, [Int i]) => char (Char.fromInt i)
-	   | (Char_ord, [Char c]) => int (Char.toInt c)
-	   | (Int_add, [Int i1, Int i2]) => io (Int.+, i1, i2)
-	   | (Int_addCheck, [Int i1, Int i2]) => io (Int.+, i1, i2)
-	   | (Int_mul, [Int i1, Int i2]) => io (Int.*, i1, i2)
-	   | (Int_mulCheck, [Int i1, Int i2]) => io (Int.*, i1, i2)
-	   | (Int_sub, [Int i1, Int i2]) => io (Int.-, i1, i2)
-	   | (Int_subCheck, [Int i1, Int i2]) => io (Int.-, i1, i2)
-	   | (Int_lt, [Int i1, Int i2]) => pred (Int.<, i1, i2)
-	   | (Int_le, [Int i1, Int i2]) => pred (Int.<=, i1, i2)
-	   | (Int_gt, [Int i1, Int i2]) => pred (Int.>, i1, i2)
-	   | (Int_ge, [Int i1, Int i2]) => pred (Int.>=, i1, i2)
-	   | (Int_geu, [Int i1, Int i2]) => iu (Word.>=, i1, i2)
-	   | (Int_gtu, [Int i1, Int i2]) => iu (Word.>, i1, i2)
-	   | (Int_neg, [Int i]) => int (~ i)
-	   | (Int_negCheck, [Int i]) => int (~ i)
-	   | (Int_quot, [Int i1, Int i2]) => io (Int.quot, i1, i2)
-	   | (Int_rem, [Int i1, Int i2]) => io (Int.rem, i1, i2)
+	     (Int_add _, [Int i1, Int i2]) => io (IntX.+, i1, i2)
+	   | (Int_addCheck _, [Int i1, Int i2]) => io (IntX.+, i1, i2)
+	   | (Int_ge s, [Int i1, Int i2]) => pred (IntX.>=, i1, i2)
+	   | (Int_gt s, [Int i1, Int i2]) => pred (IntX.>, i1, i2)
+	   | (Int_le s, [Int i1, Int i2]) => pred (IntX.<=, i1, i2)
+	   | (Int_lt s, [Int i1, Int i2]) => pred (IntX.<, i1, i2)
+	   | (Int_mul _, [Int i1, Int i2]) => io (IntX.*, i1, i2)
+	   | (Int_mulCheck _, [Int i1, Int i2]) => io (IntX.*, i1, i2)
+	   | (Int_neg _, [Int i]) => int (IntX.~ i)
+	   | (Int_negCheck _, [Int i]) => int (IntX.~ i)
+	   | (Int_quot _, [Int i1, Int i2]) => io (IntX.quot, i1, i2)
+	   | (Int_rem _, [Int i1, Int i2]) => io (IntX.rem, i1, i2)
+	   | (Int_sub _, [Int i1, Int i2]) => io (IntX.-, i1, i2)
+	   | (Int_subCheck _, [Int i1, Int i2]) => io (IntX.-, i1, i2)
+	   | (Int_toWord (_, s), [Int i]) =>
+		word (WordX.fromLargeInt (IntX.toIntInf i, s))
 	   | (IntInf_compare, [IntInf i1, IntInf i2]) =>
-		int (case IntInf.compare (i1, i2) of
-			Relation.LESS => ~1
-		      | Relation.EQUAL => 0
-		      | Relation.GREATER => 1)
+		int (IntX.make
+		     (IntInf.fromInt (case IntInf.compare (i1, i2) of
+					 Relation.LESS => ~1
+				       | Relation.EQUAL => 0
+				       | Relation.GREATER => 1),
+		      IntSize.default))
 	   | (IntInf_equal, [IntInf i1, IntInf i2]) =>
 		bool (IntInf.equals (i1, i2))
-	   | (IntInf_fromWord, [Word w]) =>
-		(case SmallIntInf.fromWord w of
-		    NONE => ApplyResult.Unknown
-		  | SOME i => intInf i)
 	   | (IntInf_toWord, [IntInf i]) =>
 		(case SmallIntInf.toWord i of
 		    NONE => ApplyResult.Unknown
-		  | SOME w => word w)
+		  | SOME w => word (WordX.make (w, WordSize.default)))
 	   | (MLton_eq, [c1, c2]) => eq (c1, c2)
 	   | (MLton_equal, [c1, c2]) => equal (c1, c2)
-	   | (Word8_mul, [Word w1, Word w2]) => w8o (Word8.*, w1, w2)
-	   | (Word8_add, [Word w1, Word w2]) => w8o (Word8.+, w1, w2)
-	   | (Word8_sub, [Word w1, Word w2]) => w8o (Word8.-, w1, w2)
-	   | (Word8_lt, [Word w1, Word w2]) => w8p (Word8.<, w1, w2)
-	   | (Word8_lshift, [Word w1, Word w2]) => w8w (Word8.<<, w1, w2)
-	   | (Word8_le, [Word w1, Word w2]) => w8p (Word8.<=, w1, w2)
-	   | (Word8_gt, [Word w1, Word w2]) => w8p (Word8.>, w1, w2)
-	   | (Word8_ge, [Word w1, Word w2]) => w8p (Word8.>=, w1, w2)
-	   | (Word8_rol, [Word w1, Word w2]) => w8w (Word8.rol, w1, w2)
-	   | (Word8_ror, [Word w1, Word w2]) => w8w (Word8.ror, w1, w2)
-	   | (Word8_rshift, [Word w1, Word w2]) => w8w (Word8.>>, w1, w2)
-	   | (Word8_andb, [Word w1, Word w2]) => w8o (Word8.andb, w1, w2)
-	   | (Word8_div, [Word w1, Word w2]) => w8o (Word8.div, w1, w2)
-	   | (Word8_fromInt, [Int i]) => word8 (Word8.fromInt i)
-	   | (Word8_fromLargeWord, [Word w]) => word8 (Word8.fromWord w)
-	   | (Word8_mod, [Word w1, Word w2]) => w8o (Word8.mod, w1, w2)
-	   | (Word8_notb, [Word w]) => word8 (Word8.notb (Word8.fromWord w))
-	   | (Word8_orb, [Word w1, Word w2]) => w8o (Word8.orb, w1, w2)
-	   | (Word8_toInt, [Word w]) => int (Word8.toInt (Word8.fromWord w))
-	   | (Word8_toIntX, [Word w]) => int (Word8.toIntX (Word8.fromWord w))
-	   | (Word8_toLargeWord, [Word w]) =>
-		word (Word8.toWord (Word8.fromWord w))
-	   | (Word8_toLargeWordX, [Word w]) => 
-		word (Word8.toWordX (Word8.fromWord w))
-	   | (Word8_xorb, [Word w1, Word w2]) => w8o (Word8.xorb, w1, w2)
-	   | (Word8_arshift, [Word w1, Word w2]) => w8w (Word8.~>>, w1, w2)
-	   | (Word32_add, [Word w1, Word w2]) => wo (Word.+, w1, w2)
-	   | (Word32_addCheck, [Word w1, Word w2]) =>
-		wo (MLton.Word.addCheck, w1, w2)
-	   | (Word32_andb, [Word w1, Word w2]) => wo (Word.andb, w1, w2)
-	   | (Word32_arshift, [Word w1, Word w2]) => wo (Word.~>>, w1, w2)
-	   | (Word32_div, [Word w1, Word w2]) => wo (Word.div, w1, w2)
-	   | (Word32_fromInt, [Int i]) => word (Word.fromInt i)
-	   | (Word32_ge, [Word w1, Word w2]) => pred (Word.>=, w1, w2)
-	   | (Word32_gt, [Word w1, Word w2]) => pred (Word.>, w1, w2)
-	   | (Word32_le, [Word w1, Word w2]) => pred (Word.<=, w1, w2)
-	   | (Word32_lshift, [Word w1, Word w2]) => wo (Word.<<, w1, w2)
-	   | (Word32_lt, [Word w1, Word w2]) => pred (Word.<, w1, w2)
-	   | (Word32_mod, [Word w1, Word w2]) => wo (Word.mod, w1, w2)
-	   | (Word32_mul, [Word w1, Word w2]) => wo (Word.*, w1, w2)
-	   | (Word32_mulCheck, [Word w1, Word w2]) =>
-		wo (MLton.Word.mulCheck, w1, w2)
-	   | (Word32_notb, [Word w]) => word (Word.notb w)
-	   | (Word32_orb, [Word w1, Word w2]) => wo (Word.orb, w1, w2)
-	   | (Word32_rol, [Word w1, Word w2]) => wo (Word.rol, w1, w2)
-	   | (Word32_ror, [Word w1, Word w2]) => wo (Word.ror, w1, w2)
-	   | (Word32_rshift, [Word w1, Word w2]) => wo (Word.>>, w1, w2)
-	   | (Word32_sub, [Word w1, Word w2]) => wo (Word.-, w1, w2)
-	   | (Word32_toIntX, [Word w]) => int (Word.toIntX w)
-	   | (Word32_xorb, [Word w1, Word w2]) => wo (Word.xorb, w1, w2)
+	   | (Word_add _, [Word w1, Word w2]) => word (WordX.+ (w1, w2))
+	   | (Word_addCheck s, [Word w1, Word w2]) =>
+		wcheck (IntInf.+, w1, w2, s)
+	   | (Word_andb _, [Word w1, Word w2]) => word (WordX.andb (w1, w2))
+	   | (Word_arshift _, [Word w1, Word w2]) => word (WordX.~>> (w1, w2))
+	   | (Word_div _, [Word w1, Word w2]) => word (WordX.div (w1, w2))
+	   | (Word_ge _, [Word w1, Word w2]) => bool (WordX.>= (w1, w2))
+	   | (Word_gt _, [Word w1, Word w2]) => bool (WordX.> (w1, w2))
+	   | (Word_le _, [Word w1, Word w2]) => bool (WordX.<= (w1, w2))
+	   | (Word_lshift _, [Word w1, Word w2]) => word (WordX.<< (w1, w2))
+	   | (Word_lt _, [Word w1, Word w2]) => bool (WordX.< (w1, w2))
+	   | (Word_mod _, [Word w1, Word w2]) => word (WordX.mod (w1, w2))
+	   | (Word_mul _, [Word w1, Word w2]) => word (WordX.* (w1, w2))
+	   | (Word_mulCheck s, [Word w1, Word w2]) =>
+		wcheck (IntInf.*, w1, w2, s)
+	   | (Word_notb _, [Word w]) => word (WordX.notb w)
+	   | (Word_orb _, [Word w1, Word w2]) => word (WordX.orb (w1, w2))
+	   | (Word_rol _, [Word w1, Word w2]) => word (WordX.rol (w1, w2))
+	   | (Word_ror _, [Word w1, Word w2]) => word (WordX.ror (w1, w2))
+	   | (Word_rshift _, [Word w1, Word w2]) => word (WordX.>> (w1, w2))
+	   | (Word_sub _, [Word w1, Word w2]) => word (WordX.- (w1, w2))
+	   | (Word_toInt (_, s), [Word w]) =>
+		int (IntX.make (WordX.toIntInf w, s))
+	   | (Word_toIntInf, [Word w]) =>
+		(case SmallIntInf.fromWord (WordX.toWord w) of
+		    NONE => ApplyResult.Unknown
+		  | SOME i => intInf i)
+	   | (Word_toIntX (_, s), [Word w]) =>
+		int (IntX.make (WordX.toIntInfX w, s))
+	   | (Word_toWord (_, s), [Word w]) => word (WordX.resize (w, s))
+	   | (Word_toWordX (_, s), [Word w]) => word (WordX.resizeX (w, s))
+	   | (Word_xorb _, [Word w1, Word w2]) => word (WordX.xorb (w1, w2))
 	   | _ => ApplyResult.Unknown)
 	     handle Chr => ApplyResult.Unknown
 		  | Div => ApplyResult.Unknown
@@ -925,13 +935,14 @@
       fun someVars () =
 	 let
 	    datatype z = datatype ApplyResult.t
-	    fun add (x, i) = if i = 0 then Var x else Unknown
-	    fun mul (x, i, neg) =
-	       case i of
-		  0 => int 0
-		| 1 => Var x
-		| ~1 => Apply (neg, [x])
-		| _ => Unknown
+	    fun add (x: 'a, i: IntX.t): 'a ApplyResult.t =
+	       if IntX.isZero i then Var x else Unknown
+	    fun mul (x: 'a, i: IntX.t, s: IntSize.t, neg) =
+	       (case IntX.toInt i of
+		   0 => int (IntX.zero s)
+		 | 1 => Var x
+		 | ~1 => Apply (neg s, [x])
+		 | _ => Unknown) handle Exn.Overflow => Unknown
 	    val name = name p
 	    fun varIntInf (x, i: IntInf.t, space, inOrder) =
 	       let
@@ -983,151 +994,124 @@
 	       end handle Exn.Overflow => Unknown
 	    fun varWord (x, w, inOrder) =
 	       let
-		  fun allOnes isWord8 = if isWord8 then 0wxFF else 0wxFFFFFFFF
-		  val max = allOnes
-		  fun zero isWord8 = if isWord8 then word8 0wx0 else word32 0wx0
-		  fun maxRes isWord8 =
-		     if isWord8 then word8 0wxFF else word32 0wxFFFFFFFF
-		  fun add () = if w = 0w0 then Var x else Unknown
-		  fun andb isWord8 =
-		     if w = 0w0
-		        then zero isWord8
-		     else if w = allOnes isWord8
+		  val zero = word o WordX.zero
+		  fun add s = if WordX.isZero w then Var x else Unknown
+		  fun mul () =
+		     if WordX.isZero w
+			then word w
+		     else if WordX.isOne w
 			     then Var x
 			  else Unknown
-		  fun arshift isWord8 =
-		     if w = 0w0 then if inOrder then Var x else zero isWord8
-		     else if w = max isWord8
-			     then if inOrder then Unknown else maxRes isWord8
-			  else Unknown
-		  nonfix div
-		  fun div () = if inOrder andalso w = 0w1 then Var x else Unknown
-		  fun ge isWord8 =
-		     if inOrder
-			then if w = 0w0 then t else Unknown
-		     else if w = max isWord8 then t else Unknown
-		  fun gt isWord8 =
-		     if inOrder
-			then if w = max isWord8 then f else Unknown
-		     else if w = 0w0 then f else Unknown
-		  fun le isWord8 =
-		     if inOrder
-			then if w = max isWord8 then t else Unknown
-		     else if w = 0w0 then t else Unknown
-		  fun lt isWord8 =
-		     if inOrder
-			then if w = 0w0 then f else Unknown
-		     else if w = max isWord8 then f else Unknown
-		  nonfix mod
-		  fun mod isWord8 =
-		     if inOrder andalso w = 0w1 then zero isWord8 else Unknown
-		  fun mul isWord8 =
-		     case w of
-			0w0 => zero isWord8
-		      | 0w1 => Var x
-		      | _ => Unknown
-		  fun orb isWord8 =
-		     if w = 0w0
-			then Var x
-		     else if w = allOnes isWord8
-			     then maxRes isWord8
-			  else Unknown
-		  fun ro isWord8 =
+		  fun ro () =
 		     if inOrder
 			then
-			   if 0w0 = Word.mod (w, if isWord8 then 0w8 else 0w32)
-			      then Var x
-			   else Unknown
+			   let
+			      val s = WordX.size w
+			   in
+			      if WordX.isZero
+				 (WordX.mod
+				  (w,
+				   WordX.make
+				   (Word.fromInt (WordSize.size s), s)))
+				 then Var x
+			      else Unknown
+			   end
 		     else
-			if w = 0w0
-			   then zero isWord8
-			else if w = allOnes isWord8
-				then maxRes isWord8
-			     else Unknown
-		  fun shift isWord8 =
+			if WordX.isZero w orelse WordX.isAllOnes w
+			   then word w
+			else Unknown
+		  fun shift s =
 		     if inOrder
-			then if w = 0w0
+			then if WordX.isZero w
 				then Var x
-			     else if w >= (if isWord8 then 0w8 else 0w32)
-				     then zero isWord8
+			     else if (WordX.>=
+				      (w, WordX.make (Word.fromInt
+						      (WordSize.size s),
+						      WordSize.default)))
+				     then zero s
 				  else Unknown
-		     else if w = 0w0
-			     then zero isWord8
-			  else Unknown
-		  fun sub isWord8 =
-		     if w = 0w0
-			then
-			   if inOrder
-			      then Var x
-			   else Apply (if isWord8
-					  then word8Neg
-				       else word32Neg,
-					  [x])
-		     else Unknown
-		  fun xorb isWord8 =
-		     if w = 0w0
-			then Var x
-		     else if w = allOnes isWord8
-			     then Apply (if isWord8 then word8Notb
-					 else word32Notb,
-					 [x])
+		     else if WordX.isZero w
+			     then zero s
 			  else Unknown
 	       in
 		  case name of
-		     Word8_add => add ()
-		   | Word32_add => add ()
-		   | Word32_addCheck => add ()
-		   | Word8_andb => andb true
-		   | Word32_andb => andb false
-		   | Word8_arshift => arshift true
-		   | Word32_arshift => arshift false
-		   | Word8_div => div ()
-		   | Word32_div => div ()
-		   | Word8_ge => ge true
-		   | Word32_ge => ge false
-		   | Word8_gt => gt true
-		   | Word32_gt => gt false
-		   | Word8_le => le true
-		   | Word32_le => le false
-		   | Word8_lshift => shift true
-		   | Word32_lshift => shift false
-		   | Word8_lt => lt true
-		   | Word32_lt => lt false
-		   | Word8_mod => mod true
-		   | Word32_mod => mod false
-		   | Word8_mul => mul true
-		   | Word32_mul => mul false
-		   | Word32_mulCheck => mul false
-		   | Word8_orb => orb true
-		   | Word32_orb => orb false
-		   | Word8_rol => ro true
-		   | Word32_rol => ro false
-		   | Word8_ror => ro true
-		   | Word32_ror => ro false
-		   | Word8_rshift => shift true
-		   | Word32_rshift => shift false
-		   | Word8_sub => sub true
-		   | Word32_sub => sub false
-		   | Word8_xorb => xorb true
-		   | Word32_xorb => xorb false
+		     Word_add s => add s
+		   | Word_addCheck s => add s
+		   | Word_andb s =>
+			if WordX.isZero w
+			   then zero s
+			else if WordX.isAllOnes w
+				then Var x
+			     else Unknown
+		   | Word_arshift s =>
+			if WordX.isZero w
+			   then if inOrder then Var x else zero s
+			else if WordX.isAllOnes w
+				then if inOrder then Unknown else word w
+			     else Unknown
+		   | Word_div _ =>
+			if inOrder andalso WordX.isOne w then Var x else Unknown
+		   | Word_ge _ =>
+			if inOrder
+			   then if WordX.isZero w then t else Unknown
+			else if WordX.isMax w then t else Unknown
+		   | Word_gt _ =>
+			if inOrder
+			   then if WordX.isMax w then f else Unknown
+			else if WordX.isZero w then f else Unknown
+		   | Word_le _ =>
+			if inOrder
+			   then if WordX.isMax w then t else Unknown
+			else if WordX.isZero w then t else Unknown
+		   | Word_lshift s => shift s
+		   | Word_lt _ =>
+			if inOrder
+			   then if WordX.isZero w then f else Unknown
+			else if WordX.isMax w then f else Unknown
+		   | Word_mod s =>
+			if inOrder andalso WordX.isOne w
+			   then zero s
+			else Unknown
+		   | Word_mul _ => mul ()
+		   | Word_mulCheck _ => mul ()
+		   | Word_orb _ =>
+			if WordX.isZero w
+			   then Var x
+			else if WordX.isAllOnes w
+				then word w
+			     else Unknown
+		   | Word_rol _ => ro ()
+		   | Word_ror _ => ro ()
+		   | Word_rshift s => shift s
+		   | Word_sub s =>
+			if WordX.isZero w
+			   then
+			      if inOrder
+				 then Var x
+			      else Apply (wordNeg s, [x])
+			else Unknown
+		   | Word_xorb s =>
+			if WordX.isZero w
+			   then Var x
+			else if WordX.isAllOnes w
+				then Apply (wordNotb s, [x])
+			     else Unknown
 		   | _ => Unknown
 	       end
-	    val minInt = ~0x80000000
-	    val maxInt = 0x7FFFFFFF
 	    datatype z = datatype ApplyArg.t
 	 in
 	    case (name, args) of
 	       (IntInf_toString, [Const (IntInf i), Const (Int base), _]) =>
 		  let
 		     val base =
-			case base of
+			case IntX.toInt base of
 			   2 => StringCvt.BIN
 			 | 8 => StringCvt.OCT 
 			 | 10 => StringCvt.DEC
 			 | 16 => StringCvt.HEX
 			 | _ => Error.bug "strange base for IntInf_toString"
 		  in
-		     string (IntInf.format (i, base))
+		     word8Vector (Word8.stringToVector (IntInf.format (i, base)))
 		  end
 	     | (_, [Con {con = c, hasArg = h}, Con {con = c', hasArg = h'}]) =>
 		  if name = MLton_equal orelse name = MLton_eq
@@ -1141,40 +1125,51 @@
 	     | (_, [Const (Word i), Var x]) => varWord (x, i, false)
 	     | (_, [Var x, Const (Int i)]) =>
 		  (case name of
-		      Int_add => add (x, i)
-		    | Int_addCheck => add (x, i)
-		    | Int_ge => if i = minInt then t else Unknown
-		    | Int_geu => if i = 0 then t else Unknown
-		    | Int_gt => if i = maxInt then f else Unknown
-		    | Int_gtu => if i = ~1 then f else Unknown
-		    | Int_le => if i = maxInt then t else Unknown
-		    | Int_lt => if i = minInt then f else Unknown
-		    | Int_mul => mul (x, i, intNeg)
-		    | Int_mulCheck => mul (x, i, intNegCheck)
-		    | Int_quot => (case i of
-				      1 => ApplyResult.Var x
-				    | ~1 => Apply (intNeg, [x])
-				    | _ => Unknown)
-		    | Int_rem => if i = ~1 orelse i = 1 then int 0 else Unknown
-		    | Int_sub => if i = 0 then ApplyResult.Var x else Unknown
-		    | Int_subCheck =>
-			 if i = 0 then ApplyResult.Var x else Unknown
+		      Int_add s => add (x, i)
+		    | Int_addCheck s => add (x, i)
+		    | Int_ge _ => if IntX.isMin i then t else Unknown
+		    | Int_gt _ => if IntX.isMax i then f else Unknown
+		    | Int_le _ => if IntX.isMax i then t else Unknown
+		    | Int_lt _ => if IntX.isMin i then f else Unknown
+		    | Int_mul s => mul (x, i, s, intNeg)
+		    | Int_mulCheck s => mul (x, i, s, intNegCheck)
+		    | Int_quot s =>
+			 if IntX.isNegOne i
+			    then Apply (intNeg s, [x])
+			 else if IntX.isOne i
+				 then ApplyResult.Var x
+			      else Unknown
+		    | Int_rem s =>
+			 if IntX.isNegOne i orelse IntX.isOne i
+			    then int (IntX.zero s)
+			 else Unknown
+		    | Int_sub _ =>
+			 if IntX.isZero i
+			    then ApplyResult.Var x
+			 else Unknown
+		    | Int_subCheck _ =>
+			 if IntX.isZero i
+			    then ApplyResult.Var x
+			 else Unknown
 		    | _ => Unknown)
 	     | (_, [Const (Int i), Var x]) =>
 		  (case name of 
-		      Int_add => add (x, i)
-		    | Int_addCheck => add (x, i)
-		    | Int_ge => if i = maxInt then t else Unknown
-		    | Int_geu => if i = ~1 then t else Unknown
-		    | Int_gt => if i = minInt then f else Unknown
-		    | Int_gtu => if i = 0 then f else Unknown
-		    | Int_le => if i = minInt then t else Unknown
-		    | Int_lt => if i = maxInt then f else Unknown
-		    | Int_mul => mul (x, i, intNeg)
-		    | Int_mulCheck => mul (x, i, intNegCheck)
-		    | Int_sub => if i = 0 then Apply (intNeg, [x]) else Unknown
-		    | Int_subCheck =>
-			 if i = 0 then Apply (intNegCheck, [x]) else Unknown
+		      Int_add _ => add (x, i)
+		    | Int_addCheck _ => add (x, i)
+		    | Int_ge _ => if IntX.isMax i then t else Unknown
+		    | Int_gt _ => if IntX.isMin i then f else Unknown
+		    | Int_le _ => if IntX.isMin i then t else Unknown
+		    | Int_lt _ => if IntX.isMax i then f else Unknown
+		    | Int_mul s => mul (x, i, s, intNeg)
+		    | Int_mulCheck s => mul (x, i, s, intNegCheck)
+		    | Int_sub s =>
+			 if IntX.isZero i
+			    then Apply (intNeg s, [x])
+			 else Unknown
+		    | Int_subCheck s =>
+			 if IntX.isZero i
+			    then Apply (intNegCheck s, [x])
+			 else Unknown
 		    | _ => Unknown)
 	     | (_, [Const (IntInf i1), Const (IntInf i2), _]) =>
 		  (case name of
@@ -1190,8 +1185,8 @@
 		    | _ => Unknown)
 	     | (_, [Const (IntInf i1), Const (Word w2), _]) =>
 		  (case name of
-		      IntInf_arshift => intInf (IntInf.~>> (i1, w2))
-		    | IntInf_lshift => intInf (IntInf.<< (i1, w2))
+		      IntInf_arshift => intInf (IntInf.~>> (i1, WordX.toWord w2))
+		    | IntInf_lshift => intInf (IntInf.<< (i1, WordX.toWord w2))
 		    | _ => Unknown)
 	     | (_, [Const (IntInf i1), _]) =>
 		  (case name of
@@ -1202,15 +1197,19 @@
 		  varIntInf (x, i, space, true)
 	     | (_, [Const (IntInf i), Var x, Var space]) =>
 		  varIntInf (x, i, space, false)
-	     | (_, [Var x, Const (Word 0wx0), _]) =>
-		  (let datatype z = datatype ApplyResult.t
-		   in 
-		      case name of
-			 IntInf_arshift => Var x
-		       | IntInf_lshift => Var x
-		       | _ => Unknown
-		   end)
-	     | (_, [Var x, Var y, _]) =>
+	     | (_, [Var x, Const (Word w), _]) =>
+		  if WordX.isZero w
+		     then
+			let
+			   datatype z = datatype ApplyResult.t
+			in
+			   case name of
+			      IntInf_arshift => Var x
+			    | IntInf_lshift => Var x
+			    | _ => Unknown
+			end
+		  else Unknown
+             | (_, [Var x, Var y, _]) =>
 		  if varEquals (x, y)
 		     then let datatype z = datatype ApplyResult.t
 			  in
@@ -1230,50 +1229,36 @@
 			     val t = ApplyResult.truee
 			     val f = ApplyResult.falsee
 			     datatype z = datatype ApplyResult.t
-			  in case name of
-			        Char_lt => f
-			      | Char_le => t
-			      | Char_gt => f
-			      | Char_ge => t
-			      | Int_ge => t
-			      | Int_geu => t
-			      | Int_gt => f
-			      | Int_gtu => f
-			      | Int_le => t
-			      | Int_lt => f
-			      | Int_quot => int 1
-			      | Int_rem => int 0
-			      | Int_sub => int 0
-			      | IntInf_compare => int 0
+			  in
+			     case name of
+				Int_ge _ => t
+			      | Int_gt _ => f
+			      | Int_le _ => t
+			      | Int_lt _ => f
+			      | Int_quot s => int (IntX.one s)
+			      | Int_rem s => int (IntX.zero s)
+			      | Int_sub s => int (IntX.zero s)
+			      | IntInf_compare =>
+				   int (IntX.zero IntSize.default)
 			      | IntInf_equal => t
 			      | MLton_eq => t
 			      | MLton_equal => t
-			      | Real_lt => f
-			      | Real_le => t
-			      | Real_equal => t
-			      | Real_gt => f
-			      | Real_ge => t
-			      | Real_qequal => t
-			      | Word8_andb => Var x
-			      | Word8_div => word8 0w1
-			      | Word8_ge => t
-			      | Word8_gt => f
-			      | Word8_le => t
-			      | Word8_lt => f
-			      | Word8_mod => word8 0w0
-			      | Word8_orb => Var x
-			      | Word8_sub => word8 0w0
-			      | Word8_xorb => word8 0w0
-			      | Word32_andb => Var x
-			      | Word32_div => word 0w1
-			      | Word32_ge => t
-			      | Word32_gt => f
-			      | Word32_le => t
-			      | Word32_lt => f
-			      | Word32_mod => word 0w0
-			      | Word32_orb => Var x
-			      | Word32_sub => word 0w0
-			      | Word32_xorb => word 0w0
+			      | Real_lt _ => f
+			      | Real_le _ => t
+			      | Real_equal _ => t
+			      | Real_gt _ => f
+			      | Real_ge _ => t
+			      | Real_qequal _ => t
+			      | Word_andb _ => Var x
+			      | Word_div s => word (WordX.one s)
+			      | Word_ge _ => t
+			      | Word_gt _ => f
+			      | Word_le _ => t
+			      | Word_lt _ => f
+			      | Word_mod s => word (WordX.zero s)
+			      | Word_orb _ => Var x
+			      | Word_sub s => word (WordX.zero s)
+			      | Word_xorb s => word (WordX.zero s)
 			      | _ => Unknown
 			  end
 		  else Unknown
@@ -1303,85 +1288,63 @@
        | Char_ge => two ">="
        | Char_chr => one "chr"
        | Char_ord => one "ord"
-       | Int_mul => two "*?"
-       | Int_mulCheck => two "*"
-       | Int_add => two "+?"
-       | Int_addCheck => two "+"
-       | Int_sub => two "-?"
-       | Int_subCheck => two "-"
-       | Int_lt => two "<"
-       | Int_le => two "<="
-       | Int_gt => two ">"
-       | Int_ge => two ">="
-       | Int_geu => two ">=u"
-       | Int_gtu => two ">u"
-       | Int_neg => one "-?"
-       | Int_negCheck => one "-"
+       | Int_mul _ => two "*?"
+       | Int_mulCheck _ => two "*"
+       | Int_add _ => two "+?"
+       | Int_addCheck _ => two "+"
+       | Int_sub _ => two "-?"
+       | Int_subCheck _ => two "-"
+       | Int_lt _ => two "<"
+       | Int_le _ => two "<="
+       | Int_gt _ => two ">"
+       | Int_ge _ => two ">="
+       | Int_neg _ => one "-?"
+       | Int_negCheck _ => one "-"
        | IntInf_equal => two "="
        | MLton_eq => two "="
-       | Real_Math_acos => one "acos"
-       | Real_Math_asin => one "asin"
-       | Real_Math_atan => one "atan"
-       | Real_Math_cos => one "cos"
-       | Real_Math_cosh => one "cosh"
-       | Real_Math_exp => one "exp"
-       | Real_Math_ln => one "ln"
-       | Real_Math_log10  => one "log10"
-       | Real_Math_pow => two "^"
-       | Real_Math_sin => one "sin"
-       | Real_Math_sinh => one "sinh"
-       | Real_Math_sqrt => one "sqrt"
-       | Real_Math_tan => one "tan"
-       | Real_Math_tanh => one "tanh"
-       | Real_mul => two "*"
-       | Real_add => two "+"
-       | Real_sub => two "-"
-       | Real_div => two "/"
-       | Real_lt => two "<"
-       | Real_le => two "<="
-       | Real_equal => two "=="
-       | Real_gt => two ">"
-       | Real_ge => two ">="
-       | Real_qequal => two "?="
-       | Real_neg => one "-"
+       | Real_Math_acos _ => one "acos"
+       | Real_Math_asin _ => one "asin"
+       | Real_Math_atan _ => one "atan"
+       | Real_Math_cos _ => one "cos"
+       | Real_Math_exp _ => one "exp"
+       | Real_Math_ln _ => one "ln"
+       | Real_Math_log10  _ => one "log10"
+       | Real_Math_sin _ => one "sin"
+       | Real_Math_sqrt _ => one "sqrt"
+       | Real_Math_tan _ => one "tan"
+       | Real_add _ => two "+"
+       | Real_div _ => two "/"
+       | Real_equal _ => two "=="
+       | Real_ge _ => two ">="
+       | Real_gt _ => two ">"
+       | Real_le _ => two "<="
+       | Real_lt _ => two "<"
+       | Real_mul _ => two "*"
+       | Real_neg _ => one "-"
+       | Real_qequal _ => two "?="
+       | Real_sub _ => two "-"
        | Ref_assign => two ":="
        | Ref_deref => one "!"
        | Ref_ref => one "ref"
        | Vector_length => one "length"
-       | Word32_add => two "+"
-       | Word32_addCheck => two "+c"
-       | Word32_andb => two "&"
-       | Word32_arshift => two "~>>"
-       | Word32_ge => two ">="
-       | Word32_gt => two ">"
-       | Word32_le => two "<="
-       | Word32_lshift => two "<<"
-       | Word32_lt => two "<"
-       | Word32_mul => two "*"
-       | Word32_mulCheck => two "*c"
-       | Word32_neg => one "-"
-       | Word32_orb => two "|"
-       | Word32_rol => two "rol"
-       | Word32_ror => two "ror"
-       | Word32_rshift => two ">>"
-       | Word32_sub => two "-"
-       | Word32_xorb => two "^"
-       | Word8_add => two "+"
-       | Word8_andb => two "&"
-       | Word8_arshift => two "~>>"
-       | Word8_ge => two ">="
-       | Word8_gt => two ">"
-       | Word8_le => two "<="
-       | Word8_lshift => two "<<"
-       | Word8_lt => two "<"
-       | Word8_mul => two "*"
-       | Word8_neg => one "-"
-       | Word8_orb => two "|"
-       | Word8_rol => two "rol"
-       | Word8_ror => two "ror"
-       | Word8_rshift => two ">>"
-       | Word8_sub => two "-"
-       | Word8_xorb => two "^"
+       | Word_add _ => two "+"
+       | Word_addCheck _ => two "+c"
+       | Word_andb _ => two "&"
+       | Word_arshift _ => two "~>>"
+       | Word_ge _ => two ">="
+       | Word_gt _ => two ">"
+       | Word_le _ => two "<="
+       | Word_lshift _ => two "<<"
+       | Word_lt _ => two "<"
+       | Word_mul _ => two "*"
+       | Word_mulCheck _ => two "*c"
+       | Word_neg _ => one "-"
+       | Word_orb _ => two "|"
+       | Word_rol _ => two "rol"
+       | Word_ror _ => two "ror"
+       | Word_rshift _ => two ">>"
+       | Word_sub _ => two "-"
+       | Word_xorb _ => two "^"
        | _ => seq [layout p, str " ", Vector.layout layoutArg args]
    end
 



1.39      +107 -128  mlton/mlton/atoms/prim.sig

Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- prim.sig	20 May 2003 02:18:26 -0000	1.38
+++ prim.sig	23 Jun 2003 04:58:55 -0000	1.39
@@ -11,9 +11,15 @@
    sig
       structure Con: CON
       structure Const: CONST
+      structure IntSize: INT_SIZE
+      structure RealSize: REAL_SIZE
       structure Scheme: SCHEME
       structure Type: TYPE
+      structure WordSize: WORD_SIZE
+      sharing IntSize = Const.IntX.IntSize = Type.Tycon.IntSize
+      sharing RealSize = Const.RealX.RealSize = Type.Tycon.RealSize
       sharing Type = Scheme.Type
+      sharing WordSize = Const.WordX.WordSize = Type.Tycon.WordSize
    end
 
 signature PRIM = 
@@ -27,6 +33,7 @@
 	     | Array_array0Const (* constant propagation *)
 	     | Array_length (* ssa to rssa *)
 	     | Array_sub (* backend *)
+	     | Array_toVector (* backend *)
 	     | Array_update (* backend *)
 	     | BuildConstant of string (* type inference *)
 	     | Byte_byteToChar (* ssa to rssa *)
@@ -50,29 +57,27 @@
 	     | GC_collect (* ssa to rssa *)
 	     | GC_pack (* ssa to rssa *)
 	     | GC_unpack (* ssa to rssa *)
-             | Int_add (* codegen *)
-             | Int_addCheck (* codegen *)
-             | Int_ge (* codegen *)
-             | Int_geu (* codegen *)
-             | Int_gt (* codegen *)
-             | Int_gtu (* codegen *)
-             | Int_le (* codegen *)
-             | Int_lt (* codegen *)
-             | Int_mul (* codegen *)
-             | Int_mulCheck (* codegen *)
-             | Int_neg (* codegen *)
-             | Int_negCheck (* codegen *)
-             | Int_quot (* codegen *)
-             | Int_rem (* codegen *)
-             | Int_sub (* codegen *)
-             | Int_subCheck (* codegen *)
+	     | Int_add of IntSize.t (* codegen *)
+	     | Int_addCheck of IntSize.t (* codegen *)
+	     | Int_ge of IntSize.t (* codegen *)
+	     | Int_gt of IntSize.t (* codegen *)
+	     | Int_le of IntSize.t (* codegen *)
+	     | Int_lt of IntSize.t (* codegen *)
+	     | Int_mul of IntSize.t (* codegen *)
+	     | Int_mulCheck of IntSize.t (* codegen *)
+	     | Int_neg of IntSize.t (* codegen *)
+	     | Int_negCheck of IntSize.t (* codegen *)
+	     | Int_quot of IntSize.t (* codegen *)
+	     | Int_rem of IntSize.t (* codegen *)
+	     | Int_sub of IntSize.t (* codegen *)
+	     | Int_subCheck of IntSize.t (* codegen *)
+	     | Int_toReal of IntSize.t * RealSize.t (* codegen *)
+	     | Int_toWord of IntSize.t * WordSize.t (* codegen *)
 	     | IntInf_add (* ssa to rssa *)
 	     | IntInf_andb (* ssa to rssa *)
 	     | IntInf_arshift (* ssa to rssa *)
 	     | IntInf_compare (* ssa to rssa *)
 	     | IntInf_equal (* ssa to rssa *)
-	     | IntInf_fromVector (* ssa to rssa *)
-	     | IntInf_fromWord (* ssa to rssa *)
 	     | IntInf_gcd (* ssa to rssa *)
 	     | IntInf_lshift (* ssa to rssa *)
 	     | IntInf_mul (* ssa to rssa *)
@@ -87,9 +92,9 @@
 	     | IntInf_toWord (* ssa to rssa *)
 	     | IntInf_xorb (* ssa to rssa *)
 	     | MLton_bogus (* ssa to rssa *)
-	                   (* of type unit -> 'a.
-			    * Makes a bogus value of any type.
-			    *)
+	     (* of type unit -> 'a.
+	      * Makes a bogus value of any type.
+	      *)
 	     | MLton_bug (* ssa to rssa *)
 	     | MLton_deserialize (* unused *)
 	     | MLton_eq (* codegen *)
@@ -112,47 +117,38 @@
 	     | MLton_serialize (* unused *)
 	     | MLton_size (* ssa to rssa *)
 	     | MLton_touch (* backend *)
-	     | Real_Math_acos (* codegen *)
-	     | Real_Math_asin (* codegen *)
-	     | Real_Math_atan (* codegen *)
-	     | Real_Math_atan2 (* codegen *)
-	     | Real_Math_cos (* codegen *)
-	     | Real_Math_cosh (* codegen *)
-	     | Real_Math_exp (* codegen *)
-	     | Real_Math_ln (* codegen *)
-	     | Real_Math_log10  (* codegen *)
-	     | Real_Math_pow (* codegen *)
-	     | Real_Math_sin (* codegen *)
-	     | Real_Math_sinh (* codegen *)
-	     | Real_Math_sqrt (* codegen *)
-	     | Real_Math_tan (* codegen *)
-	     | Real_Math_tanh (* codegen *)
-	     | Real_abs (* codegen *)
-	     | Real_add (* codegen *)
-	     | Real_copysign (* codegen *)
-	     | Real_div (* codegen *)
-	     | Real_equal (* codegen *)
-	     | Real_frexp (* ssa to rssa *)
-	     | Real_fromInt (* codegen *)
-	     | Real_ge (* codegen *)
-	     | Real_gt (* codegen *)
-	     | Real_ldexp (* codegen *)
-	     | Real_le (* codegen *)
-	     | Real_lt (* codegen *)
-	     | Real_modf (* ssa to rssa *)
-	     | Real_mul (* codegen *)
-	     | Real_muladd (* codegen *)
-	     | Real_mulsub (* codegen *)
-	     | Real_neg	  (* codegen *)
-	     | Real_qequal (* codegen *)
-	     | Real_round (* codegen *)
-	     | Real_sub (* codegen *)
-	     | Real_toInt (* codegen *)
+	     | Real_Math_acos of RealSize.t (* codegen *)
+	     | Real_Math_asin of RealSize.t (* codegen *)
+	     | Real_Math_atan of RealSize.t (* codegen *)
+	     | Real_Math_atan2 of RealSize.t (* codegen *)
+	     | Real_Math_cos of RealSize.t (* codegen *)
+	     | Real_Math_exp of RealSize.t (* codegen *)
+	     | Real_Math_ln of RealSize.t (* codegen *)
+	     | Real_Math_log10 of RealSize.t  (* codegen *)
+	     | Real_Math_sin of RealSize.t (* codegen *)
+	     | Real_Math_sqrt of RealSize.t (* codegen *)
+	     | Real_Math_tan of RealSize.t (* codegen *)
+	     | Real_abs of RealSize.t (* codegen *)
+	     | Real_add of RealSize.t (* codegen *)
+	     | Real_div of RealSize.t (* codegen *)
+	     | Real_equal of RealSize.t (* codegen *)
+	     | Real_ge of RealSize.t (* codegen *)
+	     | Real_gt of RealSize.t (* codegen *)
+	     | Real_ldexp of RealSize.t (* codegen *)
+	     | Real_le of RealSize.t (* codegen *)
+	     | Real_lt of RealSize.t (* codegen *)
+	     | Real_mul of RealSize.t (* codegen *)
+	     | Real_muladd of RealSize.t (* codegen *)
+	     | Real_mulsub of RealSize.t (* codegen *)
+	     | Real_neg of RealSize.t	  (* codegen *)
+	     | Real_qequal of RealSize.t (* codegen *)
+	     | Real_round of RealSize.t (* codegen *)
+	     | Real_sub of RealSize.t (* codegen *)
+	     | Real_toInt of RealSize.t (* codegen *)
 	     | Ref_assign (* backend *)
 	     | Ref_deref (* backend *)
 	     | Ref_ref (* backend *)
-	     | String_fromWord8Vector (* ssa to rssa *)
-	     | String_toWord8Vector (* ssa to rssa *)
+	     | String_toWord8Vector (* infer *)
 	     | Thread_atomicBegin (* backend *)
 	     | Thread_atomicEnd (* backend *)
 	     | Thread_canHandle (* backend *)
@@ -164,63 +160,42 @@
 	      * on the stack.
 	      *)
 	     | Thread_switchTo (* ssa to rssa *)
-	     | Vector_fromArray (* backend *)
 	     | Vector_length (* ssa to rssa *)
 	     | Vector_sub (* backend *)
 	     | Weak_canGet (* ssa to rssa *)
 	     | Weak_get (* ssa to rssa *)
 	     | Weak_new (* ssa to rssa *)
-	     | Word32_add (* codegen *)
-	     | Word32_addCheck (* codegen *)
-	     | Word32_andb (* codegen *)
-	     | Word32_arshift (* codegen *)
-	     | Word32_div (* codegen *)
-	     | Word32_fromInt (* ssa to rssa *)
-	     | Word32_ge (* codegen *)
-	     | Word32_gt (* codegen *)
-	     | Word32_le (* codegen *)
-	     | Word32_lshift (* codegen *)
-	     | Word32_lt (* codegen *)
-	     | Word32_mod (* codegen *)
-	     | Word32_mul (* codegen *)
-	     | Word32_mulCheck (* codegen *)
-	     | Word32_neg (* codegen *)
-	     | Word32_notb (* codegen *)
-	     | Word32_orb (* codegen *)
-	     | Word32_rol (* codegen *)
-	     | Word32_ror (* codegen *)
-	     | Word32_rshift (* codegen *)
-	     | Word32_sub (* codegen *)
-	     | Word32_toIntX (* ssa to rssa *)
-	     | Word32_xorb (* codegen *)
-	     | Word8Array_subWord (* codegen *)
-	     | Word8Array_updateWord (* codegen *)
-	     | Word8Vector_subWord (* codegen *)
-	     | Word8_add (* codegen *)
-	     | Word8_andb (* codegen *)
-	     | Word8_arshift (* codegen *)
-	     | Word8_div (* codegen *)
-	     | Word8_fromInt (* codegen *)
-	     | Word8_fromLargeWord (* codegen *)
-	     | Word8_ge (* codegen *)
-	     | Word8_gt (* codegen *)
-	     | Word8_le (* codegen *)
-	     | Word8_lshift (* codegen *)
-	     | Word8_lt (* codegen *)
-	     | Word8_mod (* codegen *)
-	     | Word8_mul (* codegen *)
-	     | Word8_neg (* codegen *)
-	     | Word8_notb (* codegen *)
-	     | Word8_orb (* codegen *)
-	     | Word8_rol (* codegen *)
-	     | Word8_ror (* codegen *)
-	     | Word8_rshift (* codegen *)
-	     | Word8_sub (* codegen *)
-	     | Word8_toInt (* codegen *)
-	     | Word8_toIntX (* codegen *)
-	     | Word8_toLargeWord (* codegen *)
-	     | Word8_toLargeWordX (* codegen *)
-	     | Word8_xorb (* codegen *)
+	     | Word_add of WordSize.t (* codegen *)
+	     | Word_addCheck of WordSize.t (* codegen *)
+	     | Word_andb of WordSize.t (* codegen *)
+	     | Word_arshift of WordSize.t (* codegen *)
+	     | Word_div of WordSize.t (* codegen *)
+	     | Word_ge of WordSize.t (* codegen *)
+	     | Word_gt of WordSize.t (* codegen *)
+	     | Word_le of WordSize.t (* codegen *)
+	     | Word_lshift of WordSize.t (* codegen *)
+	     | Word_lt of WordSize.t (* codegen *)
+	     | Word_mod of WordSize.t (* codegen *)
+	     | Word_mul of WordSize.t (* codegen *)
+	     | Word_mulCheck of WordSize.t (* codegen *)
+	     | Word_neg of WordSize.t (* codegen *)
+	     | Word_notb of WordSize.t (* codegen *)
+	     | Word_orb of WordSize.t (* codegen *)
+	     | Word_rol of WordSize.t (* codegen *)
+	     | Word_ror of WordSize.t (* codegen *)
+	     | Word_rshift of WordSize.t (* codegen *)
+	     | Word_sub of WordSize.t (* codegen *)
+	     | Word_toInt of WordSize.t * IntSize.t (* codegen *)
+	     | Word_toIntInf (* ssa to rssa *)
+	     | Word_toIntX of WordSize.t * IntSize.t (* codegen *)
+	     | Word_toWord of WordSize.t * WordSize.t (* codegen *)
+	     | Word_toWordX of WordSize.t * WordSize.t (* codegen *)
+	     | Word_xorb of WordSize.t (* codegen *)
+	     | WordVector_toIntInf (* ssa to rssa *)
+	     | Word8Array_subWord (* ssa to rssa *)
+	     | Word8Array_updateWord (* ssa to rssa *)
+	     | Word8Vector_subWord (* ssa to rssa *)
+	     | Word8Vector_toString (* infer *)
 	     | World_save (* ssa to rssa *)
 
 	    val layout: t -> Layout.t
@@ -233,7 +208,7 @@
 	 sig
 	    datatype 'a t =
 	       Con of {con: Con.t, hasArg: bool}
-	     | Const of Const.Node.t
+	     | Const of Const.t
 	     | Var of 'a
 
 	    val layout: ('a -> Layout.t) -> 'a t -> Layout.t
@@ -286,12 +261,13 @@
       val ffi: string * Scheme.t -> t
       val gcCollect: t
       val intInfEqual: t
-      val intAdd: t
-      val intAddCheck: t
-      val intMul: t
-      val intMulCheck: t
-      val intSub: t
-      val intSubCheck: t
+      val intAdd: IntSize.t -> t
+      val intAddCheck: IntSize.t -> t
+      val intMul: IntSize.t -> t
+      val intMulCheck: IntSize.t -> t
+      val intSub: IntSize.t -> t
+      val intSubCheck: IntSize.t -> t
+      val intToWord: IntSize.t * WordSize.t -> t
       val isCommutative: t -> bool
       (*
        * isFunctional p = true iff p always returns same result when given
@@ -320,14 +296,17 @@
       val toString: t -> string
       val vectorLength: t
       val vectorSub: t
-      val word32Add: t
-      val word32AddCheck: t
-      val word32Andb: t
-      val word32FromInt: t
-      val word32Gt: t
-      val word32Mul: t
-      val word32MulCheck: t
-      val word32Rshift: t
-      val word32Sub: t
-      val word32ToIntX: t
+      val wordAdd: WordSize.t -> t
+      val wordAddCheck: WordSize.t -> t
+      val wordAndb: WordSize.t -> t
+      val wordGe: WordSize.t -> t
+      val wordGt: WordSize.t -> t
+      val wordLe: WordSize.t -> t
+      val wordLt: WordSize.t -> t
+      val wordMul: WordSize.t -> t
+      val wordMulCheck: WordSize.t -> t
+      val wordRshift: WordSize.t -> t
+      val wordSub: WordSize.t -> t
+      val wordToInt: WordSize.t * IntSize.t -> t
+      val wordToIntX: WordSize.t * IntSize.t -> t
    end



1.12      +9 -4      mlton/mlton/atoms/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- sources.cm	18 Apr 2003 22:44:58 -0000	1.11
+++ sources.cm	23 Jun 2003 04:58:55 -0000	1.12
@@ -11,7 +11,7 @@
 signature ATOMS
 signature ID
 signature ID_NO_AST
-signature CASES
+signature INT_X
 signature CON
 signature CONST
 signature GENERIC_SCHEME
@@ -19,6 +19,7 @@
 signature HASH_TYPE
 signature PRIM
 signature PROFILE_EXP
+signature REAL_X
 signature RECORD
 signature SCHEME
 signature SOURCE_INFO
@@ -27,9 +28,9 @@
 signature TYPE
 signature TYVAR
 signature VAR
+signature WORD_X
 
 functor Atoms
-functor Cases
 functor Id
 functor IdNoAst
 functor GenericScheme
@@ -45,8 +46,6 @@
 
 atoms.fun
 atoms.sig
-cases.fun
-cases.sig
 cons.fun
 cons.sig
 const.fun
@@ -57,10 +56,14 @@
 hash-type.sig
 id.fun
 id.sig
+int-x.fun
+int-x.sig
 prim.fun
 prim.sig
 profile-exp.fun
 profile-exp.sig
+real-x.fun
+real-x.sig
 scheme.sig
 source-info.fun
 source-info.sig
@@ -73,3 +76,5 @@
 use-name.fun
 var.fun
 var.sig
+word-x.fun
+word-x.sig



1.3       +4 -1      mlton/mlton/atoms/tycon.fun

Index: tycon.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/tycon.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- tycon.fun	10 Apr 2002 07:02:19 -0000	1.2
+++ tycon.fun	23 Jun 2003 04:58:55 -0000	1.3
@@ -14,7 +14,10 @@
 		       val noname = "t")
 open Id
 
-structure P = PrimTycons (Id)
+structure P = PrimTycons (structure IntSize = IntSize
+			  structure RealSize = RealSize
+			  structure WordSize = WordSize
+			  open Id)
 open P
 
 fun stats () =



1.3       +3 -0      mlton/mlton/atoms/tycon.sig

Index: tycon.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/tycon.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- tycon.sig	10 Apr 2002 07:02:19 -0000	1.2
+++ tycon.sig	23 Jun 2003 04:58:55 -0000	1.3
@@ -8,6 +8,9 @@
 signature TYCON_STRUCTS = 
    sig
       structure AstId: AST_ID
+      structure IntSize: INT_SIZE
+      structure RealSize: REAL_SIZE
+      structure WordSize: WORD_SIZE
    end
 
 signature TYCON =



1.6       +20 -10    mlton/mlton/atoms/type-ops.fun

Index: type-ops.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- type-ops.fun	18 Apr 2003 22:44:58 -0000	1.5
+++ type-ops.fun	23 Jun 2003 04:58:55 -0000	1.6
@@ -10,26 +10,35 @@
 
 open S
 
+local
+   open Tycon
+in
+   structure IntSize = IntSize
+   structure RealSize = RealSize
+   structure WordSize = WordSize
+end
+datatype intSize = datatype IntSize.t
+datatype realSize = datatype RealSize.t
 type tycon = Tycon.t
+datatype wordSize = datatype WordSize.t
    
 local
    fun nullary tycon = con (tycon, Vector.new0 ())
 in
    val bool = nullary Tycon.bool
-   val char = nullary Tycon.char
    val exn = nullary Tycon.exn
-   val int = nullary Tycon.int
+   val int = IntSize.memoize (fn s => nullary (Tycon.int s))
    val intInf = nullary Tycon.intInf
    val preThread = nullary Tycon.preThread
-   val real = nullary Tycon.real
+   val real = RealSize.memoize (fn s => nullary (Tycon.real s))
    val thread = nullary Tycon.thread
-   val word = nullary Tycon.word
-   val word8 = nullary Tycon.word8
-
-   val defaultInt = nullary Tycon.defaultInt
-   val defaultWord = nullary Tycon.defaultWord
+   val word = WordSize.memoize (fn s => nullary (Tycon.word s))
 end
 
+val defaultInt = int IntSize.default
+val defaultReal = real RealSize.default
+val defaultWord = word WordSize.default
+
 local
    fun unary tycon t = con (tycon, Vector.new1 t)
 in
@@ -40,8 +49,9 @@
    val weak = unary Tycon.weak
 end
 
-val string = vector char
-
+val word8 = word W8
+val word8Vector = vector word8
+   
 local
    fun binary tycon (t1, t2) = con (tycon, Vector.new2 (t1, t2))
 in



1.6       +10 -7     mlton/mlton/atoms/type-ops.sig

Index: type-ops.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- type-ops.sig	18 Apr 2003 22:44:58 -0000	1.5
+++ type-ops.sig	23 Jun 2003 04:58:55 -0000	1.6
@@ -22,17 +22,19 @@
 signature TYPE_OPS =
    sig
       (* Don't want to include TYPE_OPS_STRUCTS because don't want to propagate
-       * the Tycon structure, which will cause duplicate specifications later on.
+       * the Tycon structure, which will cause duplicate specifications later
+       * on.
        *)
-
+      type intSize
+      type realSize
       type tycon
+      type wordSize
       type t
 
       val arg: t -> t    (* arg = #1 o dearrow *)
       val array: t -> t
       val arrow: t * t -> t
       val bool: t
-      val char: t
       val con: tycon * t vector -> t
       val dearray: t -> t
       val dearrayOpt: t -> t option
@@ -42,6 +44,7 @@
       val deconConstOpt: t -> (tycon * tycon vector) option
       val deconConst: t -> (tycon * tycon vector)
       val defaultInt: t
+      val defaultReal: t
       val defaultWord: t
       val deref: t -> t
       val derefOpt: t -> t option
@@ -52,22 +55,22 @@
       val deweak: t -> t
       val deweakOpt: t -> t option
       val exn: t
-      val int: t
+      val int: intSize -> t
       val intInf: t
       val isTuple: t -> bool
       val list: t -> t
       val nth: t * int -> t
       val preThread: t
-      val real: t
+      val real: realSize -> t
       val reff: t -> t
       val result: t -> t (* result = #2 o dearrow *)
-      val string: t
       val thread: t
       val tuple: t vector -> t
       val unit: t
       val unitRef: t
       val vector: t -> t
       val weak: t -> t
+      val word: wordSize -> t
       val word8: t
-      val word: t
+      val word8Vector: t
    end



1.3       +12 -2     mlton/mlton/atoms/type.fun

Index: type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- type.fun	10 Apr 2002 07:02:19 -0000	1.2
+++ type.fun	23 Jun 2003 04:58:55 -0000	1.3
@@ -12,12 +12,13 @@
 
 structure Type =
    struct
+      type var = Tyvar.t
+	 
       datatype t =
 	 Var of var
        | Con of con
        | Record of record
-      withtype var = Tyvar.t
-      and con = Tycon.t * t vector
+      withtype con = Tycon.t * t vector
       and record = t Record.t
       datatype t' = datatype t
 
@@ -51,6 +52,15 @@
 structure Ops = TypeOps (structure Tycon = Tycon
 			 open Type)
 open Ops Type
+
+val rec equals =
+   fn (Var a, Var a') => Tyvar.equals (a, a')
+    | (Con (c, ts), Con (c', ts')) =>
+	 Tycon.equals (c, c')
+	 andalso Vector.equals (ts, ts', equals)
+    | (Record r, Record r') =>
+	 Record.equals (r, r', equals)
+    | _ => false
 
 structure Tyvars = UnorderedSet (Tyvar)
    



1.4       +8 -3      mlton/mlton/atoms/type.sig

Index: type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- type.sig	13 May 2003 16:32:28 -0000	1.3
+++ type.sig	23 Jun 2003 04:58:55 -0000	1.4
@@ -11,22 +11,27 @@
       structure Record: RECORD
       structure Tycon: TYCON
       structure Tyvar: TYVAR
+      sharing Record = Ast.SortedRecord
       sharing Tyvar = Ast.Tyvar
       sharing Ast.Tycon = Tycon.AstId
-      sharing Record = Ast.SortedRecord
    end
 
 signature TYPE = 
    sig
       include TYPE_STRUCTS
-      include TYPE_OPS where type tycon = Tycon.t
+      include TYPE_OPS
+	 where type intSize = Tycon.IntSize.t
+	 where type realSize = Tycon.RealSize.t
+	 where type tycon = Tycon.t
+	 where type wordSize = Tycon.WordSize.t
 	    
       datatype t' =
 	 Con of Tycon.t * t' vector
        | Record of t' Record.t
        | Var of Tyvar.t
       sharing type t = t'
-	 
+
+      val equals: t * t -> bool
       val hom: {ty: t,
 		var: Tyvar.t -> 'a,
 		con: Tycon.t * 'a vector -> 'a} -> 'a



1.1                  mlton/mlton/atoms/int-x.fun

Index: int-x.fun
===================================================================
functor IntX (S: INT_X_STRUCTS): INT_X = 
struct

open S

datatype z = datatype IntSize.t
   
datatype t = T of {int: IntInf.t,
		   size: IntSize.t}

local
   fun make f (T r) = f r
in
   val int = make #int
   val size = make #size
end

fun equals (T {int = i, ...}, T {int = i', ...}) = i = i'

fun toString (T {int = i, ...}) = IntInf.toString i

val layout = Layout.str o toString

fun format (T {int = i, ...}, r) = IntInf.format (i, r)

fun make (i: IntInf.t, s: IntSize.t): t =
   if IntSize.isInRange (s, i)
      then T {int = i,
	      size = s}
   else raise Overflow

fun defaultInt (i: int): t = make (IntInf.fromInt i, IntSize.default)

val toIntInf = int

val toInt = IntInf.toInt o toIntInf

val toChar = Char.fromInt o toInt

val hash = IntInf.hash o toIntInf

local
   val make: (IntInf.t * IntInf.t -> IntInf.t) -> t * t -> t =
      fn f => fn (i, i') => make (f (int i, int i'), size i)
in
   val op + = make IntInf.+
   val op - = make IntInf.-
   val op * = make IntInf.*
   val quot = make IntInf.quot
   val rem = make IntInf.rem
end

fun ~ i = make (IntInf.~ (int i), size i)

local
   fun is i i' = int i' = IntInf.fromInt i
in
   val isNegOne = is ~1
   val isOne = is 1
   val isZero = is 0
end

local
   fun is f i = int i = f (size i)
in
   val isMax = is IntSize.max
   val isMin = is IntSize.min
end

fun one s = make (IntInf.fromInt 1, s)
   
fun zero s = make (IntInf.fromInt 0, s)

fun max s = make (IntSize.max s, s)

fun min s = make (IntSize.min s, s)

local
   fun make (f: IntInf.t * IntInf.t -> 'a): t * t -> 'a =
      fn (i, i') =>
      if IntSize.equals (size i, size i')
	 then f (int i, int i')
      else Error.bug "IntX binary failure"
in
   val op < = make IntInf.<
   val op <= = make IntInf.<=
   val op > = make IntInf.>
   val op >= = make IntInf.>=
   val compare = make IntInf.compare
end

end



1.1                  mlton/mlton/atoms/int-x.sig

Index: int-x.sig
===================================================================
type int = Int.t
type word = Word.t
   
signature INT_X_STRUCTS = 
   sig
      structure IntSize: INT_SIZE
   end

signature INT_X = 
   sig
      include INT_X_STRUCTS
	 
      (* Ints of all IntSize.t sizes. *)
      type t

      val + : t * t -> t 
      val - : t * t -> t 
      val * : t * t -> t
      val ~ : t -> t
      val > : t * t -> bool 
      val < : t * t -> bool 
      val >= : t * t -> bool 
      val <= : t * t -> bool
      val compare: t * t -> Relation.t
      val defaultInt: int -> t
      val equals: t * t -> bool
      val format: t * StringCvt.radix -> string
      val hash: t -> word
      val isMax: t -> bool
      val isMin: t -> bool
      val isNegOne: t -> bool
      val isOne: t -> bool
      val isZero: t -> bool
      val layout: t -> Layout.t
      val make: IntInf.t * IntSize.t -> t
      val max: IntSize.t -> t
      val min: IntSize.t -> t
      val one: IntSize.t -> t
      val quot: t * t -> t
      val rem: t * t -> t
      val size: t -> IntSize.t
      val toChar: t -> char
      val toInt: t -> int
      val toIntInf: t -> IntInf.t
      val toString: t -> string
      val zero: IntSize.t -> t
   end




1.1                  mlton/mlton/atoms/real-x.fun

Index: real-x.fun
===================================================================
functor RealX (S: REAL_X_STRUCTS): REAL_X = 
struct

open S

datatype t = T of {real: string,
		   size: RealSize.t}

local
   fun make f (T r) = f r
in
   val size = make #size
end

fun make (r, s) = T {real = r, size = s}

fun equals (T {real = r, ...}, T {real = r', ...}) = r = r'

fun toString (T {real = r, ...}) = r

val layout = Layout.str o toString

val hash = String.hash o toString

end



1.1                  mlton/mlton/atoms/real-x.sig

Index: real-x.sig
===================================================================
type int = Int.t
type word = Word.t
   
signature REAL_X_STRUCTS = 
   sig
      structure RealSize: REAL_SIZE
   end

signature REAL_X = 
   sig
      include REAL_X_STRUCTS

      (* reals of all RealSize.t sizes. *)
      type t

      val equals: t * t -> bool
      val hash: t -> word
      val layout: t -> Layout.t
      val make: string * RealSize.t -> t
      val size: t -> RealSize.t
      val toString: t -> string
   end



1.1                  mlton/mlton/atoms/word-x.fun

Index: word-x.fun
===================================================================
functor WordX (S: WORD_X_STRUCTS): WORD_X = 
struct

open S

datatype z = datatype WordSize.t
   
(* Words are stored with all zeros for the unused bits. *)
local
   datatype t = T of {size: WordSize.t,
		      word: word}
in
   type t = t
   fun make (w, s) =
      T {size = s,
	 word = Word.andb (w, WordSize.max s)}
   fun dest (T r) = r
end

local
   fun make f = f o dest
in
   val size = make #size
   val word = make #word
end

val toWord = word

fun fromWord8 w = make (Word8.toWord w, W8)

fun equals (w, w') = dest w = dest w'

fun toString w =
   let
      val {word, ...} = dest w
   in
      concat ["0wx", Word.toString word]
   end

val layout = Layout.str o toString

fun fromChar (c: Char.t) =
   make (Word8.toWord (Word8.fromChar c), WordSize.W8)

fun signExtend (w: t): word =
   let
      val {size = s, word = w} = dest w
   in
      case s of
	 W8 => if 0w0 = Word.andb (w, 0wx80)
		  then w
	       else Word.orb (w, 0wxFFFFFF00)
       | W16 => if 0w0 = Word.andb (w, 0wx8000)
		   then w
		else Word.orb (w, 0wxFFFF0000)
       | W32 => w
   end

fun ~>> (w, w') =
   make (Word.~>> (signExtend w, word w'), size w)

fun rol (w, w') =
   let
      val {size = s, word = w} = dest w
      val {word = w', ...} = dest w'
   in
      make (let
	       open Word
	       val s = Word.fromInt (WordSize.size s)
	       val w' = w' mod s
	    in
	       orb (>> (w, s - w'), << (w, w'))
	    end,
	       s)
   end

fun ror (w, w') =
   let
      val {size = s, word = w} = dest w
      val {word = w', ...} = dest w'
   in
      make (let
	       open Word
	       val s = Word.fromInt (WordSize.size s)
	       val w' = w' mod s
	    in
	       orb (>> (w, w'), << (w, s - w'))
	    end,
	       s)
   end

fun resize (w, s) = make (word w, s)

fun resizeX (w, s) = make (signExtend w, s)

fun fromLargeInt (i: IntInf.t, s) = make (Word.fromIntInf i, s)

val toIntInf = Word.toIntInf o word

fun toIntInfX w = Word.toIntInfX (signExtend w)

local
   val make: (word * word -> word) -> t * t -> t =
      fn f => fn (w, w') =>
      let
	 val {size = s, word = w} = dest w
	 val {word = w', ...} = dest w'
      in
	 make (f (w, w'), s)
      end
in
   val op + = make Word.+
   val op - = make Word.-
   val op * = make Word.*
   val << = make Word.<<
   val >> = make Word.>>
   val andb = make Word.andb
   val op div = make Word.div
   val op mod = make Word.mod
   val orb = make Word.orb
   val xorb = make Word.xorb
end

fun notb w = make (Word.notb (word w), size w)

fun isOne w = 0w1 = word w
	 
fun isZero w = 0w0 = word w

fun isAllOnes w = word w = WordSize.allOnes (size w)

fun isMax w = word w = WordSize.max (size w)

fun one s = make (0w1, s)
   
fun zero s = make (0w0, s)

fun allOnes s = make (WordSize.allOnes s, s)

fun max s = make (WordSize.max s, s)

fun toChar w =
   let
      val {word = w, ...} = dest w
   in
      Word8.toChar (Word8.fromWord w)
   end

val toString = Word.toString o word

local
   fun make (f: word * word -> 'a): t * t -> 'a =
      fn (w, w') =>
      let
	 val {size = s, word = w} = dest w
	 val {size = s', word = w'} = dest w'
      in
	 if WordSize.equals (s, s')
	    then f (w, w')
	 else Error.bug "WordX binary failure"
      end
in
   val op < = make (op <)
   val op <= = make (op <=)
   val op > = make (op >)
   val op >= = make (op >=)
end

end



1.1                  mlton/mlton/atoms/word-x.sig

Index: word-x.sig
===================================================================
type int = Int.t
type word = Word.t
   
signature WORD_X_STRUCTS = 
   sig
      structure WordSize: WORD_SIZE
   end

signature WORD_X = 
   sig
      include WORD_X_STRUCTS
	 
      (* Words of all WordSize.t sizes. *)
      type t

      val << : t * t -> t
      val >> : t * t -> t
      val ~>> : t * t -> t
      val + : t * t -> t 
      val - : t * t -> t 
      val * : t * t -> t 
      val > : t * t -> bool 
      val < : t * t -> bool 
      val >= : t * t -> bool 
      val <= : t * t -> bool 
      val andb: t * t -> t 
      val div: t * t -> t
      val equals: t * t -> bool
      val fromChar: char -> t (* returns a word of size 8 *)
      val fromLargeInt: IntInf.t * WordSize.t -> t
      val fromWord8: Word8.t -> t
      val isAllOnes: t -> bool
      val isOne: t -> bool
      val isMax: t -> bool
      val isZero: t -> bool
      val layout: t -> Layout.t
      val make: word * WordSize.t -> t
      val max: WordSize.t -> t
      val mod: t * t -> t
      val notb: t -> t
      val one: WordSize.t -> t
      val orb: t * t -> t
      val resize: t * WordSize.t -> t
      val resizeX: t * WordSize.t -> t
      val rol: t * t -> t
      val ror: t * t -> t
      val size: t -> WordSize.t
      val toChar: t -> char
      val toIntInf: t -> IntInf.t
      val toIntInfX: t -> IntInf.t
      val toString: t -> string
      val toWord: t -> word
      val xorb: t * t -> t
      val zero: WordSize.t -> t
   end




1.27      +3 -3      mlton/mlton/backend/allocate-registers.fun

Index: allocate-registers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/allocate-registers.fun,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- allocate-registers.fun	24 Apr 2003 20:50:44 -0000	1.26
+++ allocate-registers.fun	23 Jun 2003 04:58:56 -0000	1.27
@@ -42,7 +42,7 @@
 local
    open Type
 in
-   val handlerSize = Runtime.labelSize + size word
+   val handlerSize = Runtime.labelSize + size defaultWord
 end
 
 structure Live = Live (open Rssa)
@@ -455,7 +455,7 @@
 	    then
 	       let
 		  val (stack, {offset = handler, ...}) =
-		     Allocation.Stack.get (stack, Type.word)
+		     Allocation.Stack.get (stack, Type.defaultWord)
 		  val (stack, {offset = link, ...}) = 
 		     Allocation.Stack.get (stack, Type.ExnStack)
 	       in
@@ -513,7 +513,7 @@
 		case handlerLinkOffset of
 		   NONE => stackInit
 		 | SOME {handler, link} =>
-		      {offset = handler, ty = Type.word} (* should be label *)
+		      {offset = handler, ty = Type.defaultWord} (* should be label *)
 		      :: {offset = link, ty = Type.ExnStack}
 		      :: stackInit
 	     val a = Allocation.new (stackInit, registersInit)



1.55      +54 -39    mlton/mlton/backend/backend.fun

Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.54
retrieving revision 1.55
diff -u -r1.54 -r1.55
--- backend.fun	20 May 2003 02:18:26 -0000	1.54
+++ backend.fun	23 Jun 2003 04:58:56 -0000	1.55
@@ -16,15 +16,19 @@
 in
    structure Chunk = Chunk
    structure Global = Global
+   structure IntX = IntX
    structure Label = Label
    structure MemChunk = MemChunk
    structure ObjectType = ObjectType
    structure PointerTycon = PointerTycon
    structure ProfileInfo = ProfileInfo
+   structure RealX = RealX
    structure Register = Register
    structure Runtime = Runtime
    structure SourceInfo = SourceInfo
    structure Type = Type
+   structure WordSize = WordSize
+   structure WordX = WordX
 end
 local
    open Runtime
@@ -345,61 +349,67 @@
       fun varOperands xs = Vector.map (xs, varOperand)
       (* Hash tables for uniquifying globals. *)
       local
-	 fun 'a make (ty: Type.t, toString: 'a -> string) =
+	 fun ('a, 'b) make (equals: 'a * 'a -> bool,
+			    info: 'a -> string * Type.t * 'b) =
 	    let
-	       val set: {global: M.Global.t,
+	       val set: {a: 'a,
+			 global: M.Global.t,
 			 hash: word,
-			 string: string} HashSet.t = HashSet.new {hash = #hash}
+			 value: 'b} HashSet.t = HashSet.new {hash = #hash}
 	       fun get (a: 'a): M.Operand.t =
 		  let
-		     val s = toString a
-		     val hash = String.hash s
+		     val (string, ty, value) = info a
+		     val hash = String.hash string
 		  in
 		     M.Operand.Global
 		     (#global
 		      (HashSet.lookupOrInsert
-		       (set, hash, fn {string, ...} => s = string,
-			fn () => {hash = hash,
+		       (set, hash,
+			fn {a = a', ...} => equals (a, a'),
+			fn () => {a = a,
+				  hash = hash,
 				  global = M.Global.new {isRoot = true,
 							 ty = ty},
-				  string = s})))
+				  value =  value})))
 		  end
 	       fun all () =
 		  HashSet.fold
-		  (set, [], fn ({global, string, ...}, ac) =>
-		   (global, string) :: ac)
+		  (set, [], fn ({global, value, ...}, ac) =>
+		   (global, value) :: ac)
 	    in
 	       (all, get)
 	    end
       in
 	 val (allIntInfs, globalIntInf) =
-	    make (Type.intInf, fn i => IntInf.format (i, StringCvt.DEC))
-	 val (allReals, globalReal) = make (Type.real, fn s => s)
-	 val (allStrings, globalString) = make (Type.string, fn s => s)
+	    make (IntInf.equals,
+		  fn i => let
+			     val s = IntInf.toString i
+			  in
+			     (s, Type.intInf, s)
+			  end)
+	 val (allReals, globalReal) =
+	    make (RealX.equals,
+		  fn r => (RealX.toString r,
+			   Type.real (RealX.size r),
+			   r))
+	 val (allStrings, globalString) =
+	    make (String.equals, fn s => (s, Type.word8Vector, s))
 	 fun constOperand (c: Const.t): M.Operand.t =
 	    let
-	       datatype z = datatype Const.Node.t
+	       datatype z = datatype Const.t
 	    in
-	       case Const.node c of
-		  Char n => M.Operand.Char n
-		| Int n => M.Operand.Int n
+	       case c of
+		  Int i => M.Operand.Int i
 		| IntInf i =>
 		     (case Const.SmallIntInf.toWord i of
 			 NONE => globalIntInf i
 		       | SOME w => M.Operand.SmallIntInf w)
-		| Real f =>
+		| Real r =>
 		     if !Control.Native.native
-			then globalReal f
-		     else M.Operand.Real f
-		| String s => globalString s
-		| Word w =>
-		     let val ty = Const.ty c
-		     in if Const.Type.equals (ty, Const.Type.word)
-			   then M.Operand.Word w
-			else if Const.Type.equals (ty, Const.Type.word8)
-				then M.Operand.Char (Char.chr (Word.toInt w))
-			     else Error.bug "strange word"
-		     end
+			then globalReal r
+		     else M.Operand.Real r
+		| Word w => M.Operand.Word w
+		| Word8Vector v => globalString (Word8.vectorToString v)
 	    end
       end
       fun parallelMove {chunk,
@@ -430,8 +440,8 @@
 				 offset = GCField.offset field,
 				 ty = ty}
       val exnStackOp = runtimeOp (GCField.ExnStack, Type.ExnStack)
-      val stackBottomOp = runtimeOp (GCField.StackBottom, Type.Word)
-      val stackTopOp = runtimeOp (GCField.StackTop, Type.Word)
+      val stackBottomOp = runtimeOp (GCField.StackBottom, Type.defaultWord)
+      val stackTopOp = runtimeOp (GCField.StackTop, Type.defaultWord)
       fun translateOperand (oper: R.Operand.t): M.Operand.t =
 	 let
 	    datatype z = datatype R.Operand.t
@@ -453,8 +463,9 @@
 				    offset = offset,
 				    ty = ty}
 	     | PointerTycon pt =>
-		  M.Operand.Word (Runtime.typeIndexToHeader
-				  (PointerTycon.index pt))
+		  M.Operand.Word
+		  (WordX.make (Runtime.typeIndexToHeader (PointerTycon.index pt),
+			       WordSize.default))
 	     | Runtime f =>
 		  runtimeOp (f, R.Operand.ty oper)
 	     | SmallIntInf w => M.Operand.SmallIntInf w
@@ -513,20 +524,22 @@
 		  (* ExnStack = stackTop + (offset + WORD_SIZE) - StackBottom; *)
 		  let
 		     val tmp =
-			M.Operand.Register (Register.new (Type.word, NONE))
+			M.Operand.Register
+			(Register.new (Type.defaultWord, NONE))
 		  in
 		     Vector.new2
 		     (M.Statement.PrimApp
 		      {args = (Vector.new2
 			       (stackTopOp,
 				M.Operand.Int
-				(handlerOffset () + Runtime.wordSize))),
+				(IntX.defaultInt
+				 (handlerOffset () + Runtime.wordSize)))),
 		       dst = SOME tmp,
-		       prim = Prim.word32Add},
+		       prim = Prim.wordAdd WordSize.default},
 		      M.Statement.PrimApp
 		      {args = Vector.new2 (tmp, stackBottomOp),
 		       dst = SOME exnStackOp,
-		       prim = Prim.word32Sub})
+		       prim = Prim.wordSub WordSize.default})
 		  end
 	     | SetExnStackSlot =>
 		  (* ExnStack = *(uint* )(stackTop + offset);	*)
@@ -822,9 +835,11 @@
 			let
 			   fun doit ({cases: ('a * Label.t) vector,
 				      default: Label.t option,
+				      size: 'b,
 				      test: R.Operand.t},
 				     make: {cases: ('a * Label.t) vector,
 					    default: Label.t option,
+					    size: 'b,
 					    test: M.Operand.t} -> M.Switch.t) =
 			      simple
 			      (case (Vector.length cases, default) of
@@ -836,11 +851,11 @@
 				     M.Transfer.Switch
 				     (make {cases = cases,
 					    default = default,
+					    size = size,
 					    test = translateOperand test}))
 			in
 			   case switch of
-			      R.Switch.Char z => doit (z, M.Switch.Char)
-			    | R.Switch.EnumPointers {enum, pointers, test} =>
+			      R.Switch.EnumPointers {enum, pointers, test} =>
 			         simple
 			         (M.Transfer.Switch
 				  (M.Switch.EnumPointers



1.9       +3 -0      mlton/mlton/backend/backend.sig

Index: backend.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- backend.sig	12 Dec 2002 01:14:21 -0000	1.8
+++ backend.sig	23 Jun 2003 04:58:56 -0000	1.9
@@ -12,9 +12,12 @@
    sig
       structure Machine: MACHINE
       structure Ssa: SSA
+      sharing Machine.IntX = Ssa.IntX
       sharing Machine.Label = Ssa.Label
       sharing Machine.Prim = Ssa.Prim
+      sharing Machine.RealX = Ssa.RealX
       sharing Machine.SourceInfo = Ssa.SourceInfo
+      sharing Machine.WordX = Ssa.WordX
 
       val funcToLabel: Ssa.Func.t -> Machine.Label.t
    end



1.12      +1 -1      mlton/mlton/backend/c-function.fun

Index: c-function.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- c-function.fun	25 Mar 2003 04:31:24 -0000	1.11
+++ c-function.fun	23 Jun 2003 04:58:56 -0000	1.12
@@ -111,7 +111,7 @@
 end
 
 val size = vanilla {name = "MLton_size",
-		    returnTy = SOME Type.int}
+		    returnTy = SOME Type.defaultInt}
 
 val returnToC =
    T {bytesNeeded = NONE,



1.16      +2 -3      mlton/mlton/backend/chunkify.fun

Index: chunkify.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/chunkify.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- chunkify.fun	2 Apr 2003 02:55:56 -0000	1.15
+++ chunkify.fun	23 Jun 2003 04:58:56 -0000	1.16
@@ -44,12 +44,11 @@
 	    Switch s =>
 	       let
 		  datatype z = datatype Switch.t
-		  fun simple {cases, default, test} =
+		  fun simple {cases, default, size, test} =
 		     1 + Vector.length cases
 	       in
 		  case s of
-		     Char z => simple z
-		   | EnumPointers _ => 2
+		     EnumPointers _ => 2
 		   | Int z => simple z
 		   | Pointer {cases, ...} => 1 + Vector.length cases
 		   | Word z => simple z



1.38      +27 -18    mlton/mlton/backend/limit-check.fun

Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- limit-check.fun	25 Mar 2003 04:31:24 -0000	1.37
+++ limit-check.fun	23 Jun 2003 04:58:56 -0000	1.38
@@ -167,7 +167,9 @@
 				       case z of
 					  Operand.EnsuresBytesFree =>
 					     Operand.word
-					     (ensureBytesFree (valOf return))
+					     (WordX.make
+					      (ensureBytesFree (valOf return),
+					       WordSize.default))
 					| _ => z)),
 			      func = func,
 			      return = return}
@@ -280,7 +282,7 @@
 	     fun stackCheck (maybeFirst, z): Label.t =
 		let
 		   val (statements, transfer) =
-		      primApp (Prim.word32Gt,
+		      primApp (Prim.wordGt WordSize.default,
 			       Operand.Runtime StackTop,
 			       Operand.Runtime StackLimit,
 			       z)
@@ -289,7 +291,9 @@
 		end
 	     fun maybeStack (): Label.t =
 		if stack
-		   then stackCheck (true, insert (Operand.word 0w0))
+		   then stackCheck (true,
+				    insert (Operand.word
+					    (WordX.zero WordSize.default)))
 		else
 		   (* No limit check, just keep the block around. *)
 		   (List.push (newBlocks,
@@ -324,12 +328,12 @@
 		      Statement.PrimApp
 		      {args = Vector.new2 (Operand.Runtime LimitPlusSlop,
 					   Operand.Runtime Frontier),
-		       dst = SOME (res, Type.word),
-		       prim = Prim.word32Sub}
+		       dst = SOME (res, Type.defaultWord),
+		       prim = Prim.wordSub WordSize.default}
 		   val (statements, transfer) =
-		      primApp (Prim.word32Gt,
+		      primApp (Prim.wordGt WordSize.default,
 			       amount,
-			       Operand.Var {var = res, ty = Type.word},
+			       Operand.Var {var = res, ty = Type.defaultWord},
 			       z)
 		   val statements = Vector.concat [Vector.new1 s, statements]
 		in
@@ -338,7 +342,7 @@
 			 frontierCheck (isFirst,
 					Prim.eq,
 					Operand.Runtime Limit,
-					Operand.int 0,
+					Operand.int (IntX.zero IntSize.default),
 					{collect = collect,
 					 dontCollect = newBlock (false,
 								 statements,
@@ -355,11 +359,14 @@
 	     fun heapCheckNonZero (bytes: Word.t): Label.t =
 		if bytes <= Word.fromInt Runtime.limitSlop
 		   then frontierCheck (true,
-				       Prim.word32Gt,
+				       Prim.wordGt WordSize.default,
 				       Operand.Runtime Frontier,
 				       Operand.Runtime Limit,
-				       insert (Operand.word 0w0))
-		else heapCheck (true, Operand.word bytes)
+				       insert (Operand.word
+					       (WordX.zero WordSize.default)))
+		else heapCheck (true,
+				Operand.word (WordX.make (bytes,
+							  WordSize.default)))
 	     fun smallAllocation _ =
 		let
 		   val w = blockCheckAmount {blockIndex = i}
@@ -376,10 +383,10 @@
 		in
 		   case bytesNeeded of
 		      Operand.Const c =>
-			 (case Const.node c of
-			     Const.Node.Word w =>
+			 (case c of
+			     Const.Word w =>
 				heapCheckNonZero
-				(MLton.Word.addCheck (w, extraBytes)
+				(MLton.Word.addCheck (WordX.toWord w, extraBytes)
 				 handle Overflow => Runtime.allocTooLarge)
 			   | _ => Error.bug "strange primitive bytes needed")
 		    | _ =>
@@ -390,16 +397,18 @@
 			    (true,
 			     Vector.new0 (),
 			     Transfer.Arith
-			     {args = Vector.new2 (Operand.word extraBytes,
+			     {args = Vector.new2 (Operand.word
+						  (WordX.make (extraBytes,
+							       WordSize.default)),
 						  bytesNeeded),
 			      dst = bytes,
 			      overflow = allocTooLarge (),
-			      prim = Prim.word32AddCheck,
+			      prim = Prim.wordAddCheck WordSize.default,
 			      success = (heapCheck
 					 (false, 
 					  Operand.Var {var = bytes,
-						       ty = Type.word})),
-			      ty = Type.word})
+						       ty = Type.defaultWord})),
+			      ty = Type.defaultWord})
 			 end
 		end
 	     val bs = {big = bigAllocation,



1.9       +69 -63    mlton/mlton/backend/machine-atoms.fun

Index: machine-atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- machine-atoms.fun	18 Apr 2003 22:44:59 -0000	1.8
+++ machine-atoms.fun	23 Jun 2003 04:58:56 -0000	1.9
@@ -9,6 +9,8 @@
 struct
 
 open S
+datatype z = datatype IntSize.t
+datatype z = datatype WordSize.t
 
 structure ProfileLabel = ProfileLabel ()
 
@@ -44,7 +46,7 @@
        * {STACK,STRING,THREAD,WEAK_GONE,WORD_VECTOR}_TYPE_INDEX.
        *)
       val stack = new ()
-      val string = new ()
+      val word8Vector = new ()
       val thread = new ()
       val weakGone = new ()
       val wordVector = new ()
@@ -53,17 +55,16 @@
 structure TypeAndMemChunk =
    struct
       datatype ty =
-	 Char
-       | CPointer
+	 CPointer
        | EnumPointers of {enum: int vector,
 			  pointers: PointerTycon.t vector}
        | ExnStack
-       | Int
+       | Int of IntSize.t
        | IntInf
        | Label of Label.t
        | MemChunk of memChunk
-       | Real
-       | Word
+       | Real of RealSize.t
+       | Word of WordSize.t
       and memChunk =
 	 T of {components: {mutable: bool,
 			    offset: int,
@@ -75,8 +76,7 @@
 	    open Layout
 	 in
 	    case t of
-	       Char => str "char"
-	     | CPointer => str "cpointer"
+	       CPointer => str "cpointer"
 	     | EnumPointers {enum, pointers} => 
 		  if 0 = Vector.length enum
 		     andalso 1 = Vector.length pointers
@@ -86,12 +86,12 @@
 		     (Vector.concat [Vector.map (enum, Int.layout),
 				     Vector.map (pointers, PointerTycon.layout)])
 	     | ExnStack => str "exnStack"
-	     | Int => str "int"
+	     | Int s => str (concat ["Int", IntSize.toString s])
 	     | IntInf => str "intInf"
 	     | Label l => seq [str "Label ", Label.layout l]
 	     | MemChunk m => seq [str "MemChunk ", layoutMemChunk m]
-	     | Real => str "real"
-	     | Word => str "word"
+	     | Real s => str (concat ["Real", RealSize.toString s])
+	     | Word s => str (concat ["Word", WordSize.toString s])
 	 end
       and layoutMemChunk (T {components, size}) =
 	 Layout.record
@@ -105,20 +105,19 @@
 
       fun equalsTy (t, t'): bool =
 	 case (t, t') of
-	    (Char, Char) => true
-	  | (CPointer, CPointer) => true
+	    (CPointer, CPointer) => true
 	  | (EnumPointers {enum = e, pointers = p},
 	     EnumPointers {enum = e', pointers = p'}) =>
 	       e = e'
 	       andalso (MLton.eq (p, p')
 			orelse Vector.equals (p, p', PointerTycon.equals))
           | (ExnStack, ExnStack) => true
-	  | (Int, Int) => true
+	  | (Int s, Int s') => IntSize.equals (s, s')
 	  | (IntInf, IntInf) => true
 	  | (Label l, Label l') => Label.equals (l, l')
 	  | (MemChunk m, MemChunk m') => equalsMemChunk (m, m')
-	  | (Real, Real) => true
-	  | (Word, Word) => true
+	  | (Real s, Real s') => RealSize.equals (s, s')
+	  | (Word s, Word s') => WordSize.equals (s, s')
 	  | _ => false
       and equalsMemChunk (T {components = cs, size = s},
 			  T {components = cs', size = s'}) =
@@ -134,34 +133,32 @@
 	 val double: int = 8
       in
 	 val size =
-	    fn Char => byte
-	     | CPointer => word
+	    fn CPointer => word
 	     | EnumPointers _ => word
 	     | ExnStack => word
-	     | Int => word
+	     | Int s => IntSize.bytes s
 	     | IntInf => word
 	     | Label _ => word
 	     | MemChunk _ => word
-	     | Real => double
-	     | Word => word
+	     | Real s => RealSize.bytes s
+	     | Word s => WordSize.bytes s
       end
 
       fun isOkTy (t: ty): bool =
 	 case t of
-	    Char => true
-	  | CPointer => true
+	    CPointer => true
 	  | EnumPointers {enum, pointers} =>
 	       Vector.isSorted (enum, op <=)
 	       andalso Vector.isSorted (pointers, PointerTycon.<=)
 	       andalso (0 = Vector.length pointers
 			orelse Vector.forall (enum, Int.isOdd))
 	  | ExnStack => true
-	  | Int => true
+	  | Int _ => true
 	  | IntInf => true
 	  | Label _ => true
 	  | MemChunk m => isOkMemChunk m
-	  | Real => true
-	  | Word => true
+	  | Real _ => true
+	  | Word _ => true
       and isOkMemChunk (T {components, size = s}) =
 	 let
 	    exception No
@@ -223,8 +220,9 @@
 
       val bool = EnumPointers {enum = Vector.new2 (0, 1),
 			       pointers = Vector.new0 ()}
-      val char = Char
       val cpointer = CPointer
+      val defaultInt = Int IntSize.default
+      val defaultWord = Word WordSize.default
       val exnStack = ExnStack
       val int = Int
       val intInf = IntInf
@@ -237,9 +235,9 @@
 		       pointers = Vector.new1 pt}
 
       val stack = pointer PointerTycon.stack
-      val string = pointer PointerTycon.string
       val thread = pointer PointerTycon.thread
       val wordVector = pointer PointerTycon.wordVector
+      val word8Vector = pointer PointerTycon.word8Vector
 
       fun containsPointer (t, pt): bool =
 	 case t of
@@ -252,6 +250,10 @@
 	  | IntInf => true
 	  | _ => false
 
+      val isReal =
+	 fn Real _ => true
+	  | _ => false
+
       fun split ({enum, pointers}) =
 	 {enum = {enum = enum, pointers = Vector.new0 ()},
 	  pointers = {enum = Vector.new0 (), pointers = pointers}}
@@ -262,26 +264,24 @@
 	 val fromRuntime: Runtime.Type.t -> t =
 	    fn t =>
 	    case R.dest t of
-	       R.Char => char
-	     | R.Double => real
-	     | R.Int => int
+	       R.Int s => int s
 	     | R.Pointer => cpointer
-	     | Uint => word
+	     | R.Real s => real s
+	     | R.Word s => word s
 
 	 val toRuntime: t -> Runtime.Type.t =
-	    fn Char => R.char
-	     | CPointer => R.pointer
+	    fn CPointer => R.pointer
 	     | EnumPointers {enum, pointers} =>
 		  if 0 = Vector.length pointers
-		     then R.int
+		     then R.defaultInt
 		  else R.pointer
-	     | ExnStack => R.uint
-	     | Int => R.int
+	     | ExnStack => R.defaultWord
+	     | Int s => R.int s
 	     | IntInf => R.pointer
-	     | Label _ => R.uint
+	     | Label _ => R.defaultWord
 	     | MemChunk _ => R.pointer
-	     | Real => R.double
-	     | Word => R.word
+	     | Real s => R.real s
+	     | Word s => R.word s
 
 	 val name = R.name o toRuntime
 
@@ -361,10 +361,10 @@
 	 
       val stack = Stack
 
-      val string =
+      val word8Vector =
 	 Array (MemChunk.T {components = Vector.new1 {mutable = false,
 						      offset = 0,
-						      ty = Type.char},
+						      ty = Type.word W8},
 			    size = 1})
 
       val thread =
@@ -372,10 +372,10 @@
 	    val components =
 	       Vector.new3 ({mutable = true,
 			     offset = 0,
-			     ty = Type.word},
+			     ty = Type.defaultWord},
 			    {mutable = true,
 			     offset = wordSize,
-			     ty = Type.word},
+			     ty = Type.defaultWord},
 			    {mutable = true,
 			     offset = 2 * wordSize,
 			     ty = Type.stack})
@@ -389,7 +389,7 @@
       val wordVector =
 	 Array (MemChunk.T {components = Vector.new1 {mutable = false,
 						      offset = 0,
-						      ty = Type.word},
+						      ty = Type.defaultWord},
 			    size = wordSize})
 		
       val isOk =
@@ -425,14 +425,14 @@
       val basic =
 	 Vector.fromList
 	 [(PointerTycon.stack, stack),
-	  (PointerTycon.string, string),
 	  (PointerTycon.thread, thread),
 	  (PointerTycon.weakGone, WeakGone),
-	  (PointerTycon.wordVector, wordVector)]
+	  (PointerTycon.wordVector, wordVector),
+	  (PointerTycon.word8Vector, word8Vector)]
    end
 
 fun castIsOk {from: Type.t,
-	      fromInt: int option,
+	      fromInt: IntX.t option,
 	      to: Type.t,
 	      tyconTy: PointerTycon.t -> ObjectType.t}: bool =
    let
@@ -442,7 +442,7 @@
 	 (Vector.isSubsequence (e, e', op =)
 	  andalso Vector.isSubsequence (p, p', PointerTycon.equals))
 	 orelse
-	 (* Unsafe Vector_fromArray. *)
+	 (* Unsafe Array_toVector. *)
 	 (0 = Vector.length e
 	  andalso 0 = Vector.length e'
 	  andalso 1 = Vector.length p
@@ -483,37 +483,43 @@
       datatype z = datatype Type.t
    in
       not (Type.equals (from, to))
+      andalso Type.size from = Type.size to
       andalso
       case from of
 	 CPointer =>
 	    (case to of
-		Int => true
-	      | Word => true
+		Int _ => true
+	      | Word _ => true
 	      | _ => false)
        | EnumPointers (ep as {enum, pointers}) =>
 	    (case to of
 		EnumPointers ep' => castEnumIsOk (ep, ep')
 	      | IntInf =>
-		   (* IntInf_fromVector *)
+		   (* WordVector_toIntInf *)
 		   0 = Vector.length enum
 		   andalso 1 = Vector.length pointers
 		   andalso PointerTycon.equals (PointerTycon.wordVector,
 						Vector.sub (pointers, 0))
-	      | Word => true (* necessary for card marking *)
+	      | Word _ => true (* necessary for card marking *)
 	      | _ => false)
-       | Int =>
+       | Int _ =>
 	    (case to of
 		EnumPointers {enum, ...} =>
 		   (case fromInt of
 		       NONE => false
-		     | SOME int => Vector.exists (enum, fn i => i = int))
+		     | SOME int =>
+			  Vector.exists (enum, fn i =>
+					 IntInf.equals (IntX.toIntInf int,
+							IntInf.fromInt i)))
 		   orelse
 		   (* MLton_bogus *)
 		   (0 = Vector.length enum
 		    andalso (case fromInt of
-				SOME 1 => true
-			      | _ => false))
-	      | Word => true (* Word32_fromInt *)
+				NONE => false
+			      | SOME i =>
+				   IntInf.equals (IntX.toIntInf i,
+						  IntInf.fromInt 1)))
+	      | Word _ => true
 	      | _ => false)
        | IntInf =>
 	    (case to of
@@ -523,16 +529,16 @@
 		   andalso 1 = Vector.length pointers
 		   andalso PointerTycon.equals (PointerTycon.wordVector,
 						Vector.sub (pointers, 0))
-	      | Word => true  (* IntInf_toWord *)
+	      | Word s =>  true  (* IntInf_toWord *)
 	      | _ => false)
        | MemChunk _ =>
 	    (case to of
-		Word => true (* needed for card marking of arrays *)
+		Word _ => true (* needed for card marking of arrays *)
 	      | _ => false)
-       | Word =>
+       | Word _ =>
 	    (case to of
-		Int => true (* Word32_toIntX *)
-	      | IntInf => true (* IntInf_fromWord *)
+		Int _ => true (* Word32_toIntX *)
+	      | IntInf => true (* Word_toIntInf *)
 	      | _ => false)
        | _ => false
    end



1.11      +23 -13    mlton/mlton/backend/machine-atoms.sig

Index: machine-atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- machine-atoms.sig	24 Apr 2003 20:50:49 -0000	1.10
+++ machine-atoms.sig	23 Jun 2003 04:58:56 -0000	1.11
@@ -9,10 +9,19 @@
    
 signature MACHINE_ATOMS_STRUCTS =
    sig
+      structure IntSize: INT_SIZE
+      structure IntX: INT_X
       structure Label: HASH_ID
       structure Prim: PRIM
+      structure RealSize: REAL_SIZE
+      structure RealX: REAL_X
       structure Runtime: RUNTIME
       structure SourceInfo: SOURCE_INFO
+      structure WordSize: WORD_SIZE
+      structure WordX: WORD_X
+      sharing IntSize = IntX.IntSize = Prim.IntSize = Runtime.IntSize
+      sharing RealSize = Prim.RealSize = RealX.RealSize = Runtime.RealSize
+      sharing WordSize = Prim.WordSize = Runtime.WordSize = WordX.WordSize
    end
 
 signature MACHINE_ATOMS =
@@ -32,18 +41,17 @@
 	    val new: unit -> t
 	    val plist: t -> PropertyList.t
 	    val stack: t
-	    val string: t
 	    val thread: t
 	    val toString: t -> string
 	    val wordVector: t
+	    val word8Vector: t
 	 end
 
       type memChunk
       structure Type:
 	 sig
 	    datatype t =
-	       Char
-	     | CPointer
+	       CPointer
 	     (* The ints in an enum are in increasing order without dups.
 	      * The pointers are in increasing order (of index in objectTypes
 	      * vector) without dups.
@@ -51,38 +59,40 @@
 	     | EnumPointers of {enum: int vector,
 				pointers: PointerTycon.t vector}
 	     | ExnStack
-	     | Int
+	     | Int of IntSize.t
 	     | IntInf
 	     | Label of Label.t
 	     | MemChunk of memChunk (* An internal pointer. *)
-	     | Real
-	     | Word
+	     | Real of RealSize.t
+	     | Word of WordSize.t
 
 	    val align: t * int -> int       (* align an address *)
 	    val bool: t
-	    val char: t
 	    val containsPointer: t * PointerTycon.t -> bool
 	    val cpointer: t
 	    val dePointer: t -> PointerTycon.t option
+	    val defaultInt: t
+	    val defaultWord: t
 	    val equals: t * t -> bool
 	    val exnStack: t
 	    val fromRuntime: Runtime.Type.t -> t
-	    val int: t
+	    val int: IntSize.t -> t
 	    val intInf: t
 	    val isPointer: t -> bool
+	    val isReal: t -> bool
 	    val label: Label.t -> t
 	    val layout: t -> Layout.t
 	    val name: t -> string (* simple one letter abbreviation *)
 	    val pointer: PointerTycon.t -> t
-	    val real: t
+	    val real: RealSize.t -> t
 	    val size: t -> int
 	    val stack: t
-	    val string: t
 	    val thread: t
 	    val toRuntime: t -> Runtime.Type.t
 	    val toString: t -> string
-	    val word: t
+	    val word: WordSize.t -> t
 	    val wordVector: t
+	    val word8Vector: t
 	 end
 
       structure MemChunk:
@@ -111,15 +121,15 @@
 	    val basic: (PointerTycon.t * t) vector
 	    val isOk: t -> bool
 	    val layout: t -> Layout.t
-	    val string: t
 	    val thread: t
 	    val toRuntime: t -> Runtime.ObjectType.t
 	    val weak: Type.t -> t
 	    val wordVector: t
+	    val word8Vector: t
 	 end
 
       val castIsOk: {from: Type.t,
-		     fromInt: int option,
+		     fromInt: IntX.t option,
 		     to: Type.t,
 		     tyconTy: PointerTycon.t -> ObjectType.t} -> bool
    end



1.49      +57 -38    mlton/mlton/backend/machine.fun

Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -r1.48 -r1.49
--- machine.fun	15 May 2003 14:50:56 -0000	1.48
+++ machine.fun	23 Jun 2003 04:58:56 -0000	1.49
@@ -11,7 +11,17 @@
 
 open S
 
-structure Runtime = Runtime ()
+structure IntSize = IntX.IntSize
+structure RealSize = RealX.RealSize
+structure WordSize = WordX.WordSize
+
+datatype z = datatype IntSize.t
+datatype z = datatype RealSize.t
+datatype z = datatype WordSize.t
+
+structure Runtime = Runtime (structure IntSize = IntSize
+			     structure RealSize = RealSize
+			     structure WordSize = WordSize)
 local
    open Runtime
 in
@@ -19,10 +29,11 @@
    structure GCField = GCField
 end
 
-structure Atoms = MachineAtoms (structure Label = Label
-				structure Prim = Prim
+structure Atoms = MachineAtoms (open S
+				structure IntSize = IntSize
+				structure RealSize = RealSize
 				structure Runtime = Runtime
-				structure SourceInfo = SourceInfo)
+				structure WordSize = WordSize)
 open Atoms
 
 structure ChunkLabel = IdNoAst (val noname = "ChunkLabel")
@@ -174,23 +185,22 @@
 			 index: t,
 			 ty: Type.t}
        | Cast of t * Type.t
-       | Char of char
        | Contents of {oper: t,
 		      ty: Type.t}
        | File
        | Frontier
        | GCState
        | Global of Global.t
-       | Int of int
+       | Int of IntX.t
        | SmallIntInf of SmallIntInf.t
        | Label of Label.t
        | Line
        | Offset of {base: t, offset: int, ty: Type.t}
        | Register of Register.t
-       | Real of string
+       | Real of RealX.t
        | StackOffset of StackOffset.t
        | StackTop
-       | Word of Word.t
+       | Word of WordX.t
     
       val rec isLocation =
 	 fn ArrayOffset _ => true
@@ -217,7 +227,6 @@
 		       constrain ty]
 	     | Cast (z, ty) =>
 		  seq [str "Cast ", tuple [layout z, Type.layout ty]]
-	     | Char c => str (Char.escapeC c)
 	     | Contents {oper, ty} =>
 		  seq [str (concat ["C", Type.name ty, " "]),
 		       paren (layout oper)]
@@ -225,19 +234,19 @@
 	     | Frontier => str "<Frontier>"
 	     | GCState => str "<GCState>"
 	     | Global g => Global.layout g
-	     | Int i => Int.layout i
+	     | Int i => IntX.layout i
 	     | Label l => Label.layout l
 	     | Line => str "<Line>"
 	     | Offset {base, offset, ty} =>
 		  seq [str (concat ["O", Type.name ty, " "]),
 		       tuple [layout base, Int.layout offset],
 		       constrain ty]
-	     | Real s => str s
+	     | Real r => RealX.layout r
 	     | Register r => Register.layout r
 	     | SmallIntInf w => seq [str "SmallIntInf ", paren (Word.layout w)]
 	     | StackOffset so => StackOffset.layout so
 	     | StackTop => str "<StackTop>"
-	     | Word w => seq [str "0x", Word.layout w]
+	     | Word w => WordX.layout w
 	 end
 
     val toString = Layout.toString o layout
@@ -245,22 +254,21 @@
     val ty =
        fn ArrayOffset {ty, ...} => ty
 	| Cast (_, ty) => ty
-	| Char _ => Type.char
 	| Contents {ty, ...} => ty
 	| File => Type.cpointer
-	| Frontier => Type.word
+	| Frontier => Type.defaultWord
 	| GCState => Type.cpointer
 	| Global g => Global.ty g
-	| Int _ => Type.int
+	| Int i => Type.int (IntX.size i)
 	| Label l => Type.label l
-	| Line => Type.int
+	| Line => Type.defaultInt
 	| Offset {ty, ...} => ty
-	| Real _ => Type.real
+	| Real r => Type.real (RealX.size r)
 	| Register r => Register.ty r
 	| SmallIntInf _ => Type.intInf
 	| StackOffset {ty, ...} => ty
-	| StackTop => Type.word
-	| Word _ => Type.word
+	| StackTop => Type.defaultWord
+	| Word w => Type.word (WordX.size w)
 	 
       val rec equals =
 	 fn (ArrayOffset {base = b, index = i, ...},
@@ -268,23 +276,22 @@
 	        equals (b, b') andalso equals (i, i') 
 	   | (Cast (z, t), Cast (z', t')) =>
 		Type.equals (t, t') andalso equals (z, z')
-	   | (Char c, Char c') => c = c'
 	   | (Contents {oper = z, ...}, Contents {oper = z', ...}) =>
 		equals (z, z')
 	   | (File, File) => true
 	   | (GCState, GCState) => true
 	   | (Global g, Global g') => Global.equals (g, g')
-	   | (Int i, Int i') => i = i'
+	   | (Int i, Int i') => IntX.equals (i, i')
 	   | (Label l, Label l') => Label.equals (l, l')
 	   | (Line, Line) => true
 	   | (Offset {base = b, offset = i, ...},
 	      Offset {base = b', offset = i', ...}) =>
 	        equals (b, b') andalso i = i' 
-	   | (Real s, Real s') => s = s'
+	   | (Real r, Real r') => RealX.equals (r, r')
 	   | (Register r, Register r') => Register.equals (r, r')
 	   | (SmallIntInf w, SmallIntInf w') => Word.equals (w, w')
 	   | (StackOffset so, StackOffset so') => StackOffset.equals (so, so')
-	   | (Word w, Word w') => w = w'
+	   | (Word w, Word w') => WordX.equals (w, w')
 	   | _ => false
 
       fun interfere (write: t, read: t): bool =
@@ -732,7 +739,7 @@
 			 maxFrameSize: int,
 			 objectTypes: ObjectType.t vector,
 			 profileInfo: ProfileInfo.t,
-			 reals: (Global.t * string) list,
+			 reals: (Global.t * RealX.t) list,
 			 strings: (Global.t * string) list}
 
       fun clear (T {chunks, profileInfo, ...}) =
@@ -884,16 +891,24 @@
 	    fun tyconTy (pt: PointerTycon.t): ObjectType.t =
 	       Vector.sub (objectTypes, PointerTycon.index pt)
 	    open Layout
-	    fun globals (name, gs, ty) =
+	    fun globals (name, gs, isOk, layout) =
 	       List.foreach
 	       (gs, fn (g, s) =>
-		Err.check
-		(concat ["global ", name],
-		 fn () => Type.equals (ty, Global.ty g),
-		 fn () => seq [String.layout s, str ": ", Type.layout ty]))
-	    val _ = globals ("real", reals, Type.real)
-	    val _ = globals ("intInf", intInfs, Type.intInf)
-	    val _ = globals ("string", strings, Type.string)
+		let
+		   val ty = Global.ty g
+		in
+		   Err.check
+		   (concat ["global ", name],
+		    fn () => isOk ty,
+		    fn () => seq [layout s, str ": ", Type.layout ty])
+		end)
+	    val _ = globals ("real", reals, Type.isReal, RealX.layout)
+	    val _ = globals ("intInf", intInfs,
+			     fn t => Type.equals (t, Type.intInf),
+			     String.layout)
+	    val _ = globals ("string", strings,
+			     fn t => Type.equals (t, Type.word8Vector),
+			     String.layout)
 	    (* Check for no duplicate labels. *)
 	    local
 	       val {get, ...} =
@@ -941,7 +956,6 @@
 					    | _ => NONE),
 				to = t,
 				tyconTy = tyconTy}))
-		      | Char _ => true
 		      | Contents {oper, ...} =>
 			   (checkOperand (oper, alloc)
 			    ; Type.equals (Operand.ty oper,
@@ -1001,7 +1015,7 @@
 		  Err.check ("operand", ok, fn () => Operand.layout x)
 	       end
 	    and arrayOffsetIsOk {base, index, ty} =
-	       Type.equals (Operand.ty index, Type.int)
+	       Type.equals (Operand.ty index, Type.defaultInt)
 	       andalso
 	       case Operand.ty base of
 		  Type.CPointer => true (* needed for card marking *)
@@ -1020,7 +1034,12 @@
 				  Vector.sub (components, 0)
 			    in
 			       offset = 0
-			       andalso Type.equals (ty, ty')
+			       andalso (Type.equals (ty, ty')
+					orelse
+					(* Get a word from a word8 array.*)
+					(Type.equals (ty, Type.word W32)
+					 andalso
+					 Type.equals (ty', Type.word W8)))
 			    end
 		       | _ => false)
 		| _ => false
@@ -1039,12 +1058,12 @@
 		   | Type.EnumPointers {enum, pointers} =>
 			0 = Vector.length enum
 			andalso
-			((* Vector_fromArray header update. *)
+			((* Array_toVector header update. *)
 			 (offset = Runtime.headerOffset
-			  andalso Type.equals (ty, Type.word))
+			  andalso Type.equals (ty, Type.defaultWord))
 			 orelse
 			 (offset = Runtime.arrayLengthOffset
-			  andalso Type.equals (ty, Type.int))
+			  andalso Type.equals (ty, Type.defaultInt))
 			 orelse
 			 Vector.forall
 			 (pointers, fn p =>



1.37      +13 -6     mlton/mlton/backend/machine.sig

Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- machine.sig	15 May 2003 14:50:56 -0000	1.36
+++ machine.sig	23 Jun 2003 04:58:56 -0000	1.37
@@ -10,9 +10,15 @@
    
 signature MACHINE_STRUCTS = 
    sig
+      structure IntX: INT_X
       structure Label: HASH_ID
       structure Prim: PRIM
       structure SourceInfo: SOURCE_INFO
+      structure RealX: REAL_X
+      structure WordX: WORD_X
+      sharing IntX.IntSize = Prim.IntSize
+      sharing RealX.RealSize = Prim.RealSize
+      sharing WordX.WordSize = Prim.WordSize
    end
 
 signature MACHINE = 
@@ -20,9 +26,11 @@
       include MACHINE_ATOMS
 
       structure Switch: SWITCH
+      sharing IntX = Switch.IntX
       sharing Label = Switch.Label
       sharing PointerTycon = Switch.PointerTycon
       sharing Type = Switch.Type
+      sharing WordX = Switch.WordX
       structure CFunction: C_FUNCTION
       sharing CFunction = Runtime.CFunction
       structure ChunkLabel: ID_NO_AST
@@ -63,26 +71,25 @@
 			       index: t,
 			       ty: Type.t}
 	     | Cast of t * Type.t
-	     | Char of char
 	     | Contents of {oper: t,
 			    ty: Type.t}
-	     | File (* expand by codegen into string constant *)
+	     | File (* expanded by codegen into string constant *)
 	     | Frontier
 	     | GCState
 	     | Global of Global.t
-	     | Int of int
+	     | Int of IntX.t
 	     | Label of Label.t
 	     | Line (* expand by codegen into int constant *)
 	     | Offset of {base: t,
 			  offset: int,
 			  ty: Type.t}
-	     | Real of string
+	     | Real of RealX.t
 	     | Register of Register.t
 	     | SmallIntInf of word
 	     | StackOffset of {offset: int,
 			       ty: Type.t}
 	     | StackTop
-	     | Word of Word.t
+	     | Word of WordX.t
 
 	    val equals: t * t -> bool
 	    val interfere: t * t -> bool
@@ -247,7 +254,7 @@
 		     maxFrameSize: int,
 		     objectTypes: ObjectType.t vector,
 		     profileInfo: ProfileInfo.t,
-		     reals: (Global.t * string) list,
+		     reals: (Global.t * RealX.t) list,
 		     strings: (Global.t * string) list}
 
 	    val frameSize: t * FrameInfo.t -> int



1.9       +64 -62    mlton/mlton/backend/mtype.fun

Index: mtype.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/mtype.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- mtype.fun	14 May 2003 02:50:10 -0000	1.8
+++ mtype.fun	23 Jun 2003 04:58:56 -0000	1.9
@@ -10,79 +10,88 @@
 
 open S
 
-datatype dest =
-   Char
- | Double
- | Int
+datatype t =
+   Int of IntSize.t
  | Pointer
- | Uint
+ | Real of RealSize.t
+ | Word of WordSize.t
 
-datatype t = T of {dest: dest}
+datatype dest = datatype t
 
-fun dest (T {dest, ...}) = dest
+fun dest t = t
 
-fun toString t =
-   case dest t of
-      Char => "Char"
-    | Double => "Double"
-    | Int => "Int"
-    | Pointer => "Pointer"
-    | Uint => "Word"
+val isReal =
+   fn Real _ => true
+    | _ => false
+
+fun memo f =
+   let
+      val int = IntSize.memoize (f o Int)
+      val pointer = f Pointer
+      val real = RealSize.memoize (f o Real)
+      val word = WordSize.memoize (f o Word)
+   in
+      fn Int s => int s
+       | Pointer => pointer
+       | Real s => real s
+       | Word s => word s
+   end
+
+val toString =
+   memo
+   (fn t =>
+    case t of
+       Int s => concat ["Int", IntSize.toString s]
+     | Pointer => "Pointer"
+     | Real s => concat ["Real", RealSize.toString s]
+     | Word s => concat ["Word", WordSize.toString s])
 
 val layout = Layout.str o toString
 
-fun equals (t, t') = dest t = dest t'
+fun equals (t, t') = t = t'
 
 val equals =
    Trace.trace2 ("Runtime.Type.equals", layout, layout, Bool.layout) equals
 
-local
-   fun new dest = T {dest = dest}
-in
-   val char = new Char
-   val double = new Double
-   val int = new Int
-   val pointer = new Pointer
-   val uint = new Uint
-end
-
-val all = [char, double, int, pointer, uint]
+val int = IntSize.memoize Int
+val pointer = Pointer
+val real = RealSize.memoize Real
+val word = WordSize.memoize Word
+
+val all =
+   List.map (IntSize.all, int)
+   @ [pointer]
+   @ List.map (RealSize.all, real)
+   @ List.map (WordSize.all, word)
+
+val bool = int IntSize.I32
+
+val defaultInt = int IntSize.default
+
+val defaultReal = real RealSize.default
+   
+val defaultWord = word WordSize.default
 
-fun memo f =
-   let val all = List.revMap (all, fn t => (t, f t))
-   in fn t => #2 (valOf (List.peek (all, fn (t', _) => equals (t, t'))))
-   end
-
-val bool = int
-val label = uint
-val word = uint
+val label = word WordSize.W32
   
 fun isPointer t =
-   case dest t of
+   case t of
       Pointer => true
     | _ => false
-	 
-local
-   val byte: int = 1
-   val word: int = 4
-   val double: int = 8
-in
-   fun size t =
-      case dest t of
-	 Char => byte
-       | Double => double
-       | Int => word
-       | Pointer => word
-       | Uint => word
-end
+
+fun size (t: t): int =
+   case t of
+      Int s => IntSize.bytes s
+    | Pointer => 4
+    | Real s => RealSize.bytes s
+    | Word s => WordSize.bytes s
 
 fun name t =
-   case dest t of
-      Char => "C"
-    | Double => "D"
-    | Int => "I"
+   case t of
+      Int s => concat ["I", IntSize.toString s]
     | Pointer => "P"
-    | Uint => "U"
+    | Real s => concat ["R", RealSize.toString s]
+    | Word s => concat ["W", WordSize.toString s]
 
 local
    fun align a b =
@@ -95,14 +104,7 @@
 in
    val align4 = align 4
    val align8 = align 8
+   val align: t * int -> int = fn (ty, n) => align (size ty) n
 end
-
-fun align (ty: t, n: int): int =
-   case dest ty of
-      Char => n
-    | Double => align8 n
-    | Int => align4 n
-    | Pointer => align4 n
-    | Uint => align4 n
 
 end



1.6       +16 -11    mlton/mlton/backend/mtype.sig

Index: mtype.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/mtype.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- mtype.sig	24 Apr 2003 20:50:51 -0000	1.5
+++ mtype.sig	23 Jun 2003 04:58:56 -0000	1.6
@@ -9,6 +9,9 @@
    
 signature MTYPE_STRUCTS = 
    sig
+      structure IntSize: INT_SIZE
+      structure RealSize: REAL_SIZE
+      structure WordSize: WORD_SIZE
    end
 
 signature MTYPE = 
@@ -18,30 +21,32 @@
       type t
 	 
       datatype dest =
-	 Char
-       | Double
-       | Int
+	 Int of IntSize.t
        | Pointer
-       | Uint
+       | Real of RealSize.t
+       | Word of WordSize.t
 
       val align4: int -> int
       val align8: int -> int
-      val align: t * int -> int       (* align an address *)	 
+      val align: t * int -> int (* align an address *)	 
       val all: t list
       val bool: t (* same as int *)
-      val char: t
+      val defaultInt: t
+      val defaultReal: t
+      val defaultWord: t
       val dest: t -> dest
-      val double: t
       val equals: t * t -> bool
-      val int: t
+      val int: IntSize.t -> t
       val isPointer: t -> bool
+      val isReal: t -> bool
       val label: t (* same as uint *)
       val layout: t -> Layout.t
       val memo: (t -> 'a) -> (t -> 'a)
-      val name: t -> string (* one letter abbreviation: CDIPUV *)
+      (* name: R{32,64} I{8,16,32,64] P W[8,16,32] *)
+      val name: t -> string
       val pointer: t
+      val real: RealSize.t -> t
       val size: t -> int (* bytes *)
       val toString: t -> string
-      val uint: t
-      val word: t (* synonym for uint *)
+      val word: WordSize.t -> t
    end



1.27      +3 -1      mlton/mlton/backend/profile.fun

Index: profile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.fun,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- profile.fun	25 Feb 2003 20:44:22 -0000	1.26
+++ profile.fun	23 Jun 2003 04:58:56 -0000	1.27
@@ -511,7 +511,9 @@
 				       {args = (Vector.new2
 						(Operand.GCState,
 						 Operand.word
-						 (Word.fromInt bytesAllocated))),
+						 (WordX.make
+						  (Word.fromInt bytesAllocated,
+						   WordSize.default)))),
 					func = func,
 					return = SOME newLabel}
 				    val sourceSeq = Push.toSources pushes



1.15      +10 -9     mlton/mlton/backend/representation.fun

Index: representation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- representation.fun	24 Apr 2003 20:50:51 -0000	1.14
+++ representation.fun	23 Jun 2003 04:58:57 -0000	1.15
@@ -16,9 +16,11 @@
 local
    open Rssa
 in
+   structure IntSize = IntSize
    structure ObjectType = ObjectType
    structure PointerTycon = PointerTycon
    structure Runtime = Runtime
+   structure WordSize = WordSize
 end
 structure S = Ssa
 local
@@ -28,6 +30,8 @@
    structure Tycon = Tycon
 end
 
+datatype z = datatype WordSize.t
+   
 structure TyconRep =
    struct
       datatype t =
@@ -313,7 +317,7 @@
 		       if isTagged
 			  then {mutable = false,
 				offset = 0,
-				ty = R.Type.int} :: components
+				ty = R.Type.int IntSize.default} :: components
 		       else components
 		    val components =
 		       Vector.fromArray
@@ -525,22 +529,20 @@
 		       then new ()
 		    else
 		       case S.Type.dest ty of
-			  Char => R.Type.string
-			| Word => R.Type.wordVector
-			| Word8 => R.Type.string
+			  Word W8 => R.Type.word8Vector
+			| Word W32 => R.Type.wordVector
 			| _ => new ()
 		 end
 	      datatype z = datatype S.Type.dest
 	   in
 	      case S.Type.dest t of
 		 Array t => SOME (array {mutable = true, ty = t})
-	       | Char => SOME R.Type.char
 	       | Datatype tycon => convertDatatype tycon
-	       | Int => SOME R.Type.int
+	       | Int s => SOME (R.Type.int s)
 	       | IntInf => SOME R.Type.intInf
 	       | Pointer => SOME R.Type.cpointer
 	       | PreThread => SOME R.Type.thread
-	       | Real => SOME R.Type.real
+	       | Real s => SOME (R.Type.real s)
 	       | Ref t =>
 		    SOME (pointer {fin = fn r => setRefRep (t, r),
 				   isNormal = true,
@@ -572,8 +574,7 @@
 				     SOME (R.Type.pointer pt)
 				  end
 			   else NONE)
-	       | Word => SOME R.Type.word
-	       | Word8 => SOME R.Type.char
+	       | Word s => SOME (R.Type.word s)
 	   end))
       val toRtype =
 	 Trace.trace



1.8       +4 -1      mlton/mlton/backend/representation.sig

Index: representation.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- representation.sig	7 Dec 2002 02:21:52 -0000	1.7
+++ representation.sig	23 Jun 2003 04:58:57 -0000	1.8
@@ -9,8 +9,11 @@
    
 signature REPRESENTATION_STRUCTS = 
    sig
-      structure Ssa: SSA
       structure Rssa: RSSA
+      structure Ssa: SSA
+      sharing Rssa.IntSize = Ssa.IntSize
+      sharing Rssa.RealSize = Ssa.RealSize
+      sharing Rssa.WordSize = Ssa.WordSize
    end
 
 signature REPRESENTATION = 



1.33      +54 -47    mlton/mlton/backend/rssa.fun

Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- rssa.fun	14 May 2003 02:50:10 -0000	1.32
+++ rssa.fun	23 Jun 2003 04:58:57 -0000	1.33
@@ -16,6 +16,8 @@
    structure GCField = GCField
 end
 
+datatype z = datatype WordSize.t
+
 structure Operand =
    struct
       datatype t =
@@ -37,41 +39,34 @@
        | Var of {var: Var.t,
 		 ty: Type.t}
 
-      val char = Const o Const.fromChar
-      val int = Const o Const.fromInt
-      val word = Const o Const.fromWord
-      fun bool b = Cast (int (if b then 1 else 0), Type.bool)
+      val int = Const o Const.int
+      val real = Const o Const.real
+      val word = Const o Const.word
+	 
+      fun bool b = Cast (int (IntX.make (IntInf.fromInt (if b then 1 else 0),
+					 IntSize.default)),
+			 Type.bool)
 	 
       val ty =
 	 fn ArrayOffset {ty, ...} => ty
 	  | Cast (_, ty) => ty
 	  | Const c =>
 	       let
-		  datatype z = datatype Const.Node.t
+		  datatype z = datatype Const.t
 	       in
-		  case Const.node c of
-		     Char _ => Type.char
-		   | Int _ => Type.int
+		  case c of
+		     Int i => Type.int (IntX.size i)
 		   | IntInf _ => Type.intInf
-		   | Real _ => Type.real
-		   | String _ => Type.string
-		   | Word _ =>
-			let
-			   val ty = Const.ty c
-			in
-			   if Const.Type.equals (ty, Const.Type.word)
-			      then Type.word
-			   else if Const.Type.equals (ty, Const.Type.word8)
-				   then Type.char
-				else Error.bug "strange word"
-			end
+		   | Real r => Type.real (RealX.size r)
+		   | Word w => Type.word (WordX.size w)
+		   | Word8Vector _ => Type.word8Vector
 	       end
-	  | EnsuresBytesFree => Type.word
+	  | EnsuresBytesFree => Type.word WordSize.default
 	  | File => Type.cpointer
 	  | GCState => Type.cpointer
-	  | Line => Type.int
+	  | Line => Type.int IntSize.default
 	  | Offset {ty, ...} => ty
-	  | PointerTycon _ => Type.word
+	  | PointerTycon _ => Type.word WordSize.default
 	  | Runtime z => Type.fromRuntime (GCField.ty z)
 	  | SmallIntInf _ => Type.IntInf
 	  | Var {ty, ...} => ty
@@ -139,10 +134,12 @@
 			 small: word -> 'a}): 'a =
 	 case z of
 	    Const c =>
-	       (case Const.node c of
-		   Const.Node.Word w =>
-		      if w <= 0w512 (* pretty arbitrary *)
-			 then small w
+	       (case c of
+		   Const.Word w =>
+		      (* 512 is pretty arbitrary *)
+		      if WordX.<= (w, WordX.fromLargeInt (IntInf.fromInt 512,
+							  WordX.size w))
+			 then small (WordX.toWord w)
 		      else big z
 		 | _ => Error.bug "strange numBytes")
 	  | _ => big z
@@ -328,7 +325,7 @@
       val bug =
 	 CCall {args = (Vector.new1
 			(Operand.Const
-			 (Const.fromString "control shouldn't reach here"))),
+			 (Const.string "control shouldn't reach here"))),
 		func = CFunction.bug,
 		return = NONE}
 
@@ -394,17 +391,22 @@
       fun clear (t: t): unit =
 	 foreachDef (t, Var.clear o #1)
 
-      fun ifBool (test, {falsee, truee}) =
-	 Switch (Switch.Int
-		 {cases = Vector.new2 ((0, falsee), (1, truee)),
-		  default = NONE,
-		  test = test})
-	 
-      fun ifInt (test, {falsee, truee}) =
-	 Switch (Switch.Int
-		 {cases = Vector.new1 (0, falsee),
-		  default = SOME truee,
-		  test = test})
+      local
+	 fun make i = IntX.make (IntInf.fromInt i, IntSize.default)
+      in
+	 fun ifBool (test, {falsee, truee}) =
+	    Switch (Switch.Int
+		    {cases = Vector.new2 ((make 0, falsee), (make 1, truee)),
+		     default = NONE,
+		     size = IntSize.default,
+		     test = test})
+	 fun ifInt (test, {falsee, truee}) =
+	    Switch (Switch.Int
+		    {cases = Vector.new1 (make 0, falsee),
+		     default = SOME truee,
+		     size = IntSize.default,
+		     test = test})
+      end
    end
 
 structure Kind =
@@ -1030,8 +1032,8 @@
 			       {from = Operand.ty z,
 				fromInt = (case z of
 					      Const c =>
-						 (case Const.node c of
-						     Const.Node.Int n => SOME n
+						 (case c of
+						     Const.Int n => SOME n
 						   | _ => NONE)
 					    | _ => NONE),
 				to = ty,
@@ -1054,7 +1056,7 @@
 		  val _ = checkOperand base
 		  val _ = checkOperand index
 	       in
-		  Type.equals (Operand.ty index, Type.int)
+		  Type.equals (Operand.ty index, Type.defaultInt)
 		  andalso
 		  case Operand.ty base of
 		     Type.CPointer => true (* needed for card marking *)
@@ -1072,8 +1074,13 @@
 				  val {offset, ty = ty', ...} =
 				     Vector.sub (components, 0)
 			       in
-				  offset = 0
-				  andalso Type.equals (ty, ty')
+				  0 = offset
+				  andalso (Type.equals (ty, ty')
+					   orelse
+					   (* Get a word from a word8 array.*)
+					   (Type.equals (ty, Type.word W32)
+					    andalso
+					    Type.equals (ty', Type.word W8)))
 			       end
 			  | _ => false)
 		   | _ => false
@@ -1091,12 +1098,12 @@
 		     Type.EnumPointers {enum, pointers} =>
 			0 = Vector.length enum
 			andalso
-			((* Vector_fromArray header update. *)
+			((* Array_toVector header update. *)
 			 (offset = Runtime.headerOffset
-			  andalso Type.equals (ty, Type.word))
+			  andalso Type.equals (ty, Type.defaultWord))
 			 orelse
 			 (offset = Runtime.arrayLengthOffset
-			  andalso Type.equals (ty, Type.int))
+			  andalso Type.equals (ty, Type.defaultInt))
 			 orelse
 			 Vector.forall
 			 (pointers, fn p =>



1.25      +10 -6     mlton/mlton/backend/rssa.sig

Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- rssa.sig	23 Jan 2003 03:34:36 -0000	1.24
+++ rssa.sig	23 Jun 2003 04:58:57 -0000	1.25
@@ -15,12 +15,15 @@
       structure Const: CONST
       structure Func: HASH_ID
       structure Handler: HANDLER
-      sharing Handler.Label = Label
       structure ProfileExp: PROFILE_EXP
-      sharing ProfileExp.SourceInfo = SourceInfo
       structure Return: RETURN
-      sharing Return.Handler = Handler
       structure Var: VAR
+      sharing Handler = Return.Handler
+      sharing IntX = Const.IntX
+      sharing Label = Handler.Label
+      sharing RealX = Const.RealX
+      sharing SourceInfo = ProfileExp.SourceInfo
+      sharing WordX = Const.WordX
    end
 
 signature RSSA = 
@@ -28,9 +31,11 @@
       include RSSA_STRUCTS
 
       structure Switch: SWITCH
+      sharing IntX = Switch.IntX
       sharing Label = Switch.Label
       sharing PointerTycon = Switch.PointerTycon
       sharing Type = Switch.Type
+      sharing WordX = Switch.WordX
       structure CFunction: C_FUNCTION
       sharing CFunction = Runtime.CFunction
      
@@ -65,12 +70,11 @@
 	    val caseBytes: t * {big: t -> 'a,
 				small: word -> 'a} -> 'a
 	    val cast: t * Type.t -> t
-	    val char: char -> t
-	    val int: int -> t
+	    val int: IntX.t -> t
 	    val layout: t -> Layout.t
 	    val foreachVar: t * (Var.t -> unit) -> unit
 	    val ty: t -> Type.t
-	    val word: word -> t
+	    val word: WordX.t -> t
 	 end
       sharing Operand = Switch.Use
     



1.14      +5 -5      mlton/mlton/backend/runtime.fun

Index: runtime.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- runtime.fun	14 May 2003 02:50:10 -0000	1.13
+++ runtime.fun	23 Jun 2003 04:58:57 -0000	1.14
@@ -9,7 +9,7 @@
 
 open S
 
-structure Type = Mtype ()
+structure Type = Mtype (S)
 
 structure CFunction = CFunction (structure Type = Type)
 
@@ -32,15 +32,15 @@
       val equals: t * t -> bool = op =
 	 
       val ty =
-	 fn CanHandle => Type.int
+	 fn CanHandle => Type.defaultInt
 	  | CardMap => Type.pointer
 	  | CurrentThread => Type.pointer
-	  | ExnStack => Type.word
+	  | ExnStack => Type.defaultWord
 	  | Frontier => Type.pointer
 	  | Limit => Type.pointer
 	  | LimitPlusSlop => Type.pointer
-	  | MaxFrameSize => Type.word
-	  | SignalIsPending => Type.int
+	  | MaxFrameSize => Type.defaultWord
+	  | SignalIsPending => Type.defaultInt
 	  | StackBottom => Type.pointer
 	  | StackLimit => Type.pointer
 	  | StackTop => Type.pointer



1.23      +6 -0      mlton/mlton/backend/runtime.sig

Index: runtime.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.sig,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- runtime.sig	14 May 2003 02:50:10 -0000	1.22
+++ runtime.sig	23 Jun 2003 04:58:57 -0000	1.23
@@ -10,6 +10,9 @@
    
 signature RUNTIME_STRUCTS =
    sig
+      structure IntSize: INT_SIZE
+      structure RealSize: REAL_SIZE
+      structure WordSize: WORD_SIZE
    end
 
 signature RUNTIME =
@@ -17,6 +20,9 @@
       include RUNTIME_STRUCTS
 
       structure Type: MTYPE
+      sharing IntSize = Type.IntSize
+      sharing RealSize = Type.RealSize
+      sharing WordSize = Type.WordSize
       structure CFunction: C_FUNCTION
       sharing Type = CFunction.Type
       structure GCField:



1.17      +5 -5      mlton/mlton/backend/signal-check.fun

Index: signal-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/signal-check.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- signal-check.fun	12 Feb 2003 05:11:27 -0000	1.16
+++ signal-check.fun	23 Jun 2003 04:58:57 -0000	1.17
@@ -79,10 +79,9 @@
 	       Vector.new1
 	       (Statement.PrimApp
 		{args = Vector.new2 (Operand.Cast
-				     (Operand.Runtime
-				      Runtime.GCField.Limit,
-				      Type.Word),
-				     Operand.word 0w0),
+				     (Operand.Runtime Runtime.GCField.Limit,
+				      Type.defaultWord),
+				     Operand.word (WordX.zero WordSize.default)),
 		 dst = SOME (res, Type.bool),
 		 prim = Prim.eq})
 	    val compareTransfer =
@@ -106,7 +105,8 @@
 		    transfer =
 		    Transfer.CCall
 		    {args = Vector.new5 (Operand.GCState,
-					 Operand.word 0w0,
+					 Operand.word (WordX.zero
+						       WordSize.default),
 					 Operand.bool false,
 					 Operand.File,
 					 Operand.Line),



1.15      +1 -0      mlton/mlton/backend/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/sources.cm,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- sources.cm	20 Jan 2003 20:38:31 -0000	1.14
+++ sources.cm	23 Jun 2003 04:58:57 -0000	1.15
@@ -17,6 +17,7 @@
 is
 
 ../../lib/mlton/sources.cm
+../ast/sources.cm
 ../atoms/sources.cm
 ../control/sources.cm
 ../ssa/sources.cm



1.40      +135 -128  mlton/mlton/backend/ssa-to-rssa.fun

Index: ssa-to-rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.fun,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- ssa-to-rssa.fun	14 May 2003 02:50:10 -0000	1.39
+++ ssa-to-rssa.fun	23 Jun 2003 04:58:57 -0000	1.40
@@ -23,24 +23,13 @@
    structure GCField = GCField
 end
 
+datatype z = datatype WordSize.t
+
 structure CFunction =
    struct
       open CFunction
 
       local
-	 fun make name = vanilla {name = name,
-				  returnTy = SOME Type.double}
-      in
-	 val cosh = make "cosh"
-	 val sinh = make "sinh"
-	 val tanh = make "tanh"
-	 val pow = make "pow"
-	 val copysign = make "copysign"
-	 val frexp = make "frexp"
-	 val modf = make "modf"
-      end
-
-      local
 	 fun make (name, i) =
 	    CFunction.make {bytesNeeded = SOME i,
 			    ensuresBytesFree = false,
@@ -69,7 +58,7 @@
 
       local
 	 fun make name = vanilla {name = name,
-				  returnTy = SOME Type.int}
+				  returnTy = SOME Type.defaultInt}
       in
 	 val intInfCompare = make "IntInf_compare"
 	 val intInfEqual = make "IntInf_equal"
@@ -200,15 +189,15 @@
       (* varInt is set for variables that are constant integers.  It is used
        * so that we can precompute array numBytes when numElts is known.
        *)
-      val {get = varInt: Var.t -> int option,
+      val {get = varInt: Var.t -> IntX.t option,
 	   set = setVarInt, ...} =
 	 Property.getSetOnce (Var.plist, Property.initConst NONE)
       val _ =
 	 Vector.foreach (globals, fn S.Statement.T {var, exp, ...} =>
 			 case exp of
 			    S.Exp.Const c =>
-			       (case Const.node c of
-				   Const.Node.Int n =>
+			       (case c of
+				   Const.Int n =>
 				      Option.app (var, fn x =>
 						  setVarInt (x, SOME n))
 				 | _ => ())
@@ -296,10 +285,16 @@
 			      val cases =
 				 QuickSort.sortVector
 				 (cases, fn ((i, _), (i', _)) => i <= i')
+			      val cases =
+				 Vector.map (cases, fn (i, l) =>
+					     (IntX.make (IntInf.fromInt i,
+							 IntSize.default),
+					      l))
 			   in
-			      Switch (Switch.Int {test = test,
-						  cases = cases,
-						  default = default})
+			      Switch (Switch.Int {cases = cases,
+						  default = default,
+						  size = IntSize.default,
+						  test = test})
 			   end
 		     end
 	       end
@@ -446,7 +441,7 @@
 			Control.FirstWord =>
 			   ([], Offset {base = test,
 					offset = tagOffset,
-					ty = Type.int})
+					ty = Type.defaultInt})
 		      | Control.Header =>
 			   let
 			      val headerOffset = ~4
@@ -455,14 +450,14 @@
 				 PrimApp {args = (Vector.new2
 						  (Offset {base = test,
 							   offset = headerOffset,
-							   ty = Type.word},
-						   Operand.word 0w1)),
-					  dst = SOME (tagVar, Type.word),
-					  prim = Prim.word32Rshift}
+							   ty = Type.defaultWord},
+						   Operand.word (WordX.one WordSize.default))),
+					  dst = SOME (tagVar, Type.defaultWord),
+					  prim = Prim.wordRshift WordSize.default}
 			   in
-			      ([s], Cast (Var {ty = Type.word,
+			      ([s], Cast (Var {ty = Type.defaultWord,
 					       var = tagVar},
-					  Type.int))
+					  Type.defaultInt))
 			   end
 		      | HeaderIndirect =>
 			   Error.bug "HeaderIndirect unimplemented"
@@ -508,27 +503,23 @@
 	     | TyconRep.Void => ([], prim ())
 	 end
       fun translateCase ({test: Var.t,
-			  cases: Label.t S.Cases.t,
+			  cases: S.Cases.t,
 			  default: Label.t option})
 	 : Statement.t list * Transfer.t =
 	 let
 	    fun id x = x
-	    fun simple (l, make, branch, le) =
+	    fun simple (s, cs, make, branch, le) =
 	       ([],
 		Switch
-		(make {test = varOp test,
-		       cases = (QuickSort.sortVector
-				(Vector.map (l, fn (i, j) => (branch i, j)),
+		(make {cases = (QuickSort.sortVector
+				(Vector.map (cs, fn (i, j) => (branch i, j)),
 				 fn ((i, _), (i', _)) => le (i, i'))),
-		       default = default}))
+		       default = default,
+		       size = s,
+		       test = varOp test}))
 	 in
 	    case cases of
-	       S.Cases.Char cs => simple (cs, Switch.Char, id, Char.<=)
-	     | S.Cases.Int cs => simple (cs, Switch.Int, id, Int.<=)
-	     | S.Cases.Word cs => simple (cs, Switch.Word, id, Word.<=)
-	     | S.Cases.Word8 cs =>
-		  simple (cs, Switch.Char, Word8.toChar, Char.<=)
-	     | S.Cases.Con cases =>
+	       S.Cases.Con cases =>
 		  (case (Vector.length cases, default) of
 		      (0, NONE) => ([], Transfer.bug)
 		    | _ => 
@@ -542,6 +533,8 @@
 					     testRep = tyconRep tycon}
 			    else Error.bug "strange type in case"
 			 end)
+	     | S.Cases.Int (s, cs) => simple (s, cs, Switch.Int, id, IntX.<=)
+	     | S.Cases.Word (s, cs) => simple (s, cs, Switch.Word, id, WordX.<=)
 	 end
       val {get = labelInfo: (Label.t ->
 			     {args: (Var.t * S.Type.t) vector,
@@ -702,18 +695,16 @@
 	    val c = Operand.Const
 	 in
 	    case t of
-	       Type.Char =>
-		  c (Const.fromChar #"\000")
-	     | Type.CPointer => Error.bug "bogus CPointer"
+	       Type.CPointer => Error.bug "bogus CPointer"
 	     | Type.EnumPointers (ep as {enum, ...})  =>
-		  Operand.Cast (Operand.int 1, t)
+		  Operand.Cast (Operand.int (IntX.one IntSize.default), t)
 	     | Type.ExnStack => Error.bug "bogus ExnStack"
-	     | Type.Int => c (Const.fromInt 0)
+	     | Type.Int s => c (Const.int (IntX.zero s))
 	     | Type.IntInf => SmallIntInf 0wx1
 	     | Type.Label _ => Error.bug "bogus Label"
 	     | Type.MemChunk _ => Error.bug "bogus MemChunk"
-	     | Type.Real => c (Const.fromReal "0.0")
-	     | Type.Word => c (Const.fromWord 0w0)
+	     | Type.Real s => c (Const.real (RealX.make ("0.0", s)))
+	     | Type.Word s => c (Const.word (WordX.zero s))
 	 end
       fun translateStatementsTransfer (statements, ss, transfer) =
 	 let
@@ -767,8 +758,12 @@
 			     {dst = valOf var,
 			      size = size + Runtime.normalHeaderSize,
 			      stores = (Vector.concat
-					[Vector.new1 {offset = tagOffset,
-						      value = Operand.int n},
+					[Vector.new1
+					 {offset = tagOffset,
+					  value = (Operand.int
+						   (IntX.make
+						    (IntInf.fromInt n,
+						     IntSize.default)))},
 					 makeStores (ys, offsets)]),
 			      ty = ty,
 			      tycon = tycon})
@@ -782,7 +777,11 @@
 			   (case conRep con of
 			       ConRep.Void => none ()
 			     | ConRep.IntAsTy {int, ty} =>
-				  move (Operand.Cast (Operand.int int, ty))
+				  move (Operand.Cast
+					(Operand.int
+					 (IntX.make (IntInf.fromInt int,
+						     IntSize.default)),
+					 ty))
 			     | ConRep.TagTuple {rep, tag} =>
 				  if !Control.variant = Control.FirstWord
 				     then allocateTagged (tag, args, rep)
@@ -812,7 +811,7 @@
 				 move (Operand.Offset
 				       {base = varOp (a 0),
 					offset = Runtime.arrayLengthOffset,
-					ty = Type.int})
+					ty = Type.defaultInt})
 			      fun arrayOffset (ty: Type.t): Operand.t =
 				 ArrayOffset {base = varOp (a 0),
 					      index = varOp (a 1),
@@ -836,14 +835,18 @@
 				    val res = Var.newNoname ()
 				 in
 				    [Statement.PrimApp
-				     {args = Vector.new2 (canHandle,
-							  Operand.int n),
-				      dst = SOME (res, Type.int),
-				      prim = Prim.intAdd},
+				     {args = (Vector.new2
+					      (canHandle,
+					       (Operand.int
+						(IntX.make
+						 (IntInf.fromInt n,
+						  IntSize.default))))),
+				      dst = SOME (res, Type.defaultInt),
+				      prim = Prim.intAdd IntSize.default},
 				     Statement.Move
 				     {dst = canHandle,
 				      src = Operand.Var {var = res,
-							 ty = Type.int}}]
+							 ty = Type.defaultInt}}]
 				 end
 			      fun ccallGen
 				 {args: Operand.t vector,
@@ -923,21 +926,24 @@
 			   val ss = 
 			      (PrimApp
 			       {args = (Vector.new2
-					(Operand.Cast (addr, Type.Word),
+					(Operand.Cast (addr, Type.defaultWord),
 					 Operand.word
-					 (Word.fromInt
-					  (!Control.cardSizeLog2)))),
-				dst = SOME (index, Type.int),
-				prim = Prim.word32Rshift})
+					 (WordX.make
+					  (Word.fromInt
+					   (!Control.cardSizeLog2),
+					   WordSize.default)))),
+				dst = SOME (index, Type.defaultInt),
+				prim = Prim.wordRshift WordSize.default})
 			      :: (Move
 				  {dst = (Operand.ArrayOffset
 					  {base = (Operand.Runtime
 						   GCField.CardMap),
-					   index = Operand.Var {ty = Type.int,
-								var = index},
-					   ty = Type.char}),
-				   src = Operand.char #"\001"})
-				  :: assign
+					   index = (Operand.Var
+						    {ty = Type.defaultInt,
+						     var = index}),
+					   ty = Type.word W8}),
+				   src = Operand.word (WordX.one W8)})
+			      :: assign
 			      :: ss
 			in
 			  loop (i - 1, prefix ss, t)
@@ -948,8 +954,9 @@
 				   val src = varOp (a 2)
 				   val arrayOp = varOp (a 0)
 				   val temp = Var.newNoname ()
-				   val tempOp = Operand.Var {var = temp,
-							     ty = Type.word}
+				   val tempOp =
+				      Operand.Var {var = temp,
+						   ty = Type.defaultWord}
 				   val addr = Var.newNoname ()
 				   val mc =
 				      case Type.dePointer (Operand.ty arrayOp) of
@@ -965,18 +972,20 @@
 				      (PrimApp
 				       {args = Vector.new2
 					       (Operand.Cast (varOp (a 1),
-							      Type.Word),
+							      Type.defaultWord),
 					        Operand.word
-						(Word.fromInt (Type.size ty))),
-				        dst = SOME (temp, Type.word),
-				        prim = Prim.word32Mul})
+						(WordX.make
+						 (Word.fromInt (Type.size ty),
+						  WordSize.default))),
+				        dst = SOME (temp, Type.defaultWord),
+				        prim = Prim.wordMul WordSize.default})
 				      :: (PrimApp
 					  {args = (Vector.new2
 						   (Operand.Cast (arrayOp,
-								  Type.Word),
+								  Type.defaultWord),
 						    tempOp)),
 					   dst = SOME (addr, Type.MemChunk mc),
-					   prim = Prim.word32Add})
+					   prim = Prim.wordAdd WordSize.default})
 				      :: ss
 				   val assign =
 				      Move {dst = (Operand.Offset
@@ -1006,19 +1015,40 @@
 			      case Prim.name prim of
 				 Array_array =>
 				    array (Operand.Var {var = a 0,
-							ty = Type.int})
+							ty = Type.defaultInt})
 			       | Array_length => arrayOrVectorLength ()
 			       | Array_sub =>
 				    (case targ () of
 					NONE => none ()
 				      | SOME t => sub t)
+			       | Array_toVector =>
+				    let
+				       val array = varOp (a 0)
+				       val vecTy = valOf (toRtype ty)
+				       val pt =
+					  case Type.dePointer vecTy of
+					     NONE => Error.bug "strange Array_toVector"
+					   | SOME pt => pt
+				    in
+				       loop
+				       (i - 1,
+					Move
+					{dst = (Offset
+						{base = array,
+						 offset = Runtime.headerOffset,
+						 ty = Type.defaultWord}),
+					 src = PointerTycon pt}
+					:: Bind {isMutable = false,
+						 oper = (Operand.Cast
+							 (array, vecTy)),
+						 var = valOf var}
+					:: ss,
+					t)
+				    end
 			       | Array_update =>
 				    (case targ () of
 					NONE => none ()
 				      | SOME ty => arrayUpdate ty)
-			       | Byte_byteToChar => cast ()
-			       | Byte_charToByte => cast ()
-			       | C_CS_charArrayToWord8Array => cast ()
 			       | FFI name =>
 				    if Option.isNone (Prim.numArgs prim)
 				       then normal ()
@@ -1036,11 +1066,13 @@
 								Type.toRuntime)})
 			       | GC_collect =>
 				    ccall
-				    {args = Vector.new5 (Operand.GCState,
-							 Operand.int 0,
-							 Operand.bool true,
-							 Operand.File,
-							 Operand.Line),
+				    {args = (Vector.new5
+					     (Operand.GCState,
+					      Operand.int (IntX.zero
+							   IntSize.default),
+					      Operand.bool true,
+					      Operand.File,
+					      Operand.Line)),
 				     func = (CFunction.gc
 					     {maySwitchThreads = false})}
 			       | GC_pack =>
@@ -1057,8 +1089,6 @@
 				    simpleCCall CFunction.intInfCompare
 			       | IntInf_equal =>
 				    simpleCCall CFunction.intInfEqual
-			       | IntInf_fromVector => cast ()
-			       | IntInf_fromWord => cast ()
 			       | IntInf_gcd => simpleCCall CFunction.intInfGcd
 			       | IntInf_lshift =>
 				    simpleCCall CFunction.intInfLshift
@@ -1081,16 +1111,10 @@
 			       | MLton_bug => simpleCCall CFunction.bug
 			       | MLton_eq =>
 				    (case targ () of
-					NONE => move (Operand.int 1)
+					NONE => move (Operand.int
+						      (IntX.defaultInt 1))
 				      | SOME _ => normal ())
 			       | MLton_size => simpleCCall CFunction.size
-			       | Real_Math_cosh => simpleCCall CFunction.cosh
-			       | Real_Math_sinh => simpleCCall CFunction.sinh
-			       | Real_Math_tanh => simpleCCall CFunction.tanh
-			       | Real_Math_pow => simpleCCall CFunction.pow
-			       | Real_copysign => simpleCCall CFunction.copysign
-			       | Real_frexp => simpleCCall CFunction.frexp
-			       | Real_modf => simpleCCall CFunction.modf
 			       | Ref_assign =>
 				    (case targ () of
 					NONE => none ()
@@ -1106,8 +1130,6 @@
 				    allocate
 				    (Vector.new1 (a 0),
 				     refRep (Vector.sub (targs, 0)))
-			       | String_fromWord8Vector => cast ()
-			       | String_toWord8Vector => cast ()
 			       | Thread_atomicBegin =>
 				    (* assert (s->canHandle >= 0);
 				     * s->canHandle++;
@@ -1125,24 +1147,27 @@
 					      Vector.new2
 					      (Statement.PrimApp
 					       {args = Vector.new2 (a, b),
-						dst = SOME (tmp, Type.word),
+						dst = SOME (tmp,
+							    Type.defaultWord),
 						prim = prim},
 					       Statement.Move
 					       {dst = (Operand.Cast
 						       (Operand.Runtime dst,
-							Type.Word)),
+							Type.defaultWord)),
 						src = (Operand.Var
 						       {var = tmp,
-							ty = Type.word})})
+							ty = Type.defaultWord})})
 					   end
 					datatype z = datatype GCField.t
 					val statements =
 					   doit (Limit,
-						 Prim.word32Sub,
+						 Prim.wordSub WordSize.default,
 						 Operand.Runtime LimitPlusSlop,
 						 Operand.word
-						 (Word.fromInt
-						  Runtime.limitSlop))
+						 (WordX.make
+						  (Word.fromInt
+						   Runtime.limitSlop,
+						   WordSize.default)))
 					val l' =
 					   newBlock
 					   {args = Vector.new0 (),
@@ -1174,8 +1199,10 @@
 					   (Statement.Move
 					    {dst = (Operand.Cast
 						    (Operand.Runtime Limit,
-						     Type.Word)),
-					     src = Operand.word 0w0})
+						     Type.defaultWord)),
+					     src =
+					     Operand.word
+					     (WordX.zero WordSize.default)})
 					val l'' =
 					   newBlock
 					   {args = Vector.new0 (),
@@ -1217,30 +1244,6 @@
 						   (varOp (a 0),
 						    Operand.EnsuresBytesFree)),
 					   func = CFunction.threadSwitchTo}
-			       | Vector_fromArray =>
-				    let
-				       val array = varOp (a 0)
-				       val vecTy = valOf (toRtype ty)
-				       val pt =
-					  case Type.dePointer vecTy of
-					     NONE => Error.bug "strange Vector_fromArray"
-					   | SOME pt => pt
-				    in
-				       loop
-				       (i - 1,
-					Move
-					{dst = (Offset
-						{base = array,
-						 offset = Runtime.headerOffset,
-						 ty = Type.word}),
-					 src = PointerTycon pt}
-					:: Bind {isMutable = false,
-						 oper = (Operand.Cast
-							 (array, vecTy)),
-						 var = valOf var}
-					:: ss,
-					t)
-				    end
 			       | Vector_length => arrayOrVectorLength ()
 			       | Vector_sub =>
 				    (case targ () of
@@ -1272,8 +1275,12 @@
 					       func = CFunction.weakNew}
 				     end,
 				     none)
-			       | Word32_toIntX => cast ()
-			       | Word32_fromInt => cast ()
+			       | Word_toIntInf => cast ()
+			       | WordVector_toIntInf => cast ()
+			       | Word8Array_subWord => sub Type.defaultWord
+			       | Word8Array_updateWord =>
+				    arrayUpdate Type.defaultWord
+			       | Word8Vector_subWord => sub Type.defaultWord
 			       | World_save =>
 				    ccall {args = (Vector.new2
 						   (Operand.GCState,



1.3       +33 -42    mlton/mlton/backend/switch.fun

Index: switch.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/switch.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- switch.fun	10 Dec 2002 21:45:49 -0000	1.2
+++ switch.fun	23 Jun 2003 04:58:57 -0000	1.3
@@ -41,14 +41,12 @@
    andalso not (isRedundant {cases = cases, equals = equals})
 
 datatype t =
-   Char of {cases: (char * Label.t) vector,
-	    default: Label.t option,
-	    test: Use.t}
-  | EnumPointers of {enum: Label.t,
+   EnumPointers of {enum: Label.t,
 		     pointers: Label.t,
 		     test: Use.t}
-  | Int of {cases: (int * Label.t) vector,
+  | Int of {cases: (IntX.t * Label.t) vector,
 	    default: Label.t option,
+	    size: IntSize.t,
 	    test: Use.t}
   | Pointer of {cases: {dst: Label.t,
 			tag: int,
@@ -56,14 +54,15 @@
 		default: Label.t option,
 		tag: Use.t,
 		test: Use.t} (* of type int*)
-  | Word of {cases: (word * Label.t) vector,
+  | Word of {cases: (WordX.t * Label.t) vector,
 	     default: Label.t option,
+	     size: WordSize.t,
 	     test: Use.t}
 
 fun layout s =
    let
       open Layout
-      fun simple ({cases, default, test}, name, lay) =
+      fun simple ({cases, default, size, test}, name, lay) =
 	 seq [str (concat ["switch", name, " "]),
 	      record [("test", Use.layout test),
 		      ("default", Option.layout Label.layout default),
@@ -73,13 +72,12 @@
 		       cases)]]
    in
       case s of
-	 Char z => simple (z, "Char", Char.layout)
-       | EnumPointers {enum, pointers, test} =>
+	 EnumPointers {enum, pointers, test} =>
 	    seq [str "SwitchEP ",
 		 record [("test", Use.layout test),
 			 ("enum", Label.layout enum),
 			 ("pointers", Label.layout pointers)]]
-       | Int z => simple (z, "Int", Int.layout)
+       | Int z => simple (z, "Int", IntX.layout)
        | Pointer {cases, default, tag, test} =>
 	    seq [str "SwitchPointer ",
 		 record [("test", Use.layout test),
@@ -92,59 +90,52 @@
 				   ("tag", Int.layout tag),
 				   ("tycon", PointerTycon.layout tycon)])
 			  cases)]]
-       | Word z => simple (z, "Word", Word.layout)
+       | Word z => simple (z, "Word", WordX.layout)
    end
 
 val allChars = Vector.tabulate (Char.numChars, Char.fromInt)
 
 fun isOk (s, {checkUse, labelIsOk}): bool =
    case s of
-      Char {cases, default, test}  =>
-	 (checkUse test
-	  ; (Type.equals (Use.ty test, Type.char)
-	     andalso (case default of
-			 NONE => true
-		       | SOME l => labelIsOk l)
-	     andalso Vector.forall (cases, labelIsOk o #2)
-	     andalso Vector.isSorted (cases, fn ((c, _), (c', _)) => c <= c')
-	     andalso exhaustiveAndIrredundant {all = allChars,
-					       cases = Vector.map (cases, #1),
-					       default = default,
-					       equals = op =}))
-    | EnumPointers {enum, pointers, test, ...} =>
+      EnumPointers {enum, pointers, test, ...} =>
 	 (checkUse test
 	  ; (labelIsOk enum
 	     andalso labelIsOk pointers
 	     andalso (case Use.ty test of
 			 Type.EnumPointers _ => true
 		       | _ => false)))
-    | Int {cases, default, test} =>
+    | Int {cases, default, size, test} =>
 	 (checkUse test
 	  ; ((case default of
 		 NONE => true
 	       | SOME l => labelIsOk l)
 	     andalso Vector.forall (cases, labelIsOk o #2)
-	     andalso Vector.isSorted (cases, fn ((i, _), (i', _)) => i <= i')
+	     andalso Vector.isSorted (cases, fn ((i, _), (i', _)) =>
+				      IntX.<= (i, i'))
 	     andalso
 	     (case Use.ty test of
-		 Type.Int =>
-		    Option.isSome default
-		    andalso not (isRedundant
-				 {cases = cases,
-				  equals = fn ((i, _), (i', _)) => i = i'})
-	       | Type.EnumPointers {enum, pointers} =>
+		 Type.EnumPointers {enum, pointers} =>
 		    0 = Vector.length pointers
 		    andalso
 		    exhaustiveAndIrredundant
-		    {all = enum,
+		    {all = Vector.map (enum, fn i =>
+				       IntX.make (IntInf.fromInt i, size)),
 		     cases = Vector.map (cases, #1),
 		     default = default,
-		     equals = op =}
+		     equals = IntX.equals}
+	       | Type.Int s =>
+		    IntSize.equals (size, s)
+		    andalso Option.isSome default
+		    andalso not (isRedundant
+				 {cases = cases,
+				  equals = fn ((i, _), (i', _)) =>
+				  IntX.equals (i, i')})
+
 	       | _ => false)))
     | Pointer {cases, default, tag, test} =>
 	  (checkUse tag
 	   ; checkUse test
-	   ; (Type.equals (Use.ty tag, Type.int)
+	   ; (Type.equals (Use.ty tag, Type.defaultInt)
 	      andalso (case default of
 			  NONE => true
 			| SOME l => labelIsOk l)
@@ -163,22 +154,23 @@
 					      default = default,
 					      equals = PointerTycon.equals}
 	       | _ => false))
-    | Word {cases, default, test} =>
+    | Word {cases, default, size, test} =>
 	 (checkUse test
-	  ; (Type.equals (Use.ty test, Type.word)
+	  ; (Type.equals (Use.ty test, Type.word size)
 	     andalso (case default of
 			 NONE => false
 		       | SOME l => labelIsOk l)
 	     andalso Vector.forall (cases, labelIsOk o #2)
-	     andalso Vector.isSorted (cases, fn ((w, _), (w', _)) => w <= w')
+	     andalso Vector.isSorted (cases, fn ((w, _), (w', _)) =>
+				      WordX.<= (w, w'))
 	     andalso
 	     not (isRedundant
 		  {cases = cases,
-		   equals = fn ((w, _), (w', _)) => w = w'})))
+		   equals = fn ((w, _), (w', _)) => WordX.equals (w, w')})))
 
 fun foldLabelUse (s: t, a: 'a, {label, use}): 'a =
    let
-      fun simple {cases, default, test} =
+      fun simple {cases, default, size, test} =
 	 let
 	    val a = use (test, a)
 	    val a = Option.fold (default, a, label)
@@ -189,8 +181,7 @@
 	 end
    in
       case s of
-	  Char z => simple z
-        | EnumPointers {enum, pointers, test} =>
+	 EnumPointers {enum, pointers, test} =>
 	  let
 	     val a = use (test, a)
 	     val a = label (enum, a)



1.3       +5 -7      mlton/mlton/backend/switch.sig

Index: switch.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/switch.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- switch.sig	10 Dec 2002 21:45:49 -0000	1.2
+++ switch.sig	23 Jun 2003 04:58:57 -0000	1.3
@@ -25,16 +25,13 @@
       include SWITCH_STRUCTS
 
       datatype t =
-	 Char of {(* Cases are in increasing order of char. *)
-		  cases: (char * Label.t) vector,
-		  default: Label.t option,
-		  test: Use.t}
-       | EnumPointers of {enum: Label.t,
+	 EnumPointers of {enum: Label.t,
 			  pointers: Label.t,
 			  test: Use.t}
        | Int of {(* Cases are in increasing order of int. *)
-		 cases: (int * Label.t) vector,
+		 cases: (IntX.t * Label.t) vector,
 		 default: Label.t option,
+		 size: IntSize.t,
 		 test: Use.t}
        | Pointer of {(* Cases are in increasing order of tycon. *)
 		     cases: {dst: Label.t,
@@ -44,8 +41,9 @@
 		     tag: Use.t, (* of type int *)
 		     test: Use.t}
        | Word of {(* Cases are in increasing order of word. *)
-		  cases: (word * Label.t) vector,
+		  cases: (WordX.t * Label.t) vector,
 		  default: Label.t option,
+		  size: WordSize.t,
 		  test: Use.t}
 
       val foldLabelUse: t * 'a * {label: Label.t * 'a -> 'a,



1.8       +1 -1      mlton/mlton/closure-convert/abstract-value.fun

Index: abstract-value.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/abstract-value.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- abstract-value.fun	18 Apr 2003 22:44:59 -0000	1.7
+++ abstract-value.fun	23 Jun 2003 04:58:58 -0000	1.8
@@ -444,7 +444,7 @@
 	    in
 	       r
 	    end
-       | Vector_fromArray =>
+       | Array_toVector =>
 	    let val r = result ()
 	    in (case (dest (oneArg ()), dest r) of
 		   (Type _, Type _) => ()



1.27      +9 -6      mlton/mlton/closure-convert/closure-convert.fun

Index: closure-convert.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/closure-convert.fun,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- closure-convert.fun	18 Apr 2003 22:45:00 -0000	1.26
+++ closure-convert.fun	23 Jun 2003 04:58:58 -0000	1.27
@@ -805,8 +805,7 @@
 		     fun doit (l, f) = doCases (l, f, fn i => fn e => (i, e))
 		     val (cases, ac) =
 			case cases of
-			   Scases.Char l => doit (l, Dexp.Char)
-			 | Scases.Con cases =>
+			   Scases.Con cases =>
 			      doCases
 			      (cases, Dexp.Con,
 			       fn Spat.T {con, arg, ...} =>
@@ -817,11 +816,15 @@
 				      | (SOME v, SOME (arg, _)) =>
 					   Vector.new1 (newVar arg, valueType v)
 				      | _ => Error.bug "constructor mismatch"
-			       in fn body => {con = con, args = args, body = body}
+			       in
+				  fn body => {args = args,
+					      body = body,
+					      con = con}
 			       end)
-			 | Scases.Int l => doit (l, Dexp.Int)
-			 | Scases.Word l => doit (l, Dexp.Word)
-			 | Scases.Word8 l => doit (l, Dexp.Word8)
+			 | Scases.Int (s, cs) =>
+			      doit (cs, fn cs => Dexp.Int (s, cs))
+			 | Scases.Word (s, cs) =>
+			      doit (cs, fn cs => Dexp.Word (s, cs))
 		  in (Dexp.casee
 		      {test = convertVarExp test,
 		       ty = ty, cases = cases, default = default},



1.57      +247 -137  mlton/mlton/codegen/c-codegen/c-codegen.fun

Index: c-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.fun,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -r1.56 -r1.57
--- c-codegen.fun	15 May 2003 14:50:56 -0000	1.56
+++ c-codegen.fun	23 Jun 2003 04:58:58 -0000	1.57
@@ -18,6 +18,8 @@
    structure ChunkLabel = ChunkLabel
    structure FrameInfo = FrameInfo
    structure Global = Global
+   structure IntSize = IntSize
+   structure IntX = IntX
    structure Kind = Kind
    structure Label = Label
    structure ObjectType = ObjectType
@@ -26,6 +28,8 @@
    structure ProfileInfo = ProfileInfo
    structure ProfileLabel = ProfileLabel
    structure Program = Program
+   structure RealSize = RealSize
+   structure RealX = RealX
    structure Register = Register
    structure Runtime = Runtime
    structure SourceInfo = SourceInfo
@@ -33,8 +37,14 @@
    structure Switch = Switch
    structure Transfer = Transfer
    structure Type = Type
+   structure WordSize = WordSize
+   structure WordX = WordX
 end
 
+datatype z = datatype IntSize.t
+datatype z = datatype RealSize.t
+datatype z = datatype WordSize.t
+
 local
    open Runtime
 in
@@ -58,6 +68,68 @@
 val traceGotoLabel = Trace.trace ("gotoLabel", Label.layout, Unit.layout) 
 
 val overhead = "**C overhead**"
+
+structure IntX =
+   struct
+      open IntX
+	 
+      fun toC (i: t): string =
+	 let
+	    fun isPos () = i >= zero (size i)
+	    fun neg () = concat ["-", String.dropPrefix (toString i, 1)]
+	    fun simple s =
+	       concat ["(Int", s, ")",
+		       if isPos () then toString i else neg ()]
+	    (* tricky writes min as a word to avoid a gcc warning. *)
+	    fun tricky min =
+	       if isPos ()
+		  then toString i
+	       else if IntX.isMin i
+		       then min
+		    else neg ()
+	 in
+	    case size i of
+	       I8 => simple "8"
+	     | I16 => simple "16"
+	     | I32 => tricky ("0x80000000")
+	     | I64 => concat ["(Int64)", tricky "0x8000000000000000"]
+	 end
+   end
+
+structure RealX =
+   struct
+      open RealX
+
+      fun toC (r: t): string =
+	 let
+	    (* The only difference between SML reals and C floats/doubles is that
+	     * SML uses "~" while C uses "-".
+	     *)
+	    val s =
+	       String.translate (toString r,
+				 fn #"~" => "-" | c => String.fromChar c)
+	 in
+	    case size r of
+	       R32 => concat ["(Real32)", s]
+	     | R64 => s
+	 end
+   end
+
+structure WordX =
+   struct
+      open WordX
+
+      fun toC (w: t): string =
+	 let
+	    fun simple s =
+	       concat ["(Word", s, ")0x", toString w]
+	 in
+	    case size w of
+	       W8 => simple "8"
+	     | W16 => simple "16"
+	     | W32 => concat ["0x", toString w]
+	 end
+   end
    
 structure C =
    struct
@@ -83,29 +155,20 @@
 	 (callNoSemi (f, xs, print)
 	  ; print ";\n")
 
-      fun int (n: int): string =
-	 if n >= 0
-	    then Int.toString n
-	 else if n = Int.minInt
-		 then "(int)0x80000000" (* because of goofy gcc warning *)
-	      else concat ["-", String.dropPrefix (Int.toString n, 1)]
-
       fun char (c: char) =
 	 concat [if Char.ord c >= 0x80 then "(uchar)" else "",
 		 "'", Char.escapeC c, "'"]
 
-      fun word (w: Word.t) = "0x" ^ Word.toString w
-
-      (* The only difference between SML reals and C floats/doubles is that
-       * SML uses "~" while C uses "-".
-       *)
-      fun real s = String.translate (s, fn #"~" => "-" | c => String.fromChar c)
+      fun int (i: int) =
+	 IntX.toC (IntX.make (IntInf.fromInt i, IntSize.default))
 
       fun string s =
 	 let val quote = "\""
 	 in concat [quote, String.escapeC s, quote]
 	 end
 
+      fun word (w: Word.t) = "0x" ^ Word.toString w
+
       fun bug (s: string, print) =
 	 call ("MLton_bug", [concat ["\"", String.escapeC s, "\""]], print)
 
@@ -142,6 +205,30 @@
 fun declareProfileLabel (l, print) =
    C.call ("DeclareProfileLabel", [ProfileLabel.toString l], print)
 
+fun declareGlobals (prefix: string, print) =
+   let
+      (* gcState can't be static because stuff in mlton-lib.c refers to
+       * it.
+       *)
+      val _ = print (concat [prefix, "struct GC_state gcState;\n"])
+      val _ =
+	 List.foreach
+	 (Runtime.Type.all, fn t =>
+	  let
+	     val s = Runtime.Type.toString t
+	  in		
+	     print (concat [prefix, s, " global", s,
+			    " [", C.int (Global.numberOfType t), "];\n"])
+	     ; print (concat [prefix, s, " CReturn", Runtime.Type.name t, ";\n"])
+	  end)
+      val _ =	       			    
+	 print (concat [prefix, "Pointer globalPointerNonRoot [",
+			C.int (Global.numberOfNonRoot ()),
+			"];\n"])
+   in
+      ()
+   end
+
 fun outputDeclarations
    {additionalMainArgs: string list,
     includes: string list,
@@ -152,15 +239,25 @@
     rest: unit -> unit
     }: unit =
    let
-      fun declareGlobals () =
-	 C.call ("Globals",
-		 List.map (List.map (let open Runtime.Type
-				     in [char, double, int, pointer, uint]
-				     end, 
-				     Global.numberOfType)
-			   @ [Global.numberOfNonRoot ()],
-			   C.int),
-		 print)
+      fun declareLoadSaveGlobals () =
+	 let
+	    val _ =
+	       (print "static void saveGlobals (int fd) {\n"
+		; (List.foreach
+		   (Runtime.Type.all, fn t =>
+		    print (concat ["\tSaveArray (global",
+				   Runtime.Type.toString t, ", fd);\n"])))
+		; print "}\n")
+	    val _ =
+	       (print "static void loadGlobals (FILE *file) {\n"
+		; (List.foreach
+		   (Runtime.Type.all, fn t =>
+		    print (concat ["\tLoadArray (global",
+				   Runtime.Type.toString t, ", file);\n"])))
+		; print "}\n")
+	 in
+	    ()
+	 end
       fun declareIntInfs () =
 	 (print "BeginIntInfs\n"
 	  ; List.foreach (intInfs, fn (g, s) =>
@@ -181,14 +278,13 @@
 			   ; print "\n"))
 	  ; print "EndStrings\n")
       fun declareReals () =
-	 (print "BeginReals\n"
-	  ; List.foreach (reals, fn (g, f) =>
-			  (C.callNoSemi ("Real",
-					 [C.int (Global.index g),
-					  C.real f],
-					 print)
-			   ; print "\n"))
-	  ; print "EndReals\n")
+	 (print "static void real_Init() {\n"
+	  ; List.foreach (reals, fn (g, r) =>
+			  print (concat ["\tglobalReal",
+					 RealSize.toString (RealX.size r),
+					 "[", C.int (Global.index g), "] = ",
+					 RealX.toC r, ";\n"]))
+	  ; print "}\n")
       fun declareFrameOffsets () =
 	 Vector.foreachi
 	 (frameOffsets, fn (i, v) =>
@@ -289,7 +385,8 @@
 	 end
    in
       outputIncludes (includes, print)
-      ; declareGlobals ()
+      ; declareGlobals ("", print)
+      ; declareLoadSaveGlobals ()
       ; declareIntInfs ()
       ; declareStrings ()
       ; declareReals ()
@@ -305,21 +402,29 @@
    struct
       open Type
 
-      fun toC (t: t): string =
-	 case t of
-	    Char => "Char"
-	  | CPointer => "Pointer"
-	  | EnumPointers {pointers, ...} =>
-	       if 0 = Vector.length pointers
-		  then "Int"
-	       else "Pointer"
-	  | ExnStack => "Word"
-	  | Int => "Int"
-	  | IntInf => "Pointer"
-	  | Label _ => "Word"
-	  | Real => "Double"
-	  | Word => "Word"
-	  | _ => Error.bug (concat ["Type.toC strange type: ", toString t])
+      local
+	 fun make (name, memo, toString) =
+	    memo (fn s => concat [name, toString s])
+	 val int = make ("Int", IntSize.memoize, IntSize.toString)
+	 val real = make ("Real", RealSize.memoize, RealSize.toString)
+	 val word = make ("Word", WordSize.memoize, WordSize.toString)
+	 val pointer = "Pointer"
+      in
+	 fun toC (t: t): string =
+	    case t of
+	       CPointer => pointer
+	     | EnumPointers {pointers, ...} =>
+		  if 0 = Vector.length pointers
+		     then int I32
+		  else pointer
+	     | ExnStack => word W32
+	     | Int s => int s
+	     | IntInf => pointer
+	     | Label _ => word W32
+	     | Real s => real s
+	     | Word s => word s
+	     | _ => Error.bug (concat ["Type.toC strange type: ", toString t])
+      end
    end
 
 structure Prim =
@@ -333,19 +438,23 @@
 	       val {get: Tycon.t -> string option, set, ...} =
 		  Property.getSetOnce (Tycon.plist, Property.initConst NONE)
 	       val tycons =
-		  [(Tycon.char, "Char"),
-		   (Tycon.int, "Int"),
-		   (Tycon.intInf, "Pointer"),
-		   (Tycon.pointer, "Pointer"),
-		   (Tycon.preThread, "Pointer"),
-		   (Tycon.real, "Double"),
-		   (Tycon.reff, "Pointer"),
-		   (Tycon.thread, "Pointer"),
-		   (Tycon.tuple, "Pointer"),
-		   (Tycon.vector, "Pointer"),
-		   (Tycon.weak, "Pointer"),
-		   (Tycon.word, "Word32"),
-		   (Tycon.word8, "Word8")]
+		  List.map
+		  (IntSize.all, fn s =>
+		   (Tycon.int s, concat ["Int", IntSize.toString s]))
+		  @ [(Tycon.intInf, "Pointer"),
+		     (Tycon.pointer, "Pointer"),
+		     (Tycon.preThread, "Pointer")]
+		  @ (List.map
+		     (RealSize.all, fn s =>
+		      (Tycon.real s, concat ["Real", RealSize.toString s])))
+		  @ [(Tycon.reff, "Pointer"),
+		     (Tycon.thread, "Pointer"),
+		     (Tycon.tuple, "Pointer"),
+		     (Tycon.vector, "Pointer"),
+		     (Tycon.weak, "Pointer")]
+		  @ (List.map
+		     (WordSize.all, fn s =>
+		      (Tycon.word s, concat ["Word", WordSize.toString s])))
 	       val _ =
 		  List.foreach (tycons, fn (tycon, s) => set (tycon, SOME s))
 	    in
@@ -360,7 +469,9 @@
 	    end
 	 end
    end
-   
+
+fun contents (ty, z) = concat ["C", C.args [Type.toC ty, z]]
+
 fun output {program as Machine.Program.T {chunks,
 					  frameLayouts,
 					  main = {chunkLabel, label}, ...},
@@ -454,7 +565,7 @@
 		src: string, srcIsMem: bool,
 		ty: Type.t}: string =
 	 if handleMisalignedReals
-	    andalso Type.equals (ty, Type.real)
+	    andalso Type.equals (ty, Type.real R64)
 	    then
 	       case (dstIsMem, srcIsMem) of
 		  (false, false) => concat [dst, " = ", src, ";\n"]
@@ -467,45 +578,41 @@
       	 fun toString (z: Operand.t): string =
 	    case z of
 	       ArrayOffset {base, index, ty} =>
-		  concat ["X", Type.name ty,
-			  C.args [toString base, toString index]]
-	     | Cast (z, ty) =>
-		  concat ["(", Runtime.Type.toString (Type.toRuntime ty), ")",
-			  toString z]
-	     | Char c => C.char c
-	     | Contents {oper, ty} =>
-		  concat ["C", Type.name ty, "(", toString oper, ")"]
+		  concat ["X", C.args [Type.toC ty,
+				       toString base,
+				       toString index]]
+	     | Cast (z, ty) => concat ["(", Type.toC ty, ")", toString z]
+	     | Contents {oper, ty} => contents (ty, toString oper)
 	     | File => "__FILE__"
 	     | Frontier => "Frontier"
 	     | GCState => "GCState"
 	     | Global g =>
-		  concat ["G", Type.name (Global.ty g),
-			  if Global.isRoot g
-			     then ""
-			  else "NR",
-			     "(", Int.toString (Global.index g), ")"]
-	     | Int n => C.int n
+		  if Global.isRoot g
+		     then concat ["G",
+				  C.args [Type.toC (Global.ty g),
+					  Int.toString (Global.index g)]]
+		  else concat ["GPNR", C.args [Int.toString (Global.index g)]]
+	     | Int i => IntX.toC i
 	     | Label l => labelToStringIndex l
 	     | Line => "__LINE__"
 	     | Offset {base, offset, ty} =>
-		  concat ["O", Type.name ty,
-			  C.args [toString base, C.int offset]]
-	     | Real s => C.real s
+		  concat ["O", C.args [Type.toC ty, toString base, C.int offset]]
+	     | Real r => RealX.toC r
 	     | Register r =>
-		  concat ["R", Type.name (Register.ty r),
-			  "(", Int.toString (Register.index r), ")"]
+		  concat [Type.name (Register.ty r), "_",
+			  Int.toString (Register.index r)]
 	     | SmallIntInf w =>
 		  concat ["SmallIntInf", C.args [concat ["0x", Word.toString w]]]
 	     | StackOffset {offset, ty} =>
-		  concat ["S", Type.name ty, "(", C.int offset, ")"]
+		  concat ["S", C.args [Type.toC ty, C.int offset]]
 	     | StackTop => "StackTop"
-	     | Word w => C.word w
+	     | Word w => WordX.toC w
       in
 	 val operandToString = toString
       end
       fun fetchOperand (z: Operand.t): string =
 	 if handleMisalignedReals
-	    andalso Type.equals (Operand.ty z, Type.real)
+	    andalso Type.equals (Operand.ty z, Type.real R64)
 	    andalso Operand.isMem z
 	    then realFetch (operandToString z)
 	 else operandToString z
@@ -535,12 +642,12 @@
 				 let
 				    val ty = Operand.ty value
 				    val dst =
-				       concat
-				       ["C", Type.name (Operand.ty value),
-					"(Frontier + ",
-					C.int (offset
-					       + Runtime.normalHeaderSize),
-					")"]
+				       contents
+				       (Operand.ty value,
+					concat ["Frontier + ",
+						C.int
+						(offset
+						 + Runtime.normalHeaderSize)])
 				 in
 				    print "\t"
 				    ; (print
@@ -758,12 +865,8 @@
 				     val _ =
 					print
 					(concat
-					 ["\t",
-					  Runtime.Type.toString
-					  (Type.toRuntime ty),
-					  " ", tmp, " = ",
-					  fetchOperand z,
-					  ";\n"])
+					 ["\t", Type.toC ty, " ", tmp, " = ",
+					  fetchOperand z, ";\n"])
 				  in
 				     tmp
 				  end
@@ -890,36 +993,40 @@
 				 fun const1 () = const 1
 			      in
 				 case Prim.name prim of
-				    Int_addCheck =>
-				       if const0 ()
-					  then "\tInt_addCheckCX"
-				       else if const1 ()
-					       then "\tInt_addCheckXC"
-					    else "\tInt_addCheck"
-				  | Int_mulCheck => "\tInt_mulCheck"
-				  | Int_negCheck => "\tInt_negCheck"
-				  | Int_subCheck =>
-				       if const0 ()
-					  then "\tInt_subCheckCX"
-				       else if const1 ()
-					       then "\tInt_subCheckXC"
-					    else "\tInt_subCheck"
-				  | Word32_addCheck =>
-				       if const0 ()
-					  then "\tWord32_addCheckCX"
-				       else if const1 ()
-					       then "\tWord32_addCheckXC"
-					    else "\tWord32_addCheck"
-				  | Word32_mulCheck => "\tWord32_mulCheck"  
+				    Int_addCheck _ =>
+				       concat [Prim.toString prim,
+					       if const0 ()
+						  then "CX"
+					       else if const1 ()
+						       then "XC"
+						    else ""]
+				  | Int_mulCheck _ => Prim.toString prim
+				  | Int_negCheck _ => Prim.toString prim
+				  | Int_subCheck _ =>
+				       concat [Prim.toString prim,
+					       if const0 ()
+						  then "CX"
+					       else if const1 ()
+						       then "XC"
+						    else ""]
+				  | Word_addCheck _ =>
+				       concat [Prim.toString prim,
+					       if const0 ()
+						  then "CX"
+					       else if const1 ()
+						       then "XC"
+						    else ""]
+				  | Word_mulCheck _ => Prim.toString prim
 				  | _ => Error.bug "strange overflow prim"
 			      end
 			   val _ = force overflow
 			in
-			   C.call (prim,
-				   operandToString dst
-				   :: (Vector.toListMap (args, operandToString)
-				       @ [Label.toString overflow]),
-				   print)
+                           print "\t"
+			   ; C.call (prim,
+				     operandToString dst
+				     :: (Vector.toListMap (args, operandToString)
+					 @ [Label.toString overflow]),
+				     print)
 			   ; gotoLabel success 
 			   ; maybePrintLabel overflow
 			end
@@ -1030,7 +1137,7 @@
 					       #2 (Vector.sub (cases, 0)))
 				  | (_, SOME l) => switch (cases, l)
 			      end
-			   fun simple ({cases, default, test}, f) =
+			   fun simple ({cases, default, size, test}, f) =
 			      doit {cases = Vector.map (cases, fn (c, l) =>
 							(f c, l)),
 				    default = default,
@@ -1038,27 +1145,28 @@
 			   datatype z = datatype Switch.t
 			in
 			   case switch of
-			      Char z => simple (z, C.char)
-			    | EnumPointers {enum, pointers, test} =>
+			      EnumPointers {enum, pointers, test} =>
 			      iff (concat
 				   ["IsInt (", operandToString test, ")"],
 				   enum, pointers)
-			    | Int (z as {cases, default, test}) =>
+			    | Int (z as {cases, default, size, test}) =>
 				 let
-				    fun normal () = simple (z, C.int)
+				    fun normal () = simple (z, IntX.toC)
 				 in
 				    if 2 = Vector.length cases
+				       andalso Option.isNone default
 				       then
 					  let
-					     val c0 = Vector.sub (cases, 0)
-					     val c1 = Vector.sub (cases, 1)
+					     val (c0, l0) = Vector.sub (cases, 0)
+					     val (c1, l1) = Vector.sub (cases, 1)
 					  in
-					     case (c0, c1, default) of
-						((0, f), (1, t), NONE) =>
-						   bool (test, t, f)
-					      | ((1, t), (0, f), NONE) =>
-						   bool (test, t, f)
-					      | _ => normal ()
+					     if IntX.isZero c0
+						andalso IntX.isOne c1
+						then bool (test, l1, l0)
+					     else if (IntX.isOne c0
+						      andalso IntX.isZero c1)
+						     then bool (test, l0, l1)
+						  else normal ()
 					  end
 				    else normal ()
 				 end
@@ -1068,17 +1176,18 @@
 						 (Int.toString tag, dst))),
 				       default = default,
 				       test = tag}
-			    | Word z => simple (z, C.word)
+			    | Word z => simple (z, WordX.toC)
 			end
 	       end
 	    fun declareRegisters () =
 	       List.foreach
 	       (Runtime.Type.all, fn t =>
 		let
-		   val d = concat ["D", Runtime.Type.name t]
+		   val pre = concat ["\t", Runtime.Type.toString t, " ",
+				     Runtime.Type.name t, "_"]
 		in
 		   Int.for (0, 1 + regMax t, fn i =>
-			    C.call (d, [C.int i], print))
+			    print (concat [pre, C.int i, ";\n"]))
 		end)
 	    fun outputOffsets () =
 	       List.foreach
@@ -1092,6 +1201,7 @@
 	 in
 	    outputIncludes (["c-chunk.h"], print)
 	    ; outputOffsets ()
+	    ; declareGlobals ("extern ", print)
 	    ; declareFFI ()
 	    ; declareChunks ()
 	    ; declareProfileLabels ()



1.40      +11 -14    mlton/mlton/codegen/x86-codegen/x86-codegen.fun

Index: x86-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-codegen.fun,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- x86-codegen.fun	14 May 2003 02:50:11 -0000	1.39
+++ x86-codegen.fun	23 Jun 2003 04:58:58 -0000	1.40
@@ -159,22 +159,19 @@
 		    [mainLabel, if reserveEsp then C.truee else C.falsee]
 		 end
 	      fun declareLocals () =
-		 let
-		    val tyMax =
-		       Runtime.Type.memo
-		       (fn t =>
+		 List.foreach
+		 (Runtime.Type.all,
+		  fn t =>
+		  let
+		     val m =
 			List.fold
 			(chunks, ~1, fn (Machine.Chunk.T {regMax, ...}, max) =>
-			 Int.max (max, regMax t)))
-		 in
-		    print
-		    (concat ["Locals",
-			     Layout.toString
-			     (Layout.tuple (List.map
-					    (Runtime.Type.all, fn t =>
-					     Int.layout (1 + tyMax t)))),
-			     ";\n"])
-		 end
+			 Int.max (max, regMax t))
+		     val m = m + 1
+		  in
+		     print (concat ["local", Runtime.Type.toString t,
+				    "[", Int.toString m, "];\n"])
+		  end)
 	      fun rest () =
 		 declareLocals ()
 	    in



1.19      +75 -45    mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun

Index: x86-mlton-basic.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- x86-mlton-basic.fun	15 May 2003 14:50:57 -0000	1.18
+++ x86-mlton-basic.fun	23 Jun 2003 04:58:58 -0000	1.19
@@ -12,6 +12,13 @@
   open x86
 
   structure Runtime = Machine.Runtime
+  local
+     open Runtime
+  in
+     structure IntSize = IntSize
+     structure RealSize = RealSize
+     structure WordSize = WordSize
+  end
 
   (*
    * x86.Size.t equivalents
@@ -30,23 +37,40 @@
    
   local
      datatype z = datatype Runtime.Type.dest
+     datatype z = datatype x86.Size.t
   in
-    fun toX86Size' t
-      = case t
-	  of Char => x86.Size.BYTE
-	   | Double => x86.Size.DBLE
-	   | Int => x86.Size.LONG
-	   | Pointer => x86.Size.LONG
-	   | Uint => x86.Size.LONG
+    fun toX86Size' t =
+       case t of
+	  Int s =>
+	     let
+		datatype z = datatype IntSize.t
+	     in
+		case s of
+		   I8 => BYTE
+		 | I16 => WORD
+		 | I32 => LONG
+		 | I64 => Error.bug "FIXME"
+	     end
+	| Pointer => LONG
+	| Real s =>
+	     let
+		datatype z = datatype RealSize.t
+	     in
+		case s of
+		   R32 => SNGL
+		 | R64 => DBLE
+	     end
+	| Word s =>
+	     let
+		datatype z = datatype WordSize.t
+	     in
+		case s of
+		   W8 => BYTE
+		 | W16 => WORD 
+		 | W32 => LONG
+	     end
     val toX86Size = fn t => toX86Size' (Runtime.Type.dest t)
-    fun toX86Scale' t
-      = case t
-	  of Char => x86.Scale.One
-	   | Double => x86.Scale.Eight
-	   | Int => x86.Scale.Four
-	   | Pointer => x86.Scale.Four
-	   | Uint => x86.Scale.Four
-    val toX86Scale = fn t => toX86Scale' (Runtime.Type.dest t)
+    fun toX86Scale t = x86.Scale.fromBytes (Runtime.Type.size t)
   end
 
   (*
@@ -251,45 +275,51 @@
     = Operand.memloc fpswTempContents
 
   local
-    val localC_base = Label.fromString "localuchar"
-    val localD_base = Label.fromString "localdouble"
-    val localI_base = Label.fromString "localint"
-    val localP_base = Label.fromString "localpointer"
-    val localU_base = Label.fromString "localuint"
+    val localI_base =
+       IntSize.memoize
+       (fn s => Label.fromString (concat ["localInt", IntSize.toString s]))
+    val localP_base = Label.fromString "localPointer"
+    val localR_base =
+       RealSize.memoize
+       (fn s => Label.fromString (concat ["localReal", RealSize.toString s]))
+    val localW_base =
+       WordSize.memoize
+       (fn s => Label.fromString (concat ["localWord", WordSize.toString s]))
     datatype z = datatype Runtime.Type.dest
   in
-    fun local_base ty
-      = case Runtime.Type.dest ty
-	  of Char    => localC_base
-	   | Double  => localD_base
-	   | Int     => localI_base
-	   | Pointer => localP_base
-	   | Uint    => localU_base
+    fun local_base ty =
+       case Runtime.Type.dest ty of
+	  Int s => localI_base s
+	| Pointer => localP_base
+	| Real s => localR_base s
+	| Word s => localW_base s
   end
 
   local
-    val globalC_base = Label.fromString "globaluchar"
-    val globalC_num = Label.fromString "num_globaluchar"
-    val globalD_base = Label.fromString "globaldouble"
-    val globalD_num = Label.fromString "num_globaldouble"
-    val globalI_base = Label.fromString "globalint"
-    val globalI_num = Label.fromString "num_globalint"
-    val globalP_base = Label.fromString "globalpointer"
-    val globalP_num = Label.fromString "num_globalpointer"
-    val globalU_base = Label.fromString "globaluint"
-    val globalU_num = Label.fromString "num_globaluint"
+     fun make (name, memo, toString) =
+	(memo (fn s =>
+	       Label.fromString (concat ["global", name, toString s])),
+	 memo (fn s =>
+	       Label.fromString (concat ["num_global", name, toString s])))
+     val (globalI_base, globalI_num) =
+	make ("Int", IntSize.memoize, IntSize.toString)
+     val globalP_base = Label.fromString "globalPointer"
+     val globalP_num = Label.fromString "num_globalpointer"
+     val (globalR_base, globalR_num) =
+	make ("Real", RealSize.memoize, RealSize.toString)
+     val (globalW_base, globalW_num) =
+	make ("Word", WordSize.memoize, WordSize.toString)
     datatype z = datatype Runtime.Type.dest
   in
-    fun global_base ty
-      = case Runtime.Type.dest ty
-	  of Char    => globalC_base
-	   | Double  => globalD_base
-	   | Int     => globalI_base
-	   | Pointer => globalP_base
-	   | Uint    => globalU_base
+     fun global_base ty =
+	case Runtime.Type.dest ty of
+	   Int s => globalI_base s
+	 | Pointer => globalP_base
+	 | Real s => globalR_base s
+	 | Word s => globalW_base s
   end
 
-  val globalPointerNonRoot_base = Label.fromString "globalpointerNonRoot"
+  val globalPointerNonRoot_base = Label.fromString "globalPointerNonRoot"
 
   val saveGlobals = Label.fromString "saveGlobals"
   val loadGlobals = Label.fromString "loadGlobals"



1.44      +110 -225  mlton/mlton/codegen/x86-codegen/x86-mlton.fun

Index: x86-mlton.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.fun,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -r1.43 -r1.44
--- x86-mlton.fun	14 May 2003 02:50:11 -0000	1.43
+++ x86-mlton.fun	23 Jun 2003 04:58:58 -0000	1.44
@@ -17,6 +17,9 @@
      structure CFunction = CFunction
      structure Prim = Prim
      structure Runtime = Runtime
+     datatype z = datatype IntSize.t
+     datatype z = datatype RealSize.t
+     datatype z = datatype WordSize.t
   end
 
   type transInfo = {addData : x86.Assembly.t list -> unit,
@@ -54,110 +57,6 @@
 	      statements = [Assembly.comment ("UNIMPLEMENTED PRIM: " ^ s)],
 	      transfer = NONE}]
 
-	fun subWord8ArrayVector ()
-	  = let
-	      val (dst,dstsize) = getDst ()
-	      val _ 
-		= Assert.assert
-		  ("applyPrim: subWord8ArrayVector, dstsize", 
-		   fn () => dstsize = Size.LONG)
-	      val ((src1,src1size),
-		   (src2,src2size)) = getSrc2 ()
-	      val _ 
-		= Assert.assert
-		  ("applyPrim: subWord8ArrayVector, src1size",
-		   fn () => src1size = pointerSize)
-	      val _ 
-		= Assert.assert
-		  ("applyPrim: subWord8ArrayVector, src2size",
-		   fn () => src2size = pointerSize)
-
-	      val base 
-		= case (Operand.deMemloc src1)
-		    of SOME base => base
-		     | NONE => Error.bug "applyPrim: subWord8ArrayVector, src1"
-	      val memloc
-		= case (Operand.deImmediate src2,
-			Operand.deMemloc src2)
-		    of (SOME index, _)
-		     => MemLoc.simple 
-		        {base = base,
-			 index = index,
-			 scale = Scale.Four,
-			 size = Size.LONG,
-			 class = Classes.Heap}
-		     | (_, SOME index)
-		     => MemLoc.complex 
-		        {base = base,
-			 index = index,
-			 scale = Scale.Four,
-			 size = Size.LONG,
-			 class = Classes.Heap}
-		     | _ => Error.bug "applyPrim: subWord8ArrayVector, src2"
-	    in
-	      AppendList.fromList
-	      [Block.mkBlock'
-	       {entry = NONE,
-		statements 
-		= [Assembly.instruction_mov
-		   {dst = dst,
-		    src = Operand.memloc memloc,
-		    size = dstsize}],
-		transfer = NONE}]
-	    end	  
-
-	fun updateWord8Array ()
-	  = let
-	      val ((src1,src1size),
-		   (src2,src2size),
-		   (src3,src3size)) = getSrc3 ()
-	      val _ 
-		= Assert.assert
-		  ("applyPrim: updateWord8Array, src1size", 
-		   fn () => src1size = pointerSize)
-	      val _ 
-		= Assert.assert
-		  ("applyPrim: updateWord8Array, src2size", 
-		   fn () => src2size = wordSize)
-	      val _ 
-		= Assert.assert
-		  ("applyPrim: updateWord8Array, src3size", 
-		   fn () => src3size = wordSize)
-
-	      val base 
-		= case (Operand.deMemloc src1)
-		    of SOME base => base
-		     | NONE => Error.bug "applyPrim: updateWord8Array, src1"
-	      val memloc
-		= case (Operand.deImmediate src2,
-			Operand.deMemloc src2)
-		    of (SOME index, _)
-		     => MemLoc.simple 
-		        {base = base,
-			 index = index,
-			 scale = Scale.Four,
-			 size = Size.LONG,
-			 class = Classes.Heap}
-		     | (_, SOME index)
-		     => MemLoc.complex 
-			{base = base,
-			 index = index,
-			 scale = Scale.Four,
-			 size = Size.LONG,
-			 class = Classes.Heap}
-		     | _ => Error.bug "applyPrim: updateWord8Array, src2"
-	    in
-	      AppendList.fromList
-	      [Block.mkBlock'
-	       {entry = NONE,
-		statements 
-		= [Assembly.instruction_mov
-		   {dst = Operand.memloc memloc,
-		    src = src3,
-		    size = src3size}],
-		transfer = NONE}]
-	    end	  
-
 	fun mov ()
 	  = let
 	      val (dst,dstsize) = getDst ()
@@ -650,13 +549,7 @@
 	AppendList.appends
 	[comment_begin,
 	 (case Prim.name prim of
-	       Char_lt => cmp Instruction.B
-	     | Char_le => cmp Instruction.BE
-	     | Char_gt => cmp Instruction.A
-	     | Char_ge => cmp Instruction.AE
-	     | Char_chr => xvom ()
-	     | Char_ord => movx Instruction.MOVZX
-	     | Cpointer_isNull 
+	     Cpointer_isNull 
 	     => let
 		  val (dst,dstsize) = getDst ()
 		  val (src,srcsize) = getSrc1 ()
@@ -706,22 +599,39 @@
 			   transfer = NONE}]
 		       end
  	            | SOME _ => Error.bug "prim: FFI")
-             | Int_add => binal Instruction.ADD
-	     | Int_sub => binal Instruction.SUB
-	     | Int_mul => imul2 () 
-	     | Int_quot => pmd Instruction.IDIV
-	     | Int_rem => pmd Instruction.IMOD
-	     | Int_neg => unal Instruction.NEG 
-	     | Int_lt => cmp Instruction.L
-	     | Int_le => cmp Instruction.LE
-	     | Int_gt => cmp Instruction.G
-	     | Int_ge => cmp Instruction.GE
-	     | Int_gtu => cmp Instruction.A
-	     | Int_geu => cmp Instruction.AE
+	     | Int_ge _ => cmp Instruction.GE
+	     | Int_gt _ => cmp Instruction.G
+	     | Int_le _ => cmp Instruction.LE
+	     | Int_lt _ => cmp Instruction.L
+	     | Int_mul _ => imul2 () 
+	     | Int_neg _ => unal Instruction.NEG 
+	     | Int_quot _ => pmd Instruction.IDIV
+	     | Int_rem _ => pmd Instruction.IMOD
+	     | Int_sub _ => binal Instruction.SUB
+             | Int_add _ => binal Instruction.ADD
+	     | Int_toReal _
+	     => let
+		  val (dst,dstsize) = getDst ()
+		  val (src,srcsize) = getSrc1 ()
+		in
+		  AppendList.fromList
+		  [Block.mkBlock'
+		   {entry = NONE,
+		    statements 
+		    = [Assembly.instruction_pfmovfi
+		       {dst = dst,
+			src = src,
+			srcsize = srcsize,
+			dstsize = dstsize}],
+		    transfer = NONE}]
+		end 
+	     | Int_toWord (s, s') =>
+		  (case (s, s') of
+		      (I32, W8) => xvom ()
+		    | (I32, W32) => mov ()
+		    | _ => Error.bug (Prim.toString prim))
 	     | MLton_eq => cmp Instruction.E
-	     | MLton_serialize => unimplemented primName
-	     | MLton_deserialize => unimplemented primName
-	     | Real_Math_acos 
+	     | Real_Math_acos _
 	     => let
 		  val (dst,dstsize) = getDst ()
 		  val (src,srcsize) = getSrc1 ()
@@ -771,7 +681,7 @@
 			size = dstsize}],
 		    transfer = NONE}]
 		end
-	     | Real_Math_asin
+	     | Real_Math_asin _
 	     => let
 		  val (dst,dstsize) = getDst ()
 		  val (src,srcsize) = getSrc1 ()
@@ -817,7 +727,7 @@
 			size = dstsize}],
 		    transfer = NONE}]
 		end
-	     | Real_Math_atan 
+	     | Real_Math_atan _
 	     => let
 		  val (dst,dstsize) = getDst ()
 		  val (src,srcsize) = getSrc1 ()
@@ -845,7 +755,7 @@
 			size = dstsize}],
 		    transfer = NONE}]
 		end
-	     | Real_Math_atan2 
+	     | Real_Math_atan2 _
 	     => let
 		  val (dst,dstsize) = getDst ()
 		  val ((src1,src1size),
@@ -871,8 +781,8 @@
 			size = dstsize}],
 		    transfer = NONE}]
 		end
-	     | Real_Math_cos => funa Instruction.FCOS
-	     | Real_Math_exp 
+	     | Real_Math_cos _ => funa Instruction.FCOS
+	     | Real_Math_exp _
 	     => let
 		  val (dst,dstsize) = getDst ()
 		  val (src,srcsize) = getSrc1 ()
@@ -927,11 +837,11 @@
 			size = dstsize}],
 		    transfer = NONE}]
 		end
- 	     | Real_Math_ln => flogarithm Instruction.LN2
-	     | Real_Math_log10 => flogarithm Instruction.LG2
-	     | Real_Math_sin => funa Instruction.FSIN
-	     | Real_Math_sqrt => funa Instruction.FSQRT
-	     | Real_Math_tan
+ 	     | Real_Math_ln _ => flogarithm Instruction.LN2
+	     | Real_Math_log10 _ => flogarithm Instruction.LG2
+	     | Real_Math_sin _ => funa Instruction.FSIN
+	     | Real_Math_sqrt _ => funa Instruction.FSQRT
+	     | Real_Math_tan _
 	     => let
 		  val (dst,dstsize) = getDst ()
 		  val (src,srcsize) = getSrc1 ()
@@ -953,13 +863,13 @@
 			size = dstsize}],
 		    transfer = NONE}]
 		end
-	     | Real_mul => fbina Instruction.FMUL
-	     | Real_muladd => fbina_fmul Instruction.FADD
-	     | Real_mulsub => fbina_fmul Instruction.FSUB
-	     | Real_add => fbina Instruction.FADD
-	     | Real_sub => fbina Instruction.FSUB
-	     | Real_div => fbina Instruction.FDIV
-	     | Real_lt 
+	     | Real_mul _ => fbina Instruction.FMUL
+	     | Real_muladd _ => fbina_fmul Instruction.FADD
+	     | Real_mulsub _ => fbina_fmul Instruction.FSUB
+	     | Real_add _ => fbina Instruction.FADD
+	     | Real_sub _ => fbina Instruction.FSUB
+	     | Real_div _ => fbina Instruction.FDIV
+	     | Real_lt _
 	     => let
 		  val (dst,dstsize) = getDst ()
 		  val ((src1,src1size),
@@ -990,7 +900,7 @@
 			size = dstsize}],
 		    transfer = NONE}]
 		end
-	     | Real_le
+	     | Real_le _
 	     => let
 		  val (dst,dstsize) = getDst ()
 		  val ((src1,src1size),
@@ -1021,7 +931,7 @@
 			size = dstsize}],
 		    transfer = NONE}]
 		end
-	     | Real_equal
+	     | Real_equal _
 	     => let
 		  val (dst,dstsize) = getDst ()
 		  val ((src1,src1size),
@@ -1057,7 +967,7 @@
 			size = dstsize}],
 		    transfer = NONE}]
 		end
-	     | Real_gt
+	     | Real_gt _
 	     => let
 		  val (dst,dstsize) = getDst ()
 		  val ((src1,src1size),
@@ -1088,7 +998,7 @@
 			size = dstsize}],
 		    transfer = NONE}]
 		end
-	     | Real_ge
+	     | Real_ge _
 	     => let
 		  val (dst,dstsize) = getDst ()
 		  val ((src1,src1size),
@@ -1119,7 +1029,7 @@
 			size = dstsize}],
 		    transfer = NONE}]
 		end
-	     | Real_qequal
+	     | Real_qequal _
 	     => let
 		  val (dst,dstsize) = getDst ()
 		  val ((src1,src1size),
@@ -1150,24 +1060,8 @@
 			size = dstsize}],
 		    transfer = NONE}]
 		end
-	     | Real_abs => funa Instruction.FABS
-	     | Real_fromInt 
-	     => let
-		  val (dst,dstsize) = getDst ()
-		  val (src,srcsize) = getSrc1 ()
-		in
-		  AppendList.fromList
-		  [Block.mkBlock'
-		   {entry = NONE,
-		    statements 
-		    = [Assembly.instruction_pfmovfi
-		       {dst = dst,
-			src = src,
-			srcsize = srcsize,
-			dstsize = dstsize}],
-		    transfer = NONE}]
-		end 
-	     | Real_toInt
+	     | Real_abs _ => funa Instruction.FABS
+	     | Real_toInt _
 	     => let
 		  val (dst,dstsize) = getDst ()
 		  val (src,srcsize) = getSrc1 ()
@@ -1183,7 +1077,7 @@
 			dstsize = dstsize}],
 		    transfer = NONE}]
 		end 
-	     | Real_ldexp 
+	     | Real_ldexp _ 
 	     => let
 		  val (dst,dstsize) = getDst ()
 		  val ((src1,src1size),
@@ -1217,58 +1111,49 @@
 			size = dstsize}],
 		    transfer = NONE}]
 		end
-	     | Real_neg => funa Instruction.FCHS
-	     | Real_round => funa Instruction.FRNDINT
-	     | Word8_toInt => movx Instruction.MOVZX
-	     | Word8_toIntX => movx Instruction.MOVSX
-	     | Word8_fromInt => xvom ()
-	     | Word8_toLargeWord => movx Instruction.MOVZX
-	     | Word8_toLargeWordX => movx Instruction.MOVSX
-	     | Word8_fromLargeWord => xvom ()
-	     | Word8_add => binal Instruction.ADD
-	     | Word8_sub => binal Instruction.SUB
-	     | Word8_andb => binal Instruction.AND
-	     | Word8_orb => binal Instruction.OR
-	     | Word8_xorb => binal Instruction.XOR
-	     | Word8_mul => pmd Instruction.MUL
-	     | Word8_div => pmd Instruction.DIV
-	     | Word8_mod => pmd Instruction.MOD
-	     | Word8_neg => unal Instruction.NEG
-	     | Word8_notb => unal Instruction.NOT
-	     | Word8_lt => cmp Instruction.B
-	     | Word8_le => cmp Instruction.BE
-	     | Word8_gt => cmp Instruction.A
-	     | Word8_ge => cmp Instruction.AE
-	     | Word8_rol => sral Instruction.ROL
-	     | Word8_ror => sral Instruction.ROR
-	     | Word8_lshift => sral Instruction.SHL
-	     | Word8_rshift => sral Instruction.SHR
-	     | Word8_arshift => sral Instruction.SAR
-	     | Word8Array_subWord => subWord8ArrayVector ()
-	     | Word8Array_updateWord => updateWord8Array ()
-	     | Word8Vector_subWord => subWord8ArrayVector ()
-	     | Word32_add => binal Instruction.ADD
-	     | Word32_sub => binal Instruction.SUB
-	     | Word32_andb => binal Instruction.AND
-	     | Word32_orb => binal Instruction.OR
-	     | Word32_xorb => binal Instruction.XOR
-(*
-	     | Word32_mul => pmd Instruction.MUL
-*)
-	     | Word32_mul => imul2 ()
-	     | Word32_div => pmd Instruction.DIV
-	     | Word32_mod => pmd Instruction.MOD
-	     | Word32_neg => unal Instruction.NEG
-	     | Word32_notb => unal Instruction.NOT
-	     | Word32_lt => cmp Instruction.B
-	     | Word32_le => cmp Instruction.BE
-	     | Word32_gt => cmp Instruction.A
-	     | Word32_ge => cmp Instruction.AE
-	     | Word32_rol => sral Instruction.ROL
-	     | Word32_ror => sral Instruction.ROR
-	     | Word32_lshift => sral Instruction.SHL
-	     | Word32_rshift => sral Instruction.SHR
-	     | Word32_arshift => sral Instruction.SAR
+	     | Real_neg _ => funa Instruction.FCHS
+	     | Real_round _ => funa Instruction.FRNDINT
+	     | Word_add _ => binal Instruction.ADD
+	     | Word_andb _ => binal Instruction.AND
+	     | Word_arshift _ => sral Instruction.SAR
+	     | Word_div _ => pmd Instruction.DIV
+	     | Word_ge _ => cmp Instruction.AE
+	     | Word_gt _ => cmp Instruction.A
+	     | Word_le _ => cmp Instruction.BE
+	     | Word_lshift _ => sral Instruction.SHL
+	     | Word_lt _ => cmp Instruction.B
+	     | Word_mod _ => pmd Instruction.MOD
+	     | Word_mul s =>
+		  (case s of
+		      W8 => pmd Instruction.MUL
+		    | W16 => Error.bug "FIXME"
+		    | W32 => imul2 ())
+	     | Word_neg _ => unal Instruction.NEG
+	     | Word_notb _ => unal Instruction.NOT
+	     | Word_orb _ => binal Instruction.OR
+	     | Word_rol _ => sral Instruction.ROL
+	     | Word_ror _ => sral Instruction.ROR
+	     | Word_rshift _ => sral Instruction.SHR
+	     | Word_sub _ => binal Instruction.SUB
+	     | Word_toInt (s, s') =>
+		  (case (s, s') of
+		      (W8, I32) => movx Instruction.MOVZX
+		    | _ => Error.bug (Prim.toString prim))
+	     | Word_toIntX (s, s') =>
+		  (case (s, s') of
+		      (W8, I32) => movx Instruction.MOVSX
+		    | (W32, I32) => mov ()
+		    | _ => Error.bug (Prim.toString prim))
+	     | Word_toWord (s, s') =>
+		  (case (s, s') of
+		      (W8, W32) => movx Instruction.MOVZX
+		    | (W32, W8) => xvom ()
+		    | _ => Error.bug (Prim.toString prim))
+	     | Word_toWordX (s, s') =>
+		  (case (s, s') of
+		      (W8, W32) => movx Instruction.MOVSX
+		    | _ => Error.bug (Prim.toString prim))
+	     | Word_xorb _ => binal Instruction.XOR
 	     | _ => Error.bug ("prim: strange Prim.Name.t: " ^ primName)),
 	 comment_end]
       end
@@ -1497,12 +1382,12 @@
 	AppendList.appends
 	[comment_begin,
 	 (case Prim.name prim of
-	     Int_addCheck => binal (x86.Instruction.ADD, x86.Instruction.O)
-	   | Int_subCheck => binal (x86.Instruction.SUB, x86.Instruction.O)
-	   | Int_mulCheck => imul2_check x86.Instruction.O
-	   | Int_negCheck => unal (x86.Instruction.NEG, x86.Instruction.O)
-	   | Word32_addCheck => binal (x86.Instruction.ADD, x86.Instruction.C)
-	   | Word32_mulCheck => pmd (x86.Instruction.MUL, x86.Instruction.C)
+	     Int_addCheck _ => binal (x86.Instruction.ADD, x86.Instruction.O)
+	   | Int_subCheck _ => binal (x86.Instruction.SUB, x86.Instruction.O)
+	   | Int_mulCheck _ => imul2_check x86.Instruction.O
+	   | Int_negCheck _ => unal (x86.Instruction.NEG, x86.Instruction.O)
+	   | Word_addCheck _ => binal (x86.Instruction.ADD, x86.Instruction.C)
+	   | Word_mulCheck _ => pmd (x86.Instruction.MUL, x86.Instruction.C)
 	   | _ => Error.bug ("arith: strange Prim.Name.t: " ^ primName))]
       end
 



1.43      +60 -7     mlton/mlton/codegen/x86-codegen/x86-translate.fun

Index: x86-translate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-translate.fun,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- x86-translate.fun	15 May 2003 14:50:58 -0000	1.42
+++ x86-translate.fun	23 Jun 2003 04:58:58 -0000	1.43
@@ -27,8 +27,12 @@
   local
      open Machine
   in
+     structure IntSize = IntSize
+     structure IntX = IntX
      structure Label = Label
      structure Prim = Prim
+     structure RealSize = RealSize
+     structure RealX = RealX
      structure Register = Register
      structure Runtime = Runtime
      local
@@ -37,7 +41,13 @@
        structure GCField = GCField
      end
      structure Type = Type
+     structure WordSize = WordSize
+     structure WordX = WordX
   end
+
+  datatype z = datatype IntSize.t
+  datatype z = datatype RealSize.t
+  datatype z = datatype WordSize.t
   
   structure Global =
      struct
@@ -101,7 +111,6 @@
 		  x86.Operand.memloc memloc
 	       end
 	  | Cast (z, _) => toX86Operand z
-	  | Char c => x86.Operand.immediate_const_char c
 	  | Contents {oper, ty} =>
 	       let
 		  val ty = Type.toRuntime ty
@@ -128,7 +137,14 @@
 	  | Frontier => x86MLton.gcState_frontierContentsOperand ()
 	  | GCState => x86.Operand.label x86MLton.gcState_label
 	  | Global g => x86.Operand.memloc (Global.toX86MemLoc g)
-	  | Int i => x86.Operand.immediate_const_int i
+	  | Int i =>
+	       let
+		  val i' = IntX.toIntInf i
+	       in
+		  case IntX.size i of
+		     I32 => x86.Operand.immediate_const_int (IntInf.toInt i')
+		   | _ => Error.bug "FIXME"
+	       end
 	  | Label l => x86.Operand.immediate_label l
 	  | Line => x86MLton.fileLine ()
 	  | Offset {base = GCState, offset, ty} =>
@@ -185,7 +201,17 @@
 		  x86.Operand.memloc memloc
 	       end
 	  | StackTop => x86MLton.gcState_stackTopContentsOperand ()
-	  | Word w => x86.Operand.immediate_const_word w
+	  | Word w =>
+	       let
+		  val w' = WordX.toWord w
+	       in
+		  case WordX.size w of
+		     W8 =>
+			x86.Operand.immediate_const_char
+			(Word8.toChar (Word8.fromWord w'))
+		   | W16 => Error.bug "FIXME"
+		   | W32 => x86.Operand.immediate_const_word w'
+	       end
 	       
       val toX86Operand =
 	 fn operand =>
@@ -681,8 +707,7 @@
 			
 		 in
 		    case switch of
-		       Char z => simple (z, doSwitchChar)
-		     | EnumPointers {enum, pointers, test} =>
+		       EnumPointers {enum, pointers, test} =>
 			  let
 			     val size = Operand.toX86Size test
 			     val test = Operand.toX86Operand test
@@ -706,7 +731,16 @@
 					 truee = enum,
 					 falsee = pointers})}))
 			  end
-		     | Int z => simple (z, doSwitchInt)
+		     | Int {cases, default, size, test} =>
+			  (case size of
+			      I32 =>
+				 simple ({cases = (Vector.map
+						   (cases, fn (i, l) =>
+						    (IntX.toInt i, l))),
+					  default = default,
+					  test = test},
+					 doSwitchInt)
+			    | _ => Error.bug "FIXME")
 		     | Pointer {cases, default, tag, ...} =>
 			  simple ({cases = (Vector.map
 					    (cases, fn {dst, tag, ...} =>
@@ -714,7 +748,26 @@
 				   default = default,
 				   test = tag},
 				  doSwitchInt)
-		     | Word z => simple (z, doSwitchWord)
+		     | Word {cases, default, size, test} =>
+			  (case size of
+			      W8 =>
+				 simple ({cases = (Vector.map
+						   (cases, fn (w, l) =>
+						    (Word8.toChar
+						     (Word8.fromWord
+						      (WordX.toWord w)),
+						     l))),
+					  default = default,
+					  test = test},
+					 doSwitchChar)
+			    | W32 =>
+				 simple ({cases = (Vector.map
+						   (cases, fn (w, l) =>
+						    (WordX.toWord w, l))),
+					  default = default,
+					  test = test},
+					 doSwitchWord)
+			    | _ => Error.bug "FIXME")
 		 end
 	      | Goto label
 	      => (AppendList.append



1.21      +37 -59    mlton/mlton/core-ml/lookup-constant.fun

Index: lookup-constant.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/lookup-constant.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- lookup-constant.fun	14 May 2003 02:50:11 -0000	1.20
+++ lookup-constant.fun	23 Jun 2003 04:58:58 -0000	1.21
@@ -9,32 +9,7 @@
 struct
 
 open S
-
-structure Int =
-   struct
-      open Int
-      val fromString =
-	 Trace.trace ("Int.fromString", String.layout, Option.layout layout)
-	 fromString
-   end
-
-structure Word =
-   struct
-      open Word
-      val fromString =
-	 Trace.trace ("Word.fromString", String.layout, Option.layout layout)
-	 fromString
-   end
-
-structure Const =
-   struct
-      datatype t =
-	 Bool of bool
-       | Int of int
-       | Real of string
-       | String of string
-       | Word of word
-   end
+open CoreML
 
 fun unescape s =
    let
@@ -54,16 +29,16 @@
 
 structure ConstType =
    struct
-      datatype t = Bool | Int | Real | String | Word
+      datatype t = Int | Real | String | Word
    end
 datatype z = datatype ConstType.t
 
 type res = (string * ConstType.t) list
 
-fun decsConstants (decs: CoreML.Dec.t vector): res =
+fun decsConstants (decs: Dec.t vector): res =
    let
-      open CoreML
-      open Exp Dec
+      datatype z = datatype Exp.node
+      datatype z = datatype Dec.node
       fun loopExp (e: Exp.t, ac: res): res =
 	 case Exp.node e of
 	    App (e, e') => loopExp (e, loopExp (e', ac))
@@ -78,27 +53,24 @@
 			 fun strange () =
 			    Error.bug
 			    (concat ["constant with strange type: ", c])
-		      in case Prim.scheme p of
-			   Scheme.T {tyvars, ty as Type.Con (tc, ts)} =>
-			      if 0 = Vector.length tyvars
-				 then
-				    let
-				       val ty = Const.Type.make
-					        (Type.deconConst ty)
-				       val tys = [(Const.Type.bool, Bool),
-						  (Const.Type.int, Int),
-						  (Const.Type.real, Real),
-						  (Const.Type.string, String),
-						  (Const.Type.word, Word)]
-				    in case (List.peek
-					     (tys, fn (ty', _) =>
-					      Const.Type.equals (ty, ty'))) of
-				          NONE => strange ()
-					| SOME (_,t) => (c,t) :: ac
-
-				    end
-			      else strange ()
-			  | _ => strange ()
+			 val Scheme.T {tyvars, ty} = Prim.scheme p
+		      in
+			 if 0 = Vector.length tyvars
+			    then
+			       let
+				  val tys =
+				     [(Type.defaultInt, Int),
+				      (Type.defaultReal, Real),
+				      (Type.word8Vector, String),
+				      (Type.defaultWord, Word)]
+			       in case (List.peek
+					(tys, fn (ty', _) =>
+					 Type.equals (ty, ty'))) of
+				  NONE => strange ()
+				| SOME (_, t) => (c, t) :: ac
+
+			       end
+			 else strange ()
 		      end
 		 | _ => ac)
 	  | Raise {exn, ...} => loopExp (exn, ac)
@@ -163,11 +135,10 @@
 		    value, ");"]
       in
 	 case ty of
-	    Bool => doit ("%s", concat [value, "? \"true\" : \"false\""])
-	  | Int => doit ("%d", value)
+	    Int => doit ("%d", value)
 	  | Real => doit ("%.20f", value)
 	  | String => concat ["MLton_printStringEscaped (f, ", value, ");"]
-	  | Word => doit ("%x", value)
+	  | Word => doit ("%u", value)
       end),
      ["return 0;}"]],
     fn l => (Out.output (out, l); Out.newline out))
@@ -194,11 +165,18 @@
 		  | _ => Error.bug (concat ["strange constants line ", s])
 	   in
 	      case ty of
-		 Bool => Const.Bool (valOf (Bool.fromString s))
-	       | Int => Const.Int (valOf (Int.fromString s))
-	       | String => Const.String (unescape s)
-	       | Real => Const.Real s
-	       | Word => Const.Word (valOf (Word.fromString s))
+		 Int =>
+		    (case IntInf.fromString s of
+			NONE => Error.bug "strange Int constant"
+		      | SOME i => 
+			   Const.Int (IntX.make (i, IntSize.default)))
+	       | String => Const.string (unescape s)
+	       | Real => Const.Real (RealX.make (s, RealSize.default))
+	       | Word =>
+		    (case IntInf.fromString s of
+			NONE => Error.bug "strange Word constant"
+		      | SOME i => 
+			   Const.Word (WordX.fromLargeInt (i, WordSize.default)))
 	   end)
       val lookupConstant =
 	 String.memoizeList



1.4       +1 -21     mlton/mlton/core-ml/lookup-constant.sig

Index: lookup-constant.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/lookup-constant.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- lookup-constant.sig	16 Apr 2002 12:10:52 -0000	1.3
+++ lookup-constant.sig	23 Jun 2003 04:58:58 -0000	1.4
@@ -17,26 +17,6 @@
    sig
       include LOOKUP_CONSTANT_STRUCTS
 
-      structure Const:
-	 sig
-	    datatype t =
-	       Bool of bool
-	     | Int of int
-	     | Real of string
-	     | String of string
-	     | Word of word
-	 end
-
       val build: CoreML.Dec.t vector * Out.t -> unit
-      val load: CoreML.Dec.t vector * In.t -> string -> Const.t
+      val load: CoreML.Dec.t vector * In.t -> string -> CoreML.Const.t
    end
-
-
-functor TestLookupConstant (S: LOOKUP_CONSTANT): sig end = 
-struct
-
-open S
-
-val _ = Assert.assert("LookupConstant", fn () => true)
-
-end



1.5       +2 -0      mlton/mlton/front-end/import.cm

Index: import.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/import.cm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- import.cm	16 Apr 2002 12:10:52 -0000	1.4
+++ import.cm	23 Jun 2003 04:58:58 -0000	1.5
@@ -10,9 +10,11 @@
 structure Array
 structure Char
 structure Error
+structure Exn
 structure File
 structure In
 structure Int
+structure IntInf
 structure Layout
 structure List
 structure Out



1.9       +157 -167  mlton/mlton/front-end/ml.grm

Index: ml.grm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.grm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- ml.grm	28 Feb 2002 18:29:49 -0000	1.8
+++ ml.grm	23 Jun 2003 04:58:59 -0000	1.9
@@ -212,8 +212,8 @@
       EOF | SEMICOLON
     | LONGID of string
     | TYVAR of string
-    | INT of string
-    | WORD of Word32.word
+    | INT of IntInf.t
+    | WORD of IntInf.t
     | REAL of string
     | STRING of string 
     | CHAR of char
@@ -228,185 +228,168 @@
       (* primitives *)
     | PRIM | FFI | CONST | BUILD_CONST
 
-%nonterm digit of int
-       | int of int
+%nonterm
+         aexp of Exp.node
+       | andspecs of wherespec list
+       | apat of Pat.t
+       | apat' of Pat.t
+       | apatnode of Pat.node
+       | apats of Pat.t list
+       | app_exp of Exp.t list
+       | app_exp1 of Exp.t list
+       | arg_fct of Strexp.t
+       | clause of clause
+       | clauses of clause list
+       | clausesTop of clauses
+       | commapats of Pat.t list
+       | con of Con.t
+       | const of Const.t
+       | const' of Const.node
+       | constr of Con.t * Type.t option
+       | constraint of Type.t option
+       | constrs of (Con.t * Type.t option) list
+       | datBind of DatBind.t
+       | datBindNoWithtype of DatBind.t
+       | datatypeRhs of DatatypeRhs.t
+       | datatypeRhsNoWithtype of DatatypeRhs.t
+       | datatypeRhsnode of DatatypeRhs.node
+       | datatypeRhsnodeNoWithtype of DatatypeRhs.node
+       | db of db
+       | dbs of db list
+       | dec of Dec.t
+       | decnode of Dec.node
+       | decnolocal of Dec.node
+       | decs of Dec.t
+       | decsnode of Dec.node
+       | digit of int
+       | eb of eb
+       | ebrhs of EbRhs.t
+       | ebrhsnode of EbRhs.node
+       | ebs of eb list
+       | elabel of (Field.t * Exp.t)
+       | elabels of (Field.t * Exp.t) list
+       | exndesc of exndesc
+       | exndescs of exndesc list
+       | exp of Exp.t
+       | exp_2c of Exp.t list
+       | exp_list of Exp.t list
+       | exp_ps of Exp.t list
+       | expnode of Exp.node
+       | fctarg of FctArg.node
+       | fctid of Fctid.t
+       | field of Field.t
+       | fixity of Fixity.t
+       | funbinds of funbind list
+       | funbinds' of Strexp.t * funbind list
+       | funbinds'1 of funbind whereAnd
+       | funbinds'1' of funbind whereAnd
+       | funbinds'2 of funbind list
+       | funs of clauses list
        | id of string * Region.t
        | idEqual of string * Region.t
        | idNoAsterisk of string * Region.t
-       | longidNoAsterisk of string * Region.t
+       | int of IntInf.t
+       | leadExps of Topdec.t list
+       | longcon of Longcon.t
        | longid of string * Region.t
        | longidEqual of string * Region.t
-       | const of Const.t
-       | const' of Const.node
-       | vid of Vid.t
-       | vidNoEqual of Vid.t
-       | vids of Vid.t list
-       | var of Var.t
-       | con of Con.t
-       | opcon of Con.t
-       | tyvar of Tyvar.t
-       | tycon of Tycon.t
-       | field of Field.t
-       | strid of Strid.t
-       | sigid of Sigid.t
-       | sigids of Sigid.t list
-       | fctid of Fctid.t
+       | longidNoAsterisk of string * Region.t
+       | longstrid of Longstrid.t
+       | longstrideqns of Longstrid.t list
+       | longstrids of Longstrid.t list
        | longtycon of Longtycon.t
+       | longtyconeqns of Longtycon.t list
        | longvar of Longvar.t
        | longvarands of Longvar.t list
-       | longcon of Longcon.t
        | longvid of Longvid.t
        | longvidNoEqual of Longvid.t
-       | longstrid of Longstrid.t
-       | longstrids of Longstrid.t list
-
-       | tlabel of (Field.t * Type.t)
-       | tlabels  of (Field.t * Type.t) list
-       | ty' of Type.t
-       | ty'node of Type.node
-       | tuple_ty of Type.t list
-       | ty of Type.t
-       | tynode of Type.node
-       | ty1 of Type.t
-       | tyOpt of Type.t option
-       | ty0_pc of Type.t list
-
        | match of Match.t
-       | rules of rule list
-       | rule of rule
-       | elabel of (Field.t * Exp.t)
-       | elabels of (Field.t * Exp.t) list
-       | exp_ps of Exp.t list
-       | exp of Exp.t
-       | expnode of Exp.node
-       | app_exp of Exp.t list
-       | app_exp1 of Exp.t list
-       | aexp of Exp.node
+       | opaspat of Pat.t option
+       | opcon of Con.t
        | ot_list of Exp.t list
-       | exp_2c of Exp.t list
-       | exp_list of Exp.t list
-
        | pat of Pat.t
-       | patnode of Pat.node
-       | apats of Pat.t list
-       | apat of Pat.t
-       | apatnode of Pat.node
-       | apat' of Pat.t
-       | patitems of (Pat.Item.t list * bool)
-       | patitem of Pat.Item.t
        | pat_2c of Pat.t list
+       | patitem of Pat.Item.t
+       | patitems of (Pat.Item.t list * bool)
+       | patnode of Pat.node
        | pats of Pat.t list
-       | commapats of Pat.t list
-       | opaspat of Pat.t option
-	 
-       | valbindTop of vb vector * rvb vector
-       | valbind of vb list * rvb list
-       | valbindRest of vb list * rvb list
+       | program of Program.t
+       | repl of DatatypeRhs.node
+       | rule of rule
+       | rules of rule list
        | rvalbind of rvb list
        | rvalbindRest of rvb list
-       | constraint of Type.t option
-       | funs of clauses list
-       | clausesTop of clauses
-       | clauses of clause list
-       | clause of clause
-
-       | typBind of TypBind.t
-       | typBind' of TypBind.node
-
-       | tyvars of Tyvar.t vector
-       | tyvarseq of Tyvar.t vector
-       | tyvar_pc of Tyvar.t list
-       | constrs of (Con.t * Type.t option) list
-       | constr of Con.t * Type.t option
-       | ebs of eb list
-       | eb of eb
-       | ebrhs of EbRhs.t
-       | ebrhsnode of EbRhs.node
-       | fixity of Fixity.t
-
-       | dec of Dec.t
-       | decnode of Dec.node
-       | decnolocal of Dec.node
-       | decs of Dec.t
-       | decsnode of Dec.node
-
-       | specs of Spec.t
-       | spec of Spec.t
-       | specnode of Spec.node
+       | sdec of Dec.t
+       | sdecs of Dec.t
+       | sdecsPlus of Dec.t
        | sharespec of Equation.node
-
-       | strdescs of strdesc list
-       | strdescs' of strdesc whereAnd
-       | strdescs'' of strdesc whereAnd
-	 
-       | typdescs of typdesc list
-       | typdesc of typdesc
-       | typdefs of typdef list
-       | typdef of typdef
-       | valdescs of valdesc list
-       | valdesc of valdesc
-       | exndescs of exndesc list
-       | exndesc of exndesc
-       | longtyconeqns of Longtycon.t list
-       | longstrideqns of Longstrid.t list
-
-       | wherespec of wherespec
-	 
+       | sigbinds of sigbind list
+       | sigbinds' of sigbind whereAnd
+       | sigbinds'' of sigbind whereAnd
+       | sigconst of SigConst.t
        | sigexp of Sigexp.t
-       | sigexpnode of Sigexp.node
        | sigexp' of Sigexp.t
        | sigexp'node of Sigexp.node
-       | sigconst of SigConst.t
-       | arg_fct of Strexp.t
-       | sdecs of Dec.t
-       | sdec of Dec.t
-       | sdecsPlus of Dec.t
-
+       | sigexpnode of Sigexp.node
+       | sigid of Sigid.t
+       | sigids of Sigid.t list
+       | spec of Spec.t
+       | specnode of Spec.node
+       | specs of Spec.t
        | strbinds of strbind list
        | strbinds' of Strexp.t * strbind list
        | strbinds'1 of strbind whereAnd
-       | strbinds'2 of strbind list
        | strbinds'1' of strbind whereAnd
-
-       | sigbinds of sigbind list
-       | sigbinds' of sigbind whereAnd
-       | sigbinds'' of sigbind whereAnd
-
-       | wherespecs of wherespec list
-       | andspecs of wherespec list
-	 
-       | funbinds of funbind list
-       | funbinds' of Strexp.t * funbind list
-       | funbinds'1 of funbind whereAnd
-       | funbinds'1' of funbind whereAnd
-       | funbinds'2 of funbind list
-       | fctarg of FctArg.node
-	 
-       | datatypeRhs of DatatypeRhs.t
-       | datatypeRhsNoWithtype of DatatypeRhs.t
-       | datatypeRhsnode of DatatypeRhs.node
-       | datatypeRhsnodeNoWithtype of DatatypeRhs.node
-       | repl of DatatypeRhs.node
-       | datBind of DatBind.t
-       | datBindNoWithtype of DatBind.t
-       | db of db
-       | dbs of db list
-       | withtypes of TypBind.t
-       | strdecs of Strdec.t
-       | strdecsnode of Strdec.node
+       | strbinds'2 of strbind list
        | strdec of Strdec.t
        | strdecnode of Strdec.node
-       | topdec of Topdec.t
-       | topdecnode of Topdec.node
-       | topdecs of Topdec.t list
-       | leadExps of Topdec.t list
-       | program of Program.t
-
+       | strdecs of Strdec.t
+       | strdecsnode of Strdec.node
+       | strdescs of strdesc list
+       | strdescs' of strdesc whereAnd
+       | strdescs'' of strdesc whereAnd
        | strexp of Strexp.t
-       | strexpnode of Strexp.node
        | strexp1 of Strexp.t * (Sigexp.t -> SigConst.t) * Sigexp.t
        | strexp2 of Strexp.t
        | strexp2node of Strexp.node
+       | strexpnode of Strexp.node
+       | strid of Strid.t
+       | tlabel of (Field.t * Type.t)
+       | tlabels  of (Field.t * Type.t) list
+       | topdec of Topdec.t
+       | topdecnode of Topdec.node
+       | topdecs of Topdec.t list
+       | tuple_ty of Type.t list
+       | ty of Type.t
+       | ty' of Type.t
+       | ty'node of Type.node
+       | ty0_pc of Type.t list
+       | ty1 of Type.t
+       | tyOpt of Type.t option
+       | tycon of Tycon.t
+       | tynode of Type.node
+       | typBind of TypBind.t
+       | typBind' of TypBind.node
+       | typdef of typdef
+       | typdefs of typdef list
+       | typdesc of typdesc
+       | typdescs of typdesc list
+       | tyvar of Tyvar.t
+       | tyvar_pc of Tyvar.t list
+       | tyvars of Tyvar.t vector
+       | tyvarseq of Tyvar.t vector
+       | valbind of vb list * rvb list
+       | valbindRest of vb list * rvb list
+       | valbindTop of vb vector * rvb vector
+       | valdesc of valdesc
+       | valdescs of valdesc list
+       | var of Var.t
+       | vid of Vid.t
+       | vidNoEqual of Vid.t
+       | vids of Vid.t list
+       | wherespec of wherespec
+       | wherespecs of wherespec list
+       | withtypes of TypBind.t
 
 %verbose
 %pos SourcePos.t
@@ -414,7 +397,7 @@
 %noshift EOF
 
 %header (functor MLLrValsFun (structure Token: TOKEN
-			     structure Ast: AST))
+                              structure Ast: AST))
 
 %nonassoc WITHTYPE
 %right AND
@@ -811,15 +794,13 @@
 	| INFIXR digit		(Fixity.Infixr (SOME digit))
 	| NONFIX		(Fixity.Nonfix)
 
-int : INT (case Int.fromString INT of
-	      NONE => (error (reg (INTleft, INTright), "expected integer");
-		       ~1)
-	    | SOME n => n)
+int : INT (INT)
 	   
-digit : int (if int < 0 orelse int >= 10
-		then (error (reg (intleft, intright), "expected single digit") ;
-		      0)
-	     else int)
+digit : int (if IntInf.< (int, IntInf.fromInt 0)
+		orelse IntInf.>= (int, IntInf.fromInt 10)
+		then (error (reg (intleft, intright), "expected single digit")
+		      ; 0)
+	     else IntInf.toInt int)
 
 datatypeRhs : datatypeRhsnode (DatatypeRhs.makeRegion' (datatypeRhsnode,
 						       datatypeRhsnodeleft,
@@ -1066,14 +1047,23 @@
 tyvar : TYVAR 		       (Tyvar.newString (TYVAR, {left = TYVARleft,
 							 right = TYVARright}))
 field : id  		       (Field.String (#1 id))
-      | int 		       (Field.Int
-				(if int <= 0
-				    then (error (reg (intleft, intright),
-						 "expected integer")
-					  ; ~1)
-				 else
-				    int - 1))
-	(* The int - 1 is because fields are represented zero based. *)
+      | int 		       (let
+				   val int =
+				      IntInf.toInt int
+				      handle Exn.Overflow =>
+					 (error (reg (intleft, intright),
+						 "field too huge")
+					  ; 0)
+				in
+				   Field.Int
+				   (if int <= 0
+				       then (error (reg (intleft, intright),
+						    "nonpositive field")
+					     ; ~1)
+				    else
+				       int - 1)
+				end) (* int - 1 because fields are 0-based *)
+
 strid : id 		       (Strid.fromString id)
 sigid : id 		       (Sigid.fromString id)
 sigids : sigid         	       ([sigid])



1.9       +33 -26    mlton/mlton/front-end/ml.lex

Index: ml.lex
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.lex,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- ml.lex	28 Feb 2002 18:29:49 -0000	1.8
+++ ml.lex	23 Jun 2003 04:58:59 -0000	1.9
@@ -87,26 +87,27 @@
 
 fun tok' (t, x, s, l) = tok (fn (l, r) => t (x, l, r), s, l, l + size x)
 
-local 
-   fun make (scan, token, default, msg) (radix, str, source, left) =
-      let
-	 val right = left + size str
-      in
-	 token ((case StringCvt.scanString (scan radix) str of
-		    NONE => (error (source, left, right,
-				    concat ["invalid ", msg, " constant"])
-			     ; default)
-		  | SOME n => n)
-		handle Overflow =>
-		   (error (source, left, right,
-			   concat [msg, " constant out of range"])
-		    ; default),
-		   Source.getPos (source, left),
-		   Source.getPos (source, right))
-      end
-in 
-   val makeWord = make (Word32.scan, Tokens.WORD, 0w0, "word")
-end
+fun scanInt (yytext: string,
+	     start: int,
+	     radix: StringCvt.radix,
+	     negate: bool,
+	     makeToken,
+	     source,
+	     yypos: int) =
+   let
+      val str = String.dropPrefix (yytext, start)
+      val left = yypos
+      val right = left + size str
+   in
+      makeToken ((case (StringCvt.scanString
+			(fn r => IntInf.scan (radix, r)) str) of
+		     NONE => (error (source, left, right,
+				     concat ["invalid constant: ", yytext])
+			      ; IntInf.fromInt 0)
+		   | SOME n => if negate then IntInf.~ n else n),
+		 Source.getPos (source, left),
+		 Source.getPos (source, right))
+   end
 
 %% 
 %reject
@@ -208,12 +209,18 @@
 			 "*" => tok (Tokens.ASTERISK, source, yypos, yypos + 1)
 		       | _ => tok' (Tokens.LONGID, yytext, source, yypos));
 <INITIAL>{real}	=> (tok' (Tokens.REAL, yytext, source, yypos));
-<INITIAL>{num}	=> (tok' (Tokens.INT, yytext, source, yypos));
-<INITIAL>~{num}	=> (tok' (Tokens.INT, yytext, source, yypos));
-<INITIAL>"0x"{hexnum} => (tok' (Tokens.INT, yytext, source, yypos));
-<INITIAL>"~0x"{hexnum} => (tok' (Tokens.INT, yytext, source, yypos));
-<INITIAL>"0w"{num} => (makeWord (StringCvt.DEC, yytext, source, yypos));
-<INITIAL>"0wx"{hexnum} => (makeWord (StringCvt.HEX, yytext, source, yypos));
+<INITIAL>{num}	=> (scanInt (yytext, 0, StringCvt.DEC, false, Tokens.INT,
+			     source, yypos));
+<INITIAL>~{num}	=> (scanInt (yytext, 1, StringCvt.DEC, true, Tokens.INT,
+			     source, yypos));
+<INITIAL>"0x"{hexnum} => (scanInt (yytext, 2, StringCvt.HEX, false, Tokens.INT,
+				   source, yypos));
+<INITIAL>"~0x"{hexnum} => (scanInt (yytext, 3, StringCvt.HEX, true, Tokens.INT,
+				    source, yypos));
+<INITIAL>"0w"{num} => (scanInt (yytext, 2, StringCvt.DEC, false, Tokens.WORD,
+				source, yypos));
+<INITIAL>"0wx"{hexnum} => (scanInt (yytext, 3, StringCvt.HEX, false, Tokens.WORD,
+				    source, yypos));
 <INITIAL>\"	=> (charlist := [""]
                     ; stringStart := Source.getPos (source, yypos)
                     ; stringtype := true



1.52      +33 -12    mlton/mlton/main/compile.sml

Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -r1.51 -r1.52
--- compile.sml	14 May 2003 02:50:12 -0000	1.51
+++ compile.sml	23 Jun 2003 04:58:59 -0000	1.52
@@ -13,15 +13,30 @@
 (*---------------------------------------------------*)
    
 structure Ast = Ast ()
-structure Atoms = Atoms (structure Ast = Ast)
+local
+   open Ast.Tycon
+in
+   structure IntSize = IntSize
+   structure RealSize = RealSize
+   structure WordSize = WordSize
+end
+structure Atoms = Atoms (structure Ast = Ast
+			 structure IntSize = IntSize
+			 structure RealSize = RealSize
+			 structure WordSize = WordSize)
+local
+   open Atoms
+in
+   structure Const = Const
+   structure IntX = IntX
+end
 structure CoreML = CoreML (open Atoms
 			   structure Type = Prim.Type)
 structure Xml = Xml (open Atoms)
 structure Sxml = Sxml (open Xml)
 structure Ssa = Ssa (open Atoms)
-structure Machine = Machine (structure Label = Ssa.Label
-			     structure Prim = Atoms.Prim
-			     structure SourceInfo = Ssa.SourceInfo)
+structure Machine = Machine (open Atoms
+			     structure Label = Ssa.Label)
 local
    open Machine
 in
@@ -40,6 +55,11 @@
 structure Infer = Infer (structure CoreML = CoreML
 			 structure LookupConstant = LookupConstant
 			 structure Xml = Xml)
+local
+   open Infer
+in
+   structure BuildConst = BuildConst
+end
 structure Monomorphise = Monomorphise (structure Xml = Xml
 				       structure Sxml = Sxml)
 structure ClosureConvert = ClosureConvert (structure Ssa = Ssa
@@ -342,15 +362,16 @@
 			       CoreML.Program.layoutStats coreML)
       val buildConstants =
 	 let
-	    datatype z = datatype LookupConstant.Const.t
+	    val bool = BuildConst.Bool
+	    val int = BuildConst.Int
 	    open Control
 	 in
-	    [("Exn_keepHistory", Bool (!exnHistory)),
-	     ("MLton_detectOverflow", Bool (!detectOverflow)),
-	     ("MLton_native", Bool (!Native.native)),
-	     ("MLton_profile_isOn", Bool (!profile <> ProfileNone)),
-	     ("MLton_safe", Bool (!safe)),
-	     ("TextIO_bufSize", Int (!textIOBufSize))]
+	    [("Exn_keepHistory", bool (!exnHistory)),
+	     ("MLton_detectOverflow", bool (!detectOverflow)),
+	     ("MLton_native", bool (!Native.native)),
+	     ("MLton_profile_isOn", bool (!profile <> ProfileNone)),
+	     ("MLton_safe", bool (!safe)),
+	     ("TextIO_bufSize", int (!textIOBufSize))]
 	 end
       fun lookupBuildConstant (c: string) =
 	 case List.peek (buildConstants, fn (c', _) => c = c') of
@@ -365,7 +386,7 @@
 	 let
 	    fun get s =
 	       case lookupConstant s of
-		  LookupConstant.Const.Int n => n
+		  Const.Int i => IntX.toInt i
 		| _ => Error.bug "GC_state offset must be an int"
 	 in
 	    Runtime.GCField.setOffsets



1.21      +7 -9      mlton/mlton/ssa/analyze.fun

Index: analyze.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/analyze.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- analyze.fun	11 Jan 2003 00:34:40 -0000	1.20
+++ analyze.fun	23 Jun 2003 04:58:59 -0000	1.21
@@ -14,7 +14,7 @@
    
 fun 'a analyze
    {coerce, conApp, const, copy,
-    filter, filterChar, filterInt, filterWord, filterWord8,
+    filter, filterInt, filterWord,
     fromType, layout, primApp,
     program = Program.T {main, datatypes, globals, functions},
     select, tuple, useFromTypeOnBinds} =
@@ -131,19 +131,17 @@
 			then ()
 		     else Error.bug (concat [Label.toString j,
 					     " must be nullary"])
-		  fun doit (l, filter) =
-		     (filter test
-		      ; Vector.foreach (l, fn (_, j) => ensureNullary j))
+		  fun doit (s, cs, filter) =
+		     (filter (test, s)
+		      ; Vector.foreach (cs, fn (_, j) => ensureNullary j))
 		  datatype z = datatype Cases.t
 		  val _ =
 		     case cases of
-			Char l => doit (l, filterChar)
-		      | Con cases =>
+			Con cases =>
 			   Vector.foreach (cases, fn (c, j) =>
 					   filter (test, c, labelValues j))
-		      | Int l => doit (l, filterInt)
-		      | Word l => doit (l, filterWord)
-		      | Word8 l => doit (l, filterWord8)
+		      | Int (s, cs) => doit (s, cs, filterInt)
+		      | Word (s, cs) => doit (s, cs, filterWord)
 		  val _ = Option.app (default, ensureNullary)
 	       in ()
 	       end



1.9       +2 -4      mlton/mlton/ssa/analyze.sig

Index: analyze.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/analyze.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- analyze.sig	7 Jul 2002 21:41:51 -0000	1.8
+++ analyze.sig	23 Jun 2003 04:58:59 -0000	1.9
@@ -25,10 +25,8 @@
 	  const: Const.t -> 'a,
 	  copy: 'a -> 'a,
 	  filter: 'a * Con.t * 'a vector -> unit,
-	  filterChar: 'a -> unit,
-	  filterInt: 'a -> unit,
-	  filterWord: 'a -> unit,
-	  filterWord8: 'a -> unit,
+	  filterInt: 'a * IntSize.t -> unit,
+	  filterWord: 'a * WordSize.t -> unit,
 	  fromType: Type.t -> 'a,
 	  layout: 'a -> Layout.t,
 	  primApp: {args: 'a vector,



1.23      +2 -2      mlton/mlton/ssa/common-subexp.fun

Index: common-subexp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/common-subexp.fun,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- common-subexp.fun	19 Dec 2002 23:43:35 -0000	1.22
+++ common-subexp.fun	23 Jun 2003 04:58:59 -0000	1.23
@@ -206,10 +206,10 @@
 					   case Prim.name prim of
 					      Array_array => knownLength (arg ())
 					    | Array_length => length ()
-					    | Vector_fromArray => conv ()
-					    | String_fromWord8Vector => conv ()
+					    | Array_toVector => conv ()
 					    | String_toWord8Vector => conv ()
 					    | Vector_length => length ()
+					    | Word8Vector_toString => conv ()
 					    | _ => if Prim.isFunctional prim
 						      then doit ()
 						   else keep ()



1.16      +39 -52    mlton/mlton/ssa/constant-propagation.fun

Index: constant-propagation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/constant-propagation.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- constant-propagation.fun	18 Apr 2003 22:45:00 -0000	1.15
+++ constant-propagation.fun	23 Jun 2003 04:58:59 -0000	1.16
@@ -61,8 +61,8 @@
 	    fun isZero (T {const, ...}) =
 	       case !const of
 		  Const c =>
-		     (case Const.node c of
-			 Const.Node.Int 0 => true
+		     (case c of
+			 Const.Int i => IntX.isZero i
 		       | _ => false)
 		| _ => false
 
@@ -398,41 +398,44 @@
 		    in new (Const c', Type.ofConst c)
 		    end
 
-      val zero = const (S.Const.fromInt 0)
+      val zero = IntSize.memoize (fn s => const (S.Const.int (IntX.zero s)))
 
       fun deconst v =
 	 case value v of
 	    Const c => c
 	  | _ => Error.bug "deconst"
+
+      fun constToEltLength (c, err) =
+	 let
+	    val v = case c of
+	       Sconst.Word8Vector v => v
+	     | _ => Error.bug err 
+	    val n = Vector.length v
+	    val x = if n = 0
+		       then const' (Const.unknown (), Type.word8)
+		    else let
+			    val w = Vector.sub (v, 0)
+			 in
+			    if Vector.forall (v, fn w' => w = w')
+			       then const (Sconst.word8 w)
+			    else const' (Const.unknown (), Type.word8)
+			 end
+	    val n =
+	       const (Sconst.Int (IntX.make
+				  (IntInf.fromInt n, IntSize.default)))
+	 in
+	    {elt = x, length = n}
+	 end
 	       
       local
 	 fun make (err, sel) v =
 	    case value v of
 	       Vector fs => sel fs
-	     | Const (Const.T {const = ref (Const.Const c), coercedTo}) =>
-		  let
-		     val s = case Sconst.node c of
-		                Sconst.Node.String s => s
-			      | _ => Error.bug err 
-		     val n = String.length s
-		     val x = if n = 0
-			        then const' (Const.unknown(), Type.char)
-			     else let
-				     val c = String.sub (s, 0)
-				  in
-				     if String.forall (s, fn c' => c = c')
-				        then (const o Sconst.make)
-					     (Sconst.Node.Char c, 
-					      Sconst.Type.char)
-				     else const' (Const.unknown(), Type.char)
-				  end
-		     val n = (const o Sconst.make)
-		             (Sconst.Node.Int n, Sconst.Type.int)
-		  in
-		     sel {length = n, elt = x}
-		  end
+	     | Const (Const.T {const = ref (Const.Const c), ...}) =>
+		  sel (constToEltLength (c, err))
 	     | _ => Error.bug err
-      in val devector = make ("devector", #elt)
+      in
+	 val devector = make ("devector", #elt)
 	 val vectorLength = make ("vectorLength", #length)
       end
 
@@ -496,13 +499,13 @@
 		  (case Type.dest t of
 		      Type.Array t => Array {birth = arrayBirth (),
 					     elt = loop t,
-					     length = loop Type.int}
+					     length = loop Type.defaultInt}
 		    | Type.Datatype _ => Datatype (data ())
 		    | Type.Ref t => Ref {arg = loop t,
 					 birth = refBirth ()}
 		    | Type.Tuple ts => Tuple (Vector.map (ts, loop))
 		    | Type.Vector t => Vector {elt = loop t,
-					       length = loop Type.int}
+					       length = loop Type.defaultInt}
 		    | Type.Weak t => Weak (loop t)
 		    | _ => Const (const ()), 
 		   t)
@@ -662,28 +665,13 @@
 		   | (Tuple vs, Tuple vs') => coerces {froms = vs, tos = vs'}
 		   | (Weak v, Weak v') => unify (v, v')
 		   | (Const (Const.T {const = ref (Const.Const c), coercedTo}),
-		      Vector {length, elt}) =>
+		      Vector {elt, length}) =>
 			let
-			   val s = case Sconst.node c of
-			              Sconst.Node.String s => s
-				    | _ => error ()
-			   val n = String.length s
-			   val x = if n = 0
-			              then const' (Const.unknown(), Type.char)
-				   else let
-					   val c = String.sub (s, 0)
-					in
-					   if String.forall (s, fn c' => c = c')
-					      then (const o Sconst.make)
-						   (Sconst.Node.Char c, 
-						    Sconst.Type.char)
-					   else const' (Const.unknown(), Type.char)
-					end
-			   val n = (const o Sconst.make)
-			           (Sconst.Node.Int n, Sconst.Type.int)
+			   val {elt = elt', length = length'} =
+			      Value.constToEltLength (c, "coerce")
 			in
-			   coerce {from = x, to = elt}
-			   ; coerce {from = n, to = length}
+			   coerce {from = elt', to = elt}
+			   ; coerce {from = length', to = length}
 			end
 		   | (_, _) => error ()
 		end) arg
@@ -785,9 +773,11 @@
 	    in
 	       case Prim.name prim of
 		  Array_array => array (arg 0, bear ())
-		| Array_array0Const => array (zero, Birth.here ())
+		| Array_array0Const =>
+		     array (zero IntSize.default, Birth.here ())
 		| Array_length => arrayLength (arg 0)
 		| Array_sub => dearray (arg 0)
+		| Array_toVector => vectorFromArray (arg 0)
 		| Array_update => update (arg 0, arg 2)
 		| Ref_assign =>
 		     (coerce {from = arg 1, to = deref (arg 0)}; unit ())
@@ -802,7 +792,6 @@
 		     in
 			r
 		     end
-		| Vector_fromArray => vectorFromArray (arg 0)
 		| Vector_length => vectorLength (arg 0)
 		| Vector_sub => devector (arg 0)
 		| Weak_get => deweak (arg 0)
@@ -847,10 +836,8 @@
 		  const = Value.const,
 		  copy = Value.fromType o Value.ty,
 		  filter = filter,
-		  filterChar = filterIgnore,
 		  filterInt = filterIgnore,
 		  filterWord = filterIgnore,
-		  filterWord8 = filterIgnore,
 		  fromType = Value.fromType,
 		  layout = Value.layout,
 		  primApp = primApp,



1.14      +10 -16    mlton/mlton/ssa/direct-exp.fun

Index: direct-exp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- direct-exp.fun	11 Jan 2003 00:34:40 -0000	1.13
+++ direct-exp.fun	23 Jun 2003 04:58:59 -0000	1.14
@@ -60,13 +60,11 @@
 	     ty: Type.t}
  | Var of Var.t * Type.t
 and cases =
-   Char of (char * t) vector
- | Con of {con: Con.t,
+   Con of {con: Con.t,
 	   args: (Var.t * Type.t) vector,
 	   body: t} vector
- | Int of (int * t) vector
- | Word of (word * t) vector
- | Word8 of (Word8.t * t) vector
+ | Int of IntSize.t * (IntX.t * t) vector
+ | Word of WordSize.t * (WordX.t * t) vector
 
 val arith = Arith
 val call = Call
@@ -113,7 +111,7 @@
    val falsee = make Con.falsee
 end
 
-val int = const o Const.fromInt
+val int = const o Const.int
    
 fun eq (e1, e2, ty) =
    primApp {prim = Prim.eq,
@@ -154,15 +152,13 @@
 			   doit (v, (fn (x, e) => (f x, e)))
 		     in
 			case cases of
-			   Char v => simple (v, Char.layout)
-			 | Con v =>
+			   Con v =>
 			      doit (v, fn {con, args, body} =>
 				    (seq [Con.layout con,
 					  Vector.layout (Var.layout o #1) args],
 				     body))
-			 | Int v => simple (v, Int.layout)
-			 | Word v => simple (v, Word.layout)
-			 | Word8 v => simple (v, Word8.layout)
+			 | Int (_, v) => simple (v, IntX.layout)
+			 | Word (_, v) => simple (v, WordX.layout)
 		     end,
 			case default of
 			   NONE => empty
@@ -433,16 +429,14 @@
 					     (c, newLabel0 (e, h, k)))
 			   in
 			      case cases of
-				 Char v => Cases.Char (doit v)
-			       | Con v =>
+				 Con v =>
 				    Cases.Con
 				    (Vector.map
 				     (v, fn {con, args, body} =>
 				      (con,
 				       newLabel (args, body, h, k))))
-			       | Int v => Cases.Int (doit v)
-			       | Word v => Cases.Word (doit v)
-			       | Word8 v => Cases.Word8 (doit v)
+			       | Int (s, v) => Cases.Int (s, doit v)
+			       | Word (s, v) => Cases.Word (s, doit v)
 			   end}})
 	       end
 	  | ConApp {con, args, ty} =>



1.12      +4 -6      mlton/mlton/ssa/direct-exp.sig

Index: direct-exp.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- direct-exp.sig	10 Jan 2003 18:36:13 -0000	1.11
+++ direct-exp.sig	23 Jun 2003 04:58:59 -0000	1.12
@@ -22,13 +22,11 @@
 	   type t
 
 	   datatype cases =
-	      Char of (char * t) vector
-	    | Con of {con: Con.t,
+	      Con of {con: Con.t,
 		      args: (Var.t * Type.t) vector,
 		      body: t} vector
-	    | Int of (int * t) vector
-	    | Word of (word * t) vector
-	    | Word8 of (Word8.t * t) vector
+	    | Int of IntSize.t * (IntX.t * t) vector
+	    | Word of WordSize.t * (WordX.t * t) vector
 
 	   val arith: {prim: Prim.t,
 		       args: t vector,
@@ -59,7 +57,7 @@
 			 ty: Type.t,
 			 catch: Var.t * Type.t,
 			 handler: t} -> t
-	   val int: int -> t
+	   val int: IntX.t -> t
 	   val layout: t -> Layout.t
 	   val lett: {decs: {var: Var.t, exp: t} list,
 		      body: t} -> t



1.15      +26 -23    mlton/mlton/ssa/poly-equal.fun

Index: poly-equal.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/poly-equal.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- poly-equal.fun	2 Jan 2003 17:45:21 -0000	1.14
+++ poly-equal.fun	23 Jun 2003 04:58:59 -0000	1.15
@@ -44,10 +44,10 @@
       open DirectExp
 
       fun add (e1: t, e2: t): t =
-	 primApp {prim = Prim.intAdd,
+	 primApp {prim = Prim.intAdd IntSize.default,
 		  targs = Vector.new0 (),
 		  args = Vector.new2 (e1, e2),
-		  ty = Type.int}
+		  ty = Type.defaultInt}
 
       fun conjoin (e1: t, e2: t): t =
 	 casee {test = e1,
@@ -199,18 +199,19 @@
 		        let
 			  fun length x =
 			     Dexp.primApp {prim = Prim.vectorLength,
-						targs = Vector.new1 ty,
-						args = Vector.new1 x,
-						ty = Type.int}
+					   targs = Vector.new1 ty,
+					   args = Vector.new1 x,
+					   ty = Type.defaultInt}
 			in
 			   Dexp.disjoin
 			   (Dexp.eq (Dexp.var v1, Dexp.var v2, vty),
 			    Dexp.conjoin
-			    (Dexp.eq (length dv1, length dv2, Type.int),
+			    (Dexp.eq (length dv1, length dv2, Type.defaultInt),
 			     Dexp.call
 			     {func = loop,
 			      args = (Vector.new4 
-				      (Dexp.int 0, length dv1, dv1, dv2)),
+				      (Dexp.int (IntX.zero IntSize.default),
+				       length dv1, dv1, dv2)),
 			      ty = Type.bool}))
 			end
 		     val (start, blocks) = Dexp.linearize (body, Handler.Caller)
@@ -225,8 +226,8 @@
 				     start = start}
 		  end
 		  local
-		     val i = (Var.newNoname (), Type.int)
-		     val len = (Var.newNoname (), Type.int)
+		     val i = (Var.newNoname (), Type.defaultInt)
+		     val len = (Var.newNoname (), Type.defaultInt)
 		     val v1 = (Var.newNoname (), vty)
 		     val v2 = (Var.newNoname (), vty)
 		     val args = Vector.new4 (i, len, v1, v2)
@@ -241,17 +242,19 @@
 					    targs = Vector.new1 ty,
 					    args = Vector.new2 (v, i),
 					    ty = ty}
+			   val args =
+			      Vector.new4 
+			      (Dexp.add
+			       (di, Dexp.int (IntX.one IntSize.default)),
+			       dlen, dv1, dv2)
 			in
 			   Dexp.disjoin 
-			   (Dexp.eq (di, dlen, Type.int),
+			   (Dexp.eq (di, dlen, Type.defaultInt),
 			    Dexp.conjoin
 			    (equalExp (sub (dv1, di), sub (dv2, di), ty),
-			     Dexp.call
-			     {func = loop,
-			      args = (Vector.new4 
-				      (Dexp.add (di, Dexp.int 1),
-				       dlen, dv1, dv2)),
-			      ty = Type.bool}))
+			     Dexp.call {args = args,
+					func = loop,
+					ty = Type.bool}))
 			end
 		     val (start, blocks) = Dexp.linearize (body, Handler.Caller)
 		     val blocks = Vector.fromList blocks
@@ -283,14 +286,13 @@
 	 in
 	    case Type.dest ty of
 	       Type.Array _ => eq ()
-	     | Type.Char => eq ()
 	     | Type.Datatype tycon =>
 		  if isEnum tycon orelse hasConstArg ()
 		     then eq ()
 		  else Dexp.call {func = equalFunc tycon,
 				  args = Vector.new2 (dx1, dx2),
 				  ty = Type.bool}
-	     | Type.Int => eq ()
+	     | Type.Int _ => eq ()
 	     | Type.IntInf => if hasConstArg ()
 				 then eq ()
 			      else prim (Prim.intInfEqual, Vector.new0 ())
@@ -320,8 +322,7 @@
 		  Dexp.call {func = vectorEqualFunc ty,
 			     args = Vector.new2 (dx1, dx2),
 			     ty = Type.bool}
-	     | Type.Word => eq ()
-	     | Type.Word8 => eq ()
+	     | Type.Word _ => eq ()
 	     | _ => Error.bug "equal of strange type"
 	 end
       fun loopBind (Statement.T {var, ty, exp}) =
@@ -330,13 +331,15 @@
 	 in
 	    case exp of
 	       Const c =>
-		  (case Const.node c of
-		      Const.Node.IntInf i =>
+		  (case c of
+		      Const.Int _ => const ()
+		    | Const.IntInf i =>
 			 if Const.SmallIntInf.isSmall i
 			    then const ()
 			 else ()
 		    | _ => ())
-	     | ConApp {args, ...} => if Vector.isEmpty args then const () else ()
+	     | ConApp {args, ...} =>
+		  if Vector.isEmpty args then const () else ()
 	     | _ => ()
 	 end
       val _ = Vector.foreach (globals, loopBind)



1.12      +51 -64    mlton/mlton/ssa/redundant-tests.fun

Index: redundant-tests.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/redundant-tests.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- redundant-tests.fun	19 Dec 2002 23:43:36 -0000	1.11
+++ redundant-tests.fun	23 Jun 2003 04:58:59 -0000	1.12
@@ -38,7 +38,7 @@
 	 fn Const c => Const.layout c
 	  | Var x => Var.layout x
 
-      val zero = Const (Const.fromInt 0)
+      val zero = IntSize.memoize (fn s => Const (Const.int (IntX.zero s)))
       val equals =
 	 fn (Const c, Const c') => Const.equals (c, c')
 	  | (Var x, Var x') => Var.equals (x, x')
@@ -117,37 +117,19 @@
 	    datatype z = datatype Prim.Name.t
 	 in
 	    case Prim.name prim of
-	       Char_gt => doit' LT
-	     | Char_ge => doit' LE
-	     | Char_lt => doit LT
+	       Char_ge => doit' LE
+	     | Char_gt => doit' LT
 	     | Char_le => doit LE
-	     | Int_gt => doit' LT
-	     | Int_ge => doit' LE
-	     | Int_geu =>
-		  Or (Fact.T {rel = LT,
-			      lhs = arg 0,
-			      rhs = Oper.zero},
-		      Fact.T {rel = LE,
-			      lhs = arg 1,
-			      rhs = arg 0})
-	     | Int_gtu =>
-		  Or (Fact.T {rel = LT,
-			      lhs = arg 0,
-			      rhs = Oper.zero},
-		      Fact.T {rel = LT,
-			      lhs = arg 1,
-			      rhs = arg 0})
-	     | Int_lt => doit LT
-	     | Int_le => doit LE
+	     | Char_lt => doit LT
+	     | Int_ge _ => doit' LE
+	     | Int_gt _ => doit' LT
+	     | Int_le _ => doit LE
+	     | Int_lt _ => doit LT
 	     | MLton_eq => doit EQ
-	     | Word32_ge => doit' LE
-	     | Word32_gt => doit' LT
-	     | Word32_le => doit LE
-	     | Word32_lt => doit LT
-	     | Word8_ge => doit' LE
-	     | Word8_gt => doit' LT
-	     | Word8_le => doit LE
-	     | Word8_lt => doit LT
+	     | Word_ge _ => doit' LE
+	     | Word_gt _ => doit' LT
+	     | Word_le _ => doit LE
+	     | Word_lt _ => doit LT
 	     | _ => None
 	 end
       fun setConst (x, c) = setVarInfo (x, Const c)
@@ -172,9 +154,10 @@
 	 val (falseVar, f) = make Con.falsee
       end
       val one = Var.newNoname ()
-      val oneS = Statement.T {exp = Exp.Const (Const.fromInt 1),
-			      var = SOME one,
-			      ty = Type.int}
+      val oneS =
+	 Statement.T {exp = Exp.Const (Const.int (IntX.one IntSize.default)),
+		      ty = Type.defaultInt,
+		      var = SOME one}
       val globals = Vector.concat [Vector.new3 (t, f, oneS), globals]
       val shrink = shrinkFunction globals
       val numSimplified = ref 0
@@ -373,7 +356,7 @@
 			       success: Label.t)
 		       : Statement.t vector * Transfer.t =
 		       let
-			  fun simplify (prim: Prim.t, x: Var.t) =
+			  fun simplify (prim: Prim.t, x: Var.t, s: IntSize.t) =
 			     let
 				val res = Var.newNoname ()
 			     in
@@ -384,75 +367,79 @@
 				   {exp = PrimApp {args = Vector.new2 (x, one),
 						   prim = prim,
 						   targs = Vector.new0 ()},
-				    ty = Type.int,
+				    ty = Type.int s,
 				    var = SOME res})],
 				 Goto {args = Vector.new1 res,
 				       dst = success})
 			     end
-			  fun add1 (x: Var.t) =
+			  fun add1 (x: Var.t, s: IntSize.t) =
 			     if isFact (label, fn Fact.T {lhs, rel, rhs} =>
 					case (lhs, rel, rhs) of
 					   (Oper.Var x', Rel.LT, _) =>
 					      Var.equals (x, x')
 					 | (Oper.Var x', Rel.LE, Oper.Const c) =>
 					      Var.equals (x, x')
-					      andalso (case Const.node c of
-							  Const.Node.Int c =>
-							     c < Int.maxInt
-							| _ => Error.bug "strange fact")
+					      andalso
+					      (case c of
+						  Const.Int i =>
+						     IntX.<
+						     (i, IntX.max (IntX.size i))
+						| _ => Error.bug "strange fact")
 					 | _ => false)
-				then simplify (Prim.intAdd, x)
+				then simplify (Prim.intAdd s, x, s)
 			     else noChange
-			  fun sub1 (x: Var.t) =
+			  fun sub1 (x: Var.t, s: IntSize.t) =
 			     if isFact (label, fn Fact.T {lhs, rel, rhs} =>
 					case (lhs, rel, rhs) of
 					   (_, Rel.LT, Oper.Var x') =>
 					      Var.equals (x, x')
 					 | (Oper.Const c, Rel.LE, Oper.Var x') =>
 					      Var.equals (x, x')
-					      andalso (case Const.node c of
-							  Const.Node.Int c =>
-							     c > Int.minInt
-							| _ => Error.bug "strange fact")
+					      andalso
+					      (case c of
+						  Const.Int i =>
+						     IntX.>
+						     (i, IntX.min (IntX.size i))
+						| _ => Error.bug "strange fact")
 					 | _ => false)
-				then simplify (Prim.intSub, x)
+				then simplify (Prim.intSub s, x, s)
 			     else noChange
-			  fun add (c: Const.t, x: Var.t) =
-			     case Const.node c of
-				Const.Node.Int i =>
-				   if i = 1
-				      then add1 x
-				   else if i = ~1
-					   then sub1 x
+			  fun add (c: Const.t, x: Var.t, s: IntSize.t) =
+			     case c of
+				Const.Int i =>
+				   if IntX.isOne i
+				      then add1 (x, s)
+				   else if IntX.isNegOne i
+					   then sub1 (x, s)
 					else noChange
 			      | _ => Error.bug "add of strange const"
 			  datatype z = datatype Prim.Name.t
 		       in
 			  case Prim.name prim of
-			     Int_addCheck =>
+			     Int_addCheck s =>
 				let
 				   val x1 = Vector.sub (args, 0)
 				   val x2 = Vector.sub (args, 1)
 				in
 				   case varInfo x1 of
-				      Const c => add (c, x2)
+				      Const c => add (c, x2, s)
 				    | _ => (case varInfo x2 of
-					       Const c => add (c, x1)
+					       Const c => add (c, x1, s)
 					     | _ => noChange)
 				end
-			   | Int_subCheck =>
+			   | Int_subCheck s =>
 				let
 				   val x1 = Vector.sub (args, 0)
 				   val x2 = Vector.sub (args, 1)
 				in
 				   case varInfo x2 of
 				      Const c =>
-					 (case Const.node c of
-					     Const.Node.Int i =>
-						if i = ~1
-						   then add1 x1
-						else if i = 1
-							then sub1 x1
+					 (case c of
+					     Const.Int i =>
+						if IntX.isNegOne i
+						   then add1 (x1, s)
+						else if IntX.isOne i
+							then sub1 (x1, s)
 						     else noChange
 					   | _ =>
 						Error.bug "sub of strage const")



1.24      +4 -6      mlton/mlton/ssa/remove-unused.fun

Index: remove-unused.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/remove-unused.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- remove-unused.fun	11 Jan 2003 00:34:40 -0000	1.23
+++ remove-unused.fun	23 Jun 2003 04:58:59 -0000	1.24
@@ -491,12 +491,10 @@
 		  fun doit l = (Vector.foreach (l, fn (_, l) => visitLabel l);
 				Option.app (default, visitLabel))
 		in
-		  case cases 
-		    of Cases.Char l => doit l
-		     | Cases.Int l => doit l
-		     | Cases.Word l => doit l
-		     | Cases.Word8 l => doit l
-		     | Cases.Con cases
+		  case cases of
+		     Cases.Int (_, cs) => doit cs
+		   | Cases.Word (_, cs) => doit cs
+		   | Cases.Con cases
 		     => if Vector.length cases = 0
 			  then Option.app (default, visitLabel)
 			  else let



1.31      +10 -15    mlton/mlton/ssa/shrink.fun

Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/shrink.fun,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- shrink.fun	18 Jun 2003 17:40:50 -0000	1.30
+++ shrink.fun	23 Jun 2003 04:58:59 -0000	1.31
@@ -133,7 +133,7 @@
       and aux =
 	 Block
        | Bug
-       | Case of {cases: Label.t Cases.t,
+       | Case of {cases: Cases.t,
 		  default: Label.t option}
        | Goto of {dst: t,
 		  args: Positions.t}
@@ -190,7 +190,7 @@
    Trace.trace ("Prim.apply",
 		fn (p, args, _: VarInfo.t * VarInfo.t -> bool) =>
 		let open Layout
-		in seq [Prim.layout p,
+		in seq [Prim.layout p, str " ",
 			List.layout (Prim.ApplyArg.layout
 				     (Var.layout o VarInfo.var)) args]
 		end,
@@ -661,8 +661,7 @@
 					    {con = con,
 					     hasArg = not (Vector.isEmpty args)}
 				      else Prim.ApplyArg.Var vi
-				 | Value.Const c =>
-				      Prim.ApplyArg.Const (Const.node c)
+				 | Value.Const c => Prim.ApplyArg.Const c
 				 | _ => Prim.ApplyArg.Var vi)
 			  | _ => Prim.ApplyArg.Var vi)
 		  in
@@ -1015,19 +1014,15 @@
 			   case (VarInfo.value test, cases) of
 			      (SOME (Value.Const c), _) =>
 				 let
-				    fun doit (l, z) =
-				       findCase (l, fn z' => z = z',
+				    fun doit (l, z, eq) =
+				       findCase (l, fn z' => eq (z, z'),
 						 Vector.new0 ())
 				 in
-				    case (cases, Const.node c) of
-				       (Cases.Char l, Const.Node.Char c) =>
-					  doit (l, c)
-				     | (Cases.Int l, Const.Node.Int i) =>
-					  doit (l, i)
-				     | (Cases.Word l, Const.Node.Word w) =>
-					  doit (l, w)
-				     | (Cases.Word8 l, Const.Node.Word w) =>
-					  doit (l, Word8.fromWord w)
+				    case (cases, c) of
+				       (Cases.Int (_, cs), Const.Int i) =>
+					  doit (cs, i, IntX.equals)
+				     | (Cases.Word (_, cs), Const.Word w) =>
+					  doit (cs, w, WordX.equals)
 				     | _ =>
 					  Error.bug "strange constant for cases"
 				 end



1.59      +132 -44   mlton/mlton/ssa/ssa-tree.fun

Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.58
retrieving revision 1.59
diff -u -r1.58 -r1.59
--- ssa-tree.fun	11 May 2003 23:44:01 -0000	1.58
+++ ssa-tree.fun	23 Jun 2003 04:58:59 -0000	1.59
@@ -9,6 +9,9 @@
 struct
 
 open S
+datatype z = datatype IntSize.t
+datatype z = datatype RealSize.t
+datatype z = datatype WordSize.t
 
 structure Type =
    struct
@@ -23,20 +26,18 @@
 	       
       datatype dest =
 	  Array of t
-	| Char
 	| Datatype of Tycon.t
-	| Int
+	| Int of IntSize.t
 	| IntInf
 	| Pointer
 	| PreThread
-	| Real
+	| Real of RealSize.t
 	| Ref of t
 	| Thread
 	| Tuple of t vector
 	| Vector of t
 	| Weak of t
-	| Word
-	| Word8
+	| Word of WordSize.t
 
       local
 	 val {get, set, ...} =
@@ -53,20 +54,21 @@
 	    else Error.bug "bogus application of unary tycon"
 
 	 val tycons =
-	    [(Tycon.array, unary Array),
-	     (Tycon.char, nullary Char),
-	     (Tycon.int, nullary Int),
-	     (Tycon.intInf, nullary IntInf),
-	     (Tycon.pointer, nullary Pointer),
-	     (Tycon.preThread, nullary PreThread),
-	     (Tycon.real, nullary Real),
-	     (Tycon.reff, unary Ref),
-	     (Tycon.thread, nullary Thread),
-	     (Tycon.tuple, Tuple),
-	     (Tycon.vector, unary Vector),
-	     (Tycon.weak, unary Weak),
-	     (Tycon.word, nullary Word),
-	     (Tycon.word8, nullary Word8)]
+	    [(Tycon.array, unary Array)]
+	    @ List.map (Tycon.ints, fn (t, s) =>
+			(t, nullary (Int s)))
+	    @ [(Tycon.intInf, nullary IntInf),
+	       (Tycon.pointer, nullary Pointer),
+	       (Tycon.preThread, nullary PreThread)]
+	    @ List.map (Tycon.reals, fn (t, s) =>
+			(t, nullary (Real s)))
+	    @ [(Tycon.reff, unary Ref),
+	       (Tycon.thread, nullary Thread),
+	       (Tycon.tuple, Tuple),
+	       (Tycon.vector, unary Vector),
+	       (Tycon.weak, unary Weak)]
+	    @ List.map (Tycon.words, fn (t, s) =>
+			(t, nullary (Word s)))
       in
 	 val _ = List.foreach (tycons, fn (tycon, f) => set (tycon, SOME f))
 
@@ -89,13 +91,12 @@
 	     (fn (t, layout) =>
 	      case dest t of
 		 Array t => seq [layout t, str " array"]
-	       | Char => str "char"
 	       | Datatype t => Tycon.layout t
-	       | Int => str "int"
+	       | Int s => str (concat ["int", IntSize.toString s])
 	       | IntInf => str "IntInf.int"
 	       | Pointer => str "pointer"
 	       | PreThread => str "preThread"
-	       | Real => str "real"
+	       | Real s => str (concat ["real", RealSize.toString s])
 	       | Ref t => seq [layout t, str " ref"]
 	       | Thread => str "thread"
 	       | Tuple ts =>
@@ -105,8 +106,7 @@
 					       " * ")))
 	       | Vector t => seq [layout t, str " vector"]
 	       | Weak t => seq [layout t, str " weak"]
-	       | Word => str "word"
-	       | Word8 => str "word8"))
+	       | Word s => str (concat ["word", WordSize.toString s])))
       end
    end
 
@@ -123,8 +123,96 @@
       fun newNoname () = newString "L"
    end
 
-structure Cases = Cases (type con = Con.t
-			 val conEquals = Con.equals)
+structure Cases =
+   struct
+      datatype t =
+	 Con of (Con.t * Label.t) vector
+       | Int of IntSize.t * (IntX.t * Label.t) vector
+       | Word of WordSize.t * (WordX.t * Label.t) vector
+
+      fun equals (c1: t, c2: t): bool =
+	 let
+	    fun doit (l1, l2, eq') = 
+	       Vector.equals 
+	       (l1, l2, fn ((x1, a1), (x2, a2)) =>
+		eq' (x1, x2) andalso Label.equals (a1, a2))
+	 in
+	    case (c1, c2) of
+	       (Con l1, Con l2) => doit (l1, l2, Con.equals)
+	     | (Int (_, l1), Int (_, l2)) => doit (l1, l2, IntX.equals)
+	     | (Word (_, l1), Word (_, l2)) => doit (l1, l2, WordX.equals)
+	     | _ => false
+	 end
+
+      fun hd (c: t): Label.t =
+	 let
+	    fun doit v =
+	       if Vector.length v >= 1
+		  then let val (_, a) = Vector.sub (v, 0)
+		       in a
+		       end
+	       else Error.bug "Cases.hd"
+	 in
+	    case c of
+	       Con cs => doit cs
+	     | Int (_, cs) => doit cs
+	     | Word (_, cs) => doit cs
+	 end
+
+      fun isEmpty (c: t): bool =
+	 let
+	    fun doit v = 0 = Vector.length v
+	 in
+	    case c of
+	       Con cs => doit cs
+	     | Int (_, cs) => doit cs
+	     | Word (_, cs) => doit cs
+	 end
+
+      fun fold (c: t, b, f) =
+	 let
+	    fun doit l = Vector.fold (l, b, fn ((_, a), b) => f (a, b))
+	 in
+	    case c of
+	       Con l => doit l
+	     | Int (_, l) => doit l
+	     | Word (_, l) => doit l
+	 end
+
+      fun map (c: t, f): t =
+	 let
+	    fun doit l = Vector.map (l, fn (i, x) => (i, f x))
+	 in
+	    case c of
+	       Con l => Con (doit l)
+	     | Int (s, l) => Int (s, doit l)
+	     | Word (s, l) => Word (s, doit l)
+	 end
+      
+      fun forall (c: t, f: Label.t -> bool): bool =
+	 let
+	    fun doit l = Vector.forall (l, fn (_, x) => f x)
+	 in
+	    case c of
+	       Con l => doit l
+	     | Int (_, l) => doit l
+	     | Word (_, l) => doit l
+	 end
+
+      fun length (c: t): int = fold (c, 0, fn (_, i) => i + 1)
+
+      fun foreach (c, f) = fold (c, (), fn (x, ()) => f x)
+
+      fun foreach' (c: t, f: Label.t -> unit, fc: Con.t -> unit): unit =
+	 let
+	    fun doit l = Vector.foreach (l, fn (_, a) => f a)
+	 in
+	    case c of
+	       Con l => Vector.foreach (l, fn (c, a) => (fc c; f a))
+	     | Int (_, l) => doit l
+	     | Word (_, l) => doit l
+	 end
+   end
 
 local open Layout
 in
@@ -544,7 +632,7 @@
 		  func: Func.t,
 		  return: Return.t}
        | Case of {test: Var.t,
-		  cases: Label.t Cases.t,
+		  cases: Cases.t,
 		  default: Label.t option} (* Must be nullary. *)
        | Goto of {dst: Label.t,
 		  args: Var.t vector}
@@ -556,7 +644,9 @@
 
       fun iff (test: Var.t, {truee, falsee}) =
 	 Case
-	 {cases = Cases.Int (Vector.new2 ((0, falsee), (1, truee))),
+	 {cases = Cases.Int (I32,
+			     Vector.new2 ((IntX.zero I32, falsee),
+					  (IntX.one I32, truee))),
 	  default = NONE,
 	  test = test}
 	 
@@ -640,11 +730,9 @@
 	       datatype z = datatype Cases.t
 	       val cases =
 		  case cases of
-		     Char l => doit (l, Char.layout)
-		   | Con l => doit (l, Con.layout)
-		   | Int l => doit (l, Int.layout)
-		   | Word l => doit (l, Word.layout)
-		   | Word8 l => doit (l, Word8.layout)
+		     Con l => doit (l, Con.layout)
+		   | Int (_, l) => doit (l, IntX.layout)
+		   | Word (_, l) => doit (l, WordX.layout)
 	       val cases =
 		  case default of
 		     NONE => cases
@@ -697,9 +785,9 @@
 	       Return.equals (return, return')
 	  | (Case {test, cases, default},
 	     Case {test = test', cases = cases', default = default'}) =>
-	       Var.equals (test, test') andalso
-	       Cases.equals (cases, cases', Label.equals) andalso
-	       Option.equals (default, default', Label.equals)
+	       Var.equals (test, test')
+	       andalso Cases.equals (cases, cases')
+	       andalso Option.equals (default, default', Label.equals)
 	  | (Goto {dst, args}, Goto {dst = dst', args = args'}) =>
 	       Label.equals (dst, dst') andalso
 	       varsEquals (args, args')
@@ -1104,11 +1192,11 @@
 				      edge (j, toString x, Solid))
 				  val _ =
 				     case cases of
-					Cases.Char v => doit (v, Char.toString)
-				      | Cases.Con v => doit (v, Con.toString)
-				      | Cases.Int v => doit (v, Int.toString)
-				      | Cases.Word v => doit (v, Word.toString)
-				      | Cases.Word8 v => doit (v, Word8.toString)
+					Cases.Con v => doit (v, Con.toString)
+				      | Cases.Int (_, v) =>
+					   doit (v, IntX.toString)
+				      | Cases.Word (_, v) =>
+					   doit (v, WordX.toString)
 				  val _ = 
 				     case default of
 					NONE => ()
@@ -1757,9 +1845,9 @@
 			     datatype z = datatype Prim.Name.t
 			  in
 			     case Prim.name prim of
-				Int_addCheck => doit add
-			      | Int_subCheck => doit sub
-			      | Int_mulCheck => doit mul
+				Int_addCheck _ => doit add
+			      | Int_subCheck _ => doit sub
+			      | Int_mulCheck _ => doit mul
 			      | _ => ()
 			  end
 		     | _ => ())



1.48      +18 -7     mlton/mlton/ssa/ssa-tree.sig

Index: ssa-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.sig,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -r1.47 -r1.48
--- ssa-tree.sig	11 May 2003 23:44:01 -0000	1.47
+++ ssa-tree.sig	23 Jun 2003 04:58:59 -0000	1.48
@@ -62,20 +62,18 @@
 	       
 	    datatype dest =
 	       Array of t
-	     | Char
 	     | Datatype of Tycon.t
-	     | Int
+	     | Int of IntSize.t
 	     | IntInf
 	     | Pointer
 	     | PreThread
-	     | Real
+	     | Real of RealSize.t
 	     | Ref of t
 	     | Thread
 	     | Tuple of t vector
 	     | Vector of t
 	     | Weak of t
-	     | Word
-	     | Word8
+	     | Word of WordSize.t
 
 	    val dest: t -> dest
 	    val tyconArgs: t -> Tycon.t * t vector
@@ -126,7 +124,20 @@
 	    val var: t -> Var.t option
 	 end
       
-      structure Cases: CASES sharing type Cases.con = Con.t
+      structure Cases:
+	 sig
+	    datatype t =
+	       Con of (Con.t * Label.t) vector
+	     | Int of IntSize.t * (IntX.t * Label.t) vector
+	     | Word of WordSize.t * (WordX.t * Label.t) vector
+
+	    val forall: t * (Label.t -> bool) -> bool
+	    val foreach: t * (Label.t -> unit) -> unit
+	    val hd: t -> Label.t
+	    val isEmpty: t -> bool
+	    val length: t -> int
+	    val map: t * (Label.t -> Label.t) -> t
+	 end
 
       structure Handler: HANDLER
       sharing Handler.Label = Label
@@ -147,7 +158,7 @@
 			func: Func.t,
 			return: Return.t}
 	     | Case of {test: Var.t,
-			cases: Label.t Cases.t,
+			cases: Cases.t,
 			default: Label.t option (* Must be nullary. *)
 		       }
 	     | Goto of {dst: Label.t,



1.23      +7 -11     mlton/mlton/ssa/type-check.fun

Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/type-check.fun,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- type-check.fun	11 Jan 2003 00:34:40 -0000	1.22
+++ type-check.fun	23 Jun 2003 04:58:59 -0000	1.23
@@ -74,7 +74,6 @@
 	 fn Arith {args, ...} => getVars args
 	  | Bug => ()
 	  | Call {func, args, ...} => (getFunc func; getVars args)
-
 	  | Case {test, cases, default, ...} =>
 	       let
 		  fun doit (cases: ('a * 'b) vector,
@@ -123,12 +122,9 @@
 		  val _ = getVar test
 	       in
 		  case cases of
-		     Cases.Char cases => doit (cases, Char.equals, Word.fromChar)
-		   | Cases.Con cases => doitCon cases 
-		   | Cases.Int cases => doit (cases, Int.equals, Word.fromInt)
-		   | Cases.Word cases => doit (cases, Word.equals, Word.fromWord)
-		   | Cases.Word8 cases =>
-			doit (cases, Word8.equals, Word.fromWord8)
+		     Cases.Con cs => doitCon cs 
+		   | Cases.Int (_, cs) => doit (cs, IntX.equals, IntX.hash)
+		   | Cases.Word (_, cs) => doit (cs, WordX.equals, WordX.toWord)
 	       end
 	  | Goto {args, ...} => getVars args
 	  | Raise xs => getVars xs
@@ -407,10 +403,10 @@
 		  const = Type.ofConst,
 		  copy = fn x => x,
 		  filter = filter,
-		  filterChar = filterGround Type.char,
-		  filterInt = filterGround Type.int,
-		  filterWord = filterGround Type.word,
-		  filterWord8 = filterGround Type.word8,
+		  filterInt = fn (from, s) => coerce {from = from,
+						      to = Type.int s},
+		  filterWord = fn (from, s) => coerce {from = from,
+						       to = Type.word s},
 		  fromType = fn x => x,
 		  layout = Type.layout,
 		  primApp = primApp,



1.19      +41 -44    mlton/mlton/ssa/useless.fun

Index: useless.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/useless.fun,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- useless.fun	3 Jun 2003 20:04:32 -0000	1.18
+++ useless.fun	23 Jun 2003 04:58:59 -0000	1.19
@@ -252,7 +252,7 @@
 		     case Type.dest t of
 			Type.Array t =>
 			   let val elt as (_, e) = slot t
-			       val length = loop Type.int
+			       val length = loop Type.defaultInt
 			   in Exists.addHandler
 			      (e, fn () => Useful.makeUseful (deground length))
 			      ; Array {useful = useful (),
@@ -262,7 +262,7 @@
 		      | Type.Ref t => Ref {arg = slot t,
 					   useful = useful ()}
 		      | Type.Tuple ts => Tuple (Vector.map (ts, slot))
-		      | Type.Vector t => Vector {length = loop Type.int,
+		      | Type.Vector t => Vector {length = loop Type.defaultInt,
 						 elt = slot t}
 		      | Type.Weak t => Weak {arg = slot t,
 					     useful = useful ()}
@@ -287,7 +287,7 @@
 	 in
 	    v
 	 end
-      val int = fromType Type.int
+      val int = fromType Type.defaultInt
 
       fun detupleSlots (v: t): slot vector =
 	 case value v of
@@ -526,17 +526,17 @@
 		   | Array_array0Const => ()
 		   | Array_length => return (arrayLength (arg 0))
 		   | Array_sub => sub ()
+		   | Array_toVector =>
+			(case (value (arg 0), value result) of
+			    (Array {length = l, elt = e, ...},
+			     Vector {length = l', elt = e', ...}) =>
+			       (unify (l, l'); unifySlot (e, e'))
+			   | _ => Error.bug "strange Array_toVector")
 		   | Array_update => update ()
 		   | MLton_equal => Vector.foreach (args, deepMakeUseful)
 		   | Ref_assign => coerce {from = arg 1, to = deref (arg 0)}
 		   | Ref_deref => return (deref (arg 0))
 		   | Ref_ref => coerce {from = arg 0, to = deref result}
-		   | Vector_fromArray =>
-			(case (value (arg 0), value result) of
-			    (Array {length = l, elt = e, ...},
-			     Vector {length = l', elt = e', ...}) =>
-			       (unify (l, l'); unifySlot (e, e'))
-			   | _ => Error.bug "strange Vector_fromArray")
 		   | Vector_length => return (vectorLength (arg 0))
 		   | Vector_sub => (arg 1 dependsOn result
 				    ; return (devector (arg 0)))
@@ -576,10 +576,8 @@
 		  const = Value.const,
 		  copy = Value.fromType o Value.ty,
 		  filter = filter,
-		  filterChar = filterGround,
-		  filterInt = filterGround,
-		  filterWord = filterGround,
-		  filterWord8 = filterGround,
+		  filterInt = filterGround o #1,
+		  filterWord = filterGround o #1,
 		  fromType = Value.fromType,
 		  layout = Value.layout,
 		  primApp = primApp,
@@ -947,37 +945,36 @@
 			(0, NONE) => ([], Bug)
 		      | _ => ([], t)
 		  datatype z = datatype Cases.t
-	       in case cases of
-		  Char l => doit l
-		| Int l => doit l
-		| Word l => doit l
-		| Word8 l => doit l
-		| Con cases =>
-		     case (Vector.length cases, default) of
-			(0, NONE) => ([], Bug)
-		      | _ => 
-			   let
-			      val (cases, blocks) =
-				 Vector.mapAndFold
-				 (cases, [], fn ((c, l), blocks) =>
-				  let
-				     val args = label l
-				  in if Vector.forall (args, Value.isUseful)
-					then ((c, l), blocks)
-				     else
-					let
-					   val (l', b) =
-					      dropUseless
-					      (conArgs c, args, fn args =>
-					       Goto {dst = l, args = args})
-					in ((c, l'), b :: blocks)
-					end
-				  end)
-			   in (blocks, 
-			       Case {test = test, 
-				     cases = Cases.Con cases,
-				     default = default})
-			   end
+	       in
+		  case cases of
+		     Con cases =>
+			(case (Vector.length cases, default) of
+			    (0, NONE) => ([], Bug)
+			  | _ => 
+			       let
+				  val (cases, blocks) =
+				     Vector.mapAndFold
+				     (cases, [], fn ((c, l), blocks) =>
+				      let
+					 val args = label l
+				      in if Vector.forall (args, Value.isUseful)
+					    then ((c, l), blocks)
+					 else
+					    let
+					       val (l', b) =
+						  dropUseless
+						  (conArgs c, args, fn args =>
+						   Goto {dst = l, args = args})
+					    in ((c, l'), b :: blocks)
+					    end
+				      end)
+			       in (blocks, 
+				   Case {test = test, 
+					 cases = Cases.Con cases,
+					 default = default})
+			       end)
+		   | Int (_, cs) => doit cs
+		   | Word (_, cs) => doit cs
 	       end
 	  | Goto {dst, args} =>
 	       ([], Goto {dst = dst, args = keepUseful (args, label dst)})



1.24      +82 -65    mlton/mlton/type-inference/infer.fun

Index: infer.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/infer.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- infer.fun	18 May 2003 23:57:50 -0000	1.23
+++ infer.fun	23 Jun 2003 04:59:00 -0000	1.24
@@ -12,6 +12,8 @@
 
 open CoreML.Atoms
 
+datatype z = datatype WordSize.t
+   
 structure Srecord = SortedRecord
 structure Field = Record.Field
 structure Scope = Scope (structure CoreML = CoreML)
@@ -49,6 +51,13 @@
    structure XvarExp = VarExp
 end
 
+structure BuildConst =
+   struct
+      datatype t =
+	 Bool of bool
+       | Int of int
+   end
+
 structure Type =
    struct
       open Type
@@ -81,10 +90,8 @@
 
 		       open Xcases
 		       type t = exp t
-		       val char = Char
 		       val int = Int
 		       val word = Word
-		       val word8 = Word8
 		       fun con v =
 			  Con (Vector.map
 			       (v, fn {con, targs, arg, rhs} =>
@@ -170,54 +177,42 @@
 
 fun makeXconst (c: Aconst.t, ty: Type.t): Xconst.t =
    let
-      val ty = Xconst.Type.make (Xtype.deconConst (Type.toXml (ty, Aconst.region c)))
-      datatype z = datatype Xconst.Node.t
       fun error m =
 	 Control.error (Aconst.region c,
 			Layout.str (concat [m, ": ", Aconst.toString c]),
 			Layout.empty)
+      val ty = Type.toXml (ty, Aconst.region c)
+      fun choose (all, sizeTy, name, make) =
+	 case List.peek (all, fn s => Xtype.equals (ty, sizeTy s)) of
+	    NONE => Error.bug (concat ["strange ", name, " type: ",
+				       Layout.toString (Xtype.layout ty)])
+	  | SOME s => make s
    in
-      Xconst.make
-      (case Aconst.node c of
-	  Aconst.Char c => Char c
-	| Aconst.Int s =>
-	     if Xconst.Type.equals (ty, Xconst.Type.intInf)
-		then
-		   IntInf (stringToIntInf s)
-		   handle _ => (error "invalid IntInf";
-				IntInf (valOf (IntInf.fromString "~1")))
-	     else
-		Int
-		(let
-		    val radix =
-		       if String.isPrefix {string = s, prefix = "0x"}
-			  orelse String.isPrefix {string = s, prefix = "~0x"}
-			  then StringCvt.HEX
-		       else StringCvt.DEC
-		 in
-		    case StringCvt.scanString (Pervasive.Int32.scan radix) s of
-		       NONE => (error "invalid int constant"; ~1)
-		     | SOME n =>
-			  if Xconst.Type.equals (ty, Xconst.Type.int)
-			     then n
-			  else (error (concat ["int can't be of type ",
-					       Xconst.Type.toString ty])
-				; ~1)
-		 end
-		    handle Overflow =>
-		       (error "int constant too big"; ~1))
-	| Aconst.Real r => Real r
-	| Aconst.String s => String s
-	| Aconst.Word w =>
-	     Word (if Xconst.Type.equals (ty, Xconst.Type.word)
-		     then w
-		  else if Xconst.Type.equals (ty, Xconst.Type.word8)
-			  then if w = Word.andb (w, 0wxFF)
-				  then w
-			       else (error "word8 too big"; 0w0)
-		       else (error ("strange word " ^ (Xconst.Type.toString ty))
-			     ; 0w0)),
-       ty)
+      case Aconst.node c of
+	 Aconst.Char c =>
+	    Xconst.Word (WordX.make (Word8.toWord (Word8.fromChar c),
+				     WordSize.W8))
+       | Aconst.Int i =>
+	    if Xtype.equals (ty, Xtype.intInf)
+	       then Xconst.IntInf i
+	    else
+	       choose (IntSize.all, Xtype.int, "int", fn s =>
+		       Xconst.Int
+		       (IntX.make (i, s)
+			handle Overflow =>
+			   (error (concat [Xtype.toString ty, " too big"])
+			    ; IntX.zero s)))
+       | Aconst.Real r =>
+	    choose (RealSize.all, Xtype.real, "real", fn s =>
+		    Xconst.Real (RealX.make (r, s)))
+       | Aconst.String s => Xconst.string s
+       | Aconst.Word w =>
+	    choose (WordSize.all, Xtype.word, "word", fn s =>
+		    Xconst.Word
+		    (if IntInf.<= (w, Word.toIntInf (WordSize.max s))
+			then WordX.fromLargeInt (w, s)
+		     else (error (concat [Xtype.toString ty, " too big"])
+			   ; WordX.zero s)))
    end
 
 fun 'a sortByField (v: (Field.t * 'a) vector): 'a vector =
@@ -1158,30 +1153,52 @@
 		  in
 		     eta (instance, fn (arg, resultType) =>
 			  let
-			     fun constant c =
-				let
-				   datatype z = datatype LookupConstant.Const.t
-				in
-				   case c of
-				      Bool b => if b then Xexp.truee ()
-						else Xexp.falsee ()
-				    | Int i => Xexp.const (Const.fromInt i)
-				    | Real r => Xexp.const (Const.fromReal r)
-				    | String s =>
-					 Xexp.const (Const.fromString s)
-				    | Word w => Xexp.const (Const.fromWord w)
-				end
+			     datatype z = datatype Prim.Name.t
 			     fun make (args: Xexp.t vector): Xexp.t =
-				case Prim.name prim of
-				   Prim.Name.BuildConstant c =>
-				      constant (lookupBuildConstant c)
-				 | Prim.Name.Constant c =>
-				      constant (lookupConstant c)
-				 | _ => 
-				      Xexp.primApp {prim = prim,
+				let
+				   fun app p =
+				      Xexp.primApp {prim = p,
 						    targs = targs (),
 						    args = args,
 						    ty = resultType}
+				   fun id () = Vector.sub (args, 0)
+				in
+				   case Prim.name prim of
+				      BuildConstant c =>
+					 let
+					    datatype z = datatype BuildConst.t
+					 in
+					    case lookupBuildConstant c of
+					       Bool b =>
+						  if b
+						     then Xexp.truee ()
+						  else Xexp.falsee ()
+					     | Int i =>
+						  Xexp.const
+						  (Const.int
+						   (IntX.make
+						    (IntInf.fromInt i,
+						     IntSize.default)))
+					 end
+				    | Byte_byteToChar => id ()
+				    | Byte_charToByte => id ()
+				    | C_CS_charArrayToWord8Array => id ()
+				    | Char_chr =>
+					 app (Prim.intToWord
+					      (IntSize.default, W8))
+				    | Char_ge => app (Prim.wordGe W8)
+				    | Char_gt => app (Prim.wordGt W8)
+				    | Char_le => app (Prim.wordLe W8)
+				    | Char_lt => app (Prim.wordLt W8)
+				    | Char_ord =>
+					 app (Prim.wordToInt
+					      (W8, IntSize.default))
+				    | Constant c =>
+					 Xexp.const (lookupConstant c)
+				    | String_toWord8Vector => id ()
+				    | Word8Vector_toString => id ()
+				    | _ => app prim
+				end
 			  in
 			     case (Prim.numArgs prim, arg) of
 				(NONE, NONE) => make (Vector.new0 ())



1.4       +10 -3     mlton/mlton/type-inference/infer.sig

Index: infer.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/infer.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- infer.sig	10 Apr 2002 07:02:21 -0000	1.3
+++ infer.sig	23 Jun 2003 04:59:00 -0000	1.4
@@ -19,11 +19,18 @@
 signature INFER = 
    sig
       include INFER_STRUCTS
-      
+
+      structure BuildConst:
+	 sig
+	    datatype t =
+	       Bool of bool
+	     | Int of int
+	 end
+	 
       val infer:
 	 {program: CoreML.Program.t,
-	  lookupBuildConstant: string -> LookupConstant.Const.t,
-	  lookupConstant: string -> LookupConstant.Const.t}
+	  lookupBuildConstant: string -> BuildConst.t,
+	  lookupConstant: string -> CoreML.Const.t}
 	 -> Xml.Program.t
    end
 



1.4       +14 -20    mlton/mlton/type-inference/match-compile.fun

Index: match-compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/match-compile.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- match-compile.fun	12 Dec 2002 01:14:23 -0000	1.3
+++ match-compile.fun	23 Jun 2003 04:59:00 -0000	1.4
@@ -144,28 +144,22 @@
 end
 
 local
-   fun make (inj, get) (cases, finish) =
-      inj (Vector.map
-	   (cases, fn {const, infos: Info.t list} =>
-	    (get (Const.node const), finish (Vector.fromList infos))))
+   fun make (all, ty, inj, get) =
+      List.map (all, fn s =>
+		(ty s,
+		 fn (cases, finish) =>
+		 inj (s,
+		      Vector.map
+		      (cases, fn {const, infos: Info.t list} =>
+		       (get const, finish (Vector.fromList infos))))))
 in
    val directCases = 
-      [(Type.char,
-	make (Cases.char,
-	      fn Const.Node.Char c => c
-	       | _ => Error.bug "caseChar type error")),
-       (Type.int,
-	make (Cases.int,
-	      fn Const.Node.Int i => i
-	       | _ => Error.bug "caseInt type error")),
-       (Type.word,
-	make (Cases.word,
-	      fn Const.Node.Word w => w
-	       | _ => Error.bug "caseWord type error")),
-       (Type.word8,
-	make (Cases.word8,
-	      fn Const.Node.Word w => Word8.fromWord w
-	       | _ => Error.bug "caseWord8 type error"))]
+      make (IntSize.all, Type.int, Cases.int,
+	    fn Const.Int i => i
+	     | _ => Error.bug "caseInt type error")
+      @ make (WordSize.all, Type.word, Cases.word,
+	      fn Const.Word w => w
+	       | _ => Error.bug "caseWord type error")
 end
 
 (*---------------------------------------------------*)



1.4       +5 -9      mlton/mlton/type-inference/match-compile.sig

Index: match-compile.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/match-compile.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- match-compile.sig	12 Dec 2002 01:14:23 -0000	1.3
+++ match-compile.sig	23 Jun 2003 04:59:00 -0000	1.4
@@ -16,32 +16,28 @@
 	 sig
 	    type t
 
-	    val char: t
 	    val detuple: t -> t vector
 	    val equals: t * t -> bool
-	    val int: t
+	    val int: IntSize.t -> t
 	    val layout: t -> Layout.t
-	    val word: t
-	    val word8: t
+	    val word: WordSize.t -> t
 	 end
       structure Cases:
 	 sig
 	    type exp
-
 	    type t
 
-	    val char: (char * exp) vector -> t
 	    val con: {con: Con.t,
 		      targs: Type.t vector,
 		      arg: (Var.t * Type.t) option,
 		      rhs: exp} vector -> t
-	    val int: (int * exp) vector -> t
-	    val word: (word * exp) vector -> t
-	    val word8: (Word8.t * exp) vector -> t
+	    val int: IntSize.t * (IntX.t * exp) vector -> t
+	    val word: WordSize.t * (WordX.t * exp) vector -> t
 	 end
       structure Exp:
 	 sig
 	    type t
+	       
 	    val const: Const.t -> t
 	    val var: Var.t * Type.t -> t
 	    val detuple: {tuple: t,



1.12      +105 -83   mlton/mlton/type-inference/type-env.fun

Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/type-env.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- type-env.fun	18 May 2003 23:57:50 -0000	1.11
+++ type-env.fun	23 Jun 2003 04:59:00 -0000	1.12
@@ -50,7 +50,7 @@
 	    id = newId ()}
 
       fun join (T r, T r'): t =
-	 T {equality = #equality r orelse #equality r',
+	 T {equality = #equality r andalso #equality r',
 	    canGeneralize = #canGeneralize r andalso #canGeneralize r',
 	    id = newId ()}
    end
@@ -183,6 +183,7 @@
 			    final: FinalRecordType.t,
 			    region: Region.t,
 			    spine: Spine.t}
+	| Real (* an unresolved real type *)
 	| Record of t Srecord.t
 	| Unknown of Unknown.t
 	| Var of Tyvar.t
@@ -206,7 +207,6 @@
 	       Con (c, ts) =>
 		  paren (align [seq [str "Con ", Tycon.layout c],
 				Vector.layout layout ts])
-	     | Int => str "Int"
 	     | FlexRecord {fields, final, region, spine} =>
 		  seq [str "Flex ",
 		       record [("fields", layoutFields fields),
@@ -218,6 +218,8 @@
 		       record [("fields", layoutFields fields),
 			       ("final", FinalRecordType.layout final),
 			       ("spine", Spine.layout spine)]]
+	     | Int => str "Int"
+	     | Real => str "Real"
 	     | Record r => Srecord.layout {record = r,
 					   separator = ": ",
 					   extra = "",
@@ -228,11 +230,13 @@
 	     | Word => str "Word"
       end
 
+      val toString = Layout.toString o layout
+
       fun union (T s, T s') = Set.union (s, s')
 
       fun set (T s, v) = Set.setValue (s, v)
 	 
-      fun makeHom {con, flexRecord, genFlexRecord, int,
+      fun makeHom {con, flexRecord, genFlexRecord, int, real,
 		   record, recursive, unknown, var, word} =
 	 let
 	    datatype status = Processing | Seen | Unseen
@@ -271,6 +275,7 @@
 					   final = final,
 					   region = region,
 					   spine = spine})
+				 | Real => real t
 				 | Record r => record (t, Srecord.map (r, get))
 				 | Unknown u => unknown (t, u)
 				 | Var a => var (t, a)
@@ -283,7 +288,8 @@
 	    fun destroy () =
 	       (destroyStatus ()
 		; destroyProp ())
-	 in {hom = get, destroy = destroy}
+	 in
+	    {hom = get, destroy = destroy}
 	 end
 
       fun hom (ty, z) =
@@ -320,6 +326,7 @@
 		    Spine.layoutPretty spine,
 		    str "}"]
 	    fun genFlexRecord (t, _) = layout t
+	    fun real _ = str "real"
 	    fun record (_, r) =
 	       Srecord.layout
 	       {record = r,
@@ -341,6 +348,7 @@
 		     flexRecord = flexRecord,
 		     genFlexRecord = genFlexRecord,
 		     int = int,
+		     real = real,
 		     record = record,
 		     recursive = recursive,
 		     unknown = unknown,
@@ -381,9 +389,14 @@
       fun con (tycon, ts) =
 	 if Tycon.equals (tycon, Tycon.tuple) then tuple ts
 	 else newTy (Con (tycon, ts))
+
+      val char = con (Tycon.char, Vector.new0 ())
+      val string = con (Tycon.vector, Vector.new1 char)
    end
 
-structure Ops = TypeOps (structure Tycon = Tycon
+structure Ops = TypeOps (structure IntSize = IntSize
+			 structure Tycon = Tycon
+			 structure WordSize = WordSize
 			 open Type)
 
 structure Type =
@@ -403,34 +416,23 @@
 	 case Aconst.node c of
 	    Aconst.Char _ => char
 	  | Aconst.Int _ => newTy Type.Int
-	  | Aconst.Real _ => real
+	  | Aconst.Real _ => newTy Type.Real
 	  | Aconst.String _ => string
 	  | Aconst.Word _ => newTy Type.Word
 
-
       val traceCanUnify =
 	 Trace.trace2 ("canUnify", layout, layout, Bool.layout)
 
       fun canUnify arg = 
 	 traceCanUnify
 	 (fn (t, t') =>
-	  case (toType t,   toType t') of
+	  case (toType t, toType t') of
 	     (Unknown _,  _) => true
 	   | (_, Unknown _) => true
-	   | (Con (c, ts), Con (c', ts')) => (Tycon.equals (c, c')
-					      andalso
-					      Vector.forall2 (ts, ts', canUnify))
-	   | (Con (c, ts), Word) =>
-		0 = Vector.length ts andalso Tycon.isWordX c
-	   | (Word, Con (c, ts)) =>
-		0 = Vector.length ts andalso Tycon.isWordX c
-	   | (Con (c, ts), Int) =>
-		0 = Vector.length ts andalso Tycon.isIntX c
-	   | (Int, Con (c, ts)) =>
-		0 = Vector.length ts andalso Tycon.isIntX c
-	   | (Var a, Var a') => Tyvar.equals (a, a')
-	   | (Word, Word) => true
+	   | (Con (c, ts), t') => conAnd (c, ts, t')
+	   | (t', Con (c, ts)) => conAnd (c, ts, t')
 	   | (Int, Int) => true
+	   | (Real, Real) => true
 	   | (Record r, Record r') =>
 		let
 		   val fs = Srecord.toVector r
@@ -440,7 +442,18 @@
 					   Field.equals (f, f')
 					   andalso canUnify (t, t'))
 		end
-	    | _ => false) arg
+	   | (Var a, Var a') => Tyvar.equals (a, a')
+	   | (Word, Word) => true
+	   | _ => false) arg
+      and conAnd (c, ts, t') =
+	 case t' of
+	    Con (c', ts') =>
+	       Tycon.equals (c, c')
+	       andalso Vector.forall2 (ts, ts', canUnify)
+	  | Int => 0 = Vector.length ts andalso Tycon.isIntX c
+	  | Real => 0 = Vector.length ts andalso Tycon.isRealX c
+	  | Word => 0 = Vector.length ts andalso Tycon.isWordX c
+	  | _ => false
 
       val traceUnify = Trace.trace2 ("unify", layout, layout, Unit.layout)
 
@@ -509,39 +522,67 @@
 			 Error.bug "GenFlexRecord seen in unify"
 		      val {ty = t, plist} = Set.value s
 		      val {ty = t', ...} = Set.value s'
-		      val t =
-			 case (t, t')           of
-			    (Unknown r, Unknown r') =>
-			       Unknown (Unknown.join (r, r'))
-			  | (t, Unknown _) => t
-			  | (Unknown _, t) => t
-			  | (Var a, Var a') =>
-			       if Tyvar.equals (a, a')
-				  then t
-			       else (errorS "type variables not equal"
-				     ; t)
-			  | (Con (c, ts), Con (c', ts')) =>
+		      fun conAnd (c, ts, t, t') =
+			 case t of
+			    Con (c', ts') =>
 			       if Tycon.equals (c, c')
 				  then (unifys (ts, ts'); t)
 			       else (errorS "type constructors not equal"; t)
-			  | (Con (c, ts), Word) =>
-			       if Tycon.isWordX c andalso Vector.isEmpty ts
-				  then t
-			       else (errorS "not a word"; t)
-			  | (Word, Con (c, ts)) =>
-			       if Tycon.isWordX c andalso Vector.isEmpty ts
-				  then t'
-			       else (errorS "not a word"; t)
-			  | (Con (c, ts), Int) =>
-			       if Tycon.isIntX c andalso Vector.isEmpty ts
-				  then t
-			       else (errorS "not an int"; t)
-			  | (Int, Con (c, ts)) =>
+			  | Int =>
 			       if Tycon.isIntX c andalso Vector.isEmpty ts
 				  then t'
-			       else (errorS "not an int"; t)
-			  | (Word, Word) => t
+			       else (errorS "not an int"; t')
+			  | Real =>
+			       if Tycon.isRealX c andalso Vector.isEmpty ts
+				  then t'
+			       else (errorS "not a real"; t')
+			  | Word =>
+			       if Tycon.isWordX c andalso Vector.isEmpty ts
+				  then t'
+			       else (errorS "not a word"; t')
+			  | _ => (errorS "can't unify"; t)
+		      val t =
+			 case (t, t') of
+			    (Unknown r, Unknown r') =>
+			       Unknown (Unknown.join (r, r'))
+			  | (_, Unknown _) => t
+			  | (Unknown _, _) => t'
+			  | (Con (c, ts), _) => conAnd (c, ts, t', t)
+			  | (_, Con (c, ts)) => conAnd (c, ts, t, t')
+			  | (FlexRecord f, res as Record r) =>
+			       (oneFlex (f, r); res)
+			  | (res as Record r, FlexRecord f) =>
+			       (oneFlex (f, r); res)
+			  | (FlexRecord {fields = fields, final, region,
+					 spine = s},
+			     FlexRecord {fields = fields', spine = s', ...}) =>
+			       let
+				  val _ = Spine.unify (s, s', error)
+				  fun subset (fields, fields') =
+				     let
+					val res = ref fields'
+					val _ =
+					   List.foreach
+					   (fields, fn (f, t) =>
+					    case List.peek (fields', fn (f', _) =>
+							    Field.equals (f, f')) of
+					       NONE => List.push (res, (f, t))
+					     | SOME (_, t') => unify (t, t'))
+				     in
+					!res
+				     end
+				  val _ = subset (fields, fields')
+				  val fields = subset (fields', fields)
+			       in
+				  FlexRecord {fields = fields,
+					      final = final,
+					      region = region,
+					      spine = s}
+			       end
+			  | (GenFlexRecord _, _) => genFlexError ()
+			  | (_, GenFlexRecord _) => genFlexError ()
 			  | (Int, Int) => t
+			  | (Real, Real) => t
 			  | (Record r, Record r') =>
 			       let
 				  val fs = Srecord.toVector r
@@ -559,39 +600,12 @@
 				  else (errorS "different length records"
 					; t)
 			       end
-			  | (GenFlexRecord _, _) => genFlexError ()
-			  | (_, GenFlexRecord _) => genFlexError ()
-			  | (FlexRecord f, res as Record r) =>
-			       (oneFlex (f, r); res)
-			  | (res as Record r, FlexRecord f) =>
-			       (oneFlex (f, r); res)
-			| (FlexRecord {fields = fields, final, region,
-				       spine = s},
-			   FlexRecord {fields = fields', spine = s', ...}) =>
-			  let
-			     val _ = Spine.unify (s, s', error)
-			     fun subset (fields, fields') =
-				let
-				   val res = ref fields'
-				   val _ =
-				      List.foreach
-				      (fields, fn (f, t) =>
-				       case List.peek (fields', fn (f', _) =>
-						       Field.equals (f, f')) of
-					  NONE => List.push (res, (f, t))
-					| SOME (_, t') => unify (t, t'))
-				in
-				   !res
-				end
-			     val _ = subset (fields, fields')
-			     val fields = subset (fields', fields)
-			  in
-			     FlexRecord {fields = fields,
-					 final = final,
-					 region = region,
-					 spine = s}
-			  end
-			 | _ => (errorS "can't unify"; t)
+			  | (Var a, Var a') =>
+			       if Tyvar.equals (a, a')
+				  then t
+			       else (errorS "type variables not equal"; t)
+			  | (Word, Word) => t
+			  | _ => (errorS "can't unify"; t)
 		      val _ = Set.union (s, s')
 		      val _ = Set.setValue (s, {ty = t, plist = plist})
 		   in
@@ -613,7 +627,10 @@
 
       local
 	 structure X = XmlType
-	 val con = X.con
+	 fun con (c, ts) =
+	    if Tycon.equals (c, Tycon.char)
+	       then X.word8
+	    else X.con (c, ts)
 	 val unknown = con (Tycon.tuple, Vector.new0 ())
 	 fun tuple ts =
 	    if 1 = Vector.length ts
@@ -666,12 +683,14 @@
 	       X.unit
 	    end
 	 val int = con (Tycon.defaultInt, Vector.new0 ())
+	 val real = con (Tycon.defaultReal, Vector.new0 ())
 	 val word = con (Tycon.defaultWord, Vector.new0 ())
 	 val {hom: Type.t -> X.t, ...} =
 	    makeHom {con = fn (_, c, ts) => con (c, ts),
 		     int = fn _ => int,
 		     flexRecord = flexRecord,
 		     genFlexRecord = genFlexRecord,
+		     real = fn _ => real,
 		     record = record,
 		     recursive = recursive,
 		     unknown = fn _ => unknown,
@@ -814,6 +833,7 @@
 				    int = keep,
 				    flexRecord = fn (t, _) => keep t,
 				    genFlexRecord = genFlexRecord,
+				    real = keep,
 				    record = record,
 				    recursive = recursive,
 				    unknown = fn (t, _) => keep t,
@@ -974,6 +994,7 @@
 	    int = fn _ => (),
 	    flexRecord = fn (t, _) => add (flexes, t, Type.equals),
 	    genFlexRecord = fn _ => Error.bug "GenFlexRecord seen in Env.close",
+	    real = fn _ => (),
 	    record = fn _ => (),
 	    recursive = fn _ => (),
 	    unknown = (fn (t, Unknown.T {canGeneralize, ...}) =>
@@ -1118,6 +1139,7 @@
 					int = ignore,
 					flexRecord = flexRecord,
 					genFlexRecord = ignore,
+					real = ignore,
 					record = ignore,
 					recursive = ignore,
 					unknown = unknown,



1.8       +2 -0      mlton/mlton/type-inference/type-env.sig

Index: type-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/type-env.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- type-env.sig	18 May 2003 23:57:50 -0000	1.7
+++ type-env.sig	23 Jun 2003 04:59:00 -0000	1.8
@@ -25,6 +25,7 @@
             (* can two types be unified?  not side-effecting. *)
             val canUnify: t * t -> bool
 	    val derecord: t * Region.t -> (Record.Field.t * XmlType.t) vector
+	    val equals: t * t -> bool
 	    val layout: t -> Layout.t
 	    val layoutPretty: t -> Layout.t
 	    val new: {equality: bool, canGeneralize: bool} -> t
@@ -32,6 +33,7 @@
 	    val record: {flexible: bool,
 			 record: t SortedRecord.t,
 			 region: Region.t} -> t
+	    val toString: t -> string
 	    (* cached for speed *)
 	    val toXml: t * Region.t -> XmlType.t
 	    (* make two types identical (recursively).  side-effecting. *)



1.9       +2 -2      mlton/mlton/xml/implement-exceptions.fun

Index: implement-exceptions.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/implement-exceptions.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- implement-exceptions.fun	10 Jan 2003 20:52:51 -0000	1.8
+++ implement-exceptions.fun	23 Jun 2003 04:59:00 -0000	1.9
@@ -508,7 +508,7 @@
 					   targs = Vector.new0 (),
 					   arg = SOME (Var.newNoname (), arg)},
 				    const
-				    (Const.fromString
+				    (Const.string
 				     (Con.originalName con))))),
 				 default = NONE,
 				 ty = Type.string}))
@@ -540,7 +540,7 @@
 		       Type.unit),
 		      MonoVal {var = s,
 			       ty = Type.string,
-			       exp = Const (Const.fromString
+			       exp = Const (Const.string
 					    "toplevel handler not installed")})
 		  end},
 	  Type.unit)



1.9       +3 -5      mlton/mlton/xml/monomorphise.fun

Index: monomorphise.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/monomorphise.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- monomorphise.fun	10 Jan 2003 20:09:03 -0000	1.8
+++ monomorphise.fun	23 Jun 2003 04:59:00 -0000	1.9
@@ -363,13 +363,11 @@
 		     Vector.map (cases, fn (c, e) => (c, monoExp e))
 		  val cases =
 		     case cases of
-			Xcases.Char l => Scases.Char (doit l)
-		      | Xcases.Con cases => 
+			Xcases.Con cases => 
 			   Scases.Con (Vector.map (cases, fn (pat, exp) =>
 						   (monoPat pat, monoExp exp)))
-		      | Xcases.Int l => Scases.Int (doit l)
-		      | Xcases.Word l => Scases.Word (doit l)
-		      | Xcases.Word8 l => Scases.Word8 (doit l)
+		      | Xcases.Int (s, l) => Scases.Int (s, doit l)
+		      | Xcases.Word (s, l) => Scases.Word (s, doit l)
 	       in
 		  SprimExp.Case
 		  {test = monoVarExp test,



1.11      +3 -6      mlton/mlton/xml/polyvariance.fun

Index: polyvariance.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/polyvariance.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- polyvariance.fun	21 Apr 2003 15:16:19 -0000	1.10
+++ polyvariance.fun	23 Jun 2003 04:59:00 -0000	1.11
@@ -316,16 +316,13 @@
 							  (z, loopExp e))
 					   val cases =
 					      case cases of
-						 Char cases => Char (doit cases)
-					       | Con cases =>
+						 Con cases =>
 						    Con
 						    (Vector.map
 						     (cases, fn (p, e) =>
 						      (bindPat p, loopExp e)))
-					       | Int cases => Int (doit cases)
-					       | Word cases => Word (doit cases)
-					       | Word8 cases =>
-						    Word8 (doit cases)
+					       | Int (s, v) => Int (s, doit v)
+					       | Word (s, v) => Word (s, doit v)
 					in
 					   Case {test = loopVar test,
 						 cases = cases,



1.2       +9 -10     mlton/mlton/xml/shrink.fun

Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/shrink.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- shrink.fun	21 Apr 2003 15:16:19 -0000	1.1
+++ shrink.fun	23 Jun 2003 04:59:00 -0000	1.2
@@ -366,16 +366,15 @@
 			      end
 			     | (_, SOME (Value.Const c)) =>
 				  let
-				     fun doit (l, z) = match (l, fn z' => z = z')
-				  in case (cases, Const.node c) of
-				     (Cases.Char l, Const.Node.Char c) =>
-					doit (l, c)
-				   | (Cases.Int l, Const.Node.Int i) =>
-					doit (l, i)
-				   | (Cases.Word l, Const.Node.Word w) =>
-					doit (l, w)
-				   | (Cases.Word8 l, Const.Node.Word w) =>
-					doit (l, Word8.fromWord w)
+				     fun doit (l, z, equals) =
+					match (l, fn z' => equals (z, z'))
+				     datatype z = datatype Const.t
+				  in
+				     case (cases, c) of
+					(Cases.Int (_, l), Int i) =>
+					   doit (l, i, IntX.equals)
+				      | (Cases.Word (_, l), Word w) =>
+					   doit (l, w, WordX.equals)
 				   | _ => Error.bug "strange case"
 				  end
 			     | (_, NONE) => normal varExp



1.7       +3 -5      mlton/mlton/xml/simplify-types.fun

Index: simplify-types.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/simplify-types.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- simplify-types.fun	25 Feb 2003 02:50:44 -0000	1.6
+++ simplify-types.fun	23 Jun 2003 04:59:00 -0000	1.7
@@ -249,13 +249,11 @@
 		  fun doit v = Vector.map (v, fn (c, e) => (c, fixExp e))
 		  val cases =
 		     case cases of
-			I.Cases.Char v => O.Cases.Char (doit v)
-		      | I.Cases.Con v =>
+			I.Cases.Con v =>
 			   O.Cases.Con (Vector.map (v, fn (p, e) =>
 						    (fixPat p, fixExp e)))
-		      | I.Cases.Int v => O.Cases.Int (doit v)
-		      | I.Cases.Word v => O.Cases.Word (doit v)
-		      | I.Cases.Word8 v => O.Cases.Word8 (doit v)
+		      | I.Cases.Int (s, v) => O.Cases.Int (s, doit v)
+		      | I.Cases.Word (s, v) => O.Cases.Word (s, doit v)
 	       in
 		  O.PrimExp.Case {cases = cases,
 				  default = Option.map (default, fn (e, r) =>



1.12      +54 -48    mlton/mlton/xml/type-check.fun

Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/type-check.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- type-check.fun	18 May 2003 23:57:50 -0000	1.11
+++ type-check.fun	23 Jun 2003 04:59:00 -0000	1.12
@@ -133,34 +133,34 @@
 	 let
 	    fun error msg =
 	       Type.error (msg, let open Layout
-			       in seq [str "exp: ", PrimExp.layout e]
-			       end)
+				in seq [str "exp: ", PrimExp.layout e]
+				end)
 	    fun checkApp (t1, x) =
-	       let val t2 = checkVarExp x
-	       in case Type.dearrowOpt t1 of
-		  SOME (t2', t3) =>
-		     if Type.equals (t2, t2') then t3
-		     else
-			Type.error
-			("actual and formal not of same type",
-			 let open Layout
-			 in align [seq [str "actual: ", Type.layout t2],
-				   seq [str "formal: ", Type.layout t2'],
-				   seq [str "expression: ",
-					PrimExp.layout e]]
-			 end)
-		| NONE => error "function not of arrow type"
+	       let
+		  val t2 = checkVarExp x
+	       in
+		  case Type.dearrowOpt t1 of
+		     NONE => error "function not of arrow type"
+		   | SOME (t2', t3) =>
+			if Type.equals (t2, t2') then t3
+			else
+			   Type.error
+			   ("actual and formal not of same type",
+			    let open Layout
+			    in align [seq [str "actual: ", Type.layout t2],
+				      seq [str "formal: ", Type.layout t2'],
+				      seq [str "expression: ",
+					   PrimExp.layout e]]
+			    end)
 	       end
 	    fun checkApps (t, es) =
 	       List.fold (es, t, fn (e, t) => checkApp (t, e))
 	 in
 	    case e of
-	       App {func, arg} => checkApp (checkVarExp func, arg)
-	     | Case {test, cases, default} =>
+	       App {arg, func} => checkApp (checkVarExp func, arg)
+	     | Case {cases, default, test} =>
 		  let
-		     val ty = checkVarExp test
-		     fun doit (l, t) =
-			(Vector.new1 t, Vector.map (l, fn (_, e) => checkExp e))
+		     val default = Option.map (default, checkExp o #1)
 		     fun equalss v =
 			if Vector.isEmpty v
 			   then Error.bug "equalss"
@@ -172,37 +172,41 @@
 				 then SOME t
 			      else NONE
 			   end
+		     fun finish (ptys: Type.t vector,
+				 etys: Type.t vector): Type.t =
+			case (equalss ptys, equalss etys) of
+			   (NONE, _) => error "patterns not of same type"
+			 | (_, NONE) => error "branches not of same type"
+			 | (SOME pty, SOME ety) =>
+			      if Type.equals (checkVarExp test, pty)
+				 then
+				    case default of
+				       NONE => ety
+				     | SOME t =>
+					  if Type.equals (ety, t)
+					     then ety
+					  else error "default of wrong type"
+			      else error "test and patterns of different types"
+		     fun doit (l, t) =
+			finish (Vector.new1 t,
+				Vector.map (l, fn (_, e) => checkExp e))
 		     datatype z = datatype Cases.t
-		     val (ptys, etys) =
-			case cases of
-			   Char l => doit (l, Type.char)
-			 | Con cases =>
-			      Vector.unzip
-			      (Vector.map (cases, fn (p, e) =>
-					   (checkPat p, checkExp e)))
-			 | Int l => doit (l, Type.int)
-			 | Word l => doit (l, Type.word)
-			 | Word8 l => doit (l, Type.word8)
-		  in case (equalss ptys, equalss etys) of
-		     (NONE, _) => error "patterns not of same type"
-		   | (_, NONE) => error "branches not of same type"
-		   | (SOME pty, SOME ety) =>
-			if Type.equals (ty, pty)
-			   then
-			      case default of
-				 NONE => ety
-			       | SOME (e, _) =>
-				    if Type.equals (ety, checkExp e)
-				       then ety
-				    else error "default of wrong type"
-			else error "test and patterns of different types"
+		  in
+		     case cases of
+			Con cases =>
+			   finish (Vector.unzip
+				   (Vector.map (cases, fn (p, e) =>
+						(checkPat p, checkExp e))))
+		      | Int (s, cs) => doit (cs, Type.int s)
+		      | Word (s, cs) => doit (cs, Type.word s)
 		  end
 	     | ConApp {con, targs, arg} =>
 		  let
 		     val t = checkConExp (con, targs)
-		  in case arg of
-		     NONE => t
-		   | SOME e => checkApp (t, e)
+		  in
+		     case arg of
+			NONE => t
+		      | SOME e => checkApp (t, e)
 		  end
 	     | Const c => Type.ofConst c
 	     | Handle {try, catch = (catch, catchType), handler, ...} =>
@@ -214,7 +218,9 @@
 		     val _ = setVar (catch, {tyvars = Vector.new0 (),
 					     ty = catchType})
 		     val ty' = checkExp handler
-		  in if Type.equals (ty, ty') then ty
+		  in
+		     if Type.equals (ty, ty')
+			then ty
 		     else error "bad handle"
 		  end
 	     | Lambda l => checkLambda l



1.16      +57 -10    mlton/mlton/xml/xml-tree.fun

Index: xml-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- xml-tree.fun	13 Jan 2003 01:14:28 -0000	1.15
+++ xml-tree.fun	23 Jun 2003 04:59:00 -0000	1.16
@@ -63,9 +63,57 @@
       val layout = Apat.layout o toAst
    end
 
-structure Cases = Cases (type con = Pat.t
-			 val conEquals = fn _ => 
-			 Error.bug "XmlTree.Cases.conEquals")
+structure Cases =
+   struct
+      datatype 'a t = 
+	 Con of (Pat.t * 'a) vector
+       | Int of IntSize.t * (IntX.t * 'a) vector
+       | Word of WordSize.t * (WordX.t * 'a) vector
+
+      fun fold (c: 'a t, b: 'b, f: 'a * 'b -> 'b): 'b =
+	 let
+	    fun doit l = Vector.fold (l, b, fn ((_, a), b) => f (a, b))
+	 in
+	    case c of
+	       Con l => doit l
+	     | Int (_, l) => doit l
+	     | Word (_, l) => doit l
+	 end
+
+      fun map (c: 'a t, f: 'a -> 'b): 'b t =
+	 let
+	    fun doit l = Vector.map (l, fn (i, x) => (i, f x))
+	 in
+	    case c of
+	       Con l => Con (doit l)
+	     | Int (s, l) => Int (s, doit l)
+	     | Word (s, l) => Word (s, doit l)
+	 end
+      
+      fun forall (c: 'a t, f: 'a -> bool): bool =
+	 let
+	    fun doit l = Vector.forall (l, fn (_, x) => f x)
+	 in
+	    case c of
+	       Con l => doit l
+	     | Int (_, l) => doit l
+	     | Word (_, l) => doit l
+	 end
+
+      fun length (c: 'a t): int = fold (c, 0, fn (_, i) => i + 1)
+
+      fun foreach (c, f) = fold (c, (), fn (x, ()) => f x)
+
+      fun foreach' (c: 'a t, f: 'a -> unit, fc: Pat.t -> unit): unit =
+	 let
+	    fun doit l = Vector.foreach (l, fn (_, a) => f a)
+	 in
+	    case c of
+	       Con l => Vector.foreach (l, fn (c, a) => (fc c; f a))
+	     | Int (_, l) => doit l
+	     | Word (_, l) => doit l
+	 end
+   end
 
 (*---------------------------------------------------*)
 (*                      VarExp                       *)
@@ -210,12 +258,10 @@
 	       fn n => Ast.Pat.const (Ast.Const.makeRegion (n, Region.bogus))
 	    val cases =
 	       case cases of
-		  Char l => doit (l, make o Ast.Const.Char)
-		| Con l => Vector.map (l, fn (pat, exp) =>
+		  Con l => Vector.map (l, fn (pat, exp) =>
 				       (Pat.toAst pat, expToAst exp))
-		| Int l => doit (l, make o Ast.Const.Int o Int.toString)
-		| Word l => doit (l, make o Ast.Const.Word)
-		| Word8 l => doit (l, make o Ast.Const.Word o Word8.toWord)
+		| Int (_, l) => doit (l, make o Ast.Const.Int o IntX.toIntInf)
+		| Word (_, l) => doit (l, make o Ast.Const.Word o WordX.toIntInf)
 	    val cases =
 	       case default of
 		  NONE => cases
@@ -602,11 +648,12 @@
 	 
       fun const c = simple (Const c, Type.ofConst c)
 
-      val string = const o Const.fromString
+      val string = const o Const.string
 	 
       fun varExp (x, t) = simple (Var x, t)
 
-      fun var {var, targs, ty} = varExp (VarExp.T {var = var, targs = targs}, ty)
+      fun var {var, targs, ty} =
+	 varExp (VarExp.T {var = var, targs = targs}, ty)
 
       fun monoVar (x, t) = var {var = x, targs = Vector.new0 (), ty = t}
 



1.12      +12 -1     mlton/mlton/xml/xml-tree.sig

Index: xml-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- xml-tree.sig	25 Feb 2003 02:50:44 -0000	1.11
+++ xml-tree.sig	23 Jun 2003 04:59:00 -0000	1.12
@@ -41,7 +41,18 @@
 	    val layout: t -> Layout.t
 	 end
 
-      structure Cases: CASES sharing type Cases.con = Pat.t
+      structure Cases:
+	 sig
+	    datatype 'a t =
+	       Con of (Pat.t * 'a) vector
+	     | Int of IntSize.t * (IntX.t * 'a) vector
+	     | Word of WordSize.t * (WordX.t * 'a) vector
+
+	    val fold: 'a t * 'b * ('a * 'b -> 'b) -> 'b
+	    val foreach: 'a t * ('a -> unit) -> unit
+	    val foreach': 'a t * ('a -> unit) * (Pat.t -> unit) -> unit
+	    val map: 'a t * ('a -> 'b) -> 'b t
+	 end
 
       structure Lambda:
 	 sig



1.9       +2 -2      mlton/mlyacc/mlyacc-stubs.cm

Index: mlyacc-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlyacc/mlyacc-stubs.cm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- mlyacc-stubs.cm	15 May 2003 20:12:29 -0000	1.8
+++ mlyacc-stubs.cm	23 Jun 2003 04:59:00 -0000	1.9
@@ -131,8 +131,6 @@
 ../lib/mlton/basic/euclidean-ring.fun
 ../lib/mlton/basic/integer.fun
 ../lib/mlton/basic/int.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/char.sig
 ../lib/mlton/basic/char.sml
 ../lib/mlton/basic/vector.sig
@@ -164,6 +162,8 @@
 ../lib/mlton/basic/function.sig
 ../lib/mlton/basic/function.sml
 ../lib/mlton/basic/signal.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/dir.sig
 ../lib/mlton/basic/dir.sml
 ../lib/mlton/basic/process.sig



1.6       +2 -2      mlton/mlyacc/mlyacc.cm

Index: mlyacc.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlyacc/mlyacc.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- mlyacc.cm	1 Apr 2003 06:16:11 -0000	1.5
+++ mlyacc.cm	23 Jun 2003 04:59:00 -0000	1.6
@@ -97,8 +97,6 @@
 ../lib/mlton/basic/euclidean-ring.fun
 ../lib/mlton/basic/integer.fun
 ../lib/mlton/basic/int.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/char.sig
 ../lib/mlton/basic/char.sml
 ../lib/mlton/basic/vector.sig
@@ -130,6 +128,8 @@
 ../lib/mlton/basic/function.sig
 ../lib/mlton/basic/function.sml
 ../lib/mlton/basic/signal.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/dir.sig
 ../lib/mlton/basic/dir.sml
 ../lib/mlton/basic/process.sig



1.64      +0 -4      mlton/runtime/Makefile

Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Makefile,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -r1.63 -r1.64
--- Makefile	19 Jun 2003 15:38:04 -0000	1.63
+++ Makefile	23 Jun 2003 04:59:01 -0000	1.64
@@ -78,13 +78,11 @@
 	basis/Ptrace/ptrace2.o			\
 	basis/Ptrace/ptrace4.o			\
 	basis/Real/class.o			\
-	basis/Real/const.o			\
 	basis/Real/gdtoa.o			\
 	basis/Real/isFinite.o			\
 	basis/Real/isNan.o			\
 	basis/Real/isNormal.o			\
 	basis/Real/nextAfter.o			\
-	basis/Real/qequal.o			\
 	basis/Real/real.o			\
 	basis/Real/round.o			\
 	basis/Real/signBit.o			\
@@ -249,13 +247,11 @@
 	basis/Ptrace/ptrace2-gdb.o		\
 	basis/Ptrace/ptrace4-gdb.o		\
 	basis/Real/class-gdb.o			\
-	basis/Real/const-gdb.o			\
 	basis/Real/gdtoa-gdb.o			\
 	basis/Real/isFinite-gdb.o		\
 	basis/Real/isNan-gdb.o			\
 	basis/Real/isNormal-gdb.o		\
 	basis/Real/nextAfter-gdb.o		\
-	basis/Real/qequal-gdb.o			\
 	basis/Real/real-gdb.o			\
 	basis/Real/round-gdb.o			\
 	basis/Real/signBit-gdb.o		\



1.144     +3 -3      mlton/runtime/gc.c

Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.143
retrieving revision 1.144
diff -u -r1.143 -r1.144
--- gc.c	17 Jun 2003 01:23:31 -0000	1.143
+++ gc.c	23 Jun 2003 04:59:01 -0000	1.144
@@ -4549,7 +4549,7 @@
  * The second word is the weak pointer.
  */ 
 
-Bool GC_weakCanGet (pointer p) {
+bool GC_weakCanGet (pointer p) {
 	Bool res;
 
 	res = WEAK_GONE_HEADER != GC_getHeader (p);
@@ -4559,7 +4559,7 @@
 	return res;
 }
 
-pointer GC_weakGet (pointer p) {
+Pointer GC_weakGet (Pointer p) {
 	pointer res;
 
 	res = ((GC_weak)p)->object;
@@ -4569,7 +4569,7 @@
 	return res;
 }
 
-pointer GC_weakNew (GC_state s, W32 header, pointer p) {
+Pointer GC_weakNew (GC_state s, Word32 header, Pointer p) {
 	pointer res;
 
 	res = object (s, header, GC_NORMAL_HEADER_SIZE + 3 * WORD_SIZE, 



1.24      +31 -60    mlton/runtime/mlton-basis.h

Index: mlton-basis.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/mlton-basis.h,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- mlton-basis.h	19 Jun 2003 15:38:04 -0000	1.23
+++ mlton-basis.h	23 Jun 2003 04:59:01 -0000	1.24
@@ -6,18 +6,9 @@
 #endif
 #include <sys/resource.h>
 
-/* Here are the types that the abstract machine deals with.
- * See backend/mtype.sig.
- */
-typedef char Char;
-typedef double Double;
-typedef int Int;
-typedef char *Pointer;
-typedef unsigned long Word32;
-typedef Word32 Word;
+#include "types.h"
 
 /* Here are some type abbreviations for abstract machine types. */
-typedef Int Bool;
 typedef Word Cpointer;
 typedef Word Cstring;
 typedef Pointer Thread;
@@ -28,15 +19,15 @@
 /*                       Array                       */
 /* ------------------------------------------------- */
 
-Int Array_numElements(Pointer p);
+Int Array_numElements (Pointer p);
 
 /* ------------------------------------------------- */
 /*                         C                         */
 /* ------------------------------------------------- */
 
-Char C_CS_sub(Cstring s, Int i);
-void C_CS_update(Cstring s, Int i, Char c);
-Cstring C_CSS_sub(CstringArray a, Int i);
+Char C_CS_sub (Cstring s, Int i);
+void C_CS_update (Cstring s, Int i, Char c);
+Cstring C_CSS_sub (CstringArray a, Int i);
 
 /* ------------------------------------------------- */
 /*                    CommandLine                    */
@@ -81,22 +72,22 @@
 /*                       Debug                       */
 /* ------------------------------------------------- */
 
-void Debug_enter(Pointer name);
-void Debug_leave(Pointer name);
+void Debug_enter (Pointer name);
+void Debug_leave (Pointer name);
 
 /* ------------------------------------------------- */
 /*                        GC                         */
 /* ------------------------------------------------- */
 
-void GC_setMessages(Int b);
-void GC_setSummary(Int b);
+void GC_setMessages (Int b);
+void GC_setSummary (Int b);
 
 /* ------------------------------------------------- */
 /*                     IEEEReal                      */
 /* ------------------------------------------------- */
 
-void IEEEReal_setRoundingMode(Int mode);
-Int IEEEReal_getRoundingMode();
+void IEEEReal_setRoundingMode (Int mode);
+Int IEEEReal_getRoundingMode ();
 
 /* ------------------------------------------------- */
 /*                      Itimer                       */
@@ -120,12 +111,12 @@
 Bool MLton_Callback_fetchB(Int l);
 Char MLton_Callback_fetchC(Int l);
 Int MLton_Callback_fetchI(Int l);
-Double MLton_Callback_fetchR(Int l);
+Real MLton_Callback_fetchR(Int l);
 Word MLton_Callback_fetchW(Int l);
 void MLton_Callback_retB(Bool b);
 void MLton_Callback_retC(Char c);
 void MLton_Callback_retI(Int i);
-void MLton_Callback_retR(Double r);
+void MLton_Callback_retR(Real r);
 void MLton_Callback_retW(Word w);
 /* C functions */
 int MLton_Callback_call(char *rep, char *name, ...);
@@ -153,43 +144,23 @@
 /*                        OS                         */
 /* ------------------------------------------------- */
 
-Cstring OS_FileSys_tmpnam();
-Int OS_IO_poll(Int *fds, Word *eventss, Int n, Int timeout, Word *reventss);
+Cstring OS_FileSys_tmpnam ();
+Int OS_IO_poll (Int *fds, Word *eventss, Int n, Int timeout, Word *reventss);
 
 /* ------------------------------------------------- */
 /*                     PackReal                      */
 /* ------------------------------------------------- */
 
-Double PackReal_subVec(Pointer v, Int offset);
-void PackReal_update(Pointer a, Int offset, Double r);
+Real64 PackReal_subVec (Pointer v, Int offset);
+void PackReal_update (Pointer a, Int offset, Real64 r);
 
 /* ------------------------------------------------- */
 /*                      Ptrace                       */
 /* ------------------------------------------------- */
 
-Int Ptrace_ptrace2(Int request, Int pid);
+Int Ptrace_ptrace2 (Int request, Int pid);
 /* data is a word ref */
-Int Ptrace_ptrace4(Int request, Int pid, Word addr, Pointer data);
-
-/* ------------------------------------------------- */
-/*                       Real                        */
-/* ------------------------------------------------- */
-
-extern Double Real_Math_e;
-extern Double Real_Math_pi;
-extern Double Real_posInf;
-extern Double Real_maxFinite;
-extern Double Real_minNormalPos;
-extern Double Real_minPos;
-
-Int Real_class (Double d);
-Int Real_isFinite (Double d);
-Int Real_isNan (Double d);
-Int Real_isNormal (Double d);
-Int Real_isPositive (Double d);
-Int Real_qequal (Double x1, Double x2);
-double Real_round (Double d);
-Int Real_signBit (Double d);
+Int Ptrace_ptrace4 (Int request, Int pid, Word addr, Pointer data);
 
 /* ------------------------------------------------- */
 /*                      Rlimit                       */
@@ -224,23 +195,23 @@
 typedef Word Rlimit;
 typedef Int Resource;
 
-Int MLton_Rlimit_get(Resource r);
-Rlimit MLton_Rlimit_getHard();
-Rlimit MLton_Rlimit_getSoft();
-Int MLton_Rlimit_set(Resource r, Rlimit hard, Rlimit soft);
+Int MLton_Rlimit_get (Resource r);
+Rlimit MLton_Rlimit_getHard ();
+Rlimit MLton_Rlimit_getSoft ();
+Int MLton_Rlimit_set (Resource r, Rlimit hard, Rlimit soft);
 
 /* ------------------------------------------------- */
 /*                       Stdio                       */
 /* ------------------------------------------------- */
 
-void Stdio_print(Pointer s);
-Int Stdio_sprintf(Pointer buf, Pointer fmt, Double x);
+void Stdio_print (Pointer s);
+Int Stdio_sprintf (Pointer buf, Pointer fmt, Real64 x);
 
 /* ------------------------------------------------- */
 /*                      String                       */
 /* ------------------------------------------------- */
 
-int String_equal(char * s1, char * s2);
+int String_equal (char * s1, char * s2);
 
 /* ------------------------------------------------- */
 /*                      Thread                       */
@@ -259,20 +230,20 @@
 /*                       Time                        */
 /* ------------------------------------------------- */
 
-Int Time_gettimeofday();
-Int Time_sec();
-Int Time_usec();
+Int Time_gettimeofday ();
+Int Time_sec ();
+Int Time_usec ();
 
 /* ------------------------------------------------- */
 /*                       Word8                       */
 /* ------------------------------------------------- */
 
-Char Word8_arshiftAsm(Char w, Word s);
+Char Word8_arshiftAsm (Char w, Word s);
 
 /* ------------------------------------------------- */
 /*                      Word32                       */
 /* ------------------------------------------------- */
 
-Word Word32_arshiftAsm(Word w, Word s);
+Word Word32_arshiftAsm (Word w, Word s);
 
 #endif /* #ifndef _MLTON_BASIS_H_ */



1.1                  mlton/runtime/types.h

Index: types.h
===================================================================
#ifndef _TYPES_H_
#define _TYPES_H_

typedef char Int8;
typedef short Int16;
typedef long Int32;
typedef long long Int64;
typedef char *Pointer;
typedef float Real32;
typedef double Real64;
typedef unsigned char Word8;
typedef unsigned short Word16;
typedef unsigned long Word32;
typedef unsigned long long Word64;

typedef Int32 Int;
typedef Real64 Real;
typedef Word8 Char;
typedef Word32 Word;

typedef Int Bool;

#endif /* _TYPES_H_ */



1.2       +2 -2      mlton/runtime/Posix/Process/exit.c

Index: exit.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Posix/Process/exit.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- exit.c	18 Jul 2001 05:51:06 -0000	1.1
+++ exit.c	23 Jun 2003 04:59:01 -0000	1.2
@@ -1,6 +1,6 @@
 #include <stdlib.h>
 #include "mlton-posix.h"
 
-void Posix_Process_exit(int i) {
-	exit(i);
+void Posix_Process_exit (Int i) {
+	exit (i);
 }



1.2       +2 -2      mlton/runtime/Posix/Process/sleep.c

Index: sleep.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Posix/Process/sleep.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- sleep.c	18 Jul 2001 05:51:06 -0000	1.1
+++ sleep.c	23 Jun 2003 04:59:01 -0000	1.2
@@ -1,6 +1,6 @@
 #include <unistd.h>
 #include "mlton-posix.h"
 
-int Posix_Process_sleep(int i) {
-	return sleep(i);
+Int Posix_Process_sleep (Int i) {
+	return sleep (i);
 }



1.11      +4 -4      mlton/runtime/Posix/Signal/Signal.c

Index: Signal.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Posix/Signal/Signal.c,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- Signal.c	12 May 2003 23:14:16 -0000	1.10
+++ Signal.c	23 Jun 2003 04:59:01 -0000	1.11
@@ -5,7 +5,7 @@
 
 extern struct GC_state gcState;
 
-static void handler (Int signum) {
+static void handler (int signum) {
 	GC_handler (&gcState, signum);
 }
 
@@ -29,7 +29,7 @@
 	return sigaction (signum, &sa, NULL);
 }
 
-Int Posix_Signal_handle (int signum) {
+Int Posix_Signal_handle (Int signum) {
 	static struct sigaction sa;
 
 	sigaddset (&gcState.signalsHandled, signum);
@@ -69,11 +69,11 @@
 
 static sigset_t set;
 
-Int Posix_Signal_sigaddset (int signum) {
+Int Posix_Signal_sigaddset (Int signum) {
 	return sigaddset (&set, signum);
 }
 
-Int Posix_Signal_sigdelset (int signum) {
+Int Posix_Signal_sigdelset (Int signum) {
 	return sigdelset (&set, signum);
 }
 



1.3       +1 -1      mlton/runtime/Posix/Signal/isPending.c

Index: isPending.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Posix/Signal/isPending.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- isPending.c	12 May 2003 08:40:54 -0000	1.2
+++ isPending.c	23 Jun 2003 04:59:01 -0000	1.3
@@ -18,6 +18,6 @@
  	return res;
 }
 
-bool Posix_Signal_isPending (Int signum) {
+Bool Posix_Signal_isPending (Int signum) {
 	return sigismember (&gcState.signalsPending, signum);
 }



1.3       +3 -3      mlton/runtime/basis/IEEEReal.c

Index: IEEEReal.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/IEEEReal.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- IEEEReal.c	10 Apr 2003 02:03:12 -0000	1.2
+++ IEEEReal.c	23 Jun 2003 04:59:01 -0000	1.3
@@ -14,7 +14,7 @@
 #define ROUNDING_CONTROL_MASK 0x0C00
 #define ROUNDING_CONTROL_SHIFT 10
 
-void IEEEReal_setRoundingMode (int mode) {
+void IEEEReal_setRoundingMode (Int mode) {
 	unsigned short controlWord;
 
 	_FPU_GETCW(controlWord);
@@ -34,7 +34,7 @@
 
 #include <ieeefp.h>
 
-void IEEEReal_setRoundingMode (int mode) {
+void IEEEReal_setRoundingMode (Int mode) {
 	switch (mode) {
 	case 0: mode = FP_RN; break;
 	case 1: mode = FP_RM; break;
@@ -46,7 +46,7 @@
 	fpsetround (mode);
 }
  
-int IEEEReal_getRoundingMode () {
+Int IEEEReal_getRoundingMode () {
 	int mode;
 
 	mode = fpgetround ();



1.3       +4 -4      mlton/runtime/basis/Stdio.c

Index: Stdio.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Stdio.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- Stdio.c	10 Jan 2003 16:36:20 -0000	1.2
+++ Stdio.c	23 Jun 2003 04:59:01 -0000	1.3
@@ -3,12 +3,12 @@
 #include "my-lib.h"
 
 void Stdio_print (Pointer s) {
-	if (0 == Array_numElements(s))
+	if (0 == Array_numElements (s))
 		return;
-	while (1 != fwrite(s, Array_numElements(s), 1, stderr))
+	while (1 != fwrite (s, Array_numElements(s), 1, stderr))
 		/* nothing */;
 }
 
-Int Stdio_sprintf (Pointer buf, Pointer fmt, Double x) {
-	return sprintf(buf, (char*) fmt, x);
+Int Stdio_sprintf (Pointer buf, Pointer fmt, Real x) {
+	return sprintf (buf, (char*) fmt, x);
 }



1.5       +2 -2      mlton/runtime/basis/Int/quot.c

Index: quot.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Int/quot.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- quot.c	10 Apr 2003 02:03:12 -0000	1.4
+++ quot.c	23 Jun 2003 04:59:01 -0000	1.5
@@ -26,10 +26,10 @@
  * implements / and %.
  */
 
-Int Int_quot (Int n, Int d) {
+Int32 Int32_quot (Int32 n, Int32 d) {
 #if (defined (__i386__) || defined (__sparc__))
 	return n / d;
 #else
-#error check that C / correctly implements Int.quot from the basis library
+#error check that C / correctly implements Int32.quot from the basis library
 #endif
 }



1.4       +2 -2      mlton/runtime/basis/Int/rem.c

Index: rem.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Int/rem.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- rem.c	10 Apr 2003 02:03:12 -0000	1.3
+++ rem.c	23 Jun 2003 04:59:01 -0000	1.4
@@ -2,10 +2,10 @@
 
 /* See the comment in quot.c. */
 
-Int Int_rem (Int n, Int d) {
+Int32 Int32_rem (Int32 n, Int32 d) {
 #if (defined (__i386__) || defined (__sparc__))
 	return n % d;
 #else
-#error check that C % correctly implements Int.rem from the basis library
+#error check that C % correctly implements Int32.rem from the basis library
 #endif
 }



1.2       +6 -6      mlton/runtime/basis/MLton/Callback.c

Index: Callback.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/MLton/Callback.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- Callback.c	19 Jun 2003 15:38:04 -0000	1.1
+++ Callback.c	23 Jun 2003 04:59:01 -0000	1.2
@@ -6,13 +6,13 @@
 static Bool argB[10];
 static Char argC[10];
 static Int argI[10];
-static Double argR[10];
+static Real argR[10];
 static Word argW[10];
 
 static Bool resB;
 static Char resC;
 static Int resI;
-static Double resR;
+static Real resR;
 static Word resW;
 
 Cstring callbackName;
@@ -39,7 +39,7 @@
   return argI[l];
 }
 
-Double MLton_Callback_fetchR(Int l) {
+Real MLton_Callback_fetchR(Int l) {
   return argR[l];
 }
 
@@ -59,7 +59,7 @@
   resI = i;
 }
 
-void MLton_Callback_retR(Double r) {
+void MLton_Callback_retR(Real r) {
   resR = r;
 }
 
@@ -102,7 +102,7 @@
       argI[indices[2]++] = va_arg(ap, Int);
       break;
     case 'R':
-      argR[indices[3]++] = va_arg(ap, Double);
+      argR[indices[3]++] = va_arg(ap, Real);
       break;
     case 'U':
       break;
@@ -125,7 +125,7 @@
     *(va_arg(ap, Int*)) = resI;
     break;
   case 'R':
-    *(va_arg(ap, Double*)) = resR;
+    *(va_arg(ap, Real*)) = resR;
     break;
   case 'U':
     break;



1.3       +1 -1      mlton/runtime/basis/MLton/exit.c

Index: exit.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/MLton/exit.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- exit.c	6 Jul 2002 17:22:08 -0000	1.2
+++ exit.c	23 Jun 2003 04:59:01 -0000	1.3
@@ -3,7 +3,7 @@
 
 extern struct GC_state gcState;
 
-void MLton_exit (int status) {
+void MLton_exit (Int status) {
 	GC_done (&gcState);
 	exit (status);
 }



1.2       +1 -1      mlton/runtime/basis/PackReal/subVec.c

Index: subVec.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/PackReal/subVec.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- subVec.c	18 Jul 2001 05:51:06 -0000	1.1
+++ subVec.c	23 Jun 2003 04:59:01 -0000	1.2
@@ -1,6 +1,6 @@
 #include "mlton-basis.h"
 
-Double PackReal_subVec(Pointer v, Int offset) {
+Real64 PackReal_subVec (Pointer v, Int offset) {
 	double r;
 	char *p = (char*)&r;
 	char *s = v + offset;



1.2       +1 -1      mlton/runtime/basis/PackReal/update.c

Index: update.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/PackReal/update.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- update.c	18 Jul 2001 05:51:06 -0000	1.1
+++ update.c	23 Jun 2003 04:59:01 -0000	1.2
@@ -1,6 +1,6 @@
 #include "mlton-basis.h"
 
-void PackReal_update(Pointer a, Int offset, Double r) {
+void PackReal_update (Pointer a, Int offset, Real r) {
 	char *p = (char*)&r;
 	char *s = a + offset;
 	int i;



1.3       +2 -2      mlton/runtime/basis/Real/class.c

Index: class.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/class.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- class.c	2 Jun 2003 20:59:36 -0000	1.2
+++ class.c	23 Jun 2003 04:59:01 -0000	1.3
@@ -40,7 +40,7 @@
 #define SIGNBIT_MASK  0x80000000
 #define MANTISSA_HIGHBIT_MASK 0x00080000
 
-Int Real_class (Double d) {
+Int Real64_class (Real64 d) {
 	Word word0, word1;
 	Int res;
 
@@ -73,7 +73,7 @@
 
 #elif (defined __sparc__)
 
-Int Real_class (Double d) {
+Int Real64_class (Real64 d) {
 	fpclass_t c;
 
 	c = fpclass (d);



1.2       +1 -1      mlton/runtime/basis/Real/gdtoa.c

Index: gdtoa.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/gdtoa.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- gdtoa.c	1 Jun 2003 00:31:34 -0000	1.1
+++ gdtoa.c	23 Jun 2003 04:59:02 -0000	1.2
@@ -21,7 +21,7 @@
 #endif
 
 /* This code is patterned on g_dfmt from the gdtoa sources. */
-char * Real_gdtoa (double d, int mode, int ndig, int *decpt) {
+char * Real64_gdtoa (double d, int mode, int ndig, int *decpt) {
 	ULong bits[2];
 	int ex;
 	static FPI fpi = { 53, 1-1023-53+1, 2046-1023-53+1, 1, 0 };



1.3       +1 -1      mlton/runtime/basis/Real/isFinite.c

Index: isFinite.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/isFinite.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- isFinite.c	2 Jun 2003 20:59:36 -0000	1.2
+++ isFinite.c	23 Jun 2003 04:59:02 -0000	1.3
@@ -4,6 +4,6 @@
 #endif
 #include "mlton-basis.h"
 
-Int Real_isFinite (Double d) {
+Int Real64_isFinite (Real64 d) {
 	return finite (d); /* finite is from math.h */
 }



1.3       +3 -3      mlton/runtime/basis/Real/isNan.c

Index: isNan.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/isNan.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- isNan.c	2 Jun 2003 20:59:36 -0000	1.2
+++ isNan.c	23 Jun 2003 04:59:02 -0000	1.3
@@ -6,13 +6,13 @@
 
 #if (defined (__i386__))
 
-Int Real_isNan (Double d) {
+Int Real64_isNan (Real64 d) {
 	return isnan (d); /* isnan is from math.h */
 }
 
 #elif (defined __sparc__)
 
-Int Real_isNan (Double d) {
+Int Real64_isNan (Real64 d) {
 	fpclass_t c;
 
 	c = fpclass (d);
@@ -21,6 +21,6 @@
 
 #else
 
-#error Real_isNan not defined
+#error Real64_isNan not defined
 
 #endif



1.3       +3 -3      mlton/runtime/basis/Real/isNormal.c

Index: isNormal.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/isNormal.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- isNormal.c	2 Jun 2003 20:59:36 -0000	1.2
+++ isNormal.c	23 Jun 2003 04:59:02 -0000	1.3
@@ -9,7 +9,7 @@
 
 #define EXPONENT_MASK 0x7FF00000
 
-Int Real_isNormal (Double d) {
+Int Real64_isNormal (Real64 d) {
 	Word word1, exponent;
 
 	word1 = ((Word *)&d)[1];
@@ -21,7 +21,7 @@
 
 #elif (defined __sparc__)
 
-Int Real_isNormal (Double d) {
+Int Real64_isNormal (Real64 d) {
 	fpclass_t c;
 
 	c = fpclass (d);
@@ -30,6 +30,6 @@
 
 #else
 
-#error Real_isNormal not defined
+#error Real64_isNormal not defined
 
 #endif



1.2       +1 -1      mlton/runtime/basis/Real/nextAfter.c

Index: nextAfter.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/nextAfter.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- nextAfter.c	1 Jun 2003 00:31:34 -0000	1.1
+++ nextAfter.c	23 Jun 2003 04:59:02 -0000	1.2
@@ -1,6 +1,6 @@
 #include <math.h>
 #include "mlton-basis.h"
 
-Double Real_nextAfter (Double x1, Double x2) {
+Real64 Real64_nextAfter (Real64 x1, Real64 x2) {
 	return nextafter (x1, x2);
 }



1.2       +5 -8      mlton/runtime/basis/Real/real.c

Index: real.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/real.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- real.c	1 Jun 2003 00:31:34 -0000	1.1
+++ real.c	23 Jun 2003 04:59:02 -0000	1.2
@@ -2,13 +2,10 @@
 #include "basis-constants.h"
 #include "mlton-basis.h"
 
-Double Real_Math_pi = M_PI;
-Double Real_Math_e = M_E;
+Real64 Real64_Math_pi = M_PI;
+Real64 Real64_Math_e = M_E;
 
-#if (defined __sparc__)
+Real64 Real64_maxFinite =    1.7976931348623157e308;
+Real64 Real64_minNormalPos = 2.22507385850720140e-308;
+Real64 Real64_minPos =       4.94065645841246544e-324;
 
-double Real_maxFinite =    1.7976931348623157e308;
-double Real_minPos =       4.94065645841246544e-324;
-double Real_minNormalPos = 2.22507385850720140e-308;
-
-#endif



1.2       +2 -2      mlton/runtime/basis/Real/round.c

Index: round.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/round.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- round.c	1 Jun 2003 00:31:34 -0000	1.1
+++ round.c	23 Jun 2003 04:59:02 -0000	1.2
@@ -3,7 +3,7 @@
 
 #if (defined (__i386__))
 
-Double Real_round (Double d) {
+Real64 Real64_round (Real64 d) {
 	register double f0;
 
 	f0 = d;
@@ -16,7 +16,7 @@
 
 #elif (defined __sparc__)
 
-Double Real_round (Double d) {
+Real64 Real64_round (Real64 d) {
 	return rint (d);
 }
 



1.2       +1 -1      mlton/runtime/basis/Real/signBit.c

Index: signBit.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/signBit.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- signBit.c	1 Jun 2003 00:31:34 -0000	1.1
+++ signBit.c	23 Jun 2003 04:59:02 -0000	1.2
@@ -1,5 +1,5 @@
 #include "mlton-basis.h"
 
-Int Real_signBit (Double d) {
+Int Real64_signBit (Real64 d) {
 	return (((unsigned char *)&d)[7] & 0x80) >> 7;
 }



1.2       +2 -2      mlton/runtime/basis/Real/strtod.c

Index: strtod.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/strtod.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- strtod.c	1 Jun 2003 00:31:34 -0000	1.1
+++ strtod.c	23 Jun 2003 04:59:02 -0000	1.2
@@ -4,9 +4,9 @@
 #include "mlton-basis.h"
 #include "my-lib.h"
 
-Double Real_strtod (char *s) {
+Real64 Real64_strtod (char *s) {
 	char *endptr;
-	Double res;
+	Real64 res;
 
 	res = strtod (s, &endptr);
 	assert (NULL != endptr);





-------------------------------------------------------
This SF.Net email is sponsored by: INetU
Attention Web Developers & Consultants: Become An INetU Hosting Partner.
Refer Dedicated Servers. We Manage Them. You Get 10% Monthly Commission!
INetU Dedicated Managed Hosting http://www.inetu.net/partner/index.php
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel