[MLton-devel] cvs commit: card maps and machine IL semantics change
Stephen Weeks
sweeks@users.sourceforge.net
Mon, 29 Jul 2002 19:48:34 -0700
sweeks 02/07/29 19:48:34
Modified: include ccodegen.h
mlton/atoms prim.fun prim.sig
mlton/backend array-init.fun backend.fun machine.fun
rssa.fun rssa.sig runtime.fun runtime.sig
ssa-to-rssa.fun
mlton/codegen/c-codegen c-codegen.fun
mlton/codegen/x86-codegen x86-mlton-basic.fun
x86-mlton-basic.sig x86-translate.fun
mlton/core-ml lookup-constant.fun
mlton/main compile.sml
runtime gc.c gc.h
Log:
Added code to the runtime to allocate space for card maps. Added code to
backend/ssa-to-rssa so that the mutator does cardmap updates when writing to
pointers arrays or pointer refs.
All regressions pass with the C codegen, but the native codegen is currently
broken, because I changed the semantics of ArrayOffset so that it does not do
the derefence. I needed to do this because the address in an ArrayOffset is
treated as a value for indexing into the cardmap. The relevant change in the C
codegen is that
#define ArrayOffset(ty, b, i) (*(ty*)((b) + ((i) * sizeof(ty))))
is changed to
#define ArrayOffset(ty, b, i) ((b) + ((i) * sizeof(ty)))
Matthew, can you please make the relevant change to the native codegen.
Thanks.
Revision Changes Path
1.33 +1 -1 mlton/include/ccodegen.h
Index: ccodegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/ccodegen.h,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- ccodegen.h 27 Jul 2002 20:52:05 -0000 1.32
+++ ccodegen.h 30 Jul 2002 02:48:32 -0000 1.33
@@ -331,7 +331,7 @@
#define Array_length GC_arrayNumElements
-#define ArrayOffset(ty, b, i) (*(ty*)((b) + ((i) * sizeof(ty))))
+#define ArrayOffset(ty, b, i) ((b) + ((i) * sizeof(ty)))
#define XC(b, i) ArrayOffset(uchar, b, i)
#define XD(b, i) ArrayOffset(double, b, i)
1.32 +1 -0 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- prim.fun 29 Jul 2002 02:00:02 -0000 1.31
+++ prim.fun 30 Jul 2002 02:48:32 -0000 1.32
@@ -580,6 +580,7 @@
val word32AddCheck = make Name.Word32_addCheck
val word32Andb = make Name.Word32_andb
val word32MulCheck = make Name.Word32_mulCheck
+ val word32Rshift = make Name.Word32_rshift
val word32Sub = make Name.Word32_sub
end
1.26 +1 -0 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- prim.sig 29 Jul 2002 02:00:02 -0000 1.25
+++ prim.sig 30 Jul 2002 02:48:32 -0000 1.26
@@ -323,6 +323,7 @@
val word32FromInt: t
val word32Gt: t
val word32MulCheck: t
+ val word32Rshift: t
val word32Sub: t
val word32ToIntX: t
end
1.9 +5 -3 mlton/mlton/backend/array-init.fun
Index: array-init.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/array-init.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- array-init.fun 6 Jul 2002 17:22:05 -0000 1.8
+++ array-init.fun 30 Jul 2002 02:48:32 -0000 1.9
@@ -28,9 +28,11 @@
val loopStatements =
Vector.new3
(Statement.Move
- {dst = Operand.ArrayOffset {base = array,
- index = i,
- ty = Type.pointer},
+ {dst = (Operand.ArrayOffset
+ {base = Operand.Var {var = array,
+ ty = Type.pointer},
+ index = i,
+ ty = Type.pointer}),
src = Operand.Pointer 1},
Statement.PrimApp
{args = Vector.new2 (Operand.Var {var = i, ty = Type.int},
1.33 +2 -2 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- backend.fun 6 Jul 2002 17:22:05 -0000 1.32
+++ backend.fun 30 Jul 2002 02:48:32 -0000 1.33
@@ -369,7 +369,7 @@
ArrayHeader z =>
M.Operand.Uint (Runtime.typeIndexToHeader (arrayTypeIndex z))
| ArrayOffset {base, index, ty} =>
- M.Operand.ArrayOffset {base = varOperand base,
+ M.Operand.ArrayOffset {base = translateOperand 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 = varOperand base,
+ M.Operand.Offset {base = translateOperand base,
offset = bytes,
ty = ty}
| Pointer n => M.Operand.Pointer n
1.25 +1 -1 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- machine.fun 6 Jul 2002 17:22:05 -0000 1.24
+++ machine.fun 30 Jul 2002 02:48:33 -0000 1.25
@@ -140,7 +140,7 @@
val layout = Layout.str o toString
val ty =
- fn ArrayOffset {ty, ...} => ty
+ fn ArrayOffset _ => Type.pointer
| CastInt _ => Type.int
| CastWord _ => Type.word
| Char _ => Type.char
1.15 +10 -9 mlton/mlton/backend/rssa.fun
Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- rssa.fun 6 Jul 2002 17:22:05 -0000 1.14
+++ rssa.fun 30 Jul 2002 02:48:33 -0000 1.15
@@ -21,7 +21,7 @@
datatype t =
ArrayHeader of {numBytesNonPointers: int,
numPointers: int}
- | ArrayOffset of {base: Var.t,
+ | ArrayOffset of {base: t,
index: Var.t,
ty: Type.t}
| CastInt of t
@@ -31,7 +31,7 @@
| File
| GCState
| Line
- | Offset of {base: Var.t,
+ | Offset of {base: t,
bytes: int,
ty: Type.t}
| Pointer of int
@@ -39,6 +39,7 @@
| Var of {var: Var.t,
ty: Type.t}
+ val char = Const o Const.fromChar
val int = Const o Const.fromInt
val word = Const o Const.fromWord
fun bool b = int (if b then 1 else 0)
@@ -52,7 +53,7 @@
")"]
| ArrayOffset {base, index, ty} =>
concat ["X", Type.name ty,
- "(", Var.toString base, ",", Var.toString index, ")"]
+ "(", toString base, ",", Var.toString index, ")"]
| CastInt z => concat ["CastInt ", toString z]
| CastWord z => concat ["CastWord ", toString z]
| Const c => Const.toString c
@@ -62,7 +63,7 @@
| Line => "<Line>"
| Offset {base, bytes, ty} =>
concat ["O", Type.name ty,
- "(", Var.toString base, ",", Int.toString bytes, ")"]
+ "(", toString base, ",", Int.toString bytes, ")"]
| Pointer n => concat ["IntAsPointer (", Int.toString n, ")"]
| Runtime r => GCField.toString r
| Var {var, ...} => Var.toString var
@@ -79,7 +80,7 @@
val ty =
fn ArrayHeader _ => Type.word
- | ArrayOffset {ty, ...} => ty
+ | ArrayOffset _ => Type.pointer
| CastInt _ => Type.int
| CastWord _ => Type.word
| Const c =>
@@ -114,10 +115,10 @@
fun 'a foldVars (z: t, a: 'a, f: Var.t * 'a -> 'a): 'a =
case z of
- ArrayOffset {base, index, ...} => f (index, f (base, a))
+ ArrayOffset {base, index, ...} => f (index, foldVars (base, a, f))
| CastInt z => foldVars (z, a, f)
| CastWord z => foldVars (z, a, f)
- | Offset {base, ...} => f (base, a)
+ | Offset {base, ...} => foldVars (base, a, f)
| Var {var, ...} => f (var, a)
| _ => a
@@ -777,7 +778,7 @@
nbnp >= 0 andalso np >= 0
| ArrayOffset {base, index, ty} =>
- Type.equals (varType base, Type.pointer)
+ Type.equals (Operand.ty 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)
@@ -787,7 +788,7 @@
| GCState => true
| Line => true
| Offset {base, ...} =>
- Type.equals (varType base, Type.pointer)
+ Type.equals (Operand.ty base, Type.pointer)
| Pointer n => 0 < Int.rem (n, Runtime.wordSize)
| Runtime _ => true
| Var {ty, var} => Type.equals (ty, varType var)
1.14 +3 -2 mlton/mlton/backend/rssa.sig
Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- rssa.sig 20 Jul 2002 00:20:24 -0000 1.13
+++ rssa.sig 30 Jul 2002 02:48:33 -0000 1.14
@@ -57,7 +57,7 @@
datatype t =
ArrayHeader of {numBytesNonPointers: int,
numPointers: int}
- | ArrayOffset of {base: Var.t,
+ | ArrayOffset of {base: 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: Var.t,
+ | Offset of {base: t,
bytes: int,
ty: Type.t}
| Pointer of int (* the int must be nonzero mod Runtime.wordSize. *)
@@ -82,6 +82,7 @@
ty: Type.t}
val bool: bool -> t
+ val char: char -> t
val caseBytes: t * {big: t -> 'a,
small: word -> 'a} -> 'a
val int: int -> t
1.4 +9 -1 mlton/mlton/backend/runtime.fun
Index: runtime.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- runtime.fun 27 Jul 2002 00:48:20 -0000 1.3
+++ runtime.fun 30 Jul 2002 02:48:33 -0000 1.4
@@ -17,6 +17,7 @@
struct
datatype t =
CanHandle
+ | CardMap
| CurrentThread
| Frontier
| Limit
@@ -29,6 +30,7 @@
val ty =
fn CanHandle => Type.int
+ | CardMap => Type.pointer
| CurrentThread => Type.pointer
| Frontier => Type.pointer
| Limit => Type.pointer
@@ -40,6 +42,7 @@
| StackTop => Type.pointer
val canHandleOffset: int ref = ref 0
+ val cardMapOffset: int ref = ref 0
val currentThreadOffset: int ref = ref 0
val frontierOffset: int ref = ref 0
val limitOffset: int ref = ref 0
@@ -50,10 +53,11 @@
val stackLimitOffset: int ref = ref 0
val stackTopOffset: int ref = ref 0
- fun setOffsets {canHandle, currentThread, frontier, limit,
+ fun setOffsets {canHandle, cardMap, currentThread, frontier, limit,
limitPlusSlop, maxFrameSize, signalIsPending, stackBottom,
stackLimit, stackTop} =
(canHandleOffset := canHandle
+ ; cardMapOffset := cardMap
; currentThreadOffset := currentThread
; frontierOffset := frontier
; limitOffset := limit
@@ -66,6 +70,7 @@
val offset =
fn CanHandle => !canHandleOffset
+ | CardMap => !cardMapOffset
| CurrentThread => !currentThreadOffset
| Frontier => !frontierOffset
| Limit => !limitOffset
@@ -78,6 +83,7 @@
val toString =
fn CanHandle => "CanHandle"
+ | CardMap => "CardMap"
| CurrentThread => "CurrentThread"
| Frontier => "Frontier"
| Limit => "Limit"
@@ -141,6 +147,8 @@
val arrayLengthOffset = ~ (2 * wordSize)
val allocTooLarge: word = 0wxFFFFFFFC
+val bytesPerCardLog2: word = 0w8
+
fun normalSize {numPointers, numWordsNonPointers} =
wordSize * (numPointers + numWordsNonPointers)
1.13 +3 -0 mlton/mlton/backend/runtime.sig
Index: runtime.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.sig,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- runtime.sig 27 Jul 2002 00:48:20 -0000 1.12
+++ runtime.sig 30 Jul 2002 02:48:33 -0000 1.13
@@ -23,6 +23,7 @@
sig
datatype t =
CanHandle
+ | CardMap
| CurrentThread
| Frontier (* The place where the next object is allocated. *)
| Limit (* frontier + heapSize - LIMIT_SLOP *)
@@ -36,6 +37,7 @@
val layout: t -> Layout.t
val offset: t -> int (* Field offset in struct GC_state. *)
val setOffsets: {canHandle: int,
+ cardMap: int,
currentThread: int,
frontier: int,
limit: int,
@@ -67,6 +69,7 @@
val arrayHeaderSize: int
val arrayLengthOffset: int
val array0Size: int
+ val bytesPerCardLog2: word
val headerToTypeIndex: word -> int
val isWordAligned: int -> bool
val intInfOverheadSize: int
1.19 +55 -12 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.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- ssa-to-rssa.fun 29 Jul 2002 02:00:02 -0000 1.18
+++ ssa-to-rssa.fun 30 Jul 2002 02:48:33 -0000 1.19
@@ -321,6 +321,7 @@
| 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} =>
@@ -456,7 +457,8 @@
((n, tail (j, conSelects (test, c))) :: cases,
numLeft - 1)
| _ => (cases, numLeft))
- in switch {test = Offset {base = test,
+ in switch {test = Offset {base = Var {var = test,
+ ty = Type.pointer},
bytes = tagOffset,
ty = Type.int},
cases = Cases.Int cases,
@@ -755,6 +757,42 @@
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} =>
@@ -774,10 +812,13 @@
fun a i = Vector.sub (args, i)
fun targ () = toType (Vector.sub (targs, 0))
fun arrayOffset (ty: Type.t): Operand.t =
- ArrayOffset {base = a 0,
+ ArrayOffset {base = varOp (a 0),
index = a 1,
ty = ty}
- fun sub (ty: Type.t) = move (arrayOffset ty)
+ fun sub (ty: Type.t) =
+ move (Offset {base = arrayOffset ty,
+ bytes = 0,
+ ty = ty})
fun dst () =
case var of
SOME x =>
@@ -1037,8 +1078,9 @@
(case targ () of
NONE => none ()
| SOME t =>
- add (Move {dst = arrayOffset t,
- src = varOp (a 2)}))
+ assign
+ (t, {dst = arrayOffset t,
+ src = varOp (a 2)}))
| FFI name =>
if Option.isNone (Prim.numArgs prim)
then normal ()
@@ -1114,16 +1156,16 @@
(case targ () of
NONE => none ()
| SOME ty =>
- add
- (Move {dst = Offset {base = a 0,
- bytes = 0,
- ty = ty},
- src = varOp (a 1)}))
+ assign
+ (ty, {dst = Var {var = a 0,
+ ty = Type.pointer},
+ src = varOp (a 1)}))
| Ref_deref =>
(case targ () of
NONE => none ()
| SOME ty =>
- move (Offset {base = a 0,
+ move (Offset {base = Var {var = a 0,
+ ty = Type.pointer},
bytes = 0,
ty = ty}))
| Ref_ref =>
@@ -1263,7 +1305,8 @@
offset) of
NONE => none ()
| SOME {offset, ty} =>
- move (Offset {base = tuple,
+ move (Offset {base = Var {var = tuple,
+ ty = Type.pointer},
bytes = offset,
ty = ty}))
| S.Exp.SetExnStackLocal => add SetExnStackLocal
1.27 +1 -0 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.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- c-codegen.fun 27 Jul 2002 20:52:05 -0000 1.26
+++ c-codegen.fun 30 Jul 2002 02:48:33 -0000 1.27
@@ -168,6 +168,7 @@
in
case r of
CanHandle => "gcState.canHandle"
+ | CardMap => "gcState.heap.cardMap"
| CurrentThread => "gcState.currentThread"
| Frontier => "frontier"
| Limit => "gcState.limit"
1.5 +3 -0 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun
Index: x86-mlton-basic.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- x86-mlton-basic.fun 27 Jul 2002 00:48:20 -0000 1.4
+++ x86-mlton-basic.fun 30 Jul 2002 02:48:33 -0000 1.5
@@ -338,6 +338,9 @@
val (_, _, gcState_canHandleContentsOperand) =
make (Field.CanHandle, wordSize, Classes.GCState)
+ val (_, _, gcState_cardMapContentsOperand) =
+ make (Field.CardMap, wordSize, Classes.GCState)
+
val (gcState_currentThread, gcState_currentThreadContents,
gcState_currentThreadContentsOperand) =
make (Field.CurrentThread, pointerSize, Classes.GCState)
1.15 +1 -0 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig
Index: x86-mlton-basic.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- x86-mlton-basic.sig 27 Jul 2002 00:48:20 -0000 1.14
+++ x86-mlton-basic.sig 30 Jul 2002 02:48:33 -0000 1.15
@@ -101,6 +101,7 @@
(* gcState relative locations defined in gc.h *)
val gcState_canHandleContentsOperand: unit -> x86.Operand.t
+ val gcState_cardMapContentsOperand: unit -> x86.Operand.t
val gcState_currentThread: unit -> x86.Immediate.t
val gcState_currentThreadContentsOperand: unit -> x86.Operand.t
val gcState_currentThread_exnStackContents: unit -> x86.MemLoc.t
1.28 +1 -0 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.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- x86-translate.fun 27 Jul 2002 00:48:20 -0000 1.27
+++ x86-translate.fun 30 Jul 2002 02:48:33 -0000 1.28
@@ -134,6 +134,7 @@
in
case oper of
CanHandle => gcState_canHandleContentsOperand ()
+ | CardMap => gcState_cardMapContentsOperand ()
| CurrentThread => gcState_currentThreadContentsOperand ()
| Frontier => gcState_frontierContentsOperand ()
| Limit => gcState_limitContentsOperand ()
1.12 +1 -0 mlton/mlton/core-ml/lookup-constant.fun
Index: lookup-constant.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/lookup-constant.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- lookup-constant.fun 27 Jul 2002 00:48:20 -0000 1.11
+++ lookup-constant.fun 30 Jul 2002 02:48:33 -0000 1.12
@@ -122,6 +122,7 @@
"canHandle",
"currentThread",
"frontier",
+ "heap.cardMap",
"limit",
"limitPlusSlop",
"maxFrameSize",
1.34 +1 -1 mlton/mlton/main/compile.sml
Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- compile.sml 27 Jul 2002 00:48:20 -0000 1.33
+++ compile.sml 30 Jul 2002 02:48:33 -0000 1.34
@@ -322,7 +322,6 @@
(* Set GC_state offsets. *)
val _ =
let
-
fun get s =
case lookupConstant s of
LookupConstant.Const.Int n => n
@@ -331,6 +330,7 @@
Runtime.GCField.setOffsets
{
canHandle = get "canHandle",
+ cardMap = get "heap.cardMap",
currentThread = get "currentThread",
frontier = get "frontier",
limit = get "limit",
1.67 +95 -59 mlton/runtime/gc.c
Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.66
retrieving revision 1.67
diff -u -r1.66 -r1.67
--- gc.c 29 Jul 2002 02:00:02 -0000 1.66
+++ gc.c 30 Jul 2002 02:48:33 -0000 1.67
@@ -43,6 +43,7 @@
enum {
BOGUS_EXN_STACK = 0xFFFFFFFF,
BOGUS_POINTER = 0x1,
+ BYTES_PER_CARD = 256,
DEBUG = FALSE,
DEBUG_DETAILED = FALSE,
DEBUG_MARK_COMPACT = FALSE,
@@ -52,7 +53,6 @@
DEBUG_STACKS = FALSE,
DEBUG_THREADS = FALSE,
FORWARDED = 0xFFFFFFFF,
- GENERATIONAL = FALSE,
HEADER_SIZE = WORD_SIZE,
LIVE_RATIO = 8, /* The desired live ratio. */
STACK_HEADER_SIZE = WORD_SIZE,
@@ -129,13 +129,20 @@
return ((x > y) ? x : y);
}
+
+static inline uint roundUp (uint a, uint b) {
+ assert (a >= 0);
+ assert (b >= 1);
+ a += b - 1;
+ a -= a % b;
+ return a;
+}
+
/*
* Round size up to a multiple of the size of a page.
*/
static inline size_t roundPage (GC_state s, size_t size) {
- size += s->pageSize - 1;
- size -= size % s->pageSize;
- return (size);
+ return roundUp (size, s->pageSize);
}
#ifndef NODEBUG
@@ -172,7 +179,7 @@
static void release (void *base, size_t length) {
#if (defined (__CYGWIN__))
if (DEBUG_MEM)
- fprintf(stderr, "VirtualFree (0x%x, 0, MEM_RELEASE)\n",
+ fprintf (stderr, "VirtualFree (0x%x, 0, MEM_RELEASE)\n",
(uint)base);
if (0 == VirtualFree (base, 0, MEM_RELEASE))
die ("VirtualFree release failed");
@@ -184,7 +191,7 @@
static void decommit (void *base, size_t length) {
#if (defined (__CYGWIN__))
if (DEBUG_MEM)
- fprintf(stderr, "VirtualFree (0x%x, %u, MEM_DECOMMIT)\n",
+ fprintf (stderr, "VirtualFree (0x%x, %u, MEM_DECOMMIT)\n",
(uint)base, (uint)length);
if (0 == VirtualFree (base, length, MEM_DECOMMIT))
die ("VirtualFree decommit failed");
@@ -454,8 +461,9 @@
/* ---------------------------------------------------------------- */
void GC_display (GC_state s, FILE *stream) {
- fprintf (stream, "GC state\n\toldGen = 0x%08x\n\tnursery = 0x%08x\n\tfrontier - nursery = %u\n\tlimitPlusSlop - frontier = %d\n",
- (uint) s->heap.oldGen,
+ fprintf (stream, "GC state\n\tcardMap = 0x%08x\n\toldGen = 0x%08x\n\tnursery = 0x%08x\n\tfrontier - nursery = %u\n\tlimitPlusSlop - frontier = %d\n",
+ (uint) s->heap.cardMap,
+ (uint) s->heap.oldGen,
(uint) s->heap.nursery,
s->frontier - s->heap.nursery,
s->limitPlusSlop - s->frontier);
@@ -821,7 +829,7 @@
static inline bool isInToSpace (GC_state s, pointer p) {
return (not (GC_isPointer (p))
or (s->heap2.oldGen <= p
- and p < s->heap2.start + s->heap2.size));
+ and p < s->heap2.oldGen + s->heap2.size));
}
static bool invariant (GC_state s) {
@@ -848,7 +856,7 @@
assert (isWordAligned ((uint)s->frontier));
assert (s->heap.nursery <= s->frontier);
assert (0 == s->heap.size
- or (isPageAligned (s, s->heap.size)
+ or (isPageAligned (s, s->heap.totalSize)
and s->frontier <= s->limitPlusSlop
and s->limitPlusSlop == s->heap.nursery + s->heap.nurserySize
and s->limit == s->limitPlusSlop - LIMIT_SLOP));
@@ -940,7 +948,6 @@
max64 (live * LIVE_RATIO_MIN,
min64 (s->ramSlop * s->totalRam,
live * LIVE_RATIO)));
- res = roundPage (s, res);
if (DEBUG_RESIZING)
fprintf (stderr, "%u = heapDesiredSize (%llu)\n",
(uint)res, live);
@@ -950,17 +957,19 @@
static inline void heapInit (GC_state s, GC_heap h) {
h->size = 0;
h->start = NULL;
+ h->totalSize = 0;
}
static inline void heapRelease (GC_state s, GC_heap h) {
- if (0 == h->size)
+ if (NULL == h->start)
return;
if (s->messages)
fprintf (stderr, "Releasing heap at 0x%08x of size %u.\n",
- (uint)h->start, (uint)h->size);
- release (h->start, h->size);
- h->start = NULL;
+ (uint)h->start, (uint)h->totalSize);
+ release (h->start, h->totalSize);
h->size = 0;
+ h->start = NULL;
+ h->totalSize = 0;
}
static inline void releaseFromSpace (GC_state s) {
@@ -973,16 +982,25 @@
static inline void heapShrink (GC_state s, GC_heap h, W32 keep) {
assert (keep <= h->size);
- assert (isPageAligned (s, keep));
if (0 == keep)
heapRelease (s, h);
else if (keep < h->size) {
+ uint remove;
+
+ remove = (uint)h->start + h->totalSize
+ - roundPage (s, (uint)h->oldGen + keep);
+ assert (isPageAligned (s, remove));
if (DEBUG or s->messages)
fprintf (stderr,
- "Shrinking space at 0x%08x from %u to %u bytes.\n",
- (uint)h->start, (uint)h->size, (uint)keep);
- decommit (h->start + keep, h->size - keep);
+ "Shrinking space at 0x%08x of size %u by %u bytes.\n",
+ (uint)h->start,
+ (uint)h->totalSize,
+ (uint)remove);
h->size = keep;
+ if (remove > 0) {
+ decommit (h->start + h->totalSize - remove, remove);
+ h->totalSize -= remove;
+ }
}
}
@@ -997,23 +1015,21 @@
h = &s->heap;
h->oldGenSize = s->bytesLive;
h->toSpace = h->oldGen + h->oldGenSize;
- h->nurserySize = h->start + h->size - h->toSpace;
- if (GENERATIONAL)
+ h->nurserySize = h->oldGen + h->size - h->toSpace;
+ if (FALSE and s->generational) /* FIXME */
h->nurserySize /= 2;
- h->nursery = h->start + h->size - h->nurserySize;
+ h->nursery = h->oldGen + h->size - h->nurserySize;
s->frontier = h->nursery;
setLimit (s);
}
static inline void shrinkFromSpace (GC_state s, W32 keep) {
assert (keep <= s->heap.size);
- assert (isPageAligned (s, keep));
heapShrink (s, &s->heap, keep);
}
static inline void shrinkToSpace (GC_state s, W32 keep) {
assert (keep <= s->heap2.size);
- assert (isPageAligned (s, keep));
heapShrink (s, &s->heap2, keep);
}
@@ -1030,7 +1046,6 @@
if (DEBUG)
fprintf (stderr, "heapCreate need = %llu minSize = %u\n",
need, (uint)minSize);
- minSize = roundPage (s, minSize);
requested = heapDesiredSize (s, need);
if (requested < minSize)
requested = minSize;
@@ -1040,20 +1055,31 @@
else
heapRelease (s, h);
assert (0 == h->size and NULL == h->start);
- backoff = (requested == minSize)
- ? s->pageSize
- : roundPage (s, (requested - minSize) / 20);
- assert (isPageAligned (s, requested));
- assert (isPageAligned (s, backoff));
+ backoff = (requested - minSize) / 20;
+ if (0 == backoff)
+ backoff = 1; /* enough to terminate the loop below */
/* mmap toggling back and forth between high and low addresses to
* decrease the chance of virtual memory fragmentation causing an mmap
* to fail. This is important for large heaps.
*/
for (h->size = requested; h->size >= minSize; h->size -= backoff) {
+ uint cardMapSpace;
static int direction = 1;
int i;
- assert (isPageAligned (s, h->size));
+ if (s->generational)
+ h->numCards = roundUp (h->size, BYTES_PER_CARD)
+ / BYTES_PER_CARD;
+ else
+ h->numCards = 0;
+ if (DEBUG_DETAILED)
+ fprintf (stderr, "numCards = %u\n", h->numCards);
+ /* We make sure that the card maps take up a multiple of
+ * BYTES_PER_CARD bytes so that the heap starts on a card
+ * boundary.
+ */
+ cardMapSpace = roundUp (2 * h->numCards, BYTES_PER_CARD);
+ h->totalSize = roundPage (s, h->size + cardMapSpace);
for (i = 0; i < 32; i++) {
unsigned long address;
@@ -1063,36 +1089,42 @@
#if (defined (__CYGWIN__))
address = 0; /* FIXME */
i = 31; /* FIXME */
- h->start = VirtualAlloc ((LPVOID)address, h->size,
+ h->start = VirtualAlloc ((LPVOID)address, h->totalSize,
MEM_COMMIT,
PAGE_READWRITE);
if (DEBUG_MEM)
fprintf (stderr, "0x%08x = VirtualAlloc (0x%08x, %u, MEM_COMMIT, PAGE_READWRITE)\n",
- (uint)h->start, (uint)address,
- (uint)h->size);
+ (uint)h->start,
+ (uint)address,
+ (uint)h->totalSize);
#elif (defined (__linux__) || defined (__FreeBSD__))
- h->start = mmap (address+(void*)0, h->size, PROT_READ | PROT_WRITE,
- MAP_PRIVATE | MAP_ANON, -1, 0);
+ h->start = mmap (address+(void*)0, h->totalSize,
+ PROT_READ | PROT_WRITE,
+ MAP_PRIVATE | MAP_ANON, -1, 0);
if ((void*)-1 == h->start)
h->start = (void*)NULL;
#endif
unless ((void*)NULL == h->start) {
direction = (direction==0);
- assert (isPageAligned (s, h->size));
- if (h->size > s->maxHeapSizeSeen)
- s->maxHeapSizeSeen = h->size;
- h->oldGen = h->start;
+ assert (isPageAligned (s, h->totalSize));
+ if (h->totalSize > s->maxHeapSizeSeen)
+ s->maxHeapSizeSeen = h->totalSize;
+ h->oldGen = h->start + cardMapSpace;
+ assert ((uint)h->oldGen / BYTES_PER_CARD <= (uint)h->start);
+ h->cardMap = h->start - ((uint)h->oldGen / BYTES_PER_CARD);
+
if (DEBUG or s->messages)
fprintf (stderr, "Created heap of size %s at 0x%08x.\n",
- uintToCommaString (h->size),
+ uintToCommaString (h->totalSize),
(uint)h->start);
return TRUE;
}
}
if (s->messages)
fprintf(stderr, "[Requested %luM cannot be satisfied, backing off by %luM (need = %luM).\n",
- meg (h->size), meg (backoff), meg (need));
+ meg (h->totalSize), meg (backoff), meg (need));
}
+ h->totalSize = 0;
h->size = 0;
return FALSE;
}
@@ -1150,11 +1182,11 @@
skip = stack->reserved - stack->used;
}
size = headerBytes + objectBytes;
- assert (s->back + size + skip <= s->heap2.start + s->heap2.size);
+ assert (s->back + size + skip <= s->heap2.oldGen + s->heap2.size);
/* Copy the object. */
if (DEBUG_DETAILED)
- fprintf (stderr, "copying from 0x%08x to 0x%08x\n",
- (uint)p, (uint)s->back);
+ fprintf (stderr, "copying from 0x%08x to 0x%08x of size %u\n",
+ (uint)p, (uint)s->back, size);
copy (p - headerBytes, s->back, size);
#if METER
if (size < sizeof(sizes)/sizeof(sizes[0])) sizes[size]++;
@@ -1212,6 +1244,7 @@
* because that is too strong.
*/
assert (s->heap2.size >= s->frontier - s->heap.nursery);
+
s->back = s->heap2.oldGen;
foreachGlobal (s, forward);
forwardEachPointerInRange (s, s->heap2.oldGen, &s->back);
@@ -1632,14 +1665,14 @@
Header header;
pointer p;
uint size;
- uint totalSize;
+ uint live;
if (DEBUG_MARK_COMPACT)
fprintf (stderr, "updateBackwardPointersAndSlide\n");
back = s->frontier;
front = s->heap.oldGen;
gap = 0;
- totalSize = 0;
+ live = 0;
updateObject:
if (front == back)
goto done;
@@ -1668,7 +1701,7 @@
fprintf (stderr, "sliding 0x%08x down %u\n",
(uint)front, gap);
copy (front, front - gap, size);
- totalSize += size;
+ live += size;
front += size;
goto updateObject;
} else {
@@ -1701,7 +1734,7 @@
}
assert (FALSE);
done:
- s->bytesLive = totalSize;
+ s->bytesLive = live;
return;
}
@@ -1796,8 +1829,8 @@
(uint)s->heap.size, (uint)need, (uint)keep);
/* Shrink or grow the heap. */
if (not grow) {
- assert (roundPage (s, keep) <= s->heap.size);
- shrinkFromSpace (s, roundPage (s, keep));
+ assert (keep <= s->heap.size);
+ shrinkFromSpace (s, keep);
} else {
pointer old;
@@ -1806,8 +1839,8 @@
(uint)s->bytesLive);
releaseToSpace (s);
old = s->heap.oldGen;
- assert (roundPage (s, s->bytesLive) <= s->heap.size);
- shrinkFromSpace (s, roundPage (s, s->bytesLive));
+ assert (s->bytesLive <= s->heap.size);
+ shrinkFromSpace (s, s->bytesLive);
/* Allocate a space of the desired size. */
if (heapCreate (s, &s->heap2, need, need)) {
copy (s->heap.oldGen, s->heap2.oldGen, s->bytesLive);
@@ -1857,7 +1890,6 @@
else
shrinkToSpace (s, s->heap.size);
assert (s->heap.size >= need);
- assert (0 == s->heap2.size or s->heap.size == s->heap2.size);
assert (invariant (s));
}
@@ -2208,16 +2240,16 @@
/* Initialization */
/* ---------------------------------------------------------------- */
-static inline void initSignalStack(GC_state s) {
+static inline void initSignalStack (GC_state s) {
#if (defined (__linux__) || defined (__FreeBSD__))
static stack_t altstack;
- size_t ss_size = roundPage(s, SIGSTKSZ);
+ size_t ss_size = roundPage (s, SIGSTKSZ);
size_t psize = s->pageSize;
- void *ss_sp = ssmmap(2 * ss_size, psize, psize);
+ void *ss_sp = ssmmap (2 * ss_size, psize, psize);
altstack.ss_sp = ss_sp + ss_size;
altstack.ss_size = ss_size;
altstack.ss_flags = 0;
- sigaltstack(&altstack, NULL);
+ sigaltstack (&altstack, NULL);
#endif
}
@@ -2537,6 +2569,9 @@
}
frontier += numBytes;
}
+ if (DEBUG_DETAILED)
+ fprintf (stderr, "frontier after string allocation is 0x%08x\n",
+ (uint)frontier);
s->frontier = frontier;
}
@@ -2607,6 +2642,7 @@
s->canHandle = 0;
s->currentThread = BOGUS_THREAD;
rusageZero (&s->ru_gc);
+ s->generational = TRUE;
s->inSignalHandler = FALSE;
s->isOriginal = TRUE;
s->maxBytesLive = 0;
@@ -2810,7 +2846,7 @@
* allocated since the last collection.
*/
doGC (s, 0);
- shrinkFromSpace (s, roundPage (s, s->bytesLive * 1.1));
+ shrinkFromSpace (s, s->bytesLive * 1.1);
setNursery (s);
if (DEBUG or s->messages)
fprintf (stderr, "Packed heap to size %s.\n",
1.34 +12 -3 mlton/runtime/gc.h
Index: gc.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.h,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- gc.h 29 Jul 2002 02:00:02 -0000 1.33
+++ gc.h 30 Jul 2002 02:48:34 -0000 1.34
@@ -199,20 +199,28 @@
* | card map | cross map | old generation | to space | nursery |
* --------------------------------------------------------------------------
*
- * If generational collection is not used then the old generation and the
- * nursery are identical, and the card map, cross map, and to space are empty.
+ * If generational collection is not used then the card map, cross map, and
+ * to space are empty.
*/
typedef struct GC_heap {
pointer cardMap;
pointer crossMap;
+ uint numCards;
pointer nursery;
uint nurserySize;
pointer oldGen;
uint oldGenSize;
- uint size; /* size (in bytes) of memory area */
+ /* size is the amount (in bytes) of usable heap, i.e. not including the
+ * cardMap and crossMap.
+ */
+ uint size;
pointer start; /* start of memory area */
pointer toSpace;
+ /* totalSize is the total length of the memory area. i.e., the memory
+ * range is [start, start + totalSize)
+ */
+ uint totalSize;
} *GC_heap;
@@ -245,6 +253,7 @@
GC_thread currentThread; /* This points to a thread in the heap. */
uint fixedHeapSize; /* Only meaningful if useFixedHeap. */
GC_frameLayout *frameLayouts;
+ bool generational; /* Whether or not to use generational gc. */
pointer *globals; /* An array of size numGlobals. */
struct GC_heap heap;
struct GC_heap heap2;
-------------------------------------------------------
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