Initialize the heap lock in DLL_PROCESS_ATTACH and finalize in DLL_PROCESS_DETACH.

rtl/inc/heap.inc

@@ -452,7 +452,10 @@ type
     {$endif FPC_HAS_FEATURE_THREADING}
     end;
 
-    GlobalState = record
+    GlobalState = object
+    const
+      LockInitializedProcessWide = -1; { Special lockUse value to support DLL_PROCESS_ATTACH / DLL_PROCESS_DETACH-like mechanism. }
+    var
       hugeUsed: SizeUint; { Same as non-existing “hugeAllocated” as huge chunks don’t have free space.
                             Atomic, but can be read unprotected if unreliability is tolerable.
                             Huge chunks don’t have thread affinity, so are tracked here. Presently, this value is added to all memory statistics.
@@ -461,6 +464,7 @@ type
     {$ifdef FPC_HAS_FEATURE_THREADING}
       lock: TRTLCriticalSection;
       lockUse: int32;
+      askedForProcessWideLockInitialization: boolean;
 
       { Like ThreadState.varFree but over orphaned OS chunks. Protected by gs.lock. }
       varFree: VarFreeMap;
@@ -1629,7 +1633,7 @@ type
     lastFree, nextFree: pFreeOSChunk;
   {$endif not HAS_SYSOSFREE}
   begin
-    if gs.lockUse > 0 then
+    if gs.lockUse <> 0 then
       EnterCriticalSection(HeapInc.gs.lock);
     FlushToFree; { Performing it under gs.lock guarantees there will be no new toFree requests. }
     FreeEmptyArenas; { Has to free all empty arenas, otherwise the chunk that contains only empty arenas can leak. }
@@ -1666,7 +1670,7 @@ type
       vOs := vOs^.next;
     end;
     varOS := nil;
-    if gs.lockUse > 0 then
+    if gs.lockUse <> 0 then
       LeaveCriticalSection(gs.lock);
 
 {$ifdef HAS_SYSOSFREE}
@@ -1923,15 +1927,34 @@ end;
                                  InitHeap
 *****************************************************************************}
 
+{$ifdef FPC_HAS_FEATURE_THREADING}
+{ DeferInitHeapProcessWide / DoneHeapProcessWide are meant to support DLL_PROCESS_ATTACH / DLL_PROCESS_DETACH.
+  Otherwise InitHeapThread + FinalizeHeap called per thread do their best with refcounting... }
+procedure DeferInitHeapProcessWide;
+begin
+  HeapInc.gs.askedForProcessWideLockInitialization := true; { Called before InitSystemThreads, cannot initialize the lock... }
+end;
+
+procedure DoneHeapProcessWide;
+begin
+  if HeapInc.gs.lockUse = HeapInc.gs.LockInitializedProcessWide then
+  begin
+    HeapInc.gs.lockUse := 0;
+    DoneCriticalSection(HeapInc.gs.lock);
+  end;
+end;
+
 { This function will initialize the Heap manager and need to be called from
   the initialization of the system unit }
-{$ifdef FPC_HAS_FEATURE_THREADING}
 procedure InitHeapThread;
 begin
-  if HeapInc.gs.lockUse>0 then
-    InterlockedIncrement(HeapInc.gs.lockUse);
+  if (HeapInc.gs.lockUse = 0) and HeapInc.gs.askedForProcessWideLockInitialization then
+    HeapInc.gs.lockUse := HeapInc.gs.LockInitializedProcessWide
+  else if not ((HeapInc.gs.lockUse >= 0) and ({$ifdef VER3_2} InterlockedIncrement {$else} AtomicIncrement {$endif} (HeapInc.gs.lockUse) = 1)) then
+    exit;
+  InitCriticalSection(HeapInc.gs.lock);
 end;
-{$endif}
+{$endif FPC_HAS_FEATURE_THREADING}
 
 procedure InitHeap; public name '_FPC_InitHeap';
 begin
@@ -1942,10 +1965,9 @@ end;
 procedure RelocateHeap;
 begin
 {$ifdef FPC_HAS_FEATURE_THREADING}
-  if HeapInc.gs.lockUse > 0 then
+  if HeapInc.gs.lockUse <> 0 then
     exit;
-  HeapInc.gs.lockUse := 1;
-  InitCriticalSection(HeapInc.gs.lock);
+  InitHeapThread; { Initializes the lock and sets lockUse = 1 (or maybe LockInitializedProcessWide). }
 {$ifndef FPC_SECTION_THREADVARS}
   { threadState pointers still point to main thread's thisTs, but they
     have a reference to the global main thisTs, fix them to point

rtl/inc/heaph.inc

@@ -99,5 +99,9 @@ function ReAllocMem(var p:pointer;Size:ptruint):pointer; inline;
 function ReAllocMemory(p:pointer;Size:ptruint):pointer; cdecl;
 function GetHeapStatus:THeapStatus;
 function GetFPCHeapStatus:TFPCHeapStatus;
-{$endif FPC_HAS_FEATURE_HEAP}
 
+{$if defined(FPC_HAS_FEATURE_THREADING) and not defined(FPC_NO_DEFAULT_HEAP) and not defined(LEGACYHEAP)}
+procedure DeferInitHeapProcessWide; inline; { for Windows sysinit.pp... }
+procedure DoneHeapProcessWide; inline;
+{$endif FPC_HAS_FEATURE_THREADING and not FPC_NO_DEFAULT_HEAP and not LEGACYHEAP}
+{$endif FPC_HAS_FEATURE_HEAP}

rtl/inc/oldheap.inc

@@ -1578,12 +1578,11 @@ procedure InitHeapThread;
 var
   loc_freelists: pfreelists;
 begin
-  if heap_lock_use > 0 then
-  begin
-    EnterCriticalSection(heap_lock);
-    inc(heap_lock_use);
-    LeaveCriticalSection(heap_lock);
-  end;
+  if heap_lock_use = 0 then
+    InitCriticalSection(heap_lock);
+  EnterCriticalSection(heap_lock);
+  inc(heap_lock_use);
+  LeaveCriticalSection(heap_lock);
   loc_freelists := @freelists;
   fillchar(loc_freelists^,sizeof(tfreelists),0);
   { initialise the local blocksize for allocating oschunks for fixed
@@ -1600,17 +1599,12 @@ procedure InitHeap; public name '_FPC_InitHeap';
 var
   loc_freelists: pfreelists;
 begin
-{$ifdef FPC_HAS_FEATURE_THREADING}
   { we cannot initialize the locks here yet, thread support is
     not loaded yet }
-  heap_lock_use := 0;
-{$endif}
   loc_freelists := @freelists;
-  fillchar(loc_freelists^,sizeof(tfreelists),0);
   { initialise the local blocksize for allocating oschunks for fixed
     freelists with the default starting value }
   loc_freelists^.locgrowheapsizesmall:=growheapsizesmall;
-  fillchar(orphaned_freelists,sizeof(orphaned_freelists),0);
 end;
 
 procedure RelocateHeap;

rtl/win/systlsdir.inc

@@ -84,9 +84,17 @@ procedure Exec_Tls_callback(Handle : pointer; reason : Dword; Reserved : pointer
            SetupEntryInformation(SysInitEntryInformation);
            {$endif FPC_HAS_INDIRECT_ENTRY_INFORMATION}
            InitHeap;
+         {$ifndef LEGACYHEAP}
+           DeferInitHeapProcessWide;
+         {$endif ndef LEGACYHEAP}
            InitSystemThreads;
          end;
-
+       DLL_PROCESS_DETACH :
+         begin
+         {$ifndef LEGACYHEAP}
+           DoneHeapProcessWide;
+         {$endif ndef LEGACYHEAP}
+         end;
        DLL_THREAD_ATTACH :
          begin
          {  !!! SysInitMultithreading must NOT be called here. Windows guarantees that

rtl/win/syswin.inc

@@ -408,6 +408,9 @@ function Dll_entry{$ifdef FPC_HAS_INDIRECT_ENTRY_INFORMATION}(constref info : TE
 {$ifdef FPC_USE_SEH}
                try
 {$endif}
+{$ifndef LEGACYHEAP}
+               DeferInitHeapProcessWide;
+{$endif ndef LEGACYHEAP}
 {$ifdef FPC_HAS_INDIRECT_ENTRY_INFORMATION}
                EntryInformation.PascalMain();
 {$else FPC_HAS_INDIRECT_ENTRY_INFORMATION}
@@ -460,6 +463,9 @@ function Dll_entry{$ifdef FPC_HAS_INDIRECT_ENTRY_INFORMATION}(constref info : TE
            SysReleaseThreadVars;
            { Free TLS resources used by ThreadVars }
            SysFiniMultiThreading;
+{$ifndef LEGACYHEAP}
+           DoneHeapProcessWide;
+{$endif ndef LEGACYHEAP}
            MainThreadIDWin32:=0;
          end;
      end;