Browse Source

* Call InitHeap before InitSystemThreads in TLS callback (necessary because InitSystemThreads calls RelocateHeap), and skip both of them in initialization section of system.pp if they have been called from TLS callback. This restores correct initialization sequence which was broken by r19779, resulting in lots of debug messages about corrupted heap when running tests/test/theapthread.pp

git-svn-id: trunk@19836 -
sergei 13 years ago
parent
commit
bcbd25568e
4 changed files with 18 additions and 10 deletions
  1. 1 1
      rtl/inc/heap.inc
  2. 5 1
      rtl/win/systlsdir.inc
  3. 6 4
      rtl/win32/system.pp
  4. 6 4
      rtl/win64/system.pp

+ 1 - 1
rtl/inc/heap.inc

@@ -1510,7 +1510,7 @@ begin
 end;
 end;
 {$endif}
 {$endif}
 
 
-procedure InitHeap;
+procedure InitHeap; public name '_FPC_InitHeap';
 var
 var
   loc_freelists: pfreelists;
   loc_freelists: pfreelists;
 begin
 begin

+ 5 - 1
rtl/win/systlsdir.inc

@@ -47,6 +47,7 @@ function TlsGetValue(dwTlsIndex : DWord) : pointer; stdcall;
 
 
 procedure InitSystemThreads; external name '_FPC_InitSystemThreads';
 procedure InitSystemThreads; external name '_FPC_InitSystemThreads';
 procedure SysAllocateThreadVars; external name '_FPC_SysAllocateThreadVars';
 procedure SysAllocateThreadVars; external name '_FPC_SysAllocateThreadVars';
+procedure InitHeap; external name '_FPC_InitHeap';
 {$endif FPC_INSSIDE_SYSINIT}
 {$endif FPC_INSSIDE_SYSINIT}
 
 
 procedure Exec_Tls_callback(Handle : pointer; reason : Dword; Reserved : pointer);
 procedure Exec_Tls_callback(Handle : pointer; reason : Dword; Reserved : pointer);
@@ -68,7 +69,10 @@ procedure Exec_Tls_callback(Handle : pointer; reason : Dword; Reserved : pointer
          Exec_Tls_Callback is now part of sysinit unit for win32
          Exec_Tls_Callback is now part of sysinit unit for win32
          and the EntryInformation is a constant which sholud prevent troubles }
          and the EntryInformation is a constant which sholud prevent troubles }
        EXEC_PROCESS_ATTACH:
        EXEC_PROCESS_ATTACH:
-         InitSystemThreads;
+         begin
+           InitHeap;
+           InitSystemThreads;
+         end;
 
 
        EXEC_THREAD_ATTACH :
        EXEC_THREAD_ATTACH :
          begin
          begin

+ 6 - 4
rtl/win32/system.pp

@@ -686,8 +686,12 @@ begin
   StackBottom := StackTop - StackLength;
   StackBottom := StackTop - StackLength;
 
 
   cmdshow:=startupinfo.wshowwindow;
   cmdshow:=startupinfo.wshowwindow;
-  { Setup heap }
-  InitHeap;
+  { Setup heap and threading, these may be already initialized from TLS callback }
+  if not Assigned(CurrentTM.BeginThread) then
+  begin
+    InitHeap;
+    InitSystemThreads;
+  end;
   SysInitExceptions;
   SysInitExceptions;
   { setup fastmove stuff }
   { setup fastmove stuff }
   fpc_cpucodeinit;
   fpc_cpucodeinit;
@@ -700,8 +704,6 @@ begin
   { Reset IO Error }
   { Reset IO Error }
   InOutRes:=0;
   InOutRes:=0;
   ProcessID := GetCurrentProcessID;
   ProcessID := GetCurrentProcessID;
-  { threading }
-  InitSystemThreads;
   { Reset internal error variable }
   { Reset internal error variable }
   errno:=0;
   errno:=0;
   initvariantmanager;
   initvariantmanager;

+ 6 - 4
rtl/win64/system.pp

@@ -584,8 +584,12 @@ begin
     SysInstance:=getmodulehandle(nil);
     SysInstance:=getmodulehandle(nil);
   MainInstance:=SysInstance;
   MainInstance:=SysInstance;
   cmdshow:=startupinfo.wshowwindow;
   cmdshow:=startupinfo.wshowwindow;
-  { Setup heap }
-  InitHeap;
+  { Setup heap and threading, these may be already initialized from TLS callback }
+  if not Assigned(CurrentTM.BeginThread) then
+  begin
+    InitHeap;
+    InitSystemThreads;
+  end;  
   SysInitExceptions;
   SysInitExceptions;
   { setup fastmove stuff }
   { setup fastmove stuff }
   fpc_cpucodeinit;
   fpc_cpucodeinit;
@@ -598,8 +602,6 @@ begin
   { Reset IO Error }
   { Reset IO Error }
   InOutRes:=0;
   InOutRes:=0;
   ProcessID := GetCurrentProcessID;
   ProcessID := GetCurrentProcessID;
-  { threading }
-  InitSystemThreads;
   { Reset internal error variable }
   { Reset internal error variable }
   errno:=0;
   errno:=0;
   initvariantmanager;
   initvariantmanager;