[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