[MLton] cvs commit: new SSA IL

Stephen Weeks sweeks@mlton.org
Mon, 24 May 2004 21:03:04 -0700


sweeks      04/05/24 21:03:01

  Modified:    mlton/atoms prim.fun word-x.fun word-x.sig
               mlton/backend allocate-registers.fun backend.fun machine.fun
                        machine.sig packed-representation.fun rep-type.fun
                        representation.sig sources.cm ssa-to-rssa.fun
                        switch.fun
               mlton/codegen/c-codegen c-codegen.fun
               mlton/codegen/x86-codegen x86-translate.fun
               mlton/main compile.fun
               mlton/ssa analyze2.fun analyze2.sig ref-flatten.sig
                        simplify2.fun simplify2.sig sources.cm
                        ssa-to-ssa2.fun ssa-tree2.fun ssa-tree2.sig
                        ssa2.fun type-check.fun type-check2.fun
  Log:
  MAIL new SSA IL
  
  The beginnings of Ssa2 are in place.  Here are what types in the new
  IL look like.
  
  	       Array of t
  	     | Datatype of Tycon.t
  	     | IntInf
  	     | Object of {args: {elt: t, isMutable: bool} vector,
  			  con: Con.t option}
  	     | Real of RealSize.t
  	     | Thread
  	     | Vector of t
  	     | Weak of t
  	     | Word of WordSize.t
  
  The main difference between Ssa2 types and Ssa types is the new
  "Object" type, which is used for both constructed objects (with con =
  SOME ...) and tuples (with con = NONE).  Each field in an object type
  has an isMutable flag indicating whether or not it can be updated.
  Ref types have also been dropped, since a ref is simply an object with
  one mutable field.  The new Ssa2 types are different enough from the
  old Ssa and XML types that I re-implemented the hash consing from the
  ground up.
  
  Here are what expressions in the new IL look like.
  
  	       Const of Const.t
  	     | Object of {args: Var.t vector,
  			  con: Con.t option}
  	     | PrimApp of {args: Var.t vector,
  			   prim: Type.t Prim.t,
  			   targs: Type.t vector}
  	     | Profile of ProfileExp.t
  	     | Select of {object: Var.t,
  			  offset: int}
  	     | Update of {object: Var.t,
  			  offset: int,
  			  value: Var.t}
  	     | Var of Var.t
  
  As with types, Object is used for both constructor and tuple
  applications.  Similarly, select is used to select from both kinds of
  objects.  Case transfers no longer implicitly select.  Finally, the
  new Update expression is used to modify a field in both kinds of
  objects.
  
  I've put in the minimum amount of plumbing to get the new IL working.
  So, there is the general analyzer and the type checker, and the passes
  from Ssa to Ssa2 and from Ssa2 to Rssa, but nothing else.  The type
  checker is like the old one, except the very simple notion of
  subtyping that makes a constructed value a subtype of the datatype
  that declares the constructor.  For now, there is no shrinker, and I
  haven't even ported the ref flattening.  Both of those will happen
  soon.
  
  The pass from Ssa to Ssa2 is pretty simple.  It replaces Ref_assign
  with Update, Ref_deref with Select, and Ref_ref with Object.  It
  replaces ConApp and Tuple with Object.  It also adds selects to Case
  targets, since those are no longer implicit.
  
  I've only ported the -representation packed part of the backend to the
  new IL.  I'm thinking it's not worth the effort to port the unpacked
  stuff, which should be dropped since the packed stuff is better.
  
  One interesting thing that this round of changes brought up was some
  weaknesses in subtyping in the Machine IL.  There were some places
  that unnecessarily required type equality instead of subtyping.

Revision  Changes    Path
1.85      +1 -1      mlton/mlton/atoms/prim.fun

Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.84
retrieving revision 1.85
diff -u -r1.84 -r1.85
--- prim.fun	13 May 2004 20:34:51 -0000	1.84
+++ prim.fun	25 May 2004 04:02:58 -0000	1.85
@@ -1222,7 +1222,7 @@
 	   | (Word_ge s, [Word w1, Word w2]) => wordCmp (WordX.ge, s, w1, w2)
 	   | (Word_gt s, [Word w1, Word w2]) => wordCmp (WordX.gt, s, w1, w2)
 	   | (Word_le s, [Word w1, Word w2]) => wordCmp (WordX.le, s, w1, w2)
-	   | (Word_lshift _, [Word w1, Word w2]) => word (WordX.<< (w1, w2))
+	   | (Word_lshift _, [Word w1, Word w2]) => word (WordX.lshift (w1, w2))
 	   | (Word_lt s, [Word w1, Word w2]) => wordCmp (WordX.lt, s, w1, w2)
 	   | (Word_mul s, [Word w1, Word w2]) => wordS (WordX.mul, s, w1, w2)
 	   | (Word_mulCheck s, [Word w1, Word w2]) => wcheck (op *, s, w1, w2)



1.10      +3 -1      mlton/mlton/atoms/word-x.fun

Index: word-x.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/word-x.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- word-x.fun	1 May 2004 00:49:34 -0000	1.9
+++ word-x.fun	25 May 2004 04:02:58 -0000	1.10
@@ -66,7 +66,7 @@
 	 else make (f (value w, Word.fromIntInf v'), s)
       end
 in
-   val << = make IntInf.<<
+   val lshift = make IntInf.<<
    val >> = make IntInf.~>> (* OK because we know the value is positive. *)
 end
 
@@ -92,6 +92,8 @@
    val max = make WordSize.max
    val min = make WordSize.min
 end
+
+fun allOnes s = max (s, {signed = false})
 
 local
    fun make f (w, sg) = equals (w, f (size w, sg))



1.7       +2 -1      mlton/mlton/atoms/word-x.sig

Index: word-x.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/word-x.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- word-x.sig	1 May 2004 00:49:34 -0000	1.6
+++ word-x.sig	25 May 2004 04:02:58 -0000	1.7
@@ -19,8 +19,8 @@
       (* Words of all WordSize.t sizes. *)
       type t
 
-      val << : t * t -> t
       val add: t * t -> t
+      val allOnes: WordSize.t -> t
       val andb: t * t -> t
       val bitIsSet: t * Int.t -> bool
       val equals: t * t -> bool
@@ -37,6 +37,7 @@
       val isZero: t -> bool
       val layout: t -> Layout.t
       val le: t * t * {signed: bool} -> bool
+      val lshift: t * t -> t
       val lt: t * t * {signed: bool} -> bool
       val max: WordSize.t * {signed: bool} -> t
       val min: WordSize.t * {signed: bool} -> t



1.32      +13 -11    mlton/mlton/backend/allocate-registers.fun

Index: allocate-registers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/allocate-registers.fun,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- allocate-registers.fun	4 Apr 2004 06:50:16 -0000	1.31
+++ allocate-registers.fun	25 May 2004 04:02:58 -0000	1.32
@@ -30,6 +30,7 @@
    structure Operand = Operand
    structure Register = Register
    structure Runtime = Runtime
+   structure StackOffset = StackOffset
 end
 
 structure Live = Live (Rssa)
@@ -42,7 +43,7 @@
 
             val get: t * Type.t -> t * {offset: Bytes.t}
             val layout: t -> Layout.t
-            val new: {offset: Bytes.t, ty: Type.t} list -> t
+            val new: StackOffset.t list -> t
             val size: t -> Bytes.t
          end
 
@@ -51,7 +52,7 @@
       val getRegister: t * Type.t -> Register.t
       val getStack: t * Type.t -> {offset: Bytes.t}
       val layout: t -> Layout.t
-      val new: {offset: Bytes.t, ty: Type.t} list * Register.t list -> t
+      val new: StackOffset.t list * Register.t list -> t
       val stack: t -> Stack.t
       val stackSize: t -> Bytes.t
    end =
@@ -80,7 +81,7 @@
 	  fun new (alloc): t =
 	     T (Array.toList
 		(QuickSort.sortArray
-		 (Array.fromListMap (alloc, fn {offset, ty} =>
+		 (Array.fromListMap (alloc, fn StackOffset.T {offset, ty} =>
 				     {offset = offset,
 				      size = Type.bytes ty}),
 		  fn (r, r') => Bytes.<= (#offset r, #offset r'))))
@@ -372,7 +373,8 @@
 				let
 				   val {offset} = Allocation.getStack (a, ty)
 				in
-				   Operand.StackOffset {offset = offset, ty = ty}
+				   Operand.StackOffset
+				   (StackOffset.T {offset = offset, ty = ty})
 				end
 			   | Register =>
 				Operand.Register
@@ -397,9 +399,9 @@
 	  (args, argOperands, [],
 	   fn ((x, t), z, ac) =>
 	   case z of
-	      Operand.StackOffset {offset, ...} =>
+	      Operand.StackOffset (StackOffset.T {offset, ...}) =>
 		 (valOf (#operand (varInfo x)) := SOME z
-		  ; {offset = offset, ty = t} :: ac)
+		  ; StackOffset.T {offset = offset, ty = t} :: ac)
 	    | _ => Error.bug "strange argOperand"))
       (* Allocate slots for the link and handler, if necessary. *)
       val handlerLinkOffset =
@@ -440,13 +442,13 @@
 			     case handlerLive of
 				NONE => ops
 			      | SOME h => 
-				   Operand.StackOffset {offset = handler,
+				   Operand.stackOffset {offset = handler,
 							ty = Type.label h}
 				   :: ops
 			  val ops =
 			     if linkLive
 				then
-				   Operand.StackOffset {offset = link,
+				   Operand.stackOffset {offset = link,
 							ty = Type.exnStack}
 				   :: ops
 			     else ops
@@ -458,15 +460,15 @@
 	        List.fold
 		(liveNoFormals, ([],[]), fn (oper, (stack, registers)) =>
 		 case oper of
-		    Operand.StackOffset a => (a::stack, registers)
+		    Operand.StackOffset s => (s::stack, registers)
 		  | Operand.Register r => (stack, r::registers)
 		  | _ => (stack, registers))
 	     val stackInit =
 		case handlerLinkOffset of
 		   NONE => stackInit
 		 | SOME {handler, link} =>
-		      {offset = handler, ty = Type.defaultWord} (* should be label *)
-		      :: {offset = link, ty = Type.exnStack}
+		      StackOffset.T {offset = handler, ty = Type.defaultWord} (* should be label *)
+		      :: StackOffset.T {offset = link, ty = Type.exnStack}
 		      :: stackInit
 	     val a = Allocation.new (stackInit, registersInit)
 	     val size =



1.71      +60 -43    mlton/mlton/backend/backend.fun

Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.70
retrieving revision 1.71
diff -u -r1.70 -r1.71
--- backend.fun	1 May 2004 00:49:35 -0000	1.70
+++ backend.fun	25 May 2004 04:02:58 -0000	1.71
@@ -16,10 +16,12 @@
 in
    structure Global = Global
    structure Label = Label
+   structure Live = Live
    structure PointerTycon = PointerTycon
    structure RealX = RealX
    structure Register = Register
    structure Runtime = Runtime
+   structure StackOffset = StackOffset
    structure WordSize = WordSize
    structure WordX = WordX
 end
@@ -284,16 +286,16 @@
 	 setFrameInfo
       (* The global raise operands. *)
       local
-	 val table: (Type.t vector * M.Operand.t vector) list ref = ref []
+	 val table: (Type.t vector * M.Live.t vector) list ref = ref []
       in
-	 fun raiseOperands (ts: Type.t vector): M.Operand.t vector =
+	 fun raiseOperands (ts: Type.t vector): M.Live.t vector =
 	    case List.peek (!table, fn (ts', _) =>
 			    Vector.equals (ts, ts', Type.equals)) of
 	       NONE =>
 		  let
 		     val gs =
 			Vector.map (ts, fn ty =>
-				    M.Operand.Global
+				    M.Live.Global
 				    (Global.new {isRoot = false,
 						 ty = ty}))
 		     val _ = List.push (table, (ts, gs))
@@ -514,19 +516,19 @@
 		  Vector.new1
 		  (M.Statement.move
 		   {dst = exnStackOp,
-		    src = M.Operand.StackOffset {offset = linkOffset (),
+		    src = M.Operand.stackOffset {offset = linkOffset (),
 						 ty = Type.exnStack}})
 	     | SetHandler h =>
 		  Vector.new1
 		  (M.Statement.move
-		   {dst = M.Operand.StackOffset {offset = handlerOffset (),
+		   {dst = M.Operand.stackOffset {offset = handlerOffset (),
 						 ty = Type.label h},
 		    src = M.Operand.Label h})
 	     | SetSlotExnStack =>
 		  (* *(uint* )(stackTop + offset) = ExnStack; *)
 		  Vector.new1
 		  (M.Statement.move
-		   {dst = M.Operand.StackOffset {offset = linkOffset (),
+		   {dst = M.Operand.stackOffset {offset = linkOffset (),
 						 ty = Type.exnStack},
 		    src = exnStackOp})
 	     | _ => Error.bug (concat
@@ -554,7 +556,7 @@
 	 setLabelInfo
       fun callReturnOperands (xs: 'a vector,
 			      ty: 'a -> Type.t,
-			      shift: Bytes.t): M.Operand.t vector =
+			      shift: Bytes.t): StackOffset.t vector =
 	 #1 (Vector.mapAndFold
 	     (xs, Bytes.zero,
 	      fn (x, offset) =>
@@ -562,10 +564,13 @@
 		 val ty = ty x
 		 val offset = Type.align (ty, offset)
 	      in
-		 (M.Operand.StackOffset {offset = Bytes.+ (shift, offset),
-					 ty = ty},
+		 (StackOffset.T {offset = Bytes.+ (shift, offset), ty = ty},
 		  Bytes.+ (offset, Type.bytes ty))
 	      end))
+      val operandLive: M.Operand.t -> M.Live.t =
+	 valOf o M.Live.fromOperand
+      val operandsLive: M.Operand.t vector -> M.Live.t vector =
+	 fn ops => Vector.map (ops, operandLive)
       fun genFunc (f: Function.t, isMain: bool): unit =
 	 let
 	    val f = eliminateDeadCode f
@@ -660,10 +665,16 @@
 		  end
 	    in
 	       val {handlerLinkOffset, labelInfo = labelRegInfo, ...} =
-		  AllocateRegisters.allocate
-		  {argOperands = callReturnOperands (args, #2, Bytes.zero),
-		   function = f,
-		   varInfo = varInfo}
+		  let
+		     val argOperands =
+			Vector.map
+			(callReturnOperands (args, #2, Bytes.zero),
+			 M.Operand.StackOffset)
+		  in
+		     AllocateRegisters.allocate {argOperands = argOperands,
+						 function = f,
+						 varInfo = varInfo}
+		  end
 	    end
 	    (* Set the frameInfo for blocks in this function. *)
 	    val _ =
@@ -679,7 +690,7 @@
 				  Vector.fold
 				  (liveNoFormals, [], fn (oper, ac) =>
 				   case oper of
-				      M.Operand.StackOffset {offset, ty} =>
+				      M.Operand.StackOffset (StackOffset.T {offset, ty}) =>
 					 if Type.isPointer ty
 					    then offset :: ac
 					 else ac
@@ -762,13 +773,15 @@
 			   val setupArgs =
 			      parallelMove
 			      {chunk = chunk,
-			       dsts = dsts,
+			       dsts = Vector.map (dsts, M.Operand.StackOffset),
 			       srcs = translateOperands args}
+			   val live =
+			      Vector.concat [operandsLive contLive,
+					     Vector.map (dsts, Live.StackOffset)]
 			   val transfer =
-			      M.Transfer.Call
-			      {label = funcToLabel func,
-			       live = Vector.concat [contLive, dsts],
-			       return = return}
+			      M.Transfer.Call {label = funcToLabel func,
+					       live = live,
+					       return = return}
 			in
 			   (setupArgs, transfer)
 			end
@@ -778,22 +791,16 @@
 				       chunk = labelChunk dst},
 			 M.Transfer.Goto dst)
 		   | R.Transfer.Raise srcs =>
-			(M.Statement.moves
-			 {dsts = (raiseOperands
-				  (Vector.map (srcs, R.Operand.ty))),
-			  srcs = translateOperands srcs},
+			(M.Statement.moves {dsts = Vector.map (valOf raises,
+							       Live.toOperand),
+					    srcs = translateOperands srcs},
 			 M.Transfer.Raise)
 		   | R.Transfer.Return xs =>
-			let
-			   val dsts =
-			      callReturnOperands (xs, R.Operand.ty, Bytes.zero)
-			in
-			   (parallelMove
-			    {chunk = chunk,
-			     dsts = dsts,
-			     srcs = translateOperands xs},
-			    M.Transfer.Return)
-			end
+			(parallelMove {chunk = chunk,
+				       dsts = Vector.map (valOf returns,
+							  M.Operand.StackOffset),
+				       srcs = translateOperands xs},
+			 M.Transfer.Return)
 		   | R.Transfer.Switch switch =>
 			let
 			   val R.Switch.T {cases, default, size, test} =
@@ -827,12 +834,16 @@
 		     if Label.equals (label, start)
 			then let
 				val live = #live (labelRegInfo start)
+				val returns =
+				   Option.map
+				   (returns, fn returns =>
+				    Vector.map (returns, Live.StackOffset))
 			     in
 				Chunk.newBlock
 				(chunk, 
 				 {label = funcToLabel name,
 				  kind = M.Kind.Func,
-				  live = live,
+				  live = operandsLive live,
 				  raises = raises,
 				  returns = returns,
 				  statements = Vector.new0 (),
@@ -845,28 +856,30 @@
 		     Vector.concatV
 		     (Vector.map (statements, fn s =>
 				  genStatement (s, handlerLinkOffset)))
-		  val (preTransfer, transfer) = genTransfer (transfer, chunk)
+		  val (preTransfer, transfer) = genTransfer (transfer, chunk)	
 		  val (kind, live, pre) =
 		     case kind of
 			R.Kind.Cont _ =>
 			   let
 			      val srcs = callReturnOperands (args, #2, size)
 			   in
-			      (M.Kind.Cont {args = srcs,
+			      (M.Kind.Cont {args = Vector.map (srcs,
+							       Live.StackOffset),
 					    frameInfo = valOf (frameInfo label)},
 			       liveNoFormals,
 			       parallelMove
 			       {chunk = chunk,
 				dsts = Vector.map (args, varOperand o #1),
-				srcs = srcs})
+				srcs = Vector.map (srcs, M.Operand.StackOffset)})
 			   end
 		      | R.Kind.CReturn {func, ...} =>
 			   let
 			      val dst =
 				 case Vector.length args of
 				    0 => NONE
-				  | 1 => SOME (varOperand
-					       (#1 (Vector.sub (args, 0))))
+				  | 1 => SOME (operandLive
+					       (varOperand
+						(#1 (Vector.sub (args, 0)))))
 				  | _ => Error.bug "strange CReturn"
 			   in
 			      (M.Kind.CReturn {dst = dst,
@@ -889,8 +902,9 @@
 			       {frameInfo = valOf (frameInfo label),
 				handles = handles},
 			       liveNoFormals,
-			       M.Statement.moves {dsts = dsts,
-						  srcs = handles})
+			       M.Statement.moves
+			       {dsts = dsts,
+				srcs = Vector.map (handles, Live.toOperand)})
 			   end
 		      | R.Kind.Jump => (M.Kind.Jump, live, Vector.new0 ())
 		  val (first, statements) =
@@ -912,11 +926,14 @@
 		     else (Vector.new0 (), statements)
 		  val statements =
 		     Vector.concat [first, pre, statements, preTransfer]
+		  val returns =
+		     Option.map (returns, fn returns =>
+				 Vector.map (returns, Live.StackOffset))
 	       in
 		  Chunk.newBlock (chunk,
 				  {kind = kind,
 				   label = label,
-				   live = live,
+				   live = operandsLive live,
 				   raises = raises,
 				   returns = returns,
 				   statements = statements,
@@ -1007,7 +1024,7 @@
 		     | Cast (z, _) => doOperand (z, max)
 		     | Contents {oper, ...} => doOperand (oper, max)
 		     | Offset {base, ...} => doOperand (base, max)
-		     | StackOffset {offset, ty} =>
+		     | StackOffset (StackOffset.T {offset, ty}) =>
 			  Bytes.max (Bytes.+ (offset, Type.bytes ty), max)
 		     | _ => max
 		 end



1.67      +174 -91   mlton/mlton/backend/machine.fun

Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.66
retrieving revision 1.67
diff -u -r1.66 -r1.67
--- machine.fun	13 May 2004 20:34:51 -0000	1.66
+++ machine.fun	25 May 2004 04:02:59 -0000	1.67
@@ -77,6 +77,14 @@
 
       val equals =
 	 Trace.trace2 ("Register.equals", layout, layout, Bool.layout) equals
+
+      val isSubtype: t * t -> bool =
+	 fn (T {index = i, ty = t}, T {index = i', ty = t'}) =>
+	 (case (!i, !i') of
+	     (SOME i, SOME i') => i = i'
+	   | _ => false)
+	 andalso Type.isSubtype (t, t')
+	 andalso CType.equals (Type.toCType t, Type.toCType t')
    end
 
 structure Global =
@@ -130,14 +138,29 @@
 	 i = i'
 	 andalso r = r'
 	 andalso Type.equals (ty, ty')
+
+      val isSubtype: t * t -> bool =
+	 fn (T {index = i, isRoot = r, ty},
+	     T {index = i', isRoot = r', ty = ty'}) =>
+	 i = i'
+	 andalso r = r'
+	 andalso Type.isSubtype (ty, ty')
+	 andalso CType.equals (Type.toCType ty, Type.toCType ty')
    end
 
 structure StackOffset =
    struct
-      type t = {offset: Bytes.t,
-		ty: Type.t}
+      datatype t = T of {offset: Bytes.t,
+			 ty: Type.t}
 
-      fun layout ({offset, ty}: t): Layout.t =
+      local
+	 fun make f (T r) = f r
+      in
+	 val offset = make #offset
+	 val ty = make #ty
+      end
+
+      fun layout (T {offset, ty}): Layout.t =
 	 let
 	    open Layout
 	 in
@@ -147,17 +170,25 @@
 	 end
 
       val equals: t * t -> bool =
-	 fn ({offset = b, ty}, {offset = b', ty = ty'}) =>
+	 fn (T {offset = b, ty}, T {offset = b', ty = ty'}) =>
 	 Bytes.equals (b, b') andalso Type.equals (ty, ty')
 
+      val isSubtype: t * t -> bool =
+	 fn (T {offset = b, ty = t}, T {offset = b', ty = t'}) =>
+	 Bytes.equals (b, b') andalso Type.isSubtype (t, t')
+
       val interfere: t * t -> bool =
-	 fn ({offset = b, ty = ty}, {offset = b', ty = ty'}) =>
+	 fn (T {offset = b, ty = ty}, T {offset = b', ty = ty'}) =>
 	 let 
 	    val max = Bytes.+ (b, Type.bytes ty)
 	    val max' = Bytes.+ (b', Type.bytes ty')
 	 in
 	    Bytes.> (max, b') andalso Bytes.> (max', b)
 	 end
+
+      fun shift (T {offset, ty}, size): t =
+	 T {offset = Bytes.- (offset, size),
+	    ty = ty}
    end
 
 structure Operand =
@@ -183,16 +214,6 @@
        | StackOffset of StackOffset.t
        | StackTop
        | Word of WordX.t
-    
-      val rec isLocation =
-	 fn ArrayOffset _ => true
-	  | Cast (z, _) => isLocation z
-	  | Contents _ => true
-	  | Global _ => true
-	  | Offset _ => true
-	  | Register _ => true
-	  | StackOffset _ => true
-	  | _ => false
 
     val ty =
        fn ArrayOffset {ty, ...} => ty
@@ -207,7 +228,7 @@
 	| Offset {ty, ...} => ty
 	| Real r => Type.real (RealX.size r)
 	| Register r => Register.ty r
-	| StackOffset {ty, ...} => ty
+	| StackOffset s => StackOffset.ty s
 	| StackTop => Type.defaultWord
 	| Word w => Type.constant w
 
@@ -270,6 +291,8 @@
 	   | (Word w, Word w') => WordX.equals (w, w')
 	   | _ => false
 
+      val stackOffset = StackOffset o StackOffset.T
+    
       fun interfere (write: t, read: t): bool =
 	 let
 	    fun inter read = interfere (write, read)
@@ -285,6 +308,16 @@
 		  StackOffset.interfere (so, so')
 	     | _ => false
 	 end
+
+      val rec isLocation =
+	 fn ArrayOffset _ => true
+	  | Cast (z, _) => isLocation z
+	  | Contents _ => true
+	  | Global _ => true
+	  | Offset _ => true
+	  | Register _ => true
+	  | StackOffset _ => true
+	  | _ => false
    end
 
 structure Switch = Switch (open Atoms
@@ -392,6 +425,55 @@
 	 i = i'
    end
 
+structure Live =
+   struct
+      datatype t =
+	 Global of Global.t
+       | Register of Register.t
+       | StackOffset of StackOffset.t
+
+      val layout: t -> Layout.t =
+	 fn Global g => Global.layout g
+	  | Register r => Register.layout r
+	  | StackOffset s => StackOffset.layout s
+
+      val equals: t * t -> bool =
+	 fn (Global g, Global g') => Global.equals (g, g')
+	  | (Register r, Register r') => Register.equals (r, r')
+	  | (StackOffset s, StackOffset s') => StackOffset.equals (s, s')
+	  | _ => false
+
+      val ty =
+	 fn Global g => Global.ty g
+	  | Register r => Register.ty r
+	  | StackOffset s => StackOffset.ty s
+
+      val isSubtype: t * t -> bool =
+	 fn (Global g, Global g') => Global.isSubtype (g, g')
+	  | (Register r, Register r') => Register.isSubtype (r, r')
+	  | (StackOffset s, StackOffset s') => StackOffset.isSubtype (s, s')
+	  | _ => false
+
+      val interfere: t * t -> bool =
+	 fn (l, l') =>
+	 equals (l, l')
+	 orelse (case (l, l') of
+		    (StackOffset s, StackOffset s') =>
+		       StackOffset.interfere (s, s')
+		  | _ => false)
+
+      val fromOperand: Operand.t -> t option =
+	 fn Operand.Global g => SOME (Global g)
+	  | Operand.Register r => SOME (Register r)
+	  | Operand.StackOffset s => SOME (StackOffset s)
+	  | _ => NONE
+
+      val toOperand: t -> Operand.t =
+	 fn Global g => Operand.Global g
+	  | Register r => Operand.Register r
+	  | StackOffset s => Operand.StackOffset s
+   end
+
 structure Transfer =
    struct
       datatype t =
@@ -405,7 +487,7 @@
 		   func: Type.t CFunction.t,
 		   return: Label.t option}
        | Call of {label: Label.t,
-		  live: Operand.t vector,
+		  live: Live.t vector,
 		  return: {return: Label.t,
 			   handler: Label.t option,
 			   size: Bytes.t} option}
@@ -436,7 +518,7 @@
 	     | Call {label, live, return} => 
 		  seq [str "Call ", 
 		       record [("label", Label.layout label),
-			       ("live", Vector.layout Operand.layout live),
+			       ("live", Vector.layout Live.layout live),
 			       ("return", Option.layout 
 				(fn {return, handler, size} =>
 				 record [("return", Label.layout return),
@@ -469,14 +551,14 @@
 structure Kind =
    struct
       datatype t =
-	 Cont of {args: Operand.t vector,
+	 Cont of {args: Live.t vector,
 		  frameInfo: FrameInfo.t}
-       | CReturn of {dst: Operand.t option,
+       | CReturn of {dst: Live.t option,
 		     frameInfo: FrameInfo.t option,
 		     func: Type.t CFunction.t}
        | Func
        | Handler of {frameInfo: FrameInfo.t,
-		     handles: Operand.t vector}
+		     handles: Live.t vector}
        | Jump
 
       fun layout k =
@@ -486,12 +568,12 @@
 	    case k of
 	       Cont {args, frameInfo} =>
 		  seq [str "Cont ",
-		       record [("args", Vector.layout Operand.layout args),
+		       record [("args", Vector.layout Live.layout args),
 			       ("frameInfo", FrameInfo.layout frameInfo)]]
 	     | CReturn {dst, frameInfo, func} =>
 		  seq [str "CReturn ",
 		       record
-		       [("dst", Option.layout Operand.layout dst),
+		       [("dst", Option.layout Live.layout dst),
 			("frameInfo", Option.layout FrameInfo.layout frameInfo),
 			("func", CFunction.layout (func, Type.layout))]]
 	     | Func => str "Func"
@@ -499,7 +581,7 @@
 		  seq [str "Handler ",
 		       record [("frameInfo", FrameInfo.layout frameInfo),
 			       ("handles",
-				Vector.layout Operand.layout handles)]]
+				Vector.layout Live.layout handles)]]
 	     | Jump => str "Jump"
 	 end
 
@@ -514,9 +596,9 @@
    struct
       datatype t = T of {kind: Kind.t,
 			 label: Label.t,
-			 live: Operand.t vector,
-			 raises: Operand.t vector option,
-			 returns: Operand.t vector option,
+			 live: Live.t vector,
+			 raises: Live.t vector option,
+			 returns: Live.t vector option,
 			 statements: Statement.t vector,
 			 transfer: Transfer.t}
 
@@ -536,12 +618,12 @@
 	    align [seq [Label.layout label, 
 			str ": ",
 			record [("kind", Kind.layout kind),
-				("live", Vector.layout Operand.layout live),
+				("live", Vector.layout Live.layout live),
 				("raises",
-				 Option.layout (Vector.layout Operand.layout)
+				 Option.layout (Vector.layout Live.layout)
 				 raises),
 				("returns",
-				 Option.layout (Vector.layout Operand.layout)
+				 Option.layout (Vector.layout Live.layout)
 				 returns)]],
 		   indent (align
 			   [align (Vector.toListMap
@@ -559,7 +641,7 @@
 		  Kind.CReturn {dst, ...} =>
 		     (case dst of
 			 NONE => a
-		       | SOME z => f (z, a))
+		       | SOME z => f (Live.toOperand z, a))
 		| _ => a
 	    val a =
 	       Vector.fold (statements, a, fn (s, a) =>
@@ -756,30 +838,35 @@
 
       structure Alloc =
 	 struct
-	    datatype t = T of Operand.t list
+	    datatype t = T of Live.t list
 
-	    fun layout (T zs) = List.layout Operand.layout zs
+	    fun layout (T ds) = List.layout Live.layout ds
+
+	    val empty = T []
 	       
-	    val new = T
+	    fun forall (T ds, f) = List.forall (ds, f o Live.toOperand)
 
-	    fun forall (T zs, f) = List.forall (zs, f)
+	    fun defineLive (T ls, l) = T (l :: ls)
 	       
-	    fun define (T zs, z) =
-	       if (case z of
-		      Operand.Global _ => true
-		    | Operand.Register _ => true
-		    | Operand.StackOffset _ => true
-		    | _ => false)
-		  then T (z :: zs)
-	       else T zs
-
-	    fun doesDefine (T zs, z): bool =
-	       case List.peek (zs, fn z' => Operand.interfere (z, z')) of
-		  NONE => false
-		| SOME z' => Operand.equals (z, z')
+	    fun define (T ds, z) =
+	       case Live.fromOperand z of
+		  NONE => T ds
+		| SOME d => T (d :: ds)
+
+	    val new: Live.t list -> t = T
+
+	    fun doesDefine (T ls, l': Live.t): bool =
+	       let
+		  val oper' = Live.toOperand l'
+	       in
+		  case List.peek (ls, fn l =>
+				  Operand.interfere (Live.toOperand l, oper')) of
+		     NONE => false
+		   | SOME l => Live.isSubtype (l, l')
+	       end
 
 	    val doesDefine =
-	       Trace.trace2 ("Alloc.doesDefine", layout, Operand.layout,
+	       Trace.trace2 ("Alloc.doesDefine", layout, Live.layout,
 			     Bool.layout)
 	       doesDefine
 	 end
@@ -941,12 +1028,11 @@
 		      | Frontier => true
 		      | GCState => true
 		      | Global _ =>
-			   (* For now, we don't check that globals are
-			    * defined, because they aren't captured by
-			    * liveness info.
+			   (* We don't check that globals are defined because
+			    * they aren't captured by liveness info.  It would
+			    * be nice to fix this.
 			    *)
 			   true
-			   orelse Alloc.doesDefine (alloc, x)
 		      | Label l => 
 			   (let val _ = labelBlock l
 			    in true
@@ -962,11 +1048,11 @@
 						      pointerTy = tyconTy,
 						      result = ty}))
 		      | Real _ => true
-		      | Register _ => Alloc.doesDefine (alloc, x)
-		      | StackOffset {offset, ty, ...} =>
+		      | Register r => Alloc.doesDefine (alloc, Live.Register r)
+		      | StackOffset (so as StackOffset.T {offset, ty, ...}) =>
 			   Bytes.<= (Bytes.+ (offset, Type.bytes ty),
 				     maxFrameSize)
-			   andalso Alloc.doesDefine (alloc, x)
+			   andalso Alloc.doesDefine (alloc, Live.StackOffset so)
 			   andalso (case Type.dest ty of
 				       Type.Label l =>
 					  let
@@ -1028,7 +1114,7 @@
 			       List.fold
 			       (zs, [], fn (z, liveOffsets) =>
 				case z of
-				   Operand.StackOffset {offset, ty} =>
+				   Live.StackOffset (StackOffset.T {offset, ty}) =>
 				      if Type.isPointer ty
 					 then offset :: liveOffsets
 				      else liveOffsets
@@ -1052,7 +1138,7 @@
 			Alloc.forall
 			(alloc, fn z =>
 			 case z of
-			    Operand.StackOffset {offset, ty} =>
+			    Operand.StackOffset (StackOffset.T {offset, ty}) =>
 			       Bytes.<= (Bytes.+ (offset, Type.bytes ty), size)
 			  | _ => false)
 		     end
@@ -1063,7 +1149,7 @@
 			   andalso slotsAreInFrame frameInfo
 			   then SOME (Vector.fold
 				      (args, alloc, fn (z, alloc) =>
-				       Alloc.define (alloc, z)))
+				       Alloc.defineLive (alloc, z)))
 			else NONE
 		   | CReturn {dst, frameInfo, func, ...} =>
 			let
@@ -1072,7 +1158,7 @@
 				  NONE => true
 				| SOME z =>
 				     Type.isSubtype (CFunction.return func,
-						     Operand.ty z))
+						     Live.ty z))
                               andalso
 			      (if CFunction.mayGC func
 				  then (case frameInfo of
@@ -1089,7 +1175,7 @@
 			   if ok
 			      then SOME (case dst of
 					    NONE => alloc
-					  | SOME z => Alloc.define (alloc, z))
+					  | SOME z => Alloc.defineLive (alloc, z))
 			   else NONE
 			end
 		   | Func => SOME alloc
@@ -1168,33 +1254,32 @@
 			   then SOME alloc
 			else NONE
 	       end
-	    fun liveIsOk (live: Operand.t vector,
+	    fun liveIsOk (live: Live.t vector,
 			  a: Alloc.t): bool =
 	       Vector.forall (live, fn z => Alloc.doesDefine (a, z))
-	    fun liveSubset (live: Operand.t vector,
-			    live': Operand.t vector): bool =
+	    fun liveSubset (live: Live.t vector,
+			    live': Live.t vector): bool =
 	       Vector.forall
-	       (live, fn z =>
-		Vector.exists (live', fn z' =>
-			       Operand.equals (z, z')))
+	       (live, fn z => Vector.exists (live', fn z' =>
+					     Live.equals (z, z')))
 	    fun goto (Block.T {live,
 			       raises = raises',
 			       returns = returns', ...},
-		      raises,
-		      returns,
+		      raises: Live.t vector option,
+		      returns: Live.t vector option,
 		      alloc: Alloc.t): bool =
 	       liveIsOk (live, alloc)
 	       andalso
 	       (case (raises, raises') of
 		   (_, NONE) => true
 		 | (SOME gs, SOME gs') =>
-		      Vector.equals (gs, gs', Operand.equals)
+		      Vector.equals (gs', gs, Live.isSubtype)
 		 | _ => false)
 		   andalso
 		   (case (returns, returns') of
 		       (_, NONE) => true
 		     | (SOME os, SOME os') =>
-			  Vector.equals (os, os', Operand.equals)
+			  Vector.equals (os', os, Live.isSubtype)
 		     | _ => false)
 	    fun checkCont (cont: Label.t, size: Bytes.t, alloc: Alloc.t) =
 	       let
@@ -1213,10 +1298,9 @@
 				       (Vector.map
 					(args, fn z =>
 					 case z of
-					    Operand.StackOffset {offset, ty} =>
-					       Operand.StackOffset
-					       {offset = Bytes.- (offset, size),
-						ty = ty}
+					    Live.StackOffset s =>
+					       Live.StackOffset
+					       (StackOffset.shift (s, size))
 					  | _ => z)))
 				else NONE)
 			  | _ => NONE)
@@ -1224,10 +1308,10 @@
 	       end
 	    fun callIsOk {alloc: Alloc.t,
 			  dst: Label.t,
-			  live,
-			  raises,
+			  live: Live.t vector,
+			  raises: Live.t vector option,
 			  return,
-			  returns} =
+			  returns: Live.t vector option} =
 	       let
 		  val {raises, returns, size} =
 		     case return of
@@ -1273,20 +1357,21 @@
 		     (Vector.fold
 		      (live, [], fn (z, ac) =>
 		       case z of
-			  Operand.StackOffset {offset, ty} =>
+			  Live.StackOffset (StackOffset.T {offset, ty}) =>
 			     if Bytes.< (offset, size)
 				then ac
-			     else (Operand.StackOffset
-				   {offset = Bytes.- (offset, size),
-				    ty = ty} :: ac)
+			     else (Live.StackOffset
+				   (StackOffset.T
+				    {offset = Bytes.- (offset, size),
+				     ty = ty})) :: ac
 			| _ => ac))
 	       in
 		  goto (b, raises, returns, alloc)
 	       end
 	    fun transferOk
 	       (t: Transfer.t,
-		raises: Operand.t vector option,
-		returns: Operand.t vector option,
+		raises: Live.t vector option,
+		returns: Live.t vector option,
 		alloc: Alloc.t): bool =
 	       let
 		  fun jump (l: Label.t, a: Alloc.t) =
@@ -1358,16 +1443,14 @@
 			   (case raises of
 			       NONE => false
 			     | SOME zs =>
-				  Vector.forall (zs, fn z =>
-						 Alloc.doesDefine
-						 (alloc, z)))
+				  Vector.forall
+				  (zs, fn z => Alloc.doesDefine (alloc, z)))
 		      | Return =>
 			   (case returns of
 			       NONE => false
 			     | SOME zs =>
 				  Vector.forall
-				  (zs, fn z =>
-				   Alloc.doesDefine (alloc, z)))
+				  (zs, fn z => Alloc.doesDefine (alloc, z)))
 		      | Switch s =>
 			   Switch.isOk
 			   (s, {checkUse = fn z => checkOperand (z, alloc),
@@ -1395,11 +1478,11 @@
 			     | z :: zs =>
 				  List.forall
 				  (zs, fn z' =>
-				   not (Operand.interfere (z, z')))
+				   not (Live.interfere (z, z')))
 		      in
 			 loop live
 		      end,
-		      fn () => List.layout Operand.layout live)
+		      fn () => List.layout Live.layout live)
 		  val alloc = Alloc.new live
 		  val alloc =
 		     Err.check'



1.47      +32 -9     mlton/mlton/backend/machine.sig

Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- machine.sig	1 May 2004 00:49:35 -0000	1.46
+++ machine.sig	25 May 2004 04:02:59 -0000	1.47
@@ -60,6 +60,15 @@
 	    val ty: t -> Type.t
 	 end
 
+      structure StackOffset:
+	 sig
+	    datatype t = T of {offset: Bytes.t,
+			       ty: Type.t}
+
+	    val offset: t -> Bytes.t
+	    val ty: t -> Type.t
+	 end
+
       structure Operand:
 	 sig
 	    datatype t =
@@ -80,19 +89,33 @@
 			  ty: Type.t}
 	     | Real of RealX.t
 	     | Register of Register.t
-	     | StackOffset of {offset: Bytes.t,
-			       ty: Type.t}
+	     | StackOffset of StackOffset.t
 	     | StackTop
 	     | Word of WordX.t
 
 	    val equals: t * t -> bool
 	    val interfere: t * t -> bool
 	    val layout: t -> Layout.t
+	    val stackOffset: {offset: Bytes.t, ty: Type.t} -> t
 	    val toString: t -> string
 	    val ty: t -> Type.t
 	 end
       sharing Operand = Switch.Use
 
+      structure Live:
+	 sig
+	    datatype t =
+	       Global of Global.t
+	     | Register of Register.t
+	     | StackOffset of StackOffset.t
+
+	    val equals: t * t -> bool
+	    val fromOperand: Operand.t -> t option
+	    val layout: t -> Layout.t
+	    val toOperand: t -> Operand.t
+	    val ty: t -> Type.t
+	 end
+
       structure Statement:
 	 sig
 	    datatype t =
@@ -150,7 +173,7 @@
 			  *)
 			 return: Label.t option}
 	     | Call of {label: Label.t, (* label must be a Func *)
-			live: Operand.t vector,
+			live: Live.t vector,
 			return: {return: Label.t,
 				 handler: Label.t option,
 				 size: Bytes.t} option}
@@ -166,14 +189,14 @@
       structure Kind:
 	 sig
 	    datatype t =
-	       Cont of {args: Operand.t vector,
+	       Cont of {args: Live.t vector,
 			frameInfo: FrameInfo.t}
-	     | CReturn of {dst: Operand.t option,
+	     | CReturn of {dst: Live.t option,
 			   frameInfo: FrameInfo.t option,
 			   func: Type.t CFunction.t}
 	     | Func
 	     | Handler of {frameInfo: FrameInfo.t,
-			   handles: Operand.t vector}
+			   handles: Live.t vector}
 	     | Jump
 
 	    val frameInfoOpt: t -> FrameInfo.t option
@@ -185,9 +208,9 @@
 	       T of {kind: Kind.t,
 		     label: Label.t,
 		     (* Live registers and stack offsets at start of block. *)
-		     live: Operand.t vector,
-		     raises: Operand.t vector option,
-		     returns: Operand.t vector option,
+		     live: Live.t vector,
+		     raises: Live.t vector option,
+		     returns: Live.t vector option,
 		     statements: Statement.t vector,
 		     transfer: Transfer.t}
 



1.14      +376 -330  mlton/mlton/backend/packed-representation.fun

Index: packed-representation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/packed-representation.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- packed-representation.fun	13 May 2004 20:34:51 -0000	1.13
+++ packed-representation.fun	25 May 2004 04:02:59 -0000	1.14
@@ -119,6 +119,8 @@
 
       fun nonPointer ty = T {rep = NonPointer,
 			     ty = ty}
+
+      val bool = nonPointer Type.bool
 	 
       val width = Type.width o ty
 
@@ -415,6 +417,41 @@
 				      ("src", Operand.layout src)],
 		       List.layout Statement.layout)
 	 select
+
+      fun update (T {shift, ty},
+		  {chunk: Operand.t,
+		   component: Operand.t}): Operand.t * Statement.t list =
+	 let
+	    val shift =
+	       WordX.fromIntInf (Bits.toIntInf shift, WordSize.default)
+	    val chunkWidth = Type.width (Operand.ty chunk)
+	    val mask =
+	       Operand.word
+	       (WordX.notb
+		(WordX.resize
+		 (WordX.lshift (WordX.allOnes
+				(WordSize.fromBits (Type.width ty)),
+				shift),
+		  WordSize.fromBits chunkWidth)))
+	    val (s1, chunk) = Statement.andb (chunk, mask)
+	    val (component, s2) = Statement.resize (component, chunkWidth)
+	    val (s3, component) =
+	       Statement.lshift (component, Operand.word shift)
+	    val (s4, result) = Statement.orb (chunk, component)
+	 in
+	    (result, [s1] @ s2 @ [s3, s4])
+	 end
+
+      val update =
+	 Trace.trace2
+	 ("Unpack.update",
+	  layout,
+	  fn {chunk, component} =>
+	  Layout.record [("chunk", Operand.layout chunk),
+			 ("component", Operand.layout component)],
+	  Layout.tuple2 (Operand.layout,
+			 List.layout Statement.layout))
+	 update
    end
 
 structure Select =
@@ -469,12 +506,12 @@
 			      rest = rest,
 			      ty = ty}
 
-      fun select (s: t, {dst: unit -> Var.t * Type.t,
-			 tuple: unit -> Operand.t}): Statement.t list =
+      fun select (s: t, {dst: Var.t * Type.t,
+			 object: Operand.t}): Statement.t list =
 	 let
 	    fun move src =
 	       let
-		  val (dst, dstTy) = dst ()
+		  val (dst, dstTy) = dst
 		  val (src, ss) = Statement.resize (src, Type.width dstTy)
 	       in
 		  ss @ [Bind {dst = (dst, dstTy),
@@ -484,9 +521,9 @@
 	 in
 	    case s of
 	       None => []
-	     | Direct _ => move (tuple ())
+	     | Direct _ => move object
 	     | Indirect {offset, ty} =>
-		  move (Offset {base = tuple (),
+		  move (Offset {base = object,
 				offset = offset,
 				ty = ty})
 	     | IndirectUnpack {offset, rest, ty} =>
@@ -496,17 +533,44 @@
 		  in
 		     Bind {dst = (tmpVar, ty),
 			   isMutable = false,
-			   src = Offset {base = tuple (),
+			   src = Offset {base = object,
 					 offset = Words.toBytes offset,
 					 ty = ty}}
-		     :: Unpack.select (rest, {dst = dst (), src = tmpOp})
+		     :: Unpack.select (rest, {dst = dst, src = tmpOp})
 		  end
-	     | Unpack u => Unpack.select (u, {dst = dst (), src = tuple ()})
+	     | Unpack u => Unpack.select (u, {dst = dst, src = object})
 	 end
 
       val select =
 	 Trace.trace ("Select.select", layout o #1, List.layout Statement.layout)
 	 select
+
+      fun update (s: t, {object: Rssa.Operand.t,
+			 value: Rssa.Operand.t}): Statement.t list =
+	 case s of
+	    Indirect {offset, ty} =>
+	       [Move {dst = Offset {base = object,
+				    offset = offset,
+				    ty = ty},
+		      src = value}]
+	  | IndirectUnpack {offset, rest, ty} =>
+	       let
+		  val tmpVar = Var.newNoname ()
+		  val tmpOp = Var {ty = ty, var = tmpVar}
+		  val chunk = Offset {base = object,
+				      offset = Words.toBytes offset,
+				      ty = ty}
+		  val (newChunk, ss) = 
+		     Unpack.update (rest, {chunk = chunk,
+					   component = value})
+	       in
+		  ss @ [Move {dst = chunk, src = newChunk}]
+	       end
+	  | _ => Error.bug "Select.update of non indirect"
+
+      val update =
+	 Trace.trace ("Select.update", layout o #1, List.layout Statement.layout)
+	 update
    end
 
 structure Selects =
@@ -523,39 +587,20 @@
 			{orig = orig,
 			 select = f select}))
 
-      fun select (T v, {dst: unit -> Var.t * Type.t,
-			offset: int,
-			tuple: unit -> Operand.t}): Statement.t list =
+      fun select (T v, {dst: Var.t * Type.t,
+			object: Operand.t,
+			offset: int}): Statement.t list =
 	 Select.select (#select (Vector.sub (v, offset)),
-			{dst = dst, tuple = tuple})
+			{dst = dst, object = object})
+
+      fun update (T v, {object, offset, value}) =
+	 Select.update (#select (Vector.sub (v, offset)),
+			{object = object, value = value})
 
       fun lshift (T v, b: Bits.t) =
 	 T (Vector.map (v, fn {orig, select} =>
 			{orig = orig,
 			 select = Select.lshift (select, b)}))
-
-      fun goto (T v,
-		l: Label.t,
-		toRtype: S.Type.t -> R.Type.t option,
-		tuple: unit -> Operand.t): Statement.t list * Transfer.t =
-	 let
-	    val args = ref []
-	    val statements =
-	       Vector.foldr
-	       (v, [], fn ({orig, select}, ac) =>
-		case toRtype orig of
-		   NONE => ac
-		 | SOME ty =>
-		      let
-			 val x = Var.newNoname ()
-			 val () = List.push (args, Var {ty = ty, var = x})
-			 fun dst () = (x, ty)
-		      in
-			 Select.select (select, {dst = dst, tuple = tuple}) @ ac
-		      end)
-	 in
-	    (statements, Goto {args = Vector.fromList (!args), dst = l})
-	 end
    end
 
 structure PointerRep =
@@ -767,9 +812,6 @@
 	    Direct {selects, ...} => selects
 	  | Indirect (PointerRep.T {selects, ...}) => selects
 
-      fun select (tr: t, z) =
-	 Selects.select (selects tr, z)
-
       fun tuple (tr: t,
 		 {dst: Var.t * Type.t,
 		  src: {index: int} -> Operand.t}): Statement.t list =
@@ -786,9 +828,10 @@
 		       List.layout Statement.layout)
 	 tuple
 
-      val make: ((Rep.t * S.Type.t) vector * PointerTycon.t * {forceBox: bool}
-		 -> t) =
-	 fn (rs, pointerTycon, {forceBox}) =>
+      val make: PointerTycon.t * {isMutable: bool,
+				  rep: Rep.t,
+				  ty: S.Type.t} vector -> t =
+	 fn (pointerTycon, rs) =>
 	 let
 	    val pointers = ref []
 	    val doubleWords = ref []
@@ -796,7 +839,7 @@
 	    val a = Array.array (Bits.toInt Bits.inWord, [])
 	    val () =
 	       Vector.foreachi
-	       (rs, fn (i, (r as Rep.T {rep, ty}, _)) =>
+	       (rs, fn (i, {rep = r as Rep.T {rep, ty}, ...}) =>
 		case rep of
 		   Rep.NonPointer =>
 		      let
@@ -921,7 +964,7 @@
 	    fun getSelects s =
 	       Selects.T (Vector.tabulate
 			  (Array.length selects, fn i =>
-			   {orig = #2 (Vector.sub (rs, i)),
+			   {orig = #ty (Vector.sub (rs, i)),
 			    select = s (Array.sub (selects, i))}))
 	    fun box () =
 	       let
@@ -936,7 +979,7 @@
 					     tycon = pointerTycon})
 	       end
 	 in
-	    if forceBox
+	    if Vector.exists (rs, #isMutable)
 	       then box ()
 	    else
 	       case Vector.length components of
@@ -948,9 +991,10 @@
 	 end
 
       val make =
-	 Trace.trace ("TupleRep.make",
-		      (Vector.layout (Rep.layout o #1)) o #1,
-		      layout)
+	 Trace.trace2 ("TupleRep.make",
+		       PointerTycon.layout,
+		       Vector.layout (Rep.layout o #rep),
+		       layout)
 	 make
    end
 
@@ -979,41 +1023,64 @@
 structure ConRep =
    struct
       datatype t =
-	 Box of PointerRep.t
-       | ShiftAndTag of {component: Component.t,
+	 ShiftAndTag of {component: Component.t,
 			 selects: Selects.t,
 			 tag: WordX.t,
 			 ty: Type.t (* alread padded to prim *)}
-       | Tag of {tag: WordX.t}
-       | Transparent
-       | Unit
+       | Tag of {tag: WordX.t,
+		 ty: Type.t}
+       | Tuple of TupleRep.t
 
       val layout =
 	 let
 	    open Layout
 	 in
-	    fn Box pr => seq [str "Box ", PointerRep.layout pr]
-	     | ShiftAndTag {component, selects, tag, ty} =>
+	    fn ShiftAndTag {component, selects, tag, ty} =>
 		  seq [str "ShiftAndTag ",
 		       record [("component", Component.layout component),
 			       ("selects", Selects.layout selects),
 			       ("tag", WordX.layout tag),
 			       ("ty", Type.layout ty)]]
-	     | Tag {tag} =>
-		  seq [str "Tag ", WordX.layout tag]
-	     | Transparent => str "Transparent"
-	     | Unit => str "Unit"
+	     | Tag {tag, ...} => seq [str "Tag ", WordX.layout tag]
+	     | Tuple tr => TupleRep.layout tr
 	 end
 
-      fun conApp (r: t, {src: {index: int} -> Operand.t,
-			 dst: unit -> Var.t * Type.t}): Statement.t list =
+      val equals: t * t -> bool =
+	 fn (ShiftAndTag {component = c1, tag = t1, ...},
+	     ShiftAndTag {component = c2, tag = t2, ...}) =>
+	      Component.equals (c1, c2) andalso WordX.equals (t1, t2)
+	  | (Tag {tag = t1, ty = ty1}, Tag {tag = t2, ty = ty2}) =>
+	       WordX.equals (t1, t2) andalso Type.equals (ty1, ty2)
+	  | (Tuple tr1, Tuple tr2) => TupleRep.equals (tr1, tr2)
+	  | _ => false
+
+      val rep: t -> Rep.t =
+	 fn ShiftAndTag {ty, ...} => Rep.nonPointer ty
+	  | Tag {ty, ...} => Rep.nonPointer ty
+	  | Tuple tr => TupleRep.rep tr
+
+      val box = Tuple o TupleRep.Indirect
+
+      local
+	 fun make i = 
+	    let
+	       val tag = WordX.fromIntInf (i, WordSize.default)
+	    in
+	       Tag {tag = tag, ty = Type.constant tag}
+	    end
+      in
+	 val falsee = make 0
+	 val truee = make 1
+      end
+
+      val unit = Tuple TupleRep.unit
+	       
+      fun conApp (r: t, {dst: Var.t * Type.t,
+			 src: {index: int} -> Operand.t}): Statement.t list =
 	 case r of
-	    Box pr =>
-	       PointerRep.tuple (pr, {dst = #1 (dst ()),
-				      src = src})
-	  | ShiftAndTag {component, tag, ...} =>
+	    ShiftAndTag {component, tag, ...} =>
 	       let
-		  val (dstVar, dstTy) = dst ()
+		  val (dstVar, dstTy) = dst
 		  val shift = tagShift (WordSize.bits (WordX.size tag))
 		  val tmpVar = Var.newNoname ()
 		  val tmpTy =
@@ -1036,9 +1103,9 @@
 	       in
 		  component @ [s1, s2, s3]
 	       end
-	  | Tag {tag} =>
+	  | Tag {tag, ...} =>
 	       let
-		  val (dstVar, dstTy) = dst ()
+		  val (dstVar, dstTy) = dst
 	       in
 		  [Bind {dst = (dstVar, dstTy),
 			 isMutable = false,
@@ -1046,11 +1113,7 @@
 				(WordX.resize
 				 (tag, WordSize.fromBits (Type.width dstTy))))}]
 	       end
-	  | Transparent =>
-	       [Bind {dst = dst (),
-		      isMutable = false,
-		      src = src {index = 0}}]
-	  | Unit => []
+	  | Tuple tr => TupleRep.tuple (tr, {dst = dst, src = src})
 
       val conApp =
 	 Trace.trace ("ConRep.conApp", layout o #1, List.layout Statement.layout)
@@ -1139,37 +1202,24 @@
 	       Vector.keepAllMap
 	       (cases, fn (c, l) =>
 		case conRep c of
-		   ConRep.Box (PointerRep.T {selects, tycon, ...}) =>
-		      let
-			 val tag = PointerTycon.index tycon
-			 val pointerVar = Var.newNoname ()
-			 val pointerTy = Type.pointer tycon
-			 val pointerOp = Var {ty = pointerTy, var = pointerVar}
-			 val (ss, transfer) =
-			    Selects.goto (selects, l, toRtype,
-					  fn () => pointerOp)
-			 val ss =
-			    Vector.fromList
-			    (Bind {dst = (pointerVar, pointerTy),
-				   isMutable = false,
-				   src = Cast (test, pointerTy)}
-			     :: ss)
-			 val dst =
-			    Block.new {statements = ss,
-				       transfer = transfer}
-		      in
-			 SOME (WordX.fromIntInf (Int.toIntInf tag, wordSize),
-			       dst)
-		      end
+		   ConRep.Tuple (TupleRep.Indirect
+				 (PointerRep.T {ty, tycon, ...})) =>
+		      SOME (WordX.fromIntInf (Int.toIntInf
+					      (PointerTycon.index tycon),
+					      wordSize),
+			    Block.new
+			    {statements = Vector.new0 (),
+			     transfer =
+			     Goto {args = Vector.new1 (Cast (test, ty)),
+				   dst = l}})
 		 | _ => NONE)
 	    val default =
 	       if Vector.length variants = Vector.length cases
 		  then NONE
 	       else default
 	    val cases =
-	       QuickSort.sortVector 
-	       (cases, fn ((w, _), (w', _)) =>
-		WordX.le (w, w', {signed = false}))
+	       QuickSort.sortVector (cases, fn ((w, _), (w', _)) =>
+				     WordX.le (w, w', {signed = false}))
 	    val headerTy = headerTy ()
 	    val (s, tag) =
 	       Statement.rshift (Offset {base = test,
@@ -1207,6 +1257,12 @@
 	 val rep = make #rep
       end
 
+      val bool =
+	 T {isEnum = true,
+	    rep = Rep.bool,
+	    tagBits = Bits.fromInt 1,
+	    variants = Vector.new2 (Con.falsee, Con.truee)}
+
       fun genCase (T {isEnum, tagBits, variants, ...},
 		   {cases: (Con.t * Label.t) vector,
 		    conRep: Con.t -> ConRep.t,
@@ -1223,19 +1279,17 @@
 	       Vector.keepAllMap
 	       (cases, fn (c, l) =>
 		case conRep c of
-		   ConRep.ShiftAndTag {selects, tag, ty, ...} =>
+		   ConRep.ShiftAndTag {tag, ty, ...} =>
 		      let
 			 val test = Cast (test, Type.padToWidth (ty, testBits))
 			 val (test, ss) = Statement.resize (test, Type.width ty)
-			 val (ss', transfer) =
-			    Selects.goto (selects, l, toRtype, fn () => test)
-			 val statements = Vector.fromList (ss @ ss')
+			 val transfer = Goto {args = Vector.new1 test, dst = l}
 		      in
 			 SOME (WordX.resize (tag, wordSize),
-			       Block.new {statements = statements,
+			       Block.new {statements = Vector.fromList ss,
 					  transfer = transfer})
 		      end
-		 | ConRep.Tag {tag} =>
+		 | ConRep.Tag {tag, ...} =>
 		      SOME (WordX.resize (tag, wordSize), l)
 		 | _ => NONE)
 	    val cases = QuickSort.sortVector (cases, fn ((w, _), (w', _)) =>
@@ -1359,6 +1413,8 @@
 	     | Unit => str "Unit"
 	 end
 
+      val bool = Small Small.bool
+
       val unit = Unit
 
       val rep: t -> Rep.t =
@@ -1418,7 +1474,9 @@
 	    tagBitsNeeded
       end
 
-      fun make (variants: {args: (Rep.t * S.Type.t) vector,
+      fun make (variants: {args: {isMutable: bool,
+				  rep: Rep.t,
+				  ty: S.Type.t} vector,
 			   con: Con.t,
 			   pointerTycon: PointerTycon.t} vector)
 	 : t * {con: Con.t, rep: ConRep.t} vector =
@@ -1428,32 +1486,23 @@
 	    then
 	       let
 		  val {args, con, pointerTycon} = Vector.sub (variants, 0)
-		  val tupleRep = TupleRep.make (args, pointerTycon,
-						{forceBox = false})
-		  val conRep =
-		     case tupleRep of
-			TupleRep.Direct {component, ...} =>
-			   if Component.isUnit component
-			      then ConRep.Unit
-			   else ConRep.Transparent
-		      | TupleRep.Indirect pr => ConRep.Box pr
+		  val tupleRep = TupleRep.make (pointerTycon, args)
+		  val conRep = ConRep.Tuple tupleRep
 	       in
 		  (One {con = con, tupleRep = tupleRep},
 		   Vector.new1 {con = con, rep = conRep})
 	       end
+	 else if (2 = Vector.length variants
+		  andalso let
+			     val c = #con (Vector.sub (variants, 0))
+			  in
+			     Con.equals (c, Con.falsee)
+			     orelse Con.equals (c, Con.truee)
+			  end)
+	    then (bool, Vector.new2 ({con = Con.falsee, rep = ConRep.falsee},
+				     {con = Con.truee, rep = ConRep.truee}))
 	 else
 	 let
-	    val variants =
-	       if 2 = Vector.length variants
-		  then
-		     let
-			val c = Vector.sub (variants, 0)
-		     in
-			if Con.equals (#con c, Con.falsee)
-			   then Vector.new2 (Vector.sub (variants, 1), c)
-			else variants
-		     end
-	       else variants
 	    val numSmall = ref 0
 	    val small = Array.array (wordBits, [])
 	    val big = ref []
@@ -1461,8 +1510,7 @@
 	       Vector.foreach
 	       (variants, fn {args, con, pointerTycon} =>
 		let
-		   val tr = TupleRep.make (args, pointerTycon,
-					   {forceBox = false})
+		   val tr = TupleRep.make (pointerTycon, args)
 		   fun makeBig () =
 		      List.push (big,
 				 {con = con,
@@ -1506,8 +1554,8 @@
 		  then ac
 	       else noLargerThan (i - 1,
 				  List.fold (Array.sub (small, i), ac, op ::))
-	    (* Box as few things as possible so that the number of
-	     * tags available is >= the number of unboxed variants.
+	    (* Box as few things as possible so that the number of tags available
+	     * is >= the number of unboxed variants.
 	     *)
 	    fun loop (maxSmallWidth: int,
 		      forced,
@@ -1566,7 +1614,7 @@
 		     not (List.isEmpty big),
 		     Int.toIntInf numSmall)
 	    val maxSmallWidth = Bits.fromInt maxSmallWidth
-	    val withPointer = not (List.isEmpty big)
+	    val withPointer = not (List.isEmpty big andalso List.isEmpty forced)
 	    (* ShiftAndTag all the small. *)
 	    val (small: Small.t option, smallReps) =
 	       let
@@ -1607,6 +1655,10 @@
 				  Type.seq
 				  (Vector.new2 (Type.constant tag,
 						Component.ty component))
+			       val ty =
+				  if withPointer
+				     then Type.resize (ty, Bits.inPointer)
+				  else Type.padToPrim ty
 			    in
 			       {component = component,
 				con = con,
@@ -1621,12 +1673,12 @@
 			   (small, fn {component, con, selects, tag, ty, ...} =>
 			    {con = con,
 			     rep = if Component.isUseless component
-				      then ConRep.Tag {tag = tag}
+				      then ConRep.Tag {tag = tag, ty = ty}
 				   else (ConRep.ShiftAndTag
 					 {component = component,
 					  selects = selects,
 					  tag = tag,
-					  ty = Type.padToPrim ty})})
+					  ty = ty})})
 			val isEnum =
 			   Vector.forall
 			   (reps, fn {rep, ...} =>
@@ -1642,13 +1694,10 @@
 		     end
 	       end
 	    fun makeSmallPointer {component, con, pointerTycon, selects} =
-	       let
-		  val component =
-		     Component.padToWidth (component, Bits.inWord)
-	       in
-		  {con = con,
-		   pointer = PointerRep.box (component, pointerTycon, selects)}
-	       end
+	       {con = con,
+		pointer = (PointerRep.box
+			   (Component.padToWidth (component, Bits.inWord),
+			    pointerTycon, selects))}
 	    fun makeBigPointer {con, pointerTycon, tupleRep} =
 	       let
 		  val pr =
@@ -1659,14 +1708,11 @@
 	       in
 		  {con = con, pointer = pr}
 	       end
-	    fun sumWithSmall r =
-	       let
-		  val t = Type.resize (Rep.ty (Small.rep (valOf small)),
-				       Bits.inPointer)
-	       in
-		  Rep.T {rep = Rep.Pointer {endsIn00 = false},
-			 ty = Type.sum (Vector.new2 (Rep.ty r, t))}
-	       end
+	    fun sumWithSmall (r: Rep.t): Rep.t =
+	       Rep.T {rep = Rep.Pointer {endsIn00 = false},
+		      ty = Type.sum (Vector.new2
+				     (Rep.ty r,
+				      Rep.ty (Small.rep (valOf small))))}
 	    fun box () =
 	       let
 		  val pointers =
@@ -1709,7 +1755,7 @@
 		  (sumRep,
 		   Vector.map (pointers, fn {con, pointer} =>
 			       {con = con,
-				rep = ConRep.Box pointer}))
+				rep = ConRep.box pointer}))
 	       end
 	    val (sumRep, pointerReps) =
 	       case (forced, big) of
@@ -1733,8 +1779,9 @@
 						     con = con},
 					  rep = sumWithSmall rep,
 					  small = small},
-					 Vector.new1 {con = con,
-						      rep = ConRep.Transparent})
+					 Vector.new1
+					 {con = con,
+					  rep = ConRep.Tuple tupleRep})
 				     end
 			       else box ()
 			    end
@@ -1749,9 +1796,13 @@
 	 ("TyconRep.make",
 	  Vector.layout
 	  (fn {args, con, ...} =>
-	   Layout.record [("args", Vector.layout (Rep.layout o #1) args),
+	   Layout.record [("args", Vector.layout (Rep.layout o #rep) args),
 			  ("con", Con.layout con)]),
-	  layout o #1)
+	  Layout.tuple2 (layout,
+			 Vector.layout
+			 (fn {con, rep} =>
+			  Layout.record [("con", Con.layout con),
+					 ("rep", ConRep.layout rep)])))
 	 make
 
       fun genCase (r: t,
@@ -1775,8 +1826,9 @@
 			    in
 			       if not (Con.equals (c, con))
 				  then Error.bug "genCase One"
-			       else Selects.goto (TupleRep.selects tupleRep,
-						  l, toRtype, test)
+			       else
+				  ([], Goto {args = Vector.new1 (test ()),
+					     dst = l})
 			    end
 		       | (0, SOME l) =>
 			    ([], Goto {dst = l, args = Vector.new0 ()})
@@ -1805,13 +1857,12 @@
 				 let
 				    val test =
 				       Cast (test (), PointerRep.ty pointer)
-				    val (ss, t) =
-				       Selects.goto (PointerRep.selects pointer,
-						     l, toRtype, fn () => test)
 				 in
-				    SOME (Block.new
-					  {statements = Vector.fromList ss,
-					   transfer = t})
+				    SOME
+				    (Block.new
+				     {statements = Vector.new0 (),
+				      transfer = Goto {args = Vector.new1 test,
+						       dst = l}})
 				 end
 		     in
 			Small.genCase (small, {cases = cases,
@@ -1902,6 +1953,7 @@
       val new: {compute: unit -> 'a,
 		equals: 'a * 'a -> bool,
 		init: 'a} -> 'a t
+      val set: 'a t * 'a -> unit
    end =
    struct
       structure Dep =
@@ -1969,6 +2021,13 @@
 	 fn Constant a => a
 	  | Variable (_, r) => !r
 
+      fun set (v, a) =
+	 case v of
+	    Constant _ => Error.bug "Value.set"
+	  | Variable (Dep.T {affects, ...}, r) =>
+	       (r := a
+		; List.foreach (!affects, Dep.recompute))
+
       val constant = Constant
 
       fun new z = Variable (Dep.new z)
@@ -1983,35 +2042,66 @@
 
 fun compute (program as Ssa.Program.T {datatypes, ...}) =
    let
-      val {get = refRep: S.Type.t -> TupleRep.t Value.t,
-	   set = setRefRep, ...} =
-	 Property.getSetOnce (S.Type.plist,
-			      Property.initRaise ("refRep", S.Type.layout))
+      type tyconRepAndCons =
+	 (TyconRep.t * {con: Con.t, rep: ConRep.t} vector) Value.t
+      val {get = conInfo: Con.t -> {rep: ConRep.t ref,
+				    tyconRep: tyconRepAndCons},
+	   set = setConInfo, ...} =
+	 Property.getSetOnce (Con.plist, Property.initRaise ("info", Con.layout))
       val {get = tupleRep: S.Type.t -> TupleRep.t Value.t,
 	   set = setTupleRep, ...} =
 	 Property.getSetOnce (S.Type.plist,
 			      Property.initRaise ("tupleRep", S.Type.layout))
-      val {get = tyconRep: (Tycon.t
-			    -> (TyconRep.t
-				* {con: Con.t, rep: ConRep.t} vector) Value.t),
-	   set = setTyconRep, ...} =
+      val {get = tyconRep: Tycon.t -> tyconRepAndCons, set = setTyconRep, ...} =
 	 Property.getSetOnce (Tycon.plist,
 			      Property.initRaise ("tyconRep", Tycon.layout))
       (* Initialize the datatypes. *)
+      val typeRepRef = ref (fn _ => raise Fail "typeRepRef not set")
+      fun typeRep t = !typeRepRef t
       val datatypes =
 	 Vector.map
 	 (datatypes, fn S.Datatype.T {cons, tycon} =>
 	  let
-	     val computeRef = ref (fn () => raise Fail "can't compute")
+	     val cons =
+		Vector.map
+		(cons, fn {args, con} =>
+		 {args = args,
+		  con = con,
+		  pointerTycon = PointerTycon.new ()})
+	     fun compute () =
+		let
+		   val (tr, cons) =
+		      TyconRep.make
+		      (Vector.map
+		       (cons, fn {args, con, pointerTycon} =>
+			{args = Vector.map (args, fn {elt, isMutable} =>
+					    {isMutable = isMutable,
+					     rep = Value.get (typeRep elt),
+					     ty = elt}),
+			 con = con,
+			 pointerTycon = pointerTycon}))
+		   val () =
+		      Vector.foreach
+		      (cons, fn {con, rep} => #rep (conInfo con) := rep)
+		in
+		   (tr, cons)
+		end
+	     fun equals ((r, v), (r', v')) =
+		TyconRep.equals (r, r')
+		andalso Vector.equals (v, v', fn ({con = c, rep = r},
+						  {con = c', rep = r'}) =>
+				       Con.equals (c, c')
+				       andalso ConRep.equals (r, r'))
 	     val rep =
-		Value.new
-		{compute = fn () => ! computeRef (),
-		 equals = fn ((r, _), (r', _)) => TyconRep.equals (r, r'),
-		 init = (TyconRep.unit, Vector.new0 ())}
+		Value.new {compute = compute,
+			   equals = equals,
+			   init = (TyconRep.unit, Vector.new0 ())}
 	     val () = setTyconRep (tycon, rep)
+	     val () = Vector.foreach (cons, fn {con, ...} =>
+				      setConInfo (con, {rep = ref ConRep.unit,
+							tyconRep = rep}))
 	  in
-	     {computeRef = computeRef,
-	      cons = cons,
+	     {cons = cons,
 	      rep = rep,
 	      tycon = tycon}
 	  end)
@@ -2062,31 +2152,6 @@
 		    constant (Rep.T {rep = Rep.Pointer {endsIn00 = true},
 				     ty = ty})
 		 end
-	      fun tuple (ts: S.Type.t vector,
-			 pt: PointerTycon.t,
-			 {forceBox: bool}): TupleRep.t Value.t =
-		 let
-		    val rs = Vector.map (ts, typeRep)
-		    fun compute () =
-		       TupleRep.make (Vector.map2 (rs, ts, fn (r, t) =>
-						   (Value.get r, t)),
-				      pt, {forceBox = forceBox})
-		    val tr =
-		       Value.new {compute = compute,
-				  equals = TupleRep.equals,
-				  init = TupleRep.unit}
-		    val () = Vector.foreach (rs, fn r => Value.affect (r, tr))
-		    val () =
-		       List.push
-		       (delayedObjectTypes, fn () =>
-			case Value.get tr of
-			   TupleRep.Indirect pr =>
-			      SOME (pt, (ObjectType.Normal
-					 (PointerRep.componentsTy pr)))
-			 | _ => NONE)
-		 in
-		    tr
-		 end
 	      datatype z = datatype S.Type.dest
 	   in
 	      case S.Type.dest t of
@@ -2105,32 +2170,57 @@
 	       | IntInf =>
 		    constant (Rep.T {rep = Rep.Pointer {endsIn00 = false},
 				     ty = Type.intInf})
+	       | Object {args, con} =>
+		    (case con of
+			NONE =>
+			   let
+			      val pt = PointerTycon.new ()
+			      val rs = Vector.map (args, typeRep o #elt)
+			      fun compute () =
+				 TupleRep.make
+				 (pt,
+				  Vector.map2
+				  (rs, args, fn (r, {elt, isMutable}) =>
+				   {isMutable = isMutable,
+				    rep = Value.get r,
+				    ty = elt}))
+			      val tr =
+				 Value.new {compute = compute,
+					    equals = TupleRep.equals,
+					    init = TupleRep.unit}
+			      val () = Vector.foreach (rs, fn r => Value.affect (r, tr))
+			      val () =
+				 List.push
+				 (delayedObjectTypes, fn () =>
+				  case Value.get tr of
+				     TupleRep.Indirect pr =>
+					SOME (pt, (ObjectType.Normal
+						   (PointerRep.componentsTy pr)))
+				   | _ => NONE)
+			      val () = setTupleRep (t, tr)
+			      fun compute () = TupleRep.rep (Value.get tr)
+			      val r = Value.new {compute = compute,
+						 equals = Rep.equals,
+						 init = Rep.unit}
+			      val () = Value.affect (tr, r)
+			   in
+			      r
+			   end
+		      | SOME con =>
+			   let
+			      val {rep, tyconRep} = conInfo con
+			      fun compute () = ConRep.rep (!rep)
+			      val r = Value.new {compute = compute,
+						 equals = Rep.equals,
+						 init = Rep.unit}
+			      val () = Value.affect (tyconRep, r)
+			   in
+			      r
+			   end)
 	       | Real s => nonPointer (Type.real s)
-	       | Ref t =>
-		    let
-		       val pt = PointerTycon.new ()
-		       val tr = tuple (Vector.new1 t, pt, {forceBox = true})
-		       val () = setRefRep (t, tr)
-		    in
-		       constant (Rep.T {rep = Rep.Pointer {endsIn00 = true},
-					ty = Type.pointer pt})
-		    end
 	       | Thread =>
 		    constant (Rep.T {rep = Rep.Pointer {endsIn00 = true},
 				     ty = Type.thread})
-	       | Tuple ts =>
-		    let
-		       val pt = PointerTycon.new ()
-		       val tr = tuple (ts, pt, {forceBox = false})
-		       val () = setTupleRep (t, tr)
-		       fun compute () = TupleRep.rep (Value.get tr)
-		       val r = Value.new {compute = compute,
-					  equals = Rep.equals,
-					  init = Rep.unit}
-		       val () = Value.affect (tr, r)
-		    in
-		       r
-		    end
 	       | Vector t => array {mutable = false, ty = t}
 	       | Weak t =>
 		    let
@@ -2162,59 +2252,31 @@
 		    end
 	     | Word s => nonPointer (Type.word (WordSize.bits s))
 	   end))
+      val () = typeRepRef := typeRep
+      (* Establish dependence between constructor argument type representations
+       * and tycon representations.
+       *)
+      val () =
+	 Vector.foreach
+	 (datatypes, fn {cons, rep, ...} =>
+	  Vector.foreach
+	  (cons, fn {args, con, ...} =>
+	   Vector.foreach (args, fn {elt, ...} =>
+			   Value.affect (typeRep elt, rep))))
       val () = S.Program.foreachVar (program, fn (_, t) => ignore (typeRep t))
-      val datatypes =
-	 Vector.map
-	 (datatypes, fn {computeRef, cons, rep, tycon} =>
-	  let
-	     val cons =
-		Vector.map
-		(cons, fn {args, con} =>
-		 let
-		    val pt = PointerTycon.new ()
-		 in
-		    {args = Vector.map (args, fn t =>
-					let
-					   val r = typeRep t
-					   val () = Value.affect (r, rep)
-					in
-					   (t, r)
-					end),
-		     con = con,
-		     pointerTycon = pt}
-		 end)
-	     fun compute () =
-		TyconRep.make
-		(Vector.map (cons, fn {args, con, pointerTycon} =>
-			     {args = Vector.map (args, fn (t, r) =>
-						 (Value.get r, t)), 
-			      con = con,
-			      pointerTycon = pointerTycon}))
-	     val () = computeRef := compute
-	  in
-	     {cons = cons,
-	      rep = rep,
-	      tycon = tycon}
-	  end)
       val () = Value.fixedPoint ()
-      val {get = conRep, set = setConRep, ...} =
-	 Property.getSetOnce (Con.plist, Property.initRaise ("rep", Con.layout))
+      val conRep = ! o #rep o conInfo
+      val tyconRep = #1 o Value.get o tyconRep
       val objectTypes =
 	 Vector.fold
 	 (datatypes, [], fn ({cons, rep, ...}, ac) =>
-	  let
-	     val (_, conReps) = Value.get rep
-	     val () =
-		Vector.foreach (conReps, fn {con, rep} => setConRep (con, rep))
-	  in
-	     Vector.fold
-	     (cons, ac, fn ({con, pointerTycon, ...}, ac) =>
-	      case conRep con of
-		 ConRep.Box pr =>
-		    (pointerTycon,
-		     ObjectType.Normal (PointerRep.componentsTy pr)) :: ac
-	       | _ => ac)
-	  end)
+	  Vector.fold
+	  (cons, ac, fn ({con, pointerTycon, ...}, ac) =>
+	   case conRep con of
+	      ConRep.Tuple (TupleRep.Indirect pr) =>
+		 (pointerTycon,
+		  ObjectType.Normal (PointerRep.componentsTy pr)) :: ac
+	    | _ => ac))
       val objectTypes = ref objectTypes
       val () =
 	 List.foreach (!delayedObjectTypes, fn f =>
@@ -2230,90 +2292,74 @@
 		  open Layout
 	       in
 		  display (seq [Tycon.layout tycon,
-				str " ",
-				TyconRep.layout
-				(#1 (Value.get (tyconRep tycon)))])
+				str " ", TyconRep.layout (tyconRep tycon)])
 		  ; display (indent
-			     (Vector.layout (fn {con, ...} =>
-					     record
-					     [("con", Con.layout con),
-					      ("rep",
-					       ConRep.layout (conRep con))])
+			     (Vector.layout
+			      (fn {con, ...} =>
+			       record [("con", Con.layout con),
+				       ("rep", ConRep.layout (conRep con))])
 			      cons,
 			      2))
 	       end))))
       fun toRtype (t: S.Type.t): Type.t option =
 	 let
-	    fun normal () =
-	       let
-		  val ty = Rep.ty (Value.get (typeRep t))
-	       in
-		  if Type.isUnit ty
-		     then NONE
-		  else SOME (Type.padToPrim ty)
-	       end
-	    datatype z = datatype S.Type.dest
+	    val ty = Rep.ty (Value.get (typeRep t))
 	 in
-	    case S.Type.dest t of
-	       Datatype c =>
-		  if Tycon.equals (c, Tycon.bool)
-		     then SOME Type.bool
-		  else normal ()
-	     | _ => normal ()
+	    if Type.isUnit ty
+	       then NONE
+	    else SOME (Type.padToPrim ty)
 	 end
       fun makeSrc (v, oper) {index} = oper (Vector.sub (v, index))
-      fun conApp {args, con, dst, oper, ty} =
-	 ConRep.conApp (conRep con,
-			{src = makeSrc (args, oper),
-			 dst = fn () => (dst (), ty ())})
-      val conApp =
-	 Trace.trace ("conApp", Con.layout o #con, List.layout Statement.layout)
-	 conApp
       fun genCase {cases, default, test, tycon} =
 	 TyconRep.genCase
-	 (#1 (Value.get (tyconRep tycon)),
+	 (tyconRep tycon,
 	  {cases = cases,
 	   conRep = conRep,
 	   default = default,
 	   test = test,
 	   toRtype = toRtype})
-      fun reff {arg: unit -> Rssa.Operand.t, dst: Rssa.Var.t, ty} =
+      fun object {args, con, dst, objectTy, oper} =
 	 let
-	    val tr = Value.get (refRep ty)
+	    val src = makeSrc (args, oper)
 	 in
-	    TupleRep.tuple (tr, {dst = (dst, TupleRep.ty tr),
-				 src = fn _ => arg ()})
-	 end
-      fun select {dst, offset, tuple, tupleTy} =
-	 let
-	    val dst =
-	       fn () =>
-	       case S.Type.dest tupleTy of
-		  S.Type.Tuple ts =>
-		     (dst (), valOf (toRtype (Vector.sub (ts, offset))))
-		| _ => Error.bug "select"
-	 in
-	    TupleRep.select (Value.get (tupleRep tupleTy),
-			     {dst = dst,
-			      offset = offset,
-			      tuple = tuple})
-	 end
-      fun tuple {components, dst = (dstVar, dstTy), oper} =
-	 case toRtype dstTy of
-	    NONE => []
-	  | SOME t => 
-	       TupleRep.tuple (Value.get (tupleRep dstTy),
-			       {dst = (dstVar, t),
-				src = makeSrc (components, oper)})
+	    case con of
+	       NONE => TupleRep.tuple (Value.get (tupleRep objectTy),
+				       {dst = dst, src = src})
+	     | SOME con => ConRep.conApp (conRep con, {dst = dst, src = src})
+	 end
+      fun getSelects (con, objectTy) =
+	 case con of
+	    NONE => TupleRep.selects (Value.get (tupleRep objectTy))
+	  | SOME con =>
+	       case conRep con of
+		  ConRep.ShiftAndTag {selects, ...} => selects
+		| ConRep.Tuple tr => TupleRep.selects tr
+		| _ => Error.bug "can't get con selects"
+      fun select {dst, object, objectTy, offset} =
+	 case S.Type.dest objectTy of
+	    S.Type.Object {args, con} =>
+	       Selects.select
+	       (getSelects (con, objectTy),
+		{dst = (dst, valOf (toRtype (#elt (Vector.sub (args, offset))))),
+		 object = object,
+		 offset = offset})
+	  | _ => Error.bug "select of non object"
+      fun update {object, objectTy, offset, value} =
+	 case S.Type.dest objectTy of
+	    S.Type.Object {args, con} =>
+	       Selects.update (getSelects (con, objectTy),
+			       {object = object,
+				offset = offset,
+				value = value})
+	  | _ => Error.bug "update of non object"
    in
-      {conApp = conApp,
-       diagnostic = diagnostic,
+      {diagnostic = diagnostic,
        genCase = genCase,
+       object = object,
        objectTypes = objectTypes,
-       reff = reff,
        select = select,
        toRtype = toRtype,
-       tuple = tuple}
+       update = update}
    end
 
 end



1.7       +42 -30    mlton/mlton/backend/rep-type.fun

Index: rep-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rep-type.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- rep-type.fun	1 May 2004 00:49:35 -0000	1.6
+++ rep-type.fun	25 May 2004 04:02:59 -0000	1.7
@@ -54,42 +54,54 @@
 
       val toString = Layout.toString o layout
 
-      fun compare (t, t') =
-	 case (dest t, dest t') of
-	    (Address t, Address t') => compare (t, t')
-	  | (Address _, _) => LESS
-	  | (Constant w, Constant w') =>
-	       Relation.lexico
-	       (WordSize.compare (WordX.size w, WordX.size w'), fn () =>
-		IntInf.compare (WordX.toIntInf w, WordX.toIntInf w'))
-	  | (Constant _, _) => LESS
-	  | (ExnStack, ExnStack) => EQUAL
-	  | (ExnStack, _) => LESS
-	  | (GCState, GCState) => EQUAL
-	  | (GCState, _) => LESS
-	  | (Junk b, Junk b') => Bits.compare (b, b')
-	  | (Junk _, _) => LESS
-	  | (Label l, Label l') =>
-	       String.compare (Label.originalName l, Label.originalName l')
-	  | (Label _, _) => LESS
-	  | (Pointer p, Pointer p') => PointerTycon.compare (p, p')
-	  | (Pointer _, _) => LESS
-	  | (Real s, Real s') => RealSize.compare (s, s')
-	  | (Real _, _) => LESS
-	  | (Seq ts, Seq ts') => compares (ts, ts')
-	  | (Seq _, _) => LESS
-	  | (Sum ts, Sum ts') => compares (ts, ts')
-	  | (Sum _, _) => LESS
-	  | (Word s, Word s') => Bits.compare (s, s')
-	  | _ => GREATER
-      and compares (ts: t vector, ts': t vector): Relation.t =
-	 Vector.compare (ts, ts', compare)
+      val toInt: t -> int =
+	 fn t =>
+	 case dest t of
+	    Address _ => 0
+	  | Constant _ => 1
+	  | ExnStack => 2
+	  | GCState => 3
+	  | Junk _ => 4
+	  | Label _ => 5
+	  | Pointer _ => 6
+	  | Real _ => 7
+	  | Seq _ => 8
+	  | Sum _ => 9
+	  | Word _ => 10
+
+      val rec compare: t * t -> Relation.t =
+	 fn (t, t') =>
+	 Relation.lexico
+	 (Int.compare (toInt t, toInt t'), fn () =>
+	  case (dest t, dest t') of
+	     (Address t, Address t') => compare (t, t')
+	   | (Constant w, Constant w') =>
+		Relation.lexico
+		(WordSize.compare (WordX.size w, WordX.size w'), fn () =>
+		 IntInf.compare (WordX.toIntInf w, WordX.toIntInf w'))
+	   | (ExnStack, ExnStack) => EQUAL
+	   | (GCState, GCState) => EQUAL
+	   | (Junk b, Junk b') => Bits.compare (b, b')
+	   | (Label l, Label l') =>
+		String.compare (Label.originalName l, Label.originalName l')
+	   | (Pointer p, Pointer p') => PointerTycon.compare (p, p')
+	   | (Real s, Real s') => RealSize.compare (s, s')
+	   | (Seq ts, Seq ts') => compares (ts, ts')
+	   | (Sum ts, Sum ts') => compares (ts, ts')
+	   | (Word s, Word s') => Bits.compare (s, s')
+	   | _ => Error.bug "RepType.compare")
+      and compares: t vector * t vector -> Relation.t =
+	 fn (ts, ts') => Vector.compare (ts, ts', compare)
 
       val {<= = lessEq, equals, ...} = Relation.compare compare
 
       val equals =
 	 Trace.trace2 ("RepType.equals", layout, layout, Bool.layout)
 	 equals
+
+      val lessEq =
+	 Trace.trace2 ("RepType.lessEq", layout, layout, Bool.layout)
+	 lessEq
 
       local
 	 val word = Bits.inWord



1.13      +15 -17    mlton/mlton/backend/representation.sig

Index: representation.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.sig,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- representation.sig	1 May 2004 00:49:35 -0000	1.12
+++ representation.sig	25 May 2004 04:02:59 -0000	1.13
@@ -10,7 +10,7 @@
 signature REPRESENTATION_STRUCTS = 
    sig
       structure Rssa: RSSA
-      structure Ssa: SSA
+      structure Ssa: SSA2
       sharing Rssa.RealSize = Ssa.RealSize
       sharing Rssa.WordSize = Ssa.WordSize
    end
@@ -21,28 +21,26 @@
 
       val compute:
 	 Ssa.Program.t
-	 -> {conApp: {args: 'a vector,
-		      con: Ssa.Con.t,
-		      dst: unit -> Rssa.Var.t,
-		      oper: 'a -> Rssa.Operand.t,
-		      ty: unit -> Rssa.Type.t} -> Rssa.Statement.t list,
-	     diagnostic: unit -> unit,
+	 -> {diagnostic: unit -> unit,
 	     genCase: {cases: (Ssa.Con.t * Rssa.Label.t) vector,
 		       default: Rssa.Label.t option,
 		       test: unit -> Rssa.Operand.t,
 		       tycon: Ssa.Tycon.t} -> (Rssa.Statement.t list
 					       * Rssa.Transfer.t
 					       * Rssa.Block.t list),
+	     object: {args: 'a vector,
+		      con: Ssa.Con.t option,
+		      dst: Rssa.Var.t * Rssa.Type.t,
+		      objectTy: Ssa.Type.t,
+		      oper: 'a -> Rssa.Operand.t} -> Rssa.Statement.t list,
 	     objectTypes: (Rssa.PointerTycon.t * Rssa.ObjectType.t) vector,
-	     reff: {arg: unit -> Rssa.Operand.t,
-		    dst: Rssa.Var.t,
-		    ty: Ssa.Type.t} -> Rssa.Statement.t list,
-	     select: {dst: unit -> Rssa.Var.t,
-		      offset: int,
-		      tuple: unit -> Rssa.Operand.t,
-		      tupleTy: Ssa.Type.t} -> Rssa.Statement.t list,
+	     select: {dst: Rssa.Var.t,
+		      object: Rssa.Operand.t,
+		      objectTy: Ssa.Type.t,
+		      offset: int} -> Rssa.Statement.t list,
 	     toRtype: Ssa.Type.t -> Rssa.Type.t option,
-	     tuple: {components: 'a vector,
-		     dst: Rssa.Var.t * Ssa.Type.t,
-		     oper: 'a -> Rssa.Operand.t} -> Rssa.Statement.t list}
+	     update: {object: Rssa.Operand.t,
+		      objectTy: Ssa.Type.t,
+		      offset: int,
+		      value: Rssa.Operand.t} -> Rssa.Statement.t list}
    end



1.20      +1 -1      mlton/mlton/backend/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/sources.cm,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- sources.cm	25 Apr 2004 06:55:44 -0000	1.19
+++ sources.cm	25 May 2004 04:02:59 -0000	1.20
@@ -35,7 +35,7 @@
 rssa.sig
 rssa.fun
 representation.sig
-representation.fun
+(* representation.fun *)
 packed-representation.fun
 ssa-to-rssa.sig
 ssa-to-rssa.fun



1.80      +70 -87    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.79
retrieving revision 1.80
diff -u -r1.79 -r1.80
--- ssa-to-rssa.fun	13 May 2004 20:34:51 -0000	1.79
+++ ssa-to-rssa.fun	25 May 2004 04:02:59 -0000	1.80
@@ -319,8 +319,9 @@
 datatype z = datatype Statement.t
 datatype z = datatype Transfer.t
 
-structure Representation = Representation (structure Rssa = Rssa
-					   structure Ssa = Ssa)
+(* structure Representation = Representation (structure Rssa = Rssa
+ * 					   structure Ssa = Ssa)
+ *)
 structure PackedRepresentation = PackedRepresentation (structure Rssa = Rssa
 						       structure Ssa = Ssa)
 
@@ -352,7 +353,9 @@
    in
       if not (!Control.markCards) orelse not (Type.isPointer ty)
 	 then
-	    ss @ [Move {dst = ArrayOffset {base = array, index = index, ty = ty},
+	    ss @ [Move {dst = ArrayOffset {base = array,
+					   index = index,
+					   ty = arrayElementTy},
 			src = elt}]
       else
 	 let
@@ -382,7 +385,7 @@
 	    @ updateCard addrOp
 	    @ [Move {dst = Offset {base = addrOp,
 				   offset = Bytes.zero,
-				   ty = ty},
+				   ty = arrayElementTy},
 		     src = elt}]
 	 end
    end
@@ -401,11 +404,12 @@
 fun convert (program as S.Program.T {functions, globals, main, ...},
 	     {codegenImplementsPrim}): Rssa.Program.t =
    let
-      val {conApp, diagnostic, genCase, objectTypes, reff, select, toRtype,
-	   tuple} =
+      val {diagnostic, genCase, object, objectTypes, select, toRtype, update} =
 	 (case !Control.representation of
 	     Control.Packed => PackedRepresentation.compute
-	   | Control.Unpacked => Representation.compute) program
+	   | Control.Unpacked =>
+		Error.bug "-representation unpacked is not implemented"
+		(*Representation.compute*)) program
       val objectTypes = Vector.concat [ObjectType.basic, objectTypes]
       val () =
 	 Vector.foreachi
@@ -456,26 +460,22 @@
 	    S.Cases.Con cases =>
 	       (case (Vector.length cases, default) of
 		   (0, NONE) => ([], Transfer.bug)
-		 | _ => 
-		      let
-			 val (tycon, tys) = S.Type.tyconArgs (varType test)
-		      in
-			 if Vector.isEmpty tys
-			    then
-			       let
-				  val test = fn () => varOp test
-				  val (ss, t, blocks) =
-				     genCase {cases = cases,
-					      default = default,
-					      test = test,
-					      tycon = tycon}
-				  val () =
-				     extraBlocks := blocks @ !extraBlocks
-			       in
-				  (ss, t)
-			       end
-			 else Error.bug "strange type in case"
-		      end)
+		 | _ =>
+		      (case S.Type.dest (varType test) of
+			  S.Type.Datatype tycon =>
+			     let
+				val test = fn () => varOp test
+				val (ss, t, blocks) =
+				   genCase {cases = cases,
+					    default = default,
+					    test = test,
+					    tycon = tycon}
+				val () =
+				   extraBlocks := blocks @ !extraBlocks
+			     in
+				(ss, t)
+			     end
+			| _ => Error.bug "strange type in case"))
 	  | S.Cases.Word (s, cs) =>
 	       ([],
 		Switch
@@ -710,14 +710,16 @@
 				   src = src})				   
 		  in
 		     case exp of
-			S.Exp.ConApp {con, args} =>
-			   adds (conApp
-				 {args = args,
-				  con = con,
-				  dst = fn () => valOf var,
-				  oper = varOp,
-				  ty = fn () => valOf (toRtype ty)})
-		      | S.Exp.Const c => move (Const (convertConst c))
+			S.Exp.Const c => move (Const (convertConst c))
+		      | S.Exp.Object {args, con} =>
+			   (case toRtype ty of
+			       NONE => none ()
+			     | SOME dstTy => 
+				  adds (object {args = args,
+						con = con,
+						dst = (valOf var, dstTy),
+						objectTy = ty,
+						oper = varOp}))
 		      | S.Exp.PrimApp {prim, targs, args, ...} =>
 			   let
 			      val prim = translatePrim prim
@@ -869,25 +871,6 @@
 						      index = a 1,
 						      ty = ty},
 				   src = a 2})
-		     fun refAssign (ty, src) =
-		        let
-			   val addr = a 0
-			   val offset =
-			      Rssa.byteOffset {offset = Bytes.zero,
-					       ty = ty}
-			   val ss =
-			      Move {dst = Offset {base = addr,
-						  offset = offset,
-						  ty = ty},
-				    src = src}
-			      :: ss
-			   val ss =
-			      if !Control.markCards andalso Type.isPointer ty
-				 then updateCard addr @ ss
-			      else ss
-			in
-			   loop (i - 1, ss, t)
-			end
 		     fun codegenOrC (p: Prim.t) =
 			let
 			   val n = Prim.name p
@@ -994,28 +977,6 @@
 				      | SOME t => pointerSet t)
 			       | Pointer_setReal s => pointerSet (Type.real s)
 			       | Pointer_setWord s => pointerSet (word s)
-			       | Ref_assign =>
-				    (case targ () of
-					NONE => none ()
-				      | SOME ty => refAssign (ty, a 1))
-			       | Ref_deref =>
-				    (case targ () of
-					NONE => none ()
-				      | SOME ty =>
-					   let
-					      val offset =
-						 Rssa.byteOffset
-						 {offset = Bytes.zero,
-						  ty = ty}
-					   in
-					      move (Offset {base = a 0,
-							    offset = offset,
-							    ty = ty})
-					   end)
-			       | Ref_ref =>
-				    adds (reff {arg = fn () => a 0,
-						dst = valOf var,
-						ty = Vector.sub (targs, 0)})
 			       | Thread_atomicBegin =>
 				    (* gcState.canHandle++;
 				     * if (gcState.signalIsPending)
@@ -1213,17 +1174,39 @@
 			       | _ => codegenOrC prim
 			   end
 		      | S.Exp.Profile e => add (Statement.Profile e)
-		      | S.Exp.Select {tuple, offset} =>
-			   adds (select {dst = fn () => valOf var,
-					 offset = offset,
-					 tuple = fn () => varOp tuple,
-					 tupleTy = varType tuple})
-		      | S.Exp.Tuple ys =>
-			   if 0 = Vector.length ys
-			      then none ()
-			   else adds (tuple {components = ys,
-					     dst = (valOf var, ty),
-					     oper = varOp})
+		      | S.Exp.Select {object, offset} =>
+			   (case var of
+			       NONE => none ()
+			     | SOME var => 
+				  (case toRtype ty of
+				      NONE => none ()
+				    | SOME _ => 
+					 adds (select {dst = var,
+						       object = varOp object,
+						       objectTy = varType object,
+						       offset = offset})))
+		      | S.Exp.Update {object, offset, value} =>
+			   (case toRtype (varType value) of
+			       NONE => none ()
+			     | SOME _ => 
+				  let
+				     val objectTy = varType object
+				     val object = varOp object
+				     val value = varOp value
+				     val ss =
+					update {object = object,
+						objectTy = objectTy,
+						offset = offset,
+						value = value}
+				     val ss =
+					if !Control.markCards
+					   andalso
+					   Type.isPointer (Operand.ty value)
+					   then updateCard object @ ss
+					else ss
+				  in
+				     adds ss
+				  end)
 		      | S.Exp.Var y =>
 			   (case toRtype ty of
 			       NONE => none ()



1.9       +1 -3      mlton/mlton/backend/switch.fun

Index: switch.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/switch.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- switch.fun	1 May 2004 00:49:35 -0000	1.8
+++ switch.fun	25 May 2004 04:02:59 -0000	1.9
@@ -44,9 +44,7 @@
 	   record [("test", Use.layout test),
 		   ("default", Option.layout Label.layout default),
 		   ("cases",
-		    Vector.layout
-		    (Layout.tuple2 (fn w => seq [str "0x", WordX.layout w],
-				    Label.layout))
+		    Vector.layout (Layout.tuple2 (WordX.layout, Label.layout))
 		    cases)]]
    end
 



1.82      +28 -13    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.81
retrieving revision 1.82
diff -u -r1.81 -r1.82
--- c-codegen.fun	13 May 2004 20:34:51 -0000	1.81
+++ c-codegen.fun	25 May 2004 04:02:59 -0000	1.82
@@ -24,6 +24,7 @@
    structure Global = Global
    structure Kind = Kind
    structure Label = Label
+   structure Live = Live
    structure ObjectType = ObjectType
    structure Operand = Operand
    structure Prim = Prim
@@ -34,6 +35,7 @@
    structure RealX = RealX
    structure Register = Register
    structure Runtime = Runtime
+   structure StackOffset = StackOffset
    structure Statement = Statement
    structure Switch = Switch
    structure Transfer = Transfer
@@ -469,6 +471,14 @@
 	 CType.toString (Type.toCType t)
    end
 
+structure StackOffset =
+   struct
+      open StackOffset
+
+      fun toString (T {offset, ty}): string =
+	 concat ["S", C.args [Type.toC ty, C.bytes offset]]
+   end
+
 fun contents (ty, z) = concat ["C", C.args [Type.toC ty, z]]
 
 fun output {program as Machine.Program.T {chunks,
@@ -598,8 +608,7 @@
 	     | Register r =>
 		  concat [Type.name (Register.ty r), "_",
 			  Int.toString (Register.index r)]
-	     | StackOffset {offset, ty} =>
-		  concat ["S", C.args [Type.toC ty, C.bytes offset]]
+	     | StackOffset s => StackOffset.toString s
 	     | StackTop => "StackTop"
 	     | Word w => WordX.toC w
       in
@@ -800,8 +809,8 @@
 		 end)
 	    fun push (return: Label.t, size: Bytes.t) =
 	       (print "\t"
-		; print (move {dst = (operandToString
-				      (Operand.StackOffset
+		; print (move {dst = (StackOffset.toString
+				      (StackOffset.T
 				       {offset = Bytes.- (size, Runtime.labelSize),
 					ty = Type.label return})),
 			       dstIsMem = true,
@@ -824,8 +833,9 @@
 			   Vector.toListMap
 			   (args, fn z =>
 			    case z of
-			       Operand.StackOffset {ty, ...} =>
+			       Operand.StackOffset s =>
 				  let
+				     val ty = StackOffset.ty s
 				     val tmp =
 					concat ["tmp",
 						Int.toString (Counter.next c)]
@@ -896,6 +906,7 @@
 			    ; (Option.app
 			       (dst, fn x =>
 				let
+				   val x = Live.toOperand x
 				   val ty = Operand.ty x
 				in
 				   print
@@ -918,18 +929,22 @@
 			   then
 			      Vector.foreach
 			      (live, fn z =>
-			       if Type.isPointer (Operand.ty z)
-				  then
-				     print
-				     (concat ["\tCheckPointer(",
-					      operandToString z,
-					      ");\n"])
-			       else ())
+			       let
+				  val z = Live.toOperand z
+			       in
+				  if Type.isPointer (Operand.ty z)
+				     then
+					print
+					(concat ["\tCheckPointer(",
+						 operandToString z,
+						 ");\n"])
+				  else ()
+			       end)
 			else
 			   print (let open Layout
 				  in toString
 				     (seq [str "\t/* live: ",
-					   Vector.layout Operand.layout live,
+					   Vector.layout Live.layout live,
 					   str " */\n"])
 				  end)
 		  val _ = Vector.foreach (statements, fn s =>



1.59      +20 -13    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.58
retrieving revision 1.59
diff -u -r1.58 -r1.59
--- x86-translate.fun	1 May 2004 00:49:39 -0000	1.58
+++ x86-translate.fun	25 May 2004 04:02:59 -0000	1.59
@@ -23,7 +23,9 @@
      open Machine
   in
      structure Label = Label
+     structure Live = Live
      structure Register = Register
+     structure StackOffset = StackOffset
      structure Type = Type
      structure WordSize = WordSize
      structure WordX = WordX
@@ -226,7 +228,7 @@
 		      scale = x86.Scale.One,
 		      size = size}, size), offset + x86.Size.toBytes size))
 	       end
-	  | StackOffset {offset, ty} =>
+	  | StackOffset (StackOffset.T {offset, ty}) =>
 	       let
 		  val offset = Bytes.toInt offset
 		  val ty = Type.toCType ty
@@ -331,7 +333,7 @@
 		       (args, x86.MemLocSet.empty,
 			fn (operand,args) =>
 			Vector.fold
-			(Operand.toX86Operand operand, args,
+			(Operand.toX86Operand (Live.toOperand operand), args,
 			 fn ((operand,_),args) =>
 			 case x86.Operand.deMemloc operand of
 			    SOME memloc => x86.MemLocSet.add(args, memloc)
@@ -362,7 +364,7 @@
 		   val dsts =
 		      case dst of
 			 NONE => Vector.new0 ()
-		       | SOME dst => Operand.toX86Operand dst
+		       | SOME dst => Operand.toX86Operand (Live.toOperand dst)
 		 in
 		   x86MLton.creturn
 		   {dsts = dsts,
@@ -756,7 +758,8 @@
 		       Vector.fold
 		       (live, x86.MemLocSet.empty, fn (operand, live) =>
 			Vector.fold
-			(Operand.toX86Operand operand, live, fn ((operand,_),live) =>
+			(Operand.toX86Operand (Live.toOperand operand), live,
+			 fn ((operand, _), live) =>
 			 case x86.Operand.deMemloc operand of
 			    NONE => live
 			  | SOME memloc => x86.MemLocSet.add (live, memloc)))
@@ -807,20 +810,24 @@
 		   statements 
 		   = if !Control.Native.commented > 0
 		       then let
-			      val comment
-				= "Live: " ^
-				  (argsToString
-				   (Vector.toListMap
-				    (live, fn l => Operand.toString l)))
+			      val comment =
+				 concat ["Live: ",
+					 argsToString
+					 (Vector.toListMap
+					  (live, fn l =>
+					   Operand.toString (Live.toOperand l)))]
 			    in
 			      [x86.Assembly.comment comment]
 			    end
 		       else [],
 		    transfer = NONE}),
 		 Vector.foldr(statements,
-			      (Transfer.toX86Blocks {returns = returns,
-						     transfer = transfer,
-						     transInfo = transInfo}),
+			      (Transfer.toX86Blocks
+			       {returns = (Option.map
+					   (returns, fn v =>
+					    Vector.map (v, Live.toOperand))),
+				transfer = transfer,
+				transInfo = transInfo}),
 			      fn (statement,l)
 			       => AppendList.append
 			          (Statement.toX86Blocks 
@@ -858,7 +865,7 @@
 		     setLive (label,
 			      (Vector.toList o #1 o Vector.unzip o 
 			       Vector.concatV o Vector.map)
-			      (live, Operand.toX86Operand)))
+			      (live, Operand.toX86Operand o Live.toOperand)))
 	    val transInfo = {addData = addData,
 			     frameInfoToX86 = frameInfoToX86,
 			     live = live,



1.32      +5 -5      mlton/mlton/main/compile.fun

Index: compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.fun,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- compile.fun	20 May 2004 00:02:26 -0000	1.31
+++ compile.fun	25 May 2004 04:03:00 -0000	1.32
@@ -618,11 +618,11 @@
 	 (*
 	  * For now, machine type check is too slow to run.
 	  *)
-	 if true
-	    then ()
-	 else
-	    Control.trace (Control.Pass, "machine type check")
-	    Machine.Program.typeCheck machine
+	 if !Control.typeCheck
+	    then
+	       Control.trace (Control.Pass, "machine type check")
+	       Machine.Program.typeCheck machine
+	 else ()
    in
       machine
    end



1.2       +29 -15    mlton/mlton/ssa/analyze2.fun

Index: analyze2.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/analyze2.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- analyze2.fun	20 May 2004 00:02:26 -0000	1.1
+++ analyze2.fun	25 May 2004 04:03:00 -0000	1.2
@@ -14,11 +14,9 @@
 datatype z = datatype Transfer.t
    
 fun 'a analyze
-   {coerce, conApp, const,
-    filter, filterWord,
-    fromType, layout, primApp,
-    program = Program.T {main, globals, functions, ...},
-    select, tuple, useFromTypeOnBinds} =
+   {coerce, const, filter, filterWord, fromType, layout, object, primApp,
+    program = Program.T {functions, globals, main, ...},
+    select, update, useFromTypeOnBinds} =
    let
       val unit = fromType Type.unit
       fun coerces (msg, from, to) =
@@ -139,8 +137,20 @@
 		  val _ =
 		     case cases of
 			Con cases =>
-			   Vector.foreach (cases, fn (c, j) =>
-					   filter (test, c, labelValues j))
+			   Vector.foreach
+			   (cases, fn (c, j) =>
+			    let
+			       val v = labelValues j
+			       val variant =
+				  case Vector.length v of
+				     0 => NONE
+				   | 1 => SOME (Vector.sub (v, 0))
+				   | _ => Error.bug "conApp with >1 arg"
+			    in
+			       filter {con = c,
+				       test = test,
+				       variant = variant}
+			    end)
 		      | Word (s, cs) => doit (s, cs, filterWord)
 		  val _ = Option.app (default, ensureNullary)
 	       in ()
@@ -194,8 +204,11 @@
 	 let
 	    val v =
 	       case exp of
-		  ConApp {con, args} => conApp {con = con, args = values args}
-		| Const c => const c
+		  Const c => const c
+		| Object {args, con} =>
+		     object {args = values args,
+			     con = con,
+			     resultType = ty}
 		| PrimApp {prim, targs, args, ...} =>
 		     primApp {prim = prim,
 			      targs = targs,
@@ -203,14 +216,15 @@
 			      resultType = ty,
 			      resultVar = var}
 		| Profile _ => unit
-		| Select {tuple, offset} =>
-		     select {tuple = value tuple,
+		| Select {object, offset} =>
+		     select {object = value object,
 			     offset = offset,
 			     resultType = ty}
-		| Tuple xs =>
-		     if 1 = Vector.length xs
-			then Error.bug "unary tuple"
-		     else tuple (values xs)
+		| Update {object, offset, value = v} =>
+		     (update {object = value object,
+			      offset = offset,
+			      value = value v}
+		      ; unit)
 		| Var x => value x
 	 in
 	    Option.app



1.2       +13 -8     mlton/mlton/ssa/analyze2.sig

Index: analyze2.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/analyze2.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- analyze2.sig	20 May 2004 00:02:26 -0000	1.1
+++ analyze2.sig	25 May 2004 04:03:00 -0000	1.2
@@ -9,7 +9,7 @@
    
 signature ANALYZE2_STRUCTS = 
    sig
-      include DIRECT_EXP2
+      include SSA_TREE2
    end
 
 signature ANALYZE2 = 
@@ -19,23 +19,28 @@
       val analyze:
 	 {coerce: {from: 'a,
 		   to: 'a} -> unit,
-	  conApp: {args: 'a vector,
-		   con: Con.t} -> 'a,
 	  const: Const.t -> 'a,
-	  filter: 'a * Con.t * 'a vector -> unit,
+	  filter: {con: Con.t,
+		   test: 'a,
+		   variant: 'a option} -> unit,
 	  filterWord: 'a * WordSize.t -> unit,
 	  fromType: Type.t -> 'a,
 	  layout: 'a -> Layout.t,
+	  object: {args: 'a vector,
+		   con: Con.t option,
+		   resultType: Type.t} -> 'a,
 	  primApp: {args: 'a vector,
 		    prim: Type.t Prim.t,
 		    resultType: Type.t,
 		    resultVar: Var.t option,
 		    targs: Type.t vector} -> 'a,
 	  program: Program.t,
-	  select: {offset: int,
-		   resultType: Type.t,
-		   tuple: 'a} -> 'a,
-	  tuple: 'a vector -> 'a,
+	  select: {object: 'a,
+		   offset: int,
+		   resultType: Type.t} -> 'a,
+	  update: {object: 'a,
+		   offset: int,
+		   value: 'a} -> unit,
 	  useFromTypeOnBinds: bool
 	 }
 	 -> {



1.3       +1 -1      mlton/mlton/ssa/ref-flatten.sig

Index: ref-flatten.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ref-flatten.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- ref-flatten.sig	20 May 2004 00:02:26 -0000	1.2
+++ ref-flatten.sig	25 May 2004 04:03:00 -0000	1.3
@@ -7,7 +7,7 @@
 
 signature REF_FLATTEN_STRUCTS = 
    sig
-      include SHRINK2
+      include TYPE_CHECK2
    end
 
 signature REF_FLATTEN = 



1.2       +2 -2      mlton/mlton/ssa/simplify2.fun

Index: simplify2.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/simplify2.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- simplify2.fun	20 May 2004 00:02:27 -0000	1.1
+++ simplify2.fun	25 May 2004 04:03:00 -0000	1.2
@@ -26,7 +26,7 @@
 (* structure PolyEqual = PolyEqual (S) *)
 (* structure Redundant = Redundant (S) *)
 (* structure RedundantTests = RedundantTests (S) *)
-structure RefFlatten = RefFlatten (S)
+(* structure RefFlatten = RefFlatten (S) *)
 (* structure RemoveUnused = RemoveUnused (S) *)
 (* structure SimplifyTypes = SimplifyTypes (S) *)
 (* structure Useless = Useless (S) *)
@@ -94,7 +94,7 @@
     (* For now, do ref flattening last, because each pass that follows it will
      * have to be modified to correctly handle mutable fields.
      *)
-    {name = "refFlatten", doit = RefFlatten.flatten}
+(*    {name = "refFlatten", doit = RefFlatten.flatten} *)
     ]
 
 local



1.2       +1 -1      mlton/mlton/ssa/simplify2.sig

Index: simplify2.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/simplify2.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- simplify2.sig	20 May 2004 00:02:27 -0000	1.1
+++ simplify2.sig	25 May 2004 04:03:00 -0000	1.2
@@ -7,7 +7,7 @@
  *)
 signature SIMPLIFY2_STRUCTS = 
    sig
-      include RESTORE2
+      include TYPE_CHECK2
    end
 
 signature SIMPLIFY2 = 



1.38      +5 -8      mlton/mlton/ssa/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/sources.cm,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- sources.cm	20 May 2004 00:02:27 -0000	1.37
+++ sources.cm	25 May 2004 04:03:00 -0000	1.38
@@ -9,10 +9,13 @@
 
 signature HANDLER
 signature RETURN
+signature SSA
 signature SSA2
 
 functor FlatLattice
 functor Ssa
+functor Ssa2
+functor SsaToSsa2
 
 is
 
@@ -25,9 +28,7 @@
 ssa-tree.fun
 ssa-tree2.fun
 direct-exp.sig
-direct-exp2.sig
 direct-exp.fun
-direct-exp2.fun
 analyze.sig
 analyze2.sig
 analyze.fun
@@ -37,9 +38,7 @@
 type-check.fun
 type-check2.fun
 shrink.sig
-shrink2.sig
 shrink.fun
-shrink2.fun
 flat-lattice.sig
 flat-lattice.fun
 common-arg.sig
@@ -69,9 +68,7 @@
 three-point-lattice.sig
 three-point-lattice.fun
 restore.sig
-restore2.sig
 restore.fun
-restore2.fun
 known-case.sig
 known-case.fun
 local-flatten.sig
@@ -86,8 +83,8 @@
 redundant-tests.fun
 redundant.sig
 redundant.fun
-ref-flatten.sig
-ref-flatten.fun
+(* ref-flatten.sig *)
+(* ref-flatten.fun *)
 remove-unused.sig
 remove-unused.fun
 simplify-types.sig



1.2       +138 -23   mlton/mlton/ssa/ssa-to-ssa2.fun

Index: ssa-to-ssa2.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-to-ssa2.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- ssa-to-ssa2.fun	20 May 2004 00:02:27 -0000	1.1
+++ ssa-to-ssa2.fun	25 May 2004 04:03:00 -0000	1.2
@@ -13,35 +13,102 @@
 structure S = Ssa
 structure S2 = Ssa2
 
+local
+   open S
+in
+   structure Con = Con
+   structure Label = Label
+   structure Prim = Prim
+   structure Var = Var
+end
+
 fun convert (S.Program.T {datatypes, functions, globals, main}) =
    let
-      val {destroy, hom = convertType: S.Type.t -> S2.Type.t, ...} =
-	 S.Type.makeMonoHom {con = fn (_, c, ts) => S2.Type.con (c, ts)}
+      val {get = convertType: S.Type.t -> S2.Type.t, ...} =
+	 Property.get
+	 (S.Type.plist,
+	  Property.initRec
+	  (fn (t, convertType)  =>
+	   case S.Type.dest t of
+	      S.Type.Array t => S2.Type.array (convertType t)
+	    | S.Type.Datatype tycon => S2.Type.datatypee tycon
+	    | S.Type.IntInf => S2.Type.intInf
+	    | S.Type.Real s => S2.Type.real s
+	    | S.Type.Ref t => S2.Type.reff (convertType t)
+	    | S.Type.Thread => S2.Type.thread
+	    | S.Type.Tuple ts =>
+		 S2.Type.tuple (Vector.map (ts, fn t =>
+					    {elt = convertType t,
+					     isMutable = false}))
+	    | S.Type.Vector t => S2.Type.vector (convertType t)
+	    | S.Type.Weak t => S2.Type.weak (convertType t)
+	    | S.Type.Word s => S2.Type.word s))
       fun convertTypes ts = Vector.map (ts, convertType)
+      val {get = conType: Con.t -> S2.Type.t, set = setConType, ...} =
+	 Property.getSetOnce (Con.plist,
+			      Property.initRaise ("type", Con.layout))
       val datatypes =
 	 Vector.map
 	 (datatypes, fn S.Datatype.T {cons, tycon} =>
-	  S2.Datatype.T {cons = Vector.map (cons, fn {args, con} =>
-					    {args = convertTypes args,
-					     con = con}),
-			 tycon = tycon})
+	  S2.Datatype.T
+	  {cons = Vector.map (cons, fn {args, con} =>
+			      let
+				 val args = Vector.map (args, fn t =>
+							{elt = convertType t,
+							 isMutable = false})
+				 val () =
+				    setConType (con, S2.Type.conApp (con, args))
+			      in
+				 {args = args,
+				  con = con}
+			      end),
+	   tycon = tycon})
       fun convertPrim p = S.Prim.map (p, convertType)
-      fun convertExp (e: S.Exp.t): S2.Exp.t =
-	 case e of
-	    S.Exp.ConApp r => S2.Exp.ConApp r
-	  | S.Exp.Const c => S2.Exp.Const c
-	  | S.Exp.PrimApp {args, prim, targs} =>
-	       S2.Exp.PrimApp {args = args,
-			       prim = convertPrim prim,
-			       targs = convertTypes targs}
-	  | S.Exp.Profile e => S2.Exp.Profile e
-	  | S.Exp.Select r => S2.Exp.Select r
-	  | S.Exp.Tuple v => S2.Exp.Tuple v
-	  | S.Exp.Var x => S2.Exp.Var x
+      fun convertExp (e: S.Exp.t, t: S.Type.t): S2.Exp.t * S2.Type.t =
+	 let
+	    fun simple e = (e, convertType t)
+	 in
+	    case e of
+	       S.Exp.ConApp {args, con} =>
+		  (S2.Exp.Object {args = args, con = SOME con},
+		   conType con)
+	     | S.Exp.Const c => simple (S2.Exp.Const c)
+	     | S.Exp.PrimApp {args, prim, targs} =>
+		  simple
+		  (let
+		      fun arg i = Vector.sub (args, i)
+		      datatype z = datatype Prim.Name.t
+		   in
+		      case Prim.name prim of
+			 Ref_assign =>
+			    S2.Exp.Update {object = arg 0,
+					   offset = 0,
+					   value = arg 1}
+		       | Ref_deref =>
+			    S2.Exp.Select {object = arg 0,
+					   offset = 0}
+		       | Ref_ref =>
+			    S2.Exp.Object {args = Vector.new1 (arg 0),
+					   con = NONE}
+		       | _ => 
+			    S2.Exp.PrimApp {args = args,
+					    prim = convertPrim prim,
+					    targs = convertTypes targs}
+		   end)
+	     | S.Exp.Profile e => simple (S2.Exp.Profile e)
+	     | S.Exp.Select {offset, tuple} =>
+		  simple (S2.Exp.Select {object = tuple, offset = offset})
+	     | S.Exp.Tuple v => simple (S2.Exp.Object {args = v, con = NONE})
+	     | S.Exp.Var x => simple (S2.Exp.Var x)
+	 end
       fun convertStatement (S.Statement.T {exp, ty, var}) =
-	 S2.Statement.T {exp = convertExp exp,
-			 ty = convertType ty,
-			 var = var}
+	 let
+	    val (exp, ty) = convertExp (exp, ty)
+	 in
+	    S2.Statement.T {exp = exp,
+			    ty = ty,
+			    var = var}
+	 end
       fun convertHandler (h: S.Handler.t): S2.Handler.t =
 	 case h of
 	    S.Handler.Caller => S2.Handler.Caller
@@ -54,9 +121,54 @@
 	       S2.Return.NonTail {cont = cont,
 				  handler = convertHandler handler}
 	  | S.Return.Tail => S2.Return.Tail
+      val extraBlocks: S2.Block.t list ref = ref []
       fun convertCases (cs: S.Cases.t): S2.Cases.t =
 	 case cs of
-	    S.Cases.Con v => S2.Cases.Con v
+	    S.Cases.Con v =>
+	       S2.Cases.Con
+	       (Vector.map
+		(v, fn (c, l) =>
+		 let
+		    val objectTy = conType c
+		 in
+		    case S2.Type.dest objectTy of
+		       S2.Type.Object {args, ...} =>
+			  if 0 = Vector.length args
+			     then (c, l)
+			  else
+			     let
+				val l' = Label.newNoname ()
+				val object = Var.newNoname ()
+				val (xs, statements) =
+				   Vector.unzip
+				   (Vector.mapi
+				    (args, fn (i, {elt = ty, ...}) =>
+				     let
+					val x = Var.newNoname ()
+					val exp =
+					   S2.Exp.Select {object = object,
+							  offset = i}
+				     in
+					(x,
+					 S2.Statement.T {exp = exp,
+							 ty = ty,
+							 var = SOME x})
+				     end))
+				val transfer =
+				   S2.Transfer.Goto {args = xs, dst = l}
+				val args = Vector.new1 (object, objectTy)
+				val () =
+				   List.push
+				   (extraBlocks,
+				    S2.Block.T {args = args,
+						label = l',
+						statements = statements,
+						transfer = transfer})
+			     in
+				(c, l')
+			     end
+		     | _ => Error.bug "strange object type"
+		 end))
 	  | S.Cases.Word v => S2.Cases.Word v
       fun convertTransfer (t: S.Transfer.t): S2.Transfer.t =
 	 case t of
@@ -95,9 +207,12 @@
 	     val {args, blocks, name, raises, returns, start} =
 		S.Function.dest f
 	     fun rr tvo = Option.map (tvo, convertTypes)
+	     val blocks = Vector.map (blocks, convertBlock)
+	     val blocks = Vector.concat [blocks, Vector.fromList (!extraBlocks)]
+	     val () = extraBlocks := []
 	  in
 	     S2.Function.new {args = convertFormals args,
-			      blocks = Vector.map (blocks, convertBlock),
+			      blocks = blocks,
 			      name = name,
 			      raises = rr raises,
 			      returns = rr returns,



1.2       +419 -127  mlton/mlton/ssa/ssa-tree2.fun

Index: ssa-tree2.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree2.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- ssa-tree2.fun	20 May 2004 00:02:27 -0000	1.1
+++ ssa-tree2.fun	25 May 2004 04:03:00 -0000	1.2
@@ -15,63 +15,149 @@
 
 structure Type =
    struct
-      local structure T = HashType (S)
-      in open  T
-      end
-
-      fun tyconArgs t =
-	 case Dest.dest t of
-	    Dest.Con x => x
-	  | _ => Error.bug "FirstOrderType.tyconArgs"
-	       
-      datatype dest =
-	  Array of t
+      datatype t =
+	 T of {hash: Word.t,
+	       plist: PropertyList.t,
+	       tree: tree}
+      and tree =
+	 Array of t
 	| Datatype of Tycon.t
 	| IntInf
+	| Object of {args: {elt: t, isMutable: bool} vector,
+		     con: Con.t option}
 	| Real of RealSize.t
-	| Ref of t
 	| Thread
-	| Tuple of t vector
 	| Vector of t
 	| Weak of t
 	| Word of WordSize.t
 
       local
-	 val {get, set, ...} =
-	    Property.getSetOnce (Tycon.plist, Property.initConst NONE)
+	 fun make f (T r) = f r
+      in
+	 val hash = make #hash
+	 val plist = make #plist
+	 val tree = make #tree
+      end
+
+      datatype dest = datatype tree
+
+      val dest = tree
+
+      fun equals (t, t') = PropertyList.equals (plist t, plist t')
 
-	 fun nullary c v =
-	    if Vector.isEmpty v
-	       then c
-	    else Error.bug "bogus application of nullary tycon"
-
-	 fun unary make v =
-	    if 1 = Vector.length v
-	       then make (Vector.sub (v, 0))
-	    else Error.bug "bogus application of unary tycon"
-
-	 val tycons =
-	    [(Tycon.array, unary Array)]
-	    @ [(Tycon.intInf, nullary IntInf)]
-	    @ Vector.toListMap (Tycon.reals, fn (t, s) => (t, nullary (Real s)))
-	    @ [(Tycon.reff, unary Ref),
-	       (Tycon.thread, nullary Thread),
-	       (Tycon.tuple, Tuple),
-	       (Tycon.vector, unary Vector),
-	       (Tycon.weak, unary Weak)]
-	    @ Vector.toListMap (Tycon.words, fn (t, s) => (t, nullary (Word s)))
+      local
+	 val same: tree * tree -> bool =
+	    fn (Array t1, Array t2) => equals (t1, t2)
+	     | (Datatype t1, Datatype t2) => Tycon.equals (t1, t2)
+	     | (IntInf, IntInf) => true
+	     | (Object {args = a1, con = c1}, Object {args = a2, con = c2}) =>
+		  Option.equals (c1, c2, Con.equals)
+		  andalso
+		  Vector.equals (a1, a2, fn ({elt = e1, isMutable = m1},
+					     {elt = e2, isMutable = m2}) =>
+				 m1 = m2 andalso equals (e1, e2))
+	     | (Real s1, Real s2) => RealSize.equals (s1, s2)
+	     | (Thread, Thread) => true
+	     | (Vector t1, Vector t2) => equals (t1, t2)
+	     | (Weak t1, Weak t2) => equals (t1, t2)
+	     | (Word s1, Word s2) => WordSize.equals (s1, s2)
+	     | _ => false
+	 val table: t HashSet.t = HashSet.new {hash = hash}
+      in
+	 val lookup: word * tree -> t =
+	    fn (hash, tr) =>
+	    HashSet.lookupOrInsert (table, hash,
+				    fn t => same (tr, tree t),
+				    fn () => T {hash = hash,
+						plist = PropertyList.new (),
+						tree = tr})
+      end
+
+      val newHash = Random.word
+
+      local
+	 fun make f : t -> t =
+	    let
+	       val w = newHash ()
+	    in
+	       fn t => lookup (Word.xorb (w, hash t), f t)
+	    end
       in
-	 val _ = List.foreach (tycons, fn (tycon, f) => set (tycon, SOME f))
+	 val array = make Array
+	 val vector = make Vector
+	 val weak = make Weak
+      end
+
+      val datatypee: Tycon.t -> t =
+	 fn t => lookup (Tycon.hash t, Datatype t)
 
-	 fun dest t =
-	    case Dest.dest t of
-	       Dest.Con (tycon, ts) =>
-		  (case get tycon of
-		      NONE => Datatype tycon
-		    | SOME f => f ts)
-	     | _ => Error.bug "dest"
+      val bool = datatypee Tycon.bool
+
+      local
+	 fun make (tycon, tree) = lookup (Tycon.hash tycon, tree)
+      in
+	 val intInf = make (Tycon.intInf, IntInf)
+	 val thread = make (Tycon.thread, Thread)
       end
 
+      val real: RealSize.t -> t =
+	 fn s => lookup (Tycon.hash (Tycon.real s), Real s)
+	 
+      val word: WordSize.t -> t =
+	 fn s => lookup (Tycon.hash (Tycon.word s), Word s)
+
+      val defaultWord = word WordSize.default
+
+      val word8 = word WordSize.byte
+
+      val word8Vector = vector word8
+
+      val string = word8Vector
+
+      fun ofConst c =
+	 let
+	    datatype z = datatype Const.t
+	 in
+	    case c of
+	       IntInf _ => intInf
+	     | Real r => real (RealX.size r)
+	     | Word w => word (WordX.size w)
+	     | Word8Vector _ => word8Vector
+	 end
+
+      local
+	 val generator: Word.t = 0wx5555
+	 val tuple = newHash ()
+      in
+	 fun object {args, con}: t =
+	    let
+	       val base =
+		  case con of
+		     NONE => tuple
+		   | SOME c => Con.hash c
+	       val hash =
+		  Vector.fold (args, base, fn ({elt, ...}, w) =>
+			       Word.xorb (w * generator, hash elt))
+	    in
+	       lookup (hash, Object {args = args, con = con})
+	    end
+      end
+   
+      fun conApp (con, args) = object {args = args, con = SOME con}
+	 
+      fun tuple ts = object {args = ts, con = NONE}
+
+      fun reff t = object {args = Vector.new1 {elt = t, isMutable = true},
+			   con = NONE}
+	 
+      val unit = tuple (Vector.new0 ())
+
+      val isUnit: t -> bool =
+	 fn t =>
+	 case dest t of
+	    Object {args, con} => Vector.isEmpty args andalso Option.isNone con
+	  | _ => false
+
       local
 	 open Layout
       in
@@ -84,18 +170,198 @@
 		 Array t => seq [layout t, str " array"]
 	       | Datatype t => Tycon.layout t
 	       | IntInf => str "IntInf.int"
+	       | Object {args, con} =>
+		    if isUnit t
+		       then str "unit"
+		    else
+		       let
+			  val args =
+			     paren
+			     (seq (separate (Vector.toListMap
+					     (args, fn {elt, isMutable} =>
+					      if isMutable
+						 then seq [layout elt,
+							   str " ref"]
+					      else layout elt),
+					     " * ")))
+		       in
+			  case con of
+			     NONE => args
+			   | SOME c => seq [Con.layout c, str " ", args]
+		       end
 	       | Real s => str (concat ["real", RealSize.toString s])
-	       | Ref t => seq [layout t, str " ref"]
 	       | Thread => str "thread"
-	       | Tuple ts =>
-		    if Vector.isEmpty ts
-		       then str "unit"
-		    else paren (seq (separate (Vector.toListMap (ts, layout),
-					       " * ")))
 	       | Vector t => seq [layout t, str " vector"]
 	       | Weak t => seq [layout t, str " weak"]
 	       | Word s => str (concat ["word", WordSize.toString s])))
       end
+
+      fun checkPrimApp {args, isSubtype, prim, result, targs}: bool =
+	 let
+	    datatype z = datatype Prim.Name.t
+	    fun done (args', result') =
+	       Vector.equals (args, Vector.fromList args', isSubtype)
+	       andalso isSubtype (result, result')
+	    fun targ i = Vector.sub (targs, i)
+	    fun oneTarg f =
+	       1 = Vector.length targs
+	       andalso done (f (targ 0))
+	    local
+	       fun make f s = let val t = f s in done ([t], t) end
+	    in
+	       val realUnary = make real
+	       val wordUnary = make word
+	    end
+	    local
+	       fun make f s = let val t = f s in done ([t, t], t) end
+	    in
+	       val realBinary = make real
+	       val wordBinary = make word
+	    end
+	    local
+	       fun make f s = let val t = f s in done ([t, t], bool) end
+	    in
+	       val realCompare = make real
+	       val wordCompare = make word
+	    end
+	    fun intInfBinary () = done ([intInf, intInf, defaultWord], intInf)
+	    fun intInfShift () =
+	       done ([intInf, defaultWord, defaultWord], intInf)
+	    fun intInfUnary () = done ([intInf, defaultWord], intInf)
+	    fun real3 s = done ([real s, real s, real s], real s)
+	    val pointer = defaultWord
+	    val word8Array = array word8
+	    val wordVector = vector defaultWord
+	    fun wordShift s = done ([word s, defaultWord], word s)
+	 in
+	    case Prim.name prim of
+	       Array_array => oneTarg (fn targ => ([defaultWord], array targ))
+	     | Array_array0Const => oneTarg (fn targ => ([], array targ))
+	     | Array_length => oneTarg (fn t => ([array t], defaultWord))
+	     | Array_sub => oneTarg (fn t => ([array t, defaultWord], t))
+	     | Array_toVector => oneTarg (fn t => ([array t], vector t))
+	     | Array_update =>
+		  oneTarg (fn t => ([array t, defaultWord, t], unit))
+	     | FFI f => done (Vector.toList (CFunction.args f),
+			      CFunction.return f)
+	     | FFI_Symbol {ty, ...} => done ([], ty)
+	     | GC_collect => done ([], unit)
+	     | GC_pack => done ([], unit)
+	     | GC_unpack => done ([], unit)
+	     | IntInf_add => intInfBinary ()
+	     | IntInf_andb => intInfBinary ()
+	     | IntInf_arshift => intInfShift ()
+	     | IntInf_compare => done ([intInf, intInf], defaultWord)
+	     | IntInf_equal => done ([intInf, intInf], bool)
+	     | IntInf_gcd => intInfBinary ()
+	     | IntInf_lshift => intInfShift ()
+	     | IntInf_mul => intInfBinary ()
+	     | IntInf_neg => intInfUnary ()
+	     | IntInf_notb => intInfUnary ()
+	     | IntInf_orb => intInfBinary ()
+	     | IntInf_quot => intInfBinary ()
+	     | IntInf_rem => intInfBinary ()
+	     | IntInf_sub => intInfBinary ()
+	     | IntInf_toString =>
+		  done ([intInf, defaultWord, defaultWord], string)
+	     | IntInf_toVector => done ([intInf], vector defaultWord)
+	     | IntInf_toWord => done ([intInf], defaultWord)
+	     | IntInf_xorb => intInfBinary ()
+	     | MLton_bogus => oneTarg (fn t => ([], t))
+	     | MLton_bug => done ([string], unit)
+	     | MLton_eq => oneTarg (fn t => ([t, t], bool))
+	     | MLton_equal => oneTarg (fn t => ([t, t], bool))
+	     | MLton_halt => done ([defaultWord], unit)
+	     | MLton_handlesSignals => done ([], bool)
+	     | MLton_installSignalHandler => done ([], unit)
+	     | MLton_size => oneTarg (fn t => ([reff t], defaultWord))
+	     | MLton_touch => oneTarg (fn t => ([t], unit))
+	     | Pointer_getPointer =>
+		  oneTarg (fn t => ([pointer, defaultWord], t))
+	     | Pointer_getReal s => done ([pointer, defaultWord], real s)
+	     | Pointer_getWord s => done ([pointer, defaultWord], word s)
+	     | Pointer_setPointer =>
+		  oneTarg (fn t => ([pointer, defaultWord, t], unit))
+	     | Pointer_setReal s => done ([pointer, defaultWord, real s], unit)
+	     | Pointer_setWord s => done ([pointer, defaultWord, word s], unit)
+	     | Real_Math_acos s => realUnary s
+	     | Real_Math_asin s => realUnary s
+	     | Real_Math_atan s => realUnary s
+	     | Real_Math_atan2 s => realBinary s
+	     | Real_Math_cos s => realUnary s
+	     | Real_Math_exp s => realUnary s
+	     | Real_Math_ln s => realUnary s
+	     | Real_Math_log10 s => realUnary s
+	     | Real_Math_sin s => realUnary s
+	     | Real_Math_sqrt s => realUnary s
+	     | Real_Math_tan s => realUnary s
+	     | Real_abs s => realUnary s
+	     | Real_add s => realBinary s
+	     | Real_div s => realBinary s
+	     | Real_equal s => realCompare s
+	     | Real_ge s => realCompare s
+	     | Real_gt s => realCompare s
+	     | Real_ldexp s => done ([real s, defaultWord], real s)
+	     | Real_le s => realCompare s
+	     | Real_lt s => realCompare s
+	     | Real_mul s => realBinary s
+	     | Real_muladd s => real3 s
+	     | Real_mulsub s => real3 s
+	     | Real_neg s => realUnary s
+	     | Real_qequal s => realCompare s
+	     | Real_round s => realUnary s
+	     | Real_sub s => realBinary s
+	     | Real_toReal (s, s') => done ([real s], real s')
+	     | Real_toWord (s, s', _) => done ([real s], word s')
+	     | Thread_atomicBegin => done ([], unit)
+	     | Thread_atomicEnd => done ([], unit)
+	     | Thread_canHandle => done ([], defaultWord)
+	     | Thread_copy => done ([thread], thread)
+	     | Thread_copyCurrent => done ([], unit)
+	     | Thread_returnToC => done ([], unit)
+	     | Thread_switchTo => done ([thread], unit)
+	     | Vector_length => oneTarg (fn t => ([vector t], defaultWord))
+	     | Vector_sub => oneTarg (fn t => ([vector t, defaultWord], t))
+	     | Weak_canGet => oneTarg (fn t => ([weak t], bool))
+	     | Weak_get => oneTarg (fn t => ([weak t], t))
+	     | Weak_new => oneTarg (fn t => ([t], weak t))
+	     | Word8Array_subWord =>
+		  done ([word8Array, defaultWord], defaultWord)
+	     | Word8Array_updateWord =>
+		  done ([word8Array, defaultWord, defaultWord], unit)
+	     | Word8Vector_subWord =>
+		  done ([word8Vector, defaultWord], defaultWord)
+	     | WordVector_toIntInf => done ([wordVector], intInf)
+	     | Word_add s => wordBinary s
+	     | Word_addCheck (s, _) => wordBinary s
+	     | Word_andb s => wordBinary s
+	     | Word_equal s => wordCompare s
+	     | Word_ge (s, _) => wordCompare s
+	     | Word_gt (s, _) => wordCompare s
+	     | Word_le (s, _) => wordCompare s
+	     | Word_lshift s => wordShift s
+	     | Word_lt (s, _) => wordCompare s
+	     | Word_mul (s, _) => wordBinary s
+	     | Word_mulCheck (s, _) => wordBinary s
+	     | Word_neg s => wordUnary s
+	     | Word_negCheck s => wordUnary s
+	     | Word_notb s => wordUnary s
+	     | Word_orb s => wordBinary s
+	     | Word_quot (s, _) => wordBinary s
+	     | Word_rem (s, _) => wordBinary s
+	     | Word_rol s => wordShift s
+	     | Word_ror s => wordShift s
+	     | Word_rshift (s, _) => wordShift s
+	     | Word_sub s => wordBinary s
+	     | Word_subCheck (s, _) => wordBinary s
+	     | Word_toIntInf => done ([defaultWord], intInf)
+	     | Word_toReal (s, s', _) => done ([word s], real s')
+	     | Word_toWord (s, s', _) => done ([word s], word s')
+	     | Word_xorb s => wordBinary s
+	     | World_save => done ([defaultWord], unit)
+	     | _ => Error.bug (concat ["Type.checkPrimApp got strange prim: ",
+				       Prim.toString prim])
+	 end
    end
 
 structure Cases =
@@ -198,31 +464,34 @@
 structure Exp =
    struct
       datatype t =
-	 ConApp of {con: Con.t,
+	 Const of Const.t
+       | Object of {con: Con.t option,
 		    args: Var.t vector}
-       | Const of Const.t
        | PrimApp of {prim: Type.t Prim.t,
 		     targs: Type.t vector,
 		     args: Var.t vector}
        | Profile of ProfileExp.t
-       | Select of {tuple: Var.t,
+       | Select of {object: Var.t,
 		    offset: int}
-       | Tuple of Var.t vector
+       | Update of {object: Var.t,
+		    offset: int,
+		    value: Var.t}
        | Var of Var.t
 
-      val unit = Tuple (Vector.new0 ())
+      val unit = Object {con = NONE,
+			 args = Vector.new0 ()}
 	 
       fun foreachVar (e, v) =
 	 let
 	    fun vs xs = Vector.foreach (xs, v)
 	 in
 	    case e of
-	       ConApp {args, ...} => vs args
-	     | Const _ => ()
+	       Const _ => ()
+	     | Object {args, ...} => vs args
 	     | PrimApp {args, ...} => vs args
 	     | Profile _ => ()
-	     | Select {tuple, ...} => v tuple
-	     | Tuple xs => vs xs
+	     | Select {object, ...} => v object
+	     | Update {object, value, ...} => (v object; v value)
 	     | Var x => v x
 	 end
 
@@ -231,14 +500,15 @@
 	    fun fxs xs = Vector.map (xs, fx)
 	 in
 	    case e of
-	       ConApp {con, args} => ConApp {con = con, args = fxs args}
-	     | Const _ => e
+	       Const _ => e
 	     | PrimApp {prim, targs, args} =>
 		  PrimApp {prim = prim, targs = targs, args = fxs args}
+	     | Object {con, args} => Object {con = con, args = fxs args}
 	     | Profile _ => e
-	     | Select {tuple, offset} =>
-		  Select {tuple = fx tuple, offset = offset}
-	     | Tuple xs => Tuple (fxs xs)
+	     | Select {object, offset} =>
+		  Select {object = fx object, offset = offset}
+	     | Update {object, offset, value} =>
+		  Update {object = fx object, offset = offset, value = fx value}
 	     | Var x => Var (fx x)
 	 end
 
@@ -247,9 +517,12 @@
 	    open Layout
 	 in
 	    case e of
-	       ConApp {con, args} =>
-		  seq [Con.layout con, str " ", layoutTuple args]
-	     | Const c => Const.layout c
+	       Const c => Const.layout c
+	     | Object {con, args} =>
+		  seq [(case con of
+			   NONE => empty
+			 | SOME c => seq [Con.layout c, str " "]),
+		       layoutTuple args]
 	     | PrimApp {prim, targs, args} =>
 		  seq [Prim.layout prim,
 		       if !Control.showTypes
@@ -259,37 +532,44 @@
 		       else empty,
 		       seq [str " ", layoutTuple args]]
 	     | Profile p => ProfileExp.layout p
-	     | Select {tuple, offset} =>
+	     | Select {object, offset} =>
+		  seq [str "#", Int.layout (offset + 1), str " ",
+		       Var.layout object]
+	     | Update {object, offset, value} =>
 		  seq [str "#", Int.layout (offset + 1), str " ",
-		       Var.layout tuple]
-	     | Tuple xs => layoutTuple xs
+		       Var.layout object,
+		       str " := ", Var.layout value]
 	     | Var x => Var.layout x
 	 end
 	       
       fun maySideEffect (e: t): bool =
 	 case e of
-	    ConApp _ => false
-	  | Const _ => false
+	    Const _ => false
+	  | Object _ => false
 	  | PrimApp {prim,...} => Prim.maySideEffect prim
 	  | Profile _ => false
 	  | Select _ => false
-	  | Tuple _ => false
+	  | Update _ => true
 	  | Var _ => false
 
       fun varsEquals (xs, xs') = Vector.equals (xs, xs', Var.equals)
 
       fun equals (e: t, e': t): bool =
 	 case (e, e') of
-	    (ConApp {con, args}, ConApp {con = con', args = args'}) =>
-	       Con.equals (con, con') andalso varsEquals (args, args')
-	  | (Const c, Const c') => Const.equals (c, c')
+	    (Const c, Const c') => Const.equals (c, c')
+	  | (Object {con, args}, Object {con = con', args = args'}) =>
+	       Option.equals (con, con', Con.equals)
+	       andalso varsEquals (args, args')
 	  | (PrimApp {prim, args, ...},
 	     PrimApp {prim = prim', args = args', ...}) =>
 	       Prim.equals (prim, prim') andalso varsEquals (args, args')
 	  | (Profile p, Profile p') => ProfileExp.equals (p, p')
-	  | (Select {tuple = t, offset = i}, Select {tuple = t', offset = i'}) =>
-	       Var.equals (t, t') andalso i = i'
-	  | (Tuple xs, Tuple xs') => varsEquals (xs, xs')
+	  | (Select {object = o1, offset = i1},
+	     Select {object = o2, offset = i2}) =>
+	       Var.equals (o1, o2) andalso i1 = i2
+	  | (Update {object = o1, offset = i1, value = v1},
+	     Update {object = o2, offset = i2, value = v2}) =>
+	     i1 = i2 andalso Var.equals (o1, o2) andalso Var.equals (v1, v2)
 	  | (Var x, Var x') => Var.equals (x, x')
 	  | _ => false
 
@@ -299,17 +579,25 @@
 	 val profile = newHash ()
 	 val select = newHash ()
 	 val tuple = newHash ()
+	 val update = newHash ()
 	 fun hashVars (xs: Var.t vector, w: Word.t): Word.t =
 	    Vector.fold (xs, w, fn (x, w) => Word.xorb (w, Var.hash x))
       in
 	 val hash: t -> Word.t =
-	    fn ConApp {con, args, ...} => hashVars (args, Con.hash con)
-	     | Const c => Const.hash c
+	    fn Const c => Const.hash c
+	     | Object {con, args, ...} =>
+		  hashVars (args,
+			    case con of
+			       NONE => tuple
+			     | SOME c => Con.hash c)
 	     | PrimApp {args, ...} => hashVars (args, primApp)
 	     | Profile p => Word.xorb (profile, ProfileExp.hash p)
-	     | Select {tuple, offset} =>
-		  Word.xorb (select, Var.hash tuple + Word.fromInt offset)
-	     | Tuple xs => hashVars (xs, tuple)
+	     | Select {object, offset} =>
+		  Word.xorb (select, Var.hash object + Word.fromInt offset)
+	     | Update {object, offset, value} =>
+		  Word.xorb (update,
+			     Word.xorb (Var.hash object + Word.fromInt offset,
+					Var.hash value))
 	     | Var x => Var.hash x
       end
 
@@ -317,26 +605,34 @@
 
       val toString = Layout.toString o layout
 
-      fun toPretty (e: t, global: Var.t -> string option): string =
-	 case e of
-	    ConApp {con, args} =>
-	       concat [Con.toString con, " ", Var.prettys (args, global)]
-	  | Const c => Const.toString c
-	  | PrimApp {prim, args, ...} =>
-	       Layout.toString
-	       (Prim.layoutApp (prim, args, fn x =>
-				case global x of
-				   NONE => Var.layout x
-				 | SOME s => Layout.str s))
-	  | Profile p => ProfileExp.toString p
-	  | Select {tuple, offset} =>
-	       concat ["#", Int.toString (offset + 1), " ", Var.toString tuple]
-	  | Tuple xs => Var.prettys (xs, global)
-	  | Var x => Var.toString x
+      local
+	 fun select (object, offset) =
+	    concat ["#", Int.toString (offset + 1), " ", Var.toString object]
+      in
+	 fun toPretty (e: t, global: Var.t -> string option): string =
+	    case e of
+	       Const c => Const.toString c
+	     | Object {con, args} =>
+		  concat [(case con of
+			      NONE => ""
+			    | SOME c => concat [Con.toString c, " "]),
+			  Var.prettys (args, global)]
+	     | PrimApp {prim, args, ...} =>
+		  Layout.toString
+		  (Prim.layoutApp (prim, args, fn x =>
+				   case global x of
+				      NONE => Var.layout x
+				    | SOME s => Layout.str s))
+	     | Profile p => ProfileExp.toString p
+	     | Select {object, offset} => select (object, offset)
+	     | Update {object, offset, value} => 
+		 concat [select (object, offset), " := ", Var.toString value]
+	     | Var x => Var.toString x
 
-      val isProfile =
+	 val isProfile =
 	 fn Profile _ => true
 	  | _ => false
+      end
    end
 datatype z = datatype Exp.t
 
@@ -408,10 +704,13 @@
 		 in
 		    case exp of
 		       Const c => set (Layout.toString (Const.layout c))
-		     | ConApp {con, args, ...} =>
-			  if Vector.isEmpty args
-			     then set (Con.toString con)
-			  else set (concat [Con.toString con, "(...)"])
+		     | Object {con, args, ...} =>
+			  (case con of
+			      NONE => ()
+			    | SOME c =>
+				 set (if Vector.isEmpty args
+					 then Con.toString c
+				      else concat [Con.toString c, "(...)"]))
 		     | _ => ()
 		 end))
 	 in
@@ -837,13 +1136,12 @@
 structure Datatype =
    struct
       datatype t =
-	 T of {
-	       tycon: Tycon.t,
-	       cons: {con: Con.t,
-		      args: Type.t vector} vector
-	       }
+	 T of {cons: {args: {elt: Type.t,
+			     isMutable: bool} vector,
+		      con: Con.t} vector,
+	       tycon: Tycon.t}
 
-      fun layout (T {tycon, cons}) =
+      fun layout (T {cons, tycon}) =
 	 let
 	    open Layout
 	 in
@@ -856,11 +1154,16 @@
 			if Vector.isEmpty args
 			   then empty
 			else seq [str " of ",
-				  Vector.layout Type.layout args]]),
+				  Vector.layout
+				  (fn {elt, isMutable} =>
+				   if isMutable
+				      then seq [Type.layout elt, str " ref"]
+				   else Type.layout elt)
+				  args]]),
 		  "| ")]
 	 end
 
-      fun clear (T {tycon, cons}) =
+      fun clear (T {cons, tycon}) =
 	 (Tycon.clear tycon
 	  ; Vector.foreach (cons, Con.clear o #con))
    end
@@ -1611,12 +1914,6 @@
 
       fun layoutStats (T {globals, functions, ...}) =
 	 let
-	    val numTypes = ref 0
-	    fun inc _ = Int.inc numTypes
-	    val {hom = countType, destroy} =
-	       Type.makeHom
-	       {var = fn _ => Error.bug "ssa-tree saw var",
-		con = inc}
 	    val numStatements = ref (Vector.length globals)
 	    val numBlocks = ref 0
 	    val _ =
@@ -1625,18 +1922,13 @@
 		let
 		   val {args, blocks, ...} = Function.dest f
 		in
-		   Vector.foreach (args, countType o #2)
-		   ; (Vector.foreach
-		      (blocks, fn Block.T {statements, ...} =>
-		       (Int.inc numBlocks
-			; (Vector.foreach
-			   (statements, fn Statement.T {ty, ...} =>
-			    (countType ty
-			     ; Int.inc numStatements))))))
+		   Vector.foreach
+		   (blocks, fn Block.T {statements, ...} =>
+		    (Int.inc numBlocks
+		     ; numStatements := !numStatements + Vector.length statements))
 		end)
 	    val numFunctions = List.length functions
 	    open Layout
-	    val _ = destroy ()
 	 in
 	    align
 	    (List.map



1.2       +35 -12    mlton/mlton/ssa/ssa-tree2.sig

Index: ssa-tree2.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree2.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- ssa-tree2.sig	20 May 2004 00:02:27 -0000	1.1
+++ ssa-tree2.sig	25 May 2004 04:03:00 -0000	1.2
@@ -18,38 +18,60 @@
 
       structure Type:
 	 sig
-	    include HASH_TYPE
+	    type t
 	       
 	    datatype dest =
 	       Array of t
 	     | Datatype of Tycon.t
 	     | IntInf
+	     | Object of {args: {elt: t, isMutable: bool} vector,
+			  con: Con.t option}
 	     | Real of RealSize.t
-	     | Ref of t
 	     | Thread
-	     | Tuple of t vector
 	     | Vector of t
 	     | Weak of t
 	     | Word of WordSize.t
 
+	    val array: t -> t
+	    val bool: t
+	    val conApp: Con.t * {elt: t, isMutable: bool} vector -> t
+	    val checkPrimApp: {args: t vector,
+			       isSubtype: t * t -> bool,
+			       prim: t Prim.t,
+			       result: t,
+			       targs: t vector} -> bool
+	    val datatypee: Tycon.t -> t
 	    val dest: t -> dest
-	    val tyconArgs: t -> Tycon.t * t vector
+	    val equals: t * t -> bool
+	    val intInf: t
+	    val layout: t -> Layout.t
+	    val ofConst: Const.t -> t
+	    val plist: t -> PropertyList.t
+	    val real: RealSize.t -> t
+	    val reff: t -> t
+	    val thread: t
+	    val tuple: {elt: t, isMutable: bool} vector -> t
+	    val vector: t -> t
+	    val weak: t -> t
+	    val word: WordSize.t -> t
+	    val unit: t
 	 end
-      sharing Atoms = Type.Atoms
 
       structure Exp:
 	 sig
 	    datatype t =
-	       ConApp of {args: Var.t vector,
-			  con: Con.t}
-	     | Const of Const.t
+	       Const of Const.t
+	     | Object of {args: Var.t vector,
+			  con: Con.t option}
 	     | PrimApp of {args: Var.t vector,
 			   prim: Type.t Prim.t,
 			   targs: Type.t vector}
 	     | Profile of ProfileExp.t
-	     | Select of {offset: int,
-			  tuple: Var.t}
-	     | Tuple of Var.t vector
+	     | Select of {object: Var.t,
+			  offset: int}
+	     | Update of {object: Var.t,
+			  offset: int,
+			  value: Var.t}
 	     | Var of Var.t
 
 	    val equals: t * t -> bool
@@ -156,7 +178,8 @@
       structure Datatype:
 	 sig
 	    datatype t =
-	       T of {cons: {args: Type.t vector,
+	       T of {cons: {args: {elt: Type.t,
+				   isMutable: bool} vector,
 			    con: Con.t} vector,
 		     tycon: Tycon.t}
 



1.2       +1 -2      mlton/mlton/ssa/ssa2.fun

Index: ssa2.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa2.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- ssa2.fun	20 May 2004 00:02:27 -0000	1.1
+++ ssa2.fun	25 May 2004 04:03:00 -0000	1.2
@@ -6,5 +6,4 @@
  * Please see the file MLton-LICENSE for license information.
  *)
 functor Ssa2 (S: SSA2_STRUCTS): SSA2 = 
-   Simplify2 (Restore2 (Shrink2 (TypeCheck2 (Analyze2 (DirectExp2
-						       (SsaTree2 (S)))))))
+   Simplify2 (TypeCheck2 (Analyze2 (SsaTree2 (S))))



1.34      +2 -1      mlton/mlton/ssa/type-check.fun

Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/type-check.fun,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- type-check.fun	1 May 2004 00:49:47 -0000	1.33
+++ type-check.fun	25 May 2004 04:03:00 -0000	1.34
@@ -1,10 +1,11 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
  * MLton is released under the GNU General Public License (GPL).
  * Please see the file MLton-LICENSE for license information.
  *)
+
 functor TypeCheck (S: TYPE_CHECK_STRUCTS): TYPE_CHECK = 
 struct
 



1.2       +85 -58    mlton/mlton/ssa/type-check2.fun

Index: type-check2.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/type-check2.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- type-check2.fun	20 May 2004 00:02:27 -0000	1.1
+++ type-check2.fun	25 May 2004 04:03:00 -0000	1.2
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -32,15 +32,14 @@
 	    fun bind (x, v) =
 	       case get x of
 		  Undefined => set (x, InScope v)
-		| _ => Error.bug ("duplicate definition of "
-				  ^ (Layout.toString (layout x)))
+		| _ => Error.bug (concat ["duplicate definition of ",
+					  Layout.toString (layout x)])
 	    fun reference x =
 	       case get x of
 		  InScope v => v
-		| _ => Error.bug (concat
-				  ["reference to ",
-				   Layout.toString (layout x),
-				   " not in scope"])
+		| _ => Error.bug (concat ["reference to ",
+					  Layout.toString (layout x),
+					  " not in scope"])
 
 	    fun unbind x = set (x, Defined)
 	 in (bind, ignore o reference, reference, unbind)
@@ -49,7 +48,6 @@
 	 let val (bind, reference, _, unbind) = make' (layout, plist)
 	 in (fn x => bind (x, ()), reference, unbind)
 	 end
-
       val (bindTycon, _, getTycon', _) = make' (Tycon.layout, Tycon.plist)
       val (bindCon, getCon, getCon', _) = make' (Con.layout, Con.plist)
       val (bindVar, getVar, getVar', unbindVar) = make' (Var.layout, Var.plist)
@@ -58,17 +56,12 @@
       val (bindLabel, getLabel, unbindLabel) = make (Label.layout, Label.plist)
       fun loopStatement (Statement.T {var, ty, exp, ...}) =
 	 let
-	    val _ =
+	    val () = Exp.foreachVar (exp, getVar)
+	    val () =
 	       case exp of
-		  ConApp {con, args, ...} => (getCon con
-					      ; Vector.foreach (args, getVar))
-		| Const _ => ()
-		| PrimApp {args, ...} => Vector.foreach (args, getVar)
-		| Profile _ => ()
-		| Select {tuple, ...} => getVar tuple
-		| Tuple xs => Vector.foreach (xs, getVar)
-		| Var x => getVar x
-	    val _ = Option.app (var, fn x => bindVar (x, ty))
+		  Object {con, ...} => Option.app (con, getCon)
+		| _ => ()
+	    val () = Option.app (var, fn x => bindVar (x, ty))
 	 in
 	    ()
 	 end
@@ -327,15 +320,38 @@
 	  ; Layout.output (lay, out)
 	  ; print "\n"
 	  ; raise TypeError)
+      val {get = conInfo: Con.t -> {result: Type.t,
+				    ty: Type.t,
+				    tycon: Tycon.t},
+	   set = setConInfo, ...} =
+	 Property.getSetOnce
+	 (Con.plist, Property.initRaise ("TypeCheck.info", Con.layout))
+      val conTycon = #tycon o conInfo
+      val _ =
+	 Vector.foreach
+	 (datatypes, fn Datatype.T {tycon, cons} =>
+	  let
+	     val result = Type.datatypee tycon
+	  in
+	     Vector.foreach (cons, fn {con, args} =>
+			     setConInfo (con, {result = result,
+					       ty = Type.conApp (con, args),
+					       tycon = tycon}))
+	  end)
+      fun isSubtype (t1: Type.t, t2: Type.t): bool =
+	 Type.equals (t1, t2)
+	 orelse (case (Type.dest t1, Type.dest t2) of
+		    (Type.Object {con, ...}, Type.Datatype tyc) =>
+		       (case con of
+			   NONE => false
+			 | SOME c => Tycon.equals (conTycon c, tyc))
+		  | _ => false)
       fun coerce {from: Type.t, to: Type.t}: unit =
-	 if Type.equals (from, to)
+	 if isSubtype (from, to)
 	    then ()
-	 else error ("Type.equals",
+	 else error ("TypeCheck.coerce",
 		     Layout.record [("from", Type.layout from),
 				    ("to", Type.layout to)])
-      fun coerces (from, to) =
-	 Vector.foreach2 (from, to, fn (from, to) =>
-			 coerce {from = from, to = to})
       val coerce =
 	 Trace.trace ("TypeCheck.coerce",
 		      fn {from, to} => let open Layout
@@ -343,43 +359,57 @@
 						  ("to", Type.layout to)]
 				       end,
 				    Unit.layout) coerce
-      fun select {tuple: Type.t, offset: int, resultType = _}: Type.t =
-	 case Type.deTupleOpt tuple of
-	    NONE => error ("select of non tuple", Layout.empty)
-	  | SOME ts => Vector.sub (ts, offset)
-      val {get = conInfo: Con.t -> {args: Type.t vector,
-				    result: Type.t},
-	   set = setConInfo, ...} =
-	 Property.getSetOnce
-	 (Con.plist, Property.initRaise ("TypeCheck.info", Con.layout))
-      val _ =
-	 Vector.foreach
-	 (datatypes, fn Datatype.T {tycon, cons} =>
-	  let val result = Type.con (tycon, Vector.new0 ())
-	  in Vector.foreach
-	     (cons, fn {con, args} =>
-	      setConInfo (con, {args = args,
-				result = result}))
-	  end)
-      fun conApp {con, args} =
+      fun coerces (from, to) =
+	 Vector.foreach2 (from, to, fn (from, to) =>
+			  coerce {from = from, to = to})
+      fun object {args, con, resultType} =
 	 let
-	    val {args = args', result, ...} = conInfo con
-	    val _ = coerces (args', args)
+	    fun err () = error ("bad object", Layout.empty)
 	 in
-	    result
+	    case Type.dest resultType of
+	       Type.Object {args = args', con = con'} =>
+		  (if Option.equals (con, con', Con.equals)
+		      andalso (Vector.foreach2
+			       (args, args', fn (t, {elt = t', ...}) =>
+				coerce {from = t, to = t'})
+			       ; true)
+		      then resultType
+		   else err ())
+	     | _ => err ()
 	 end
-      fun filter (test, con, args) =
+      fun select {object: Type.t, offset: int, resultType = _}: Type.t =
+	 case Type.dest object of
+	    Type.Object {args, ...} => #elt (Vector.sub (args, offset))
+	  | _ => error ("select of non object", Layout.empty)
+      fun update {object, offset, value} =
+	 case Type.dest object of
+	    Type.Object {args, ...} =>
+	       let
+		  val {elt, isMutable} = Vector.sub (args, offset)
+		  val () = coerce {from = value, to = elt}
+		  val () =
+		     if isMutable
+			then ()
+		     else error ("update of non-mutable field", Layout.empty)
+	       in
+		  ()
+	       end
+	  | _ => error ("update of non object", Layout.empty)
+      fun filter {con, test, variant} =
 	 let
-	    val {result, args = args'} = conInfo con
-	    val _ = coerce {from = test, to = result}
-	    val _ = coerces (args', args)
-	 in ()
+	    val {result, ty, ...} = conInfo con
+	    val () = coerce {from = test, to = result}
+	    val () = Option.app (variant, fn to => coerce {from = ty, to = to})
+	 in
+	    ()
 	 end
+      fun filterWord (from, s) = coerce {from = from, to = Type.word s}
       fun primApp {args, prim, resultType, resultVar = _, targs} =
 	 let
 	    datatype z = datatype Prim.Name.t
 	    val () =
 	       if Type.checkPrimApp {args = args,
+				     isSubtype = isSubtype,
 				     prim = prim,
 				     result = resultType,
 				     targs = targs}
@@ -395,21 +425,18 @@
 	    resultType
 	 end
       val _ =
-	 analyze {
-		  coerce = coerce,
-		  conApp = conApp,
+	 analyze {coerce = coerce,
 		  const = Type.ofConst,
 		  filter = filter,
-		  filterWord = fn (from, s) => coerce {from = from,
-						       to = Type.word s},
+		  filterWord = filterWord,
 		  fromType = fn x => x,
 		  layout = Type.layout,
+		  object = object,
 		  primApp = primApp,
 		  program = program,
 		  select = select,
-		  tuple = Type.tuple,
-		  useFromTypeOnBinds = true
-		  }
+		  update = update,
+		  useFromTypeOnBinds = true}
 	 handle e => error (concat ["analyze raised exception ",
 				    Layout.toString (Exn.layout e)],
 			    Layout.empty)