* fix from Nikolay Samofatov for #12987: initialize thread vars in libraries on windows correctly

* unified dll entry code between win32 and win64

git-svn-id: trunk@13445 -

.gitattributes

@@ -9144,6 +9144,8 @@ tests/webtbs/tw12894.pp svneol=native#text/plain
 tests/webtbs/tw12942.pp svneol=native#text/plain
 tests/webtbs/tw1295.pp svneol=native#text/plain
 tests/webtbs/tw12985.pp svneol=native#text/plain
+tests/webtbs/tw12987a.pp svneol=native#text/plain
+tests/webtbs/tw12987b.pp svneol=native#text/plain
 tests/webtbs/tw1299.pp svneol=native#text/plain
 tests/webtbs/tw12993.pp svneol=native#text/plain
 tests/webtbs/tw13015.pp svneol=native#text/plain

rtl/win/systhrd.inc

@@ -138,6 +138,7 @@ CONST
     procedure SysReleaseThreadVars;
       begin
         LocalFree(TlsGetValue(tlskey));
+        TlsSetValue(tlskey, nil);
       end;
 
 
@@ -175,6 +176,26 @@ CONST
         ThreadMain:=ti.f(ti.p);
       end;
 
+    procedure SysInitMultithreading;
+      begin
+        { do not check IsMultiThread, as program could have altered it, out of Delphi habit }
+        if TLSKey = 0 then
+         begin
+           { We're still running in single thread mode, setup the TLS }
+           TLSKey:=TlsAlloc;
+           InitThreadVars(@SysRelocateThreadvar);
+           IsMultiThread:=true;
+         end;
+      end;
+
+    procedure SysFiniMultithreading;
+      begin
+        if IsMultiThread then
+         begin
+           TlsFree(TLSKey);
+           TLSKey := 0;
+         end;
+      end;
 
     function SysBeginThread(sa : Pointer;stacksize : ptruint;
                          ThreadFunction : tthreadfunc;p : pointer;
@@ -187,13 +208,8 @@ CONST
         writeln('Creating new thread');
 {$endif DEBUG_MT}
         { Initialize multithreading if not done }
-        if not IsMultiThread then
+        SysInitMultithreading;
-         begin
+
-           { We're still running in single thread mode, setup the TLS }
-           TLSKey:=TlsAlloc;
-           InitThreadVars(@SysRelocateThreadvar);
-           IsMultiThread:=true;
-         end;
         { the only way to pass data to the newly created thread
           in a MT safe way, is to use the heap }
         new(ti);

rtl/win/syswin.inc

@@ -14,6 +14,97 @@
 
  **********************************************************************}
 
+
+Const
+   DLL_PROCESS_ATTACH = 1;
+   DLL_THREAD_ATTACH = 2;
+   DLL_PROCESS_DETACH = 0;
+   DLL_THREAD_DETACH = 3;
+   DLLExitOK : boolean = true;
+Var
+  DLLBuf : Jmp_buf;
+  MainThreadIdWin32 : DWORD;
+
+function Dll_entry{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}(const info : TEntryInformation){$endif FPC_HAS_INDIRECT_MAIN_INFORMATION} : longbool; [public,alias:'_FPC_DLL_Entry'];
+  var
+    res : longbool;
+  begin
+{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
+     EntryInformation:=info;
+{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
+     IsLibrary:=true;
+     Dll_entry:=false;
+     case DLLreason of
+       DLL_PROCESS_ATTACH :
+         begin
+           MainThreadIdWin32 := Win32GetCurrentThreadId;
+           If SetJmp(DLLBuf) = 0 then
+             begin
+               if assigned(Dll_Process_Attach_Hook) then
+                 begin
+                   res:=Dll_Process_Attach_Hook(DllParam);
+                   if not res then
+                     exit(false);
+                 end;
+{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
+               EntryInformation.PascalMain();
+{$else FPC_HAS_INDIRECT_MAIN_INFORMATION}
+               PascalMain;
+{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
+               Dll_entry:=true;
+             end
+           else
+             Dll_entry:=DLLExitOK;
+         end;
+       DLL_THREAD_ATTACH :
+         begin
+           inclocked(Thread_count);
+
+           if (Win32GetCurrentThreadId <> MainThreadIdWin32) then
+           begin
+             { Set up TLS slot for the DLL }
+             SysInitMultiThreading;
+             { Allocate Threadvars  }
+             { NS : no idea what is correct to pass here - pass dummy value for now }
+			 { passing a dummy is ok, the correct value is read from the coff header of SysInstance (FK) }
+             InitThread($1000000); { Assume everything is idempotent there, as the thread could have been created with BeginThread... }
+           end;
+
+           if assigned(Dll_Thread_Attach_Hook) then
+             Dll_Thread_Attach_Hook(DllParam);
+           Dll_entry:=true; { return value is ignored }
+         end;
+       DLL_THREAD_DETACH :
+         begin
+           declocked(Thread_count);
+           if assigned(Dll_Thread_Detach_Hook) then
+             Dll_Thread_Detach_Hook(DllParam);
+           { Release Threadvars }
+           if (Win32GetCurrentThreadId <> MainThreadIdWin32) then
+             DoneThread; { Assume everything is idempotent there }
+           Dll_entry:=true; { return value is ignored }
+         end;
+       DLL_PROCESS_DETACH :
+         begin
+           Dll_entry:=true; { return value is ignored }
+           If SetJmp(DLLBuf) = 0 then
+             FPC_Do_Exit;
+           if assigned(Dll_Process_Detach_Hook) then
+             Dll_Process_Detach_Hook(DllParam);
+
+           { Free TLS resources used by ThreadVars }
+           SysFiniMultiThreading;
+         end;
+     end;
+  end;
+
+
+Procedure ExitDLL(Exitcode : longint);
+  begin
+    DLLExitOK:=ExitCode=0;
+    LongJmp(DLLBuf,1);
+  end;
+
 {****************************************************************************
                     Error Message writing using messageboxes
 ****************************************************************************}

rtl/win32/system.pp

@@ -380,80 +380,6 @@ procedure Exe_entry(const info : TEntryInformation);[public,alias:'_FPC_EXE_Entr
      system_exit;
   end;
 
-
-Const
-  { DllEntryPoint  }
-     DLL_PROCESS_ATTACH = 1;
-     DLL_THREAD_ATTACH = 2;
-     DLL_PROCESS_DETACH = 0;
-     DLL_THREAD_DETACH = 3;
-Var
-     DLLBuf : Jmp_buf;
-Const
-     DLLExitOK : boolean = true;
-
-function Dll_entry(const info : TEntryInformation) : longbool; [public,alias:'_FPC_DLL_Entry'];
-  var
-    res : longbool;
-  begin
-     EntryInformation:=info;
-     IsLibrary:=true;
-     Dll_entry:=false;
-     case DLLreason of
-       DLL_PROCESS_ATTACH :
-         begin
-           If SetJmp(DLLBuf) = 0 then
-             begin
-               if assigned(Dll_Process_Attach_Hook) then
-                 begin
-                   res:=Dll_Process_Attach_Hook(DllParam);
-                   if not res then
-                     exit(false);
-                 end;
-{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
-               EntryInformation.PascalMain();
-{$else FPC_HAS_INDIRECT_MAIN_INFORMATION}
-               PascalMain;
-{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
-               Dll_entry:=true;
-             end
-           else
-             Dll_entry:=DLLExitOK;
-         end;
-       DLL_THREAD_ATTACH :
-         begin
-           inclocked(Thread_count);
-{ Allocate Threadvars ?!}
-           if assigned(Dll_Thread_Attach_Hook) then
-             Dll_Thread_Attach_Hook(DllParam);
-           Dll_entry:=true; { return value is ignored }
-         end;
-       DLL_THREAD_DETACH :
-         begin
-           declocked(Thread_count);
-           if assigned(Dll_Thread_Detach_Hook) then
-             Dll_Thread_Detach_Hook(DllParam);
-{ Release Threadvars ?!}
-           Dll_entry:=true; { return value is ignored }
-         end;
-       DLL_PROCESS_DETACH :
-         begin
-           Dll_entry:=true; { return value is ignored }
-           If SetJmp(DLLBuf) = 0 then
-             FPC_Do_Exit;
-           if assigned(Dll_Process_Detach_Hook) then
-             Dll_Process_Detach_Hook(DllParam);
-         end;
-     end;
-  end;
-
-Procedure ExitDLL(Exitcode : longint);
-begin
-    DLLExitOK:=ExitCode=0;
-    LongJmp(DLLBuf,1);
-end;
-
-
 function GetCurrentProcess : dword;
  stdcall;external 'kernel32' name 'GetCurrentProcess';
 

rtl/win64/system.pp

@@ -420,77 +420,7 @@ procedure Exe_entry;[public,alias:'_FPC_EXE_Entry'];
   end;
 
 
-Const
+function Dll_entry{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}(const info : TEntryInformation){$endif FPC_HAS_INDIRECT_MAIN_INFORMATION} : longbool;forward;
-  { DllEntryPoint  }
-     DLL_PROCESS_ATTACH = 1;
-     DLL_THREAD_ATTACH = 2;
-     DLL_PROCESS_DETACH = 0;
-     DLL_THREAD_DETACH = 3;
-Var
-     DLLBuf : Jmp_buf;
-Const
-     DLLExitOK : boolean = true;
-
-function Dll_entry : longbool;
-var
-  res : longbool;
-
-  begin
-     IsLibrary:=true;
-     Dll_entry:=false;
-     case DLLreason of
-       DLL_PROCESS_ATTACH :
-         begin
-           If SetJmp(DLLBuf) = 0 then
-             begin
-               if assigned(Dll_Process_Attach_Hook) then
-                 begin
-                   res:=Dll_Process_Attach_Hook(DllParam);
-                   if not res then
-                     exit(false);
-                 end;
-               PASCALMAIN;
-               Dll_entry:=true;
-             end
-           else
-             Dll_entry:=DLLExitOK;
-         end;
-       DLL_THREAD_ATTACH :
-         begin
-           inclocked(Thread_count);
-{$warning Allocate Threadvars !}
-           if assigned(Dll_Thread_Attach_Hook) then
-             Dll_Thread_Attach_Hook(DllParam);
-           Dll_entry:=true; { return value is ignored }
-         end;
-       DLL_THREAD_DETACH :
-         begin
-           declocked(Thread_count);
-           if assigned(Dll_Thread_Detach_Hook) then
-             Dll_Thread_Detach_Hook(DllParam);
-{$warning Release Threadvars !}
-           Dll_entry:=true; { return value is ignored }
-         end;
-       DLL_PROCESS_DETACH :
-         begin
-           Dll_entry:=true; { return value is ignored }
-           If SetJmp(DLLBuf) = 0 then
-             begin
-               FPC_DO_EXIT;
-             end;
-           if assigned(Dll_Process_Detach_Hook) then
-             Dll_Process_Detach_Hook(DllParam);
-         end;
-     end;
-  end;
-
-Procedure ExitDLL(Exitcode : longint);
-begin
-    DLLExitOK:=ExitCode=0;
-    LongJmp(DLLBuf,1);
-end;
-
-{$ifndef VER2_0}
 
 procedure _FPC_mainCRTStartup;stdcall;public name '_mainCRTStartup';
 begin
@@ -525,9 +455,6 @@ begin
   DLL_Entry;
 end;
 
-{$endif VER2_0}
-
-
 function GetCurrentProcess : dword;
  stdcall;external 'kernel32' name 'GetCurrentProcess';
 

tests/webtbs/tw12987a.pp

@@ -0,0 +1,23 @@
+{ %norun }
+library tw12987a;
+
+
+procedure test;
+  var
+    p1,p2 : pointer;
+    i : longint;
+  begin
+    for i:=1 to 200000 do
+      begin
+        getmem(p1,random(1000));
+        getmem(p2,random(100));
+        freemem(p1);
+        freemem(p2);
+      end;
+  end;
+
+exports
+  test;
+
+begin
+end.

tests/webtbs/tw12987b.pp

@@ -0,0 +1,20 @@
+{ %needlibrary }
+procedure test;external 'tw12987a' name 'test';
+
+function ThreadTest(p : pointer) : PtrInt;
+  begin
+    test;
+  end;
+
+var
+  t1,t2,t3 : TThreadID;
+
+begin
+  t1:=BeginThread(@ThreadTest);
+  t2:=BeginThread(@ThreadTest);
+  t3:=BeginThread(@ThreadTest);
+  WaitForThreadTerminate(t1,0);
+  WaitForThreadTerminate(t2,0);
+  WaitForThreadTerminate(t3,0);
+  writeln('Finished');
+end.