[MLton-devel] cvs commit: using header words as variant tags

Stephen Weeks sweeks@users.sourceforge.net
Sat, 01 Feb 2003 19:17:08 -0800


sweeks      03/02/01 19:17:08

  Modified:    mlton/backend machine-atoms.sig representation.fun
                        ssa-to-rssa.fun
               mlton/control control.sig control.sml
               mlton/main main.sml
  Log:
  Added the ability to use header words as variant tags instead of
  reserving the first word of the object as we used to do.  You can
  control which technique is used with -variant {header|first-word}.
  I've gone ahead and made -variant header the default since everything
  seems to work.  All that was required was a couple of small changes to
  the backend.
  
  I ran all the benchmarks to compare the two approaches.  Here are the
  only ones where the ratio was more than 0.05 away from 1.
  
  MLton0 -- mlton -variant first-word
  MLton1 -- mlton -variant header
  
  run time ratio
  benchmark         MLton1
  boyer               0.87
  hamlet              0.86
  knuth-bendix        0.93
  lexgen              1.06
  logic               0.93
  nucleic             1.07
  peek                1.11
  
  So, not too much of an improvement.
  
  For self compiles, there was a minor improvement, cutting a little
  time and about 1.5G of allocation.
  
  -variant first-word
  	MLton finished in 274.16 + 132.44 (33% GC)
  	total allocated: 25,342,182,240 bytes
  
  -variant header
  	MLton finished in 261.86 + 120.96 (32% GC)
  	total allocated: 23,611,188,200 bytes
  
  One question about the native codegen: the variant tags for a
  particular datatype will be consecutive integers, but not starting at
  zero.  Is the codegen smart enough to do a subtract and make a jump
  table?

Revision  Changes    Path
1.8       +2 -2      mlton/mlton/backend/machine-atoms.sig

Index: machine-atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- machine-atoms.sig	20 Jan 2003 20:38:28 -0000	1.7
+++ machine-atoms.sig	2 Feb 2003 03:17:08 -0000	1.8
@@ -27,7 +27,7 @@
 
 	    val <= : t * t -> bool
 	    val equals: t * t -> bool
-	    val index: t -> int (* index into pointerTypes array *)
+	    val index: t -> int (* index into objectTypes array *)
 	    val layout: t -> Layout.t
 	    val new: unit -> t
 	    val plist: t -> PropertyList.t
@@ -45,7 +45,7 @@
 	       Char
 	     | CPointer
 	     (* The ints in an enum are in increasing order without dups.
-	      * The pointers are in increasing order (of index in pointerTypes
+	      * The pointers are in increasing order (of index in objectTypes
 	      * vector) without dups.
 	      *)
 	     | EnumPointers of {enum: int vector,



1.12      +2 -1      mlton/mlton/backend/representation.fun

Index: representation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- representation.fun	30 Jan 2003 01:43:58 -0000	1.11
+++ representation.fun	2 Feb 2003 03:17:08 -0000	1.12
@@ -391,7 +391,8 @@
 		       let
 			  val pts = pointers ()
 			  val ty = enumAnd pts
-			  val _ = indirect {isTagged = true,
+			  val isTagged = !Control.variant = Control.FirstWord
+			  val _ = indirect {isTagged = isTagged,
 					    conRep = ConRep.TagTuple,
 					    pointerTycons = pts,
 					    ty = ty}



1.36      +95 -62    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.35
retrieving revision 1.36
diff -u -r1.35 -r1.36
--- ssa-to-rssa.fun	23 Jan 2003 03:34:36 -0000	1.35
+++ ssa-to-rssa.fun	2 Feb 2003 03:17:08 -0000	1.36
@@ -232,7 +232,7 @@
       fun genCase {cases: (Con.t * Label.t) vector,
 		   default: Label.t option,
 		   test: Operand.t,
-		   testRep: TyconRep.t}: Transfer.t =
+		   testRep: TyconRep.t}: Statement.t list * Transfer.t =
 	 let
 	    fun enum (test: Operand.t): Transfer.t =
 	       let
@@ -290,7 +290,8 @@
 				 kind = Kind.Jump,
 				 statements = Vector.new0 (),
 				 transfer = transfer}
-	    fun switchEP (makePointersTransfer: Operand.t -> Transfer.t)
+	    fun switchEP
+	       (makePointersTransfer: Operand.t -> Statement.t list * Transfer.t)
 	       : Transfer.t =
 	       let
 		  val {enum = e, pointers = p} =
@@ -307,19 +308,19 @@
 		  val pointersVar = Var.newNoname ()
 		  val pointersOp = Operand.Var {ty = pointersTy,
 						var = pointersVar}
-		  fun block (var, ty, transfer) =
+		  fun block (var, ty, statements, transfer) =
 		     newBlock {args = Vector.new0 (),
 			       kind = Kind.Jump,
-			       statements = (Vector.new1
+			       statements = (Vector.fromList
 					     (Statement.Bind
 					      {isMutable = false,
 					       oper = Operand.Cast (test, ty),
-					       var = var})),
+					       var = var}
+					      :: statements)),
 			       transfer = transfer}
-		  val pointers =
-		     block (pointersVar, pointersTy,
-			    makePointersTransfer pointersOp)
-		  val enum = block (enumVar, enumTy, enum enumOp)
+		  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,
@@ -340,7 +341,8 @@
 		  end
 	    fun enumAndOne (): Transfer.t =
 	       let
-		  fun make (pointersOp: Operand.t): Transfer.t =
+		  fun make (pointersOp: Operand.t)
+		     : Statement.t list * Transfer.t =
 		     let
 			val (dst, args: Operand.t vector) =
 			   case Vector.peekMap
@@ -358,13 +360,13 @@
 				   | SOME j => (j, Vector.new0 ()))
 			    | SOME z => z
 		     in
-			Transfer.Goto {args = args,
-				       dst = dst}
+			([], Transfer.Goto {args = args,
+					    dst = dst})
 		     end
 	       in
 		  switchEP make
 	       end
-	    fun indirectTag (test: Operand.t): Transfer.t =
+	    fun indirectTag (test: Operand.t): Statement.t list * Transfer.t =
 	       let
 		  val cases =
 		     Vector.keepAllMap
@@ -373,6 +375,10 @@
 			 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 =
@@ -412,14 +418,37 @@
 		     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.int})
+		      | Control.Header =>
+			   let
+			      val headerOffset = ~4
+			      val tagVar = Var.newNoname ()
+			      val s =
+				 PrimApp {args = (Vector.new2
+						  (Offset {base = test,
+							   offset = headerOffset,
+							   ty = Type.word},
+						   Operand.word 0w1)),
+					  dst = SOME (tagVar, Type.word),
+					  prim = Prim.word32Rshift}
+			   in
+			      ([s], Cast (Var {ty = Type.word,
+					       var = tagVar},
+					  Type.int))
+			   end
+		      | HeaderIndirect =>
+			   Error.bug "HeaderIndirect unimplemented"
 	       in
-		  Switch (Switch.Pointer
-			  {cases = cases,
-			   default = default,
-			   tag = Offset {base = test,
-					 offset = tagOffset,
-					 ty = Type.int},
-			   test = test})
+		  (ss,
+		   Switch (Switch.Pointer {cases = cases,
+					   default = default,
+					   tag = tag,
+					   test = test}))
 	       end
 	    fun prim () =
 	       case (Vector.length cases, default) of
@@ -447,26 +476,28 @@
 		| _ => Error.bug "prim datatype with more than one case"
 	 in
 	    case testRep of
-	       TyconRep.Direct => prim ()
-	     | TyconRep.Enum => enum test
-	     | TyconRep.EnumDirect => enumAndOne ()
-	     | TyconRep.EnumIndirect => enumAndOne ()
-	     | TyconRep.EnumIndirectTag => switchEP indirectTag
+	       TyconRep.Direct => ([], prim ())
+	     | TyconRep.Enum => ([], enum test)
+	     | TyconRep.EnumDirect => ([], enumAndOne ())
+	     | TyconRep.EnumIndirect => ([], enumAndOne ())
+	     | TyconRep.EnumIndirectTag => ([], switchEP indirectTag)
 	     | TyconRep.IndirectTag => indirectTag test
-	     | TyconRep.Void => prim ()
+	     | TyconRep.Void => ([], prim ())
 	 end
       fun translateCase ({test: Var.t,
 			  cases: Label.t S.Cases.t,
-			  default: Label.t option}): Transfer.t =
+			  default: Label.t option})
+	 : Statement.t list * Transfer.t =
 	 let
 	    fun id x = x
 	    fun simple (l, make, branch, le) =
-	       Switch
-	       (make {test = varOp test,
-		      cases = (QuickSort.sortVector
-			       (Vector.map (l, fn (i, j) => (branch i, j)),
-				fn ((i, _), (i', _)) => le (i, i'))),
-		      default = default})
+	       ([],
+		Switch
+		(make {test = varOp test,
+		       cases = (QuickSort.sortVector
+				(Vector.map (l, fn (i, j) => (branch i, j)),
+				 fn ((i, _), (i', _)) => le (i, i'))),
+		       default = default}))
 	 in
 	    case cases of
 	       S.Cases.Char cs => simple (cs, Switch.Char, id, Char.<=)
@@ -476,7 +507,7 @@
 		  simple (cs, Switch.Char, Word8.toChar, Char.<=)
 	     | S.Cases.Con cases =>
 		  (case (Vector.length cases, default) of
-		      (0, NONE) => Transfer.bug
+		      (0, NONE) => ([], Transfer.bug)
 		    | _ => 
 			 let
 			    val (tycon, tys) = S.Type.tyconArgs (varType test)
@@ -555,7 +586,7 @@
 	 Vector.keepAllMap (xs, fn x =>
 			    Option.map (toRtype (varType x), fn _ =>
 					varOp x))
-      fun translateTransfer (t: S.Transfer.t): Transfer.t =
+      fun translateTransfer (t: S.Transfer.t): Statement.t list * Transfer.t =
 	 case t of
 	    S.Transfer.Arith {args, overflow, prim, success, ty} =>
 	       let
@@ -572,14 +603,14 @@
 					   (Operand.Var {var = temp,
 							 ty = ty}))})}
 	       in
-		  Transfer.Arith {dst = temp,
-				  args = vos args,
-				  overflow = overflow,
-				  prim = prim,
-				  success = noOverflow,
-				  ty = ty}
+		  ([], Transfer.Arith {dst = temp,
+				       args = vos args,
+				       overflow = overflow,
+				       prim = prim,
+				       success = noOverflow,
+				       ty = ty})
 	       end
-	  | S.Transfer.Bug => Transfer.bug
+	  | S.Transfer.Bug => ([], Transfer.bug)
 	  | S.Transfer.Call {func, args, return} =>
 	       let
 		  datatype z = datatype S.Return.t
@@ -600,24 +631,24 @@
 			   end
 		      | Tail => Return.Tail
 	       in
-		  Transfer.Call {func = func,
-				 args = vos args,
-				 return = return}
+		  ([], Transfer.Call {func = func,
+				      args = vos args,
+				      return = return})
 	       end
 	  | S.Transfer.Case r => translateCase r
 	  | S.Transfer.Goto {dst, args} =>
-	       Transfer.Goto {dst = dst, args = vos args}
-	  | S.Transfer.Raise xs => Transfer.Raise (vos xs)
-	  | S.Transfer.Return xs => Transfer.Return (vos xs)
+	       ([], Transfer.Goto {dst = dst, args = vos args})
+	  | S.Transfer.Raise xs => ([], Transfer.Raise (vos xs))
+	  | S.Transfer.Return xs => ([], Transfer.Return (vos xs))
 	  | S.Transfer.Runtime {args, prim, return} =>
 	       let
 		  datatype z = datatype Prim.Name.t
 	       in
 		  case Prim.name prim of
 		     MLton_halt =>
-			Transfer.CCall {args = vos args,
-					func = CFunction.exit,
-					return = NONE}
+			([], Transfer.CCall {args = vos args,
+					     func = CFunction.exit,
+					     return = NONE})
 		   | Thread_copyCurrent =>
 			let
 			   val func = CFunction.copyCurrentThread
@@ -629,11 +660,12 @@
 					(Goto {args = Vector.new0 (),
 					       dst = return})}
 			in
-			   Transfer.CCall
-			   {args = (Vector.concat
-				    [Vector.new1 Operand.GCState, vos args]),
-			    func = func,
-			    return = SOME l}
+			   ([],
+			    Transfer.CCall
+			    {args = (Vector.concat
+				     [Vector.new1 Operand.GCState, vos args]),
+			     func = func,
+			     return = SOME l})
 			end
 		   | _ => Error.bug (concat
 				     ["strange prim in SSA Runtime transfer ",
@@ -660,7 +692,7 @@
 	     | Type.Real => c (Const.fromReal "0.0")
 	     | Type.Word => c (Const.fromWord 0w0)
 	 end
-      fun translateStatementsTransfer (statements, transfer) =
+      fun translateStatementsTransfer (statements, ss, transfer) =
 	 let
 	    fun loop (i, ss, t): Statement.t vector * Transfer.t =
 	       if i < 0
@@ -729,7 +761,9 @@
 			     | ConRep.IntAsTy {int, ty} =>
 				  move (Operand.Cast (Operand.int int, ty))
 			     | ConRep.TagTuple {rep, tag} =>
-				  allocateTagged (tag, args, rep)
+				  if !Control.variant = Control.FirstWord
+				     then allocateTagged (tag, args, rep)
+				  else allocate (args, rep)
 			     | ConRep.Transparent _ =>
 				  move (Operand.cast
 					(varOp (Vector.sub (args, 0)),
@@ -1201,13 +1235,12 @@
 			     | SOME _ => move (varOp y))
 		  end
 	 in
-	    loop (Vector.length statements - 1, [], transfer)
+	    loop (Vector.length statements - 1, ss, transfer)
 	 end
       fun translateBlock (S.Block.T {label, args, statements, transfer}) = 
 	 let
-	    val (ss, t) =
-	       translateStatementsTransfer
-	       (statements, translateTransfer transfer)
+	    val (ss, t) = translateTransfer transfer
+	    val (ss, t) = translateStatementsTransfer (statements, ss, t)
 	 in
 	    Block.T {args = translateFormals args,
 		     kind = Kind.Jump,



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

Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.65
retrieving revision 1.66
diff -u -r1.65 -r1.66
--- control.sig	30 Jan 2003 06:06:23 -0000	1.65
+++ control.sig	2 Feb 2003 03:17:08 -0000	1.66
@@ -226,6 +226,12 @@
       (* 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.82      +18 -0     mlton/mlton/control/control.sml

Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.81
retrieving revision 1.82
diff -u -r1.81 -r1.82
--- control.sml	30 Jan 2003 06:06:23 -0000	1.81
+++ control.sml	2 Feb 2003 03:17:08 -0000	1.82
@@ -412,6 +412,24 @@
 			       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.117     +10 -2     mlton/mlton/main/main.sml

Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.116
retrieving revision 1.117
diff -u -r1.116 -r1.117
--- main.sml	30 Jan 2003 06:06:24 -0000	1.116
+++ main.sml	2 Feb 2003 03:17:08 -0000	1.117
@@ -319,8 +319,16 @@
 			| "1" => Top
 			| "2" => Pass
 			| "3" =>  Detail
-			| _ => usage (concat ["invalid -v arg: ", s]))))
-      ],
+			| _ => usage (concat ["invalid -v 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]))))
+       ],
        fn (style, name, arg, desc, opt) =>
        {arg = arg, desc = desc, name = name, opt = opt, style = style})
    end





-------------------------------------------------------
This SF.NET email is sponsored by:
SourceForge Enterprise Edition + IBM + LinuxWorld = Something 2 See!
http://www.vasoftware.com
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel