[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