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