Generational Garbage Collection -- Enable using Command Heaps.SetYoung

(Be aware that generational GC requires write barriers and thus can slow down performance as well)
Optimizations pending: 
- tweak GC parameters
- omit write barriers in all cases where the destination is known to be not on the heap

git-svn-id: https://svn.inf.ethz.ch/svn/lecturers/a2/trunk@7367 8c9fc860-2736-0410-a75d-ab315db34111

source/Fox.Tool

@@ -3,13 +3,15 @@ Build and Test Tool
 (c) Felix Friedrich (fof), ETH Zürich, 2008-2016
 Conceptual design of the compiler has been worked out together with Florian Negele.
 
+Heaps.SetYoung 
+Heaps.SetOld 
 
 Compiler.Compile --noInterfaceCheck
 (* 
 	SystemTools.DoCommands
 	SystemTools.Timer start ~
 
-	Compiler.Compile -p=Win32G *)
+	Compiler.Compile -p=Win32G --writeBarriers *)
 
 	BitSets.Mod ObjectFile.Mod GenericLinker.Mod StaticLinker.Mod
 	FoxBasic.Mod  FoxProgTools.Mod  FoxScanner.Mod FoxCSharpScanner.Mod FoxSyntaxTree.Mod FoxGlobal.Mod

source/FoxArrayBase.Mod

@@ -244,10 +244,16 @@ VAR
 		RETURN base.ptr;
 	END GetPtr;
 
+	PROCEDURE SafePut(VAR dest: ANY; src: ANY);
+	BEGIN
+		dest := src;
+	END SafePut;
+	
+
 	(* set data base pointer (GC protection) *)
 	PROCEDURE PutPtr(base: UnsafeArray; value: ANY);
 	BEGIN
-		base.ptr := value
+		SafePut(base.ptr,value);
 	END PutPtr;
 
 	PROCEDURE GetSize( base: UnsafeArray ): LONGINT;
@@ -556,6 +562,9 @@ Sufficient (but not necessary) conditions:
 		ELSE CopyContent( origdest, dest, elementSize );
 		END;
 		SYSTEM.PUT( d, dest );
+		IF d = p THEN (* new block *)
+			Heaps.CheckAssignment(d,dest);
+		END;
 	END ApplyGenericUnaryAAOpS;
 
 	(** apply unary operator to array:  array INTEGER -> array INTEGER *)
@@ -604,6 +613,9 @@ Sufficient (but not necessary) conditions:
 		ELSE CopyContent( origdest, dest, elementSize );
 		END;
 		SYSTEM.PUT( d, dest );
+		IF d = p THEN (* new block *)
+			Heaps.CheckAssignment(d,dest);
+		END;
 	END ApplyGenericUnaryAAOpI;
 
 	(** apply unary operator to array:  array LONGINT -> array LONGINT *)
@@ -652,6 +664,9 @@ Sufficient (but not necessary) conditions:
 		ELSE CopyContent( origdest, dest, elementSize );
 		END;
 		SYSTEM.PUT( d, dest );
+		IF d = p THEN (* new block *)
+			Heaps.CheckAssignment(d,dest);
+		END;
 	END ApplyGenericUnaryAAOpL;
 	
 	(** apply unary operator to array:  array HUGEINT -> array HUGEINT *)
@@ -703,6 +718,9 @@ Sufficient (but not necessary) conditions:
 		ELSE CopyContent( origdest, dest, elementSize );
 		END;
 		SYSTEM.PUT( d, dest );
+		IF d = p THEN (* new block *)
+			Heaps.CheckAssignment(d,dest);
+		END;
 	END ApplyGenericUnaryAAOpH;
 
 	(** apply unary operator to array:  array REAL -> array REAL *)
@@ -751,6 +769,9 @@ Sufficient (but not necessary) conditions:
 		ELSE CopyContent( origdest, dest, elementSize );
 		END;
 		SYSTEM.PUT( d, dest );
+		IF d = p THEN (* new block *)
+			Heaps.CheckAssignment(d,dest);
+		END;
 	END ApplyGenericUnaryAAOpR;
 	
 	(** apply unary operator to array:  array LONGREAL -> array LONGREAL *)
@@ -802,6 +823,9 @@ Sufficient (but not necessary) conditions:
 		ELSE CopyContent( origdest, dest, elementSize );
 		END;
 		SYSTEM.PUT( d, dest );
+		IF d = p THEN (* new block *)
+			Heaps.CheckAssignment(d,dest);
+		END;
 	END ApplyGenericUnaryAAOpX;
 	
 	(** apply unary operator to array:  array COMPLEX -> array COMPLEX *)
@@ -853,6 +877,9 @@ Sufficient (but not necessary) conditions:
 		ELSE CopyContent( origdest, dest, elementSize );
 		END;
 		SYSTEM.PUT( d, dest );
+		IF d = p THEN (* new block *)
+			Heaps.CheckAssignment(d,dest);
+		END;
 	END ApplyGenericUnaryAAOpZ;
 	
 	(** apply unary operator to array:  array LONGCOMPLEX -> array LONGCOMPLEX *)
@@ -904,6 +931,9 @@ Sufficient (but not necessary) conditions:
 		ELSE CopyContent( origdest, dest, elementSize );
 		END;
 		SYSTEM.PUT( d, dest );
+		IF d = p THEN (* new block *)
+			Heaps.CheckAssignment(d,dest);
+		END;
 	END ApplyGenericUnaryAAOpLZ;
 
 (** apply unary operator to array:  array -> array *)
@@ -958,6 +988,9 @@ Sufficient (but not necessary) conditions:
 		ELSE CopyContent( origdest, dest, elementSize );
 		END;
 		SYSTEM.PUT( d, dest );
+		IF d = p THEN (* new block *)
+			Heaps.CheckAssignment(d,dest);
+		END;
 	END ApplyUnaryAAOp;
 
 (** apply unary operator to array:  array -> scalar *)
@@ -1080,6 +1113,9 @@ Sufficient (but not necessary) conditions:
 		ELSE CopyContent( origdest, dest, elementSize );
 		END;
 		SYSTEM.PUT( d, dest );
+		IF d = p THEN (* new block *)
+			Heaps.CheckAssignment(d,dest);
+		END;
 	END ApplyBinaryAAAOp;
 
 (** apply binary operator: array x scalar -> array *)
@@ -1138,6 +1174,9 @@ Sufficient (but not necessary) conditions:
 		ELSE CopyContent( origdest, dest, elementSize );
 		END;
 		SYSTEM.PUT( d, dest );
+		IF d = p THEN (* new block *)
+			Heaps.CheckAssignment(d,dest);
+		END;
 	END ApplyBinaryASAOp;
 
 (** apply binary operator: array x array -> scalar *)
@@ -1476,6 +1515,7 @@ Sufficient (but not necessary) conditions:
 		IF debug THEN KernelLog.String( "Allocate same " );  Report( "allocation source", src );  Report( "allocation des", dest );  END;
 		IF dest = NIL THEN  (* NIL pointer, guaranteed to be tensor *)
 			ptr := GetArrayDesc( GetDim( src ) );  dest :=ptr;
+			Heaps.CheckAssignment(ADDRESS OF dest, ptr);
 			PutFlags(dest, {TensorFlag});
 			NewData();  RETURN ptr;
 		ELSIF GetDim( dest ) # GetDim( src ) THEN  (* different dimension *)
@@ -1485,6 +1525,7 @@ Sufficient (but not necessary) conditions:
 				HALT( 100 );
 			END;
 			ptr := GetArrayDesc( GetDim( src ) );  dest :=ptr;
+			Heaps.CheckAssignment(ADDRESS OF dest, ptr);
 			PutFlags(dest, {TensorFlag});
 			NewData();  
 			RETURN ptr;
@@ -1562,12 +1603,13 @@ Sufficient (but not necessary) conditions:
 	END CopyTensor;
 
 	(* copy descriptor of src to that of dest. If not existent then create.*)
-	PROCEDURE ShallowCopy*(VAR dest: ADDRESS; src: ADDRESS);
+	PROCEDURE ShallowCopy*(VAR dest: ADDRESS; src: ADDRESS): ANY;
 	VAR ptr: ANY; flags: SET;
 
 		PROCEDURE CopyDescriptor;
 		BEGIN
 			SYSTEM.MOVE( src , dest, MathLenOffset + SIZEOF(LenInc) *  GetDim( src ));
+			PutPtr(dest, GetPtr(src)); (* GC! *)
 		END CopyDescriptor;
 
 	BEGIN
@@ -1578,6 +1620,8 @@ Sufficient (but not necessary) conditions:
 
 		IF dest = 0 THEN  (* NIL pointer, guaranteed to be tensor *)
 			ptr := GetArrayDesc( GetDim( src ) );  dest := ptr;
+			Heaps.CheckAssignment(ADDRESS OF dest, ptr);
+
 			CopyDescriptor();
 			PutFlags(dest, {TensorFlag});
 		ELSIF GetDim( dest ) # GetDim( src ) THEN  (* different dimension *)
@@ -1589,6 +1633,7 @@ Sufficient (but not necessary) conditions:
 
 			(* create a new descriptor!!! (added by Alexey) *)
 			ptr := GetArrayDesc( GetDim( src ) );  dest := ptr;
+			Heaps.CheckAssignment(ADDRESS OF dest, ptr);
 
 			CopyDescriptor();
 			PutFlags(dest, flags);
@@ -1601,9 +1646,10 @@ Sufficient (but not necessary) conditions:
 			CopyDescriptor();
 			PutFlags(dest, flags);
 		END;
+		RETURN ptr;
 	END ShallowCopy;
 
-
+(*
 	PROCEDURE DescriptorCopy( src, dest: LONGINT );
 	BEGIN
 		IF debug THEN
@@ -1613,13 +1659,18 @@ Sufficient (but not necessary) conditions:
 		SYSTEM.MOVE( src, dest, 2*SIZEOF(ADDRESS) );   (* adr and ptr *)
 		SYSTEM.MOVE( src + MathLenOffset, dest + MathLenOffset, SIZEOF(LenInc) *  GetDim( src ));   (* lens and increments *)
 	END DescriptorCopy;
+*) 
 
 	PROCEDURE ZeroCopy*(CONST src: ARRAY [?]; VAR dest: ARRAY [?]);
-	VAR s,d: ADDRESS;
+	VAR p: ANY; s,d: ADDRESS;
 	BEGIN
-		s := SYSTEM.VAL(LONGINT,src); d := SYSTEM.VAL(LONGINT,dest);
-		ShallowCopy(d,s);
+		s := SYSTEM.VAL(LONGINT,src); 
+		d := SYSTEM.VAL(LONGINT,dest);
+		p := ShallowCopy(d,s);
 		SYSTEM.PUT(ADDRESSOF(dest),d);
+		IF p = d THEN
+			Heaps.CheckAssignment(ADDRESS OF dest, p);
+		END;
 	END ZeroCopy;
 
 	OPERATOR "ALIAS"*(CONST src: ARRAY [?]): ARRAY[?];
@@ -9227,6 +9278,8 @@ TYPE
 		IF debug THEN KernelLog.String( "Allocate same " );  Report( "allocation source", src );  Report( "allocation des", dest );  END;
 		IF dest = 0 THEN  (* NIL pointer, guaranteed to be tensor *)
 			ptr := GetArrayDesc( GetDim( src ) );  dest := ptr;
+						Heaps.CheckAssignment(ADDRESS OF dest, ptr);
+
 			PutFlags(dest, {TensorFlag});
 			NewData();  
 			RETURN ptr;
@@ -9237,6 +9290,8 @@ TYPE
 				HALT( 100 );
 			END;
 			ptr := GetArrayDesc( GetDim( src ) );  dest := ptr;
+						Heaps.CheckAssignment(ADDRESS OF dest, ptr);
+
 			PutFlags(dest, {TensorFlag});
 			NewData();  RETURN ptr;
 		ELSIF (GetAdr( dest ) = 0) OR ~TransposedShape( dest, src ) THEN
@@ -9542,10 +9597,11 @@ TYPE
 			END;
 		END CopyDataBack;
 
-		PROCEDURE CopyDescriptor( src, dest: LONGINT );
+		PROCEDURE CopyDescriptor( src, dest: ADDRESS );
 		BEGIN
 			ASSERT( GetDim( src ) = GetDim( dest ) );
 			SYSTEM.MOVE( src, dest, MathLenOffset + GetDim( src ) * 8 );
+			PutPtr(dest, GetPtr(src)); (* GC ! *)
 		END CopyDescriptor;
 
 		PROCEDURE ShapeDiffers( ): BOOLEAN;
@@ -9590,7 +9646,10 @@ TYPE
 			ELSIF ((newDim = oldDim) & ~ShapeDiffers()) THEN
 				(* create a copy of the original descriptor *)
 				CheckAlloc();
-				ptr := GetArrayDesc(newDim);  dest := ptr; CopyDescriptor(src,dest);
+				ptr := GetArrayDesc(newDim);  dest := ptr; 
+							Heaps.CheckAssignment(ADDRESS OF dest, ptr);
+
+				CopyDescriptor(src,dest);
 			ELSE
 				Err( "RESHAPE: given RANGE array can not be reshaped!" );
 			END;
@@ -9606,19 +9665,25 @@ TYPE
 			IF ~(TensorFlag IN GetFlags( dest )) THEN  (* no, not allowed*)
 				Err( "RESHAPE: new dimension only allowed for TENSOR" );
 			END;
-			NewDescriptor;  NewData;  CopyData;  dest := new;
+			NewDescriptor;  NewData;  CopyData;  
+			dest := new;
 		ELSIF ShapeDiffers() THEN  (* same dim but shape of destination does not match *)
 			IF RangeFlag IN GetFlags( dest ) THEN Err( "RESHAPE: new shape not allowed for RANGE" );  END;
 			(*
 			NewDescriptor;  *) 
 			new := dest;
 			NewData;  CopyData;  
+			new := NIL;
 			(*CopyDescriptor( new, dest );*)
 		ELSIF ~SameShape( src, dest ) THEN  (* shape for destination matches but that of src is different *)
 			NewDescriptor;  NewData;  CopyData;  CopyDataBack;
 		ELSE  (* same shape, just copy *)
 			CopyContent( src, dest, Size );  RETURN;
 		END;
+		IF dest = new THEN (* new block *)
+			Heaps.CheckAssignment(ADDRESSOF(dest),new);
+		END;
+
 	END DoReshape;
 
 	(* this is memory safe: the allocation result is written to a pointer in the call chain *)
@@ -9640,7 +9705,8 @@ TYPE
 				Heaps.NewArr(data, tag, size DIV elementSize,1,FALSE);
 				dest.adr := data + ArrDataArrayOffset;
 			END;
-			dest.ptr := data;
+			SafePut(dest.ptr, data);
+			(*dest.ptr := data;*)
 			PutSize( dest, elementSize );
 		END NewData;
 
@@ -9732,6 +9798,9 @@ TYPE
 			END;
 		END;
 		SYSTEM.PUT(ADDRESSOF(destA),dest);
+		IF dest = descr THEN (* new block *)
+			Heaps.CheckAssignment(ADDRESSOF(destA),dest);
+		END;
 	END AllocateTensorX;
 
 	PROCEDURE LenA*( VAR dest: ARRAY [ * ] OF SIZE;  src: ADDRESS );
@@ -9802,6 +9871,8 @@ TYPE
 		ldim := GetDim( left );  rdim := GetDim( right );
 		IF dest = 0 THEN  (* NIL pointer, guaranteed to be tensor *)
 			ptr := GetArrayDesc( ldim + rdim );  dest := ptr;
+						Heaps.CheckAssignment(ADDRESS OF dest, ptr);
+
 			NewData();  RETURN ptr;
 		ELSIF (ldim + rdim # GetDim( dest )) THEN
 			IF ~(TensorFlag IN GetFlags( dest )) &
@@ -9809,6 +9880,8 @@ TYPE
 				HALT( 100 );
 			END;
 			ptr := GetArrayDesc( ldim + rdim );  dest := ptr;
+						Heaps.CheckAssignment(ADDRESS OF dest, ptr);
+
 			NewData();  RETURN ptr;
 		ELSIF ~CheckTensorGeometry( left, right, dest, ldim, rdim ) THEN  (* dimension matches but not geometry *)
 			IF RangeFlag IN GetFlags( dest ) THEN  (* no! not allowed *)
@@ -9906,6 +9979,9 @@ TYPE
 		Traverse( GetAdr( left ), GetAdr( right ), GetAdr( dest ), 0, 0 );
 
 		SYSTEM.PUT( d, dest );
+		IF p = dest THEN
+			Heaps.CheckAssignment(d,dest);
+		END;
 	END ApplyTensorAAAOp;
 
 	OPERATOR "**"*(CONST left,right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT;
@@ -9988,7 +10064,7 @@ TYPE
 			*)
 
 			destPtr := GetArrayDesc(destDim); (* destination dimension included *)
-			dest := SYSTEM.VAL(LONGINT,destPtr);
+			dest := SYSTEM.VAL(ADDRESS,destPtr);
 			(* SYSTEM.MOVE(src,dest,MathLenOffset); *)
 			PutAdr(dest,GetAdr(src));
 			PutPtr(dest,GetPtr(src));

source/FoxCompiler.Mod

@@ -555,7 +555,7 @@ BEGIN
 	defaultPlatform := "";
 	(* platform definitions hard coded for the common cases -- maybe (parts of it) should be outsourced to a file ?*)
 	DoAddPlatform("Win32","-b=AMD --objectFile=Binary --symbolFile=Binary --objectFileExtensions=.Obw --symbolFileExtension=.Obw");
-	DoAddPlatform("Win32G","-b=AMD --objectFile=Generic --symbolFile=Textual --newObjectFile --mergeSections --objectFileExtension=.GofW --symbolFileExtension=.SymW --preciseGC --trackLeave");
+	DoAddPlatform("Win32G","-b=AMD --objectFile=Generic --symbolFile=Textual --newObjectFile --mergeSections --objectFileExtension=.GofW --symbolFileExtension=.SymW --preciseGC --trackLeave --writeBarriers");
 	DoAddPlatform("Win32C","-b=AMD --cooperative --objectFile=Generic --newObjectFile --traceModule=Trace --objectFileExtension=.GofCW --symbolFileExtension=.SymCW");
 	DoAddPlatform("ARM","-b=ARM --objectFile=Generic --newObjectFile --metaData=simple --objectFileExtension=.Goa --symbolFileExtension=.Sya");
 	DoAddPlatform("Minos","-b=ARM --objectFile=Minos"); 

source/FoxIntermediateBackend.Mod

@@ -7473,6 +7473,7 @@ TYPE
 			previous, init: IntermediateCode.Section;
 			prevScope: SyntaxTree.Scope;
 			firstPar: LONGINT;
+			saved: RegisterEntry;
 
 			PROCEDURE CallBodies(self: IntermediateCode.Operand; type: SyntaxTree.Type);
 			VAR recordScope: SyntaxTree.RecordScope; procedure: SyntaxTree.Procedure; body: SyntaxTree.Body; flags: LONGINT;
@@ -8050,8 +8051,16 @@ TYPE
 
 						IF (temporaryVariable # NIL) & (x.type = NIL) THEN
 							Designate(p0,l);
-							ToMemory(l.op,addressType,0);
-							Emit(Mov(position,l.op,pointer));
+							IF backend.writeBarriers THEN
+								SaveRegisters();ReleaseUsedRegisters(saved);
+								Emit(Push(position,l.op));
+								Emit(Push(position,pointer));
+								CallThis(position,"Heaps","Assign",2);
+								RestoreRegisters(saved);
+							ELSE
+								ToMemory(l.op,addressType,0);
+								Emit(Mov(position,l.op,pointer));
+							END;
 							ReleaseOperand(l);
 							result.tag := emptyOperand;
 						ELSIF (x.type # NIL) THEN
@@ -9910,6 +9919,7 @@ TYPE
 			procedure: SyntaxTree.Procedure;
 			call: SyntaxTree.ProcedureCallDesignator;
 			designator: SyntaxTree.Designator;
+			saved: RegisterEntry;
 
 			PROCEDURE CanPassAsResultParameter(right: SyntaxTree.Expression): BOOLEAN;
 			VAR procedureType: SyntaxTree.ProcedureType;
@@ -9971,7 +9981,8 @@ TYPE
 				END;
 				ModifyAssignments(false);
 				RETURN;
-			ELSIF backend.writeBarriers & left.NeedsTrace() THEN
+			ELSIF backend.writeBarriers & left.NeedsTrace() & ~(leftType IS SyntaxTree.MathArrayType) THEN
+				SaveRegisters();ReleaseUsedRegisters(saved);
 				IF SemanticChecker.IsPointerType(leftType) THEN
 					Evaluate(right,rightO);
 					Designate(left,leftO);
@@ -10020,6 +10031,7 @@ TYPE
 					CallThis(position,"Heaps","Assign", 2);
 				ELSE HALT(100); (* missing ? *)
 				END;
+				RestoreRegisters(saved);
 				RETURN;
 			END;
 
@@ -11291,11 +11303,6 @@ TYPE
 			
 			Info(section,"nextMark: HeapBlock;");
 			Address(section,0);
-			
-(*
-			Info(section,"generation");
-			Longint(section,0);
-*)
 		END HeapBlock;
 		
 		PROCEDURE ProtectedHeapBlock(CONST moduleName, typeName: ARRAY OF CHAR; section: IntermediateCode.Section; dataAdrOffset: LONGINT);
@@ -11531,7 +11538,7 @@ TYPE
 							base := type.arrayBase.resolved;
 						END;
 						size := ToMemoryUnits(module.system,module.system.AlignedSizeOf(base));
-						IF SemanticChecker.ContainsPointer(base) THEN
+						IF SemanticChecker.ContainsPointer(base) & base.NeedsTrace()  THEN
 							ASSERT(n<1000000); (* not more than one million pointers on the stack ... *)
 							FOR i := 0 TO n-1 DO
 								Pointers(offset+i*size, symbol, section, base,numberPointers);

source/Heaps.Mod

@@ -13,6 +13,7 @@ MODULE Heaps;	(** AUTHOR "pjm/Luc Bläser/U. Glavitsch (ug)"; PURPOSE "Heap mana
 IMPORT Runtime (* enforce import order *), SYSTEM, Trace, Machine;
 
 CONST
+
 	Paranoid = TRUE; (* if paranoid =true, then during mark phase the GC can accept spurious pointers but reports them
 									paranoid = false expects correct metadata and correct settings of untraced variables
 									moreover, it should improve GC mark speed *)
@@ -24,7 +25,7 @@ CONST
 	AddressSize = SIZEOF(ADDRESS);
 
 	MaxTries = 16;				(* max number of times to try and allocate memory, before trapping *)
-	Unmarked = -1;				(* mark value of free blocks *)
+	Unmarked = 0;				(* mark value of free blocks *)
 	BlockSize* = 32;			(* power of two, <= 32 for RegisterCandidates *)
 	ArrayAlignment = 8;			(* first array element of ArrayBlock and first data element of SystemBlock must be aligned to 0 MOD ArrayAlignment *)
 	BlockHeaderSize* = 2 * AddressSize;
@@ -51,6 +52,15 @@ CONST
 	HeuristicStackInspectionGC* = 0;
 	MetaDataForStackGC* = 1;
 
+	(* generations *)
+	Old = 1; 
+	Young = 0;
+	GenerationMask = 2;
+	(* card set for generational GC *)
+	CardSize = 4096;
+	SetSize=SIZEOF(SET) * 8;
+
+
 TYPE
 	RootObject* = OBJECT	(* ref. Linker0 *)
 		VAR nextRoot: RootObject;	(* for linking root objects during GC *)
@@ -86,8 +96,21 @@ TYPE
 		dataAdr-: ADDRESS;
 		size-: SIZE;
 		nextMark {UNTRACED}: HeapBlock;
-		(*generation-: LONGINT;*)
 	END;
+	
+	(* mechanism of the generational garbage collector
+		
+		- newly created objects belong to the young generation
+		- a new link from old to young must be entered in a list (an array), when the list is (nearly) full a GC cycle must be run
+		- any other link, from young to young or from rootset to young does not require action
+		
+		- a gc cycle dealing with the young objects traverses the root set and the set of young pointers
+		- older objects are not marked or traversed
+		- when sweeping only unmarked objects not older than the sweep generation can be freed
+				
+		- objects that survive a collection are considered old and are always moved to the tenured objects 
+	
+	*)
 
 	FreeBlock* = POINTER TO FreeBlockDesc;
 	FreeBlockU = POINTER {UNSAFE} TO FreeBlockDesc;
@@ -205,6 +228,8 @@ VAR
 	GC*: PROCEDURE;	(** activate the garbage collector *)
 	initBlock {UNTRACED}: ANY;	(* anchor for init calls *)
 	currentMarkValue: LONGINT; (* all objects that have this value in their mark field are still used - initial value filled in by linker *)
+	generationMarkValues : ARRAY 2 OF LONGINT; (* mark values of the generations *)
+	currentGeneration: LONGINT; (* current global generation state *)
 	sweepMarkValue: LONGINT; (* most recent mark value *)
 	sweepBlockAdr: ADDRESS;	(* where to resume sweeping *)
 	sweepMemBlock {UNTRACED}: Machine.MemoryBlock; (* where to resume sweeping *)
@@ -294,7 +319,102 @@ BEGIN
 		RETURN heapBlock;
 END ExtractFromMarkList;
 
-PROCEDURE Inspect(block {UNTRACED}: ANY);
+VAR 
+	cardSet: ARRAY 0x100000000 DIV SetSize DIV CardSize OF SET; (* 1 k blocks *)
+
+PROCEDURE ShowCards*;
+VAR i: LONGINT; 
+BEGIN
+	FOR i := 0 TO LEN(cardSet)-1 DO
+		IF cardSet[i] # {} THEN
+			Trace.Int(i,1); Trace.Set(cardSet[i]); Trace.Ln;
+		END;
+	END;
+END ShowCards;
+
+PROCEDURE ClearCardSet;
+VAR i: LONGINT;
+BEGIN
+	FOR i := 0 TO LEN(cardSet)-1 DO
+		cardSet[i] := {};
+	END;
+END ClearCardSet;
+
+(* lock-free entry into card-set *)
+PROCEDURE EnterInCardSet(adr: ADDRESS);
+VAR value: SET;
+BEGIN
+	adr := adr DIV CardSize;
+	IF	adr MOD SetSize IN CAS(cardSet[adr DIV SetSize],{},{}) THEN 
+		RETURN 
+	ELSE
+		LOOP
+			value := CAS (cardSet[adr DIV SetSize], {},{});
+			IF CAS (cardSet[adr DIV SetSize], value, value + {adr MOD SetSize}) = value THEN EXIT END;
+			(*CPU.Backoff;*)
+		END;
+	END;
+END EnterInCardSet;
+
+PROCEDURE CheckAssignment*(dest, src: DataBlockU);
+BEGIN
+	IF (src # NIL) & (src.heapBlock # NIL) & (src.heapBlock.mark MOD GenerationMask = Young) THEN
+		EnterInCardSet(dest);
+	END;
+END CheckAssignment;
+
+(* Sweep phase *)
+PROCEDURE SweepCardSet();
+VAR 
+	block : HeapBlockU ;
+	blockMark, blockGeneration: LONGINT;
+	memBlock {UNTRACED} : Machine.MemoryBlock;
+	blockAdr,a1,a2: ADDRESS;
+	count,count2,count3: LONGINT;
+	orgBlock: HeapBlockU;
+	mark: BOOLEAN;
+	time1, time2: HUGEINT;
+BEGIN {UNCHECKED}
+	(* blocks in the bootheap are not found by the sweep card set! *)
+	time1 := Machine.GetTimer ();
+	count := 0; count2 := 0;
+	memBlock := Machine.memBlockHead;
+	WHILE  (memBlock # NIL) DO
+		blockAdr := memBlock.beginBlockAdr;
+		WHILE  (blockAdr < memBlock.endBlockAdr) DO
+			block := blockAdr + BlockHeaderSize;
+			a1 := blockAdr DIV CardSize;
+			a2 := (blockAdr + block.size -1) DIV CardSize;
+			mark := FALSE;
+			REPEAT
+				mark := a1 MOD SetSize IN cardSet[a1 DIV SetSize];
+				INC(a1);
+			UNTIL mark OR (a1 > a2);
+		
+			IF mark THEN 
+					IF (block.mark MOD GenerationMask = Old) & (block.mark >= generationMarkValues[Old]) THEN
+					orgBlock := block.dataAdr;
+					ASSERT(orgBlock # NIL);
+					Inspect(orgBlock, Old);
+					INC(count);
+				ELSE INC(count2);
+				END;
+			ELSE
+				INC(count3);
+			END;
+			blockAdr := blockAdr + block.size
+		END;
+		memBlock := memBlock.next;
+	END;
+	time2 := Machine.GetTimer ();
+	(*
+	TRACE(LONGINT((time2-time1) DIV (1024*1024)));
+	TRACE(count,count2,count3);
+	*)
+END SweepCardSet;
+
+
+PROCEDURE Inspect(block {UNTRACED}: ANY; generation: LONGINT);
 VAR 
 	heapBlock {UNTRACED}: HeapBlock; 
 	rootObj{UNTRACED}: RootObject; 
@@ -304,8 +424,9 @@ BEGIN
 	IF (block = NIL) OR Paranoid & ~CheckPointer(block) THEN RETURN END;
 	blockMeta := block;
 	heapBlock := blockMeta.heapBlock; 
-	IF (heapBlock = NIL) OR (heapBlock.mark >= currentMarkValue) THEN RETURN END;
-	heapBlock.mark := currentMarkValue;
+	IF (heapBlock = NIL) OR (heapBlock.mark >= currentMarkValue) OR (heapBlock.mark MOD GenerationMask > generation) & ~((blockMeta.typeBlock#NIL) & (block IS RootObject)) THEN RETURN END;
+	(* blocks in the bootheap are not found by the sweep card set, thus the root objects must be traversed in all cases *)
+	heapBlock.mark := currentMarkValue + Old (* surviving objects age *); 
 	IF Stats THEN INC(Nmarked) END;
 	IF (heapBlock IS RecordBlock) OR (heapBlock IS ProtRecBlock) OR (heapBlock IS ArrayBlock) THEN
 		IF block IS RootObject THEN
@@ -328,43 +449,36 @@ VAR orgBlock: ADDRESS; staticTypeBlock {UNTRACED}: StaticTypeBlock;
 	meta: POINTER {UNSAFE} TO RECORD staticTypeBlock {FICTIVE=TypeDescOffset}: StaticTypeBlock; last, current, first: ADDRESS END;
 BEGIN{UNCHECKED} (* omit any range checks etc.*)
 	IF Stats THEN INC(Nmark) END;
-	Inspect(p);
+	Inspect(p,currentGeneration);
 	orgHeapBlock := ExtractFromMarkList();
 	WHILE orgHeapBlock # NIL DO
 		orgBlock := orgHeapBlock.dataAdr;
 		meta := orgBlock;
 		staticTypeBlock := meta.staticTypeBlock;
-		(*
-		IF TraceInvalid THEN 
-			TRACE(orgBlock);  
-			IF staticTypeBlock # NIL THEN WriteType(staticTypeBlock); END
-		END;
-		*)
 
 		IF ~(orgHeapBlock IS ArrayBlock) THEN
 			FOR i := 0 TO LEN(staticTypeBlock.pointerOffsets) - 1 DO
 				b := orgBlock + staticTypeBlock.pointerOffsets[i];
-				Inspect(b.p)
+				Inspect(b.p,currentGeneration)
 			END
 		ELSE
 			currentArrayElemAdr := meta.first;
 			
 			lastArrayElemAdr := meta.first + meta.last * staticTypeBlock.recSize;
-			IF currentArrayElemAdr > lastArrayElemAdr THEN HALT(100) END;
 			WHILE currentArrayElemAdr < lastArrayElemAdr DO
 				FOR i := 0 TO LEN(staticTypeBlock.pointerOffsets) - 1 DO
 					b := currentArrayElemAdr + staticTypeBlock.pointerOffsets[i];
-					Inspect(b.p)
+					Inspect(b.p,currentGeneration)
 				END;
 				INC(currentArrayElemAdr, staticTypeBlock.recSize);
 			END
 		END;
 		IF orgHeapBlock IS ProtRecBlock THEN
 			protected := orgHeapBlock(ProtRecBlock);
-			Inspect(protected.awaitingLock.head);
-			Inspect(protected.awaitingCond.head);
-			Inspect(protected.lockedBy);
-			Inspect(protected.lock);
+			Inspect(protected.awaitingLock.head, currentGeneration);
+			Inspect(protected.awaitingCond.head, currentGeneration);
+			Inspect(protected.lockedBy, currentGeneration);
+			Inspect(protected.lock, currentGeneration);
 		END;
 		orgHeapBlock := ExtractFromMarkList();
 	END;
@@ -567,7 +681,7 @@ VAR
 	lastFreeBlockAdr: ADDRESS;
 	lastFreeBlockSize: ADDRESS;
 	block : HeapBlockU ; freeBlock, lastFreeBlock: FreeBlockU; 
-	blockMark: LONGINT; blockSize: SIZE;
+	blockMark, blockGeneration: LONGINT; blockSize: SIZE;
 	time1, time2: HUGEINT;
 CONST FreeBlockHeaderSize = SIZEOF(FreeBlockDesc) + BlockHeaderSize;
 CONST StrongChecks = FALSE;
@@ -589,8 +703,9 @@ BEGIN{UNCHECKED}
 		WHILE  (sweepBlockAdr < sweepMemBlock.endBlockAdr) DO
 			block := sweepBlockAdr + BlockHeaderSize;
 			blockMark := block.mark; (* cache these values since they may be overwritten during concatenation *)
+			blockGeneration := block.mark MOD GenerationMask;
 			blockSize := block.size;
-			IF (blockMark < sweepMarkValue) THEN
+			IF (blockMark < generationMarkValues[blockGeneration]) THEN
 				IF (block.typeDesc # freeBlockTag) THEN
 					Machine.Fill32(sweepBlockAdr + FreeBlockHeaderSize, blockSize - FreeBlockHeaderSize, DebugValue);
 				END;
@@ -609,7 +724,8 @@ BEGIN{UNCHECKED}
 			ELSIF StrongChecks THEN 
 				ASSERT(block.typeDesc = freeBlockTag);
 			END;
-			IF (lastFreeBlockAdr # NIL) & ((blockMark >= sweepMarkValue) OR (lastFreeBlockSize >= size) OR (sweepBlockAdr + blockSize = sweepMemBlock.endBlockAdr) )
+			
+			IF (lastFreeBlockAdr # NIL) & ((blockMark >= (* sweepMarkValue *) generationMarkValues[blockGeneration]) OR (lastFreeBlockSize >= size) OR (sweepBlockAdr + blockSize = sweepMemBlock.endBlockAdr) )
 			THEN (* no further merging is possible *)
 				IF StrongChecks THEN ASSERT(sweepBlockAdr + blockSize <= sweepMemBlock.endBlockAdr) END;
 				IF lastFreeBlockSize >= size THEN (* block found - may be too big *)
@@ -848,7 +964,7 @@ BEGIN
 	n := checkRoot;
 	WHILE n # NIL DO	(* move unmarked checked objects to finalize list *)
 		SYSTEM.GET(SYSTEM.VAL(ADDRESS, n.objWeak) + HeapBlockOffset, heapBlock);
-		IF heapBlock.mark < currentMarkValue THEN
+		IF (heapBlock.mark < generationMarkValues[heapBlock.mark MOD GenerationMask]) THEN
 			IF n = checkRoot THEN checkRoot := n.nextFin ELSE p.nextFin := n.nextFin END;
 			n.objStrong := n.objWeak;	(* anchor the object for finalization *)
 			n.finalizerStrong := n.finalizer; (* anchor the finalizer for finalization *)
@@ -947,6 +1063,7 @@ VAR
 	obj: RootObject;
 	time1, time2: HUGEINT;
 	f: FreeBlock;
+	i: LONGINT;
 BEGIN
 	 (* do never use any low level locks as the garbage collector process has a very high priority and may thus be blocked by lower level processes -> potential deadlock *)
 	(*!
@@ -961,7 +1078,18 @@ BEGIN
 		END;
 		numCandidates := 0;
 		rootList := NIL;
-		INC(currentMarkValue);
+		INC(currentMarkValue, GenerationMask);
+
+		FOR i := 0 TO currentGeneration DO
+			generationMarkValues[i] := currentMarkValue;
+		END;
+		(* TRACE(currentGeneration); *)
+		IF currentGeneration = Young THEN
+			(* sweep and enter all old blocks containing old -> new pointers *)
+			SweepCardSet();
+		END; 
+		ClearCardSet();
+
 		AddRootObject(root);
 
 		IF GCType = HeuristicStackInspectionGC THEN
@@ -982,7 +1110,6 @@ BEGIN
 			UNTIL rootList = NIL;
 
 		ELSIF GCType = MetaDataForStackGC THEN
-
 			REPEAT
 				IF rootList # NIL THEN	(* check root objects *)
 					REPEAT
@@ -1006,7 +1133,7 @@ BEGIN
 			INC(NgcCyclesAllRuns, NgcCyclesLastRun);
 			NgcCyclesMark := NgcCyclesLastRun
 		END;
-
+		(* TRACE(LONGINT((time2-time1) DIV (1024*1024))); *)
 	END;
 
 	IF EnableFreeLists THEN GetFreeBlock(MAX(LONGINT), f) END;
@@ -1063,6 +1190,8 @@ BEGIN
 	Machine.Release(Machine.Heaps);
 END LazySweepGC;
 
+VAR youngCounts: LONGINT; 
+
 (* initialize a free heap block *)
 PROCEDURE InitFreeBlock(freeBlock: FreeBlockU; mark: LONGINT; dataAdr: ADDRESS; size: SIZE);
 CONST FreeBlockHeaderSize = SIZEOF(FreeBlockDesc) + BlockHeaderSize;
@@ -1071,7 +1200,7 @@ BEGIN
 	freeBlock.typeDesc := freeBlockTag;
 	freeBlock.heapBlock := NIL;
 	(* initialize heap block fields *)
-	freeBlock.mark := mark;
+	freeBlock.mark := mark + Young; 
 	freeBlock.dataAdr := dataAdr;
 	freeBlock.size := size;
 	(* initialize free block fields *)
@@ -1096,7 +1225,7 @@ BEGIN
 	CheckPostGC;
 	try := 1;
 	p := NIL;
-	IF  (GC = NilGC) OR (throughput < 128*1024*1024) THEN
+	IF  (GC = NilGC) OR (throughput < 64*1024*1024) THEN
 		GetFreeBlock(size, p);
 		IF  (p=NIL) THEN (* try restart sweep for once *)
 			GetFreeBlock(size, p);
@@ -1107,12 +1236,30 @@ BEGIN
 
 	
 	WHILE (p = NIL) & (try <= MaxTries) DO
+		IF currentGeneration = Young THEN INC(youngCounts) END;
+		IF youngCounts > 100 THEN 
+			currentGeneration := Old;
+		END;
 		Machine.Release(Machine.Heaps);	(* give up control *)
 		GC;	(* try to free memory (other processes may also steal memory now) *)
 		Machine.Acquire(Machine.Heaps);
 		CheckPostGC;
 		sweepMemBlock := NIL;
 		GetFreeBlock(size, p);
+		IF (currentGeneration = Young) & (p=NIL) THEN
+			currentGeneration := Old;
+			Machine.Release(Machine.Heaps);	(* give up control *)
+			GC;	(* try to free memory (other processes may also steal memory now) *)
+			Machine.Acquire(Machine.Heaps);
+			CheckPostGC;
+			currentGeneration := Young;
+			sweepMemBlock := NIL;
+			GetFreeBlock(size, p);
+		END;		
+		IF youngCounts > 100 THEN 
+			currentGeneration := Young;
+			youngCounts := 0;
+		END;
 		IF p = NIL THEN
 			Machine.ExpandHeap(try, size, memBlock, beginHeapBlockAdr, endHeapBlockAdr);	(* try to extend the heap *)
 			IF endHeapBlockAdr > beginHeapBlockAdr THEN
@@ -1179,7 +1326,7 @@ BEGIN
 		systemBlock.typeDesc := systemBlockTag;
 		dataBlock.typeDesc := NilVal;
 		dataBlock.heapBlock := systemBlock;
-		systemBlock.mark := currentMarkValue;
+		systemBlock.mark := currentMarkValue + Young;
 		systemBlock.dataAdr := dataBlockAdr;
 		systemBlock.size := blockSize;
 		(*! disable realtime block handling for the time being
@@ -1229,7 +1376,7 @@ BEGIN
 			recordBlock.typeDesc := recordBlockTag;
 			dataBlock.typeDesc := tag;
 			dataBlock.heapBlock := recordBlockAdr;
-			recordBlock.mark := currentMarkValue;
+			recordBlock.mark := currentMarkValue + Young;
 			recordBlock.dataAdr := dataBlockAdr;
 			recordBlock.size := blockSize; 
 			
@@ -1244,7 +1391,8 @@ BEGIN
 			
 			SetPC(dataBlock);
 			p := dataBlock; 
-			
+			EnterInCardSet(ADDRESS OF p);
+
 			(* clear must be done inside lock to ensure all traced pointer fields are initialized to NIL *)
 			Machine.Fill32(dataBlockAdr, blockSize - SIZEOF(RecordBlockDesc) - 2 * BlockHeaderSize, 0);	(* clear everything from dataBlockAdr until end of block *)
 		ELSE
@@ -1277,7 +1425,7 @@ BEGIN
 		protRecBlock.typeDesc := protRecBlockTag;
 		dataBlock.typeDesc := tag;
 		dataBlock.heapBlock := protRecBlockAdr;
-		protRecBlock.mark := currentMarkValue;
+		protRecBlock.mark := currentMarkValue + Young;
 		protRecBlock.dataAdr := dataBlockAdr;
 		protRecBlock.size := blockSize;
 		(*! disable realtime block handling for the time being
@@ -1303,6 +1451,7 @@ BEGIN
 		
 		SetPC(dataBlock);
 		p := dataBlock; 
+		EnterInCardSet(ADDRESS OF p);
 
 		(* clear must be done inside lock to ensure all traced pointer fields are initialized to NIL *)
 		Machine.Fill32(dataBlockAdr, blockSize - SIZEOF(ProtRecBlockDesc) - 2 * BlockHeaderSize, 0);	(* clear everything from dataBlockAdr to end of block *)
@@ -1354,7 +1503,7 @@ BEGIN
 				arrayBlock.typeDesc := arrayBlockTag;
 				dataBlock.typeDesc := elemType;
 				dataBlock.heapBlock := arrayBlock; 
-				arrayBlock.mark := currentMarkValue;
+				arrayBlock.mark := currentMarkValue + Young;
 				arrayBlock.dataAdr := dataBlockAdr;
 				arrayBlock.size := blockSize;
 
@@ -1378,6 +1527,7 @@ BEGIN
 
 				SetPC(dataBlock); 
 				p := dataBlock; 
+				EnterInCardSet(ADDRESS OF p);
 			ELSE
 				p := NIL
 			END;
@@ -1426,6 +1576,7 @@ VAR p: ANY; dim: SIZE;
 		SetSizes(p);
 		SetPC(p);
 		dest := p;
+		EnterInCardSet(ADDRESS OF dest);
 END NewArray;
 
 
@@ -1513,21 +1664,31 @@ VAR assigns*: LONGINT;
 
 PROCEDURE Assign*(VAR dest: ADDRESS; src: ADDRESS);
 BEGIN
-	(*TRACE(dest,src);*)
+	CheckAssignment(ADDRESS OF dest,src);
 	dest := src;
 	INC(assigns);
 END Assign;
 
 PROCEDURE AssignRecord*(dest: ADDRESS; tag: StaticTypeBlockU; src: ADDRESS);
+VAR i: LONGINT; sval: ADDRESS;
 BEGIN
-	(*TRACE(dest,tag.recSize,LEN(tag.pointerOffsets),src);*)
+	FOR i := 0 TO LEN(tag.pointerOffsets)-1 DO
+		SYSTEM.GET(src+tag.pointerOffsets[i], sval);
+		CheckAssignment(dest + tag.pointerOffsets[i], sval); 
+	END;
 	SYSTEM.MOVE(src,dest,tag.recSize);
 	INC(assigns);
 END AssignRecord;
 
 PROCEDURE AssignArray*(dest: ADDRESS; tag: StaticTypeBlockU;  numElems: SIZE; src: ADDRESS);
+VAR i, j: LONGINT; sval: ADDRESS; 
 BEGIN
-	(*TRACE(dest,tag.recSize,LEN(tag.pointerOffsets),numElems,src);*)
+	FOR j := 0 TO LEN(tag.pointerOffsets)-1 DO
+	FOR i := 0 TO numElems-1 DO
+		SYSTEM.GET(src+tag.pointerOffsets[i] + i * tag.recSize + tag.pointerOffsets[j], sval);
+		CheckAssignment(dest+ i * tag.recSize + tag.pointerOffsets[j], sval);
+	END;
+	END;
 	SYSTEM.MOVE(src,dest,tag.recSize * numElems);
 	INC(assigns);	
 END AssignArray;
@@ -1593,7 +1754,12 @@ BEGIN
 		ASSERT(freeBlock.size MOD BlockSize  =  0)
 	END;
 
-	currentMarkValue := 1;
+	currentMarkValue := GenerationMask;
+	currentGeneration := Old;
+	FOR i := 0 TO currentGeneration DO
+		generationMarkValues[i] := currentMarkValue;
+	END;
+
 	(* extend the heap for one block such that module initialization can continue as long as Heaps.GC is not set validly *)
 	Machine.ExpandHeap(1, 1, memBlock, beginBlockAdr, endBlockAdr);	(* try = 1, size = 1 -> the minimal heap block expansion is performed *)
 	IF endBlockAdr > beginBlockAdr THEN
@@ -1608,6 +1774,21 @@ BEGIN
 
 END Init;
 
+PROCEDURE SetYoung*;
+BEGIN
+	Machine.Acquire(Machine.Heaps);
+	currentGeneration := Young;
+	Machine.Release(Machine.Heaps);
+END SetYoung;
+
+PROCEDURE SetOld*;
+BEGIN
+	Machine.Acquire(Machine.Heaps);
+	currentGeneration := Old;
+	Machine.Release(Machine.Heaps);
+END SetOld;
+
+
 
 PROCEDURE SetHeuristic*;
 BEGIN
@@ -1664,10 +1845,10 @@ TraceHeap:
 Co
 
 
-Compiler.Compile -p=Win32G
+Compiler.Compile -p=Win32G --writeBarriers --traceModule=Trace
 Runtime.Mod Trace.Mod Generic.Win32.Kernel32.Mod Win32.Machine.Mod Heaps.Mod 
 Generic.Modules.Mod Win32.Objects.Mod Win32.Kernel.Mod KernelLog.Mod Plugins.Mod Streams.Mod Pipes.Mod 
-Commands.Mod I386.Reals.Mod Generic.Reflection.Mod TrapWriters.Mod CRC.Mod SystemVersion.Mod 
+Commands.Mod I386.Reals.Mod Generic.Reflection.Mod
 Win32.Traps.Mod Win32.WinTrace.Mod Win32.StdIO.Mod Locks.Mod Win32.Clock.Mod Disks.Mod Files.Mod 
 Dates.Mod Strings.Mod UTF8Strings.Mod FileTrapWriter.Mod Caches.Mod DiskVolumes.Mod 
 OldDiskVolumes.Mod RAMVolumes.Mod DiskFS.Mod OldDiskFS.Mod OberonFS.Mod FATVolumes.Mod FATFiles.Mod 
@@ -1677,9 +1858,19 @@ StringPool.Mod ObjectFile.Mod GenericLinker.Mod GenericLoader.Mod BootConsole.Mo
 
 ~
 
-Compiler.Compile -p=Win32G --traceModule=Trace  Heaps.Mod ~
+Compiler.Compile -p=Win32G --traceModule=Trace --writeBarriers Heaps.Mod ~
 StaticLinker.Link --fileFormat=PE32 --fileName=A2.exe --extension=GofW --displacement=401000H Runtime Trace Kernel32 Machine Heaps Modules Objects Kernel KernelLog Streams Commands FIles WinFS Clock Dates Reals Strings Diagnostics BitSets StringPool ObjectFile GenericLinker Reflection  GenericLoader  BootConsole ~
-FSTools.CloseFiles A2M.exe ~
+FSTools.CloseFiles A2.exe ~
+
+
+FoxBinarySymbolFile.Test /temp/obj/Heaps ~
+
+Heaps.ShowCards 
+
+(* enable generational garbage collection *)
+Heaps.SetYoung 
+(* disable generational garbage collection *)
+Heaps.SetOld 
 
+Kernel.GC
 
-FoxBinarySymbolFile.Test /temp/obj/Heaps ~

source/Win32.Machine.Mod

@@ -743,9 +743,7 @@ BEGIN
 	SYSTEM.PUT(beginBlockAdr+4*AddressSize,endBlockAdr-beginBlockAdr);
 	SYSTEM.PUT(beginBlockAdr+5*AddressSize,beginBlockAdr+2*AddressSize);
 	SYSTEM.PUT(beginBlockAdr+6*AddressSize,0);
-	(*
-	SYSTEM.PUT(beginBlockAdr+7*AddressSize,0);
-	*)
+
 
 	memoryBlock := memBlock;
 END InitHeap;