First version with a working precise GC -- contains lots of debug tracing

I commit this in order to have a reference to the tracing code. Tracing will now be removed.

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

source/FoxIntermediateBackend.Mod

@@ -100,7 +100,7 @@ CONST
 		Size8Flag = 10; (* size = 8 *)
 		
 		ReflectionSupport = TRUE;
-		PreciseGCSupport = FALSE;
+		PreciseGCSupport = TRUE;
 		(* Solution for identifying procedure descriptors on the stack and for being able to differentiate "old school" stack frames from the underlying operating system stack frames:
 			push a procedure desriptor plus one to where the BP pointer would be located. The misalignment of the procedure descriptor makes it possible to identify that it is not
 			a base pointer but a procedure descriptor. The base pointer itself is in such cases located at BP + address size.
@@ -12663,7 +12663,7 @@ TYPE
 		END Module;
 
 		PROCEDURE PointerArray(source: IntermediateCode.Section; scope: SyntaxTree.Scope; VAR numberPointers: LONGINT);
-		VAR variable: SyntaxTree.Variable; pc: LONGINT; symbol: Sections.Section;
+		VAR variable: SyntaxTree.Variable; pc: LONGINT; symbol: Sections.Section; parameter: SyntaxTree.Parameter;
 		BEGIN
 			ArrayBlock(source,pc,"",FALSE);
 			Info(source, "pointer offsets array data");
@@ -12682,7 +12682,13 @@ TYPE
 					variable := variable.nextVariable;
 				END;
 			ELSIF scope IS SyntaxTree.ProcedureScope THEN
-				(*! parameters required ? *)
+					parameter := scope(SyntaxTree.ProcedureScope).ownerProcedure.type(SyntaxTree.ProcedureType).firstParameter;
+					WHILE parameter # NIL DO
+						IF parameter.NeedsTrace() & ~IsVariableParameter(parameter) THEN
+							Pointers(ToMemoryUnits(module.system,parameter.offsetInBits), NIL,  source, parameter.type, numberPointers);
+						END;
+						parameter := parameter.nextParameter;
+					END;
 					variable := scope(SyntaxTree.ProcedureScope).firstVariable;
 					WHILE(variable # NIL) DO
 						IF ~(variable.untraced) & (variable.externalName = NIL) THEN
@@ -12690,6 +12696,7 @@ TYPE
 						END;
 						variable := variable.nextVariable
 					END;
+					
 			END;
 			PatchArray(source,pc,numberPointers);
 		END PointerArray;
@@ -14136,15 +14143,15 @@ END FoxIntermediateBackend.
 Compiler.Compile FoxIntermediateBackend.Mod ~
 
 #	Release.Build --path="/temp/obg/"  WinAosNewObjectFile ~
-#	StaticLinker.Link --fileFormat=PE32 --fileName=A2X.exe --extension=GofW --displacement=401000H --path="/temp/obg/" 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 ~
+#	StaticLinker.Link --fileFormat=PE32 --fileName=A2Z.exe --extension=GofW --displacement=401000H --path="/temp/obg/" 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 ~
 
 #	Release.Build --path="/temp/obg/" WinAosNewObjectFile ~
 #	StaticLinker.Link --fileFormat=PE32 --fileName=A2H.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 A2X.exe ~
+FSTools.CloseFiles A2Z.exe ~
 
 SystemTools.FreeDownTo FoxIntermediateBackend ~
 
-Compiler.Compile -p=Win32G --destPath=/temp/obg/
+Compiler.Compile -p=Win32G --destPath=/temp/obg/ --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 

source/Generic.Reflection.Mod

@@ -1089,8 +1089,25 @@ TYPE
 		END;
 	END Report;
 
+VAR w: Streams.Writer; 
+
+	PROCEDURE WP(pc: ADDRESS);
+	BEGIN
+		WriteProc(w,pc);w.Update;
+	END WP;
+
+	PROCEDURE WPr(p: Objects.Process);
+	BEGIN
+		WriteProcess(w,p);w.Update;
+	END WPr;
+	
+
+
 BEGIN
 	modes := " rdy run awl awc awe rip";   (* 4 characters per mode from Objects.Ready to Objects.Terminated *)
+	Streams.OpenWriter(w, Trace.Send);
+	Objects.WriteProc := WP; 
+	Objects.WriteProcess := WPr;
 END Reflection.
 
 

source/Heaps.Mod

@@ -750,6 +750,65 @@ BEGIN
 	numCandidates := 0
 END CheckCandidates;
 
+(* Check validity of single pointer candidate and enter it into the list of candidates *)
+PROCEDURE ReportCandidate*(p: ADDRESS): BOOLEAN;
+VAR memBlock, memBlockX {UNTRACED}: Machine.MemoryBlock; 
+	tdAdr, heapBlockAdr: ADDRESS;
+	tdPtr: POINTER {UNSAFE} TO RECORD typeAdr: ADDRESS END;
+	hbPtr: POINTER {UNSAFE} TO RECORD heapBlock: HeapBlock END;
+	heapBlock {UNTRACED}: HeapBlock;
+BEGIN
+	IF p MOD SIZEOF(ADDRESS) # 0 THEN RETURN FALSE END; 
+	IF (p >= Machine.memBlockHead.beginBlockAdr) & (p < Machine.memBlockTail.endBlockAdr) THEN
+		memBlock := Machine.memBlockHead;
+		WHILE memBlock # NIL DO
+			IF (p + HeapBlockOffset >= memBlock.beginBlockAdr) & (p + HeapBlockOffset < memBlock.endBlockAdr) THEN
+				hbPtr := p + HeapBlockOffset; 
+				heapBlock := hbPtr.heapBlock;
+				heapBlockAdr := heapBlock ;
+				IF heapBlockAdr MOD SIZEOF(ADDRESS) # 0 THEN RETURN FALSE END; 
+				tdAdr :=heapBlockAdr + TypeDescOffset;
+				(* check if tdAdr is a valid pointer in the heap *)
+				memBlockX := Machine.memBlockHead;
+				WHILE memBlockX # NIL DO 
+					IF (tdAdr >= memBlockX.beginBlockAdr) & (tdAdr < memBlockX.endBlockAdr) THEN
+						(* IF (heapBlock.mark >= currentMarkValue) THEN RETURN END;*)
+						tdPtr := tdAdr;
+						tdAdr := tdPtr.typeAdr;
+						(* check whether tdAdr is a valid type descriptor address *)
+						IF (tdAdr = systemBlockTag) OR (tdAdr = recordBlockTag) OR (tdAdr = protRecBlockTag) OR (tdAdr = arrayBlockTag) THEN
+							RETURN TRUE;
+							candidates[numCandidates] := p;
+							INC(numCandidates);
+							IF numCandidates = LEN(candidates) THEN CheckCandidates END
+						END;
+						RETURN FALSE; (* found *)
+					END;
+					memBlockX := memBlockX.next
+				END;
+				RETURN FALSE; (* not found *)
+			END;
+			memBlock := memBlock.next
+		END
+	END;
+	RETURN FALSE;
+END ReportCandidate;
+
+(** RegisterCandidates - Register a block of pointer candidates *)
+PROCEDURE ReportCandidates*(adr: ADDRESS; size: SIZE);
+VAR end, p: ADDRESS;
+BEGIN
+	(* current processor must hold Heaps lock *)
+	end := adr + size;
+	WHILE adr # end DO
+		SYSTEM.GET(adr, p);
+		IF ReportCandidate(p) THEN
+			Trace.Address(adr); Trace.String(":"); Trace.Address(p); Trace.Ln; 
+		END;
+		INC(adr, AddressSize)
+	END
+END ReportCandidates;
+
 (* Check validity of single pointer candidate and enter it into the list of candidates *)
 PROCEDURE Candidate*(p: ADDRESS);
 VAR memBlock, memBlockX {UNTRACED}: Machine.MemoryBlock; 
@@ -805,6 +864,8 @@ BEGIN
 	END
 END RegisterCandidates;
 
+
+
 (* Check reachability of finalized objects. *)
 PROCEDURE CheckFinalizedObjects;
 VAR n, p, t: FinalizerNode; heapBlock {UNTRACED}: HeapBlock;

source/Win32.Objects.Mod

@@ -163,20 +163,28 @@ TYPE
 		PROCEDURE FindRoots;   (* override, called while GC, replaces Threads.CheckStacks *)
 		VAR sp: LONGINT; res: Kernel32.BOOL; pc, bp, curbp: ADDRESS;
 			n,adr: ADDRESS; desc: Modules.ProcedureDescPointer; i: LONGINT; p {UNTRACED}: ANY;
+			name: ARRAY 256 OF CHAR;
 		BEGIN
 			IF (handle = 0) OR (mode = Terminated) OR (mode < Ready) (* procedure Wrapper not yet started *)
 			OR (priority > High) (* stack of GC and realtime processes not traced *) THEN
 				RETURN
 			END;
-			(*
-			ASSERT( SYSTEM.VAL( Process, Kernel32.TlsGetValue( tlsIndex ) ) # SELF); (* should not trace gc process *)
-			*)
-
+						
 			state.ContextFlags := Kernel32.ContextControl + Kernel32.ContextInteger;
 			res := Kernel32.GetThreadContext( handle, state );
+			IF SYSTEM.VAL( Process, Kernel32.TlsGetValue( tlsIndex ) ) = SELF THEN
+				Trace.String("bp = "); Trace.Address(state.BP);
+				Trace.String(" =?= "); Trace.Address(Machine.CurrentBP()); Trace.Ln;
+				Trace.String("sp = "); Trace.Address(state.SP);
+				Trace.String(" =?= "); Trace.Address(Machine.CurrentSP()); Trace.Ln;
+				Trace.String("pc = "); Trace.Address(state.PC);
+				Trace.String(" =?= "); Trace.Address(Machine.CurrentPC()); Trace.Ln;
+				sp := Machine.CurrentSP();  bp :=Machine.CurrentBP(); pc := Machine.CurrentPC(); 
+			ELSE
+				sp := state.SP;  bp := state.BP; pc := state.PC;
+			END;
 
 			ASSERT ( res # 0, 1004 );
-			sp := state.SP;  bp := state.BP; pc := state.PC; curbp := 0;
 
 			(* stack garbage collection *)
 
@@ -188,28 +196,57 @@ TYPE
 					Heaps.RegisterCandidates( sp, stackBottom - sp );
 				END;
 			ELSIF Heaps.GCType = Heaps.MetaDataForStackGC THEN
-				WHILE (bp # Heaps.NilVal) & (sp <= bp) & (bp < stackBottom)  DO
+				IF WriteProcess # NIL THEN 
+					WriteProcess(SELF);Trace.Ln;
+				END;
+				Trace.String("Heuristic:"); Trace.Ln; 
+				Heaps.ReportCandidates(sp, stackBottom-sp); 
+				Trace.String("Metadata:"); Trace.Ln; 
+				Trace.String("sp = "); Trace.Address(sp); Trace.String(" bp= "); Trace.Address(bp);
+				Trace.String("bot = "); Trace.Address(stackBottom); Trace.Ln; 
+				WHILE (bp # Heaps.NilVal) & (sp <= bp) & (bp <= stackBottom)  DO
+					Trace.String("proc ");
+					IF WriteProc # NIL THEN
+						WriteProc(pc); Trace.String("@ ");Trace.Address(bp); Trace.String(":"); Trace.Address(pc);
+					END;
+
 					SYSTEM.GET(bp, n);
 					IF ODD(n) THEN (* procedure descriptor at bp *)
+						Trace.String(" has descriptor"); Trace.Ln;
 						DEC(n);
 						desc := SYSTEM.VAL(Modules.ProcedureDescPointer, n);
 						IF desc # NIL THEN
+							IF WriteProc # NIL THEN
+								Trace.String("proc from desc: "); WriteProc((desc.pcFrom+desc.pcLimit) DIV 2); Trace.Ln;
+							END;
 							FOR i := 0 TO LEN(desc.offsets)-1 DO
 								adr := bp + desc.offsets[i]; (* pointer at offset *)
 								SYSTEM.GET(adr, p); (* load pointer *)
-								Heaps.Mark(p);
+								IF p # NIL THEN 
+ 									Trace.Int(desc.offsets[i],1); Trace.String(":"); Trace.Address(adr); Trace.String(":"); Trace.Address(p); Trace.Ln; 
+									Heaps.Mark(p);
+								END;
 							END;
+						ELSE
+								Trace.String("has nil desc: "); Trace.Ln;
 						END;
+						SYSTEM.GET(bp + 2*SIZEOF(ADDRESS), pc); (* next pc for tracing *)
 						SYSTEM.GET(bp + SIZEOF(ADDRESS), bp);
 					ELSE (* classical stack frame *)
+						Trace.String(" has no descriptor"); Trace.Ln;
+						SYSTEM.GET(bp + SIZEOF(ADDRESS), pc); (* next pc for tracing *)
 						bp := n; 
 					END;
+					Trace.String("next bp "); Trace.Address(bp); Trace.Ln;
 				END;
 			END;
 		END FindRoots;
 		
 	END Process;
 
+VAR 
+	WriteProc* : PROCEDURE (pc: ADDRESS);
+	WriteProcess*: PROCEDURE(p: Process);
 TYPE
 	ExceptionHandler* = PROCEDURE(	VAR context: Kernel32.Context;
 										VAR excpRec: Kernel32.ExceptionRecord;