[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),