[MLton] cvs commit: refactored representation determination and SsaToRssa

Stephen Weeks sweeks@mlton.org
Thu, 18 Mar 2004 20:40:10 -0800


sweeks      04/03/18 20:40:09

  Modified:    mlton/backend representation.fun representation.sig
                        ssa-to-rssa.fun
               mlton/control control.sig control.sml
               mlton/main main.fun
  Log:
  MAIL refactored representation determination and SsaToRssa
  
  Moved all the code for implementing tuple and datatype representations
  from SsaToRssa into the pass that determines representations.  This
  will make it much easier to change representation strategies, since
  the code corresponding to a representation choice is all in once
  place.  Next, I plan to put a more expressive type system into Rssa
  (and Machine) that can express everything we can now, plus packed
  tuple types and datatypes.  Then, I will take advantage of the new
  type system and the refactoring to use packed representations of SSA
  tuple types and datatypes where possible.

Revision  Changes    Path
1.25      +374 -31   mlton/mlton/backend/representation.fun

Index: representation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.fun,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- representation.fun	5 Mar 2004 03:50:52 -0000	1.24
+++ representation.fun	19 Mar 2004 04:40:07 -0000	1.25
@@ -16,12 +16,24 @@
 local
    open Rssa
 in
+   structure Block = Block
    structure CType = CType
    structure IntSize = IntSize
+   structure IntX = IntX
+   structure Kind = Kind
+   structure Label = Label
    structure ObjectType = ObjectType
+   structure Operand = Operand
    structure PointerTycon = PointerTycon
+   structure Prim = Prim
    structure Runtime = Runtime
+   structure Statement = Statement
+   structure Switch = Switch
+   structure Transfer = Transfer
+   structure Type = Type
+   structure Var = Var
    structure WordSize = WordSize
+   structure WordX = WordX
 end
 structure S = Ssa
 local
@@ -33,33 +45,6 @@
 
 datatype z = datatype WordSize.prim
 
-structure TyconRep =
-   struct
-      datatype t =
-	 Direct
-       | Enum
-       | EnumDirect
-       | EnumIndirect
-       | EnumIndirectTag
-       | IndirectTag
-       | Void
-
-      val layout =
-	 let
-	    open Layout
-	 in
-	    fn Direct => str "Direct"
-	     | Enum => str "Enum"
-	     | EnumDirect => str "EnumDirect"
-	     | EnumIndirect => str "EnumIndirect"
-	     | EnumIndirectTag => str "EnumIndirectTag"
-	     | IndirectTag => str "IndirectTag"
-	     | Void => str "Void"
-	 end
-      
-      val equals:t * t -> bool = op =
-   end
-
 structure TupleRep =
    struct
       datatype t = T of {offsets: {offset: int,
@@ -87,17 +72,59 @@
       in
 	 val tycon = make #tycon
       end
+
+      fun select (T {offsets, ...}, {dst, offset, tuple}) =
+	 case Vector.sub (offsets, offset) of
+	    NONE => []
+	  | SOME {offset, ty} =>
+	       [R.Statement.Bind
+		{isMutable = false,
+		 oper = R.Operand.Offset {base = tuple (),
+					  offset = offset,
+					  ty = ty},
+		 var = dst ()}]
+
+      fun tuple (T {size, offsets, ty, tycon, ...}, {components, dst, oper}) =
+	 let
+	    val stores =
+	       QuickSort.sortVector
+	       (Vector.keepAllMap2
+		(components, offsets, fn (x, offset) =>
+		 Option.map (offset, fn {offset, ty = _} =>
+			     {offset = offset,
+			      value = oper x})),
+		fn ({offset = i, ...}, {offset = i', ...}) => i <= i')
+	 in
+	    [R.Statement.Object {dst = dst,
+				 size = size + Runtime.normalHeaderSize,
+				 stores = stores,
+				 ty = ty,
+				 tycon = tycon}]
+	 end
+
+      fun conSelects (T {offsets, ...}, variant: Operand.t): Operand.t vector =
+	 Vector.keepAllMap
+	 (offsets, fn off =>
+	  Option.map (off, fn {offset, ty} =>
+		      Operand.Offset {base = variant,
+				      offset = offset,
+				      ty = ty}))
    end
 
 structure ConRep =
    struct
       datatype t =
+	 (* an integer representing a variant in a datatype *)
 	 IntAsTy of {int: int,
-		     ty: R.Type.t}
+		     ty: Rssa.Type.t}
+       (* box the arg(s) and add the integer tag as the first word *)
        | TagTuple of {rep: TupleRep.t,
 		      tag: int}
-       | Transparent of R.Type.t
+       (* just keep the value itself *)
+       | Transparent of Rssa.Type.t
+       (* box the arg(s) *)
        | Tuple of TupleRep.t
+       (* need no representation *)
        | Void
 
       val layout =
@@ -114,6 +141,323 @@
 	     | Tuple r => seq [str "Tuple ", TupleRep.layout r]
 	     | Void => str "Void"
 	 end
+
+      fun con (cr: t, {args, dst, oper, ty}) =
+	 let
+	    fun move (oper: Operand.t) =
+	       [Statement.Bind {isMutable = false,
+				oper = oper,
+				var = dst ()}]
+	    fun allocate (ys, tr) =
+	       TupleRep.tuple (tr, {components = ys,
+				    dst = dst (),
+				    oper = oper})
+	 in
+	    case cr of
+	       Void => []
+	     | IntAsTy {int, ty} =>
+		  move (Operand.Cast
+			(Operand.int
+			 (IntX.make (IntInf.fromInt int,
+				     IntSize.default)),
+			 ty))
+	     | TagTuple {rep, ...} => allocate (args, rep)
+	     | Transparent _ =>
+		  move (Operand.cast (oper (Vector.sub (args, 0)), ty ()))
+	     | Tuple rep => allocate (args, rep)
+	 end
+   end
+
+structure TyconRep =
+   struct
+      datatype t =
+	 (* Datatype has no representation (Void) or contains a single
+	  * variant, and hence constructor requires no additional
+	  * representation.
+	  *) 
+	 Direct
+       (* All cons are non-value-carrying and are represented as ints. *)
+       | Enum
+       (* All cons except for one are non-value-carrying and are
+	* represented as ints that are nonzero mod 4.  The value carrying
+	* con is represented transparently, i.e. the value is known to be a
+	* pointer and is left as such.
+	*)
+       | EnumDirect
+       (* All cons except for one are non-value-carrying and are
+	* represented as ints that are nonzero mod 4.  The value carrying
+	* con is represented by boxing its arg.
+	*)
+       | EnumIndirect
+       (* Non-value-carrying and are represented as ints that are nonzero
+	* mod 4.  Value carrying cons are represented by boxing the args
+	* and adding an integer tag.
+	*)
+       | EnumIndirectTag
+       (* All cons are value carrying and are represented by boxing the
+	* args and adding an integer tag.
+	*)
+       | IndirectTag
+       | Void
+
+      val layout =
+	 let
+	    open Layout
+	 in
+	    fn Direct => str "Direct"
+	     | Enum => str "Enum"
+	     | EnumDirect => str "EnumDirect"
+	     | EnumIndirect => str "EnumIndirect"
+	     | EnumIndirectTag => str "EnumIndirectTag"
+	     | IndirectTag => str "IndirectTag"
+	     | Void => str "Void"
+	 end
+      
+      val equals:t * t -> bool = op =
+
+      fun genCase (testRep: t,
+		   {cases: (ConRep.t * Label.t) vector,
+		    default: Label.t option,
+		    test: unit -> Operand.t}) =
+	 let
+	    datatype z = datatype Operand.t
+	    datatype z = datatype Transfer.t
+	    val extraBlocks = ref []
+	    fun newBlock {args, kind,
+			  statements: Statement.t vector,
+			  transfer: Transfer.t}: Label.t =
+	       let
+		  val l = Label.newNoname ()
+		  val _ = List.push (extraBlocks,
+				     Block.T {args = args,
+					      kind = kind,
+					      label = l,
+					      statements = statements,
+					      transfer = transfer})
+	       in
+		  l
+	       end
+	    fun enum (test: Operand.t): Transfer.t =
+	       let
+		  val cases =
+		     Vector.keepAllMap
+		     (cases, fn (c, j) =>
+		      case c of
+			 ConRep.IntAsTy {int, ...} => SOME (int, j)
+		       | _ => NONE)
+		  val numEnum =
+		     case Operand.ty test of
+			Type.EnumPointers {enum, ...} => Vector.length enum
+		      | _ => Error.bug "strage enum"
+		  val default =
+		     if numEnum = Vector.length cases
+			then NONE
+		     else default
+	       in
+		  if 0 = Vector.length cases
+		     then
+			(case default of
+			    NONE => Error.bug "no targets"
+			  | SOME l => Goto {dst = l,
+					    args = Vector.new0 ()})
+		  else
+		     let
+			val l = #2 (Vector.sub (cases, 0))
+		     in
+			if Vector.forall (cases, fn (_, l') =>
+					  Label.equals (l, l'))
+			   andalso (case default of
+				       NONE => true
+				     | SOME l' => Label.equals (l, l'))
+			   then Goto {dst = l,
+				      args = Vector.new0 ()}
+			else
+			   let
+			      val cases =
+				 QuickSort.sortVector
+				 (cases, fn ((i, _), (i', _)) => i <= i')
+			      val cases =
+				 Vector.map (cases, fn (i, l) =>
+					     (IntX.make (IntInf.fromInt i,
+							 IntSize.default),
+					      l))
+			   in
+			      Switch
+			      (Switch.Int {cases = cases,
+					   default = default,
+					   size = IntSize.default,
+					   test = test})
+			   end
+		     end
+	       end
+	    fun switchEP
+	       (makePointersTransfer: Operand.t -> Statement.t list * Transfer.t)
+	       : Transfer.t =
+	       let
+		  val test = test ()
+		  val {enum = e, pointers = p} =
+		     case Operand.ty test of
+			Type.EnumPointers ep => ep
+		      | _ => Error.bug "strange switchEP"
+		  val enumTy = Type.EnumPointers {enum = e,
+						  pointers = Vector.new0 ()}
+		  val enumVar = Var.newNoname ()
+		  val enumOp = Var {var = enumVar,
+				    ty = enumTy}
+		  val pointersTy = Type.EnumPointers {enum = Vector.new0 (),
+						      pointers = p}
+		  val pointersVar = Var.newNoname ()
+		  val pointersOp = Var {ty = pointersTy,
+					var = pointersVar}
+		  fun block (var, ty, statements, transfer) =
+		     newBlock {args = Vector.new0 (),
+			       kind = Kind.Jump,
+			       statements = (Vector.fromList
+					     (Statement.Bind
+					      {isMutable = false,
+					       oper = Cast (test, ty),
+					       var = var}
+					      :: statements)),
+			       transfer = transfer}
+		  val (s, t) = makePointersTransfer pointersOp
+		  val pointers = block (pointersVar, pointersTy, s, t)
+		  val enum = block (enumVar, enumTy, [], enum enumOp)
+	       in
+		  Switch (Switch.EnumPointers {enum = enum,
+					       pointers = pointers,
+					       test = test})
+	       end
+	    fun enumAndOne (): Transfer.t =
+	       let
+		  fun make (pointersOp: Operand.t)
+		     : Statement.t list * Transfer.t =
+		     let
+			val (dst, args: Operand.t vector) =
+			   case Vector.peekMap
+			      (cases, fn (c, j) =>
+			       case c of
+				  ConRep.Transparent _ =>
+				     SOME (j, Vector.new1 pointersOp)
+				| ConRep.Tuple r =>
+				     SOME (j,
+					   TupleRep.conSelects (r, pointersOp))
+				| _ => NONE) of
+			      NONE =>
+				 (case default of
+				     NONE => Error.bug "enumAndOne: no default"
+				   | SOME j => (j, Vector.new0 ()))
+			    | SOME z => z
+		     in
+			([], Goto {args = args, dst = dst})
+		     end
+	       in
+		  switchEP make
+	       end
+	    fun indirectTag (test: Operand.t): Statement.t list * Transfer.t =
+	       let
+		  val cases =
+		     Vector.keepAllMap
+		     (cases, fn (c, l) =>
+		      case c of
+			 ConRep.TagTuple {rep, tag} =>
+			    let
+			       val tycon = TupleRep.tycon rep
+			       val tag = PointerTycon.index tycon
+			       val pointerVar = Var.newNoname ()
+			       val pointerTy = Type.pointer tycon
+			       val pointerOp =
+				  Operand.Var {ty = pointerTy,
+					       var = pointerVar}
+			       val statements =
+				  Vector.new1
+				  (Statement.Bind
+				   {isMutable = false,
+				    oper = Cast (test, pointerTy),
+				    var = pointerVar})
+			       val dst =
+				  newBlock
+				  {args = Vector.new0 (),
+				   kind = Kind.Jump,
+				   statements = statements,
+				   transfer =
+				   Goto
+				   {args = TupleRep.conSelects (rep, pointerOp),
+				    dst = l}}
+			    in
+			       SOME {dst = dst,
+				     tag = tag,
+				     tycon = tycon}
+			    end
+		       | _ => NONE)
+		  val numTag =
+		     case Operand.ty test of
+			Type.EnumPointers {pointers, ...} =>
+			   Vector.length pointers
+		      | _ => Error.bug "strange indirecTag"
+		  val default =
+		     if numTag = Vector.length cases
+			then NONE
+		     else default
+		  val cases =
+		     QuickSort.sortVector
+		     (cases, fn ({tycon = t, ...}, {tycon = t', ...}) =>
+		      PointerTycon.<= (t, t'))
+		  val headerOffset = ~4
+		  val tagVar = Var.newNoname ()
+		  val s =
+		     Statement.PrimApp
+		     {args = (Vector.new2
+			      (Offset {base = test,
+				       offset = headerOffset,
+				       ty = Type.defaultWord},
+			       Operand.word (WordX.one WordSize.default))),
+		      dst = SOME (tagVar, Type.defaultWord),
+		      prim = Prim.wordRshift WordSize.default}
+		  val tag =
+		     Cast (Var {ty = Type.defaultWord,
+				var = tagVar},
+			   Type.defaultInt)
+	       in
+		  ([s], Switch (Switch.Pointer {cases = cases,
+						default = default,
+						tag = tag,
+						test = test}))
+	       end
+	    fun prim () =
+	       case (Vector.length cases, default) of
+		  (1, _) =>
+		     (* We use _ instead of NONE for the default becuase
+		      * there may be an unreachable default case.
+		      *)
+		     let
+			val (c, l) = Vector.sub (cases, 0)
+		     in
+			case c of
+			   ConRep.Void =>
+			      Goto {dst = l,
+				    args = Vector.new0 ()}
+			 | ConRep.Transparent _ =>
+			      Goto {dst = l,
+				    args = Vector.new1 (test ())}
+			 | ConRep.Tuple r =>
+			      Goto {dst = l,
+				    args = TupleRep.conSelects (r, test ())}
+			 | _ => Error.bug "strange conRep for Prim"
+		     end
+		| (0, SOME l) => Goto {dst = l, args = Vector.new0 ()}
+		| _ => Error.bug "prim datatype with more than one case"
+	    val (ss, t) =
+	       case testRep of
+		  Direct => ([], prim ())
+		| Enum => ([], enum (test ()))
+		| EnumDirect => ([], enumAndOne ())
+		| EnumIndirect => ([], enumAndOne ())
+		| EnumIndirectTag => ([], switchEP indirectTag)
+		| IndirectTag => indirectTag (test ())
+		| Void => ([], prim ())
+	 in
+	    (ss, t, !extraBlocks)
+	 end
    end
 
 fun compute (program as Ssa.Program.T {datatypes, ...}) =
@@ -412,8 +756,7 @@
 		       let
 			  val pts = pointers ()
 			  val ty = enumAnd pts
-			  val isTagged = !Control.variant = Control.FirstWord
-			  val _ = indirect {isTagged = isTagged,
+			  val _ = indirect {isTagged = false,
 					    conRep = ConRep.TagTuple,
 					    pointerTycons = pts,
 					    ty = ty}



1.9       +27 -51    mlton/mlton/backend/representation.sig

Index: representation.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- representation.sig	23 Jun 2003 04:58:57 -0000	1.8
+++ representation.sig	19 Mar 2004 04:40:07 -0000	1.9
@@ -20,69 +20,45 @@
    sig
       include REPRESENTATION_STRUCTS
 
-      structure TyconRep:
-	 sig
-	    datatype t =
-	     (* Datatype has no representation (Void) or contains a single
-	      * variant, and hence constructor requires no additional
-	      * representation.
-	      *) 
-	       Direct
-	     (* All cons are non-value-carrying and are represented as ints. *)
-	     | Enum
-	     (* All cons except for one are non-value-carrying and are
-	      * represented as ints that are nonzero mod 4.  The value carrying
-	      * con is represented transparently, i.e. the value is known to be a
-	      * pointer and is left as such.
-	      *)
-	     | EnumDirect
-	     (* All cons except for one are non-value-carrying and are
-	      * represented as ints that are nonzero mod 4.  The value carrying
-	      * con is represented by boxing its arg.
-	      *)
-	     | EnumIndirect
-	     (* Non-value-carrying and are represented as ints that are nonzero
-	      * mod 4.  Value carrying cons are represented by boxing the args
-	      * and adding an integer tag.
-	      *)
-	     | EnumIndirectTag
-	     (* All cons are value carrying and are represented by boxing the
-	      * args and adding an integer tag.
-	      *)
-	     | IndirectTag
-	     | Void
-	 end
-
       structure TupleRep:
 	 sig
-	    datatype t = T of {offsets: {offset: int,
-					 ty: Rssa.Type.t} option vector,
-			       size: int,
-			       ty: Rssa.Type.t,
-			       tycon: Rssa.PointerTycon.t}
+	    type t
 
 	    val layout: t -> Layout.t
+	    val select:
+	       t * {dst: unit -> Rssa.Var.t,
+		    offset: int,
+		    tuple: unit -> Rssa.Operand.t} -> Rssa.Statement.t list
+	    val tuple:
+	       t * {components: 'a vector,
+		    dst: Rssa.Var.t,
+		    oper: 'a -> Rssa.Operand.t} -> Rssa.Statement.t list
 	    val tycon: t -> Rssa.PointerTycon.t
 	 end
 
       (* How a constructor variant of a datatype is represented. *)
       structure ConRep:
 	 sig
-	    datatype t =
-	     (* an integer representing a variant in a datatype *)
-	       IntAsTy of {int: int,
-			   ty: Rssa.Type.t}
-	     (* box the arg(s) and add the integer tag as the first word *)
-	     | TagTuple of {rep: TupleRep.t,
-			    tag: int}
-	     (* just keep the value itself *)
-	     | Transparent of Rssa.Type.t
-	     (* box the arg(s) *)
-	     | Tuple of TupleRep.t
-	     (* need no representation *)
-	     | Void
+	    type t
 
+	    val con: t * {args: 'a vector,
+			  dst: unit -> Rssa.Var.t,
+			  oper: 'a -> Rssa.Operand.t,
+			  ty: unit -> Rssa.Type.t} -> Rssa.Statement.t list
 	    val layout: t -> Layout.t
+	 end
+
+      structure TyconRep:
+	 sig
+	    type t
+
+	    val genCase:
+	       t * {cases: (ConRep.t * Rssa.Label.t) vector,
+		    default: Rssa.Label.t option,
+		    test: unit -> Rssa.Operand.t}
+	       -> (Rssa.Statement.t list
+		   * Rssa.Transfer.t
+		   * Rssa.Block.t list)
 	 end
 
       val compute:



1.64      +35 -319   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.63
retrieving revision 1.64
diff -u -r1.63 -r1.64
--- ssa-to-rssa.fun	17 Mar 2004 06:04:12 -0000	1.63
+++ ssa-to-rssa.fun	19 Mar 2004 04:40:07 -0000	1.64
@@ -626,14 +626,6 @@
       val varOp =
 	 Trace.trace ("SsaToRssa.varOp", Var.layout, Operand.layout) varOp
       fun varOps xs = Vector.map (xs, varOp)
-      fun conSelects {rep = TupleRep.T {offsets, ...},
-		      variant: Operand.t}: Operand.t vector =
-	 Vector.keepAllMap
-	 (offsets, fn off =>
-	  Option.map (off, fn {offset, ty} =>
-		      Offset {base = variant,
-			      offset = offset,
-			      ty = ty}))
       val extraBlocks = ref []
       fun newBlock {args, kind,
 		    statements: Statement.t vector,
@@ -650,246 +642,6 @@
 	    l
 	 end
       val tagOffset = 0
-      fun genCase {cases: (Con.t * Label.t) vector,
-		   default: Label.t option,
-		   test: Var.t,
-		   testRep: TyconRep.t}: Statement.t list * Transfer.t =
-	 let
-	    fun enum (test: Operand.t): Transfer.t =
-	       let
-		  val cases =
-		     Vector.keepAllMap
-		     (cases, fn (c, j) =>
-		      case conRep c of
-			 ConRep.IntAsTy {int, ...} => SOME (int, j)
-		       | _ => NONE)
-		  val numEnum =
-		     case Operand.ty test of
-			Type.EnumPointers {enum, ...} => Vector.length enum
-		      | _ => Error.bug "strage enum"
-		  val default =
-		     if numEnum = Vector.length cases
-			then NONE
-		     else default
-	       in
-		  if 0 = Vector.length cases
-		     then
-			(case default of
-			    NONE => Error.bug "no targets"
-			  | SOME l => Goto {dst = l,
-					    args = Vector.new0 ()})
-		  else
-		     let
-			val l = #2 (Vector.sub (cases, 0))
-		     in
-			if Vector.forall (cases, fn (_, l') =>
-					  Label.equals (l, l'))
-			   andalso (case default of
-				       NONE => true
-				     | SOME l' => Label.equals (l, l'))
-			   then Goto {dst = l,
-				      args = Vector.new0 ()}
-			else
-			   let
-			      val cases =
-				 QuickSort.sortVector
-				 (cases, fn ((i, _), (i', _)) => i <= i')
-			      val cases =
-				 Vector.map (cases, fn (i, l) =>
-					     (IntX.make (IntInf.fromInt i,
-							 IntSize.default),
-					      l))
-			   in
-			      Switch (Switch.Int {cases = cases,
-						  default = default,
-						  size = IntSize.default,
-						  test = test})
-			   end
-		     end
-	       end
-	    fun switchEP
-	       (makePointersTransfer: Operand.t -> Statement.t list * Transfer.t)
-	       : Transfer.t =
-	       let
-		  val test = varOp test
-		  val {enum = e, pointers = p} =
-		     case Operand.ty test of
-			Type.EnumPointers ep => ep
-		      | _ => Error.bug "strange switchEP"
-		  val enumTy = Type.EnumPointers {enum = e,
-						  pointers = Vector.new0 ()}
-		  val enumVar = Var.newNoname ()
-		  val enumOp = Operand.Var {var = enumVar,
-					    ty = enumTy}
-		  val pointersTy = Type.EnumPointers {enum = Vector.new0 (),
-						      pointers = p}
-		  val pointersVar = Var.newNoname ()
-		  val pointersOp = Operand.Var {ty = pointersTy,
-						var = pointersVar}
-		  fun block (var, ty, statements, transfer) =
-		     newBlock {args = Vector.new0 (),
-			       kind = Kind.Jump,
-			       statements = (Vector.fromList
-					     (Statement.Bind
-					      {isMutable = false,
-					       oper = Operand.Cast (test, ty),
-					       var = var}
-					      :: statements)),
-			       transfer = transfer}
-		  val (s, t) = makePointersTransfer pointersOp
-		  val pointers = block (pointersVar, pointersTy, s, t)
-		  val enum = block (enumVar, enumTy, [], enum enumOp)
-	       in
-		  Switch (Switch.EnumPointers
-			  {enum = enum,
-			   pointers = pointers,
-			   test = test})
-	       end
-	    fun enumAndOne (): Transfer.t =
-	       let
-		  fun make (pointersOp: Operand.t)
-		     : Statement.t list * Transfer.t =
-		     let
-			val (dst, args: Operand.t vector) =
-			   case Vector.peekMap
-			      (cases, fn (c, j) =>
-			       case conRep c of
-				  ConRep.Transparent _ =>
-				     SOME (j, Vector.new1 pointersOp)
-				| ConRep.Tuple r =>
-				     SOME (j, conSelects {rep = r,
-							  variant = pointersOp})
-				| _ => NONE) of
-			      NONE =>
-				 (case default of
-				     NONE => Error.bug "enumAndOne: no default"
-				   | SOME j => (j, Vector.new0 ()))
-			    | SOME z => z
-		     in
-			([], Transfer.Goto {args = args,
-					    dst = dst})
-		     end
-	       in
-		  switchEP make
-	       end
-	    fun indirectTag (test: Operand.t): Statement.t list * Transfer.t =
-	       let
-		  val cases =
-		     Vector.keepAllMap
-		     (cases, fn (c, l) =>
-		      case conRep c of
-			 ConRep.TagTuple {rep, tag} =>
-			    let
-			       val tycon = TupleRep.tycon rep
-			       val tag =
-				  if !Control.variant = Control.FirstWord
-				     then tag
-				  else PointerTycon.index tycon
-			       val pointerVar = Var.newNoname ()
-			       val pointerTy = Type.pointer tycon
-			       val pointerOp =
-				  Operand.Var {ty = pointerTy,
-					       var = pointerVar}
-			       val statements =
-				  Vector.new1
-				  (Statement.Bind
-				   {isMutable = false,
-				    oper = Operand.Cast (test, pointerTy),
-				    var = pointerVar})
-			       val dst =
-				  newBlock
-				  {args = Vector.new0 (),
-				   kind = Kind.Jump,
-				   statements = statements,
-				   transfer =
-				   Goto {args = conSelects {rep = rep,
-							    variant = pointerOp},
-					 dst = l}}
-			    in
-			       SOME {dst = dst,
-				     tag = tag,
-				     tycon = tycon}
-			    end
-		       | _ => NONE)
-		  val numTag =
-		     case Operand.ty test of
-			Type.EnumPointers {pointers, ...} =>
-			   Vector.length pointers
-		      | _ => Error.bug "strange indirecTag"
-		  val default =
-		     if numTag = Vector.length cases
-			then NONE
-		     else default
-		  val cases =
-		     QuickSort.sortVector
-		     (cases, fn ({tycon = t, ...}, {tycon = t', ...}) =>
-		      PointerTycon.<= (t, t'))
-		  val (ss, tag) =
-		     case !Control.variant of
-			Control.FirstWord =>
-			   ([], Offset {base = test,
-					offset = tagOffset,
-					ty = Type.defaultInt})
-		      | Control.Header =>
-			   let
-			      val headerOffset = ~4
-			      val tagVar = Var.newNoname ()
-			      val s =
-				 PrimApp {args = (Vector.new2
-						  (Offset {base = test,
-							   offset = headerOffset,
-							   ty = Type.defaultWord},
-						   Operand.word (WordX.one WordSize.default))),
-					  dst = SOME (tagVar, Type.defaultWord),
-					  prim = Prim.wordRshift WordSize.default}
-			   in
-			      ([s], Cast (Var {ty = Type.defaultWord,
-					       var = tagVar},
-					  Type.defaultInt))
-			   end
-		      | Control.HeaderIndirect =>
-			   Error.bug "HeaderIndirect unimplemented"
-	       in
-		  (ss,
-		   Switch (Switch.Pointer {cases = cases,
-					   default = default,
-					   tag = tag,
-					   test = test}))
-	       end
-	    fun prim () =
-	       case (Vector.length cases, default) of
-		  (1, _) =>
-		     (* We use _ instead of NONE for the default becuase
-		      * there may be an unreachable default case.
-		      *)
-		     let
-			val (c, l) = Vector.sub (cases, 0)
-		     in
-			case conRep c of
-			   ConRep.Void =>
-			      Goto {dst = l,
-				    args = Vector.new0 ()}
-			 | ConRep.Transparent _ =>
-			      Goto {dst = l,
-				    args = Vector.new1 (varOp test)}
-			 | ConRep.Tuple r =>
-			      Goto {dst = l,
-				    args = conSelects {rep = r,
-						       variant = (varOp test)}}
-			 | _ => Error.bug "strange conRep for Prim"
-		     end
-		| (0, SOME l) => Goto {dst = l, args = Vector.new0 ()}
-		| _ => Error.bug "prim datatype with more than one case"
-	 in
-	    case testRep of
-	       TyconRep.Direct => ([], prim ())
-	     | TyconRep.Enum => ([], enum (varOp test))
-	     | TyconRep.EnumDirect => ([], enumAndOne ())
-	     | TyconRep.EnumIndirect => ([], enumAndOne ())
-	     | TyconRep.EnumIndirectTag => ([], switchEP indirectTag)
-	     | TyconRep.IndirectTag => indirectTag (varOp test)
-	     | TyconRep.Void => ([], prim ())
-	 end
       fun translateCase ({test: Var.t,
 			  cases: S.Cases.t,
 			  default: Label.t option})
@@ -915,10 +667,24 @@
 			    val (tycon, tys) = S.Type.tyconArgs (varType test)
 			 in
 			    if Vector.isEmpty tys
-			       then genCase {cases = cases,
-					     default = default,
-					     test = test,
-					     testRep = tyconRep tycon}
+			       then
+				  let
+				     val cases =
+					Vector.map
+					(cases, fn (c, l) =>
+					 (conRep c, l))
+				     val test = fn () => varOp test
+				     val (ss, t, blocks) =
+					TyconRep.genCase
+					(tyconRep tycon,
+					 {cases = cases,
+					  default = default,
+					  test = test})
+				     val () =
+					extraBlocks := blocks @ !extraBlocks
+				  in
+				     (ss, t)
+				  end
 			    else Error.bug "strange type in case"
 			 end)
 	     | S.Cases.Int (s, cs) => simple (s, cs, Switch.Int, id, IntX.<=)
@@ -1105,6 +871,7 @@
 			Vector.sub (statements, i)
 		     fun none () = loop (i - 1, ss, t)
 		     fun add s = loop (i - 1, s :: ss, t)
+		     fun adds ss' = loop (i - 1, ss' @ ss, t)
 		     fun split (args, kind,
 				ss: Statement.t list,
 				make: Label.t -> Statement.t list * Transfer.t) =
@@ -1117,44 +884,11 @@
 			in
 			   loop (i - 1, ss, t)
 			end
-		     fun makeStores (ys: Var.t vector, offsets) =
-			QuickSort.sortVector
-			(Vector.keepAllMap2
-			 (ys, offsets, fn (y, offset) =>
-			  Option.map (offset, fn {offset, ty = _} =>
-				      {offset = offset,
-				       value = varOp y})),
-			 fn ({offset = i, ...}, {offset = i', ...}) => i <= i')
-		     fun allocate (ys: Var.t vector,
-				   TupleRep.T {size, offsets, ty, tycon, ...}) =
-			add (Object {dst = valOf var,
-				     size = size + Runtime.normalHeaderSize,
-				     stores = makeStores (ys, offsets),
-				     ty = ty,
-				     tycon = tycon})
-		     val allocate =
-			Trace.trace2
-			("allocate",
-			 Vector.layout Var.layout,
-			 TupleRep.layout,
-			 Layout.ignore)
-			allocate
-		     fun allocateTagged (n: int,
-					 ys: Var.t vector,
-					 TupleRep.T {size, offsets, ty, tycon}) =
-			add (Object
-			     {dst = valOf var,
-			      size = size + Runtime.normalHeaderSize,
-			      stores = (Vector.concat
-					[Vector.new1
-					 {offset = tagOffset,
-					  value = (Operand.int
-						   (IntX.make
-						    (IntInf.fromInt n,
-						     IntSize.default)))},
-					 makeStores (ys, offsets)]),
-			      ty = ty,
-			      tycon = tycon})
+		     fun allocate (ys: Var.t vector, tr) =
+			adds (TupleRep.tuple
+			      (tr, {components = ys,
+				    dst = valOf var,
+				    oper = varOp}))
 		     fun move (oper: Operand.t) =
 			add (Bind {isMutable = false,
 				   oper = oper,
@@ -1162,24 +896,12 @@
 		  in
 		     case exp of
 			S.Exp.ConApp {con, args} =>
-			   (case conRep con of
-			       ConRep.Void => none ()
-			     | ConRep.IntAsTy {int, ty} =>
-				  move (Operand.Cast
-					(Operand.int
-					 (IntX.make (IntInf.fromInt int,
-						     IntSize.default)),
-					 ty))
-			     | ConRep.TagTuple {rep, tag} =>
-				  if !Control.variant = Control.FirstWord
-				     then allocateTagged (tag, args, rep)
-				  else allocate (args, rep)
-			     | ConRep.Transparent _ =>
-				  move (Operand.cast
-					(varOp (Vector.sub (args, 0)),
-					 valOf (toRtype ty)))
-			     | ConRep.Tuple rep =>
-				  allocate (args, rep))
+			   adds (ConRep.con
+				 (conRep con,
+				  {args = args,
+				   dst = fn () => valOf var,
+				   oper = varOp,
+				   ty = fn () => valOf (toRtype ty)}))
 		      | S.Exp.Const c =>
 			   let
 			      datatype z = datatype Const.t
@@ -1707,17 +1429,11 @@
 			   end
 		      | S.Exp.Profile e => add (Statement.Profile e)
 		      | S.Exp.Select {tuple, offset} =>
-			   let
-			      val TupleRep.T {offsets, ...} =
-				 tupleRep (varType tuple)
-			   in
-			      case Vector.sub (offsets, offset) of
-				 NONE => none ()
-			       | SOME {offset, ty} =>
-				    move (Offset {base = varOp tuple,
-						  offset = offset,
-						  ty = ty})
-			   end
+			   adds (TupleRep.select
+				 (tupleRep (varType tuple),
+				  {dst = fn () => valOf var,
+				   offset = offset,
+				   tuple = fn () => varOp tuple}))
 		      | S.Exp.Tuple ys =>
 			   if 0 = Vector.length ys
 			      then none ()



1.91      +0 -6      mlton/mlton/control/control.sig

Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.90
retrieving revision 1.91
diff -u -r1.90 -r1.91
--- control.sig	16 Feb 2004 22:42:09 -0000	1.90
+++ control.sig	19 Mar 2004 04:40:07 -0000	1.91
@@ -264,12 +264,6 @@
       (* Should the basis library be prefixed onto the program. *)
       val useBasisLibrary: bool ref
 
-      datatype variant =
-	 FirstWord
-       | Header
-       | HeaderIndirect
-      val variant: variant ref
-
       datatype verbosity =
 	 Silent
        | Top



1.112     +0 -19     mlton/mlton/control/control.sml

Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.111
retrieving revision 1.112
diff -u -r1.111 -r1.112
--- control.sml	19 Feb 2004 22:42:11 -0000	1.111
+++ control.sml	19 Mar 2004 04:40:07 -0000	1.112
@@ -495,25 +495,6 @@
 			       default = true,
 			       toString = Bool.toString}
 
-structure Variant =
-   struct
-      datatype t =
-	 FirstWord
-       | Header
-       | HeaderIndirect
-
-      val toString =
-	 fn FirstWord => "first word"
-	  | Header => "header"
-	  | HeaderIndirect => "header indirect"
-   end
-
-datatype variant = datatype Variant.t
-
-val variant = control {name = "variant",
-		       default = Header,
-		       toString = Variant.toString}
-
 structure Verbosity =
    struct
       datatype t =



1.29      +0 -8      mlton/mlton/main/main.fun

Index: main.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.fun,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- main.fun	28 Feb 2004 01:16:25 -0000	1.28
+++ main.fun	19 Mar 2004 04:40:08 -0000	1.29
@@ -394,14 +394,6 @@
 			| "2" => Pass
 			| "3" =>  Detail
 			| _ => usage (concat ["invalid -verbose arg: ", s])))),
-       (Expert, "variant", " {header|first-word}",
-	"how to represent variant tags",
-	SpaceString
-	(fn s =>
-	 variant := (case s of
-			"first-word" => FirstWord
-		      | "header" => Header
-		      | _ => usage (concat ["invalid -variant arg: ", s])))),
        (Normal, "warn-match", " {true|false}",
 	"nonexhaustive and redundant match warnings",
 	boolRef warnMatch),