[MLton-devel] cvs commit: card maps and machine IL semantics change
Matthew Fluet
fluet@users.sourceforge.net
Tue, 30 Jul 2002 09:53:44 -0700
fluet 02/07/30 09:53:44
Modified: mlton/atoms prim.fun prim.sig
mlton/backend array-init.fun backend.fun machine.fun
rssa.fun rssa.sig ssa-to-rssa.fun
Log:
Changed the semantics of the machine IL back so that ArrayOffset does
the dereference. ArrayOffset addresses that are needed for the card
map are computed explicitly. C-codegen and x86-codegen both pass
regressions and x86-codegen passes self-compile.
Revision Changes Path
1.33 +1 -0 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- prim.fun 30 Jul 2002 02:48:32 -0000 1.32
+++ prim.fun 30 Jul 2002 16:53:43 -0000 1.33
@@ -569,6 +569,7 @@
in
val intAdd = make Name.Int_add
val intAddCheck = make Name.Int_addCheck
+ val intMul = make Name.Int_mul
val intMulCheck = make Name.Int_mulCheck
val intSubCheck = make Name.Int_subCheck
end
1.27 +1 -0 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- prim.sig 30 Jul 2002 02:48:32 -0000 1.26
+++ prim.sig 30 Jul 2002 16:53:43 -0000 1.27
@@ -286,6 +286,7 @@
val intInfEqual: t
val intAdd: t
val intAddCheck: t
+ val intMul: t
val intMulCheck: t
val intSubCheck: t
val isCommutative: t -> bool
1.10 +3 -5 mlton/mlton/backend/array-init.fun
Index: array-init.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/array-init.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- array-init.fun 30 Jul 2002 02:48:32 -0000 1.9
+++ array-init.fun 30 Jul 2002 16:53:43 -0000 1.10
@@ -28,11 +28,9 @@
val loopStatements =
Vector.new3
(Statement.Move
- {dst = (Operand.ArrayOffset
- {base = Operand.Var {var = array,
- ty = Type.pointer},
- index = i,
- ty = Type.pointer}),
+ {dst = Operand.ArrayOffset {base = array,
+ index = i,
+ ty = Type.pointer},
src = Operand.Pointer 1},
Statement.PrimApp
{args = Vector.new2 (Operand.Var {var = i, ty = Type.int},
1.34 +2 -2 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- backend.fun 30 Jul 2002 02:48:32 -0000 1.33
+++ backend.fun 30 Jul 2002 16:53:43 -0000 1.34
@@ -369,7 +369,7 @@
ArrayHeader z =>
M.Operand.Uint (Runtime.typeIndexToHeader (arrayTypeIndex z))
| ArrayOffset {base, index, ty} =>
- M.Operand.ArrayOffset {base = translateOperand base,
+ M.Operand.ArrayOffset {base = varOperand base,
index = varOperand index,
ty = ty}
| CastInt z => M.Operand.CastInt (translateOperand z)
@@ -381,7 +381,7 @@
| GCState => M.Operand.GCState
| Line => M.Operand.Line
| Offset {base, bytes, ty} =>
- M.Operand.Offset {base = translateOperand base,
+ M.Operand.Offset {base = varOperand base,
offset = bytes,
ty = ty}
| Pointer n => M.Operand.Pointer n
1.26 +1 -1 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- machine.fun 30 Jul 2002 02:48:33 -0000 1.25
+++ machine.fun 30 Jul 2002 16:53:44 -0000 1.26
@@ -140,7 +140,7 @@
val layout = Layout.str o toString
val ty =
- fn ArrayOffset _ => Type.pointer
+ fn ArrayOffset {ty, ...} => ty
| CastInt _ => Type.int
| CastWord _ => Type.word
| Char _ => Type.char
1.16 +9 -9 mlton/mlton/backend/rssa.fun
Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- rssa.fun 30 Jul 2002 02:48:33 -0000 1.15
+++ rssa.fun 30 Jul 2002 16:53:44 -0000 1.16
@@ -21,7 +21,7 @@
datatype t =
ArrayHeader of {numBytesNonPointers: int,
numPointers: int}
- | ArrayOffset of {base: t,
+ | ArrayOffset of {base: Var.t,
index: Var.t,
ty: Type.t}
| CastInt of t
@@ -31,7 +31,7 @@
| File
| GCState
| Line
- | Offset of {base: t,
+ | Offset of {base: Var.t,
bytes: int,
ty: Type.t}
| Pointer of int
@@ -53,7 +53,7 @@
")"]
| ArrayOffset {base, index, ty} =>
concat ["X", Type.name ty,
- "(", toString base, ",", Var.toString index, ")"]
+ "(", Var.toString base, ",", Var.toString index, ")"]
| CastInt z => concat ["CastInt ", toString z]
| CastWord z => concat ["CastWord ", toString z]
| Const c => Const.toString c
@@ -63,7 +63,7 @@
| Line => "<Line>"
| Offset {base, bytes, ty} =>
concat ["O", Type.name ty,
- "(", toString base, ",", Int.toString bytes, ")"]
+ "(", Var.toString base, ",", Int.toString bytes, ")"]
| Pointer n => concat ["IntAsPointer (", Int.toString n, ")"]
| Runtime r => GCField.toString r
| Var {var, ...} => Var.toString var
@@ -80,7 +80,7 @@
val ty =
fn ArrayHeader _ => Type.word
- | ArrayOffset _ => Type.pointer
+ | ArrayOffset {ty, ...} => ty
| CastInt _ => Type.int
| CastWord _ => Type.word
| Const c =>
@@ -115,10 +115,10 @@
fun 'a foldVars (z: t, a: 'a, f: Var.t * 'a -> 'a): 'a =
case z of
- ArrayOffset {base, index, ...} => f (index, foldVars (base, a, f))
+ ArrayOffset {base, index, ...} => f (index, f (base, a))
| CastInt z => foldVars (z, a, f)
| CastWord z => foldVars (z, a, f)
- | Offset {base, ...} => foldVars (base, a, f)
+ | Offset {base, ...} => f (base, a)
| Var {var, ...} => f (var, a)
| _ => a
@@ -778,7 +778,7 @@
nbnp >= 0 andalso np >= 0
| ArrayOffset {base, index, ty} =>
- Type.equals (Operand.ty base, Type.pointer)
+ Type.equals (varType base, Type.pointer)
andalso Type.equals (varType index, Type.int)
| CastInt z => Type.equals (Operand.ty z, Type.pointer)
| CastWord z => Type.equals (Operand.ty z, Type.pointer)
@@ -788,7 +788,7 @@
| GCState => true
| Line => true
| Offset {base, ...} =>
- Type.equals (Operand.ty base, Type.pointer)
+ Type.equals (varType base, Type.pointer)
| Pointer n => 0 < Int.rem (n, Runtime.wordSize)
| Runtime _ => true
| Var {ty, var} => Type.equals (ty, varType var)
1.15 +3 -3 mlton/mlton/backend/rssa.sig
Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- rssa.sig 30 Jul 2002 02:48:33 -0000 1.14
+++ rssa.sig 30 Jul 2002 16:53:44 -0000 1.15
@@ -57,7 +57,7 @@
datatype t =
ArrayHeader of {numBytesNonPointers: int,
numPointers: int}
- | ArrayOffset of {base: t,
+ | ArrayOffset of {base: Var.t,
index: Var.t,
ty: Type.t}
| CastInt of t
@@ -73,7 +73,7 @@
| File (* expand by codegen into string constant *)
| GCState
| Line (* expand by codegen into int constant *)
- | Offset of {base: t,
+ | Offset of {base: Var.t,
bytes: int,
ty: Type.t}
| Pointer of int (* the int must be nonzero mod Runtime.wordSize. *)
@@ -82,9 +82,9 @@
ty: Type.t}
val bool: bool -> t
- val char: char -> t
val caseBytes: t * {big: t -> 'a,
small: word -> 'a} -> 'a
+ val char: char -> t
val int: int -> t
val layout: t -> Layout.t
val foreachVar: t * (Var.t -> unit) -> unit
1.20 +80 -57 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.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- ssa-to-rssa.fun 30 Jul 2002 02:48:33 -0000 1.19
+++ ssa-to-rssa.fun 30 Jul 2002 16:53:44 -0000 1.20
@@ -321,7 +321,6 @@
| ConRep.Tuple => true
| _ => false)
val {info = {offsets, ...}, ...} = conInfo con
- val variant = Var {var = variant, ty = Type.pointer}
in
Vector.keepAllMap (offsets, fn off =>
Option.map (off, fn {offset, ty} =>
@@ -457,8 +456,7 @@
((n, tail (j, conSelects (test, c))) :: cases,
numLeft - 1)
| _ => (cases, numLeft))
- in switch {test = Offset {base = Var {var = test,
- ty = Type.pointer},
+ in switch {test = Offset {base = test,
bytes = tagOffset,
ty = Type.int},
cases = Cases.Int cases,
@@ -757,42 +755,6 @@
add (Bind {isMutable = false,
oper = oper,
var = valOf var})
- fun assign (ty, {dst, src}) =
- let
- val s = Move {dst = Operand.Offset {base = dst,
- bytes = 0,
- ty = ty},
- src = src}
- in
- if Type.isPointer ty
- then
- let
- val index = Var.newNoname ()
- val ss =
- (PrimApp
- {args = (Vector.new2
- (Operand.CastWord dst,
- Operand.word
- Runtime.bytesPerCardLog2)),
- dst = SOME (index, Type.int),
- prim = Prim.word32Rshift})
- :: (Move
- {dst = (Operand.Offset
- {base =
- Operand.ArrayOffset
- {base = Operand.Runtime GCField.CardMap,
- index = index,
- ty = Type.char},
- bytes = 0,
- ty = Type.char}),
- src = Operand.char #"\001"})
- :: s
- :: ss
- in
- loop (i - 1, ss, t)
- end
- else add s
- end
in
case exp of
S.Exp.ConApp {con, args} =>
@@ -812,13 +774,10 @@
fun a i = Vector.sub (args, i)
fun targ () = toType (Vector.sub (targs, 0))
fun arrayOffset (ty: Type.t): Operand.t =
- ArrayOffset {base = varOp (a 0),
+ ArrayOffset {base = a 0,
index = a 1,
ty = ty}
- fun sub (ty: Type.t) =
- move (Offset {base = arrayOffset ty,
- bytes = 0,
- ty = ty})
+ fun sub (ty: Type.t) = move (arrayOffset ty)
fun dst () =
case var of
SOME x =>
@@ -915,6 +874,79 @@
numPointers = 0})),
dst = dst (),
prim = Prim.arrayAllocate})
+
+
+ fun updateCard (addr, prefix, assign) =
+ let
+ val index = Var.newNoname ()
+ val map = Var.newNoname ()
+ val ss =
+ (PrimApp
+ {args = (Vector.new2
+ (Operand.CastWord addr,
+ Operand.word
+ Runtime.bytesPerCardLog2)),
+ dst = SOME (index, Type.int),
+ prim = Prim.word32Rshift})
+ :: (Bind {isMutable = false,
+ oper = Operand.Runtime GCField.CardMap,
+ var = map})
+ :: (Move
+ {dst = (Operand.ArrayOffset
+ {base = map,
+ index = index,
+ ty = Type.char}),
+ src = Operand.char #"\001"})
+ :: assign
+ :: ss
+ in
+ loop (i - 1, prefix ss, t)
+ end
+ fun arrayUpdate (ty, src) =
+ if Type.isPointer ty
+ then let
+ val temp = Var.newNoname ()
+ val tempOp = Operand.Var {var = temp,
+ ty = Type.int}
+ val addr = Var.newNoname ()
+ val addrOp = Operand.Var {var = addr,
+ ty = Type.pointer}
+ fun prefix ss =
+ (PrimApp
+ {args = Vector.new2
+ (varOp (a 1),
+ Operand.int (Type.size ty)),
+ dst = SOME (temp, Type.int),
+ prim = Prim.intMul})
+ :: (PrimApp
+ {args = Vector.new2 (varOp (a 0), tempOp),
+ dst = SOME (addr, Type.pointer),
+ prim = Prim.intAdd})
+ :: ss
+ val assign = Move {dst = Operand.Offset
+ {base = addr,
+ bytes = 0,
+ ty = ty},
+ src = src}
+ in
+ updateCard (addrOp, prefix, assign)
+ end
+ else add (Move {dst = arrayOffset ty,
+ src = src})
+ fun refAssign (ty, src) =
+ let
+ val addr = a 0
+ val assign = Move {dst = Operand.Offset {base = addr,
+ bytes = 0,
+ ty = ty},
+ src = src}
+ in
+ if Type.isPointer ty
+ then updateCard (varOp addr, fn ss => ss, assign)
+ else loop (i - 1, assign::ss, t)
+ end
+
+
datatype z = datatype Prim.Name.t
in
case Prim.name prim of
@@ -1077,10 +1109,7 @@
| Array_update =>
(case targ () of
NONE => none ()
- | SOME t =>
- assign
- (t, {dst = arrayOffset t,
- src = varOp (a 2)}))
+ | SOME ty => arrayUpdate (ty, varOp (a 2)))
| FFI name =>
if Option.isNone (Prim.numArgs prim)
then normal ()
@@ -1155,17 +1184,12 @@
| Ref_assign =>
(case targ () of
NONE => none ()
- | SOME ty =>
- assign
- (ty, {dst = Var {var = a 0,
- ty = Type.pointer},
- src = varOp (a 1)}))
+ | SOME ty => refAssign (ty, varOp (a 1)))
| Ref_deref =>
(case targ () of
NONE => none ()
| SOME ty =>
- move (Offset {base = Var {var = a 0,
- ty = Type.pointer},
+ move (Offset {base = a 0,
bytes = 0,
ty = ty}))
| Ref_ref =>
@@ -1305,8 +1329,7 @@
offset) of
NONE => none ()
| SOME {offset, ty} =>
- move (Offset {base = Var {var = tuple,
- ty = Type.pointer},
+ move (Offset {base = tuple,
bytes = offset,
ty = ty}))
| S.Exp.SetExnStackLocal => add SetExnStackLocal
-------------------------------------------------------
This sf.net email is sponsored by: Dice - The leading online job board
for high-tech professionals. Search and apply for tech jobs today!
http://seeker.dice.com/seeker.epl?rel_code=31
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel