This adds the collector thread to the Windows RTLs. As the new TLS variant with OS support is still in development and also won't work on all Windows variants (e.g. not on a vanilla Windows 98 SE) an alternate solution was needed.

Without further support by the OS only a kind of "garbage collector" was possible. When a thread that was not created by BeginThread of the application (!) accesses a threadvar for the first time (e.g. by accessing the standard IO) the RTL for that thread is initialized and the thread is registered with the collector.

The collector now periodically checks whether one of the registered threads has terminated (its handle is signaled) and "shuts down" the RTL for that thread by calling DoneThread while letting all threadvars point to the threadvar memory area of the terminated thread.

This isn't a beautiful solution, but I think that it is better than a memory leak.

Note for DLLs: the collector is not necessary here, because DLL_THREAD_ATTACH and DLL_THREAD_DETACH are sufficient. Also note that we might receive more DLL_THREAD_DETACH calls than DLL_THREAD_ATTACH ones, because threads that were running before the DLL was loaded don't call DLL_THREAD_ATTACH anymore.

git-svn-id: branches/svenbarth/collector@17157 -

rtl/win/systhrd.inc

@@ -49,6 +49,15 @@ function  WinResumeThread  (threadHandle : THandle) : dword; {$ifdef wince}cdecl
 function  WinCloseHandle  (threadHandle : THandle) : dword; {$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'CloseHandle';
 function  TerminateThread  (threadHandle : THandle; var exitCode : dword) : boolean; {$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'TerminateThread';
 function  WaitForSingleObject (hHandle : THandle;Milliseconds: dword): dword; {$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'WaitForSingleObject';
+{$ifdef wince}
+function GetCurrentThread: THandle;
+begin
+  GetCurrentThread := SH_CURTHREAD + SYS_HANDLE_BASE;
+end;
+{$else}
+function GetCurrentThread: THandle; external KernelDLL name 'GetCurrentThread';
+{$endif}
+function  DuplicateHandle (hSourceProcessHandle : THandle; hSourceHandle : THandle; hTargetProcessHandle : THandle; var lpTargetHandle : THandle; dwDesiredAccess : dword; bInheritHandle : longbool; dwOptions : dword) : longbool;{$ifdef wince}cdecl{$else}stdcall{$endif}; external KernelDLL name 'DuplicateHandle';
 function  WinThreadSetPriority (threadHandle : THandle; Prio: longint): boolean; {$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'SetThreadPriority';
 function  WinThreadGetPriority (threadHandle : THandle): LongInt; {$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'GetThreadPriority';
 {$ifndef WINCE}
@@ -76,6 +85,7 @@ CONST
    WAIT_IO_COMPLETION = $c0;
    WAIT_ABANDONED = $80;
    WAIT_FAILED = $ffffffff;
+   DUPLICATE_SAME_ACCESS = $00000002;
 
 {$ifndef SUPPORT_WIN95}
 function WinTryEnterCriticalSection(var cs : TRTLCriticalSection):longint;
@@ -87,6 +97,243 @@ var
   WinTryEnterCriticalSection : TTryEnterCriticalSection;
 {$endif SUPPORT_WIN95}
 
+{*****************************************************************************
+                         external Threads support
+*****************************************************************************}
+
+    const
+      ExternalThreadStkLen = $1000000; // some big number
+      CollectorWaitTime = 1000; // milliseconds
+
+    type
+      PExternalThreadInfo = ^TExternalThreadInfo;
+      TExternalThreadInfo = record
+        Handle: THandle; // handle of the external thread
+                         // this needs to be closed with CloseHandle at the end
+        ThreadVarArea: Pointer; // pointer to the threadvar area that was
+                                // allocated for this thread
+        Next: PExternalThreadInfo; // the next thread info of this list
+      end;
+
+    var
+      ExternalThreadsList: PExternalThreadInfo = nil; // the head of the list
+      ExternalThreadLock: TRTLCriticalSection; // this lock is used to
+                                               // serialize access to
+                                               // ExternalThreadsList
+     TerminateCollector: Boolean = False; // set this to true to terminate the
+                                           // collector thread and to disable
+                                           // the registration of new external
+                                           // threads
+      ExternalThreadsDetected: boolean = False; // this is set to true once the
+                                                // first external thread is
+                                                // detected
+      RegisterExternalLock: TRTLCriticalSection; // lock for serializing access
+                                                 // to HelperThreads... this is
+                                                 // initialized on startup to
+                                                 // eliminate potential race
+                                                 // condition
+      FakeThreadVars: Pointer = nil;  // set to non-Nil to fake a thread in
+                                      // SysRelocateThreadVar
+      FakeProtection: TRTLCriticalSection; // enter this critical section to
+                                           // secure the faking process
+
+{$define debug_collector}
+
+    procedure SysInitCriticalSection(var cs); forward;
+    procedure SysEnterCriticalSection(var cs); forward;
+    procedure SysLeaveCriticalSection(var cs); forward;
+
+{$ifdef debug_collector}
+    procedure WritelnDirect(aStr: ShortString);
+    var
+      dummy: longint;
+    begin
+      dummy := 0;
+      aStr := aStr + LineEnding;
+      WriteFile(StdOutputHandle, @aStr[1], Length(aStr), dummy, Nil);
+    end;
+{$endif}
+
+    function ExternalThreadCollector(parameter : pointer) : ptrint;
+    var
+      last, current, tmp, tmplast: PExternalThreadInfo;
+      res: LongWord;
+    begin
+{$ifdef debug_collector}
+      Writeln('Collector thread id: 0x', HexStr(Pointer(GetCurrentThreadID)));
+{$endif}
+      while not TerminateCollector do begin
+        Sleep(CollectorWaitTime);
+        { copy the list head during a lock }
+{$ifdef debug_collector}
+        Writeln('Getting list head');
+{$endif}
+        SysEnterCriticalSection(ExternalThreadLock);
+        current := ExternalThreadsList;
+{$ifdef debug_collector}
+        Writeln('Current: ', hexstr(current), ' Head: ',
+          hexstr(ExternalThreadsList));
+        Writeln('Current list: ');
+        tmp := current;
+        while (tmp <> nil) and not TerminateCollector do begin
+          Write(hexstr(tmp));
+          if tmp^.Next <> nil then
+            Write(' -> ')
+          else
+            Writeln;
+          tmp := tmp^.Next;
+        end;
+{$endif}
+        SysLeaveCriticalSection(ExternalThreadLock);
+
+        last := nil;
+        { now walk the thread list and check whether a thread terminated }
+        while (current <> nil) and not TerminateCollector do begin
+{$ifdef debug_collector}
+          Writeln('Checking thread ', hexstr(Pointer(current^.Handle)));
+{$endif}
+          res := WaitForSingleObject(current^.Handle, 0);
+          if res = WAIT_OBJECT_0 then begin
+            { now "impersonate" the terminated thread }
+{$ifdef debug_collector}
+            Writeln('Thread ', hexstr(Pointer(current^.Handle)), ' signaled; ',
+              'impersonating it');
+{$endif}
+            SysEnterCriticalSection(FakeProtection);
+            FakeThreadVars := current^.ThreadVarArea;
+            { don't use EndThread here, as it calls ExitThread and I want to
+              avoid another check for impersonation ^^ }
+            //FlushThread;
+            DoneThread;
+            FakeThreadVars := nil;
+            SysLeaveCriticalSection(FakeProtection);
+            CloseHandle(current^.Handle);
+
+{$ifdef debug_collector}
+            Writeln('Fixing pointer list');
+{$endif}
+            { fix up the list }
+            if last = nil then begin
+              { this was the list head }
+              SysEnterCriticalSection(ExternalThreadLock);
+{$ifdef debug_collector}
+              Writeln('Current: ', hexstr(current), ' Head: ',
+                hexstr(ExternalThreadsList));
+{$endif}
+              if current = ExternalThreadsList then begin
+{$ifdef debug_collector}
+                Writeln('Current item is still list head');
+{$endif}
+                { this is still the head, so keep it simple }
+                ExternalThreadsList := current^.Next
+              end else begin
+{$ifdef debug_collector}
+                Writeln('Searching current item again');
+{$endif}
+                { we need to walk the list again -.- }
+                tmplast := nil;
+                tmp := ExternalThreadsList;
+                while (tmp <> nil) and (tmp <> current) do begin
+                  tmplast := tmp;
+                  tmp := tmp^.Next;
+                end;
+                if tmp <> nil then
+                  tmplast^.Next := tmp^.Next;
+              end;
+              SysLeaveCriticalSection(ExternalThreadLock);
+            end else begin
+              { just fix up the last entry }
+{$ifdef debug_collector}
+              Writeln('Fixing last entry');
+{$endif}
+              last^.Next := current^.Next;
+            end;
+
+{$ifdef debug_collector}
+            Writeln('List fixed; freeing item');
+{$endif}
+            { the list is fixed, so free the entry }
+            tmp := current;
+            current := current^.Next;
+            LocalFree(tmp);
+          end else begin
+{$ifdef debug_collector}
+            Writeln('Thread not signaled (', res, '); moving to next item');
+{$endif}
+            last := current;
+            current := current^.Next;
+          end;
+        end;
+{$ifdef debug_collector}
+        Writeln('Complete list processed - sleeping');
+{$endif}
+      end;
+
+{$ifdef debug_collector}
+      Writeln('Freeing complete list');
+{$endif}
+      { no threads will be attached now, so we can do a shutdown without the
+        lock being enabled }
+      current := ExternalThreadsList;
+      while current <> nil do begin
+        { SB: EndThread this thread? }
+        CloseHandle(current^.Handle);
+        tmp := current;
+        current := current^.Next;
+        LocalFree(tmp);
+      end;
+      ExternalThreadsList := nil;
+
+{$ifdef debug_collector}
+      Writeln('Ending collector');
+{$endif}
+      EndThread;
+      Result := 0;
+    end;
+
+    procedure RegisterExternalThread(aThread: THandle; aDataArea: pointer);
+    var
+      entry: PExternalThreadInfo;
+    begin
+      SysEnterCriticalSection(RegisterExternalLock);
+      if not ExternalThreadsDetected then begin
+        { from now on we are running in external thread mode }
+        ExternalThreadsDetected := True;
+        SysInitCriticalSection(FakeProtection);
+        SysInitCriticalSection(ExternalThreadLock);
+        { start the collector }
+        BeginThread(@ExternalThreadCollector);
+      end;
+      SysLeaveCriticalSection(RegisterExternalLock);
+
+      { we must not use FPC's heap, because the memory would be allocated in the
+        external thread's context which is not what we want }
+      entry := Pointer(LocalAlloc(LMEM_FIXED, SizeOf(TExternalThreadInfo)));
+      if entry = nil then
+        { oh damn }
+        Exit;
+
+      if not DuplicateHandle(GetCurrentProcess, aThread, GetCurrentProcess,
+          entry^.Handle, 0, False, DUPLICATE_SAME_ACCESS) then begin
+        { oh damn 2nd }
+        LocalFree(entry);
+        Exit;
+      end;
+
+      entry^.ThreadVarArea := aDataArea;
+
+      { now prepend the entry to the list }
+      SysEnterCriticalSection(ExternalThreadLock);
+{$ifdef debug_collector}
+      WritelnDirect('Adding new entry ' + hexstr(entry) + ' (' +
+        hexstr(Pointer(entry^.Handle)) + ') to list with head ' +
+        hexstr(ExternalThreadsList));
+{$endif}
+      entry^.Next := ExternalThreadsList;
+      ExternalThreadsList := entry;
+      SysLeaveCriticalSection(ExternalThreadLock);
+    end;
+
 {*****************************************************************************
                              Threadvar support
 *****************************************************************************}
@@ -154,7 +401,8 @@ var
       var
         dataindex : pointer;
         errorsave : dword;
-      begin	
+        usecs : Boolean;
+      begin
 {$ifdef dummy}
         { it least in the on windows 7 x64, this still doesn't not work, fs:(0x2c) is
           self referencing on this system (FK)
@@ -181,7 +429,49 @@ var
             SetLastError(errorsave);
           end;
 {$else win32}
-        errorsave:=GetLastError;
+        { once external threads have been detected we have to use the
+          FakeProtection critical section, so that only the collector will
+          access FakeThreadVars }
+        usecs := ExternalThreadsDetected and (FakeThreadVars <> Nil)
+                   and not IsLibrary;
+        if usecs then
+          SysEnterCriticalSection(FakeProtection);
+        if FakeThreadVars <> nil then begin
+{$ifdef debug_collector}
+          WritelnDirect('SysRelocateThreadVar: Impersonating thread');
+{$endif}
+          { use the faked area }
+          dataindex := FakeThreadVars
+        end else begin
+          { use our normal thread var area }
+          errorsave:=GetLastError;
+          dataindex:=TlsGetValue(tlskey);
+          if dataindex=nil then
+            begin
+              { this is a thread that was not created by FPC's RTL... so we need
+                to initalize the RTL for this thread and do some ugly
+                bookkeeping so that we can finalize the RTL at the end. }
+{$ifdef debug_collector}
+              WritelnDirect('SysRelocateThreadVar: dataindex is Nil');
+{$endif}
+              SysAllocateThreadVars;
+              dataindex:=TlsGetValue(tlskey);
+{$ifdef debug_collector}
+              WritelnDirect('SysRelocateThreadVar: Initializing external ' +
+                'thread');
+{$endif}
+              InitThread(ExternalThreadStkLen);
+              { in a DLL an external thread will be finalized by DllMain
+                called with DLL_THREAD_DETACH }
+              if not IsLibrary then
+                { attach this thread to collector thread }
+                RegisterExternalThread(GetCurrentThread, dataindex);
+            end;
+          SetLastError(errorsave);
+        end;
+        if usecs then
+          SysLeaveCriticalSection(FakeProtection);
+{        errorsave:=GetLastError;
         dataindex:=TlsGetValue(tlskey);
         if dataindex=nil then
           begin
@@ -189,7 +479,7 @@ var
             dataindex:=TlsGetValue(tlskey);
             InitThread($1000000);
           end;
-        SetLastError(errorsave);
+        SetLastError(errorsave);}
 {$endif win32}
         SysRelocateThreadvar:=DataIndex+Offset;
       end;
@@ -197,8 +487,13 @@ var
 
     procedure SysReleaseThreadVars;
       begin
-        LocalFree(TlsGetValue(tlskey));
-        TlsSetValue(tlskey, nil);
+        if ExternalThreadsDetected and (FakeThreadVars <> nil) then
+          { finally free the memory area }
+          LocalFree(FakeThreadVars)
+        else begin
+          LocalFree(TlsGetValue(tlskey));
+          TlsSetValue(tlskey, nil);
+        end;
       end;
 
 
@@ -218,16 +513,24 @@ var
       var
         ti : tthreadinfo;
       begin
-        { Allocate local thread vars, this must be the first thing,
-          because the exception management and io depends on threadvars }
-        SysAllocateThreadVars;
-
         { Copy parameter to local data }
         ti:=pthreadinfo(param)^;
-        dispose(pthreadinfo(param));
-
-        { Initialize thread }
-        InitThread(ti.stklen);
+        { In a DLL the thread was already initialized during a call to DllMain
+          with DLL_THREAD_ATTACH }
+        if not IsLibrary {and (TlsGetValue(TLSKey) = nil)} then begin
+{$ifdef debug_collector}
+          WritelnDirect('ThreadMain: Initializing thread');
+{$endif}
+          { Allocate local thread vars, this must be the first thing,
+            because the exception management and io depends on threadvars }
+          SysAllocateThreadVars;
+
+          dispose(pthreadinfo(param));
+
+          { Initialize thread }
+          InitThread(ti.stklen);
+        end else
+          dispose(pthreadinfo(param));
 
         { Start thread function }
 {$ifdef DEBUG_MT}
@@ -536,6 +839,7 @@ begin
   ThreadID := GetCurrentThreadID;
   if IsLibrary then
     SysInitMultithreading;
+  SysInitCriticalSection(RegisterExternalLock);
 {$IFDEF SUPPORT_WIN95}
   { Try to find TryEnterCriticalSection function }
   KernelHandle:=LoadLibrary(KernelDLL);
@@ -549,3 +853,8 @@ begin
 {$ENDIF SUPPORT_WIN95}
 end;
 
+procedure FiniSystemThreads;
+begin
+  TerminateCollector := True;
+end;
+

rtl/win/syswin.inc

@@ -52,6 +52,9 @@ function Dll_entry{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}(const info : TEntry
          begin
            if Win32GetCurrentThreadId <> MainThreadIdWin32 then
            begin
+{$ifdef debug_collector}
+             WritelnDirect('Dll_entry: Initializing thread');
+{$endif}
              { Allocate Threadvars  }
              SysAllocateThreadVars;
 
@@ -68,8 +71,9 @@ function Dll_entry{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}(const info : TEntry
          begin
            if assigned(Dll_Thread_Detach_Hook) then
              Dll_Thread_Detach_Hook(DllParam);
-           { Release Threadvars }
-           if Win32GetCurrentThreadId<>MainThreadIdWin32 then
+           { Release Threadvars if the thread was initialized by the DLL }
+           if (Win32GetCurrentThreadId<>MainThreadIdWin32)
+               and (TlsGetValue(TLSKey) <> Nil) then
              DoneThread; { Assume everything is idempotent there }
            Dll_entry:=true; { return value is ignored }
          end;