Microsoft's GetThreadContext and Wow64GetThreadContext functions do not return the correct base pointer in all cases (when kernel calls have entered 64-bit mode). Therefore WinAPI calls have to be intercepted for the precise GC to work. Having intercepted EnterCriticalSection and LeaveCriticalSection seems to do the job -- might require more functions in future though.

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

source/Generic.Win32.Kernel32.Mod

@@ -212,6 +212,10 @@ TYPE
 		BP*, PC*, CS*, FLAGS*, SP*, SS*: LONGINT; (* whereas BP is EBP and SP is ESP *)
 	END;
 
+	Wow64Context*= RECORD (Context)
+		extension: ARRAY 512 (* MaxWOW64Extension *) OF CHAR;
+	END;
+	
 	ExceptionRecordPtr* = POINTER TO ExceptionRecord;
 	ExceptionRecord* = RECORD
 		ExceptionCode*, ExceptionFlags*: LONGINT;
@@ -404,9 +408,17 @@ VAR
 																			 bInheritHandle: BOOL;
 																			 dwOptions: SET ): BOOL;
 	(** The EnterCriticalSection function waits for ownership of the specified critical section object. *)
-	EnterCriticalSection-: PROCEDURE {WINAPI} ( VAR lpCriticalSection: CriticalSection );
+	enterCriticalSection: PROCEDURE {WINAPI} ( VAR lpCriticalSection: CriticalSection );
+	
+	PROCEDURE EnterCriticalSection*(VAR lpCriticalSection: CriticalSection);
+	BEGIN
+		LeaveA2;
+		enterCriticalSection(lpCriticalSection);
+		ReenterA2;
+	END EnterCriticalSection;
+
 	(** The EscapeCommFunction function directs a specified communications device to perform an extended function. *)
-	EscapeCommFunction-: PROCEDURE {WINAPI} ( hFile: HANDLE;
+	VAR EscapeCommFunction-: PROCEDURE {WINAPI} ( hFile: HANDLE;
 																					  dwFunc: LONGINT ): BOOL;
 	(** The ExitProcess function ends a process and all its threads. *)
 	ExitProcess-: PROCEDURE {WINAPI} ( uExitCode: LONGINT );
@@ -536,6 +548,11 @@ VAR
 	(** The GetThreadContext function retrieves the context of the specified thread. *)
 	GetThreadContext-: PROCEDURE {WINAPI} ( hThread: HANDLE;
 																			  VAR lpContext: Context ): BOOL;
+
+	(** The GetThreadContext function retrieves the context of the specified thread. *)
+	Wow64GetThreadContext-: PROCEDURE {WINAPI} ( hThread: HANDLE;
+																			  VAR lpContext: Wow64Context ): BOOL;
+
 	(** The GetThreadPriority function returns the priority value for the specified thread. This value, together with
 			the priority class of the thread's process, determines the thread's base-priority level. *)
 	GetThreadPriority-: PROCEDURE {WINAPI} ( hThread: HANDLE ): LONGINT;
@@ -599,11 +616,20 @@ VAR
 	(** The InterlockedIncrement function both increments (increases by one) the value of the specified 32-bit variable
 			and checks the resulting value. *)
 	InterlockedIncrement-: PROCEDURE {WINAPI} ( VAR lpAddend: LONGINT ): LONGINT;
+
 	(** The LeaveCriticalSection function releases ownership of the specified critical section object. *)
-	LeaveCriticalSection-: PROCEDURE {WINAPI} ( VAR lpCriticalSection: CriticalSection );
+	leaveCriticalSection-: PROCEDURE {WINAPI} ( VAR lpCriticalSection: CriticalSection );
+	
+	PROCEDURE LeaveCriticalSection*(VAR lpCriticalSection: CriticalSection);
+	BEGIN
+		LeaveA2;
+		leaveCriticalSection(lpCriticalSection);
+		ReenterA2;
+	END LeaveCriticalSection;
+	
 	(** The LocalFileTimeToFileTime function converts a local file time to a file time based on the Coordinated
 			Universal Time (UTC). *)
-	LocalFileTimeToFileTime-: PROCEDURE {WINAPI} ( VAR lpLocalFileTime: FileTime;
+	VAR LocalFileTimeToFileTime-: PROCEDURE {WINAPI} ( VAR lpLocalFileTime: FileTime;
 																						   VAR lpFileTime: FileTime ): BOOL;
 	(** The MoveFileEx function renames an existing file or directory. *)
 	MoveFileEx-: PROCEDURE {WINAPI} ( VAR lpExistingFileName, lpNewFileName: ARRAY   OF CHAR;
@@ -709,6 +735,8 @@ VAR
 	Sleep-: PROCEDURE {WINAPI} ( dwMilliseconds: LONGINT );
 	(** The SuspendThread function suspends the specified thread. *)
 	SuspendThread-: PROCEDURE {WINAPI} ( hThread: HANDLE ): LONGINT;
+	(** The SuspendThread function suspends the specified thread. *)
+	Wow64SuspendThread-: PROCEDURE {WINAPI} ( hThread: HANDLE ): LONGINT;
 	(** The SystemTimeToFileTime function converts a system time to a file time. *)
 	SystemTimeToFileTime-: PROCEDURE {WINAPI} ( VAR lpSystemTime: SystemTime;
 																					   VAR lpFileTime: FileTime ): BOOL;
@@ -744,6 +772,9 @@ VAR
 
 	(** Method used to write text to the Console. *)
 	OutputString*: PROCEDURE ( CONST a: ARRAY OF CHAR );
+	
+	(** methods to store the GC context before temporarily escaping to Windows -- required because GetContext does not work correctly any more  *)
+	LeaveA2*, ReenterA2*: PROCEDURE;
 
 	(* OutputString*: OutputStringProc; *)
 	Shutdown*: PROCEDURE ( code: LONGINT );
@@ -795,10 +826,16 @@ VAR
 		outputDebugString("Kernel32.Shutdown");
 		ExitProcess(l);
 	END ShutdownP;
+	
+	PROCEDURE Nothing;
+	BEGIN
+	END Nothing;
 
 	PROCEDURE Init*;
 	VAR mod: HMODULE;
 	BEGIN
+		LeaveA2 := Nothing;
+		ReenterA2 := Nothing;
 		Shutdown := ShutdownP;
 		mod := LoadLibrary("Kernel32.DLL");
 		GetProcAddress(mod, "AllocConsole",SYSTEM.VAL(ADDRESS,AllocConsole));
@@ -817,7 +854,7 @@ VAR
 		GetProcAddress(mod, "DeleteFileA",SYSTEM.VAL(ADDRESS,DeleteFile));
 		GetProcAddress(mod, "DisableThreadLibraryCalls",SYSTEM.VAL(ADDRESS,DisableThreadLibraryCalls));
 		GetProcAddress(mod, "DuplicateHandle",SYSTEM.VAL(ADDRESS,DuplicateHandle));
-		GetProcAddress(mod, "EnterCriticalSection",SYSTEM.VAL(ADDRESS,EnterCriticalSection));
+		GetProcAddress(mod, "EnterCriticalSection",SYSTEM.VAL(ADDRESS,enterCriticalSection));
 		GetProcAddress(mod, "EscapeCommFunction",SYSTEM.VAL(ADDRESS,EscapeCommFunction));
 		GetProcAddress(mod, "ExitProcess",SYSTEM.VAL(ADDRESS,ExitProcess));
 		GetProcAddress(mod, "ExitThread",SYSTEM.VAL(ADDRESS,ExitThread));
@@ -862,6 +899,7 @@ VAR
 		GetProcAddress(mod, "GetTempFileNameA",SYSTEM.VAL(ADDRESS,GetTempFileName));
 		GetProcAddress(mod, "GetTempPathA",SYSTEM.VAL(ADDRESS,GetTempPath));
 		GetProcAddress(mod, "GetThreadContext",SYSTEM.VAL(ADDRESS,GetThreadContext));
+		GetProcAddress(mod, "Wow64GetThreadContext",SYSTEM.VAL(ADDRESS,Wow64GetThreadContext));
 		GetProcAddress(mod, "GetThreadPriority",SYSTEM.VAL(ADDRESS,GetThreadPriority));
 		GetProcAddress(mod, "GetThreadTimes",SYSTEM.VAL(ADDRESS,GetThreadTimes));
 		GetProcAddress(mod, "GetTickCount",SYSTEM.VAL(ADDRESS,GetTickCount));
@@ -883,7 +921,7 @@ VAR
 		GetProcAddress(mod, "InterlockedDecrement",SYSTEM.VAL(ADDRESS,InterlockedDecrement));
 		GetProcAddress(mod, "InterlockedIncrement",SYSTEM.VAL(ADDRESS,InterlockedIncrement));
 		GetProcAddress(mod, "IsDebuggerPresent",SYSTEM.VAL(ADDRESS,IsDebuggerPresent));
-		GetProcAddress(mod, "LeaveCriticalSection",SYSTEM.VAL(ADDRESS,LeaveCriticalSection));
+		GetProcAddress(mod, "LeaveCriticalSection",SYSTEM.VAL(ADDRESS,leaveCriticalSection));
 		(* must be done by linker: GetProcAddress(mod, "LoadLibraryA",SYSTEM.VAL(ADDRESS,LoadLibrary)); *)
 		GetProcAddress(mod, "LocalFileTimeToFileTime",SYSTEM.VAL(ADDRESS,LocalFileTimeToFileTime));
 		GetProcAddress(mod, "MoveFileExA",SYSTEM.VAL(ADDRESS,MoveFileEx));
@@ -920,6 +958,7 @@ VAR
 		GetProcAddress(mod, "SetupComm",SYSTEM.VAL(ADDRESS,SetupComm));
 		GetProcAddress(mod, "Sleep",SYSTEM.VAL(ADDRESS,Sleep));
 		GetProcAddress(mod, "SuspendThread",SYSTEM.VAL(ADDRESS,SuspendThread));
+		GetProcAddress(mod, "Wow64SuspendThread",SYSTEM.VAL(ADDRESS,Wow64SuspendThread));
 		GetProcAddress(mod, "SystemTimeToFileTime",SYSTEM.VAL(ADDRESS,SystemTimeToFileTime));
 		GetProcAddress(mod, "TerminateThread",SYSTEM.VAL(ADDRESS,TerminateThread));
 		GetProcAddress(mod, "TlsAlloc",SYSTEM.VAL(ADDRESS,TlsAlloc));

source/Heaps.Mod

@@ -1019,6 +1019,7 @@ VAR p {UNTRACED}: FreeBlock;
 BEGIN
 	(* invoke mark phase, mark phase starts at next scheduler interrupt *)
 	GC;
+	RETURN;
 	(* return blocks now *)
 	Machine.Acquire(Machine.Heaps);
 	(* trying to satisfy a request of MAX(LONGINT) bytes will never succeed - lazy sweep runs until end of heap *)
@@ -1110,7 +1111,9 @@ BEGIN
 		bp := CheckBP(Machine.CurrentBP()); 
 		SYSTEM.GET(bp, bp); 
 		bp := CheckBP(bp);
+		(*! somthing wrong?
 		SYSTEM.GET(bp+SIZEOF(ADDRESS), p.heapBlock.heapBlock);
+		*)
 		(*
 		stackDesc := Machine.CurrentBP();
 		p.heapBlock.heapBlock := stackDesc.link.pc;

source/Win32.Objects.Mod

@@ -120,6 +120,10 @@ TYPE
 TYPE
 
 	Win32Event = Kernel32.HANDLE;
+	
+	GCContext = RECORD
+		ebp: ADDRESS;
+	END;
 
 	Process* = OBJECT(Heaps.ProcessLink)
 	VAR
@@ -155,10 +159,13 @@ TYPE
 		oldReturnPC: LONGINT;
 		*)
 		lastThreadTimes: HUGEINT;   (*ALEX 2005.12.12*)
+		gcContext: GCContext;
 
 		PROCEDURE FindRoots;   (* override, called while GC, replaces Threads.CheckStacks *)
-		VAR sp: LONGINT; res: Kernel32.BOOL; pc, bp: ADDRESS;
+		VAR sp: ADDRESS; res: Kernel32.BOOL; pc, bp: ADDRESS;
 			n,adr: ADDRESS; desc: Modules.ProcedureDescPointer; i: LONGINT; p {UNTRACED}: ANY;
+			context: Kernel32.Wow64Context;
+			a0,a1, obp, osb, osbp, opc, gbp: ADDRESS;
 		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
@@ -169,47 +176,75 @@ TYPE
 				sp := Machine.CurrentSP();  bp :=Machine.CurrentBP(); pc := Machine.CurrentPC(); 
 			ELSE
 				IF mode # Suspended THEN
-					res := Kernel32.SuspendThread(handle);
-					ASSERT(res >= 0);
+					IF Kernel32.Wow64SuspendThread # NIL THEN 
+						res := Kernel32.Wow64SuspendThread(handle);
+					ELSE
+						res := Kernel32.SuspendThread(handle);
+					END;
+					ASSERT(res # -1);
 				END;
+
 				state.ContextFlags := Kernel32.ContextControl + Kernel32.ContextInteger;
 				res := Kernel32.GetThreadContext( handle, state );
-				ASSERT(res >= 0);
-				sp := state.SP; bp := state.BP; pc := state.PC;
-				IF mode # Suspended THEN
-					res := Kernel32.ResumeThread(handle);
-					ASSERT(res >= 0);
+				
+				context.ContextFlags := Kernel32.ContextControl + Kernel32.ContextInteger;
+				IF Kernel32.Wow64GetThreadContext # NIL THEN 
+					res := Kernel32.Wow64GetThreadContext( handle, context );
+				ELSE
+					res := Kernel32.GetThreadContext( handle, context );
 				END;
+				ASSERT(res # 0);
+				sp := context.SP; bp := context.BP; pc := context.PC;
+				
+				
+				obp := bp; osb := stackBottom; opc := pc;
+				osbp := state.BP;
 			END;
+			gbp := gcContext.ebp;
+			IF gbp # NIL THEN bp := gbp END;
+			
 			(* stack garbage collection *)
 
 			IF Heaps.GCType= Heaps.HeuristicStackInspectionGC THEN
-				Heaps.Candidate( state.EDI );  Heaps.Candidate( state.ESI );
-				Heaps.Candidate( state.EBX ); Heaps.Candidate( state.EDX );
-				Heaps.Candidate( state.ECX ); Heaps.Candidate( state.EAX );
+				Heaps.Candidate( context.EDI );  Heaps.Candidate( context.ESI );
+				Heaps.Candidate( context.EBX ); Heaps.Candidate( context.EDX );
+				Heaps.Candidate( context.ECX ); Heaps.Candidate( context.EAX );
 				IF (stackBottom # 0) & (sp # 0) THEN
 					Heaps.RegisterCandidates( sp, stackBottom - sp );
 				END;
 			ELSIF Heaps.GCType = Heaps.MetaDataForStackGC THEN
-				WHILE (bp # Heaps.NilVal) & (sp <= bp) & (bp <= stackBottom)  DO
-					SYSTEM.GET(bp, n);
-					IF ODD(n) THEN (* procedure descriptor at bp *)
-						desc := SYSTEM.VAL(Modules.ProcedureDescPointer, n-1);
-						IF desc # NIL THEN
-							FOR i := 0 TO LEN(desc.offsets)-1 DO
-								adr := bp + desc.offsets[i]; (* pointer at offset *)
-								SYSTEM.GET(adr, p); (* load pointer *)
-								IF p # NIL THEN 
-									Heaps.Mark(p);
+				IF bp < stackBottom THEN
+					WHILE (bp # Heaps.NilVal) & (bp < stackBottom)  DO (* do not test for bp >= sp: could be wrong temporarily! *)
+						SYSTEM.GET(bp, n);
+						IF ODD(n) THEN (* procedure descriptor at bp *)
+							desc := SYSTEM.VAL(Modules.ProcedureDescPointer, n-1);
+							IF desc # NIL THEN
+								a0 := ADDRESSOF(desc.offsets);
+								a1 :=  SYSTEM.VAL(ADDRESS, desc.offsets);
+								ASSERT(a0+SIZEOF(ADDRESS)=a1,54321);
+								FOR i := 0 TO LEN(desc.offsets)-1 DO
+									adr := bp + desc.offsets[i]; (* pointer at offset *)
+									SYSTEM.GET(adr, p); (* load pointer *)
+									IF p # NIL THEN 
+										Heaps.Mark(p);
+									END;
 								END;
 							END;
+							SYSTEM.GET(bp + SIZEOF(ADDRESS), bp);
+						ELSE (* classical stack frame *)
+							bp := n; 
 						END;
-						SYSTEM.GET(bp + SIZEOF(ADDRESS), bp);
-					ELSE (* classical stack frame *)
-						bp := n; 
 					END;
-				END;
+					
+					ASSERT((bp = stackBottom) OR (bp=0) ,12345);
+				END; 
+			END;
+			
+			IF (CurrentProcess() # SELF) & (mode # Suspended) THEN
+				res := Kernel32.ResumeThread(handle);
+				ASSERT(res # -1);
 			END;
+
 		END FindRoots;
 		
 	END Process;
@@ -239,7 +274,11 @@ TYPE
 				WHILE p # NIL DO
 					cur := p(Process);
 					IF ((cur.mode = Ready) OR (cur.mode = Running)) & (cur.priority <= High) & (cur # r) THEN
-						res := Kernel32.SuspendThread(cur.handle);
+						IF Kernel32.Wow64SuspendThread # NIL THEN 
+							res := Kernel32.Wow64SuspendThread(cur.handle);
+						ELSE
+							res := Kernel32.SuspendThread(cur.handle);
+						END;
 						ASSERT(res >= 0);
 						cur.mode := Suspended
 					ELSE INC(num);
@@ -1001,7 +1040,11 @@ END Await;
 		IF CurrentProcess() # t THEN
 			Machine.Acquire( Machine.Objects );
 			LOOP
-				retBOOL := Kernel32.SuspendThread( t.handle );
+				IF Kernel32.Wow64SuspendThread # NIL THEN 
+					retBOOL := Kernel32.Wow64SuspendThread(t.handle);
+				ELSE
+					retBOOL := Kernel32.SuspendThread( t.handle );
+				END;
 				t.state.ContextFlags := Kernel32.ContextControl;
 				retBOOL := Kernel32.GetThreadContext( t.handle, t.state );
 				mod := Modules.ThisModuleByAdr( t.state.PC );  Trace.String( "Objects Break at adr: " );
@@ -1083,6 +1126,8 @@ BEGIN
 	ASSERT(t.handle # 0);
 	Machine.Release(Machine.Objects);
 	InitEventHandling; (* implicit call of NewProcess! *)
+	Kernel32.LeaveA2 := LeaveA2;
+	Kernel32.ReenterA2 := ReenterA2;
 	InitGCHandling; (* do. *)
 	Heaps.gcStatus := GCStatusFactory()
 END Init;
@@ -1219,6 +1264,28 @@ END TimerFrequency;
 
 VAR GetProcedureName*: PROCEDURE (pc: ADDRESS; VAR n: ARRAY OF CHAR; VAR spc: ADDRESS);
 
+
+PROCEDURE LeaveA2;
+VAR cur: Process; ebp,n: ADDRESS;
+BEGIN
+	cur := CurrentProcess();
+	IF cur # NIL THEN 
+		ebp := Machine.CurrentBP();
+		SYSTEM.GET(ebp, n);
+		IF ODD(n) THEN SYSTEM.GET(ebp + SIZEOF(ADDRESS), ebp) ELSE ebp := n END;
+		cur.gcContext.ebp := ebp;
+	END;
+END LeaveA2;
+
+PROCEDURE ReenterA2;
+VAR cur: Process;
+BEGIN
+	cur := CurrentProcess();
+	IF cur # NIL THEN 
+		cur.gcContext.ebp := NIL;
+	END;	
+END ReenterA2;
+
 BEGIN
 	exceptionhandler := NIL;
 	terminateProc := TerminateProc;
@@ -1226,6 +1293,12 @@ BEGIN
 	tlsIndex := Kernel32.TlsAlloc();
 	ASSERT ( tlsIndex # Kernel32.TLSOutOfIndexes );
 	Kernel32.SendToDebugger("Modules.root", ADDRESSOF(Modules.root));
+	IF Kernel32.Wow64GetThreadContext # NIL THEN
+		Trace.String("Use Wow64 Context"); Trace.Ln;
+	END;
+	IF Kernel32.Wow64SuspendThread # NIL THEN
+		Trace.String("Use Wow64 suspend"); Trace.Ln;
+	END;
 	Init
 END Objects.