[MLton-devel] cvs commit: types for Rssa

Stephen Weeks sweeks@users.sourceforge.net
Fri, 06 Dec 2002 18:21:54 -0800


sweeks      02/12/06 18:21:54

  Modified:    .        Makefile
               basis-library/misc primitive.sml
               include  ccodegen.h x86codegen.h
               mlton    Makefile mlton-stubs-1997.cm mlton-stubs.cm
                        mlton.cm
               mlton/ast record.fun
               mlton/atoms id.fun id.sig prim.fun prim.sig sources.cm
               mlton/backend allocate-registers.fun allocate-registers.sig
                        backend.fun chunkify.fun limit-check.fun
                        machine.fun machine.sig profile-alloc.fun
                        representation.fun representation.sig rssa.fun
                        rssa.sig runtime.fun runtime.sig signal-check.fun
                        sources.cm ssa-to-rssa.fun ssa-to-rssa.sig
               mlton/codegen/c-codegen c-codegen.fun
               mlton/codegen/x86-codegen x86-codegen.fun
                        x86-mlton-basic.fun x86-mlton-basic.sig
                        x86-mlton.fun x86-translate.fun x86.sig
               mlton/control control.sig control.sml
               mlton/elaborate elaborate-env.fun
               mlton/main compile.sml main.sml
               mlton/ssa analyze.fun constant-propagation.fun ssa-tree.fun
                        ssa-tree.sig useless.fun
               mlton/type-inference infer.fun type-env.fun
               runtime  gc.c
  Added:       mlton/backend machine-atoms.fun machine-atoms.sig switch.fun
                        switch.sig
  Removed:     mlton/backend machine-cases.fun machine-cases.sig
  Log:
  Added types to Rssa and Machine, as discussed in earlier email.  The
  basic idea is to have object types that correspond to the header
  information that is available to the runtime, and sum types that are
  used to represent datatypes.  See backend/machine-atoms.sig for the
  new types.
  
  There is now quite a bit of type checking that is done on Rssa, but it
  is still far from type safe, partially due to lack of effort and
  partially due to some unsolved problems.  A careful pass through the
  type checker in rssa.fun should make stuff better.  But there are
  still some casts used.  See castIsOk in machine-atoms.fun to see the
  casts that are currently allowed.  Other things that remain to be
  (type-)checked: liveness info, limit checks, case statements that
  narrow types, globals defined before use, primapps, ...
  
  Various primitives are now implemented as casts by SsaToRssa instead
  of being implemented in the codegens.
  
  	Byte_byteToChar
  	Byte_charToByte
  	C_CS_charArrayToWord8Array
  	IntInf_fromVector
  	IntInf_fromWord
  	IntInf_toVector
  	IntInf_toWord
  	String_fromWord8Vector
  	String_toWord8Vector
  	Vector_fromArray
  	Word32_fromInt
  	Word32_toIntX
  
  Of course, some of these are unsafe (e.g. IntInf_fromWord).
  Vector_fromArray now changes the object header, in anticipation of
  object headers including mutability information some day.
  
  It should now be a simple matter to use headers as variant tags, but
  I haven't done it yet.
  
  Combined all the switch statements used by Rssa and Machine into a
  single datatype -- see backend/switch.sig.  With that and the changes
  to operands, Rssa and Machine are starting to look suspiciously
  similar.  Hopefully one day we will be able to unify them.
  
  Eliminated Array_array0, and Array_array is now used to allocate
  zero-length arrays.  This required a minor change to the runtime,
  since zero-length arrays now have the proper type tag instead of all
  having the same one.
  
  The backend register allocation is no longer attempts to share a
  register for multiple variables.  This may cause performance problems
  since the local{char,int,...}  arrays used by the native codegen to
  cache real registers will no longer be as small or as densely used.
  
  There were some pretty straightforward changes to the codegens to
  keep up with the changes to MACHINE.
  
  Added a new flag "-keep rssa" and added lots of improvements to Rssa
  pretty printing.
  
  Changes for rearrangement of sorting functions in library.

Revision  Changes    Path
1.80      +1 -1      mlton/Makefile

Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/Makefile,v
retrieving revision 1.79
retrieving revision 1.80
diff -u -r1.79 -r1.80
--- Makefile	21 Nov 2002 02:49:20 -0000	1.79
+++ Makefile	7 Dec 2002 02:21:50 -0000	1.80
@@ -44,7 +44,7 @@
 
 .PHONY: cm
 cm:
-	$(MAKE) -C $(COMP) mlton_cm
+	$(MAKE) -C $(COMP) mlton_cm mlton-stubs-1997_cm
 	$(MAKE) -C $(LEX) mllex_cm
 	$(MAKE) -C $(PROF) mlprof_cm
 	$(MAKE) -C $(YACC) mlyacc_cm



1.42      +5 -6      mlton/basis-library/misc/primitive.sml

Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- primitive.sml	5 Dec 2002 01:25:15 -0000	1.41
+++ primitive.sml	7 Dec 2002 02:21:50 -0000	1.42
@@ -242,12 +242,11 @@
 	 struct
 	    open Array
 
-      	    fun array n =
-	       if safe andalso Int.< (n, 0)
-		  then raise Size
-	       else if eq (n, 0)
-		       then _prim "Array_array0": unit -> 'a array; ()
-		    else _prim "Array_array": int -> 'a array; n
+	    val array = fn n => _prim "Array_array": int -> 'a array; n
+      	    val array =
+	       fn n => if safe andalso Int.< (n, 0)
+			  then raise Size
+		       else array n
 	 end
 
       structure IntInf =



1.42      +5 -43     mlton/include/ccodegen.h

Index: ccodegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/ccodegen.h,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- ccodegen.h	24 Nov 2002 01:19:41 -0000	1.41
+++ ccodegen.h	7 Dec 2002 02:21:51 -0000	1.42
@@ -41,13 +41,6 @@
 		sfread(globaluint, sizeof(uint), u, file);			\
 	}
 
-#define Locals(c, d, i, p, u)						\
-	char localuchar[c];						\
-	double localdouble[d];				       		\
-	int localint[i];						\
-	pointer localpointer[p];					\
-	uint localuint[u]
-
 #define BeginIntInfs static struct GC_intInfInit intInfInits[] = {
 #define IntInf(g, n) { g, n },
 #define EndIntInfs { 0, NULL }};
@@ -56,9 +49,9 @@
 #define String(g, s, l) { g, s, l },
 #define EndStrings { 0, NULL, 0 }};
 
-#define BeginFloats static void float_Init() {
-#define Float(c, f) globaldouble[c] = f;
-#define EndFloats }
+#define BeginReals static void real_Init() {
+#define Real(c, f) globaldouble[c] = f;
+#define EndReals }
 
 #define IsInt(p) (0x3 & (int)(p))
 
@@ -140,7 +133,7 @@
 	gcState.stringInits = stringInits;				\
 	MLton_init (argc, argv, &gcState);				\
 	if (gcState.isOriginal) {					\
-		float_Init();						\
+		real_Init();						\
 		PrepFarJump(mc, ml);					\
 	} else {							\
 		/* Return to the saved world */				\
@@ -205,6 +198,7 @@
 #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)
 
 #define Offset(ty, b, o) (*(ty*)((b) + (o)))
@@ -342,19 +336,6 @@
 #define XU(b, i) ArrayOffset(uint, b, i)
 
 /* ------------------------------------------------- */
-/*                       Byte                        */
-/* ------------------------------------------------- */
-
-#define Byte_byteToChar(b) b
-#define Byte_charToByte(c) c
-
-/* ------------------------------------------------- */
-/*                         C                         */
-/* ------------------------------------------------- */
-
-#define C_CS_charArrayToWord8Array(x) x
-
-/* ------------------------------------------------- */
 /*                       Char                        */
 /* ------------------------------------------------- */
 
@@ -584,15 +565,6 @@
 #define Int_neg(n) (-(n))
 
 /* ------------------------------------------------- */
-/*                      IntInf                       */
-/* ------------------------------------------------- */
-
-#define IntInf_fromVector(x) x
-#define IntInf_fromWord(w) ((pointer)(w))
-#define IntInf_toVector(x) x
-#define IntInf_toWord(i) ((uint)(i))
-
-/* ------------------------------------------------- */
 /*                       MLton                       */
 /* ------------------------------------------------- */
 
@@ -644,18 +616,10 @@
 #define Real_toInt(x) ((int)(x))
 
 /* ------------------------------------------------- */
-/*                      String                       */
-/* ------------------------------------------------- */
-
-#define String_fromWord8Vector(x) x
-#define String_toWord8Vector(x) x
-
-/* ------------------------------------------------- */
 /*                      Vector                       */
 /* ------------------------------------------------- */
 
 #define Vector_length GC_arrayNumElements
-#define Vector_fromArray(a) a
 
 /* ------------------------------------------------- */
 /*                       Word8                       */
@@ -715,7 +679,6 @@
  */
 #define Word32_arshift(w, s) ((int)(w) >> (s))
 #define Word32_div(w1, w2) ((w1) / (w2))
-#define Word32_fromInt(x) ((uint)(x))
 #define Word32_ge(w1, w2) ((w1) >= (w2))
 #define Word32_gt(w1, w2) ((w1) > (w2))
 #define Word32_le(w1, w2) ((w1) <= (w2))
@@ -730,7 +693,6 @@
 #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_toIntX(x) ((int)(x))
 #define Word32_xorb(w1, w2) ((w1) ^ (w2))
 
 #endif /* #ifndef _CCODEGEN_H_ */



1.19      +4 -4      mlton/include/x86codegen.h

Index: x86codegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86codegen.h,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- x86codegen.h	2 Nov 2002 03:37:36 -0000	1.18
+++ x86codegen.h	7 Dec 2002 02:21:51 -0000	1.19
@@ -60,9 +60,9 @@
 #define String(g, s, l) { g, s, l },
 #define EndStrings { 0, NULL, 0 }};
 
-#define BeginFloats static void float_Init() {
-#define Float(c, f) globaldouble[c] = f;
-#define EndFloats }
+#define BeginReals static void real_Init() {
+#define Real(c, f) globaldouble[c] = f;
+#define EndReals }
 
 #define Main(cs, mmc, mfs, mfi, mot, mg, ml, reserveEsp, a1, a2, a3) 	\
 extern pointer ml;							\
@@ -88,7 +88,7 @@
 	gcState.stringInits = stringInits;				\
 	MLton_init (argc, argv, &gcState);				\
 	if (gcState.isOriginal) {					\
-		float_Init();						\
+		real_Init();						\
 		jump = (pointer)&ml;   					\
 	} else {       							\
 		jump = *(pointer*)(gcState.stackTop - WORD_SIZE); 	\



1.63      +1 -1      mlton/mlton/Makefile

Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/Makefile,v
retrieving revision 1.62
retrieving revision 1.63
diff -u -r1.62 -r1.63
--- Makefile	7 Dec 2002 01:40:18 -0000	1.62
+++ Makefile	7 Dec 2002 02:21:51 -0000	1.63
@@ -4,7 +4,7 @@
 LIB = $(BUILD)/lib
 MLTON = mlton
 HOST = self
-FLAGS = @MLton $(RUNTIME_ARGS) gc-summary -- -host $(HOST) -v2 -o $(AOUT)
+FLAGS = @MLton $(RUNTIME_ARGS) gc-summary -- -host $(HOST) -v -o $(AOUT)
 NAME = mlton
 AOUT = mlton-compile
 PATH = $(BIN):$(shell echo $$PATH)



1.3       +8 -8      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.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- mlton-stubs-1997.cm	24 Nov 2002 22:59:47 -0000	1.2
+++ mlton-stubs-1997.cm	7 Dec 2002 02:21:51 -0000	1.3
@@ -200,6 +200,10 @@
 ast/ast.sig
 ast/ast-const.fun
 ast/field.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
@@ -319,13 +323,15 @@
 backend/mtype.sig
 backend/c-function.sig
 backend/runtime.sig
+backend/machine-atoms.sig
+backend/switch.sig
+backend/switch.fun
 backend/mtype.fun
 backend/c-function.fun
 backend/runtime.fun
 backend/err.sml
-backend/machine-cases.sig
+backend/machine-atoms.fun
 backend/machine.sig
-backend/machine-cases.fun
 backend/machine.fun
 ../lib/mlton/basic/unique-set.sig
 ../lib/mlton/basic/unique-set.fun
@@ -350,10 +356,6 @@
 backend/chunkify.sig
 backend/chunkify.fun
 backend/backend.sig
-../lib/mlton/basic/quick-sort.sig
-../lib/mlton/basic/insertion-sort.sig
-../lib/mlton/basic/insertion-sort.sml
-../lib/mlton/basic/quick-sort.sml
 backend/live.sig
 backend/live.fun
 backend/allocate-registers.sig
@@ -444,8 +446,6 @@
 elaborate/elaborate-env.sig
 elaborate/elaborate.sig
 elaborate/decs.fun
-../lib/mlton/basic/merge-sort.sig
-../lib/mlton/basic/merge-sort.sml
 elaborate/elaborate-env.fun
 elaborate/elaborate-sigexp.sig
 elaborate/elaborate-sigexp.fun



1.8       +8 -8      mlton/mlton/mlton-stubs.cm

Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- mlton-stubs.cm	24 Nov 2002 01:19:43 -0000	1.7
+++ mlton-stubs.cm	7 Dec 2002 02:21:51 -0000	1.8
@@ -199,6 +199,10 @@
 ast/ast.sig
 ast/ast-const.fun
 ast/field.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
@@ -318,13 +322,15 @@
 backend/mtype.sig
 backend/c-function.sig
 backend/runtime.sig
+backend/machine-atoms.sig
+backend/switch.sig
+backend/switch.fun
 backend/mtype.fun
 backend/c-function.fun
 backend/runtime.fun
 backend/err.sml
-backend/machine-cases.sig
+backend/machine-atoms.fun
 backend/machine.sig
-backend/machine-cases.fun
 backend/machine.fun
 ../lib/mlton/basic/unique-set.sig
 ../lib/mlton/basic/unique-set.fun
@@ -349,10 +355,6 @@
 backend/chunkify.sig
 backend/chunkify.fun
 backend/backend.sig
-../lib/mlton/basic/quick-sort.sig
-../lib/mlton/basic/insertion-sort.sig
-../lib/mlton/basic/insertion-sort.sml
-../lib/mlton/basic/quick-sort.sml
 backend/live.sig
 backend/live.fun
 backend/allocate-registers.sig
@@ -443,8 +445,6 @@
 elaborate/elaborate-env.sig
 elaborate/elaborate.sig
 elaborate/decs.fun
-../lib/mlton/basic/merge-sort.sig
-../lib/mlton/basic/merge-sort.sml
 elaborate/elaborate-env.fun
 elaborate/elaborate-sigexp.sig
 elaborate/elaborate-sigexp.fun



1.56      +8 -8      mlton/mlton/mlton.cm

Index: mlton.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton.cm,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -r1.55 -r1.56
--- mlton.cm	7 Nov 2002 01:36:55 -0000	1.55
+++ mlton.cm	7 Dec 2002 02:21:51 -0000	1.56
@@ -170,6 +170,10 @@
 ast/ast.sig
 ast/ast-const.fun
 ast/field.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
@@ -289,13 +293,15 @@
 backend/mtype.sig
 backend/c-function.sig
 backend/runtime.sig
+backend/machine-atoms.sig
+backend/switch.sig
+backend/switch.fun
 backend/mtype.fun
 backend/c-function.fun
 backend/runtime.fun
 backend/err.sml
-backend/machine-cases.sig
+backend/machine-atoms.fun
 backend/machine.sig
-backend/machine-cases.fun
 backend/machine.fun
 ../lib/mlton/basic/unique-set.sig
 ../lib/mlton/basic/unique-set.fun
@@ -320,10 +326,6 @@
 backend/chunkify.sig
 backend/chunkify.fun
 backend/backend.sig
-../lib/mlton/basic/quick-sort.sig
-../lib/mlton/basic/insertion-sort.sig
-../lib/mlton/basic/insertion-sort.sml
-../lib/mlton/basic/quick-sort.sml
 backend/live.sig
 backend/live.fun
 backend/allocate-registers.sig
@@ -414,8 +416,6 @@
 elaborate/elaborate-env.sig
 elaborate/elaborate.sig
 elaborate/decs.fun
-../lib/mlton/basic/merge-sort.sig
-../lib/mlton/basic/merge-sort.sml
 elaborate/elaborate-env.fun
 elaborate/elaborate-sigexp.sig
 elaborate/elaborate-sigexp.fun



1.4       +2 -1      mlton/mlton/ast/record.fun

Index: record.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/record.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- record.fun	10 Apr 2002 07:02:18 -0000	1.3
+++ record.fun	7 Dec 2002 02:21:51 -0000	1.4
@@ -42,7 +42,8 @@
 	   | _ => false)
       val v =
 	 if isSorted
-	    then Vector.sort (v, fn ((s, _), (s', _)) => Field.<= (s, s')) 
+	    then QuickSort.sortVector (v, fn ((s, _), (s', _)) =>
+				       Field.<= (s, s')) 
 	 else v
    in if isTuple v
 	 then Tuple (Vector.map (v, #2))



1.5       +15 -3     mlton/mlton/atoms/id.fun

Index: id.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/id.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- id.fun	10 Apr 2002 07:02:19 -0000	1.4
+++ id.fun	7 Dec 2002 02:21:51 -0000	1.5
@@ -13,7 +13,7 @@
       val getCounter = String.memoize (fn _ => Counter.new 0)
    end
 
-functor Id (S: ID_STRUCTS): ID =
+functor IdNoAst (S: ID_NO_AST_STRUCTS): ID_NO_AST =
 struct
 
 open S
@@ -108,13 +108,25 @@
       printName = ref NONE,
       plist = Plist.new ()}
 
+val clear = Plist.clear o plist
+   
+end
+
+functor Id (S: ID_STRUCTS): ID =
+struct
+
+open S
+local
+   structure I = IdNoAst (S)
+in
+   open I
+end
+   
 val fromAst = newString o AstId.toString
 fun fromAsts l = List.map (l, fromAst)
 fun toAst id = AstId.fromString (toString id, Region.bogus)
 fun toAsts l = List.map (l, toAst)
 
-val clear = Plist.clear o plist
-   
 end
 
 functor HashId (S: ID_STRUCTS): HASH_ID =



1.3       +23 -9     mlton/mlton/atoms/id.sig

Index: id.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/id.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- id.sig	10 Apr 2002 07:02:19 -0000	1.2
+++ id.sig	7 Dec 2002 02:21:51 -0000	1.3
@@ -5,32 +5,46 @@
  * MLton is released under the GNU General Public License (GPL).
  * Please see the file MLton-LICENSE for license information.
  *)
-signature ID_STRUCTS =
+signature ID_NO_AST_STRUCTS =
    sig
-      structure AstId: AST_ID
-
       val noname: string
    end
 
-signature ID =
+signature ID_NO_AST =
    sig
-      include ID_STRUCTS
-      include T
+      include ID_NO_AST_STRUCTS
+
+      type t
 
       val bogus: t
       val clear: t -> unit
-      val fromAst: AstId.t -> t
-      val fromAsts: AstId.t list -> t list
+      val equals: t * t -> bool
       val fromString: string -> t (* doesn't add uniquefying suffix *)
+      val layout: t -> Layout.t
       val new: t -> t            (* with the same prefix *)
       val newNoname: unit -> t   (* prefix is "x" *)
       val newString: string -> t (* given prefix *)
       val originalName: t -> string (* raw destructor *)
       val plist: t -> PropertyList.t
       val sameName: t * t -> bool
+      val toString: t -> string
+   end
+
+signature ID_STRUCTS =
+   sig
+      include ID_NO_AST_STRUCTS
+      structure AstId: AST_ID
+   end
+
+signature ID =
+   sig
+      include ID_NO_AST
+      structure AstId: AST_ID
+	 
+      val fromAst: AstId.t -> t
+      val fromAsts: AstId.t list -> t list
       val toAst: t -> AstId.t
       val toAsts: t list -> AstId.t list
-      val toString: t -> string
    end
 
 signature HASH_ID =



1.42      +0 -4      mlton/mlton/atoms/prim.fun

Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- prim.fun	24 Nov 2002 01:19:43 -0000	1.41
+++ prim.fun	7 Dec 2002 02:21:51 -0000	1.42
@@ -34,7 +34,6 @@
    struct
       datatype t =
 	 Array_array
-       | Array_array0
        | Array_array0Const
        | Array_length
        | Array_sub
@@ -256,7 +255,6 @@
       val strings =
 	 [
 	  (Array_array, Moveable, "Array_array"),
-	  (Array_array0, Moveable, "Array_array0"),
 	  (Array_array0Const, Moveable, "Array_array0Const"),
 	  (Array_length, Functional, "Array_length"),
 	  (Array_sub, DependsOnState, "Array_sub"),
@@ -528,7 +526,6 @@
       end
    val tuple = tuple o Vector.fromList    
 in
-   val array0 = new (Name.Array_array0, make1 (fn a => unit --> array a))
    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 bogus = new (Name.MLton_bogus, make1 (fn a => a))
@@ -678,7 +675,6 @@
    in
       case name prim of
 	 Array_array => one (dearray result)
-       | Array_array0 => one (dearray result)
        | Array_array0Const => one (dearray result)
        | Array_sub => one result
        | Array_update => one (arg 2)



1.34      +0 -2      mlton/mlton/atoms/prim.sig

Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- prim.sig	24 Nov 2002 01:19:43 -0000	1.33
+++ prim.sig	7 Dec 2002 02:21:51 -0000	1.34
@@ -24,7 +24,6 @@
 	 sig
 	    datatype t =
 	       Array_array (* implemented in backend *)
-	     | Array_array0 (* implemented in backend *)
 	     | Array_array0Const (* implemented in constant-propagation.fun *)
 	     | Array_length
 	     | Array_sub (* implemented in backend *)
@@ -250,7 +249,6 @@
 
       val allocTooLarge: t
       val apply: t * 'a ApplyArg.t list * ('a * 'a -> bool) -> 'a ApplyResult.t
-      val array0: t
       val array: t
       val assign: t
       val bogus: t



1.6       +1 -0      mlton/mlton/atoms/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- sources.cm	16 Apr 2002 12:10:52 -0000	1.5
+++ sources.cm	7 Dec 2002 02:21:51 -0000	1.6
@@ -28,6 +28,7 @@
 functor Atoms
 functor Cases
 functor Id
+functor IdNoAst
 functor GenericScheme
 functor HashType
 functor TypeOps



1.22      +52 -100   mlton/mlton/backend/allocate-registers.fun

Index: allocate-registers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/allocate-registers.fun,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- allocate-registers.fun	6 Jul 2002 17:22:05 -0000	1.21
+++ allocate-registers.fun	7 Dec 2002 02:21:51 -0000	1.22
@@ -21,8 +21,8 @@
    structure Function = Function
    structure Kind = Kind
    structure Label = Label
-   structure Var = Var
    structure Type = Type
+   structure Var = Var
 end
 
 local
@@ -36,14 +36,14 @@
 val traceForceStack =
    Trace.trace ("Allocate.forceStack", Var.layout, Unit.layout)
    
-(* If a handler is stored in a stack frame, then we need both a uint for
+(* If a handler is stored in a stack frame, then we need both a word for
  * the old handler and space for the handler itself
  *)
 local
    open Type
 in
    val labelSize = size label
-   val handlerSize = labelSize + size uint
+   val handlerSize = labelSize + size word
 end
 
 structure Live = Live (open Rssa)
@@ -63,16 +63,17 @@
          sig
             type t
             val empty: t
-            val get: t * Type.t -> t * {index: int}
+            val get: t * Type.t -> t * Register.t
             val layout: t -> Layout.t
-            val new: {index: int, ty: Type.t} list -> t
+            val new: Register.t list -> t
          end
+
       type t
       val empty: t
-      val getRegister: t * Type.t -> t * {index: int}
+      val getRegister: t * Type.t -> t * Register.t
       val getStack: t * Type.t -> t * {offset: int}
       val layout: t -> Layout.t
-      val new: {offset: int, ty: Type.t} list * {index: int, ty: Type.t} list -> t
+      val new: {offset: int, ty: Type.t} list * Register.t list -> t
       val registers: t -> Registers.t
       val stack: t -> Stack.t
       val stackSize: t -> int
@@ -102,14 +103,12 @@
 		     end
 
 	  fun new (alloc): t =
-	     let
-	        val a = Array.fromListMap (alloc, fn {offset, ty} =>
-					   {offset = offset,
-					    size = Type.size ty})
-		val _ = QuickSort.sort (a, fn (r, r') => #offset r <= #offset r')
-	     in
-	        T (Array.toList a)
-	     end
+	     T (Array.toList
+		(QuickSort.sortArray
+		 (Array.fromListMap (alloc, fn {offset, ty} =>
+				     {offset = offset,
+				      size = Type.size ty}),
+		  fn (r, r') => #offset r <= #offset r')))
 
 	  fun get (T alloc, ty) =
 	     let
@@ -165,71 +164,20 @@
        end
        structure Registers =
        struct
-	  datatype t = T of {ty: Type.t, alloc: {index: int} list} list
+	  datatype t = T
 
-	  val empty = T (List.map (Type.all, fn ty => {ty = ty, alloc = []}))
+	  val empty = T
 
-	  fun layout (T allocs) =
-	     List.layout (fn {ty, alloc} =>
-			  Layout.record [("ty", Type.layout ty),
-					 ("alloc", List.layout
-					           (fn {index} =>
-						    Layout.record
-						    [("index", Int.layout index)])
-						   alloc)])
-	                 allocs
+	  fun layout T = Layout.str "<registers>"
 
-	  fun new (allocs): t =
-	     let
-	        val allocs = List.equivalence (allocs, fn ({ty = ty1, ...},
-							   {ty = ty2, ...}) =>
-					       Type.equals (ty1, ty2))
-		val allocs =
-		   List.revMap
-		   (allocs, fn alloc =>
-		    let
-		       val a = Array.fromListMap (alloc, fn {ty, index} =>
-						  {index = index})
-		       val _ = QuickSort.sort (a, fn (r, r') => #index r <= #index r')
-		    in
-		       {ty = #ty (hd alloc),
-			alloc = Array.toList a}
-		    end)
-	     in
-	        T allocs
-	     end
+	  fun new _ = T
 
-	  fun get (T allocs, ty') =
-	     let
-	        val (allocs, index) =
-		   case List.partition (allocs, fn {ty, ...} => 
-					Type.equals (ty', ty)) of
-		      {yes = [], no = allocs} => 
-			 ({ty = ty', alloc = [{index = 0}]}::allocs, 
-			  {index = 0})
-		    | {yes = [{ty, alloc}], no = allocs} =>
-			 let
-			    fun loop (i, [], alloc') = 
-			       (List.appendRev 
-				(alloc', [{index = i}]), 
-				{index = i})
-			      | loop (i, index::alloc, alloc') =
-			       if i = #index index
-				  then loop (i + 1, alloc, index::alloc')
-			       else (List.appendRev 
-				     ({index = i}::alloc', index::alloc),
-				     {index = i})
-			    val (alloc, index) = loop (0, alloc, [])
-			 in
-			    ({ty = ty, alloc = alloc}::allocs, index)
-			 end
-		    | _ => Error.bug "AllocateRegisters.Allocation.Registers.get"
-	     in
-	        (T allocs, index)
-	     end
+	  fun get (rs, ty) = (rs, Register.new ty)
        end
        
-       datatype t = T of {stack: Stack.t, registers: Registers.t}
+       datatype t = T of {registers: Registers.t,
+			  stack: Stack.t}
+
        local
 	  fun make s (T x) = s x
        in
@@ -237,6 +185,7 @@
 	  val stackSize = Stack.size o stack
 	  val registers = make #registers
        end
+    
        val empty = T {stack = Stack.empty,
 		      registers = Registers.empty}
 
@@ -253,13 +202,16 @@
 	  end
        fun getRegister (T {stack, registers}, ty) =
 	  let
-	     val (registers, index) = Registers.get (registers, ty)
+	     val (registers, reg) = Registers.get (registers, ty)
 	  in
-	     (T {stack = stack, registers = registers}, index)
+	     (T {registers = registers,
+		 stack = stack},
+	      reg)
 	  end
 
        fun new (stack, registers) = 
-	  T {stack = Stack.new stack, registers = Registers.new registers}
+	  T {registers = Registers.new registers,
+	     stack = Stack.new stack}
    end
 
 structure Info =
@@ -284,9 +236,8 @@
 
 fun allocate {argOperands: Machine.Operand.t vector,
 	      function = f: Rssa.Function.t,
-	      newRegister,
 	      varInfo: Var.t -> {operand: Machine.Operand.t option ref option,
-				 ty: Machine.Type.t}} =
+				 ty: Type.t}} =
    let
       fun diagnostics f =
 	 Control.diagnostics
@@ -373,7 +324,6 @@
 	  in
 	     ()
 	  end)
-      val nextReg = Type.memo (fn _ => ref 0)
       fun allocateVar (x: Var.t,
 		       l: Label.t option, 
 		       force: bool,
@@ -387,22 +337,17 @@
 			  case place x of
 			     Stack =>
 				let
-				   val (a, {offset}) = Allocation.getStack (a, ty)
+				   val (a, {offset}) =
+				      Allocation.getStack (a, ty)
 				in
 				   (a, Operand.StackOffset {ty = ty,
 							    offset = offset})
 				end
 			   | Register =>
 				let
-(*
-                                   val r = nextReg ty
-				   val reg = newRegister (l, !r, ty)
-				   val _ = Int.inc r
-*)
-				   val (a, {index}) = Allocation.getRegister (a, ty)
-				   val reg = newRegister (l, index, ty)
+				   val (a, r) = Allocation.getRegister (a, ty)
 				in
-				   (a, Operand.Register reg)
+				   (a, Operand.Register r)
 				end
 		       val _ = 
 			  case operand of
@@ -416,7 +361,10 @@
       val allocateVar =
 	 Trace.trace4
 	 ("Allocate.allocateVar",
-	  Var.layout, Option.layout Label.layout, Bool.layout, Allocation.layout,
+	  Var.layout,
+	  Option.layout Label.layout,
+	  Bool.layout,
+	  Allocation.layout,
 	  Allocation.layout)
 	 allocateVar
       (* Create the initial stack and set the stack slots for the formals. *)
@@ -427,7 +375,8 @@
 			 case oper of
 			    M.Operand.StackOffset {offset, ...} =>
 			       (valOf (#operand (varInfo x)) := SOME oper
-				; {offset = offset, ty = t} :: ac)
+				; ({offset = offset, ty = t}
+				   :: ac))
 			  | _ => Error.bug "callReturnOperands"))
       (* Allocate slots for the link and handler, if necessary. *)
       val (stack, handlerLinkOffset) =
@@ -437,7 +386,7 @@
 		  val (stack, {offset = handler, ...}) =
 		     Allocation.Stack.get (stack, Type.label)
 		  val (stack, {offset = link, ...}) = 
-		     Allocation.Stack.get (stack, Type.uint)
+		     Allocation.Stack.get (stack, Type.word)
 	       in
 		  (stack, SOME {handler = handler, link = link})
 	       end
@@ -475,7 +424,7 @@
 			     if linkLive
 				then
 				   Operand.StackOffset {offset = link,
-							ty = Type.uint}
+							ty = Type.word}
 				   :: ops
 			     else ops
 		       in
@@ -483,20 +432,23 @@
 		       end)
 	     val liveNoFormals = getOperands beginNoFormals
 	     val (stackInit, registersInit) =
-	        List.fold (liveNoFormals, ([],[]), fn (oper, (stack, registers)) =>
-			   case oper of
-			      Operand.StackOffset a => (a::stack, registers)
-			    | Operand.Register (Register.T a) => (stack, a::registers)
-			    | _ => (stack, registers))
+	        List.fold
+		(liveNoFormals, ([],[]), fn (oper, (stack, registers)) =>
+		 case oper of
+		    Operand.StackOffset a => (a::stack, registers)
+		  | Operand.Register r => (stack, r::registers)
+		  | _ => (stack, registers))
 	     val stackInit =
 		case handlerLinkOffset of
 		   NONE => stackInit
 		 | SOME {handler, link} =>
 		      {offset = handler, ty = Type.label}
-		      :: {offset = link, ty = Type.uint}
+		      :: {offset = link, ty = Type.word}
 		      :: stackInit
 	     val a = Allocation.new (stackInit, registersInit)
-	     val size = Runtime.labelSize + Type.wordAlign (Allocation.stackSize a)
+	     val size =
+		Runtime.labelSize
+		+ Runtime.wordAlignInt (Allocation.stackSize a)
 	     val a =
 		Vector.fold (args, a, fn ((x, _), a) =>
 			     allocateVar (x, SOME label, false, a))



1.12      +7 -9      mlton/mlton/backend/allocate-registers.sig

Index: allocate-registers.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/allocate-registers.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- allocate-registers.sig	10 Apr 2002 07:02:19 -0000	1.11
+++ allocate-registers.sig	7 Dec 2002 02:21:51 -0000	1.12
@@ -22,16 +22,14 @@
       val allocate:
 	 {argOperands: Machine.Operand.t vector,
 	  function: Rssa.Function.t,
-	  newRegister: (Rssa.Label.t option * int * Machine.Type.t
-			-> Machine.Register.t),
 	  varInfo: Rssa.Var.t -> {
-                                 (* If (isSome operand) then a stack slot or
-				  * register needs to be allocated for the
-				  * variable.
-				  *)
-				 operand: Machine.Operand.t option ref option,
-				 ty: Machine.Type.t
-				 }
+				  (* If (isSome operand) then a stack slot or
+				   * register needs to be allocated for the
+				   * variable.
+				   *)
+				  operand: Machine.Operand.t option ref option,
+				  ty: Machine.Type.t
+				  }
 	  }
 	 -> {(* If handlers are used, handlerLinkOffset gives the stack offsets
 	      * where the handler and link (old exnStack) should be stored.



1.37      +146 -218  mlton/mlton/backend/backend.fun

Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- backend.fun	24 Nov 2002 01:19:43 -0000	1.36
+++ backend.fun	7 Dec 2002 02:21:51 -0000	1.37
@@ -15,33 +15,32 @@
    open Machine
 in
    structure Chunk = Chunk
+   structure Global = Global
+   structure Label = Label
+   structure MemChunk = MemChunk
+   structure ObjectType = ObjectType
+   structure PointerTycon = PointerTycon
+   structure Register = Register
    structure Runtime = Runtime
+   structure Type = Type
 end
 local
    open Runtime
 in
    structure CFunction = CFunction
    structure GCField = GCField
-   structure ObjectType = ObjectType
 end
 val wordSize = Runtime.wordSize
-   
-structure Rssa = Rssa (open Ssa
-		       structure Cases = Machine.Cases
-		       structure Runtime = Runtime
-		       structure Type = Machine.Type)
+
+structure Rssa = Rssa (open Ssa Machine)
 structure R = Rssa
 local
    open Rssa
 in
-   structure Cases = Cases
-   structure Con = Con
    structure Const = Const
    structure Func = Func
    structure Function = Function
-   structure Label = Label
    structure Prim = Prim
-   structure Tycon = Tycon
    structure Type = Type
    structure Var = Var
 end 
@@ -93,8 +92,7 @@
 structure Chunk =
    struct
       datatype t = T of {blocks: M.Block.t list ref,
-			 chunkLabel: M.ChunkLabel.t,
-			 regMax: Type.t -> int ref}
+			 chunkLabel: M.ChunkLabel.t}
 
       fun label (T {chunkLabel, ...}) = chunkLabel
 	 
@@ -102,19 +100,7 @@
 	 
       fun new (): t =
 	 T {blocks = ref [],
-	    chunkLabel = M.ChunkLabel.new (),
-	    regMax = Type.memo (fn _ => ref 0)}
-	 
-      fun register (T {regMax, ...}, n, ty) =
-	 let
-	    val r = regMax ty
-	    val _ = r := Int.max (!r, n + 1)
-	 in
-	    M.Register.T {index = n, ty = ty}
-	 end
-      
-      fun tempRegister (c as T {regMax, ...}, ty) =
-	 register (c, !(regMax ty), ty)
+	    chunkLabel = M.ChunkLabel.new ()}
 	 
       fun newBlock (T {blocks, ...}, z) =
 	 List.push (blocks, M.Block.T z)
@@ -127,7 +113,7 @@
 
 fun eliminateDeadCode (f: R.Function.t): R.Function.t =
    let
-      val {args, blocks, name, start} = R.Function.dest f
+      val {args, blocks, name, returns, raises, start} = R.Function.dest f
       val {get, set, ...} =
 	 Property.getSetOnce (Label.plist, Property.initConst false)
       val get = Trace.trace ("Backend.labelIsReachable",
@@ -143,6 +129,8 @@
       R.Function.new {args = args,
 		      blocks = blocks,
 		      name = name,
+		      returns = returns,
+		      raises = raises,
 		      start = start}
    end
 
@@ -162,7 +150,19 @@
 	 if !Control.profile = Control.ProfileAlloc
 	    then pass ("profileAlloc", ProfileAlloc.doit, program)
 	 else program
-      val program as R.Program.T {functions, main, profileAllocLabels} = program
+      val _ =
+	 let
+	    open Control
+	 in
+	    if !keepRSSA
+	       then saveToFile ({suffix = "rssa"},
+				No,
+				program,
+				Layouts Rssa.Program.layouts)
+	    else ()
+	 end
+      val program as R.Program.T {functions, main, objectTypes,
+				  profileAllocLabels} = program
       val handlesSignals = Rssa.Program.handlesSignals program
       (* Chunk information *)
       val {get = labelChunk, set = setLabelChunk, ...} =
@@ -172,12 +172,6 @@
 	 Property.getSetOnce (Func.plist,
 			      Property.initRaise ("funcChunk", Func.layout))
       val funcChunkLabel = Chunk.label o funcChunk
-      val globalCounter = Type.memo (fn _ => Counter.new 0)
-      fun newGlobal ty =
-	 M.Global.T {index = Counter.next (globalCounter ty),
-		     ty = ty}
-      val globalPointerNonRootCounter = Counter.new 0
-      val constantCounter = Type.memo (fn _ => Counter.new 0)
       val chunks = ref []
       fun newChunk () =
 	 let
@@ -212,13 +206,10 @@
 	       NONE =>
 		  let
 		     val opers =
-			Vector.map
-			(ts, fn t =>
-			 if Type.isPointer t
-			    then
-			       M.Operand.GlobalPointerNonRoot
-			       (Counter.next globalPointerNonRootCounter)
-			 else M.Operand.Global (newGlobal t))
+			Vector.map (ts, fn ty =>
+				    M.Operand.Global
+				    (Global.new {isRoot = false,
+						 ty = ty}))
 		     val _ = List.push (table, (ts, opers))
 		  in
 		     opers
@@ -260,7 +251,8 @@
 		      (HashSet.lookupOrInsert
 		       (set, hash, fn {string, ...} => s = string,
 			fn () => {hash = hash,
-				  global = newGlobal ty,
+				  global = M.Global.new {isRoot = true,
+							 ty = ty},
 				  string = s})))
 		  end
 	       fun all () =
@@ -272,9 +264,9 @@
 	    end
       in
 	 val (allIntInfs, globalIntInf) =
-	    make (Type.pointer, fn i => IntInf.format (i, StringCvt.DEC))
-	 val (allFloats, globalFloat) = make (Type.double, fn s => s)
-	 val (allStrings, globalString) = make (Type.pointer, fn s => s)
+	    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)
 	 fun constOperand (c: Const.t): M.Operand.t =
 	    let
 	       datatype z = datatype Const.Node.t
@@ -285,66 +277,22 @@
 		| IntInf i =>
 		     (case Const.SmallIntInf.toWord i of
 			 NONE => globalIntInf i
-		       | SOME w => M.Operand.IntInf w)
+		       | SOME w => M.Operand.SmallIntInf w)
 		| Real f =>
 		     if !Control.Native.native
-			then globalFloat f
-		     else M.Operand.Float f
+			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.Uint w
+			   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
 	    end
       end
-      (* Hash table for uniqifying object types. *)
-      local
-	 val table = HashSet.new {hash = #hash}
-	 val arrayHash = Random.word ()
-	 val normalHash = Random.word ()
-	 fun hash1 (w: word, i: int): word =
-	    Word.fromInt i + Word.* (w, 0w31)
-	 fun hash (i1: int, i2: int, w: word) = hash1 (hash1 (w, i1), i2)
-	 (* Start the counter at 1 because index 0 is reserved for the stack
-	  * object type.
-	  *)
-	 val counter = Counter.new 1
-	 fun getIndex (hash: word, ty: ObjectType.t): int =
-	    #index
-	    (HashSet.lookupOrInsert
-	     (table, hash, fn r => ObjectType.equals (ty, #ty r),
-	      fn () => {hash = hash,
-			index = Counter.next counter,
-			ty = ty}))
-      in
-	 fun arrayTypeIndex (z as {numBytesNonPointers = nbnp,
-				   numPointers = np}): int =
-	    getIndex (hash (nbnp, np, arrayHash), ObjectType.Array z)
-	 fun normalTypeIndex (z as {numPointers = np,
-				    numWordsNonPointers = nwnp}): int =
-	    getIndex (hash (np, nwnp, normalHash), ObjectType.Normal z)
-	 fun objectTypes () =
-	    let
-	       val a = Array.new (Counter.value counter, ObjectType.Stack)
-	       val _ = HashSet.foreach (table, fn {index, ty, ...} =>
-					Array.update (a, index, ty))
-	    in
-	       Vector.fromArray a
-	    end
-	 (* The GC requires some hardwired type indices -- see gc.h. *)
-	 val stackTypeIndex = 0
-	 val stringTypeIndex = (* 1 *)
-	    arrayTypeIndex {numBytesNonPointers = 1, numPointers = 0}
-	 val threadTypeIndex = (* 2 *)
-	    normalTypeIndex {numPointers = 1, numWordsNonPointers = 2}
-	 val word8VectorTypeIndex = (* 1 *) stringTypeIndex
-	 val wordVectorTypeIndex = (* 3 *)
-	    arrayTypeIndex {numBytesNonPointers = 4, numPointers = 0}
-      end
       fun parallelMove {chunk,
 			dsts: M.Operand.t vector,
 			srcs: M.Operand.t vector}: M.Statement.t vector =
@@ -352,8 +300,7 @@
 	    val moves =
 	       Vector.fold2 (srcs, dsts, [],
 			     fn (src, dst, ac) => {src = src, dst = dst} :: ac)
-	    fun temp r =
-	       M.Operand.Register (Chunk.tempRegister (chunk, M.Operand.ty r))
+	    fun temp r = M.Operand.Register (Register.new (M.Operand.ty r))
 	 in
 	    Vector.fromList
 	    (ParallelMove.move {
@@ -364,35 +311,31 @@
 				temp = temp
 				})
 	 end
-      val array0Header =
-	 M.Operand.Uint (Runtime.typeIndexToHeader
-			 (arrayTypeIndex {numBytesNonPointers = 0,
-					  numPointers = 0}))
       fun translateOperand (oper: R.Operand.t): M.Operand.t =
 	 let
 	    datatype z = datatype R.Operand.t
 	 in
 	    case oper of
-	       ArrayHeader z =>
-		  M.Operand.Uint (Runtime.typeIndexToHeader (arrayTypeIndex z))
-	     | ArrayOffset {base, index, ty} =>
-		  M.Operand.ArrayOffset {base = varOperand base,
-					 index = varOperand index,
+	       ArrayOffset {base, index, ty} =>
+		  M.Operand.ArrayOffset {base = translateOperand base,
+					 index = translateOperand index,
 					 ty = ty}
-	     | CastInt z => M.Operand.CastInt (translateOperand z)
-	     | CastWord z => M.Operand.CastWord (translateOperand z)
+	     | Cast (z, t) => M.Operand.Cast (translateOperand z, t)
 	     | Const c => constOperand c
 	     | EnsuresBytesFree =>
 		  Error.bug "backend translateOperand saw EnsuresBytesFree"
 	     | File => M.Operand.File
 	     | GCState => M.Operand.GCState
 	     | Line => M.Operand.Line
-	     | Offset {base, bytes, ty} =>
-		  M.Operand.Offset {base = varOperand base,
-				    offset = bytes,
+	     | Offset {base, offset, ty} =>
+		  M.Operand.Offset {base = translateOperand base,
+				    offset = offset,
 				    ty = ty}
-	     | Pointer n => M.Operand.Pointer n
+	     | PointerTycon pt =>
+		  M.Operand.Word (Runtime.typeIndexToHeader
+				  (PointerTycon.index pt))
 	     | Runtime r => M.Operand.Runtime r
+	     | SmallIntInf w => M.Operand.SmallIntInf w
 	     | Var {var, ...} => varOperand var
 	 end
       fun translateOperands ops = Vector.map (ops, translateOperand)
@@ -419,18 +362,13 @@
 		  Vector.new1
 		  (M.Statement.move {dst = translateOperand dst,
 				     src = translateOperand src})
-	     | Object {dst, numPointers, numWordsNonPointers, stores} =>
+	     | Object {dst, size, stores, tycon, ...} =>
 		  Vector.new1
 		  (M.Statement.Object
 		   {dst = varOperand dst,
 		    header = (Runtime.typeIndexToHeader
-			      (normalTypeIndex
-			       {numPointers = numPointers,
-				numWordsNonPointers = numWordsNonPointers})),
-		    size = (Runtime.normalHeaderSize
-			    + (Runtime.normalSize
-			       {numPointers = numPointers,
-				numWordsNonPointers = numWordsNonPointers})),
+			      (PointerTycon.index tycon)),
+		    size = size,
 		    stores = Vector.map (stores, fn {offset, value} =>
 					 {offset = offset,
 					  value = translateOperand value})})
@@ -439,42 +377,7 @@
 		     datatype z = datatype Prim.Name.t
 		  in
 		     case Prim.name prim of
-			Array_array0 =>
-			   let
-			      val frontier =
-				 M.Operand.Runtime GCField.Frontier
-			      fun arg i =
-				 translateOperand (Vector.sub (args, i))
-			      val numElts = arg 0
-			   in Vector.new5
-			      (M.Statement.Move
-			       {dst = M.Operand.Contents {oper = frontier,
-							  ty = Type.word},
-				src = M.Operand.Uint 0w0},
-			       M.Statement.Move
-			       {dst = M.Operand.Offset {base = frontier,
-							offset = wordSize,
-							ty = Type.int},
-				src = numElts},
-			       M.Statement.Move
-			       {dst = M.Operand.Offset {base = frontier,
-							offset = 2 * wordSize,
-							ty = Type.uint},
-				src = array0Header},
-			       M.Statement.PrimApp
-			       {args = Vector.new2 (frontier,
-						    M.Operand.Uint
-						    (Word.fromInt
-						     (3 * wordSize))),
-				dst = SOME (varOperand (#1 (valOf dst))),
-				prim = Prim.word32Add},
-			       M.Statement.PrimApp
-			       {args = Vector.new2 (frontier,
-						    M.Operand.Uint (Word.fromInt Runtime.array0Size)),
-				dst = SOME frontier,
-				prim = Prim.word32Add})
-			   end
-		      | MLton_installSignalHandler => Vector.new0 ()
+			MLton_installSignalHandler => Vector.new0 ()
 		      | _ => 
 			   Vector.new1
 			   (M.Statement.PrimApp
@@ -524,14 +427,18 @@
 	    val chunk = funcChunk name
 	    fun labelArgOperands (l: R.Label.t): M.Operand.t vector =
 	       Vector.map (#args (labelInfo l), varOperand o #1)
-	    fun newVarInfo (x, ty) =
-	       setVarInfo
-	       (x, {operand = if isMain
-				 then
-				    VarOperand.Const (M.Operand.Global
-						      (newGlobal ty))
-			      else VarOperand.Allocate {operand = ref NONE},
-                    ty = ty})
+	    fun newVarInfo (x, ty: Type.t) =
+	       let
+		  val operand =
+		     if isMain
+			then VarOperand.Const (M.Operand.Global
+					       (M.Global.new {isRoot = true,
+							      ty = ty}))
+		     else VarOperand.Allocate {operand = ref NONE}
+	       in
+		  setVarInfo (x, {operand = operand,
+				  ty = ty})
+	       end
 	    fun newVarInfos xts = Vector.foreach (xts, newVarInfo)
 	    (* Set the constant operands, labelInfo, and varInfo. *)
 	    val _ = newVarInfos args
@@ -553,20 +460,33 @@
 				   then normal ()
 				else
 				   let
-				      fun set oper =
-					 setVarInfo
-					 (var, {operand = VarOperand.Const oper,
-						ty = M.Operand.ty oper})
+				      fun set (z: M.Operand.t,
+					       casts: Type.t list) =
+					 let
+					    val z =
+					       List.fold
+					       (casts, z, fn (t, z) =>
+						M.Operand.Cast (z, t))
+					 in
+					    setVarInfo
+					    (var, {operand = VarOperand.Const z,
+						   ty = M.Operand.ty z})
+					 end
+				      fun loop (z: R.Operand.t, casts) =
+					 case z of
+					    R.Operand.Cast (z, t) =>
+					       loop (z, t :: casts)
+					  | R.Operand.Const c =>
+					       set (constOperand c, casts)
+					  | R.Operand.Var {var = var', ...} =>
+					       (case #operand (varInfo var') of
+						   VarOperand.Const z =>
+						      set (z, casts)
+						 | VarOperand.Allocate _ =>
+						      normal ())
+					  | _ => normal ()
 				   in
-				      case oper of
-					 R.Operand.Const c => set (constOperand c)
-				       | R.Operand.Pointer n =>
-					    set (M.Operand.Pointer n)
-				       | R.Operand.Var {var = var', ...} =>
-					    (case #operand (varInfo var') of
-						VarOperand.Const oper => set oper
-					      | VarOperand.Allocate _ => normal ())
-				       | _ => normal ()
+				      loop (oper, [])
 				   end
 			   | _ => normal ()
 		       end)
@@ -596,25 +516,16 @@
 		     val {operand, ty, ...} = varInfo x
 		  in
 		     {operand = (case operand of
-				    VarOperand.Allocate {operand, ...} => SOME operand
+				    VarOperand.Allocate {operand, ...} =>
+				       SOME operand
 				  | _ => NONE),
 		      ty = ty}
 		  end
-	       fun newRegister (l, n, ty) =
-		  let
-		     val chunk =
-			case l of
-			   NONE => chunk
-			 | SOME l => labelChunk l
-		  in
-		     Chunk.register (chunk, n, ty)
-		  end
 	    in
 	       val {handlerLinkOffset, labelInfo = labelRegInfo, ...} =
 		  AllocateRegisters.allocate
 		  {argOperands = callReturnOperands (args, #2, 0),
 		   function = f,
-		   newRegister = newRegister,
 		   varInfo = varInfo}
 	    end
 	    val profileInfoFunc = Func.toString name
@@ -679,7 +590,7 @@
 						      ty = Type.label},
 						     M.Operand.StackOffset 
 						     {offset = link,
-						      ty = Type.uint}))
+						      ty = Type.word}))
 						end
 				       val size = 
 					  if !Control.newReturn
@@ -713,8 +624,8 @@
 			 M.Transfer.Goto dst)
 		   | R.Transfer.Raise srcs =>
 			(M.Statement.moves
-			 {dsts = raiseOperands (Vector.map
-						(srcs, R.Operand.ty)),
+			 {dsts = (raiseOperands
+				  (Vector.map (srcs, R.Operand.ty))),
 			  srcs = translateOperands srcs},
 			 M.Transfer.Raise)
 		   | R.Transfer.Return xs =>
@@ -726,30 +637,50 @@
 					  dsts = dsts},
 			    M.Transfer.Return {live = dsts})
 			end
-		   | R.Transfer.Switch {cases, default, test} =>
+		   | R.Transfer.Switch switch =>
 			let
-			   fun doit l =
+			   fun doit ({cases: ('a * Label.t) vector,
+				      default: Label.t option,
+				      test: R.Operand.t},
+				     make: {cases: ('a * Label.t) vector,
+					    default: Label.t option,
+					    test: M.Operand.t} -> M.Switch.t) =
 			      simple
-			      (case (l, default) of
-				  ([], NONE) => bugTransfer
-				| ([(_, dst)], NONE) => M.Transfer.Goto dst
-				| ([], SOME dst) => M.Transfer.Goto dst
+			      (case (Vector.length cases, default) of
+				  (0, NONE) => bugTransfer
+				| (1, NONE) =>
+				     M.Transfer.Goto (#2 (Vector.sub (cases, 0)))
+				| (0, SOME dst) => M.Transfer.Goto dst
 				| _ =>
 				     M.Transfer.Switch
-				     {cases = cases,
-				      default = default,
-				      test = translateOperand test})
+				     (make {cases = cases,
+					    default = default,
+					    test = translateOperand test}))
 			in
-			   case cases of
-			      Cases.Char l => doit l
-			    | Cases.Int l => doit l
-			    | Cases.Word l => doit l
+			   case switch of
+			      R.Switch.Char z => doit (z, M.Switch.Char)
+			    | R.Switch.EnumPointers {enum, pointers, test} =>
+			         simple
+			         (M.Transfer.Switch
+				  (M.Switch.EnumPointers
+				   {enum = enum,
+				    pointers = pointers,
+				    test = translateOperand test}))
+			    | R.Switch.Int z => doit (z, M.Switch.Int)
+			    | R.Switch.Pointer {cases, default, tag, test} =>
+				 simple
+				 (M.Transfer.Switch
+				  (M.Switch.Pointer
+				   {cases = (Vector.map
+					     (cases, fn {dst, tag, tycon} =>
+					      {dst = dst,
+					       tag = tag,
+					       tycon = tycon})),
+				    default = default,
+				    tag = translateOperand tag,
+				    test = translateOperand test}))
+			    | R.Switch.Word z => doit (z, M.Switch.Word)
 			end
-		   | R.Transfer.SwitchIP {int, pointer, test} =>
-			simple (M.Transfer.SwitchIP
-				{int = int,
-				 pointer = pointer,
-				 test = translateOperand test})
 	       end
 	    val genTransfer =
 	       Trace.trace ("Backend.genTransfer",
@@ -794,9 +725,9 @@
 			   (liveNoFormals, [], fn (oper, ac) =>
 			    case oper of
 			       M.Operand.StackOffset {offset, ty} =>
-				  (case Type.dest ty of
-				      Type.Pointer => offset :: ac
-				    | _ => ac)
+				  if Type.isPointer ty
+				     then offset :: ac
+				  else ac
 			     | _ => ac)
 		     in
 			List.push (frames, {chunkLabel = Chunk.label chunk,
@@ -955,10 +886,9 @@
 		       statements = statements,
 		       transfer = transfer}
 	 end
-      fun chunkToMachine (Chunk.T {chunkLabel, blocks, regMax}) =
+      fun chunkToMachine (Chunk.T {chunkLabel, blocks}) =
 	 Machine.Chunk.T {chunkLabel = chunkLabel,
-			  blocks = Vector.fromListMap (!blocks, blockToMachine),
-			  regMax = ! o regMax}
+			  blocks = Vector.fromListMap (!blocks, blockToMachine)}
       val mainName = R.Function.name main
       val main = {chunkLabel = Chunk.label (funcChunk mainName),
 		  label = funcToLabel mainName}
@@ -981,7 +911,7 @@
 		    case z of
 		       ArrayOffset {base, index, ...} =>
 			  doOperand (base, doOperand (index, max))
-		     | CastInt z => doOperand (z, max)
+		     | Cast (z, _) => doOperand (z, max)
 		     | Contents {oper, ...} => doOperand (oper, max)
 		     | Offset {base, ...} => doOperand (base, max)
 		     | StackOffset {offset, ty} =>
@@ -1001,20 +931,18 @@
 	   in
 	      max
 	   end))
-      val maxFrameSize = Type.wordAlign maxFrameSize
+      val maxFrameSize = Runtime.wordAlignInt maxFrameSize
    in
       Machine.Program.T 
       {chunks = chunks,
-       floats = allFloats (),
        frameOffsets = frameOffsets, 
-       globals = Counter.value o globalCounter,
-       globalsNonRoot = Counter.value globalPointerNonRootCounter,
        handlesSignals = handlesSignals,
        intInfs = allIntInfs (), 
        main = main,
        maxFrameSize = maxFrameSize,
-       objectTypes = objectTypes (),
+       objectTypes = objectTypes,
        profileAllocLabels = profileAllocLabels,
+       reals = allReals (),
        strings = allStrings ()}
    end
 



1.13      +14 -6     mlton/mlton/backend/chunkify.fun

Index: chunkify.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/chunkify.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- chunkify.fun	2 Nov 2002 03:37:38 -0000	1.12
+++ chunkify.fun	7 Dec 2002 02:21:51 -0000	1.13
@@ -41,7 +41,19 @@
    let
       val transferSize =
 	 case transfer of
-	    Switch {cases, ...} => 1 + Cases.length cases
+	    Switch s =>
+	       let
+		  datatype z = datatype Switch.t
+		  fun simple {cases, default, test} =
+		     1 + Vector.length cases
+	       in
+		  case s of
+		     Char z => simple z
+		   | EnumPointers _ => 2
+		   | Int z => simple z
+		   | Pointer {cases, ...} => 1 + Vector.length cases
+		   | Word z => simple z
+	       end
 	  | _ => 1
    in transferSize + Vector.length statements
    end
@@ -136,11 +148,7 @@
 			  (same overflow; same success)
 		     | CCall {return, ...} => Option.app (return, same)
 		     | Goto {dst, ...} => same dst
-		     | Switch {cases, default, ...} =>
-			  (Cases.foreach (cases, same)
-			   ; Option.app (default, same))
-		     | SwitchIP {int, pointer, ...} =>
-			  (same int; same pointer)
+		     | Switch s => Switch.foreachLabel (s, same)
 		     | _ => ()
 		 end)
 	  in



1.28      +15 -17    mlton/mlton/backend/limit-check.fun

Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- limit-check.fun	4 Nov 2002 15:08:11 -0000	1.27
+++ limit-check.fun	7 Dec 2002 02:21:51 -0000	1.28
@@ -74,16 +74,7 @@
 		     {big: Operand.t -> 'a,
 		      small: word -> 'a}): 'a =
 	 case s of
-	    Object {numPointers = np, numWordsNonPointers = nwnp, ...} =>
-	       small (Word.fromInt
-		      (Runtime.normalHeaderSize
-		       + Runtime.normalSize {numPointers = np,
-					     numWordsNonPointers = nwnp}))
-	  | PrimApp {args, prim, ...} =>
-	       (case Prim.name prim of
-		   Prim.Name.Array_array0 =>
-		      small (Word.fromInt Runtime.array0Size)
-		 | _ => small 0w0)
+	    Object {size, ...} => small (Word.fromInt size)
 	  | _ => small 0w0
    end
 
@@ -122,7 +113,7 @@
 		    blockCheckAmount: {blockIndex: int} -> word,
 		    ensureBytesFree: Label.t -> word) =
    let
-      val {args, blocks, name, start} = Function.dest f
+      val {args, blocks, name, raises, returns, start} = Function.dest f
       val newBlocks = ref []
       val (_, allocTooLarge) = Block.allocTooLarge newBlocks
       val _ =
@@ -175,8 +166,9 @@
 				    profileInfo = profileInfo,
 				    statements = Vector.new0 (),
 				    transfer =
-				    Transfer.iff (global, {falsee = dontCollect,
-							   truee = collect})})
+				    Transfer.ifInt
+				    (global, {falsee = dontCollect,
+					      truee = collect})})
 			    in
 			       (dontCollect',
 				Vector.new1
@@ -249,7 +241,7 @@
 					 dst = SOME (res, Type.bool),
 					 prim = prim}
 		   val transfer =
-		      Transfer.iff
+		      Transfer.ifBool
 		      (Operand.Var {var = res, ty = Type.bool},
 		       {falsee = dontCollect,
 			truee = collect})
@@ -396,6 +388,8 @@
       Function.new {args = args,
 		    blocks = Vector.fromList (!newBlocks),
 		    name = name,
+		    raises = raises,
+		    returns = returns,
 		    start = start}
    end
 
@@ -417,7 +411,7 @@
 
 fun insertCoalesce (f: Function.t, handlesSignals) =
    let
-      val {args, blocks, name, start} = Function.dest f
+      val {args, blocks, name, raises, returns, start} = Function.dest f
       val n = Vector.length blocks
       val {get = labelIndex, set = setLabelIndex, rem = remLabelIndex, ...} =
 	 Property.getSetOnce
@@ -677,7 +671,7 @@
       f
    end
 
-fun insert (p as Program.T {functions, main, profileAllocLabels}) =
+fun insert (p as Program.T {functions, main, objectTypes, profileAllocLabels}) =
    let
       val _ = Control.diagnostic (fn () => Layout.str "Limit Check maxPaths")
       datatype z = datatype Control.limitCheck
@@ -687,7 +681,8 @@
 	    PerBlock => insertPerBlock (f, handlesSignals)
 	  | _ => insertCoalesce (f, handlesSignals)
       val functions = List.revMap (functions, insert)
-      val {args, blocks, name, start} = Function.dest (insert main)
+      val {args, blocks, name, raises, returns, start} =
+	 Function.dest (insert main)
       val newStart = Label.newNoname ()
       val block =
 	 Block.T {args = Vector.new0 (),
@@ -706,10 +701,13 @@
       val main = Function.new {args = args,
 			       blocks = blocks,
 			       name = name,
+			       raises = raises,
+			       returns = returns,
 			       start = newStart}
    in
       Program.T {functions = functions,
 		 main = main,
+		 objectTypes = objectTypes,
 		 profileAllocLabels = profileAllocLabels}
    end
 



1.29      +293 -214  mlton/mlton/backend/machine.fun

Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- machine.fun	2 Nov 2002 03:37:38 -0000	1.28
+++ machine.fun	7 Dec 2002 02:21:51 -0000	1.29
@@ -5,19 +5,25 @@
  * MLton is released under the GNU General Public License (GPL).
  * Please see the file MLton-LICENSE for license information.
  *)
+
 functor Machine (S: MACHINE_STRUCTS): MACHINE =
 struct
 
 open S
 
+structure Runtime = Runtime ()
 local
    open Runtime
 in
    structure CFunction = CFunction
    structure GCField = GCField
-   structure Type = Type
 end
 
+structure Atoms = MachineAtoms (structure Label = Label
+				structure Prim = Prim
+				structure Runtime = Runtime)
+open Atoms
+
 structure ChunkLabel = IntUniqueId ()
    
 structure SmallIntInf =
@@ -28,45 +34,90 @@
 structure Register =
    struct
       datatype t = T of {index: int,
+			 plist: PropertyList.t,
 			 ty: Type.t}
 
       local
 	 fun make f (T r) = f r
       in
 	 val index = make #index
+	 val plist = make #plist
 	 val ty = make #ty
       end
 
-      fun toString (T {index, ty}) =
-         concat ["R", Type.name ty, "(", Int.toString index, ")"]
-	 
-      val layout = Layout.str o toString
+      local
+	 val c = Counter.new 0
+      in
+	 fun new ty = T {index = Counter.next c,
+			 plist = PropertyList.new (),
+			 ty = ty}
+      end
 
-      fun equals (r1, r2) = 
-	 Type.equals (ty r1, ty r2) 
-	 andalso index r1 = index r2
+      fun layout (T {index, ty, ...}) =
+	 let
+	    open Layout
+	 in
+	    seq [str "reg ",
+		 record [("index", Int.layout index),
+			 ("ty", Type.layout ty)]]
+	 end
+
+      val toString = Layout.toString o layout
+
+      fun equals (T {plist = p, ...}, T {plist = p', ...}) =
+	 PropertyList.equals (p, p')
    end
 
 structure Global =
    struct
       datatype t = T of {index: int,
+			 isRoot: bool,
+			 plist: PropertyList.t,
 			 ty: Type.t}
 
+      fun layout (T {index, ty, ...}) =
+	 let
+	    open Layout
+	 in
+	    seq [str "glob ",
+		 record [("index", Int.layout index),
+			 ("ty", Type.layout ty)]]
+	 end
+      
+      val toString = Layout.toString o layout
+
       local
 	 fun make f (T r) = f r
       in
 	 val index = make #index
+	 val isRoot = make #isRoot
+	 val plist = make #plist
 	 val ty = make #ty
       end
 
-      fun toString (T {index, ty}) =
-         concat ["G", Type.name ty, "(", Int.toString index, ")"]
+      val nonRootCounter = Counter.new 0
+      fun numberOfNonRoot () = Counter.value nonRootCounter
+
+      val memo = Runtime.Type.memo (fn _ => Counter.new 0)
+      fun numberOfType t = Counter.value (memo t)
 	 
-      val layout = Layout.str o toString
+      fun new {isRoot, ty} =
+	 let
+	    val isRoot = isRoot orelse not (Type.isPointer ty)
+	    val counter =
+	       if isRoot
+		  then memo (Type.toRuntime ty)
+	       else nonRootCounter
+	    val g = T {index = Counter.next counter,
+		       isRoot = isRoot,
+		       plist = PropertyList.new (),
+		       ty = ty}
+	 in
+	    g
+	 end
 
-      fun equals (g1, g2) = 
-	 Type.equals (ty g1, ty g2)
-	 andalso index g1 = index g2
+      fun equals (T {plist = p, ...}, T {plist = p', ...}) =
+	 PropertyList.equals (p, p')
    end
 
 structure Operand =
@@ -75,115 +126,117 @@
 	 ArrayOffset of {base: t,
 			 index: t,
 			 ty: Type.t}
-       | CastInt of t
-       | CastWord of t
+       | Cast of t * Type.t
        | Char of char
        | Contents of {oper: t,
 		      ty: Type.t}
        | File
-       | Float of string
        | GCState
        | Global of Global.t
-       | GlobalPointerNonRoot of int
        | Int of int
-       | IntInf of SmallIntInf.t
+       | SmallIntInf of SmallIntInf.t
        | Label of Label.t
        | Line
        | Offset of {base: t, offset: int, ty: Type.t}
-       | Pointer of int
        | Register of Register.t
+       | Real of string
        | Runtime of GCField.t
        | StackOffset of {offset: int, ty: Type.t}
-       | Uint of Word.t
+       | Word of Word.t
     
       val rec isLocation =
 	 fn ArrayOffset _ => true
-	  | CastWord z => isLocation z
+	  | Cast (z, _) => isLocation z
 	  | Contents _ => true
 	  | Global _ => true
-	  | GlobalPointerNonRoot _ => true
 	  | Offset _ => true
 	  | Register _ => true
 	  | Runtime z => true
 	  | StackOffset _ => true
 	  | _ => false
 
-      val rec toString =
-	 fn ArrayOffset {base, index, ty} =>
-	 concat ["X", Type.name ty, 
-		 "(", toString base, ",", toString index, ")"]
-	  | CastInt oper => concat ["(int) (", toString oper, ")"]
-	  | CastWord oper => concat ["(word) (", toString oper, ")"]
-	  | Char c => Char.escapeC c
-	  | Contents {oper, ty} =>
-	       concat ["C", Type.name ty, "(", toString oper, ")"]
-	  | File => "<FILE>"
-	  | Float s => s
-	  | GCState => "gcState"
-	  | Global g => Global.toString g
-	  | GlobalPointerNonRoot n =>
-	       concat ["globalpointerNonRoot [", Int.toString n, "]"]
-	  | Int n => Int.toString n
-	  | IntInf w => concat ["SmallIntInf (", Word.toString w, ")"]
-	  | Label l => Label.toString l
-	  | Line => "<LINE>"
-	  | Offset {base, offset, ty} =>
-	       concat ["O", Type.name ty,
-		       "(", toString base, ",", Int.toString offset, ")"]
-	  | Pointer n => concat ["IntAsPointer (", Int.toString n, ")"]
-	  | Register r => Register.toString r
-	  | Runtime r => GCField.toString r
-	  | StackOffset {offset, ty} =>
-	       concat ["S", Type.name ty, "(", Int.toString offset, ")"]
-	  | Uint w => concat ["0x", Word.toString w]
+      fun layout (z: t): Layout.t =
+	 let
+	    open Layout 
+	    fun constrain (ty: Type.t): Layout.t =
+	       if !Control.showTypes
+		  then seq [str ": ", Type.layout ty]
+	       else empty
+	 in
+	    case z of
+	       ArrayOffset {base, index, ty} =>
+		  seq [str (concat ["X", Type.name ty, " "]),
+		       tuple [layout base, layout index],
+		       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)]
+	     | File => str "<File>"
+	     | GCState => str "<GCState>"
+	     | Global g => Global.layout g
+	     | Int i => Int.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
+	     | Register r => Register.layout r
+	     | Runtime r => GCField.layout r
+	     | SmallIntInf w => seq [str "SmallIntInf ", paren (Word.layout w)]
+	     | StackOffset {offset, ty} =>
+		  seq [str (concat ["S", Type.name ty, " "]),
+		       paren (Int.layout offset)]
+	     | Word w => seq [str "0x", Word.layout w]
+	 end
 
-    val layout = Layout.str o toString
+    val toString = Layout.toString o layout
 
     val ty =
        fn ArrayOffset {ty, ...} => ty
-	| CastInt _ => Type.int
-	| CastWord _ => Type.word
+	| Cast (_, ty) => ty
 	| Char _ => Type.char
 	| Contents {ty, ...} => ty
-	| File => Type.pointer
-	| Float _ => Type.double
-	| GCState => Type.pointer
+	| File => Type.cpointer
+	| GCState => Type.cpointer
 	| Global g => Global.ty g
-	| GlobalPointerNonRoot _ => Type.pointer
 	| Int _ => Type.int
-	| IntInf _ => Type.pointer
 	| Label _ => Type.label
 	| Line => Type.int
 	| Offset {ty, ...} => ty
-	| Pointer _ => Type.pointer
+	| Real _ => Type.real
 	| Register r => Register.ty r
-	| Runtime z => GCField.ty z
+	| Runtime z => Type.fromRuntime (GCField.ty z)
+	| SmallIntInf _ => Type.intInf
 	| StackOffset {ty, ...} => ty
-	| Uint _ => Type.uint
+	| Word _ => Type.word
 	 
       val rec equals =
 	 fn (ArrayOffset {base = b, index = i, ...},
 	     ArrayOffset {base = b', index = i', ...}) =>
 	        equals (b, b') andalso equals (i, i') 
-	   | (CastInt z, CastInt z') => equals (z, z')
-	   | (CastWord z, CastWord z') => equals (z, z')
+	   | (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
-	   | (Float f, Float f') => f = f'
 	   | (GCState, GCState) => true
-	   | (Int n, Int n') => n = n'
-	   | (IntInf w, IntInf w') => Word.equals (w, w')
+	   | (Int i, Int i') => i = i'
 	   | (Line, Line) => true
 	   | (Offset {base = b, offset = i, ...},
 	      Offset {base = b', offset = i', ...}) =>
 	        equals (b, b') andalso i = i' 
-	   | (Pointer n, Pointer n') => n = n'
+	   | (Real s, Real s') => s = s'
 	   | (Register r, Register r') => Register.equals (r, r')
+	   | (SmallIntInf w, SmallIntInf w') => Word.equals (w, w')
 	   | (StackOffset {offset = n, ...}, StackOffset {offset = n', ...}) =>
 		n = n'
-	   | (Uint w, Uint w') => w = w'
+	   | (Word w, Word w') => w = w'
 	   | _ => false
 
       fun interfere {write: t, read: t}: bool =
@@ -193,7 +246,6 @@
 	       inter base orelse inter index
 	  | (Contents {oper, ...}, _) => inter oper
 	  | (Global g, Global g') => Global.equals (g, g')
-	  | (GlobalPointerNonRoot i, GlobalPointerNonRoot j) => i = j
 	  | (Offset {base, offset, ...}, _) => inter base
 	  | (Register r, Register r') => Register.equals (r, r')
 	  | (StackOffset {offset = off, ty = ty},
@@ -207,6 +259,9 @@
 	 end
    end
 
+structure Switch = Switch (open Atoms
+			   structure Use = Operand)
+
 structure Statement =
    struct
       datatype t =
@@ -274,9 +329,16 @@
 	  | PrimApp {args, dst, ...} =>
 	       Vector.fold (args, Option.fold (dst, ac, f), f)
 	  | _ => ac
-   end
 
-structure Cases = MachineCases (structure Label = Label)
+      fun foldDefs (s, a, f) =
+	 case s of
+	    Move {dst, ...} => f (dst, a)
+	  | Object {dst, ...} => f (dst, a)
+	  | PrimApp {dst, ...} => (case dst of
+				      NONE => a
+				    | SOME z => f (z, a))
+	  | _ => a
+   end
 
 structure FrameInfo =
    struct
@@ -318,12 +380,7 @@
        | Goto of Label.t
        | Raise
        | Return of {live: Operand.t vector}
-       | Switch of {cases: Cases.t,
-		    default: Label.t option,
-		    test: Operand.t}
-       | SwitchIP of {int: Label.t,
-		      pointer: Label.t,
-		      test: Operand.t}
+       | Switch of Switch.t
 
       fun layout t =
 	 let
@@ -360,24 +417,23 @@
 	     | Return {live} => 
 		  seq [str "Return ",
 		       record [("live", Vector.layout Operand.layout live)]]
-	     | Switch {test, cases, default} =>
-		  seq [str "Switch ",
-		       tuple [Operand.layout test,
-			      Cases.layout cases,
-			      Option.layout Label.layout default]]
-	     | SwitchIP {test, int, pointer} =>
-		  seq [str "SwitchIP ", tuple [Operand.layout test,
-					       Label.layout int,
-					       Label.layout pointer]]
+	     | Switch s => Switch.layout s
 	 end
 
-      fun foldOperands (t, ac, f) =
+       fun foldOperands (t, ac, f) =
+ 	 case t of
+ 	    Arith {args, dst, ...} => Vector.fold (args, f (dst, ac), f)
+ 	  | CCall {args, ...} => Vector.fold (args, ac, f)
+ 	  | Switch s =>
+	       Switch.foldLabelUse
+	       (s, ac, {label = fn (_, a) => a,
+			use = f})
+ 	  | _ => ac
+
+       fun foldDefs (t, a, f) =
 	 case t of
-	    Arith {args, dst, ...} => Vector.fold (args, f (dst, ac), f)
-	  | CCall {args, ...} => Vector.fold (args, ac, f)
-	  | Switch {test, ...} => f (test, ac)
-	  | SwitchIP {test, ...} => f (test, ac)
-	  | _ => ac
+	    Arith {dst, ...} => f (dst, a)
+	  | _ => a
    end
 
 structure Kind =
@@ -456,73 +512,80 @@
 	 end
 
       fun layouts (block, output' : Layout.t -> unit) = output' (layout block)
+
+      fun foldDefs (T {kind, statements, transfer, ...}, a, f) =
+	 let
+	    val a =
+	       case kind of
+		  Kind.CReturn {dst, ...} =>
+		     (case dst of
+			 NONE => a
+		       | SOME z => f (z, a))
+		| _ => a
+	    val a =
+	       Vector.fold (statements, a, fn (s, a) =>
+			    Statement.foldDefs (s, a, f))
+	    val a = Transfer.foldDefs (transfer, a, f)
+	 in
+	    a
+	 end
    end
 
 structure Chunk =
    struct
       datatype t = T of {chunkLabel: ChunkLabel.t,
-			 blocks: Block.t vector,
-			 regMax: Type.t -> int}
+			 blocks: Block.t vector}
 
-      fun layout (T {blocks, regMax, ...}) =
+      fun layout (T {blocks, ...}) =
 	 let
 	    open Layout
 	 in
-	    align
-	    [align (List.map (Type.all, fn t =>
-			      seq [str "regMax ", Type.layout t,
-				   str " = ", Int.layout (regMax t)])),
-	     align (Vector.toListMap (blocks, Block.layout))]
+	    align (Vector.toListMap (blocks, Block.layout))
 	 end
 
-      fun layouts (c as T {blocks, regMax, ...}, output' : Layout.t -> unit) =
-	 let
-	    open Layout
-	    val output = output'
-	 in
-	    List.foreach (Type.all, fn t =>
-			  output (seq [str "regMax ", Type.layout t,
-				       str " = ", Int.layout (regMax t)]))
-	    ; Vector.foreach (blocks, fn block => Block.layouts (block, output))
-	 end
+      fun layouts (c as T {blocks, ...}, output : Layout.t -> unit) =
+	 Vector.foreach (blocks, fn block => Block.layouts (block, output))
+
+
+      fun foldRegs (T {blocks, ...}, a, f) =
+	 Vector.fold
+	 (blocks, a, fn (b, a) =>
+	  Block.foldDefs
+	  (b, a, fn (z, a) =>
+	   case z of
+	      Operand.Register r => f (r, a)
+	    | _ => a))
    end
 
 structure Program =
    struct
       datatype t = T of {chunks: Chunk.t list,
-			 floats: (Global.t * string) list,
 			 frameOffsets: int vector vector,
-			 globals: Type.t -> int,
-			 globalsNonRoot: int,
 			 handlesSignals: bool,
 			 intInfs: (Global.t * string) list,
 			 main: {chunkLabel: ChunkLabel.t,
 				label: Label.t},
 			 maxFrameSize: int,
-			 objectTypes: Runtime.ObjectType.t vector,
+			 objectTypes: ObjectType.t vector,
 			 profileAllocLabels: string vector,
+			 reals: (Global.t * string) list,
 			 strings: (Global.t * string) list}
 
-      fun layouts (p as T {chunks, frameOffsets, globals, globalsNonRoot,
-			   handlesSignals, main = {label, ...}, maxFrameSize,
-			   objectTypes, profileAllocLabels, ...},
+      fun layouts (p as T {chunks, frameOffsets, handlesSignals,
+			   main = {label, ...},
+			   maxFrameSize, objectTypes,
+			   profileAllocLabels, ...},
 		   output': Layout.t -> unit) =
 	 let
 	    open Layout
 	    val output = output'
 	 in
 	    output (record
-		    [("globals",
-		      List.layout (fn t =>
-				   seq [Type.layout t, str " ",
-					Int.layout (globals t)])
-		      Type.all),
-		     ("globalsNonRoot", Int.layout globalsNonRoot),
-		     ("handlesSignals", Bool.layout handlesSignals),
+		    [("handlesSignals", Bool.layout handlesSignals),
 		     ("main", Label.layout label),
 		     ("maxFrameSize", Int.layout maxFrameSize),
-		     ("objectTypes",
-		      Vector.layout Runtime.ObjectType.layout objectTypes),
+		     ("pointerTypes",
+		      Vector.layout ObjectType.layout objectTypes),
 		     ("profileAllocLabels",
 		      Vector.layout String.layout profileAllocLabels),
 		     ("frameOffsets",
@@ -530,11 +593,20 @@
             ; List.foreach (chunks, fn chunk => Chunk.layouts (chunk, output))
 	 end
 	    
-      fun typeCheck (T {chunks, floats, frameOffsets, globals, globalsNonRoot,
-			intInfs, main, maxFrameSize, objectTypes, strings, ...})
-	 =
+      fun foldRegs (T {chunks, ...}, a, f) =
+	 List.fold (chunks, a, fn (c, a) => Chunk.foldRegs (c, a, f))
+
+      fun typeCheck (T {chunks, frameOffsets, intInfs, main,
+			maxFrameSize, objectTypes, reals, strings, ...}) =
 	 let
-	    val numTypeIndices = Vector.length objectTypes
+	    val _ =
+	       Vector.foreach
+	       (objectTypes, fn ty =>
+		Err.check ("objectType",
+			   fn () => ObjectType.isOk ty,
+			   fn () => ObjectType.layout ty))
+	    fun tyconTy (pt: PointerTycon.t): ObjectType.t =
+	       Vector.sub (objectTypes, PointerTycon.index pt)
 	    open Layout
 	    fun globals (name, gs, ty) =
 	       List.foreach
@@ -543,9 +615,9 @@
 			   fn () => Type.equals (ty, Global.ty g),
 			   fn () =>
 			   seq [String.layout s, str ": ", Type.layout ty]))
-	    val _ = globals ("float", floats, Type.double)
-	    val _ = globals ("intInf", intInfs, Type.pointer)
-	    val _ = globals ("string", strings, Type.pointer)
+	    val _ = globals ("real", reals, Type.real)
+	    val _ = globals ("intInf", intInfs, Type.intInf)
+	    val _ = globals ("string", strings, Type.string)
 	    val {get = labelBlock: Label.t -> Block.t,
 		 set = setLabelBlock, ...} =
 	       Property.getSetOnce (Label.plist,
@@ -559,54 +631,101 @@
 	    val _ =
 	       List.foreach
 	       (chunks,
-		fn Chunk.T {chunkLabel, blocks, regMax} =>
+		fn Chunk.T {blocks, ...} =>
 		let
 		   fun checkOperand (x: Operand.t): unit =
 		      let
 			 datatype z = datatype Operand.t
 			 fun ok () =
 			    case x of
-			       ArrayOffset {base, index, ty} =>
-				  (checkOperand base
-				   ; checkOperand index
-				   ; (Type.equals (Operand.ty base, Type.pointer)
-				      andalso Type.equals (Operand.ty index,
-							   Type.int)))
-			     | CastInt x =>
-				  (checkOperand x
-				   ; Type.equals (Operand.ty x, Type.pointer))
-			     | CastWord x =>
-				  (checkOperand x
-				   ; (Type.equals (Operand.ty x, Type.pointer)
-				      orelse
-				      Type.equals (Operand.ty x, Type.int)))
+			       ArrayOffset z => arrayOffsetIsOk z
+			     | Cast (z, t) =>
+				  (checkOperand z
+				   ; (castIsOk
+				      {from = Operand.ty z,
+				       fromInt = (case z of
+						     Int i => SOME i
+						   | _ => NONE),
+				       to = t,
+				       tyconTy = tyconTy}))
 			     | Char _ => true
 			     | Contents {oper, ...} =>
 				  (checkOperand oper
-				   ; Type.equals (Operand.ty oper, Type.pointer))
+				   ; Type.equals (Operand.ty oper,
+						  Type.cpointer))
 			     | File => true
-			     | Float _ => true
 			     | GCState => true
 			     | Global _ => true
-			     | GlobalPointerNonRoot n =>
-				  0 <= n andalso n < globalsNonRoot
 			     | Int _ => true
-			     | IntInf w => 0wx1 = Word.andb (w, 0wx1)
 			     | Label l => (labelBlock l; true)
 			     | Line => true
-			     | Offset {base, ...} =>
-				  (checkOperand base
-				   ; Type.equals (Operand.ty base, Type.pointer))
-			     | Pointer n => 0 < Int.rem (n, Runtime.wordSize)
-			     | Register (Register.T {index, ty}) =>
-				  0 <= index andalso index < regMax ty
+			     | Offset z => offsetIsOk z
+			     | Real _ => true
+			     | Register _ => true
 			     | Runtime _ => true
+			     | SmallIntInf w => 0wx1 = Word.andb (w, 0wx1)
 			     | StackOffset {offset, ty, ...} =>
 				  offset + Type.size ty <= maxFrameSize
-			     | Uint _ => true
+			     | Word _ => true
 		      in
 			 Err.check ("operand", ok, fn () => Operand.layout x)
 		      end
+		   and arrayOffsetIsOk {base, index, ty} =
+		      let
+			 val _ = checkOperand base
+			 val _ = checkOperand index
+		      in
+			 Type.equals (Operand.ty index, Type.int)
+			 andalso
+			 case Operand.ty base of
+			    Type.CPointer => true (* needed for card marking *)
+			  | Type.EnumPointers {enum, pointers} =>
+			       0 = Vector.length enum
+			       andalso
+			       Vector.forall
+			       (pointers, fn p =>
+				case tyconTy p of
+				   ObjectType.Array
+				   (MemChunk.T {components, ...}) =>
+				      1 = Vector.length components
+				      andalso
+				      let
+					 val {offset, ty = ty', ...} =
+					    Vector.sub (components, 0)
+				      in
+					 offset = 0
+					 andalso Type.equals (ty, ty')
+				      end
+				 | _ => false)
+			  | _ => false
+		      end
+		   and offsetIsOk {base, offset, ty} =
+		      let
+			 val _ = checkOperand base
+			 fun memChunkIsOk (MemChunk.T {components, ...}) =
+			    case (Vector.peek
+				  (components, fn {offset = offset', ...} =>
+				   offset = offset')) of
+			       NONE => false
+			     | SOME {ty = ty', ...} => Type.equals (ty, ty')
+				  
+		      in
+			 case Operand.ty base of
+			    Type.EnumPointers {enum, pointers} =>
+			       0 = Vector.length enum
+			       andalso
+			       ((* Vector_fromArray header update. *)
+				(offset = Runtime.headerOffset
+				 andalso Type.equals (ty, Type.word))
+				orelse
+				Vector.forall
+				(pointers, fn p =>
+				 case tyconTy p of
+				    ObjectType.Normal m => memChunkIsOk m
+				  | _ => false))
+			  | Type.MemChunk m => memChunkIsOk m
+			  | _ => false
+		      end
 		   fun checkOperands v = Vector.foreach (v, checkOperand)
 		   fun check' (x, name, isOk, layout) =
 		      Err.check (name, fn () => isOk x, fn () => layout x)
@@ -619,40 +738,6 @@
 		      andalso 0 = Int.rem (size, 4)
 		   fun checkFrameInfo i =
 		      check' (i, "frame info", frameInfoOk, FrameInfo.layout)
-		   fun isValidNormal ({numPointers = np,
-				       numWordsNonPointers = nwnp},
-				      stores): bool =
-		      let
-			 val pointerStart = nwnp * Runtime.wordSize
-			 val pointerEnd = pointerStart + np * Runtime.pointerSize
-			 val initPointers = Array.new (np, false)
-		      in
-			 (* Check that every store is valid *)
-			 Vector.forall
-			 (stores, fn {offset, value} =>
-			  let
-			     val _ = checkOperand value
-			     val ty = Operand.ty value
-			  in
-			     if Type.isPointer ty
-				then
-				   pointerStart <= offset
-				   andalso offset < pointerEnd
-				   andalso Runtime.isWordAligned offset
-				   andalso (Array.update
-					    (initPointers,
-					     Int.quot (offset - pointerStart,
-						       Runtime.pointerSize),
-					     true)
-					    ; true)
-			     else
-				0 <= offset
-				andalso (offset + Type.size ty <= pointerStart)
-			  end)
-			 andalso
-			 (* Check that every pointer is initialized. *)
-			 Array.forall (initPointers, fn b => b)
-		      end
 		   fun kindOk (k: Kind.t): bool =
 		      let
 			 datatype z = datatype Kind.t
@@ -686,8 +771,13 @@
 				; (case Vector.sub (objectTypes,
 						    Runtime.headerToTypeIndex
 						    header) of
-				      Runtime.ObjectType.Normal z =>
-					 isValidNormal (z, stores)
+				      ObjectType.Normal mc =>
+					 MemChunk.isValidInit
+					 (mc, 
+					  Vector.map
+					  (stores, fn {offset, value} =>
+					   {offset = offset,
+					    ty = Operand.ty value}))
 				    | _ => false) handle Subscript => false)
 			  | PrimApp {args, dst, prim} =>
 			       (Option.app (dst, checkOperand)
@@ -732,8 +822,10 @@
 						 (case (dst, CFunction.returnTy f) of
 						     (NONE, _) => true
 						   | (SOME x, SOME ty) =>
-							Type.equals
-							(ty, Operand.ty x)
+							Runtime.Type.equals
+							(ty,
+							 Type.toRuntime
+							 (Operand.ty x))
 						   | _ => false)
 					    | _ => false
 					end
@@ -760,21 +852,8 @@
 			  | Goto l => labelIsJump l
 			  | Raise => true
 			  | Return {live} => (checkOperands live; true)
-			  | Switch {cases, default, test} =>
-			       (checkOperand test
-				; (Cases.forall (cases, labelIsJump)
-				   andalso Option.forall (default, labelIsJump)
-				   andalso
-				   (Type.equals
-				    (Operand.ty test,
-				     case cases of
-					Cases.Char _ => Type.char
-				      | Cases.Int _ => Type.int
-				      | Cases.Word _ => Type.uint))))
-			  | SwitchIP {int, pointer, test} =>
-			       (checkOperand test
-				; (labelIsJump pointer
-				   andalso labelIsJump int))
+			  | Switch s =>
+			       Switch.isOk (s, {labelIsOk = labelIsJump})
 		      end
 		   fun blockOk (Block.T {kind, label, live, profileInfo,
 					 statements, transfer}): bool =



1.22      +32 -34    mlton/mlton/backend/machine.sig

Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- machine.sig	2 Nov 2002 03:37:38 -0000	1.21
+++ machine.sig	7 Dec 2002 02:21:52 -0000	1.22
@@ -12,39 +12,44 @@
    sig
       structure Label: HASH_ID
       structure Prim: PRIM
-      structure Runtime: RUNTIME
    end
 
 signature MACHINE = 
    sig
-      include MACHINE_STRUCTS
+      include MACHINE_ATOMS
 
+      structure Switch: SWITCH
+      sharing Label = Switch.Label
+      sharing PointerTycon = Switch.PointerTycon
+      sharing Type = Switch.Type
       structure CFunction: C_FUNCTION
       sharing CFunction = Runtime.CFunction
       structure ChunkLabel: UNIQUE_ID
-      structure Type: MTYPE
-      sharing Type = Runtime.Type
 
       structure Register:
 	 sig
-	    datatype t = T of {index: int,
-			       ty: Type.t}
+	    type t
 
 	    val equals: t * t -> bool
-	    val index: t -> int
+	    val index: t -> int 
 	    val layout: t -> Layout.t
+	    val new: Type.t -> t
+	    val plist: t -> PropertyList.t
 	    val toString: t -> string
 	    val ty: t -> Type.t
 	 end
 
       structure Global:
 	 sig
-	    datatype t = T of {index: int,
-			       ty: Type.t}
+	    type t
 
 	    val equals: t * t -> bool
 	    val index: t -> int
+	    val isRoot: t -> bool
 	    val layout: t -> Layout.t
+	    val new: {isRoot: bool, ty: Type.t} -> t
+	    val numberOfNonRoot: unit -> int
+	    val numberOfType: Runtime.Type.t -> int
 	    val toString: t -> string
 	    val ty: t -> Type.t
 	 end
@@ -55,29 +60,26 @@
 	       ArrayOffset of {base: t,
 			       index: t,
 			       ty: Type.t}
-	     | CastInt of t (* takes an IntOrPointer and makes it an int *)
-	     | CastWord of t (* takes a pointer and makes it a word *)
+	     | Cast of t * Type.t
 	     | Char of char
 	     | Contents of {oper: t,
 			    ty: Type.t}
 	     | File (* expand by codegen into string constant *)
-	     | Float of string
 	     | GCState
 	     | Global of Global.t
-	     | GlobalPointerNonRoot of int
 	     | Int of int
-	     | IntInf of word
 	     | Label of Label.t
 	     | Line (* expand by codegen into int constant *)
 	     | Offset of {base: t,
 			  offset: int,
 			  ty: Type.t}
-	     | Pointer of int (* the int must be nonzero mod Runtime.wordSize. *)
+	     | Real of string
 	     | Register of Register.t
 	     | Runtime of Runtime.GCField.t
+	     | SmallIntInf of word
 	     | StackOffset of {offset: int,
 			       ty: Type.t}
-	     | Uint of Word.t
+	     | Word of Word.t
 
 	    val equals: t * t -> bool
 	    val interfere: {write: t, read: t} -> bool
@@ -85,6 +87,7 @@
 	    val toString: t -> string
 	    val ty: t -> Type.t
 	 end
+      sharing Operand = Switch.Use
 
       structure Statement:
 	 sig
@@ -117,8 +120,6 @@
 			srcs: Operand.t vector} -> t vector
 	 end
 
-      structure Cases: MACHINE_CASES sharing Label = Cases.Label
-
       structure FrameInfo:
 	 sig
 	    datatype t =
@@ -160,16 +161,7 @@
 	     | Goto of Label.t (* label must be a Jump *)
 	     | Raise
 	     | Return of {live: Operand.t vector}
-	     | Switch of {test: Operand.t,
-			  cases: Cases.t,
-			  default: Label.t option}
-	     (* Switch to one of two labels, based on whether the operand is an
-	      * Integer or a Pointer.  Pointers are word aligned and integers
-	      * are not.
-	      *)
-	     | SwitchIP of {int: Label.t,
-			    pointer: Label.t,
-			    test: Operand.t}
+	     | Switch of Switch.t
 
 	    val foldOperands: t * 'a * (Operand.t * 'a -> 'a) -> 'a
 	    val layout: t -> Layout.t
@@ -208,31 +200,37 @@
       structure Chunk:
 	 sig
 	    datatype t = T of {blocks: Block.t vector,
-			       chunkLabel: ChunkLabel.t,
-			       regMax: Type.t -> int}
+			       chunkLabel: ChunkLabel.t}
+
+	    (* Fold over each register that appears in the chunk.
+	     * May visit duplicates.
+	     *)
+	    val foldRegs: t * 'a * (Register.t * 'a -> 'a) -> 'a
 	 end
 
       structure Program:
 	 sig
 	    datatype t =
 	       T of {chunks: Chunk.t list,
-		     floats: (Global.t * string) list,
 		     (* Each vector in frame Offsets specifies the offsets
 		      * of live pointers in a stack frame.  A vector is referred
 		      * to by index as the frameOffsetsIndex in a block kind.
 		      *)
 		     frameOffsets: int vector vector,
-		     globals: Type.t -> int,
-		     globalsNonRoot: int,
 		     handlesSignals: bool,
 		     intInfs: (Global.t * string) list,
 		     main: {chunkLabel: ChunkLabel.t,
 			    label: Label.t},
 		     maxFrameSize: int,
-		     objectTypes: Runtime.ObjectType.t vector,
+		     objectTypes: ObjectType.t vector,
 		     profileAllocLabels: string vector,
+		     reals: (Global.t * string) list,
 		     strings: (Global.t * string) list}
 
+	    (* Fold over each register that appears in the chunk.
+	     * May visit duplicates.
+	     *)
+	    val foldRegs: t * 'a * (Register.t * 'a -> 'a) -> 'a
 	    val layouts: t * (Layout.t -> unit) -> unit
 	    val typeCheck: t -> unit
 	 end



1.3       +7 -14     mlton/mlton/backend/profile-alloc.fun

Index: profile-alloc.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile-alloc.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- profile-alloc.fun	2 Nov 2002 03:37:38 -0000	1.2
+++ profile-alloc.fun	7 Dec 2002 02:21:52 -0000	1.3
@@ -27,7 +27,7 @@
 	    returnTy = NONE}
    end
 
-fun doit (Program.T {functions, main, ...}) =
+fun doit (Program.T {functions, main, objectTypes, ...}) =
    let
       (* Start the counter at 1 because element 0 is PROFILE_ALLOC_MISC. *)
       val counter = Counter.new 1
@@ -35,9 +35,9 @@
       val labelIndex = String.memoize (fn s =>
 				       (List.push (profileAllocLabels, s)
 					; Counter.next counter))
-      fun doFunction (f: Function.t) =
+      fun doFunction (f: Function.t): Function.t =
 	 let
-	    val {args, blocks, name, start} = Function.dest f
+	    val {args, blocks, name, raises, returns, start} = Function.dest f
 	    val extraBlocks = ref []
 	    val blocks =
 	       Vector.map
@@ -49,17 +49,7 @@
 		      Vector.fold
 		      (statements, 0, fn (s, ac) =>
 		       case s of
-			  Statement.Object {numPointers, numWordsNonPointers,
-					    ...} =>
-			     ac
-			     + Runtime.normalHeaderSize
-			     + (Runtime.normalSize
-				{numPointers = numPointers,
-				 numWordsNonPointers = numWordsNonPointers})
-			| Statement.PrimApp {prim, ...} =>
-			    (case Prim.name prim of
-				Prim.Name.Array_array0 => ac + Runtime.array0Size
-			      | _ => ac)
+			  Statement.Object {size, ...} => ac + size
 			| _ => ac)
 		   val needs =
 		      case transfer of
@@ -123,6 +113,8 @@
 	    Function.new {args = args,
 			  blocks = blocks,
 			  name = name,
+			  raises = raises,
+			  returns = returns,
 			  start = start}
 	 end
       val functions = List.revMap (functions, doFunction)
@@ -131,6 +123,7 @@
    in
       Program.T {functions = functions,
 		 main = main,
+		 objectTypes = objectTypes,
 		 profileAllocLabels = profileAllocLabels}
    end
 



1.9       +507 -192  mlton/mlton/backend/representation.fun

Index: representation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- representation.fun	24 Nov 2002 01:19:43 -0000	1.8
+++ representation.fun	7 Dec 2002 02:21:52 -0000	1.9
@@ -12,262 +12,577 @@
 struct
 
 open S
-local open Ssa
+structure R = Rssa
+local
+   open Rssa
+in
+   structure ObjectType = ObjectType
+   structure PointerTycon = PointerTycon
+   structure Runtime = Runtime
+end
+structure S = Ssa
+local
+   open Ssa
 in
    structure Con = Con
-   structure Datatype = Datatype
    structure Tycon = Tycon
-   structure Type = Type
 end
 
 structure TyconRep =
    struct
       datatype t =
-	 Enum of {numEnum: int}
-       | EnumDirect of {numEnum: int}
-       | EnumIndirect of {numEnum: int}
-       | EnumIndirectTag of {numEnum: int,
-			     numTag: int}
-       | IndirectTag of {numTag: int}
-       | Prim of Mtype.t
+	 Direct
+       | Enum
+       | EnumDirect
+       | EnumIndirect
+       | EnumIndirectTag
+       | IndirectTag
        | Void
 
-      val pointer = Prim Mtype.pointer
-
-      val toMtype =
-	 fn Enum _ => SOME Mtype.int
-	  | EnumDirect _ => SOME Mtype.pointer
-	  | EnumIndirect _ => SOME Mtype.pointer
-	  | EnumIndirectTag _ => SOME Mtype.pointer
-	  | IndirectTag _ => SOME Mtype.pointer
-	  | Prim t => SOME t
-	  | Void => NONE
-
       val layout =
 	 let
 	    open Layout
 	 in
-	    fn Enum {numEnum} => seq [str "Enum ", Int.layout numEnum]
-	     | EnumDirect {numEnum} =>
-		  seq [str "EnumDirect ", Int.layout numEnum]
-	     | EnumIndirect {numEnum} =>
-		  seq [str "EnumIndirect ", Int.layout numEnum]
-	     | EnumIndirectTag {numEnum, numTag} =>
-		  seq [str "EnumIndirectTag",
-		       record [("numEnum", Int.layout numEnum),
-			       ("numTag", Int.layout numTag)]]
-	     | IndirectTag {numTag} =>
-		  seq [str "IndirectTag ", Int.layout numTag]
-	     | Prim m => Mtype.layout m
+	    fn Direct => str "Direct"
+	     | Enum => str "Enum"
+	     | EnumDirect => str "EnumDirect"
+	     | EnumIndirect => str "EnumIndirect"
+	     | EnumIndirectTag => str "EnumIndirectTag"
+	     | IndirectTag => str "IndirectTag"
 	     | Void => str "Void"
 	 end
       
-      val equals =
-	 fn (Prim t, Prim t') => Mtype.equals (t, t')
-	  | (Enum {numEnum = n}, Enum {numEnum = n'}) => n = n'
-	  | (EnumDirect {numEnum = n}, EnumDirect {numEnum = n'}) => n = n'
-	  | (EnumIndirect {numEnum = n}, EnumIndirect {numEnum = n'}) => n = n'
-	  | (EnumIndirectTag {numEnum = n, numTag = t},
-	     EnumIndirectTag {numEnum = n', numTag = t'}) =>
-	    n = n' andalso t = t'
-	   | (IndirectTag {numTag = n}, IndirectTag {numTag = n'}) => n = n'
-	   | (Void, Void) => true
-	   | _ => false
+      val equals:t * t -> bool = op =
    end
 
-structure ConRep =
+structure TupleRep =
    struct
-      datatype t =
-	 Void
-       | Int of int
-       | IntCast of int
-       | Transparent of Mtype.t
-       | Tuple
-       | TagTuple of int
+      datatype t = T of {offsets: {offset: int,
+				   ty: R.Type.t} option vector,
+			 size: int,
+			 ty: R.Type.t,
+			 tycon: R.PointerTycon.t}
+
+      fun layout (T {offsets, size, ty, tycon, ...}) =
+	 let
+	    open Layout
+	 in record [("offsets",
+		     Vector.layout (Option.layout
+				    (fn {offset, ty} =>
+				     record [("offset", Int.layout offset),
+					     ("ty", R.Type.layout ty)]))
+		     offsets),
+		    ("size", Int.layout size),
+		    ("ty", R.Type.layout ty),
+		    ("tycon", R.PointerTycon.layout tycon)]
+	 end
 
       local
-	 open Layout
+	 fun make f (T r) = f r
       in
-	 val layout =
-	    fn Void => str "Void"
-	     | Int n => seq [str "Int ", Int.layout n]
-	     | IntCast n => seq [str "IntCast ", Int.layout n]
-	     | Transparent t => seq [str "Transparent ", Mtype.layout t]
-	     | Tuple => str "Tuple"
-	     | TagTuple n => seq [str "TagTuple ", Int.layout n]
+	 val tycon = make #tycon
       end
    end
 
-(* fixed-point.  Initially assume all datatype tycons are Void
- * Change them if they have more than one variant or contain
- * a useful component
- *)
+structure ConRep =
+   struct
+      datatype t =
+	 IntAsTy of {int: int,
+		     ty: R.Type.t}
+       | TagTuple of {rep: TupleRep.t,
+		      tag: int}
+       | Transparent of R.Type.t
+       | Tuple of TupleRep.t
+       | Void
+
+      val layout =
+	 let
+	    open Layout
+	 in
+	    fn IntAsTy {int, ty} =>
+	          seq [Int.layout int, str ": ", R.Type.layout ty]
+	     | TagTuple {rep, tag} =>
+		  seq [str "TagTuple ",
+		       record [("rep", TupleRep.layout rep),
+			       ("tag", Int.layout tag)]]
+	     | Transparent t => seq [str "Transparent ", R.Type.layout t]
+	     | Tuple r => seq [str "Tuple ", TupleRep.layout r]
+	     | Void => str "Void"
+	 end
+   end
 
-fun compute (Ssa.Program.T {datatypes, ...}) =
-   let 
+fun compute (program as Ssa.Program.T {datatypes, ...}) =
+   let
       val {get = tyconRep, set = setTyconRep, ...} =
-	 Property.getSet (Tycon.plist, Property.initRaise ("rep", Tycon.layout))
+	 Property.getSet (Tycon.plist,
+			  Property.initRaise ("rep", Tycon.layout))
       val tyconRep =
 	 Trace.trace ("tyconRep", Tycon.layout, TyconRep.layout) tyconRep
       val {get = conRep, set = setConRep, ...} =
-	 Property.getSetOnce (Con.plist, Property.initRaise ("rep", Con.layout))
-      val tyconMtype = TyconRep.toMtype o tyconRep
-      fun toMtype t =
+	 Property.getSetOnce (Con.plist,
+			      Property.initRaise ("rep", Con.layout))
+      fun isEmpty (t: S.Type.t): bool =
 	 let
-	    datatype z = datatype Type.dest
+	    datatype z = datatype S.Type.dest
 	 in
-	    case Type.dest t of
-	       Array _ => SOME Mtype.pointer
-	     | Char => SOME Mtype.char
-	     | Datatype c => tyconMtype c
-	     | Int => SOME Mtype.int
-	     | IntInf => SOME Mtype.pointer
-	     | Pointer => SOME Mtype.uint
-	     | PreThread => SOME Mtype.pointer
-	     | Real => SOME Mtype.double
-	     | Ref _ => SOME Mtype.pointer
-	     | Thread => SOME Mtype.pointer
-	     | Tuple ts => if Vector.isEmpty ts
-			      then NONE
-			   else SOME Mtype.pointer
-	     | Vector _ => SOME Mtype.pointer
-	     | Word => SOME Mtype.uint
-	     | Word8 => SOME Mtype.char
+	    case S.Type.dest t of
+	       Datatype c => (case tyconRep c of
+				 TyconRep.Void => true
+			       | _ => false)
+	     | Tuple ts => Vector.isEmpty ts
+	     | _ => false
 	 end
-      (* You can't memoize toMtype here because it depends on tyconMtype, which
-       * is in the midst of being computed.
+      (* Split constructors into those that carry values and those that
+       * don't.
        *)
-      (* Split constructors into those that carry values and those that don't. *)
       fun splitCons cons =
 	 Vector.fold (cons, ([], []), fn ({con, args}, (no, have)) =>
-		      if Vector.forall (args, Option.isNone o toMtype)
+		      if Vector.forall (args, isEmpty)
 			 then (con :: no, have)
 		      else (no, {con = con, args = args} :: have))
-      (* Compute a least-fixed-point on tycon representations. *)
+      (* Compute a least-fixed-point on tycon representations.  Initially
+       * assume all datatype tycons are Void.  Change them if they have more
+       * than one variant or contain a useful component.
+       *)
       val _ =
-	 Vector.foreach (datatypes, fn Datatype.T {tycon, ...} =>
+	 Vector.foreach (datatypes, fn S.Datatype.T {tycon, ...} =>
 			 setTyconRep (tycon, TyconRep.Void))
       val _ =
 	 FixedPoint.fix'
 	 (fn continue =>
 	  Vector.foreach
-	  (datatypes, fn Datatype.T {tycon, cons} =>
+	  (datatypes, fn S.Datatype.T {tycon, cons} =>
 	   let
 	      val (noArgs, haveArgs) = splitCons cons
-	      val numEnum = List.length noArgs
-	      val numTag = List.length haveArgs
 	      val old = tyconRep tycon
 	      val new =
 		 case (noArgs, haveArgs) of
-		    ([],     [])           => TyconRep.Void
-		  | ([_],    [])           => TyconRep.Void
-		  | (_,      [])           => TyconRep.Enum {numEnum = numEnum}
-		  | ([],     [{args, ...}]) =>
-		       (case Vector.length args of
-			   0 => Error.bug "args should be nonempty"
-			 | 1 => (case toMtype (Vector.sub (args, 0)) of
-				    NONE => TyconRep.Void
-				  | SOME t => TyconRep.Prim t)
-			 | _ => TyconRep.pointer)
-		  | (_,      [{args, ...}]) =>
+		    ([], []) => TyconRep.Void
+		  | ([_], []) => TyconRep.Void
+		  | (_, []) => TyconRep.Enum
+		  | ([], [{args, ...}]) => TyconRep.Direct
+		  | (_, [{args, ...}]) =>
 		       if (if 1 = Vector.length args
 			      then
 				 let
 				    val a = Vector.sub (args, 0)
-				    (* Which types are guaranteed to be represented
-				     * as zero mod 4.  You can't use IntInf or
-				     * Thread here -- In fact, it's not clear to
-				     * me you can use anything, because of bogus
-				     * values.
+				    (* Which types are guaranteed to be
+				     * translated to R.Type.Pointer and are
+				     * represented as zero mod 4.
 				     *)
-				    open Type
-				 in case Type.dest a of
-				    Array _ => true
-				  | Datatype c =>
-				       (case tyconRep c of
-					   TyconRep.IndirectTag _ => true
-					 | _ => false)
-				  | Ref _ => true
-				  | Tuple _ => true
-				  | Vector _ => true
-				  | _ => false
+				    datatype z = datatype S.Type.dest
+				 in
+				    case S.Type.dest a of
+				       Array _ => true
+				     | Datatype c =>
+					  (case tyconRep c of
+					      TyconRep.IndirectTag => true
+					    | _ => false)
+				     | Ref _ => true
+				     | Tuple _ => true
+				     | Vector _ => true
+				     | _ => false
 				 end
 			   else true)
-			  then TyconRep.EnumDirect {numEnum = numEnum}
-		       else TyconRep.EnumIndirect {numEnum = numEnum}
-		  | ([],     _)            =>
-		       TyconRep.IndirectTag {numTag = numTag}
-		  | _                      =>
-		       TyconRep.EnumIndirectTag {numEnum = numEnum,
-						 numTag = numTag}
+			  then TyconRep.EnumDirect
+		       else TyconRep.EnumIndirect
+		  | ([], _) => TyconRep.IndirectTag
+		  | _ => TyconRep.EnumIndirectTag
 	   in if TyconRep.equals (old, new)
 		 then ()
 	      else (continue ()
 		    ; setTyconRep (tycon, new))
 	   end))
-      (* Now we can memoize toMtype. *)
-      val {get = toMtype, ...} =
-	 Property.get (Type.plist, Property.initFun toMtype)
-      (* Set constructor representations. *)
-      fun direct (con, args, t) =
-	 setConRep (con,
-		    if 1 = Vector.length args
-		       then ConRep.Transparent t
-		    else ConRep.Tuple)
-      (* Choose tags that are not equal to 0 mod 4. *)
-      fun enum noArgs =
-	 let
-	    fun loop (i, cs) =
-	       case cs of
-		  [] => ()
-		| c :: cs => (setConRep (c, ConRep.IntCast i)
-			      ; loop (i + 2, cs))
-	 in loop (1, noArgs)
-	 end
-      fun indirectTag haveArgs = 
-	 List.foreachi (haveArgs, fn (i, {con, args}) =>
-			setConRep (con, ConRep.TagTuple i))
+      (* Accumulate all the ObjectTypes. *)
+      val objectTypes = ref []
+      (* Keep track of pointer types -- build them later, though. *)
+      val {get = refRep: S.Type.t -> TupleRep.t, set = setRefRep, ...} =
+	 Property.getSetOnce
+	 (S.Type.plist, Property.initRaise ("refRep", S.Type.layout))
+      val {get = tupleRep: S.Type.t -> TupleRep.t,
+	   set = setTupleRep, ...} =
+	 Property.getSetOnce
+	 (S.Type.plist, Property.initRaise ("tupleRep", S.Type.layout))
+      val {get = tyconCons, set = setTyconCons, ...} =
+	 Property.getSetOnce
+	 (Tycon.plist, Property.initRaise ("cons", Tycon.layout))
+      val _ =
+	 Vector.foreach (datatypes, fn S.Datatype.T {cons, tycon} =>
+			 setTyconCons (tycon, cons))
+      (* We have to break the cycle in recursive types to avoid an infinite
+       * recursion when converting from S.Type.t to R.Type.t.  This is done
+       * by creating pointer tycons and delaying building the corresponding
+       * object types until after toRtype is done.  The "finish" list keeps
+       * the list of things to do later.
+       *)
+      val finish: (unit -> unit) list ref = ref []
+      val {get = toRtype: S.Type.t -> R.Type.t option, ...} =
+	 Property.get
+	 (S.Type.plist,
+	  Property.initRec
+	  (fn (t: S.Type.t, toRtype) =>
+	   let
+	      fun typesRep {isTagged: bool,
+			    kind: R.MemChunk.t -> R.ObjectType.t,
+			    mutable: bool,
+			    pointerTycon: R.PointerTycon.t,
+			    ty: R.Type.t,
+			    tys: S.Type.t vector}: TupleRep.t =
+		 let
+		    val initialOffset = if isTagged then Runtime.wordSize else 0
+		    val tys = Vector.map (tys, toRtype)
+		    val bytes = ref []
+		    val doubleWords = ref []
+		    val words = ref []
+		    val pointers = ref []
+		    val _ =
+		       Vector.foreachi
+		       (tys, fn (i, t) =>
+			case t of
+			   NONE => ()
+			 | SOME t =>
+			      let
+				 val r =
+				    if let
+					  datatype z = datatype R.Type.t
+				       in
+					  case t of
+					     EnumPointers {pointers, ...} =>
+						0 < Vector.length pointers
+					   | IntInf => true
+					   | _ => false
+				       end
+				       then pointers
+				    else (case R.Type.size t of
+					     1 => bytes
+					   | 4 => words
+					   | 8 => doubleWords
+					   | _ => Error.bug "strange size")
+			      in
+				 List.push (r, (i, t))
+			      end)
+		    fun build (r, size, accum) =
+		       List.fold
+		       (!r, accum, fn ((index, ty), (res, offset)) =>
+			({index = index, offset = offset, ty = ty} :: res,
+			 offset + size))
+		    val (accum, offset: int) =
+		       build
+		       (bytes, 1,
+			build (words, 4,
+			       build (doubleWords, 8, ([], initialOffset))))
+		    val offset =
+		       Runtime.Type.align (Runtime.Type.pointer, offset)
+		    val (components, size) = build (pointers, 4, (accum, offset))
+		    val size = if 0 = size then 4 else size
+		    val offsets =
+		       Vector.mapi
+		       (tys, fn (i, ty) =>
+			Option.map
+			(ty, fn ty =>
+			 let
+			    val {offset, ty, ...} =
+			       List.lookup
+			       (components, fn {index, ...} => i = index)
+			 in
+			    {offset = offset, ty = ty}
+			 end))
+		    val components =
+		       List.revMap
+		       (components, fn {offset, ty, ...} =>
+			{mutable = mutable, offset = offset, ty = ty})
+		    val components =
+		       if isTagged
+			  then {mutable = false,
+				offset = 0,
+				ty = R.Type.int} :: components
+		       else components
+		    val components =
+		       Vector.fromArray
+		       (QuickSort.sortArray
+			(Array.fromList components,
+			 fn ({offset = i, ...}, {offset = i', ...}) =>
+			 i <= i'))
+		    val _ =
+		       List.push
+		       (objectTypes,
+			(pointerTycon,
+			 kind (R.MemChunk.T {components = components,
+					     size = size})))
+		 in
+		    TupleRep.T {offsets = offsets,
+				size = size,
+				ty = ty,
+				tycon = pointerTycon}
+		 end
+	      fun pointer {fin, kind, mutable, tys}: R.Type.t =
+		 let
+		    val pt = R.PointerTycon.new ()
+		    val ty = R.Type.pointer pt
+		    val _ =
+		       List.push
+		       (finish, fn () =>
+			fin (typesRep {isTagged = false,
+				       kind = kind,
+				       mutable = mutable,
+				       pointerTycon = pt,
+				       ty = ty,
+				       tys = tys}))
+		 in
+		    ty
+		 end
+	      fun convertDatatype (tycon: Tycon.t): R.Type.t option =
+		 let
+		    val (noArgs', haveArgs') = splitCons (tyconCons tycon)
+		    val noArgs = Vector.fromList noArgs'
+		    val haveArgs = Vector.fromList haveArgs'
+		    fun pointers () =
+		       Vector.tabulate (Vector.length haveArgs, fn _ =>
+					R.PointerTycon.new ())
+		    fun indirect {conRep, isTagged, pointerTycons, ty} =
+		       List.push
+		       (finish, fn () =>
+			Vector.foreachi2
+			(pointerTycons, haveArgs, fn (i, pt, {con, args}) =>
+			 let
+			    val rep =
+			       typesRep {isTagged = isTagged,
+					 kind = R.ObjectType.Normal,
+					 mutable = false,
+					 pointerTycon = pt,
+					 ty = ty,
+					 tys = args}
+			 in
+			    setConRep (con, conRep {rep = rep, tag = i})
+			 end))
+		    fun transparent {con, args} =
+		       let
+			  val ty =
+			     case toRtype (Vector.sub (args, 0)) of
+				NONE => Error.bug "strange transparent"
+			      | SOME ty => ty
+			  val _ = setConRep (con, ConRep.Transparent ty)
+		       in
+			  ty
+		       end
+		    fun enumAnd (pointers: R.PointerTycon.t vector): R.Type.t =
+		       let
+			  val enum =
+			     Vector.tabulate
+			     (Vector.length noArgs, fn i => 2 * i + 1)
+			  val ty =
+			     R.Type.EnumPointers {enum = enum,
+						  pointers = pointers}
+			  val _ =
+			     Vector.foreach2
+			     (noArgs, enum, fn (c, i) =>
+			      setConRep (c, (ConRep.IntAsTy
+					     {int = i, ty = ty})))
+		       in
+			  ty
+		       end
+		    fun indirectTag (): R.Type.t =
+		       let
+			  val pts = pointers ()
+			  val ty = enumAnd pts
+			  val _ = indirect {isTagged = true,
+					    conRep = ConRep.TagTuple,
+					    pointerTycons = pts,
+					    ty = ty}
+		       in
+			  ty
+		       end
+		 in
+		    case tyconRep tycon of
+		       TyconRep.Direct =>
+			  (case (noArgs', haveArgs') of
+			      ([], []) => NONE
+			    | ([con], []) =>
+				 (setConRep (con, ConRep.Void)
+				  ; NONE)
+			    | ([], [ac as {args, con}]) =>
+				 if 1 = Vector.length args
+				    then SOME (transparent ac)
+				 else
+				    SOME
+				    (pointer
+				     {fin = (fn r =>
+					     setConRep (con, ConRep.Tuple r)),
+				      kind = R.ObjectType.Normal,
+				      mutable = false,
+				      tys = args})
+			    | _ =>
+				 Error.bug
+				 (concat ["strange TyconRep.Direct for ",
+					  Layout.toString (Tycon.layout tycon)]))
+		     | TyconRep.Enum =>
+			  let
+			     val enum =
+				Vector.tabulate
+				(Vector.length noArgs, fn i => i)
+			     val ty =
+				R.Type.EnumPointers {enum = enum,
+						     pointers = Vector.new0 ()}
+			     fun set (i, c) =
+				setConRep (c, (ConRep.IntAsTy
+					       {int = i, ty = ty}))
+			     val _ =
+				if Tycon.equals (tycon, Tycon.bool)
+				   then (set (0, Con.falsee)
+					 ; set (1, Con.truee))
+				else Vector.foreachi (noArgs, set)
+			  in
+			     SOME ty
+			  end
+		     | TyconRep.EnumDirect =>
+			  (case haveArgs' of
+			      [ca as {con, args}] =>
+				 if 1 = Vector.length args
+				    then
+				       case transparent ca of
+					  R.Type.EnumPointers {pointers, ...} =>
+					     SOME (enumAnd pointers)
+					| _ =>
+					     Error.bug "EnumDirect of non pointer"
+				 else
+				    let
+				       val pt = R.PointerTycon.new ()
+				       val ty = enumAnd (Vector.new1 pt)
+				       val _ =
+					  List.push
+					  (finish, fn () =>
+					   setConRep
+					   (con,
+					    ConRep.Tuple
+					    (typesRep
+					     {isTagged = false,
+					      kind = R.ObjectType.Normal,
+					      mutable = false,
+					      pointerTycon = pt,
+					      ty = ty,
+					      tys = args})))
+				    in
+				       SOME ty
+				    end
+					| _ =>
+					     Error.bug "strange haveArgs for EnumDirect")
+		     | TyconRep.EnumIndirect =>
+			  let
+			     val pts = pointers ()
+			     val ty = enumAnd pts
+			     val _ = indirect {conRep = ConRep.Tuple o #rep,
+					       isTagged = false,
+					       pointerTycons = pts,
+					       ty = ty}
+			  in
+			     SOME ty
+			  end
+		     | TyconRep.EnumIndirectTag => SOME (indirectTag ())
+		     | TyconRep.IndirectTag => SOME (indirectTag ())
+		     | TyconRep.Void =>
+			  let
+			     val _ =
+				case (noArgs', haveArgs') of
+				   ([], []) => ()
+				 | ([con], []) => setConRep (con, ConRep.Void)
+				 | _ => Error.bug "strange TyconRep.Void"
+			  in
+			     NONE
+			  end
+		 end
+	      fun array {mutable: bool, ty: S.Type.t}: R.Type.t =
+		 let
+		    fun new () =
+		       pointer {fin = fn _ => (),  
+				kind = R.ObjectType.Array,
+				mutable = mutable,
+				tys = Vector.new1 ty}
+		    datatype z = datatype S.Type.dest
+		 in
+		    case S.Type.dest ty of
+		       Char => R.Type.string
+		     | Word => if mutable
+				  then new ()
+			       else R.Type.wordVector
+		     | Word8 => R.Type.string
+		     | _ => 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
+	       | IntInf => SOME R.Type.intInf
+	       | Pointer => SOME R.Type.cpointer
+	       | PreThread => SOME R.Type.thread
+	       | Real => SOME R.Type.real
+	       | Ref t =>
+		    SOME (pointer {fin = fn r => setRefRep (t, r),
+				   kind = R.ObjectType.Normal,
+				   mutable = true,
+				   tys = Vector.new1 t})
+	       | Thread => SOME R.Type.thread
+	       | Tuple ts =>
+		    if Vector.isEmpty ts
+		       then NONE
+		    else
+		       SOME (pointer {fin = fn r => setTupleRep (t, r),
+				      kind = R.ObjectType.Normal,
+				      mutable = false,
+				      tys = S.Type.detuple t})
+	       | Vector t => SOME (array {mutable = false, ty = t})
+	       | Word => SOME R.Type.word
+	       | Word8 => SOME R.Type.char
+	   end))
+      val toRtype =
+	 Trace.trace
+	 ("toRtype", S.Type.layout, Option.layout R.Type.layout)
+	 toRtype
+      val _ = S.Program.foreachVar (program, fn (_, t) => (toRtype t; ()))
+      val n = List.length (!finish)
+      val _ = List.foreach (!finish, fn f => f ())
+      val _ =
+	 if n = List.length (!finish)
+	    then ()
+	 else Error.bug "missed finish"
+      val objectTypes =
+	 Vector.map
+	 (QuickSort.sortVector
+	  (Vector.concat [ObjectType.basic,
+			  Vector.fromList (!objectTypes)],
+	   fn ((pt, _), (pt', _)) =>
+	   PointerTycon.<= (pt, pt')),
+	  #2)
       val _ =
-	 Vector.foreach
-	 (datatypes, fn Datatype.T {tycon, cons} =>
-	  let
-	     val (noArgs, haveArgs) = splitCons cons
-	  in
-	     case tyconRep tycon of
-		TyconRep.Prim t =>
-		   (case (noArgs, haveArgs) of
-		       ([], []) => ()
-		     | ([con], []) => setConRep (con, ConRep.Void)
-		     | ([], [{con, args}]) => direct (con, args, t)
-		     | _ => Error.bug ("strange TyconRep.Prim for "
-				       ^ Layout.toString (Tycon.layout tycon)))
-	      | TyconRep.Enum _ =>
-		   if Tycon.equals (tycon, Tycon.bool)
-		      then (setConRep (Con.falsee, ConRep.Int 0)
-			    ; setConRep (Con.truee, ConRep.Int 1))
-		   else List.foreachi (noArgs, fn (i, c) =>
-				       setConRep (c, ConRep.Int i))
-	      | TyconRep.EnumDirect _ =>
-		   (enum noArgs
-		    ; (case haveArgs of
-			  [{con, args}] => direct (con, args, Mtype.pointer)
-			| _ => Error.bug "strange haveArgs for EnumDirect"))
-	      | TyconRep.EnumIndirect _ =>
-		   (enum noArgs
-		    ; List.foreach (haveArgs, fn {con, ...} =>
-				    setConRep (con, ConRep.Tuple)))
-	      | TyconRep.EnumIndirectTag _ => (enum noArgs; indirectTag haveArgs)
-	      | TyconRep.IndirectTag _ => indirectTag haveArgs
-	      | TyconRep.Void =>
-		   (case (noArgs, haveArgs) of
-		       ([], []) => ()
-		     | ([con], []) => setConRep (con, ConRep.Void)
-		     | _ => Error.bug "strange TyconRep.Void")
-	  end)
+	 Control.diagnostics
+	 (fn display =>
+	  (display (Layout.str "Representations:")
+	   ; (Vector.foreach
+	      (datatypes, fn S.Datatype.T {tycon, cons} =>
+	       let
+		  open Layout
+	       in
+		  display (seq [Tycon.layout tycon,
+				str " ",
+				TyconRep.layout (tyconRep tycon)])
+		  ; display (indent
+			     (Vector.layout (fn {con, ...} =>
+					     record
+					     [("con", Con.layout con),
+					      ("rep",
+					       ConRep.layout (conRep con))])
+			      cons,
+			      2))
+	       end))))
    in
-      {tyconRep = tyconRep,
-       conRep = conRep,
-       toMtype = toMtype}
+      {conRep = conRep,
+       objectTypes = objectTypes,
+       refRep = refRep,
+       toRtype = toRtype,
+       tupleRep = tupleRep,
+       tyconRep = tyconRep}
    end
 
 end



1.7       +33 -23    mlton/mlton/backend/representation.sig

Index: representation.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- representation.sig	10 Apr 2002 07:02:19 -0000	1.6
+++ representation.sig	7 Dec 2002 02:21:52 -0000	1.7
@@ -10,7 +10,7 @@
 signature REPRESENTATION_STRUCTS = 
    sig
       structure Ssa: SSA
-      structure Mtype: MTYPE
+      structure Rssa: RSSA
    end
 
 signature REPRESENTATION = 
@@ -24,62 +24,72 @@
 	      * variant, and hence constructor requires no additional
 	      * representation.
 	      *) 
-	       Prim of Mtype.t
+	       Direct
 	     (* All cons are non-value-carrying and are represented as ints. *)
-	     | Enum of {numEnum: int}
+	     | Enum
 	     (* All cons except for one are non-value-carrying and are
 	      * represented as ints that are nonzero mod 4.  The value carrying
 	      * con is represented transparently, i.e. the value is known to be a
 	      * pointer and is left as such.
 	      *)
-	     | EnumDirect of {numEnum: int}
+	     | EnumDirect
 	     (* All cons except for one are non-value-carrying and are
 	      * represented as ints that are nonzero mod 4.  The value carrying
 	      * con is represented by boxing its arg.
 	      *)
-	     | EnumIndirect of {numEnum: int}
+	     | EnumIndirect
 	     (* Non-value-carrying and are represented as ints that are nonzero
 	      * mod 4.  Value carrying cons are represented by boxing the args
 	      * and adding an integer tag.
 	      *)
-	     | EnumIndirectTag of {numEnum: int,
-				   numTag: int}
+	     | EnumIndirectTag
 	     (* All cons are value carrying and are represented by boxing the
 	      * args and adding an integer tag.
 	      *)
-	     | IndirectTag of {numTag: int}
+	     | IndirectTag
 	     | Void
+	 end
+
+      structure TupleRep:
+	 sig
+	    datatype t = T of {offsets: {offset: int,
+					 ty: Rssa.Type.t} option vector,
+			       size: int,
+			       ty: Rssa.Type.t,
+			       tycon: Rssa.PointerTycon.t}
 
-	    val equals: t * t -> bool
 	    val layout: t -> Layout.t
-	    val toMtype: t -> Mtype.t option
+	    val tycon: t -> Rssa.PointerTycon.t
 	 end
 
       (* How a constructor variant of a datatype is represented. *)
       structure ConRep:
 	 sig
 	    datatype t =
-	       (* need no representation *)
-	       Void
-	     (* an integer *)
-	     | Int of int
-	     (* an integer, but of Pointer type *)
-	     | IntCast of int
+	     (* an integer representing a variant in a datatype *)
+	       IntAsTy of {int: int,
+			   ty: Rssa.Type.t}
+	     (* box the arg(s) and add the integer tag as the first word *)
+	     | TagTuple of {rep: TupleRep.t,
+			    tag: int}
 	     (* just keep the value itself *)
-	     | Transparent of Mtype.t
+	     | Transparent of Rssa.Type.t
 	     (* box the arg(s) *)
-	     | Tuple
-	     (* box the arg(s) and add the integer tag as the first word *)
-	     | TagTuple of int
+	     | Tuple of TupleRep.t
+	     (* need no representation *)
+	     | Void
 
 	    val layout: t -> Layout.t
 	 end
-      
+
       val compute:
 	 Ssa.Program.t
 	 -> {
-	     tyconRep: Ssa.Tycon.t -> TyconRep.t,
 	     conRep: Ssa.Con.t -> ConRep.t,
-	     toMtype: Ssa.Type.t -> Mtype.t option
+	     objectTypes: Rssa.ObjectType.t vector,
+	     refRep: Ssa.Type.t -> TupleRep.t,
+	     toRtype: Ssa.Type.t -> Rssa.Type.t option,
+	     tupleRep: Ssa.Type.t -> TupleRep.t,
+	     tyconRep: Ssa.Tycon.t -> TyconRep.t
 	    }
    end



1.20      +384 -249  mlton/mlton/backend/rssa.fun

Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- rssa.fun	24 Nov 2002 01:19:43 -0000	1.19
+++ rssa.fun	7 Dec 2002 02:21:52 -0000	1.20
@@ -19,70 +19,32 @@
 structure Operand =
    struct
       datatype t =
-	 ArrayHeader of {numBytesNonPointers: int,
-			 numPointers: int}
-       | ArrayOffset of {base: Var.t,
-			 index: Var.t,
+	 ArrayOffset of {base: t,
+			 index: t,
 			 ty: Type.t}
-       | CastInt of t
-       | CastWord of t
+       | Cast of t * Type.t
        | Const of Const.t
        | EnsuresBytesFree
        | File
        | GCState
        | Line
-       | Offset of {base: Var.t,
-		    bytes: int,
+       | Offset of {base: t,
+		    offset: int,
 		    ty: Type.t}
-       | Pointer of int
+       | PointerTycon of PointerTycon.t
        | Runtime of GCField.t
+       | SmallIntInf of word
        | 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 = int (if b then 1 else 0)
+      fun bool b = Cast (int (if b then 1 else 0), Type.bool)
 	 
-      val rec toString =
-	 fn ArrayHeader {numBytesNonPointers, numPointers} =>
-	       concat ["AH (",
-		       Int.toString numBytesNonPointers,
-		       ", ",
-		       Int.toString numPointers,
-		       ")"]
-	  | ArrayOffset {base, index, ty} =>
-	       concat ["X", Type.name ty, 
-		       "(", Var.toString base, ",", Var.toString index, ")"]
-	  | CastInt z => concat ["CastInt ", toString z]
-	  | CastWord z => concat ["CastWord ", toString z]
-	  | Const c => Const.toString c
-	  | EnsuresBytesFree => "<EnsuresBytesFree>"
-	  | File => "<File>"
-	  | GCState => "<GCState>"
-	  | Line => "<Line>"
-	  | Offset {base, bytes, ty} =>
-	       concat ["O", Type.name ty,
-		       "(", Var.toString base, ",", Int.toString bytes, ")"]
-	  | Pointer n => concat ["IntAsPointer (", Int.toString n, ")"]
-	  | Runtime r => GCField.toString r
-	  | Var {var, ...} => Var.toString var
-
-      val layout: t -> Layout.t = Layout.str o toString
-
-      val rec isLocation =
-	 fn ArrayOffset _ => true
-	  | CastWord z => isLocation z
-	  | Offset _ => true
-	  | Runtime _ => true
-	  | Var _ => true
-	  | _ => false
-
       val ty =
-	 fn ArrayHeader _ => Type.word
-	  | ArrayOffset {ty, ...} => ty
-	  | CastInt _ => Type.int
-	  | CastWord _ => Type.word
+	 fn ArrayOffset {ty, ...} => ty
+	  | Cast (_, ty) => ty
 	  | Const c =>
 	       let
 		  datatype z = datatype Const.Node.t
@@ -90,35 +52,83 @@
 		  case Const.node c of
 		     Char _ => Type.char
 		   | Int _ => Type.int
-		   | IntInf _ => Type.pointer
-		   | Real _ => Type.double
-		   | String _ => Type.pointer
+		   | 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.uint
+			      then Type.word
 			   else if Const.Type.equals (ty, Const.Type.word8)
 				   then Type.char
 				else Error.bug "strange word"
 			end
 	       end
 	  | EnsuresBytesFree => Type.word
-	  | File => Type.pointer
-	  | GCState => Type.pointer
+	  | File => Type.cpointer
+	  | GCState => Type.cpointer
 	  | Line => Type.int
 	  | Offset {ty, ...} => ty
-	  | Pointer _ => Type.pointer
-	  | Runtime z => GCField.ty z
+	  | PointerTycon _ => Type.word
+	  | Runtime z => Type.fromRuntime (GCField.ty z)
+	  | SmallIntInf _ => Type.IntInf
 	  | Var {ty, ...} => ty
 
+      fun layout (z: t): Layout.t =
+	 let
+	    open Layout 
+	    fun constrain (ty: Type.t): Layout.t =
+	       if !Control.showTypes
+		  then seq [str ": ", Type.layout ty]
+	       else empty
+	 in
+	    case z of
+	       ArrayOffset {base, index, ty} =>
+		  seq [str (concat ["X", Type.name ty, " "]),
+		       tuple [layout base, layout index],
+		       constrain ty]
+	     | Cast (z, ty) =>
+		  seq [str "Cast ", tuple [layout z, Type.layout ty]]
+	     | Const c => Const.layout c
+	     | EnsuresBytesFree => str "<EnsuresBytesFree>"
+	     | File => str "<File>"
+	     | GCState => str "<GCState>"
+	     | Line => str "<Line>"
+	     | Offset {base, offset, ty} =>
+		  seq [str (concat ["O", Type.name ty, " "]),
+		       tuple [layout base, Int.layout offset],
+		       constrain ty]
+	     | PointerTycon pt => PointerTycon.layout pt
+	     | Runtime r => GCField.layout r
+	     | SmallIntInf w => seq [str "SmallIntInf ", paren (Word.layout w)]
+	     | Var {var, ty} => seq [Var.layout var, constrain ty]
+	 end
+
+      val toString = Layout.toString o layout
+
+      fun cast (z, t) =
+	 if Type.equals (t, ty z)
+	    then z
+	 else Cast (z, t)
+
+      val cast = Trace.trace2 ("Operand.cast", layout, Type.layout, layout) cast
+	 
+      val rec isLocation =
+	 fn ArrayOffset _ => true
+	  | Cast (z, _) => isLocation z
+	  | Offset _ => true
+	  | Runtime _ => true
+	  | Var _ => true
+	  | _ => false
+
       fun 'a foldVars (z: t, a: 'a, f: Var.t * 'a -> 'a): 'a =
 	 case z of
-	    ArrayOffset {base, index, ...} => f (index, f (base, a))
-	  | CastInt z => foldVars (z, a, f)
-	  | CastWord z => foldVars (z, a, f)
-	  | Offset {base, ...} => f (base, a)
+	    ArrayOffset {base, index, ...} =>
+	       foldVars (index, foldVars (base, a, f), f)
+	  | Cast (z, _) => foldVars (z, a, f)
+	  | Offset {base, ...} => foldVars (base, a, f)
 	  | Var {var, ...} => f (var, a)
 	  | _ => a
 
@@ -138,6 +148,9 @@
 	  | _ => big z
    end
 
+structure Switch = Switch (open S
+			   structure Use = Operand)
+
 structure Statement =
    struct
       datatype t =
@@ -147,10 +160,11 @@
        | Move of {dst: Operand.t,
 		  src: Operand.t}
        | Object of {dst: Var.t,
-		    numPointers: int,
-		    numWordsNonPointers: int,
+		    size: int,
 		    stores: {offset: int,
-			     value: Operand.t} vector}
+			     value: Operand.t} vector,
+		    ty: Type.t,
+		    tycon: PointerTycon.t}
        | PrimApp of {args: Operand.t vector,
 		     dst: (Var.t * Type.t) option,
 		     prim: Prim.t}
@@ -173,8 +187,8 @@
 	       Bind {oper, var, ...} =>
 		  def (var, Operand.ty oper, useOperand (oper, a))
 	     | Move {dst, src} => useOperand (src, useOperand (dst, a))
-	     | Object {dst, stores, ...} =>
-		  Vector.fold (stores, def (dst, Type.pointer, a),
+	     | Object {dst, stores, ty, ...} =>
+		  Vector.fold (stores, def (dst, ty, a),
 			       fn ({value, ...}, a) => useOperand (value, a))
 	     | PrimApp {dst, args, ...} =>
 		  Vector.fold (args,
@@ -205,26 +219,42 @@
       val layout =
 	 let
 	    open Layout
+	    fun constrain ty =
+	       if !Control.showTypes
+		  then seq [str ": ", Type.layout ty]
+	       else empty
 	 in
 	    fn Bind {oper, var, ...} =>
-		  seq [Var.layout var, str " = ", Operand.layout oper]
+		  seq [Var.layout var, constrain (Operand.ty oper),
+		       str " = ", Operand.layout oper]
 	     | Move {dst, src} =>
-		  seq [Operand.layout dst, str " = ", Operand.layout src]
-	     | Object {dst, numPointers, numWordsNonPointers, stores, ...} =>
-		  seq [Var.layout dst, str " = Object ",
-		       tuple [Int.layout numWordsNonPointers,
-			      Int.layout numPointers],
-		       str " ",
-		       Vector.layout (fn {offset, value} =>
-				      record [("offset", Int.layout offset),
-					      ("value", Operand.layout value)])
-		       stores]
+		  mayAlign [Operand.layout dst,
+			    seq [str " = ", Operand.layout src]]
+	     | Object {dst, size, stores, ty, tycon} =>
+		  mayAlign
+		  [seq [Var.layout dst, constrain ty],
+		   seq [str " = Object ",
+			record
+			[("size", Int.layout size),
+			 ("tycon", PointerTycon.layout tycon),
+			 ("stores",
+			  Vector.layout
+			  (fn {offset, value} =>
+			   record [("offset", Int.layout offset),
+				   ("value", Operand.layout value)])
+			  stores)]]]
 	     | PrimApp {dst, prim, args, ...} =>
-		  seq [(case dst of
-			   NONE => empty
-			 | SOME (x, _) => seq [Var.layout x, str " = "]),
-		       Prim.layout prim, str " ",
-		       Vector.layout Operand.layout args]
+		  let
+		     val rest =
+			seq [Prim.layout prim, str " ",
+			     Vector.layout Operand.layout args]
+		  in
+		     case dst of
+			NONE => rest
+		      | SOME (x, t) =>
+			   mayAlign [seq [Var.layout x, constrain t],
+				     seq [str " = ", rest]]
+		  end
 	     | SetExnStackLocal => str "SetExnStackLocal"
 	     | SetExnStackSlot => str "SetExnStackSlot "
 	     | SetHandler l => seq [str "SetHandler ", Label.layout l]
@@ -254,12 +284,7 @@
 		  args: Operand.t vector}
        | Raise of Operand.t vector
        | Return of Operand.t vector
-       | Switch of {cases: Cases.t,
-		    default: Label.t option,
-		    test: Operand.t}
-       | SwitchIP of {int: Label.t,
-		      pointer: Label.t,
-		      test: Operand.t}
+       | Switch of Switch.t
 
       fun layout t =
 	 let
@@ -305,17 +330,9 @@
 	     | Goto {dst, args} =>
 		  seq [Label.layout dst, str " ",
 		       Vector.layout Operand.layout args]
-	     | Raise xs => seq [str "Raise", Vector.layout Operand.layout xs]
+	     | Raise xs => seq [str "Raise ", Vector.layout Operand.layout xs]
 	     | Return xs => seq [str "Return ", Vector.layout Operand.layout xs]
-	     | Switch {test, cases, default} =>
-		  seq [str "Switch ",
-		       tuple [Operand.layout test,
-			      Cases.layout cases,
-			      Option.layout Label.layout default]]
-	     | SwitchIP {test, int, pointer} =>
-		  seq [str "SwitchIP ", tuple [Operand.layout test,
-					       Label.layout int,
-					       Label.layout pointer]]
+	     | Switch s => Switch.layout s
 	 end
 
       val bug =
@@ -325,9 +342,10 @@
 		func = CFunction.bug,
 		return = NONE}
 
-      fun 'a foldDefLabelUse (t, a: 'a, {def: Var.t * Type.t * 'a -> 'a,
-					 label: Label.t * 'a -> 'a,
-					 use: Var.t * 'a -> 'a}): 'a =
+      fun 'a foldDefLabelUse (t, a: 'a,
+			      z as {def: Var.t * Type.t * 'a -> 'a,
+				    label: Label.t * 'a -> 'a,
+				    use: Var.t * 'a -> 'a}): 'a =
 	 let
 	    fun useVars (xs: Var.t vector, a) =
 	       Vector.fold (xs, a, use)
@@ -355,16 +373,8 @@
 	     | Goto {args, dst, ...} => label (dst, useOperands (args, a))
 	     | Raise zs => useOperands (zs, a)
 	     | Return zs => useOperands (zs, a)
-	     | Switch {cases, default, test, ...} =>
-		  let
-		     val a = useOperand (test, a)
-		     val a = Option.fold (default, a, label)
-		     val a = Cases.fold (cases, a, label)
-		  in
-		     a
-		  end
-	     | SwitchIP {int, pointer, test, ...} =>
-		  label (int, label (pointer, useOperand (test, a)))
+	     | Switch s => Switch.foldLabelUse (s, a, {label = label,
+						       use = useOperand})
 	 end
 
       fun foreachDefLabelUse (t, {def, label, use}) =
@@ -394,10 +404,17 @@
       fun clear (t: t): unit =
 	 foreachDef (t, Var.clear o #1)
 
-      fun iff (test, {falsee, truee}) =
-	 Switch {cases = Cases.Int [(0, falsee), (1, truee)],
-		 default = NONE,
-		 test = test}
+      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})
    end
 
 structure Kind =
@@ -424,6 +441,18 @@
 	 end
    end
 
+local
+   open Layout
+in
+   fun layoutFormals (xts: (Var.t * Type.t) vector) =
+      Vector.layout (fn (x, t) =>
+		    seq [Var.layout x,
+			 if !Control.showTypes
+			    then seq [str ": ", Type.layout t]
+			 else empty])
+      xts
+end
+
 structure Block =
    struct
       datatype t =
@@ -520,6 +549,8 @@
       datatype t = T of {args: (Var.t * Type.t) vector,
 			 blocks: Block.t vector,
 			 name: Func.t,
+			 raises: Type.t vector option,
+			 returns: Type.t vector option,
 			 start: Label.t}
 
       local
@@ -542,18 +573,26 @@
       fun hasPrim (T {blocks, ...}, pred) =
 	 Vector.exists (blocks, fn b => Block.hasPrim (b, pred))
 
-      fun layout (T {args, blocks, name, start}): Layout.t =
+      fun layoutHeader (T {args, name, start, ...}): Layout.t =
 	 let
 	    open Layout
 	 in
-	    align
-	    [seq [Func.layout name,
-		  Vector.layout (Layout.tuple2 (Var.layout, Type.layout)) args,
-		  str " = ",
-		  Label.layout start,
-		  str " ()"],
-	     indent (align (Vector.toListMap (blocks, Block.layout)),
-		     2)]
+	    seq [str "fun ", Func.layout name,
+		 str " ", layoutFormals args,
+		 str " = ", Label.layout start, str " ()"]
+	 end
+
+      fun layouts (f as T {blocks, ...}, output) =
+	 (output (layoutHeader f)
+	  ; Vector.foreach (blocks, fn b =>
+			    output (Layout.indent (Block.layout b, 2))))
+
+      fun layout (f as T {blocks, ...}) =
+	 let
+	    open Layout
+	 in
+	    align [layoutHeader f,
+		   indent (align (Vector.toListMap (blocks, Block.layout)), 2)]
 	 end
 
       fun dfs (T {blocks, start, ...}, v) =
@@ -630,9 +669,11 @@
 
 structure Program =
    struct
-      datatype t = T of {functions: Function.t list,
-			 main: Function.t,
-			 profileAllocLabels: string vector}
+      datatype t =
+	 T of {functions: Function.t list,
+	       main: Function.t,
+	       objectTypes: ObjectType.t vector,
+	       profileAllocLabels: string vector}
 
       fun clear (T {functions, main, ...}) =
 	 (List.foreach (functions, Function.clear)
@@ -646,17 +687,23 @@
 	 end
 
       fun handlesSignals p =
-	 hasPrim (p, fn p => Prim.name p = Prim.Name.MLton_installSignalHandler)
+	 hasPrim (p, fn p =>
+		  Prim.name p = Prim.Name.MLton_installSignalHandler)
 	 
-      fun layouts (T {functions, main, ...}, output': Layout.t -> unit): unit =
+      fun layouts (T {functions, main, objectTypes, ...},
+		   output': Layout.t -> unit): unit =
 	 let
 	    open Layout
 	    val output = output'
 	 in
-	    output (str "Main:")
-	    ; output (Function.layout main)
-	    ; output (str "\n\nFunctions:")
-	    ; List.foreach (functions, output o Function.layout)
+	    output (str "\nObjectTypes:")
+	    ; Vector.foreachi (objectTypes, fn (i, ty) =>
+			       output (seq [str "pt_", Int.layout i,
+					    str " = ", ObjectType.layout ty]))
+	    ; output (str "\nMain:")
+	    ; Function.layouts (main, output)
+	    ; output (str "\nFunctions:")
+	    ; List.foreach (functions, fn f => Function.layouts (f, output))
 	 end
 	    
       fun checkScopes (program as T {functions, main, ...}): unit =
@@ -753,8 +800,16 @@
 	 in ()
 	 end
 
-      fun typeCheck (p as T {functions, main, ...}) =
+      fun typeCheck (p as T {functions, main, objectTypes, ...}) =
 	 let
+	    val _ =
+	       Vector.foreach
+	       (objectTypes, fn ty =>
+		Err.check ("objectType",
+			   fn () => ObjectType.isOk ty,
+			   fn () => ObjectType.layout ty))
+	    fun tyconTy (pt: PointerTycon.t): ObjectType.t =
+	       Vector.sub (objectTypes, PointerTycon.index pt)
 	    val _ = checkScopes p
 	    val {get = labelBlock: Label.t -> Block.t,
 		 set = setLabelBlock, ...} =
@@ -775,29 +830,89 @@
 		   datatype z = datatype Operand.t
 		   fun ok () =
 		      case x of
-			 ArrayHeader {numBytesNonPointers = nbnp, numPointers = np} =>
-			    nbnp >= 0 andalso np >= 0
-			    
-		       | ArrayOffset {base, index, ty} =>
-			    Type.equals (varType base, Type.pointer)
-			    andalso Type.equals (varType index, Type.int)
-		       | CastInt z => Type.equals (Operand.ty z, Type.pointer)
-		       | CastWord z =>
-			    Type.equals (Operand.ty z, Type.pointer)
-			    orelse Type.equals (Operand.ty z, Type.int)
+			 ArrayOffset z => arrayOffsetIsOk z
+		       | Cast (z, ty) =>
+			    (checkOperand z
+			    ; (castIsOk
+			       {from = Operand.ty z,
+				fromInt = (case z of
+					      Const c =>
+						 (case Const.node c of
+						     Const.Node.Int n => SOME n
+						   | _ => NONE)
+					    | _ => NONE),
+				to = ty,
+				tyconTy = tyconTy}))
 		       | Const _ => true
 		       | EnsuresBytesFree => true
 		       | File => true
 		       | GCState => true
 		       | Line => true
-		       | Offset {base, ...} =>
-			    Type.equals (varType base, Type.pointer)
-		       | Pointer n => 0 < Int.rem (n, Runtime.wordSize)
+		       | Offset z => offsetIsOk z
+		       | PointerTycon _ => true
 		       | Runtime _ => true
+		       | SmallIntInf _ => true
 		       | Var {ty, var} => Type.equals (ty, varType var)
 		in
 		   Err.check ("operand", ok, fn () => Operand.layout x)
 		end
+	    and arrayOffsetIsOk {base, index, ty} =
+	       let
+		  val _ = checkOperand base
+		  val _ = checkOperand index
+	       in
+		  Type.equals (Operand.ty index, Type.int)
+		  andalso
+		  case Operand.ty base of
+		     Type.CPointer => true (* needed for card marking *)
+		   | Type.EnumPointers {enum, pointers} =>
+			0 = Vector.length enum
+			andalso
+			Vector.forall
+			(pointers, fn p =>
+			 case tyconTy p of
+			    ObjectType.Array
+			    (MemChunk.T {components, ...}) =>
+			       1 = Vector.length components
+			       andalso
+			       let
+				  val {offset, ty = ty', ...} =
+				     Vector.sub (components, 0)
+			       in
+				  offset = 0
+				  andalso Type.equals (ty, ty')
+			       end
+			  | _ => false)
+		   | _ => false
+	       end
+	    and offsetIsOk {base, offset, ty} =
+	       let
+		  val _ = checkOperand base
+		  fun memChunkIsOk (MemChunk.T {components, ...}) =
+		     case Vector.peek (components, fn {offset = offset', ...} =>
+				       offset = offset') of
+			NONE => false
+		      | SOME {ty = ty', ...} => Type.equals (ty, ty')
+	       in
+		  case Operand.ty base of
+		     Type.EnumPointers {enum, pointers} =>
+			0 = Vector.length enum
+			andalso
+			((* Vector_fromArray header update. *)
+			 (offset = Runtime.headerOffset
+			  andalso Type.equals (ty, Type.word))
+			 orelse
+			 Vector.forall
+			 (pointers, fn p =>
+			  case tyconTy p of
+			     ObjectType.Normal m => memChunkIsOk m
+			   | _ => false))
+		   | Type.MemChunk m => memChunkIsOk m
+		   | _ => false
+	       end
+	    val checkOperand =
+	       Trace.trace ("checkOperand", Operand.layout, Unit.layout)
+	       checkOperand
 	    fun checkOperands v = Vector.foreach (v, checkOperand)
 	    fun check' (x, name, isOk, layout) =
 	       Err.check (name, fn () => isOk x, fn () => layout x)
@@ -817,11 +932,17 @@
 			 ; checkOperand src
 			 ; (Type.equals (Operand.ty dst, Operand.ty src)
 			    andalso Operand.isLocation dst))
-		   | Object {dst, numPointers, numWordsNonPointers, stores} =>
-			 (Vector.foreach (stores, fn {offset, value} =>
-					  checkOperand value)
-			  ; (numPointers >= 0
-			     andalso numWordsNonPointers >= 0))
+		   | Object {dst, size, stores, tycon, ...} =>
+			(Vector.foreach (stores, checkOperand o # value)
+			 ; (case tyconTy tycon of
+			       ObjectType.Normal mc =>
+				  MemChunk.isValidInit
+				  (mc, 
+				   Vector.map
+				   (stores, fn {offset, value} =>
+				    {offset = offset,
+				     ty = Operand.ty value}))
+			     | _ => false))
 		   | PrimApp {args, ...} =>
 			(Vector.foreach (args, checkOperand)
 			 ; true)
@@ -833,111 +954,20 @@
 			  | _ => false)
 		   | SetSlotExnStack => true
 	       end
-	    fun goto {dst, args} =
+	    fun goto {args: Type.t vector,
+		      dst: Label.t}: bool =
 	       let
 		  val Block.T {args = formals, kind, ...} = labelBlock dst
 	       in
-		  Vector.equals (args, formals, fn (z, (_, t)) =>
-				 Type.equals (t, Operand.ty z))
+		  Vector.equals (args, formals, fn (t, (_, t')) =>
+				 Type.equals (t, t'))
 		  andalso (case kind of
 			      Kind.Jump => true
 			    | _ => false)
 	       end
 	    fun labelIsNullaryJump l = goto {dst = l, args = Vector.new0 ()}
-	    fun transferOk (t: Transfer.t): bool =
-	       let
-		  datatype z = datatype Transfer.t
-	       in
-		  case t of
-		     Arith {args, dst, overflow, prim, success, ty} =>
-			Prim.mayOverflow prim
-			andalso labelIsNullaryJump overflow
-			andalso labelIsNullaryJump success
-			andalso
-			Vector.forall (args, fn x =>
-				       Type.equals (ty, Operand.ty x))
-		   | CCall {args, func, return} =>
-			let
-			   val _ = checkOperands args
-			in
-			   CFunction.isOk func
-			   andalso
-			   case return of
-			      NONE => true
-			    | SOME l =>
-				 case labelKind l of
-				    Kind.CReturn {func = f} =>
-				       CFunction.equals (func, f)
-				  | _ => false
-			   end
-		   | Call {args, func, return} =>
-			let
-			   val Function.T {args = formals, ...} = funcInfo func
-			in
-			   Vector.equals (args, formals, fn (z, (_, t)) =>
-					  Type.equals (t, Operand.ty z))
-			   andalso
-			   (case return of
-			       Return.Dead => true
-			     | Return.HandleOnly => true
-			     | Return.NonTail {cont, handler = h} =>
-				  (case labelKind cont of
-				      Kind.Cont {handler = h'} =>
-					 (case (h, h') of
-					     (Handler.CallerHandler, NONE) =>
-						true
-					   | (Handler.None, NONE) => true
-					   | (Handler.Handle l, SOME l') =>
-						Label.equals (l, l')
-					   | _ => false)
-				    | _ => false)
-			     | Return.Tail => true)
-			end
-		   | Goto z => goto z
-		   | Raise _ => true
-		   | Return _ => true
-		   | Switch {cases, default, test} =>
-			(Cases.forall (cases, labelIsNullaryJump)
-			 andalso Option.forall (default, labelIsNullaryJump)
-			 andalso (Type.equals
-				  (Operand.ty test,
-				   case cases of
-				      Cases.Char _ => Type.char
-				    | Cases.Int _ => Type.int
-				    | Cases.Word _ => Type.uint)))
-		   | SwitchIP {int, pointer, test} =>
-			(checkOperand test
-			 ; (labelIsNullaryJump pointer
-			    andalso labelIsNullaryJump int
-			    andalso Type.equals (Type.pointer,
-						 Operand.ty test)))
-	       end
-	    fun blockOk (Block.T {args, kind, label, 
-				  statements, transfer, ...}): bool =
-	       let
-		  fun kindOk (k: Kind.t): bool =
-		     let
-			datatype z = datatype Kind.t
-			val _ =
-			   case k of
-			      Cont _ => true
-			    | CReturn _ => true
-			    | Handler => true
-			    | Jump => true
-		     in
-			true
-		     end
-		  val _ = check' (kind, "kind", kindOk, Kind.layout)
-		  val _ =
-		     Vector.foreach
-		     (statements, fn s =>
-		      check' (s, "statement", statementOk, Statement.layout))
-		  val _ = check' (transfer, "transfer", transferOk,
-				  Transfer.layout)
-	       in
-		  true
-	       end
-	    fun checkFunction (Function.T {args, blocks, start, ...}) =
+	    fun checkFunction (Function.T {args, blocks, raises, returns, start,
+					   ...}) =
 	       let
 		  val _ = Vector.foreach (args, setVarType)
 		  val _ =
@@ -951,9 +981,114 @@
 					 (s, setVarType))
 		       ; Transfer.foreachDef (transfer, setVarType)))
 		  val _ = labelIsNullaryJump start
+		  fun transferOk (t: Transfer.t): bool =
+		     let
+			datatype z = datatype Transfer.t
+		     in
+			case t of
+			   Arith {args, dst, overflow, prim, success, ty} =>
+			      let
+				 val _ = checkOperands args
+			      in
+				 Prim.mayOverflow prim
+				 andalso labelIsNullaryJump overflow
+				 andalso labelIsNullaryJump success
+				 andalso
+				 Vector.forall (args, fn x =>
+						Type.equals (ty, Operand.ty x))
+			      end
+			 | CCall {args, func, return} =>
+			      let
+				 val _ = checkOperands args
+			      in
+				 CFunction.isOk func
+				 andalso
+				 case return of
+				    NONE => true
+				  | SOME l =>
+				       case labelKind l of
+					  Kind.CReturn {func = f} =>
+					     CFunction.equals (func, f)
+					| _ => false
+			      end
+			 | Call {args, func, return} =>
+			      let
+				 val _ = checkOperands args
+				 val Function.T {args = formals, ...} = funcInfo func
+			      in
+				 Vector.equals (args, formals, fn (z, (_, t)) =>
+						Type.equals (t, Operand.ty z))
+				 andalso
+				 (case return of
+				     Return.Dead => true
+				   | Return.HandleOnly => true
+				   | Return.NonTail {cont, handler = h} =>
+					(case labelKind cont of
+					    Kind.Cont {handler = h'} =>
+					       (case (h, h') of
+						   (Handler.CallerHandler, NONE) =>
+						      true
+						 | (Handler.None, NONE) => true
+						 | (Handler.Handle l, SOME l') =>
+						      Label.equals (l, l')
+						 | _ => false)
+					  | _ => false)
+				   | Return.Tail => true)
+			      end
+			 | Goto {args, dst} =>
+			      (checkOperands args
+			       ; goto {args = Vector.map (args, Operand.ty),
+				       dst = dst})
+			 | Raise zs =>
+			      (checkOperands zs
+			       ; (case raises of
+				     NONE => false
+				   | SOME ts =>
+					Vector.equals
+					(zs, ts, fn (z, t) =>
+					 Type.equals (t, Operand.ty z))))
+			 | Return zs =>
+			      (checkOperands zs
+			       ; (case returns of
+				     NONE => false
+				   | SOME ts =>
+					Vector.equals
+					(zs, ts, fn (z, t) =>
+					 Type.equals (t, Operand.ty z))))
+			 | Switch s =>
+			      Switch.isOk (s, {labelIsOk = labelIsNullaryJump})
+		     end
+		  fun blockOk (Block.T {args, kind, label, 
+					statements, transfer, ...}): bool =
+		     let
+			fun kindOk (k: Kind.t): bool =
+			   let
+			      datatype z = datatype Kind.t
+			      val _ =
+				 case k of
+				    Cont _ => true
+				  | CReturn _ => true
+				  | Handler => true
+				  | Jump => true
+			   in
+			      true
+			   end
+			val _ = check' (kind, "kind", kindOk, Kind.layout)
+			val _ =
+			   Vector.foreach
+			   (statements, fn s =>
+			    check' (s, "statement", statementOk,
+				    Statement.layout))
+			val _ = check' (transfer, "transfer", transferOk,
+					Transfer.layout)
+		     in
+			true
+		     end
+
 		  val _ = 
 		     Vector.foreach
-		     (blocks, fn b => check' (b, "block", blockOk, Block.layout))
+		     (blocks, fn b =>
+		      check' (b, "block", blockOk, Block.layout))
 	       in
 		  ()
 	       end



1.17      +31 -32    mlton/mlton/backend/rssa.sig

Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- rssa.sig	2 Nov 2002 03:37:38 -0000	1.16
+++ rssa.sig	7 Dec 2002 02:21:52 -0000	1.17
@@ -10,11 +10,10 @@
    
 signature RSSA_STRUCTS = 
    sig
-      include ATOMS
+      include MACHINE_ATOMS
 
-      structure Cases: MACHINE_CASES 
+      structure Const: CONST
       structure Func: HASH_ID
-      structure Label: HASH_ID
       structure Handler:
 	 sig
 	    datatype t =
@@ -39,29 +38,27 @@
 	    val foldLabel: t * 'a * (Label.t * 'a -> 'a) -> 'a
 	    val foreachLabel: t * (Label.t -> unit) -> unit
 	 end
-      structure Runtime: RUNTIME
-      structure Type: MTYPE
-      sharing Label = Cases.Label
-      sharing Type = Runtime.Type
+      structure Var: VAR
    end
 
 signature RSSA = 
    sig
       include RSSA_STRUCTS
 
+      structure Switch: SWITCH
+      sharing Label = Switch.Label
+      sharing PointerTycon = Switch.PointerTycon
+      sharing Type = Switch.Type
       structure CFunction: C_FUNCTION
       sharing CFunction = Runtime.CFunction
-
+     
       structure Operand:
 	 sig
 	    datatype t =
-	       ArrayHeader of {numBytesNonPointers: int,
-			       numPointers: int}
-	     | ArrayOffset of {base: Var.t,
-			       index: Var.t,
+	       ArrayOffset of {base: t,
+			       index: t,
 			       ty: Type.t}
-	     | CastInt of t
-	     | CastWord of t
+	     | Cast of t * Type.t
 	     | Const of Const.t
 	       (* EnsuresBytesFree is a pseudo-op used by C functions (like
 		* GC_allocateArray) that take a number of bytes as an argument
@@ -73,17 +70,19 @@
 	     | File (* expand by codegen into string constant *)
 	     | GCState
 	     | Line (* expand by codegen into int constant *)
-	     | Offset of {base: Var.t,
-			  bytes: int,
+	     | Offset of {base: t,
+			  offset: int,
 			  ty: Type.t}
-	     | Pointer of int (* the int must be nonzero mod Runtime.wordSize. *)
+	     | PointerTycon of PointerTycon.t
 	     | Runtime of Runtime.GCField.t
+	     | SmallIntInf of word
 	     | Var of {var: Var.t,
 		       ty: Type.t}
 
 	    val bool: bool -> t
 	    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 layout: t -> Layout.t
@@ -91,6 +90,7 @@
 	    val ty: t -> Type.t
 	    val word: word -> t
 	 end
+      sharing Operand = Switch.Use
       
       structure Statement:
 	 sig
@@ -101,10 +101,12 @@
 	     | Move of {dst: Operand.t,
 			src: Operand.t}
 	     | Object of {dst: Var.t,
-			  numPointers: int,
-			  numWordsNonPointers: int,
+			  size: int, (* in bytes, including header *)
+			  (* The stores are in increasing order of offset. *)
 			  stores: {offset: int, (* bytes *)
-				   value: Operand.t} vector}
+				   value: Operand.t} vector,
+			  ty: Type.t,
+			  tycon: PointerTycon.t}
 	     | PrimApp of {args: Operand.t vector,
 			   dst: (Var.t * Type.t) option,
 			   prim: Prim.t}
@@ -117,7 +119,7 @@
 	     * If s defines a variable x, then return f (x, a), else return a.
 	     *)
 	    val foldDef: t * 'a * (Var.t * Type.t * 'a -> 'a) -> 'a
-	    (* forDef (s, f) = foldDef (s, (), fn (x, ()) => f x) *)
+	    (* foreachDef (s, f) = foldDef (s, (), fn (x, ()) => f x) *)
 	    val foreachDef: t * (Var.t * Type.t -> unit) -> unit
 	    val foreachDefUse: t * {def: (Var.t * Type.t) -> unit,
 				    use: Var.t -> unit} -> unit
@@ -154,12 +156,7 @@
 	      *)
 	     | Raise of Operand.t vector
 	     | Return of Operand.t vector
-	     | Switch of {cases: Cases.t,
-			  default: Label.t option, (* Must be nullary. *)
-			  test: Operand.t}
-	     | SwitchIP of {int: Label.t,
-			    pointer: Label.t,
-			    test: Operand.t}
+	     | Switch of Switch.t
 
 	    val bug: t
 	    (* foldDef (t, a, f)
@@ -173,7 +170,8 @@
 					 use: Var.t -> unit} -> unit
 	    val foreachLabel: t * (Label.t -> unit) -> unit
 	    val foreachUse: t * (Var.t -> unit) -> unit
-	    val iff: Operand.t * {falsee: Label.t, truee: Label.t} -> t
+	    val ifBool: Operand.t * {falsee: Label.t, truee: Label.t} -> t
+	    val ifInt: Operand.t * {falsee: Label.t, truee: Label.t} -> t
 	    val layout: t -> Layout.t
 	 end
 
@@ -215,6 +213,8 @@
 	    val dest: t -> {args: (Var.t * Type.t) vector,
 			    blocks: Block.t vector,
 			    name: Func.t,
+			    raises: Type.t vector option,
+			    returns: Type.t vector option,
 			    start: Label.t}
 	    (* dfs (f, v) visits the blocks in depth-first order, applying v b
 	     * for block b to yield v', then visiting b's descendents,
@@ -225,6 +225,8 @@
 	    val new: {args: (Var.t * Type.t) vector,
 		      blocks: Block.t vector,
 		      name: Func.t,
+		      raises: Type.t vector option,
+		      returns: Type.t vector option,
 		      start: Label.t} -> t
 	    val start: t -> Label.t
 	 end
@@ -233,11 +235,8 @@
 	 sig
 	    datatype t =
 	       T of {functions: Function.t list,
-		     (* main must be nullary and should not be called by other
-		      * functions. It defines global variables that are in scope
-		      * for the rest of the program.
-		      *)
 		     main: Function.t,
+		     objectTypes: ObjectType.t vector,
 		     profileAllocLabels: string vector}
 
 	    val clear: t -> unit



1.7       +6 -1      mlton/mlton/backend/runtime.fun

Index: runtime.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- runtime.fun	2 Nov 2002 03:37:39 -0000	1.6
+++ runtime.fun	7 Dec 2002 02:21:52 -0000	1.7
@@ -153,15 +153,20 @@
 val arrayLengthOffset = ~ (2 * wordSize)
 val allocTooLarge: word = 0wxFFFFFFFC
 
+val headerOffset = ~wordSize
+
 fun normalSize {numPointers, numWordsNonPointers} =
    wordSize * (numPointers + numWordsNonPointers)
 
-fun wordAlign (w: word): word =
+fun wordAlignWord (w: word): word =
    let
       open Word
    in
       andb (MLton.Word.addCheck (w, 0w3), notb 0w3)
    end
+
+fun wordAlignInt (i: int): int =
+   Word.toInt (wordAlignWord (Word.fromInt i))
    
 fun isWordAligned (n: int): bool =
    0 = Int.rem (n, wordSize)



1.16      +4 -5      mlton/mlton/backend/runtime.sig

Index: runtime.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.sig,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- runtime.sig	2 Nov 2002 03:37:39 -0000	1.15
+++ runtime.sig	7 Dec 2002 02:21:52 -0000	1.16
@@ -32,7 +32,7 @@
 	     | ProfileAllocIndex
 	     | SignalIsPending
 	     | StackBottom
-	     | StackLimit (* Must have  StackTop <= StackLimit *)
+	     | StackLimit (* Must have StackTop <= StackLimit *)
 	     | StackTop (* Points at the next available word on the stack. *)
 
 	    val layout: t -> Layout.t
@@ -60,9 +60,6 @@
 	     | Normal of {numPointers: int,
 			  numWordsNonPointers: int}
 	     | Stack
-
-	    val equals: t * t -> bool
-	    val layout: t -> Layout.t
 	 end
 
       (* All sizes are in bytes, unless they explicitly say "pointers". *)
@@ -71,6 +68,7 @@
       val arrayHeaderSize: int
       val arrayLengthOffset: int
       val array0Size: int
+      val headerOffset: int
       val headerToTypeIndex: word -> int
       val isWordAligned: int -> bool
       val intInfOverheadSize: int
@@ -84,6 +82,7 @@
 		       numWordsNonPointers: int} -> int
       val pointerSize: int
       val typeIndexToHeader: int -> word
-      val wordAlign: word -> word (* Can raise Overflow. *)
+      val wordAlignInt: int -> int (* Can raise Overflow. *)
+      val wordAlignWord: word -> word (* Can raise Overflow. *)
       val wordSize: int
    end



1.11      +10 -6     mlton/mlton/backend/signal-check.fun

Index: signal-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/signal-check.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- signal-check.fun	2 Nov 2002 03:37:39 -0000	1.10
+++ signal-check.fun	7 Dec 2002 02:21:52 -0000	1.11
@@ -21,10 +21,10 @@
       then p
    else
       let
-	 val Program.T {functions, main, profileAllocLabels} = p
+	 val Program.T {functions, main, objectTypes, profileAllocLabels} = p
 	 fun insert (f: Function.t): Function.t =
 	    let
-	       val {args, blocks, name, start} = Function.dest f
+	       val {args, blocks, name, raises, returns, start} = Function.dest f
 	       val {get = labelIndex: Label.t -> int, set = setLabelIndex,
 		    rem = remLabelIndex, ...} =
 		  Property.getSetOnce
@@ -92,14 +92,15 @@
 			     val compare =
 				Vector.new1
 				(Statement.PrimApp
-				 {args = Vector.new2 (Operand.CastInt
+				 {args = Vector.new2 (Operand.Cast
 						      (Operand.Runtime
-						       Runtime.GCField.Limit),
-						      Operand.int 0),
+						       Runtime.GCField.Limit,
+						       Type.Word),
+						      Operand.word 0w0),
 				  dst = SOME (res, Type.bool),
 				  prim = Prim.eq})
 			     val compareTransfer =
-				Transfer.iff
+				Transfer.ifBool
 				(Operand.Var {var = res, ty = Type.bool},
 				 {falsee = dontCollect,
 				  truee = collect})
@@ -163,6 +164,8 @@
 	       val f = Function.new {args = args,
 				     blocks = blocks,
 				     name = name,
+				     raises = raises,
+				     returns = returns,
 				     start = start}
 	       val _ = Function.clear f
 	    in
@@ -171,6 +174,7 @@
       in
 	 Program.T {functions = List.revMap (functions, insert),
 		    main = main,
+		    objectTypes = objectTypes,
 		    profileAllocLabels = profileAllocLabels}
       end
 



1.12      +4 -4      mlton/mlton/backend/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/sources.cm,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- sources.cm	2 Nov 2002 03:37:39 -0000	1.11
+++ sources.cm	7 Dec 2002 02:21:52 -0000	1.12
@@ -12,7 +12,6 @@
 
 functor Backend
 functor Machine
-functor Runtime
    
 is
 
@@ -38,10 +37,10 @@
 limit-check.sig
 live.fun
 live.sig
-machine-cases.fun
-machine-cases.sig
 machine.fun
 machine.sig
+machine-atoms.fun
+machine-atoms.sig
 mtype.fun
 mtype.sig
 parallel-move.fun
@@ -58,4 +57,5 @@
 signal-check.sig
 ssa-to-rssa.fun
 ssa-to-rssa.sig
-
+switch.fun
+switch.sig



1.26      +414 -394  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.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- ssa-to-rssa.fun	24 Nov 2002 01:19:43 -0000	1.25
+++ ssa-to-rssa.fun	7 Dec 2002 02:21:52 -0000	1.26
@@ -9,10 +9,14 @@
 struct
 
 open S
+open Rssa
 
 structure S = Ssa
-
-open Rssa
+local
+   open Ssa
+in
+   structure Con = Con
+end
 local
    open Runtime
 in
@@ -160,20 +164,26 @@
 datatype z = datatype Transfer.t
 
 structure ImplementHandlers = ImplementHandlers (structure Ssa = Ssa)
-structure Representation = Representation (structure Ssa = Ssa
-					   structure Mtype = Type)
-
-local open Representation
+structure Representation = Representation (structure Rssa = Rssa
+					   structure Ssa = Ssa)
+local
+   open Representation
 in
-   structure TyconRep = TyconRep
    structure ConRep = ConRep
+   structure TupleRep = TupleRep
+   structure TyconRep = TyconRep
 end
 
 fun convert (p: S.Program.t): Rssa.Program.t =
    let
       val program as S.Program.T {datatypes, globals, functions, main} =
 	 ImplementHandlers.doit p
-      val {tyconRep, conRep, toMtype = toType} = Representation.compute program
+      val {conRep, objectTypes, refRep, toRtype, tupleRep, tyconRep} =
+	 Representation.compute program
+      val conRep =
+	 Trace.trace ("conRep", Con.layout, ConRep.layout) conRep
+      fun tyconTy (pt: PointerTycon.t): ObjectType.t =
+	 Vector.sub (objectTypes, PointerTycon.index pt)
       (* varInt is set for variables that are constant integers.  It is used
        * so that we can precompute array numBytes when numElts is known.
        *)
@@ -200,140 +210,19 @@
 	 setVarInfo
       val varType = #ty o varInfo
       fun varOp (x: Var.t): Operand.t =
-	 Var {var = x, ty = valOf (toType (varType x))}
+	 Var {var = x, ty = valOf (toRtype (varType x))}
       val varOp =
-	 Trace.trace
-	 ("SsaToRssa.varOp", Var.layout, Operand.layout)
-	 varOp
+	 Trace.trace ("SsaToRssa.varOp", Var.layout, Operand.layout) varOp
       fun varOps xs = Vector.map (xs, varOp)
-      val _ =
-	 Control.diagnostics
-	 (fn display =>
-	  (display (Layout.str "Representations:")
-	   ; (Vector.foreach
-	      (datatypes, fn S.Datatype.T {tycon, cons} =>
-	       let open Layout
-	       in display (seq [Tycon.layout tycon,
-				str " ",
-				TyconRep.layout (tyconRep tycon)])
-		  ; display (indent
-			     (Vector.layout (fn {con, ...} =>
-					     seq [Con.layout con,
-						  str " ",
-						  ConRep.layout (conRep con)])
-			      cons,
-			      2))
-	       end))))
-      fun toTypes ts = Vector.map (ts, toType)
-      val labelSize = Type.size Type.label
-      val tagOffset = 0
-      fun sortTypes (initialOffset: int,
-		     tys: Type.t option vector)
-	 : {numPointers: int,
-	    numWordsNonPointers: int,
-	    offsets: {offset: int, ty: Type.t} option vector,
-	    size: int} =
-	 let
-	    val bytes = ref []
-	    val doubleWords = ref []
-	    val words = ref []
-	    val pointers = ref []
-	    val numPointers = ref 0
-	    val _ =
-	       Vector.foreachi
-	       (tys, fn (i, t) =>
-		case t of
-		   NONE => ()
-		 | SOME t =>
-		      let
-			 val r =
-			    if Type.isPointer t
-			       then (Int.inc numPointers
-				     ; pointers)
-			    else (case Type.size t of
-				     1 => bytes
-				   | 4 => words
-				   | 8 => doubleWords
-				   | _ => Error.bug "strange size")
-		      in
-			 List.push (r, (i, t))
-		      end)
-	    fun build (r, size, accum) =
-	       List.fold (!r, accum, fn ((index, ty), (res, offset)) =>
-			  ({index = index, offset = offset, ty = ty} :: res,
-			   offset + size))
-	    val (accum, offset: int) =
-	       build (bytes, 1,
-		      build (words, 4,
-			     build (doubleWords, 8, ([], initialOffset))))
-	    val offset = Type.align (Type.pointer, offset)
-	    val numWordsNonPointers =
-	       (offset - initialOffset) div Runtime.wordSize
-	    val (components, size) = build (pointers, 4, (accum, offset))
-	    val offsets =
-	       Vector.mapi
-	       (tys, fn (i, ty) =>
-		Option.map
-		(ty, fn ty =>
-		 let
-		    val {offset, ty, ...} =
-		       List.lookup (components, fn {index, ...} => i = index)
-		 in
-		    {offset = offset, ty = ty}
-		 end))
-	 in
-	    {numPointers = !numPointers,
-	     numWordsNonPointers = numWordsNonPointers,
-	     offsets = offsets,
-	     size = size}
-	 end
-      (* Compute layout for each con and associate it with the con. *)
-      local
-	 val {get, set, ...} =
-	    Property.getSetOnce (Con.plist,
-				 Property.initRaise ("con info", Con.layout))
-      in
-	 val _ =
-	    Vector.foreach
-	    (datatypes, fn S.Datatype.T {cons, ...} =>
-	     Vector.foreach (cons, fn {con, args} =>
-			     let
-				fun doit n =
-				   let
-				      val mtypes = toTypes args
-				      val info = sortTypes (n, mtypes)
-				   in
-				      set (con, {info = info,
-						 mtypes = mtypes})
-				   end
-			     in
-				case conRep con of
-				   ConRep.Tuple => doit 0
-				 | ConRep.TagTuple _ => doit 4
-				 | _ => ()
-			     end))
-	 val conInfo = get
-      end
-      (* Compute layout for each tuple type. *)
-      val {get = tupleInfo, ...} =
-	 Property.get (S.Type.plist,
-		       Property.initFun
-		       (fn t => sortTypes (0, toTypes (S.Type.detuple t))))
-      fun conSelects (variant: Var.t, con: Con.t): Operand.t vector =
-	 let
-	    val _ = Assert.assert ("conSelects", fn () =>
-				   case conRep con of
-				      ConRep.TagTuple _ => true
-				    | ConRep.Tuple => true
-				    | _ => false)
-	    val {info = {offsets, ...}, ...} = conInfo con
-	 in
-	    Vector.keepAllMap (offsets, fn off =>
-			       Option.map (off, fn {offset, ty} =>
-					   Offset {base = variant,
-						   bytes = offset,
-						   ty = ty}))
-	 end
+      fun toRtypes ts = Vector.map (ts, toRtype)
+      fun conSelects {rep = TupleRep.T {offsets, ...},
+		      variant: Operand.t}: Operand.t vector =
+	 Vector.keepAllMap
+	 (offsets, fn off =>
+	  Option.map (off, fn {offset, ty} =>
+		      Offset {base = variant,
+			      offset = offset,
+			      ty = ty}))
       val extraBlocks = ref []
       val (resetAllocTooLarge, allocTooLarge) = Block.allocTooLarge extraBlocks
       fun newBlock {args, kind, profileInfo,
@@ -351,57 +240,58 @@
 	 in
 	    l
 	 end
+      val tagOffset = 0
       fun genCase {cases: (Con.t * Label.t) vector,
 		   default: Label.t option,
 		   profileInfo,
-		   test: Var.t,
+		   test: Operand.t,
 		   testRep: TyconRep.t}: Transfer.t =
 	 let
-	    fun switch {cases: Cases.t,
-			default: Label.t option,
-			numLeft: int,
-			test: Operand.t}: Transfer.t =
+	    fun enum (test: Operand.t): Transfer.t =
 	       let
-		  datatype z = None | One of Label.t | Many
-		  val default = if numLeft = 0 then NONE else default
-		  val targets =
-		     Cases.fold
-		     (cases,
-		      case default of
-			 SOME l => One l
-		       | NONE => None,
-		      fn (l, Many) => Many
-		       | (l, One l') => if Label.equals (l, l')
-					   then One l'
-					else Many
-		       | (l, None) => One l)
-	       in		
-		  case targets of
-		     None => Error.bug "no targets"
-		   | One l => Goto {dst = l,
-				    args = Vector.new0 ()}
-		   | Many => Switch {test = test,
-				     cases = cases,
-				     default = default}
-	       end
-	    fun enum (test: Operand.t, numEnum: int): Transfer.t =
-	       let
-		  val (cases, numLeft) =
-		     Vector.fold
-		     (cases, ([], numEnum),
-		      fn ((c, j), (cases, numLeft)) =>
-		      let
-			 fun keep n = ((n, j) :: cases, numLeft - 1)
-		      in
-			 case conRep c of
-			    ConRep.Int n => keep n
-			  | ConRep.IntCast n => keep n
-			  | _ => (cases, numLeft)
-		      end)
-	       in switch {test = test,
-			  cases = Cases.Int cases,
-			  default = default,
-			  numLeft = numLeft}
+		  val cases =
+		     Vector.keepAllMap
+		     (cases, fn (c, j) =>
+		      case conRep c of
+			 ConRep.IntAsTy {int, ...} => SOME (int, j)
+		       | _ => NONE)
+		  val numEnum =
+		     case Operand.ty test of
+			Type.EnumPointers {enum, ...} => Vector.length enum
+		      | _ => Error.bug "strage enum"
+		  val default =
+		     if numEnum = Vector.length cases
+			then NONE
+		     else default
+	       in
+		  if 0 = Vector.length cases
+		     then
+			(case default of
+			    NONE => Error.bug "no targets"
+			  | SOME l => Goto {dst = l,
+					    args = Vector.new0 ()})
+		  else
+		     let
+			val l = #2 (Vector.sub (cases, 0))
+		     in
+			if Vector.forall (cases, fn (_, l') =>
+					  Label.equals (l, l'))
+			   andalso (case default of
+				       NONE => true
+				     | SOME l' => Label.equals (l, l'))
+			   then Goto {dst = l,
+				      args = Vector.new0 ()}
+			else
+			   let
+			      val cases =
+				 QuickSort.sortVector
+				 (cases, fn ((i, _), (i', _)) => i <= i')
+			   in
+			      Switch (Switch.Int {test = test,
+						  cases = cases,
+						  default = default})
+			   end
+		     end
 	       end
 	    fun transferToLabel (transfer: Transfer.t): Label.t =
 	       case transfer of
@@ -414,13 +304,43 @@
 				 profileInfo = profileInfo,
 				 statements = Vector.new0 (),
 				 transfer = transfer}
-	    fun switchIP (numEnum, pointer: Label.t): Transfer.t =
-	       Transfer.SwitchIP
-	       {int = transferToLabel (enum (CastInt (Var {var = test,
-							   ty = Type.pointer}),
-					     numEnum)),
-		pointer = pointer,
-	       test = varOp test}
+	    fun switchEP (makePointersTransfer: Operand.t -> Transfer.t)
+	       : Transfer.t =
+	       let
+		  val {enum = e, pointers = p} =
+		     case Operand.ty test of
+			Type.EnumPointers ep => ep
+		      | _ => Error.bug "strange switchEP"
+		  val enumTy = Type.EnumPointers {enum = e,
+						  pointers = Vector.new0 ()}
+		  val enumVar = Var.newNoname ()
+		  val enumOp = Operand.Var {var = enumVar,
+					    ty = enumTy}
+		  val pointersTy = Type.EnumPointers {enum = Vector.new0 (),
+						      pointers = p}
+		  val pointersVar = Var.newNoname ()
+		  val pointersOp = Operand.Var {ty = pointersTy,
+						var = pointersVar}
+		  fun block (var, ty, transfer) =
+		     newBlock {args = Vector.new0 (),
+			       kind = Kind.Jump,
+			       profileInfo = profileInfo,
+			       statements = (Vector.new1
+					     (Statement.Bind
+					      {isMutable = false,
+					       oper = Operand.Cast (test, ty),
+					       var = var})),
+			       transfer = transfer}
+		  val pointers =
+		     block (pointersVar, pointersTy,
+			    makePointersTransfer pointersOp)
+		  val enum = block (enumVar, enumTy, enum enumOp)
+	       in
+		  Switch (Switch.EnumPointers
+			  {enum = enum,
+			   pointers = pointers,
+			   test = test})
+	       end
 	    fun tail (l: Label.t, args: Operand.t vector): Label.t =
 	       if 0 = Vector.length args
 		  then l
@@ -434,40 +354,89 @@
 			       statements = Vector.new0 (),
 			       transfer = Goto {dst = l, args = args}}
 		  end
-	    fun enumAndOne (numEnum: int): Transfer.t =
+	    fun enumAndOne (): Transfer.t =
 	       let
-		  val (l, args: Operand.t vector) =
-		     Vector.loop
-		     (cases, fn (c, j) =>
-		      case conRep c of
-			 ConRep.Transparent _ =>
-			    SOME (j, Vector.new1 (varOp test))
-		       | ConRep.Tuple => SOME (j, conSelects (test, c))
-		       | _ => NONE,
-			    fn () =>
-			    case default of
-			       NONE =>
-				  Error.bug "enumAndOne: no default"
-			     | SOME j => (j, Vector.new0 ()))
-	       in switchIP (numEnum, tail (l, args))
+		  fun make (pointersOp: Operand.t): Transfer.t =
+		     let
+			val (dst, args: Operand.t vector) =
+			   case Vector.peekMap
+			      (cases, fn (c, j) =>
+			       case conRep c of
+				  ConRep.Transparent _ =>
+				     SOME (j, Vector.new1 pointersOp)
+				| ConRep.Tuple r =>
+				     SOME (j, conSelects {rep = r,
+							  variant = pointersOp})
+				| _ => NONE) of
+			      NONE =>
+				 (case default of
+				     NONE => Error.bug "enumAndOne: no default"
+				   | SOME j => (j, Vector.new0 ()))
+			    | SOME z => z
+		     in
+			Transfer.Goto {args = args,
+				       dst = dst}
+		     end
+	       in
+		  switchEP make
 	       end
-	    fun indirectTag (numTag: int): Transfer.t =
+	    fun indirectTag (test: Operand.t): Transfer.t =
 	       let
-		  val (cases, numLeft) =
-		     Vector.fold
-		     (cases, ([], numTag),
-		      fn ((c, j), (cases, numLeft)) =>
+		  val cases =
+		     Vector.keepAllMap
+		     (cases, fn (c, l) =>
 		      case conRep c of
-			 ConRep.TagTuple n =>
-			    ((n, tail (j, conSelects (test, c))) :: cases,
-			     numLeft - 1)
-		       | _ => (cases, numLeft))
-	       in switch {test = Offset {base = test,
-					 bytes = tagOffset,
+			 ConRep.TagTuple {rep, tag} =>
+			    let
+			       val tycon = TupleRep.tycon rep
+			       val pointerVar = Var.newNoname ()
+			       val pointerTy = Type.pointer tycon
+			       val pointerOp =
+				  Operand.Var {ty = pointerTy,
+					       var = pointerVar}
+			       val statements =
+				  Vector.new1
+				  (Statement.Bind
+				   {isMutable = false,
+				    oper = Operand.Cast (test, pointerTy),
+				    var = pointerVar})
+			       val dst =
+				  newBlock
+				  {args = Vector.new0 (),
+				   kind = Kind.Jump,
+				   profileInfo = profileInfo,
+				   statements = statements,
+				   transfer =
+				   Goto {args = conSelects {rep = rep,
+							    variant = pointerOp},
+					 dst = l}}
+			    in
+			       SOME {dst = dst,
+				     tag = tag,
+				     tycon = tycon}
+			    end
+		       | _ => NONE)
+		  val numTag =
+		     case Operand.ty test of
+			Type.EnumPointers {pointers, ...} =>
+			   Vector.length pointers
+		      | _ => Error.bug "strange indirecTag"
+		  val default =
+		     if numTag = Vector.length cases
+			then NONE
+		     else default
+		  val cases =
+		     QuickSort.sortVector
+		     (cases, fn ({tycon = t, ...}, {tycon = t', ...}) =>
+		      PointerTycon.<= (t, t'))
+	       in
+		  Switch (Switch.Pointer
+			  {cases = cases,
+			   default = default,
+			   tag = Offset {base = test,
+					 offset = tagOffset,
 					 ty = Type.int},
-			  cases = Cases.Int cases,
-			  default = default,
-			  numLeft = numLeft}
+			   test = test})
 	       end
 	    fun prim () =
 	       case (Vector.length cases, default) of
@@ -484,23 +453,23 @@
 				    args = Vector.new0 ()}
 			 | ConRep.Transparent _ =>
 			      Goto {dst = l,
-				    args = Vector.new1 (varOp test)}
-			 | ConRep.Tuple =>
+				    args = Vector.new1 test}
+			 | ConRep.Tuple r =>
 			      Goto {dst = l,
-				    args = conSelects (test, c)}
+				    args = conSelects {rep = r,
+						       variant = test}}
 			 | _ => Error.bug "strange conRep for Prim"
 		     end
 		| (0, SOME l) => Goto {dst = l, args = Vector.new0 ()}
 		| _ => Error.bug "prim datatype with more than one case"
 	 in
 	    case testRep of
-	       TyconRep.Prim mtype => prim ()
-	     | TyconRep.Enum {numEnum} => enum (varOp test, numEnum)
-	     | TyconRep.EnumDirect {numEnum} => enumAndOne numEnum
-	     | TyconRep.EnumIndirect {numEnum} => enumAndOne numEnum
-	     | TyconRep.EnumIndirectTag {numEnum, numTag} =>
-		  switchIP (numEnum, transferToLabel (indirectTag numTag))
-	     | TyconRep.IndirectTag {numTag} => indirectTag numTag
+	       TyconRep.Direct => prim ()
+	     | TyconRep.Enum => enum test
+	     | TyconRep.EnumDirect => enumAndOne ()
+	     | TyconRep.EnumIndirect => enumAndOne ()
+	     | TyconRep.EnumIndirectTag => switchEP indirectTag
+	     | TyconRep.IndirectTag => indirectTag test
 	     | TyconRep.Void => prim ()
 	 end
       fun translateCase (profileInfo,
@@ -509,17 +478,20 @@
 			  default: Label.t option}): Transfer.t =
 	 let
 	    fun id x = x
-	    fun doit (l, f, branch) =
-	       Switch {test = varOp test,
-		       cases = f (Vector.toListMap
-				  (l, fn (i, j) => (branch i, j))),
-		       default = default}
+	    fun simple (l, make, branch, le) =
+	       Switch
+	       (make {test = varOp test,
+		      cases = (QuickSort.sortVector
+			       (Vector.map (l, fn (i, j) => (branch i, j)),
+				fn ((i, _), (i', _)) => le (i, i'))),
+		      default = default})
 	 in
 	    case cases of
-	       S.Cases.Char l => doit (l, Cases.Char, id)
-	     | S.Cases.Int l => doit (l, Cases.Int, id)
-	     | S.Cases.Word l => doit (l, Cases.Word, id)
-	     | S.Cases.Word8 l => doit (l, Cases.Char, Word8.toChar)
+	       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 =>
 		  (case (Vector.length cases, default) of
 		      (0, NONE) => Transfer.bug
@@ -531,7 +503,7 @@
 			       then genCase {cases = cases,
 					     default = default,
 					     profileInfo = profileInfo,
-					     test = test,
+					     test = varOp test,
 					     testRep = tyconRep tycon}
 			    else Error.bug "strange type in case"
 			 end)
@@ -547,7 +519,7 @@
 	 let
 	    val {args, ...} = labelInfo l
 	    val args = Vector.keepAllMap (args, fn (x, t) =>
-					  Option.map (toType t, fn t =>
+					  Option.map (toRtype t, fn t =>
 						      (Var.new x, t)))
 	    val l' = Label.new l
 	    val _ = 
@@ -611,13 +583,13 @@
 	 labelCont
       fun vos (xs: Var.t vector) =
 	 Vector.keepAllMap (xs, fn x =>
-			    Option.map (toType (varType x), fn _ =>
+			    Option.map (toRtype (varType x), fn _ =>
 					varOp x))
       fun translateTransfer (profileInfo, t: S.Transfer.t): Transfer.t =
 	 case t of
 	    S.Transfer.Arith {args, overflow, prim, success, ty} =>
 	       let
-		  val ty = valOf (toType ty)
+		  val ty = valOf (toRtype ty)
 		  val temp = Var.newNoname ()
 		  val noOverflow =
 		     newBlock
@@ -698,7 +670,25 @@
 	       end
       fun translateFormals v =
 	 Vector.keepAllMap (v, fn (x, t) =>
-			    Option.map (toType t, fn t => (x, t)))
+			    Option.map (toRtype t, fn t => (x, t)))
+      fun bogus (t: Type.t): Operand.t =
+	 let
+	    val c = Operand.Const
+	 in
+	    case t of
+	       Type.Char =>
+		  c (Const.fromChar #"\000")
+	     | Type.CPointer =>
+		  Error.bug "bogus CPointer"
+	     | Type.EnumPointers (ep as {enum, ...})  =>
+		  Operand.Cast (Operand.int 1, t)
+	     | Type.Int => c (Const.fromInt 0)
+	     | 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)
+	 end
       fun translateStatementsTransfer (profileInfo, statements, transfer) =
 	 let
 	    fun loop (i, ss, t): Statement.t vector * Transfer.t =
@@ -706,7 +696,7 @@
 		  then (Vector.fromList ss, t)
 	       else
 		  let
-		     val S.Statement.T {var, ty, exp} =
+		     val s as S.Statement.T {var, ty, exp} =
 			Vector.sub (statements, i)
 		     fun none () = loop (i - 1, ss, t)
 		     fun add s = loop (i - 1, s :: ss, t)
@@ -724,39 +714,39 @@
 			   loop (i - 1, ss, t)
 			end
 		     fun makeStores (ys: Var.t vector, offsets) =
-			Vector.keepAllMap2
-			(ys, offsets, fn (y, offset) =>
-			 Option.map (offset, fn {offset, ty} =>
-				     {offset = offset,
-				      value = varOp y}))
+			QuickSort.sortVector
+			(Vector.keepAllMap2
+			 (ys, offsets, fn (y, offset) =>
+			  Option.map (offset, fn {offset, ty} =>
+				      {offset = offset,
+				       value = varOp y})),
+			 fn ({offset = i, ...}, {offset = i', ...}) => i <= i')
 		     fun allocate (ys: Var.t vector,
-				   {size, offsets, numPointers,
-				    numWordsNonPointers}) =
-			let
-			   val (p, np) =
-			      if 0 = numPointers
-				 andalso 0 = numWordsNonPointers
-				 then (0, 1)
-			      else (numPointers, numWordsNonPointers)
-			in
-			   add (Object {dst = valOf var,
-					numPointers = p,
-					numWordsNonPointers = np,
-					stores = makeStores (ys, offsets)})
-			end
+				   TupleRep.T {size, offsets, ty, tycon, ...}) =
+			add (Object {dst = valOf var,
+				     size = size + Runtime.normalHeaderSize,
+				     stores = makeStores (ys, offsets),
+				     ty = ty,
+				     tycon = tycon})
+		     val allocate =
+			Trace.trace2
+			("allocate",
+			 Vector.layout Var.layout,
+			 TupleRep.layout,
+			 Layout.ignore)
+			allocate
 		     fun allocateTagged (n: int,
 					 ys: Var.t vector,
-					 {size, offsets,
-					  numPointers, numWordsNonPointers}) =
+					 TupleRep.T {size, offsets, ty, tycon}) =
 			add (Object
 			     {dst = valOf var,
-			      numPointers = numPointers,
-			      numWordsNonPointers =
-			      (* for the tag *) 1 + numWordsNonPointers,
+			      size = size + Runtime.normalHeaderSize,
 			      stores = (Vector.concat
 					[Vector.new1 {offset = tagOffset,
 						      value = Operand.int n},
-					 makeStores (ys, offsets)])})
+					 makeStores (ys, offsets)]),
+			      ty = ty,
+			      tycon = tycon})
 		     fun move (oper: Operand.t) =
 			add (Bind {isMutable = false,
 				   oper = oper,
@@ -766,28 +756,33 @@
 			S.Exp.ConApp {con, args} =>
 			   (case conRep con of
 			       ConRep.Void => none ()
-			     | ConRep.Int n => move (Operand.int n)
-			     | ConRep.IntCast n => move (Operand.Pointer n)
-			     | ConRep.TagTuple n =>
-				  allocateTagged (n, args, #info (conInfo con))
+			     | ConRep.IntAsTy {int, ty} =>
+				  move (Operand.Cast (Operand.int int, ty))
+			     | ConRep.TagTuple {rep, tag} =>
+				  allocateTagged (tag, args, rep)
 			     | ConRep.Transparent _ =>
-				  move (varOp (Vector.sub (args, 0)))
-			     | ConRep.Tuple =>
-				  allocate (args, #info (conInfo con)))
+				  move (Operand.cast
+					(varOp (Vector.sub (args, 0)),
+					 valOf (toRtype ty)))
+			     | ConRep.Tuple rep =>
+				  allocate (args, rep))
 		      | S.Exp.Const c => move (Operand.Const c)
 		      | S.Exp.PrimApp {prim, targs, args, ...} =>
 			   let
 			      fun a i = Vector.sub (args, i)
-			      fun targ () = toType (Vector.sub (targs, 0))
+			      fun cast () =
+				 move (Operand.cast (varOp (a 0),
+						     valOf (toRtype ty)))
+			      fun targ () = toRtype (Vector.sub (targs, 0))
 			      fun arrayOffset (ty: Type.t): Operand.t =
-				 ArrayOffset {base = a 0,
-					      index = a 1,
+				 ArrayOffset {base = varOp (a 0),
+					      index = varOp (a 1),
 					      ty = ty}
 			      fun sub (ty: Type.t) = move (arrayOffset ty)
 			      fun dst () =
 				 case var of
 				    SOME x =>
-				       Option.map (toType (varType x), fn t =>
+				       Option.map (toRtype (varType x), fn t =>
 						   (x, t))
 				  | NONE => NONE
 			      fun normal () =
@@ -868,119 +863,112 @@
 			      fun simpleCCall (f: CFunction.t) =
 				 ccall {args = vos args,
 					func = f}
-			      fun array0 (numElts: Operand.t) =
-				 add
-				 (PrimApp {args = Vector.new1 numElts,
-					   dst = dst (),
-					   prim = Prim.array0})
+			      fun array (numElts: Operand.t) =
+				 let
+				    val pt =
+				       case (Type.dePointer
+					     (valOf (toRtype ty))) of
+					  NONE => Error.bug "strange array"
+					| SOME pt => PointerTycon pt
+				    val args =
+				       Vector.new4 (Operand.GCState,
+						    Operand.EnsuresBytesFree,
+						    numElts,
+						    pt)
+				 in
+				    ccall {args = args,
+					   func = CFunction.gcArrayAllocate}
+				 end
 		     fun updateCard (addr: Operand.t, prefix, assign) =
 		        let
 			   val index = Var.newNoname ()
-			   val map = Var.newNoname ()
 			   val ss = 
 			      (PrimApp
 			       {args = (Vector.new2
-					(Operand.CastWord addr,
+					(Operand.Cast (addr, Type.Word),
 					 Operand.word
 					 (Word.fromInt
 					  (!Control.cardSizeLog2)))),
 				dst = SOME (index, Type.int),
 				prim = Prim.word32Rshift})
-			      :: (Bind {isMutable = false,
-					oper = Operand.Runtime GCField.CardMap,
-					var = map})
 			      :: (Move
 				  {dst = (Operand.ArrayOffset
-					  {base = map,
-					   index = index,
+					  {base = (Operand.Runtime
+						   GCField.CardMap),
+					   index = Operand.Var {ty = Type.int,
+								var = index},
 					   ty = Type.char}),
 				   src = Operand.char #"\001"})
-			      :: assign
+				  :: assign
 			      :: ss
 			in
 			  loop (i - 1, prefix ss, t)
 			end
-		     fun arrayUpdate (ty, src) =
+		     fun arrayUpdate (ty: Type.t) =
 		        if !Control.markCards andalso Type.isPointer ty
 			   then let
+				   val src = varOp (a 2)
+				   val arrayOp = varOp (a 0)
 				   val temp = Var.newNoname ()
 				   val tempOp = Operand.Var {var = temp,
 							     ty = Type.word}
 				   val addr = Var.newNoname ()
-				   val addrOp = Operand.Var {var = addr,
-							     ty = Type.pointer}
+				   val mc =
+				      case Type.dePointer (Operand.ty arrayOp) of
+					 NONE => Error.bug "strange array"
+				       | SOME p => 
+					    case tyconTy p of
+					       ObjectType.Array mc => mc
+					     | _ => Error.bug "strange array"
+				   val addrOp =
+				      Operand.Var {var = addr,
+						   ty = Type.MemChunk mc}
 				   fun prefix ss =
 				      (PrimApp
 				       {args = Vector.new2
-					       (Operand.CastWord (varOp (a 1)),
+					       (Operand.Cast (varOp (a 1),
+							      Type.Word),
 					        Operand.word
 						(Word.fromInt (Type.size ty))),
 				        dst = SOME (temp, Type.word),
 				        prim = Prim.word32Mul})
 				      :: (PrimApp
 					  {args = (Vector.new2
-						   (Operand.CastWord
-						    (varOp (a 0)),
+						   (Operand.Cast (arrayOp,
+								  Type.Word),
 						    tempOp)),
-					   dst = SOME (addr, Type.pointer),
+					   dst = SOME (addr, Type.MemChunk mc),
 					   prim = Prim.word32Add})
 				      :: ss
-				   val assign = Move {dst = Operand.Offset
-						            {base = addr,
-							     bytes = 0,
-							     ty = ty},
-						      src = src}
+				   val assign =
+				      Move {dst = (Operand.Offset
+						   {base = addrOp,
+						    offset = 0,
+						    ty = ty}),
+					    src = varOp (a 2)}
 				in
 				   updateCard (addrOp, prefix, assign)
 				end
 			else add (Move {dst = arrayOffset ty,
-					src = src})
+					src = varOp (a 2)})
 		     fun refAssign (ty, src) =
 		        let
-			   val addr = a 0
+			   val addr = varOp (a 0)
 			   val assign = Move {dst = Operand.Offset {base = addr,
-								    bytes = 0,
+								    offset = 0,
 								    ty = ty},
 					      src = src}
 			in
 			   if !Control.markCards andalso Type.isPointer ty
-			      then updateCard (varOp addr, fn ss => ss, assign)
+			      then updateCard (addr, fn ss => ss, assign)
 			   else loop (i - 1, assign::ss, t)
 			end
-
-
 			      datatype z = datatype Prim.Name.t
 			   in
 			      case Prim.name prim of
 				 Array_array =>
-  let
-     val numElts = a 0
-     val numEltsOp = Operand.Var {var = numElts, ty = Type.int}
-  in
-     case targ () of
-	NONE => array0 numEltsOp
-      | SOME t =>
-	   let
-	      val (nbnp, np, bytesPerElt) =
-		 if Type.isPointer t
-		    then (0, 1, Runtime.pointerSize)
-		 else
-		    let val n = Type.size t
-		    in (n, 0, n)
-		    end
-	   in
-	      if 0 = np andalso 0 = nbnp
-		 then array0 numEltsOp
-	      else ccall {args = (Vector.new4
-				  (Operand.GCState,
-				   Operand.EnsuresBytesFree,
-				      numEltsOp,
-				      ArrayHeader {numBytesNonPointers = nbnp,
-						   numPointers = np})),
-			  func = CFunction.gcArrayAllocate}
-	   end
-  end
-			       | Array_array0 => array0 (Operand.int 0)
+				    array (Operand.Var {var = a 0,
+							ty = Type.int})
 			       | Array_sub =>
 				    (case targ () of
 					NONE => none ()
@@ -988,7 +976,10 @@
 			       | Array_update =>
 				    (case targ () of
 					NONE => none ()
-				      | SOME ty => arrayUpdate (ty, varOp (a 2)))
+				      | SOME ty => arrayUpdate ty)
+			       | Byte_byteToChar => cast ()
+			       | Byte_charToByte => cast ()
+			       | C_CS_charArrayToWord8Array => cast ()
 			       | FFI name =>
 				    if Option.isNone (Prim.numArgs prim)
 				       then normal ()
@@ -998,7 +989,9 @@
 					{name = name,
 					 returnTy =
 					 Option.map
-					 (var, valOf o toType o varType)})
+					 (var, fn x =>
+					  Type.toRuntime
+					  (valOf (toRtype (varType x))))})
 			       | GC_collect =>
 				    ccall
 				    {args = Vector.new5 (Operand.GCState,
@@ -1016,13 +1009,17 @@
 					   func = CFunction.unpack}
 			       | IntInf_add => simpleCCall CFunction.intInfAdd
 			       | IntInf_andb => simpleCCall CFunction.intInfAndb
-			       | IntInf_arshift => simpleCCall CFunction.intInfArshift
+			       | IntInf_arshift =>
+				    simpleCCall CFunction.intInfArshift
 			       | IntInf_compare =>
 				    simpleCCall CFunction.intInfCompare
 			       | IntInf_equal =>
 				    simpleCCall CFunction.intInfEqual
+			       | IntInf_fromVector => cast ()
+			       | IntInf_fromWord => cast ()
 			       | IntInf_gcd => simpleCCall CFunction.intInfGcd
-			       | IntInf_lshift => simpleCCall CFunction.intInfLshift
+			       | IntInf_lshift =>
+				    simpleCCall CFunction.intInfLshift
 			       | IntInf_mul => simpleCCall CFunction.intInfMul
 			       | IntInf_neg => simpleCCall CFunction.intInfNeg
 			       | IntInf_notb => simpleCCall CFunction.intInfNotb
@@ -1032,27 +1029,13 @@
 			       | IntInf_sub => simpleCCall CFunction.intInfSub
 			       | IntInf_toString =>
 				    simpleCCall CFunction.intInfToString
+			       | IntInf_toVector => cast ()
+			       | IntInf_toWord => cast ()
 			       | IntInf_xorb => simpleCCall CFunction.intInfXorb
 			       | MLton_bogus =>
-				    (case toType ty of
+				    (case toRtype ty of
 					NONE => none ()
-				      | SOME t =>
-					   let
-					      val c = Operand.Const
-					   in
-					      move
-					      (case Type.dest t of
-						  Type.Char =>
-						     c (Const.fromChar #"\000")
-						| Type.Double =>
-						     c (Const.fromReal "0.0")
-						| Type.Int =>
-						     c (Const.fromInt 0)
-						| Type.Pointer =>
-						     Operand.Pointer 1
-						| Type.Uint =>
-						     c (Const.fromWord 0w0))
-					   end)
+				      | SOME t => move (bogus t))
 			       | MLton_bug => simpleCCall CFunction.bug
 			       | MLton_eq =>
 				    (case targ () of
@@ -1074,19 +1057,15 @@
 				    (case targ () of
 					NONE => none ()
 				      | SOME ty =>
-					   move (Offset {base = a 0,
-							 bytes = 0,
+					   move (Offset {base = varOp (a 0),
+							 offset = 0,
 							 ty = ty}))
 			       | Ref_ref =>
-				    let
-				       val (ys, ts) =
-					  case targ () of
-					     NONE => (Vector.new0 (),
-						      Vector.new0 ())
-					   | SOME t => (Vector.new1 (a 0),
-							Vector.new1 (SOME t))
-				    in allocate (ys, sortTypes (0, ts))
-				    end
+				    allocate
+				    (Vector.new1 (a 0),
+				     refRep (Vector.sub (targs, 0)))
+			       | String_fromWord8Vector => cast ()
+			       | String_toWord8Vector => cast ()
 			       | Thread_atomicBegin =>
 				    (* assert (s->canHandle >= 0);
 				     * s->canHandle++;
@@ -1107,8 +1086,9 @@
 						dst = SOME (tmp, Type.word),
 						prim = prim},
 					       Statement.Move
-					       {dst = (Operand.CastWord
-						       (Operand.Runtime dst)),
+					       {dst = (Operand.Cast
+						       (Operand.Runtime dst,
+							Type.Word)),
 						src = (Operand.Var
 						       {var = tmp,
 							ty = Type.word})})
@@ -1132,7 +1112,7 @@
 							 dst = l})}
 				     in
 					(bumpCanHandle 1,
-					 Transfer.iff
+					 Transfer.ifInt
 					 (Operand.Runtime SignalIsPending,
 					  {falsee = l,
 					   truee = l'}))
@@ -1151,8 +1131,9 @@
 					val statements =
 					   Vector.new1
 					   (Statement.Move
-					    {dst = (Operand.CastWord
-						    (Operand.Runtime Limit)),
+					    {dst = (Operand.Cast
+						    (Operand.Runtime Limit,
+						     Type.Word)),
 					     src = Operand.word 0w0})
 					val l'' =
 					   newBlock
@@ -1171,13 +1152,13 @@
 					    profileInfo = profileInfo,
 					    statements = Vector.new0 (),
 					    transfer =
-					    Transfer.iff
+					    Transfer.ifInt
 					    (Operand.Runtime CanHandle,
-					     {truee = l,
-					      falsee = l''})}
+					     {falsee = l'',
+					      truee = l})}
 				     in
 					(bumpCanHandle ~1,
-					 Transfer.iff
+					 Transfer.ifInt
 					 (Operand.Runtime SignalIsPending,
 					  {falsee = l,
 					   truee = l'}))
@@ -1194,11 +1175,36 @@
 						   (varOp (a 0),
 						    Operand.EnsuresBytesFree)),
 					   func = CFunction.threadSwitchTo}
-			       | Vector_fromArray => move (varOp (a 0))
+			       | 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_sub =>
 				    (case targ () of
 					NONE => none ()
 				      | SOME t => sub t)
+			       | Word32_toIntX => cast ()
+			       | Word32_fromInt => cast ()
 			       | World_save =>
 				    ccall {args = (Vector.new2
 						   (Operand.GCState,
@@ -1207,21 +1213,28 @@
 			       | _ => normal ()
 			   end
 		      | S.Exp.Select {tuple, offset} =>
-			   (case Vector.sub (#offsets (tupleInfo (varType tuple)),
-					     offset) of
-			       NONE => none ()
-			     | SOME {offset, ty} =>
-				  move (Offset {base = tuple,
-						bytes = offset,
-						ty = ty}))
+			   let
+			      val TupleRep.T {offsets, ...} =
+				 tupleRep (varType tuple)
+			   in
+			      case Vector.sub (offsets, offset) of
+				 NONE => none ()
+			       | SOME {offset, ty} =>
+				    move (Offset {base = varOp tuple,
+						  offset = offset,
+						  ty = ty})
+			   end
 		      | S.Exp.SetExnStackLocal => add SetExnStackLocal
 		      | S.Exp.SetExnStackSlot => add SetExnStackSlot
 		      | S.Exp.SetHandler h => 
 			   add (SetHandler (labelHandler (profileInfo, h)))
 		      | S.Exp.SetSlotExnStack => add SetSlotExnStack
-		      | S.Exp.Tuple ys => allocate (ys, tupleInfo ty)
+		      | S.Exp.Tuple ys =>
+			   if 0 = Vector.length ys
+			      then none ()
+			   else allocate (ys, tupleRep ty)
 		      | S.Exp.Var y =>
-			   (case toType ty of
+			   (case toRtype ty of
 			       NONE => none ()
 			     | SOME _ => move (varOp y))
 		      | _ => Error.bug "translateStatement saw strange PrimExp"
@@ -1250,7 +1263,8 @@
 	    val _ = resetAllocTooLarge ()
 	    val _ =
 	       S.Function.foreachVar (f, fn (x, t) => setVarInfo (x, {ty = t}))
-	    val {args, blocks, name, start, ...} = S.Function.dest f
+	    val {args, blocks, name, raises, returns, start, ...} =
+	       S.Function.dest f
 	    val _ =
 	       Vector.foreach
 	       (blocks, fn S.Block.T {label, args, ...} =>
@@ -1265,10 +1279,15 @@
 				     translateBlock (profileInfo, block))
 	    val blocks = Vector.concat [Vector.fromList (!extraBlocks), blocks]
 	    val _ = extraBlocks := []
+	    fun transTypes (ts : S.Type.t vector option)
+	       : Type.t vector option =
+	       Option.map (ts, fn ts => Vector.keepAllMap (ts, toRtype))
 	 in
 	    Function.new {args = translateFormals args,
 			  blocks = blocks,
 			  name = name,
+			  raises = transTypes raises,
+			  returns = transTypes returns,
 			  start = start}
 	 end
       val main =
@@ -1294,6 +1313,7 @@
       val functions = List.revMap (functions, translateFunction)
       val p = Program.T {functions = functions,
 			 main = main,
+			 objectTypes = objectTypes,
 			 profileAllocLabels = Vector.new0 ()}
       val _ = Program.clear p
    in



1.4       +4 -2      mlton/mlton/backend/ssa-to-rssa.sig

Index: ssa-to-rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- ssa-to-rssa.sig	16 Apr 2002 12:10:52 -0000	1.3
+++ ssa-to-rssa.sig	7 Dec 2002 02:21:52 -0000	1.4
@@ -12,11 +12,13 @@
    sig
       structure Rssa: RSSA
       structure Ssa: SSA
-      sharing Rssa.Atoms = Ssa.Atoms
+      sharing Rssa.Const = Ssa.Const
       sharing Rssa.Func = Ssa.Func
+      sharing Rssa.Handler = Ssa.Handler
       sharing Rssa.Label = Ssa.Label
+      sharing Rssa.Prim = Ssa.Prim
       sharing Rssa.Return = Ssa.Return
-      sharing Rssa.Handler = Ssa.Handler
+      sharing Rssa.Var = Ssa.Var
    end
 
 signature SSA_TO_RSSA =



1.1                  mlton/mlton/backend/machine-atoms.fun

Index: machine-atoms.fun
===================================================================
(* Copyright (C) 2002 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 *
 * MLton is released under the GNU General Public License (GPL).
 * Please see the file MLton-LICENSE for license information.
 *)

functor MachineAtoms (S: MACHINE_ATOMS_STRUCTS): MACHINE_ATOMS =
struct

open S
   
structure PointerTycon =
   struct
      datatype t = T of {index: int,
			 plist: PropertyList.t}

      local
	 fun make f (T r) = f r
      in
	 val index = make #index
	 val plist = make #plist
      end
   
      fun equals (pt, pt') = PropertyList.equals (plist pt, plist pt')

      val op <= = fn (pt, pt') => index pt <= index pt'

      fun toString (T {index, ...}) =
	 concat ["pt_", Int.toString index]

      val layout = Layout.str o toString

      val c = Counter.new 0

      fun new () =
	 T {index = Counter.next c,
	    plist = PropertyList.new ()}

      (* These basic pointer tycons are hardwired into the runtime and are
       * prefixed to every user program.  See gc.h for the definitions of
       * {STACK,STRING,THREAD,WORD_VECTOR}_TYPE_INDEX.
       *)
      val stack = new ()
      val string = new ()
      val thread = new ()
      val wordVector = new ()
   end

structure TypeAndMemChunk =
   struct
      datatype ty =
	 Char
       | CPointer
       | EnumPointers of {enum: int vector,
			  pointers: PointerTycon.t vector}
       | Int
       | IntInf
       | Label
       | MemChunk of memChunk
       | Real
       | Word
      and memChunk =
	 T of {components: {mutable: bool,
			    offset: int,
			    ty: ty} vector,
	       size: int}

      fun layoutTy (t: ty) =
	 let
	    open Layout
	 in
	    case t of
	       Char => str "char"
	     | CPointer => str "cpointer"
	     | EnumPointers {enum, pointers} => 
		  if 0 = Vector.length enum
		     andalso 1 = Vector.length pointers
		     then PointerTycon.layout (Vector.sub (pointers, 0))
		  else
		     Vector.layout (fn x => x)
		     (Vector.concat [Vector.map (enum, Int.layout),
				     Vector.map (pointers, PointerTycon.layout)])
	     | Int => str "int"
	     | IntInf => str "intInf"
	     | Label => str "Label"
	     | MemChunk m => seq [str "MemChunk ", layoutMemChunk m]
	     | Real => str "real"
	     | Word => str "word"
	 end
      and layoutMemChunk (T {components, size}) =
	 Layout.record
	 [("components",
	   Vector.layout (fn {mutable, offset, ty} =>
			  Layout.record [("mutable", Bool.layout mutable),
					 ("offset", Int.layout offset),
					 ("ty", layoutTy ty)])
	   components),
	  ("size", Int.layout size)]

      fun equalsTy (t, t'): bool =
	 case (t, t') of
	    (Char, Char) => 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))
	  | (Int, Int) => true
	  | (IntInf, IntInf) => true
	  | (Label, Label) => true
	  | (MemChunk m, MemChunk m') => equalsMemChunk (m, m')
	  | (Real, Real) => true
	  | (Word, Word) => true
	  | _ => false
      and equalsMemChunk (T {components = cs, size = s},
			  T {components = cs', size = s'}) =
	 s = s'
	 andalso
	 Vector.equals (cs, cs', fn ({mutable = m, offset = i, ty = t},
				     {mutable = m', offset = i', ty = t'}) =>
			m = m' andalso i = i' andalso equalsTy (t, t'))

      local
	 val byte: int = 1
	 val word: int = 4
	 val double: int = 8
      in
	 val size =
	    fn Char => byte
	     | CPointer => word
	     | EnumPointers _ => word
	     | Int => word
	     | IntInf => word
	     | Label => word
	     | MemChunk _ => word
	     | Real => double
	     | Word => word
      end

      fun isOkTy (t: ty): bool =
	 case t of
	    Char => 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))
	  | Int => true
	  | IntInf => true
	  | Label => true
	  | MemChunk m => isOkMemChunk m
	  | Real => true
	  | Word => true
      and isOkMemChunk (T {components, size = s}) =
	 let
	    exception No
	    fun no () = raise No
	    fun doit () =
	       Vector.fold
	       (components, (0, false),
		fn ({offset, ty, ...}, (prev, isPointer)) =>
		if prev <= offset
		   andalso isOkTy ty
		   andalso (case ty of
			       (* Can't store pointers to MemChunks in other
				* MemChunks.
				*)
			       MemChunk _ => false
			     | _ => true)
		   then (offset + size ty,
			 let
			    fun nonPointer () =
			       if isPointer
				  then no ()
			       else false
			 in
			    case ty of
			       EnumPointers {pointers, ...} =>
				  if 0 = Vector.length pointers
				     then nonPointer ()
				  else true
			     | IntInf => true
			     | _ => nonPointer ()
			 end)
		else no ())
	 in
	    #1 (doit ()) <= s
	    handle No => false
	 end
   end

type memChunk = TypeAndMemChunk.memChunk
   
structure Type =
   struct
      local
	 open TypeAndMemChunk
      in
	 datatype t = datatype ty

	 val equals = equalsTy
	 val layout = layoutTy
	 val size = size
      end

      val toString = Layout.toString o layout

      val bool = EnumPointers {enum = Vector.new2 (0, 1),
			       pointers = Vector.new0 ()}
      val char = Char
      val cpointer = CPointer
      val int = Int
      val intInf = IntInf
      val label = Label
      val real = Real
      val word = Word

      fun pointer pt =
	 EnumPointers {enum = Vector.new0 (),
		       pointers = Vector.new1 pt}

      val stack = pointer PointerTycon.stack
      val string = pointer PointerTycon.string
      val thread = pointer PointerTycon.thread
      val wordVector = pointer PointerTycon.wordVector

      fun containsPointer (t, pt): bool =
	 case t of
	    EnumPointers {pointers, ...} =>
	       Vector.exists (pointers, fn pt' => PointerTycon.equals (pt, pt'))
	  | _ => false

      val isPointer =
	 fn EnumPointers {pointers, ...} => 0 < Vector.length pointers
	  | IntInf => true
	  | _ => false

      fun split ({enum, pointers}) =
	 {enum = {enum = enum, pointers = Vector.new0 ()},
	  pointers = {enum = Vector.new0 (), pointers = pointers}}

      local
	 structure R = Runtime.Type
      in
	 val fromRuntime: Runtime.Type.t -> t =
	    fn t =>
	    case R.dest t of
	       R.Char => char
	     | R.Double => real
	     | R.Int => int
	     | R.Pointer => cpointer
	     | Uint => word

	 val toRuntime: t -> Runtime.Type.t =
	    fn Char => R.char
	     | CPointer => R.pointer
	     | EnumPointers {enum, pointers} =>
		  if 0 = Vector.length pointers
		     then R.int
		  else R.pointer
	     | Int => R.int
	     | IntInf => R.pointer
	     | Label => R.uint
	     | MemChunk _ => R.pointer
	     | Real => R.double
	     | Word => R.word

	 val name = R.name o toRuntime

	 fun align (t: t, n: int): int = R.align (toRuntime t, n)
      end

      val equals =
	 Trace.trace2 ("Rtype.equals", layout, layout, Bool.layout) equals

      fun dePointer t =
	 case t of
	    EnumPointers {enum, pointers} =>
	       if 0 = Vector.length enum
		  andalso 1 = Vector.length pointers
		  then SOME (Vector.sub (pointers, 0))
	       else NONE
	  | _ => NONE
   end

structure MemChunk =
   struct
      local
	 open TypeAndMemChunk
      in
	 datatype t = datatype memChunk

	 val isOk = isOkMemChunk
	 val layout = layoutMemChunk
      end

      fun numBytesAndPointers (T {components, size}) =
	 let
	    val offset =
	       case Vector.peek (components, Type.isPointer o #ty) of
		  NONE => size
		| SOME {offset, ...} => offset
	 in
	    (offset, Int.quot (size - offset, Runtime.pointerSize))
	 end

      fun isValidInit (T {components, ...},
		       stores: {offset: int, ty: Type.t} vector): bool =
	 Vector.length stores = Vector.length components
	 andalso
	 Vector.isSorted
	 (stores, fn ({offset = off, ...}, {offset = off', ...}) =>
	  off <= off')
	 andalso
	 Vector.forall2
	 (components, stores, fn ({offset = off, ty, ...},
				  {offset = off', ty = ty'}) =>
	  off = off' andalso Type.equals (ty, ty'))
   end

structure ObjectType =
   struct
      datatype t =
	 Array of MemChunk.t
       | Normal of MemChunk.t
       | Stack

      fun layout (t: t) =
	 let
	    open Layout
	 in
	    case t of
	       Array mc => seq [str "Array ", MemChunk.layout mc]
	     | Normal mc => seq [str "Normal ", MemChunk.layout mc]
	     | Stack => str "Stack"
	 end

      val wordSize = Runtime.wordSize
	 
      val stack = Stack
      val string =
	 Array (MemChunk.T {components = Vector.new1 {mutable = true,
						      offset = 0,
						      ty = Type.char},
			    size = 1})
      val thread =
	 let
	    val components =
	       Vector.new3 ({mutable = true,
			     offset = 0,
			     ty = Type.word},
			    {mutable = true,
			     offset = wordSize,
			     ty = Type.word},
			    {mutable = true,
			     offset = 2 * wordSize,
			     ty = Type.stack})
	 in			     
	    Normal (MemChunk.T {components = components,
				size = 3 * wordSize})
	 end
      val wordVector =
	 Array (MemChunk.T {components = Vector.new1 {mutable = false,
						      offset = 0,
						      ty = Type.word},
			    size = wordSize})
		
      val isOk =
	 fn Array mc => MemChunk.isOk mc
	  | Normal mc => MemChunk.isOk mc
	  | Stack => true

      local
	 structure R = Runtime.ObjectType
      in
	 fun toRuntime t =
	    case t of
	       Array m => let
			     val (b, p) = MemChunk.numBytesAndPointers m
			  in
			     R.Array {numBytesNonPointers = b,
				      numPointers = p}
			  end
	     | Normal m => let
			      val (b, p) = MemChunk.numBytesAndPointers m
			     val w = Int.quot (b, Runtime.wordSize)
			  in
			     R.Normal {numWordsNonPointers = w,
				       numPointers = p}
			  end
	     | Stack => R.Stack
      end

      val basic =
	 Vector.fromList
	 [(PointerTycon.stack, stack),
	  (PointerTycon.string, string),
	  (PointerTycon.thread, thread),
	  (PointerTycon.wordVector, wordVector)]
   end

fun castIsOk {from: Type.t,
	      fromInt: int option,
	      to: Type.t,
	      tyconTy: PointerTycon.t -> ObjectType.t}: bool =
   let
      fun castEnumIsOk ({enum = e, pointers = p},
			{enum = e', pointers = p'}): bool =
	 (* Safe subtyping. *)
	 (Vector.isSubsequence (e, e', op =)
	  andalso Vector.isSubsequence (p, p', PointerTycon.equals))
	 orelse
	 (* Unsafe Vector_fromArray. *)
	 (0 = Vector.length e
	  andalso 0 = Vector.length e'
	  andalso 1 = Vector.length p
	  andalso 1 = Vector.length p'
	  andalso
	  (case (tyconTy (Vector.sub (p, 0)),
		 tyconTy (Vector.sub (p', 0))) of
	      (ObjectType.Array (MemChunk.T {components = cs, size = s}),
	       ObjectType.Array (MemChunk.T {components = cs', size = s'})) =>
	      s = s'
	      andalso
	      Vector.equals
	      (cs, cs', fn ({offset = off, ty, ...},
			    {offset = off', ty = ty', ...}) =>
	       off = off' andalso Type.equals (ty, ty'))
	     | _ => false))
	 orelse
	 (* Unsafe downcast, but we use it in SwitchEnumPointers
	  * and SwitchPointer. It should be made properly type safe
	  * by using dominators or somesuch.
	  *)
	 (if 0 = Vector.length e
	     then (0 = Vector.length e'
		   andalso 1 = Vector.length p'
		   andalso
		   let
		      val pt = Vector.sub (p', 0)
		   in
		      Vector.exists (p, fn pt' =>
				     PointerTycon.equals (pt, pt'))
		   end)
	  else
	     (e = e' andalso 0 = Vector.length p')
	     orelse
	     ((MLton.eq (p, p')
	       orelse Vector.equals (p, p', PointerTycon.equals))
	      andalso 0 = Vector.length e'))
      datatype z = datatype Type.t
   in
      case from of
	 CPointer =>
	    (case to of
		Int => true
	      | Word => true
	      | _ => false)
       | EnumPointers (ep as {enum, pointers}) =>
	    (case to of
		EnumPointers ep' => castEnumIsOk (ep, ep')
	      | IntInf =>
		   (* IntInf_fromVector *)
		   0 = Vector.length enum
		   andalso 1 = Vector.length pointers
		   andalso PointerTycon.equals (PointerTycon.wordVector,
						Vector.sub (pointers, 0))
	      | Word => true (* necessary for card marking *)
	      | _ => false)
       | Int =>
	    (case to of
		EnumPointers {enum, ...} =>
		   (case fromInt of
		       NONE => false
		     | SOME int => Vector.exists (enum, fn i => i = int))
		   orelse
		   (* MLton_bogus *)
		   (0 = Vector.length enum
		    andalso (case fromInt of
				SOME 1 => true
			      | _ => false))
	      | Word => true (* Word32_fromInt *)
	      | _ => false)
       | IntInf =>
	    (case to of
		EnumPointers {enum, pointers} =>
		   (* IntInf_toVector *)
		   0 = Vector.length enum
		   andalso 1 = Vector.length pointers
		   andalso PointerTycon.equals (PointerTycon.wordVector,
						Vector.sub (pointers, 0))
	      | Word => true  (* IntInf_toWord *)
	      | _ => false)
       | MemChunk _ =>
	    (case to of
		Word => true (* needed for card marking of arrays *)
	      | _ => false)
       | Word =>
	    (case to of
		Int => true (* Word32_toIntX *)
	      | IntInf => true (* IntInf_fromWord *)
	      | _ => false)
       | _ => false
   end

end



1.1                  mlton/mlton/backend/machine-atoms.sig

Index: machine-atoms.sig
===================================================================
(* Copyright (C) 2002 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 *
 * MLton is released under the GNU General Public License (GPL).
 * Please see the file MLton-LICENSE for license information.
 *)
type int = Int.t
type word = Word.t
   
signature MACHINE_ATOMS_STRUCTS =
   sig
      structure Label: HASH_ID
      structure Prim: PRIM
      structure Runtime: RUNTIME
   end

signature MACHINE_ATOMS =
   sig
      include MACHINE_ATOMS_STRUCTS

      structure PointerTycon:
	 sig
	    type t

	    val <= : t * t -> bool
	    val equals: t * t -> bool
	    val index: t -> int (* index into pointerTypes array *)
	    val layout: t -> Layout.t
	    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
	 end

      type memChunk
      structure Type:
	 sig
	    datatype t =
	       Char
	     | CPointer
	     (* The ints in an enum are in increasing order without dups.
	      * The pointers are in increasing order (of index in pointerTypes
	      * vector) without dups.
	      *)
	     | EnumPointers of {enum: int vector,
				pointers: PointerTycon.t vector}
	     | Int
	     | IntInf
	     | Label
	     | MemChunk of memChunk (* An internal pointer. *)
	     | Real
	     | Word

	    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 equals: t * t -> bool
	    val fromRuntime: Runtime.Type.t -> t
	    val int: t
	    val intInf: t
	    val isPointer: t -> bool
	    val label: t
	    val layout: t -> Layout.t
	    val name: t -> string (* simple one letter abbreviation *)
	    val pointer: PointerTycon.t -> t
	    val real: 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 wordVector: t
	 end

      structure MemChunk:
	 sig
	    (* The components are stored in increasing order of offset and are
	     * non-overlapping.
	     *)
	    datatype t =
	       T of {components: {mutable: bool,
				  offset: int,
				  ty: Type.t} vector,
		     size: int}
	       
	    val isValidInit: t * {offset: int, ty: Type.t} vector -> bool
	 end where type t = memChunk
      
      structure ObjectType:
	 sig
	    datatype t =
	       Array of MemChunk.t
	     | Normal of MemChunk.t
	     | Stack

	    val basic: (PointerTycon.t * t) vector
	    val isOk: t -> bool
	    val layout: t -> Layout.t
	    val stack: t
	    val string: t
	    val thread: t
	    val toRuntime: t -> Runtime.ObjectType.t
	    val wordVector: t
	 end

      val castIsOk: {from: Type.t,
		     fromInt: int option,
		     to: Type.t,
		     tyconTy: PointerTycon.t -> ObjectType.t} -> bool
   end



1.1                  mlton/mlton/backend/switch.fun

Index: switch.fun
===================================================================
(* Copyright (C) 2002 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 *
 * MLton is released under the GNU General Public License (GPL).
 * Please see the file MLton-LICENSE for license information.
 *)

functor Switch (S: SWITCH_STRUCTS): SWITCH =
struct

open S
   
fun isRedundant {cases: 'a vector,
		 equals: 'a * 'a -> bool}: bool =
   let
      val nCases = Vector.length cases
   in
      0 < nCases
      andalso let
		 fun loop (i: int, prev: 'a): bool =
		    i < nCases
		    andalso let
			       val cur = Vector.sub (cases, i)
			    in
			       equals (cur, prev)
			       orelse loop (i + 1, cur)
			    end
	      in
		 loop (1, Vector.sub (cases, 0))
	      end
   end

fun exhaustiveAndIrredundant {all: 'a vector,
			      cases: 'a vector,
			      default: 'c option,
			      equals: 'a * 'a -> bool}: bool =
   Vector.isSubsequence (cases, all, equals)
   andalso (if Vector.length all = Vector.length cases
	       then Option.isNone default
	    else Option.isSome default)
   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,
		     pointers: Label.t,
		     test: Use.t}
  | Int of {cases: (int * Label.t) vector,
	    default: Label.t option,
	    test: Use.t}
  | Pointer of {cases: {dst: Label.t,
			tag: int,
			tycon: PointerTycon.t} vector,
		default: Label.t option,
		tag: Use.t,
		test: Use.t} (* of type int*)
  | Word of {cases: (word * Label.t) vector,
	     default: Label.t option,
	     test: Use.t}

fun layout s =
   let
      open Layout
      fun simple ({cases, default, test}, name, lay) =
	 seq [str (concat ["switch", name, " "]),
	      record [("test", Use.layout test),
		      ("default", Option.layout Label.layout default),
		      ("cases",
		       Vector.layout
		       (Layout.tuple2 (lay, Label.layout))
		       cases)]]
   in
      case s of
	 Char z => simple (z, "Char", Char.layout)
       | 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)
       | Pointer {cases, default, tag, test} =>
	    seq [str "SwitchPointer ",
		 record [("test", Use.layout test),
			 ("tag", Use.layout tag),
			 ("default", Option.layout Label.layout default),
			 ("cases",
			  Vector.layout
			  (fn {dst, tag, tycon} =>
			   record [("dst", Label.layout dst),
				   ("tag", Int.layout tag),
				   ("tycon", PointerTycon.layout tycon)])
			  cases)]]
       | Word z => simple (z, "Word", Word.layout)
   end

val allChars = Vector.tabulate (Char.numChars, Char.fromInt)

fun isOk (s, {labelIsOk}): bool =
   case s of
      Char {cases, default, 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, ...} =>
	 labelIsOk enum
	 andalso labelIsOk pointers
	 andalso (case Use.ty test of
		     Type.EnumPointers _ => true
		   | _ => false)
    | Int {cases, default, 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
	 (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} =>
		0 = Vector.length pointers
		andalso
		exhaustiveAndIrredundant
		{all = enum,
		 cases = Vector.map (cases, #1),
		 default = default,
		 equals = op =}
	   | _ => false)
    | Pointer {cases, default, tag, test} =>
	 (Type.equals (Use.ty tag, Type.int)
	  andalso (case default of
		      NONE => true
		    | SOME l => labelIsOk l)
	  andalso Vector.forall (cases, labelIsOk o #dst)
	  andalso Vector.isSorted (cases,
				   fn ({tycon = t, ...}, {tycon = t', ...}) =>
				   PointerTycon.index t <= PointerTycon.index t')
	  andalso
	  case Use.ty test of
	     Type.EnumPointers {enum, pointers} =>
		0 = Vector.length enum
		andalso 
		exhaustiveAndIrredundant {all = pointers,
					  cases = Vector.map (cases, #tycon),
					  default = default,
					  equals = PointerTycon.equals}
	   | _ => false)
    | Word {cases, default, test} =>
	 Type.equals (Use.ty test, Type.word)
	 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
	 not (isRedundant
	      {cases = cases,
	       equals = fn ((w, _), (w', _)) => w = w'})

fun foldLabelUse (s: t, a: 'a, {label, use}): 'a =
   let
      fun simple {cases, default, test} =
	 let
	    val a = use (test, a)
	    val a = Option.fold (default, a, label)
	    val a = Vector.fold (cases, a, fn ((_, l), a) =>
				 label (l, a))
	 in
	    a
	 end
   in
      case s of
	  Char z => simple z
        | EnumPointers {enum, pointers, test} =>
	  let
	     val a = use (test, a)
	     val a = label (enum, a)
	     val a = label (pointers, a)
	  in
	     a
	  end
	| Int z => simple z
	| Pointer {cases, default, tag, test} =>
	     let
		val a = use (tag, a)
		val a = use (test, a)
		val a = Option.fold (default, a, label)
		val a = Vector.fold (cases, a, fn ({dst, ...}, a) =>
				     label (dst, a))
	     in
		a
	     end
	| Word z => simple z
   end

fun foreachLabel (s, f) =
   foldLabelUse (s, (), {label = f o #1,
			 use = fn _ => ()})

end



1.1                  mlton/mlton/backend/switch.sig

Index: switch.sig
===================================================================
(* Copyright (C) 2002 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 *
 * MLton is released under the GNU General Public License (GPL).
 * Please see the file MLton-LICENSE for license information.
 *)

type int = Int.t
type word = Word.t
   
signature SWITCH_STRUCTS =
   sig
      include MACHINE_ATOMS

      structure Use: sig
			type t

			val layout: t -> Layout.t
			val ty: t -> Type.t
		     end
   end

signature SWITCH =
   sig
      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,
			  pointers: Label.t,
			  test: Use.t}
       | Int of {(* Cases are in increasing order of int. *)
		 cases: (int * Label.t) vector,
		 default: Label.t option,
		 test: Use.t}
       | Pointer of {(* Cases are in increasing order of tycon. *)
		     cases: {dst: Label.t,
			     tag: int,
			     tycon: PointerTycon.t} vector,
		     default: Label.t option,
		     tag: Use.t, (* of type int *)
		     test: Use.t}
       | Word of {(* Cases are in increasing order of tycon *)
		  cases: (word * Label.t) vector,
		  default: Label.t option,
		  test: Use.t}

      val foldLabelUse: t * 'a * {label: Label.t * 'a -> 'a,
				  use: Use.t * 'a -> 'a} -> 'a
      val foreachLabel: t * (Label.t -> unit) -> unit
      val isOk: t * {labelIsOk: Label.t -> bool} -> bool
      val layout: t -> Layout.t
   end




1.34      +135 -93   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.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- c-codegen.fun	22 Nov 2002 02:48:20 -0000	1.33
+++ c-codegen.fun	7 Dec 2002 02:21:52 -0000	1.34
@@ -14,18 +14,19 @@
    open Machine
 in
    structure Block = Block
-   structure Cases = Cases
    structure Chunk = Chunk
    structure ChunkLabel = ChunkLabel
    structure FrameInfo = FrameInfo
    structure Global = Global
    structure Kind = Kind
    structure Label = Label
+   structure ObjectType = ObjectType
    structure Operand = Operand
    structure Prim = Prim
    structure Register = Register
    structure Runtime = Runtime
    structure Statement = Statement
+   structure Switch = Switch
    structure Transfer = Transfer
    structure Type = Type
 end
@@ -35,7 +36,6 @@
 in
    structure CFunction = CFunction
    structure GCField = GCField
-   structure ObjectType = ObjectType
 end
 
 structure Kind =
@@ -92,10 +92,10 @@
 
       fun word (w: Word.t) = "0x" ^ Word.toString w
 
-      (* The only difference between SML floats and C floats is that
+      (* The only difference between SML reals and C floats/doubles is that
        * SML uses "~" while C uses "-".
        *)
-      fun float s = String.translate (s, fn #"~" => "-" | c => String.fromChar c)
+      fun real s = String.translate (s, fn #"~" => "-" | c => String.fromChar c)
 
       fun string s =
 	 let val quote = "\""
@@ -126,26 +126,29 @@
 	 fn ArrayOffset {base, index, ty} =>
 	       concat ["X", Type.name ty,
 		       C.args [toString base, toString index]]
-          | CastInt oper => concat ["PointerToInt", C.args [toString oper]]
-	  | CastWord oper => concat ["(word)", C.args [toString oper]]
+          | 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, ")"]
 	  | File => "__FILE__"
-          | Float s => C.float s
 	  | GCState => "&gcState"
-          | Global g => Global.toString g
-          | GlobalPointerNonRoot n =>
-	       concat ["globalpointerNonRoot [", C.int n, "]"]
-          | Int n => C.int n
-          | IntInf w =>
-	       concat ["SmallIntInf", C.args [concat ["0x", Word.toString w]]]
+          | 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
           | Label l => Label.toStringIndex l
 	  | Line => "__LINE__"
           | Offset {base, offset, ty} =>
 	       concat ["O", Type.name ty, C.args [toString base, C.int offset]]
-          | Pointer n => concat ["IntAsPointer", C.args [C.int n]]
-          | Register r => Register.toString r
+          | Real s => C.real s
+          | Register r =>
+	       concat ["R", Type.name (Register.ty r),
+		       "(", Int.toString (Register.index r), ")"]
 	  | Runtime r =>
 	       let
 		  datatype z = datatype GCField.t
@@ -164,14 +167,17 @@
 		   | StackLimit => "gcState.stackLimit"
 		   | StackTop => "stackTop"
 	       end
+          | SmallIntInf w =>
+	       concat ["SmallIntInf", C.args [concat ["0x", Word.toString w]]]
           | StackOffset {offset, ty} =>
 	       concat ["S", Type.name ty, "(", C.int offset, ")"]
-          | Uint w => C.word w
+          | Word w => C.word w
 
       val layout = Layout.str o toString
    end
 
-fun creturn (t: Type.t): string = concat ["CReturn", Type.name t]
+fun creturn (t: Runtime.Type.t): string =
+   concat ["CReturn", Runtime.Type.name t]
 
 fun outputDeclarations
    {additionalMainArgs: string list,
@@ -180,8 +186,8 @@
     name: string,
     print: string -> unit,
     program = (Machine.Program.T
-	       {chunks, frameOffsets, floats, globals, globalsNonRoot, intInfs,
-		maxFrameSize, objectTypes, strings, ...}),
+	       {chunks, frameOffsets, intInfs, maxFrameSize, objectTypes,
+		reals, strings, ...}),
     rest: unit -> unit
     }: unit =
    let
@@ -192,23 +198,11 @@
 	  ; print "\n")
       fun declareGlobals () =
 	 C.call ("Globals",
-		 List.map (List.map (let open Type
+		 List.map (List.map (let open Runtime.Type
 				     in [char, double, int, pointer, uint]
 				     end, 
-				     globals) @ [globalsNonRoot],
-			   C.int),
-		 print)
-      fun locals ty =
-	 List.fold (chunks, 0, fn (Machine.Chunk.T {regMax, ...}, max) =>
-		    if regMax ty > max
-		       then regMax ty
-		    else max)
-      fun declareLocals () =
-	 C.call ("Locals",
-		 List.map (List.map (let open Type
-				     in [char, double, int, pointer, uint]
-				     end,
-				     locals),
+				     Global.numberOfType)
+			   @ [Global.numberOfNonRoot ()],
 			   C.int),
 		 print)
       fun declareIntInfs () =
@@ -230,15 +224,15 @@
 					 print)
 			   ; print "\n"))
 	  ; print "EndStrings\n")
-      fun declareFloats () =
-	 (print "BeginFloats\n"
-	  ; List.foreach (floats, fn (g, f) =>
-			  (C.callNoSemi ("Float",
+      fun declareReals () =
+	 (print "BeginReals\n"
+	  ; List.foreach (reals, fn (g, f) =>
+			  (C.callNoSemi ("Real",
 					 [C.int (Global.index g),
-					  C.float f],
+					  C.real f],
 					 print)
 			   ; print "\n"))
-	  ; print "EndFloats\n")
+	  ; print "EndReals\n")
       fun declareFrameOffsets () =
 	 Vector.foreachi
 	 (frameOffsets, fn (i, v) =>
@@ -249,15 +243,16 @@
       fun declareObjectTypes () =
 	 (print (concat ["static GC_ObjectType objectTypes[] = {\n"])
 	  ; (Vector.foreach
-	     (objectTypes, fn t =>
+	     (objectTypes, fn ty =>
 	      let
+		 datatype z = datatype Runtime.ObjectType.t
 		 val (tag, nonPointers, pointers) =
-		    case t of
-		       ObjectType.Array {numBytesNonPointers, numPointers} =>
+		    case ObjectType.toRuntime ty of
+		       Array {numBytesNonPointers, numPointers} =>
 			  (0, numBytesNonPointers, numPointers)
-		     | ObjectType.Normal {numPointers, numWordsNonPointers} =>
+		     | Normal {numPointers, numWordsNonPointers} =>
 			  (1, numWordsNonPointers, numPointers)
-		     | ObjectType.Stack =>
+		     | Stack =>
 			  (2, 0, 0)
 	      in
 		 print (concat ["\t{ ", Int.toString tag, ", ",
@@ -283,10 +278,9 @@
       print (concat ["#define ", name, "CODEGEN\n\n"])
       ; outputIncludes ()
       ; declareGlobals ()
-      ; declareLocals ()
       ; declareIntInfs ()
       ; declareStrings ()
-      ; declareFloats ()
+      ; declareReals ()
       ; declareFrameOffsets ()
       ; declareObjectTypes ()
       ; rest ()
@@ -294,9 +288,7 @@
    end
 
 fun output {program as Machine.Program.T {chunks,
-					  frameOffsets,
-					  main = {chunkLabel, label},
-					  objectTypes, ...},
+					  main = {chunkLabel, label}, ...},
             includes,
 	    outputC: unit -> {file: File.t,
 			      print: string -> unit,
@@ -443,7 +435,7 @@
 			    C.call ("SetSlotExnStack", [C.int offset], print)
 			    ))
 	 end
-      fun outputChunk (Chunk.T {chunkLabel, blocks, regMax, ...}) =
+      fun outputChunk (chunk as Chunk.T {chunkLabel, blocks, ...}) =
 	 let
 	    fun labelFrameSize (l: Label.t): int =
 	       FrameInfo.size (valOf (labelFrameInfo l))
@@ -477,11 +469,7 @@
 		     | Goto dst => jump dst
 		     | Raise => ()
 		     | Return _ => ()
-		     | Switch {cases, default, ...} =>
-			  (Cases.foreach (cases, jump)
-			   ; Option.app (default, jump))
-		     | SwitchIP {int, pointer, ...} =>
-			  (jump int; jump pointer)
+		     | Switch s => Switch.foreachLabel (s, jump)
 		 end)
 	    fun push (return: Label.t, size: int) =
 	       (C.push (size, print)
@@ -509,10 +497,13 @@
 					concat ["tmp",
 						Int.toString (Counter.next c)]
 				     val _ =
-					print (concat ["\t", Type.toString ty,
-						       " ", tmp,
-						       " = ", Operand.toString z,
-						       ";\n"])
+					print (concat
+					       ["\t",
+						Runtime.Type.toString
+						(Type.toRuntime ty),
+						" ", tmp,
+						" = ", Operand.toString z,
+						";\n"])
 				  in
 				     tmp
 				  end
@@ -570,8 +561,10 @@
 			    else ()
 			    ; (Option.app
 			       (dst, fn x =>
-				print (concat ["\t", Operand.toString x, " = ",
-					       creturn (Operand.ty x), ";\n"]))))
+				print (concat
+				       ["\t", Operand.toString x, " = ",
+					creturn (Type.toRuntime (Operand.ty x)),
+					";\n"]))))
 		      | Kind.Func _ => ()
 		      | Kind.Handler {offset} => C.push (~offset, print)
 		      | Kind.Jump => ()
@@ -732,56 +725,105 @@
 		   | Goto dst => gotoLabel dst
 		   | Raise => C.call ("\tRaise", [], print)
 		   | Return _ => C.call ("\tReturn", [], print)
-		   | Switch {test, cases, default} =>
+		   | Switch switch =>
 			let 
-			   val test = Operand.toString test
-			   fun bool (t, f) = iff (test, t, f)
-			   fun doit (cases, f) =
+			   fun bool (test: Operand.t, t, f) =
+			      iff (Operand.toString test, t, f)
+			   fun doit {cases: (string * Label.t) vector,
+				     default: Label.t option,
+				     test: Operand.t}: unit =
 			      let
-				 fun switch (cases, l) =
+				 val test = Operand.toString test
+				 fun switch (cases: (string * Label.t) vector,
+					     default: Label.t): unit =
 				    (print "switch ("
 				     ; print test
 				     ; print ") {\n"
-				     ; (List.foreach
+				     ; (Vector.foreach
 					(cases, fn (n, l) => (print "case "
-							      ; print (f n)
+							      ; print n
 							      ; print ":\n"
 							      ; gotoLabel l)))
 				     ; print "default:\n"
-				     ; gotoLabel l
+				     ; gotoLabel default
 				     ; print "}\n")
 			      in
-				 case (cases,            default) of
-				    ([],               NONE) =>
+				 case (Vector.length cases, default) of
+				    (0, NONE) =>
 				       Error.bug "switch: empty cases"
-				  | ([(_, l)],         NONE)   => gotoLabel l
-				  | ([],               SOME l) => gotoLabel l
-				  | ((_, l) :: cases', NONE)   => switch (cases', l)
-				  | (_,                SOME l) => switch (cases, l)
+				  | (0, SOME l) => gotoLabel l
+				  | (1, NONE) =>
+				       gotoLabel (#2 (Vector.sub (cases, 0)))
+				  | (_, NONE) =>
+				       switch (Vector.dropPrefix (cases, 1),
+					       #2 (Vector.sub (cases, 0)))
+				  | (_, SOME l) => switch (cases, l)
 			      end
+			   fun simple ({cases, default, test}, f) =
+			      doit {cases = Vector.map (cases, fn (c, l) =>
+							(f c, l)),
+				    default = default,
+				    test = test}
+			   datatype z = datatype Switch.t
 			in
-			   case cases of
-			      Cases.Char l => doit (l, C.char)
-			    | Cases.Int l =>
-				 (case (l, default) of
-				     ([(0, f), (1, t)], NONE) => bool (t, f)
-				   | ([(1, t), (0, f)], NONE) => bool (t, f)
-				   | _ => doit (l, C.int))
-			    | Cases.Word l => doit (l, C.word)
+			   case switch of
+			      Char z => simple (z, C.char)
+			    | EnumPointers {enum, pointers, test} =>
+			      iff (concat
+				   ["IsInt (", Operand.toString test, ")"],
+				   enum, pointers)
+			    | Int (z as {cases, default, test}) =>
+				 let
+				    fun normal () = simple (z, C.int)
+				 in
+				    if 2 = Vector.length cases
+				       then
+					  let
+					     val c0 = Vector.sub (cases, 0)
+					     val c1 = 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 ()
+					  end
+				    else normal ()
+				 end
+			    | Pointer {cases, default, tag, ...} =>
+				 doit {cases = (Vector.map
+						(cases, fn {dst, tag, ...} =>
+						 (Int.toString tag, dst))),
+				       default = default,
+				       test = tag}
+			    | Word z => simple (z, C.word)
 			end
-		   | SwitchIP {test, int, pointer} =>
-			iff (concat ["IsInt (", Operand.toString test, ")"],
-			     int, pointer)
+	       end
+	    fun declareRegisters () =
+	       let
+		  val {get = seen, rem, set = setSeen} =
+		     Property.getSetOnce (Register.plist,
+					  Property.initConst false)
+		  val all =
+		     Chunk.foldRegs
+		     (chunk, [], fn (r, ac) =>
+		      if seen r
+			 then ac
+		      else (setSeen (r, true)
+			    ; r :: ac))
+	       in
+		  List.foreach
+		  (all, fn r =>
+		   (rem r
+		    ; C.call (concat ["D", Type.name (Register.ty r)],
+			      [C.int (Register.index r)],
+			      print)))
 	       end
 	 in
 	    C.callNoSemi ("Chunk", [ChunkLabel.toString chunkLabel], print)
+	    ; declareRegisters ()
 	    ; print "\n"
-	    (* Declare registers. *)
-	    ; List.foreach (Type.all, fn ty =>
-			    Int.for (0, regMax ty,
-				     fn i => C.call (concat ["D", Type.name ty],
-						     [C.int i],
-						     print)))
 	    ; print "ChunkSwitch\n"
 	    ; Vector.foreach (blocks, fn Block.T {kind, label, ...} =>
 			      if Kind.isEntry kind



1.30      +45 -15    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.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- x86-codegen.fun	2 Nov 2002 03:37:40 -0000	1.29
+++ x86-codegen.fun	7 Dec 2002 02:21:53 -0000	1.30
@@ -78,20 +78,16 @@
 
   open x86
   structure Type = Machine.Type
-  fun output {program as Machine.Program.T 
-	                 {chunks,
-			  floats, 
-			  frameOffsets,
-			  globals,
-			  globalsNonRoot,
-			  handlesSignals,
-			  intInfs,
-			  main,
-			  maxFrameSize,
-			  profileAllocLabels,
-			  strings,
-			  ...}: Machine.Program.t,
-	      includes: string list,
+  fun output {program as Machine.Program.T {chunks,
+					    frameOffsets,
+					    handlesSignals,
+					    intInfs,
+					    main,
+					    maxFrameSize,
+					    profileAllocLabels,
+					    strings,
+					    ...},
+              includes: string list,
 	      outputC,
 	      outputS}: unit
     = let
@@ -269,8 +265,42 @@
 		     if reserveEsp then C.truee else C.falsee,
 		     a1, a2, a3]
 		 end
+	      fun declareLocals () =
+		 let
+		    val tyMax = Runtime.Type.memo (fn _ => ref 0)
+		    val {get = seen, rem, set = setSeen} =
+		       Property.getSetOnce (Machine.Register.plist,
+					    Property.initConst false)
+		    val all =
+		       Machine.Program.foldRegs
+		       (program, [], fn (r, ac) =>
+			if seen r
+			   then ac
+			else let
+				val _ = setSeen (r, true)
+				val m = tyMax (Machine.Type.toRuntime
+					       (Machine.Register.ty r))
+				val n = Machine.Register.index r
+				val _ =
+				   if n > !m
+				      then m := n
+				   else ()
+			     in
+				r :: ac
+			     end)
+		    val _ = List.foreach (all, rem)
+		 in
+		    print
+		    (concat ["Locals",
+			     Layout.toString
+			     (Layout.tuple (List.map
+					    (Runtime.Type.all, fn t =>
+					     Int.layout (! (tyMax t))))),
+			     ";\n"])
+		 end
 	      fun rest () =
-		 (declareFrameLayouts()
+		 (declareLocals ()
+		  ; declareFrameLayouts ()
 		  ; print "extern uint profileAllocLabels;\n")
 	    in
 	      CCodegen.outputDeclarations



1.8       +7 -7      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.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- x86-mlton-basic.fun	2 Nov 2002 03:37:40 -0000	1.7
+++ x86-mlton-basic.fun	7 Dec 2002 02:21:53 -0000	1.8
@@ -29,7 +29,7 @@
   val intInfOverheadBytes = Runtime.intInfOverheadSize
    
   local
-    open Machine.Type
+     datatype z = datatype Runtime.Type.dest
   in
     fun toX86Size' t
       = case t
@@ -38,7 +38,7 @@
 	   | Int => x86.Size.LONG
 	   | Pointer => x86.Size.LONG
 	   | Uint => x86.Size.LONG
-    val toX86Size = fn t => toX86Size' (dest t)
+    val toX86Size = fn t => toX86Size' (Runtime.Type.dest t)
     fun toX86Scale' t
       = case t
 	  of Char => x86.Scale.One
@@ -46,7 +46,7 @@
 	   | Int => x86.Scale.Four
 	   | Pointer => x86.Scale.Four
 	   | Uint => x86.Scale.Four
-    val toX86Scale = fn t => toX86Scale' (dest t)
+    val toX86Scale = fn t => toX86Scale' (Runtime.Type.dest t)
   end
 
   (*
@@ -242,15 +242,15 @@
     = Operand.memloc fpswTempContents
 
   local
-    open Machine.Type
     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"
+    datatype z = datatype Runtime.Type.dest
   in
     fun local_base ty
-      = case dest ty
+      = case Runtime.Type.dest ty
 	  of Char    => localC_base
 	   | Double  => localD_base
 	   | Int     => localI_base
@@ -259,7 +259,6 @@
   end
 
   local
-    open Machine.Type
     val globalC_base = Label.fromString "globaluchar"
     val globalC_num = Label.fromString "num_globaluchar"
     val globalD_base = Label.fromString "globaldouble"
@@ -270,9 +269,10 @@
     val globalP_num = Label.fromString "num_globalpointer"
     val globalU_base = Label.fromString "globaluint"
     val globalU_num = Label.fromString "num_globaluint"
+    datatype z = datatype Runtime.Type.dest
   in
     fun global_base ty
-      = case dest ty
+      = case Runtime.Type.dest ty
 	  of Char    => globalC_base
 	   | Double  => globalD_base
 	   | Int     => globalI_base



1.17      +4 -4      mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig

Index: x86-mlton-basic.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- x86-mlton-basic.sig	2 Nov 2002 03:37:40 -0000	1.16
+++ x86-mlton-basic.sig	7 Dec 2002 02:21:53 -0000	1.17
@@ -35,8 +35,8 @@
     val arrayHeaderBytes : int
     val intInfOverheadBytes : int
 
-    val toX86Size : Machine.Type.t -> x86.Size.t
-    val toX86Scale : Machine.Type.t -> x86.Scale.t
+    val toX86Size : x86.Runtime.Type.t -> x86.Size.t
+    val toX86Scale : x86.Runtime.Type.t -> x86.Scale.t
 
     (*
      * Memory classes
@@ -86,8 +86,8 @@
     val statusTempContentsOperand : x86.Operand.t
 
     (* Static arrays defined in x86codegen.h *)
-    val local_base : Machine.Type.t -> x86.Label.t
-    val global_base : Machine.Type.t -> x86.Label.t
+    val local_base : x86.Runtime.Type.t -> x86.Label.t
+    val global_base : x86.Runtime.Type.t -> x86.Label.t
     val globalPointerNonRoot_base : x86.Label.t
 
     (* Static functions defined in x86codegen.h *)



1.38      +1 -11     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.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- x86-mlton.fun	24 Nov 2002 01:19:43 -0000	1.37
+++ x86-mlton.fun	7 Dec 2002 02:21:53 -0000	1.38
@@ -710,9 +710,7 @@
 	[comment_begin,
 	 (case Prim.name prim of
 	       Array_length => lengthArrayVectorString ()
-	     | Byte_byteToChar => mov ()
-	     | Byte_charToByte => mov ()
-	     | C_CS_charArrayToWord8Array => mov ()
+
 	     | Char_lt => cmp Instruction.B
 	     | Char_le => cmp Instruction.BE
 	     | Char_gt => cmp Instruction.A
@@ -783,10 +781,6 @@
 	     | Int_ge => cmp Instruction.GE
 	     | Int_gtu => cmp Instruction.A
 	     | Int_geu => cmp Instruction.AE
-	     | IntInf_fromVector => mov ()
-	     | IntInf_toVector => mov ()
-	     | IntInf_fromWord => mov ()
-	     | IntInf_toWord => mov ()
 	     | MLton_eq => cmp Instruction.E
 	     | MLton_serialize => unimplemented primName
 	     | MLton_deserialize => unimplemented primName
@@ -1303,8 +1297,6 @@
 		end
 	     | Real_neg => funa Instruction.FCHS
 	     | Real_round => funa Instruction.FRNDINT
-	     | String_fromWord8Vector => mov ()
-	     | String_toWord8Vector => mov ()
 	     | Vector_length => lengthArrayVectorString ()
 	     | Word8_toInt => movx Instruction.MOVZX
 	     | Word8_toIntX => movx Instruction.MOVSX
@@ -1334,8 +1326,6 @@
 	     | Word8Array_subWord => subWord8ArrayVector ()
 	     | Word8Array_updateWord => updateWord8Array ()
 	     | Word8Vector_subWord => subWord8ArrayVector ()
-	     | Word32_toIntX => mov ()
-	     | Word32_fromInt => mov ()
 	     | Word32_add => binal Instruction.ADD
 	     | Word32_sub => binal Instruction.SUB
 	     | Word32_andb => binal Instruction.AND



1.31      +208 -240  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.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- x86-translate.fun	4 Nov 2002 15:08:11 -0000	1.30
+++ x86-translate.fun	7 Dec 2002 02:21:53 -0000	1.31
@@ -28,213 +28,182 @@
   structure Prim = Machine.Prim
   structure Runtime = Machine.Runtime
     
-  structure Type =
-    struct
-      open Machine.Type
-      fun name t = case dest t 
-		     of Char => "C"
-		      | Double => "D"
-		      | Int => "I"
-		      | Pointer => "P"
-		      | Uint => "U"
-    end
+  structure Type = Machine.Type
     
   structure Local =
-    struct
-      open Machine.Register
-
-      fun toX86MemLoc (T{index, ty})
-	= let
-	    val base
-	      = x86.Immediate.label (x86MLton.local_base ty)
-	  in
-	    x86.MemLoc.imm {base = base,
-			    index = x86.Immediate.const_int index,
-			    scale = x86MLton.toX86Scale ty,
-			    size = x86MLton.toX86Size ty,
-			    class = x86MLton.Classes.Locals}
-	  end
+     struct
+	open Machine.Register
 
-      fun eq(T{index = index1, ty = ty1},T{index = index2, ty = ty2})
-	= Type.equals(ty1, ty2) 
-	  andalso index1 = index2
+	fun toX86MemLoc (r: t) =
+	   let
+	      val ty = Machine.Type.toRuntime (ty r)
+	      val base = x86.Immediate.label (x86MLton.local_base ty)
+	   in
+	      x86.MemLoc.imm {base = base,
+			      index = x86.Immediate.const_int (index r),
+			      scale = x86MLton.toX86Scale ty,
+			      size = x86MLton.toX86Size ty,
+			      class = x86MLton.Classes.Locals}
+	   end
 
-      val toString = Layout.toString o layout
-    end
+	val eq = equals
+     end
   
   structure Global =
-    struct
-      open Machine.Global
+     struct
+	open Machine.Global
 
-      fun toX86MemLoc (T{index, ty})
-	= let
-	    val base
-	      = x86.Immediate.label (x86MLton.global_base ty)
-	  in
-	    x86.MemLoc.imm {base = base,
-			    index = x86.Immediate.const_int index,
-			    scale = x86MLton.toX86Scale ty,
-			    size = x86MLton.toX86Size ty,
-			    class = x86MLton.Classes.Globals}
-	  end
+	fun toX86MemLoc (g: t) =
+	   let
+	      val ty = Machine.Type.toRuntime (ty g)
+	      val base =
+		 x86.Immediate.label
+		 (if isRoot g
+		     then x86MLton.global_base ty
+		  else x86MLton.globalPointerNonRoot_base)
+	   in
+	      x86.MemLoc.imm {base = base,
+			      index = x86.Immediate.const_int (index g),
+			      scale = x86MLton.toX86Scale ty,
+			      size = x86MLton.toX86Size ty,
+			      class = x86MLton.Classes.Globals}
+	   end
 
-      val toString = Layout.toString o layout
-    end
+	val toString = Layout.toString o layout
+     end
 
   structure Operand =
     struct
       open Machine.Operand
 
-      val toX86Size = x86MLton.toX86Size o ty
+      val toX86Size = x86MLton.toX86Size o Type.toRuntime o ty
 
-      val rec toX86Operand
-	= fn Char c 
-	   => x86.Operand.immediate_const_char c
-	   | Int i 
-	   => x86.Operand.immediate_const_int i
-	   | Uint w
-	   => x86.Operand.immediate_const_word w
-	   | IntInf ii
-	   => x86.Operand.immediate_const_word ii
-	   | File => x86MLton.fileName
-	   | Float f
-	     => Error.bug "toX86Operand: Float, unimplemented"
-	   | GCState => x86.Operand.label x86MLton.gcState_label
-	   | Pointer i
-	   => x86.Operand.immediate_const_int i
-	   | Label l
-	   => x86.Operand.immediate_label l
-	   | Line => x86MLton.fileLine ()
-	   | CastInt p
-	   => toX86Operand p
-	   | CastWord p
-	   => toX86Operand p
-	   | Register l
-	   => x86.Operand.memloc (Local.toX86MemLoc l)
-	   | Global g
-	   => x86.Operand.memloc (Global.toX86MemLoc g)
-	   | GlobalPointerNonRoot i
-           => let
-		val base
-		  = x86.Immediate.label (x86MLton.globalPointerNonRoot_base)
-		val memloc 
-		  = x86.MemLoc.imm 
-		    {base = base,
-		     index = x86.Immediate.const_int i,
-		     scale = x86MLton.pointerScale,
-		     size = x86MLton.pointerSize,
-		     class = x86MLton.Classes.Globals}
-	      in
-		x86.Operand.memloc memloc
-	      end
-	   | Runtime oper 
-	   => let
-		datatype z = datatype Machine.Runtime.GCField.t
-		open x86MLton
-	      in
-		case oper of
-		   CanHandle => gcState_canHandleContentsOperand ()
-		 | CardMap => gcState_cardMapContentsOperand ()
-		 | CurrentThread => gcState_currentThreadContentsOperand ()
-		 | Frontier => gcState_frontierContentsOperand ()
-		 | Limit => gcState_limitContentsOperand ()
-		 | LimitPlusSlop => gcState_limitPlusSlopContentsOperand ()
-		 | MaxFrameSize => gcState_maxFrameSizeContentsOperand ()
-		 | ProfileAllocIndex => gcState_profileAllocIndexContentsOperand ()
-		 | SignalIsPending => gcState_signalIsPendingContentsOperand ()
-		 | StackBottom => gcState_stackBottomContentsOperand ()
-		 | StackLimit => gcState_stackLimitContentsOperand ()
-		 | StackTop => gcState_stackTopContentsOperand ()
-	      end
-	   | StackOffset {offset, ty}
-	   => let
-		val memloc 
-		  = x86.MemLoc.simple 
-		    {base = x86MLton.gcState_stackTopContents (), 
-		     index = x86.Immediate.const_int offset,
-		     scale = x86.Scale.One,
-		     size = x86MLton.toX86Size ty,
-		     class = x86MLton.Classes.Stack}
-	      in
-		x86.Operand.memloc memloc
-	      end
-	   | Offset {base, offset, ty}
-	   => let
-		val base = toX86Operand base
-		val memloc
-		  =  case x86.Operand.deMemloc base
-		       of SOME base
-			=> x86.MemLoc.simple 
+      val rec toX86Operand =
+	 fn ArrayOffset {base, index, ty} =>
+	       let
+		  val base = toX86Operand base
+		  val index = toX86Operand index
+		  val ty = Type.toRuntime ty
+		  val memloc =
+		     case (x86.Operand.deMemloc base,
+			   x86.Operand.deImmediate index,
+			   x86.Operand.deMemloc index) of
+			(SOME base, SOME index, _) =>
+			   x86.MemLoc.simple 
 			   {base = base,
-			    index = x86.Immediate.const_int offset,
-			    scale = x86.Scale.One,
+			    index = index,
+			    scale = x86MLton.toX86Scale ty,
 			    size = x86MLton.toX86Size ty,
 			    class = x86MLton.Classes.Heap}
-		        | _
-			=> Error.bug ("toX86Operand: strange Offset:" ^
-				      " base: " ^
-				      (x86.Operand.toString base))
-	      in
-		x86.Operand.memloc memloc
-	      end
-	   | ArrayOffset {base, index, ty}
-	   => let
-		val base = toX86Operand base
-		val index = toX86Operand index
-
-		val memloc
-		  = case (x86.Operand.deMemloc base,
-			  x86.Operand.deImmediate index,
-			  x86.Operand.deMemloc index)
-		       of (SOME base, SOME index, _)
-		        => x86.MemLoc.simple 
+		      | (SOME base, _, SOME index) =>
+			   x86.MemLoc.complex 
 			   {base = base,
 			    index = index,
 			    scale = x86MLton.toX86Scale ty,
 			    size = x86MLton.toX86Size ty,
 			    class = x86MLton.Classes.Heap}
-			| (SOME base, _, SOME index)
-		        => x86.MemLoc.complex 
+		      | _ => Error.bug (concat ["toX86Operand: strange Offset:",
+						" base: ",
+						x86.Operand.toString base,
+						" index: ",
+						x86.Operand.toString index])
+	       in
+		  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
+		  val base = toX86Operand oper
+		  val offset = x86.Immediate.const_int 0
+		  val size = x86MLton.toX86Size ty
+		  val memloc =
+		     case x86.Operand.deMemloc base of
+			SOME base =>
+			   x86.MemLoc.simple 
 			   {base = base,
-			    index = index,
-			    scale = x86MLton.toX86Scale ty,
+			    index = x86.Immediate.const_int 0,
+			    scale = x86.Scale.One,
 			    size = x86MLton.toX86Size ty,
 			    class = x86MLton.Classes.Heap}
-			| _
-			=> Error.bug ("toX86Operand: strange Offset:" ^
-				      " base: " ^
-				      (x86.Operand.toString base) ^
-				      " index: " ^
-				      (x86.Operand.toString index))
-	      in
-		x86.Operand.memloc memloc
-	      end
-	   | Contents {oper, ty}
-	   => let
-		val base = toX86Operand oper
-		val offset = x86.Immediate.const_int 0
-		val size = x86MLton.toX86Size ty
-
-		val memloc
-		  = case x86.Operand.deMemloc base
-		      of SOME base
-		       => x86.MemLoc.simple 
-			  {base = base,
-			   index = x86.Immediate.const_int 0,
-			   scale = x86.Scale.One,
-			   size = x86MLton.toX86Size ty,
-			   class = x86MLton.Classes.Heap}
-		       | _
-		       => Error.bug ("toX86Operand: strange Contents" ^
-				     " base: " ^
-				      (x86.Operand.toString base))
-	      in
-		x86.Operand.memloc memloc
-	      end
-      val toX86Operand 
-	= fn operand => (toX86Operand operand)
-	                handle exn
-			 => Error.reraise (exn, "x86Translate.Operand.toX86Operand")
+		      | _ => Error.bug (concat
+					["toX86Operand: strange Contents",
+					 " base: ",
+					 x86.Operand.toString base])
+	       in
+		  x86.Operand.memloc memloc
+	       end
+	  | File => x86MLton.fileName
+	  | GCState => x86.Operand.label x86MLton.gcState_label
+	  | Global g => x86.Operand.memloc (Global.toX86MemLoc g)
+	  | Int i => x86.Operand.immediate_const_int i
+	  | Label l => x86.Operand.immediate_label l
+	  | Line => x86MLton.fileLine ()
+	  | Offset {base, offset, ty} =>
+	       let
+		  val base = toX86Operand base
+		  val ty = Type.toRuntime ty
+		  val memloc =
+		     case x86.Operand.deMemloc base of
+			SOME base =>
+			   x86.MemLoc.simple 
+			   {base = base,
+			    index = x86.Immediate.const_int offset,
+			    scale = x86.Scale.One,
+			    size = x86MLton.toX86Size ty,
+			    class = x86MLton.Classes.Heap}
+		      | _ => Error.bug (concat ["toX86Operand: strange Offset:",
+						" base: ",
+						x86.Operand.toString base])
+	       in
+		  x86.Operand.memloc memloc
+	       end
+	  | Real _ => Error.bug "toX86Operand: Real unimplemented"
+	  | Register l => x86.Operand.memloc (Local.toX86MemLoc l)
+	  | Runtime oper =>
+		let
+		   datatype z = datatype Machine.Runtime.GCField.t
+		   open x86MLton
+		in
+		   case oper of
+		      CanHandle => gcState_canHandleContentsOperand ()
+		    | CardMap => gcState_cardMapContentsOperand ()
+		    | CurrentThread => gcState_currentThreadContentsOperand ()
+		    | Frontier => gcState_frontierContentsOperand ()
+		    | Limit => gcState_limitContentsOperand ()
+		    | LimitPlusSlop => gcState_limitPlusSlopContentsOperand ()
+		    | MaxFrameSize => gcState_maxFrameSizeContentsOperand ()
+		    | ProfileAllocIndex =>
+			 gcState_profileAllocIndexContentsOperand ()
+		    | SignalIsPending =>
+			 gcState_signalIsPendingContentsOperand ()
+		    | StackBottom => gcState_stackBottomContentsOperand ()
+		    | StackLimit => gcState_stackLimitContentsOperand ()
+		    | StackTop => gcState_stackTopContentsOperand ()
+		end
+	  | SmallIntInf ii => x86.Operand.immediate_const_word ii
+	  | StackOffset {offset, ty} =>
+	       let
+		  val ty = Type.toRuntime ty
+		  val memloc =
+		     x86.MemLoc.simple 
+		     {base = x86MLton.gcState_stackTopContents (), 
+		      index = x86.Immediate.const_int offset,
+		      scale = x86.Scale.One,
+		      size = x86MLton.toX86Size ty,
+		      class = x86MLton.Classes.Stack}
+	       in
+		  x86.Operand.memloc memloc
+	       end
+	  | Word w => x86.Operand.immediate_const_word w
+	       
+      val toX86Operand =
+	 fn operand =>
+	 toX86Operand operand
+	 handle exn => Error.reraise (exn, "x86Translate.Operand.toX86Operand")
+
+      fun convert x = (toX86Operand x, toX86Size x)
     end
 
   type transInfo = x86MLton.transInfo
@@ -320,11 +289,8 @@
 		     transfer = NONE})
 		 end
 	      | Kind.CReturn {dst, frameInfo, func}
-	      => let
-		   fun convert x
-		     = (Operand.toX86Operand x,
-			x86MLton.toX86Size (Operand.ty x))
-		   val dst = Option.map (dst, convert)
+		=> let
+		   val dst = Option.map (dst, Operand.convert)
 		 in
 		   x86MLton.creturn
 		   {dst = dst,
@@ -408,15 +374,9 @@
 		 end 
 	      | PrimApp {dst, prim, args}
    	      => let
-		   val (comment_begin,
-			comment_end) = comments statement
-		   fun convert x
-		     = (Operand.toX86Operand x,
-			x86MLton.toX86Size (Operand.ty x))
-
-		   val args = Vector.map(args, convert)
-		     
-		   val dst = Option.map(dst, convert)
+		   val (comment_begin, comment_end) = comments statement
+		   val args = Vector.map (args, Operand.convert)
+		   val dst = Option.map (dst, Operand.convert)
 		 in
 		   AppendList.appends
 		   [comment_begin,
@@ -563,7 +523,9 @@
 		       
 		   fun stores_toX86Assembly ({offset, value}, l)
 		     = let
-			 val size = x86MLton.toX86Size (Operand.ty value)
+			 val size =
+			    x86MLton.toX86Size
+			    (Type.toRuntime (Operand.ty value))
 			 val value = Operand.toX86Operand value
 			 val dst
 			   = let
@@ -781,15 +743,13 @@
 		 end
 	    else AppendList.empty
 
+	 
       fun toX86Blocks {transfer, transInfo as {...} : transInfo}
 	= (case transfer
 	     of Arith {prim, args, dst, overflow, success, ty}
 	      => let
-		   fun convert x
-		     = (Operand.toX86Operand x,
-			x86MLton.toX86Size (Operand.ty x))
-		   val args = Vector.map(args, convert)
-		   val dst = convert dst
+		   val args = Vector.map (args, Operand.convert)
+		   val dst = Operand.convert dst
 		 in
 		   AppendList.append
 		   (comments transfer,
@@ -802,10 +762,7 @@
 		 end
 	      | CCall {args, frameInfo, func, return}
 	      => let
-		   fun convert x
-		     = (Operand.toX86Operand x,
-			x86MLton.toX86Size (Operand.ty x))
-		   val args = Vector.map (args, convert)
+		   val args = Vector.map (args, Operand.convert)
 		 in
 		   AppendList.append
 		   (comments transfer,	
@@ -855,40 +812,51 @@
 				(x86.MemLocSet.empty,
 				 x86MLton.gcState_stackBottomContents ()),
 				x86MLton.gcState_currentThread_exnStackContents ())})}))
-	      | Switch {test, cases, default}
-	      => AppendList.append
-	         (comments transfer,
-		  (case cases 
-		     of Machine.Cases.Char cases 
-		      => doSwitchChar (test,cases,default)
-		      | Machine.Cases.Int cases 
-		      => doSwitchInt (test,cases,default)
-	              | Machine.Cases.Word cases 
-	              => doSwitchWord (test,cases,default)))
-	      | SwitchIP {test, int, pointer}
-	      => let
-		   val size = Operand.toX86Size test
-		   val test = Operand.toX86Operand test
-		 in
-		   AppendList.append
-		   (comments transfer,
-		    AppendList.single
-		    ((* if (test & 0x3) goto int 
-		      * goto pointer
-		      *)
-		     x86.Block.T'
-		     {entry = NONE,
-		      profileInfo = x86.ProfileInfo.none,
-		      statements 
-		      = [x86.Assembly.instruction_test
-			 {src1 = test,
-			  src2 = x86.Operand.immediate_const_word 0wx3,
-			  size = size}],
-		      transfer 
-		      = SOME (x86.Transfer.iff
-			      {condition = x86.Instruction.NZ,
-			       truee = int,
-			       falsee = pointer})}))
+	      | Switch switch
+              => let
+		    datatype z = datatype Machine.Switch.t
+		    fun simple ({cases, default, test}, doSwitch) =
+		       AppendList.append
+		       (comments transfer,
+			doSwitch (test, Vector.toList cases, default))
+			
+		 in
+		    case switch of
+		       Char z => simple (z, doSwitchChar)
+		     | EnumPointers {enum, pointers, test} =>
+			  let
+			     val size = Operand.toX86Size test
+			     val test = Operand.toX86Operand test
+			  in
+			     AppendList.append
+			     (comments transfer,
+			      AppendList.single
+			      ((* if (test & 0x3) goto int 
+				* goto pointer
+				*)
+			       x86.Block.T'
+			       {entry = NONE,
+				profileInfo = x86.ProfileInfo.none,
+				statements 
+				= [x86.Assembly.instruction_test
+				   {src1 = test,
+				    src2 = x86.Operand.immediate_const_word 0wx3,
+				    size = size}],
+				transfer 
+				= SOME (x86.Transfer.iff
+					{condition = x86.Instruction.NZ,
+					 truee = enum,
+					 falsee = pointers})}))
+			  end
+		     | Int z => simple (z, doSwitchInt)
+		     | Pointer {cases, default, tag, ...} =>
+			  simple ({cases = (Vector.map
+					    (cases, fn {dst, tag, ...} =>
+					     (tag, dst))),
+				   default = default,
+				   test = tag},
+				  doSwitchInt)
+		     | Word z => simple (z, doSwitchWord)
 		 end
 	      | Goto label
 	      => (AppendList.append



1.22      +1 -1      mlton/mlton/codegen/x86-codegen/x86.sig

Index: x86.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.sig,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- x86.sig	2 Nov 2002 03:37:40 -0000	1.21
+++ x86.sig	7 Dec 2002 02:21:53 -0000	1.22
@@ -10,7 +10,7 @@
 
 signature X86_STRUCTS =
   sig
-    structure Label : HASH_ID
+    structure Label: HASH_ID
     structure Runtime: RUNTIME
   end
 



1.57      +3 -0      mlton/mlton/control/control.sig

Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -r1.56 -r1.57
--- control.sig	24 Nov 2002 01:19:43 -0000	1.56
+++ control.sig	7 Dec 2002 02:21:53 -0000	1.57
@@ -88,6 +88,9 @@
       (* call count instrumentation *)
       val instrument: bool ref
 
+      (* Save the RSSA to a file. *)
+      val keepRSSA: bool ref
+	 
       (* Save the SSA to a file. *)
       val keepSSA: bool ref
 	 



1.73      +5 -1      mlton/mlton/control/control.sml

Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.72
retrieving revision 1.73
diff -u -r1.72 -r1.73
--- control.sml	24 Nov 2002 23:15:10 -0000	1.72
+++ control.sml	7 Dec 2002 02:21:53 -0000	1.73
@@ -182,7 +182,11 @@
 			      default = false,
 			      toString = Bool.toString}
 
-val keepSSA = control {name = "keepSSA",
+val keepRSSA = control {name = "keep RSSA",
+			default = false,
+			toString = Bool.toString}
+
+val keepSSA = control {name = "keep SSA",
 		       default = false,
 		       toString = Bool.toString}
 



1.9       +10 -11    mlton/mlton/elaborate/elaborate-env.fun

Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- elaborate-env.fun	24 Nov 2002 01:19:44 -0000	1.8
+++ elaborate-env.fun	7 Dec 2002 02:21:53 -0000	1.9
@@ -543,11 +543,10 @@
 				   handleVal = handleVal})
 			   fun doit (elts, less) =
 			      Info.T
-			      (Array.fromList
-			       (MergeSort.sort
-				(!elts,
-				 fn ({values = v, ...}, {values = v', ...}) =>
-				 less (Values.domain v, Values.domain v'))))
+			      (QuickSort.sortArray
+			       (Array.fromList (!elts),
+				fn ({values = v, ...}, {values = v', ...}) =>
+				less (Values.domain v, Values.domain v')))
 			in
 			   T {shapeId = SOME shapeId',
 			      strs = doit (strs, Ast.Strid.<=),
@@ -621,10 +620,10 @@
 			       end)
 	       val _ = current := old
 	       val a =
-		  Array.fromList
-		  (MergeSort.sort
-		   (elts, fn ({values = v, ...}, {values = v', ...}) =>
-		    le (Values.domain v, Values.domain v')))
+		  QuickSort.sortArray
+		  (Array.fromList elts,
+		   fn ({values = v, ...}, {values = v', ...}) =>
+		   le (Values.domain v, Values.domain v'))
 	    in
 	       Structure.Info.T a
 	    end
@@ -747,7 +746,7 @@
 		case !ranges of
 		   [] => ac
 		 | {value, ...} :: _ => (domain, value) :: ac)
-	 in align (List.map (MergeSort.sort
+	 in align (List.map (QuickSort.sortList
 			     (l, fn ((d, _), (d', _)) => le (d, d')),
 			     layout))
 	 end
@@ -777,7 +776,7 @@
 		      else ac)
 	 in
 	    align (List.map
-		   (MergeSort.sort
+		   (QuickSort.sortList
 		    (all, fn ((d, _), (d', _)) => le (d, d')),
 		    #2))
 	 end



1.40      +12 -14    mlton/mlton/main/compile.sml

Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- compile.sml	25 Nov 2002 15:13:47 -0000	1.39
+++ compile.sml	7 Dec 2002 02:21:53 -0000	1.40
@@ -19,10 +19,13 @@
 structure Xml = Xml (open Atoms)
 structure Sxml = Xml
 structure Ssa = Ssa (open Atoms)
-structure Runtime = Runtime ()
 structure Machine = Machine (structure Label = Ssa.Label
-			     structure Prim = Atoms.Prim
-			     structure Runtime = Runtime)
+			     structure Prim = Atoms.Prim)
+local
+   open Machine
+in
+   structure Runtime = Runtime
+end
 
 (*---------------------------------------------------*)
 (*                  Compiler Passes                  *)
@@ -436,17 +439,12 @@
 	  display = Control.Layouts Ssa.Program.layouts,
 	  simplify = Ssa.simplify}
       val _ =
-	 let open Control
-	 in if !keepSSA
-	       then
-		  File.withOut
-		  (concat [!inputFile, ".ssa"], fn out =>
-		   let
-		      fun disp l = Layout.outputl (l, out)
-		   in
-		      outputHeader (No, disp)
-		      ; Ssa.Program.layouts (ssa, disp)
-		   end)
+	 let
+	    open Control
+	 in
+	    if !keepSSA
+	       then saveToFile ({suffix = "ssa"}, No, ssa,
+				 Layouts Ssa.Program.layouts)
 	    else ()
 	 end
       val machine =



1.101     +1 -0      mlton/mlton/main/main.sml

Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.100
retrieving revision 1.101
diff -u -r1.100 -r1.101
--- main.sml	24 Nov 2002 23:15:10 -0000	1.100
+++ main.sml	7 Dec 2002 02:21:53 -0000	1.101
@@ -170,6 +170,7 @@
 		      | "g" => keepGenerated := true
 		      | "o" => keepO := true
 		      | "sml" => keepSML := true
+		      | "rssa" => keepRSSA := true
 		      | "ssa" => keepSSA := true
 		      | _ => usage (concat ["invalid -keep flag: ", s]))),
        (Expert, "keep-pass", " pass", "keep the results of pass",



1.16      +1 -1      mlton/mlton/ssa/analyze.fun

Index: analyze.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/analyze.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- analyze.fun	7 Jul 2002 21:41:51 -0000	1.15
+++ analyze.fun	7 Dec 2002 02:21:53 -0000	1.16
@@ -22,7 +22,7 @@
       val unit = fromType Type.unit
       fun coerces (from, to) =
 	 Vector.foreach2 (from, to, fn (from, to) =>
-			 coerce {from = from, to = to})
+			  coerce {from = from, to = to})
       val {get = value: Var.t -> 'a, set = setValue, ...} =
 	 Property.getSetOnce
 	 (Var.plist,



1.12      +3 -8      mlton/mlton/ssa/constant-propagation.fun

Index: constant-propagation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/constant-propagation.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- constant-propagation.fun	24 Nov 2002 01:19:44 -0000	1.11
+++ constant-propagation.fun	7 Dec 2002 02:21:54 -0000	1.12
@@ -365,13 +365,9 @@
 			  | Array {birth, length, ...} =>
 			       unary (birth, fn _ => length,
 				      fn {args, targs} =>
-				      if isZero length
-					 then Exp.PrimApp {args = Vector.new0 (),
-							   prim = Prim.array0,
-							   targs = targs}
-				      else Exp.PrimApp {args = args,
-							prim = Prim.array,
-							targs = targs},
+				      Exp.PrimApp {args = args,
+						   prim = Prim.array,
+						   targs = targs},
 				      Type.dearray ty)
 			  | Vector _ => No
 			  | Tuple vs =>
@@ -773,7 +769,6 @@
 	    in
 	       case Prim.name prim of
 		  Array_array => array (arg 0, bear ())
-		| Array_array0 => array (zero, bear ())
 		| Array_array0Const => array (zero, Birth.here ())
 		| Array_length => arrayLength (arg 0)
 		| Array_sub => dearray (arg 0)



1.46      +2 -1      mlton/mlton/ssa/ssa-tree.fun

Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- ssa-tree.fun	24 Nov 2002 01:19:44 -0000	1.45
+++ ssa-tree.fun	7 Dec 2002 02:21:54 -0000	1.46
@@ -812,7 +812,8 @@
    end
 datatype z = datatype Transfer.t
 
-local open Layout
+local
+   open Layout
 in
    fun layoutFormals (xts: (Var.t * Type.t) vector) =
       Vector.layout (fn (x, t) =>



1.39      +1 -1      mlton/mlton/ssa/ssa-tree.sig

Index: ssa-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.sig,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- ssa-tree.sig	24 Nov 2002 01:19:44 -0000	1.38
+++ ssa-tree.sig	7 Dec 2002 02:21:54 -0000	1.39
@@ -282,8 +282,8 @@
 	    datatype t =
 	       T of {
 		     datatypes: Datatype.t vector,
-		     globals: Statement.t vector,
 		     functions: Function.t list,
+		     globals: Statement.t vector,
 		     main: Func.t (* Must be nullary. *)
 		    } 
 



1.12      +0 -1      mlton/mlton/ssa/useless.fun

Index: useless.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/useless.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- useless.fun	21 Aug 2002 04:48:32 -0000	1.11
+++ useless.fun	7 Dec 2002 02:21:54 -0000	1.12
@@ -468,7 +468,6 @@
 		  case Prim.name prim of
 		     Array_array =>
 			coerce {from = arg 0, to = arrayLength result}
-		   | Array_array0 => ()
 		   | Array_array0Const => ()
 		   | Array_length => return (arrayLength (arg 0))
 		   | Array_sub => sub ()



1.16      +2 -1      mlton/mlton/type-inference/infer.fun

Index: infer.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/infer.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- infer.fun	24 Nov 2002 01:19:44 -0000	1.15
+++ infer.fun	7 Dec 2002 02:21:54 -0000	1.16
@@ -221,7 +221,8 @@
    end
 
 fun 'a sortByField (v: (Field.t * 'a) vector): 'a vector =
-   Vector.map (Vector.sort (v, fn ((f, _), (f', _)) => Field.<= (f, f')),
+   Vector.map (QuickSort.sortVector (v, fn ((f, _), (f', _)) =>
+				     Field.<= (f, f')),
 	       #2)
 
 (*---------------------------------------------------*)



1.10      +4 -7      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.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- type-env.fun	10 Apr 2002 07:02:21 -0000	1.9
+++ type-env.fun	7 Dec 2002 02:21:54 -0000	1.10
@@ -620,13 +620,10 @@
 	       then Vector.sub (ts, 0)
 	    else con (Tycon.tuple, ts)
 	 fun sortFields (fields: (Field.t * 'a) list) =
-	    let
-	       val a = Array.fromList fields
-	       val _ = QuickSort.sort (a, fn ((f, _), (f', _)) =>
-				       Field.<= (f, f'))
-	    in
-	       Array.toVector a
-	    end
+	    Array.toVector
+	    (QuickSort.sortArray
+	     (Array.fromList fields, fn ((f, _), (f', _)) =>
+	      Field.<= (f, f')))
 	 fun unsorted (fields: (Field.t * X.t) list, final: FinalRecordType.t) =
 	    let
 	       val v = sortFields fields



1.103     +11 -11    mlton/runtime/gc.c

Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.102
retrieving revision 1.103
diff -u -r1.102 -r1.103
--- gc.c	26 Nov 2002 19:42:52 -0000	1.102
+++ gc.c	7 Dec 2002 02:21:54 -0000	1.103
@@ -803,19 +803,19 @@
 		pointer max;
 
 		assert (ARRAY_TAG == tag);
-		assert (0 == GC_arrayNumElements (p)
-				? 0 == numPointers
-				: TRUE);
 		numBytes = arrayNumBytes (p, numPointers, numNonPointers);
 		max = p + numBytes;
 		if (numPointers == 0) {
 			/* There are no pointers, just update p. */
 			p = max;
 		} else if (numNonPointers == 0) {
-			assert (0 < GC_arrayNumElements (p));
 		  	/* It's an array with only pointers. */
-			for (; p < max; p += POINTER_SIZE)
-				maybeCall (f, s, (pointer*)p);
+			if (0 == GC_arrayNumElements (p))
+				/* Skip the space for the forwarding pointer. */
+				p = max;
+			else
+				for (; p < max; p += POINTER_SIZE)
+					maybeCall (f, s, (pointer*)p);
 		} else {
 			uint numBytesPointers;
 			
@@ -1410,7 +1410,7 @@
 	} else { /* Array. */
 		assert(ARRAY_TAG == tag);
 		headerBytes = GC_ARRAY_HEADER_SIZE;
-		objectBytes = arrayNumBytes(p, numPointers, numNonPointers);
+		objectBytes = arrayNumBytes (p, numPointers, numNonPointers);
 	}
 	return headerBytes + objectBytes;
 }
@@ -1815,13 +1815,10 @@
 		header = nextHeader;
 		goto markNext;
 	} else if (ARRAY_TAG == tag) {
-		assert (0 == GC_arrayNumElements (cur)
-				? 0 == numPointers
-				: TRUE);
 		numBytes = arrayNumBytes (cur, numPointers, numNonPointers);
 		size += GC_ARRAY_HEADER_SIZE + numBytes;
 		*headerp = header;
-		if (0 == numBytes or 0 == numPointers)
+		if (0 == numPointers or 0 == GC_arrayNumElements (cur))
 			goto ret;
 		assert (0 == numNonPointers);
 		max = cur + numBytes;
@@ -2642,6 +2639,9 @@
 		die ("Out of memory: cannot allocate array with %s bytes.\n",
 			ullongToCommaString (arraySize64));
 	arraySize = (W32)arraySize64;
+	if (3 * WORD_SIZE == arraySize)
+		/* array is empty -- create space for forwarding pointer. */
+ 		arraySize = 4 * WORD_SIZE;
 	if (DEBUG_ARRAY)
 		fprintf (stderr, "array with %s elts of size %u and total size %s.  ensure %s bytes free.\n",
 			uintToCommaString (numElts), 





-------------------------------------------------------
This sf.net email is sponsored by:ThinkGeek
Welcome to geek heaven.
http://thinkgeek.com/sf
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel