* heap manager: handle freeing of block owned by exited thread

* heap trace: ditto

git-svn-id: trunk@7649 -

rtl/inc/heap.inc

@@ -134,8 +134,10 @@ type
   poschunk = ^toschunk;
   toschunk = record
     size : ptrint;
-    next : poschunk;
-    used : ptrint;
+    next_free : poschunk;
+    prev_any : poschunk;
+    next_any : poschunk;
+    used : ptrint;          { 0: free, >0: fixed, -1: var }
     freelists : pfreelists;
     { padding inserted automatically by alloc_oschunk }
   end;
@@ -178,8 +180,9 @@ type
   tfixedfreelists = array[1..maxblockindex] of pmemchunk_fixed;
 
   tfreelists = record
-    oslist : poschunk;
-    oscount : dword;
+    oslist : poschunk;      { os chunks free, available for use }
+    oscount : dword;        { number of os chunks on oslist }
+    oslist_all : poschunk;  { all os chunks allocated }
     fixedlists : tfixedfreelists;
     varlist : pmemchunk_var;
     { chunks waiting to be freed from other thread }
@@ -205,6 +208,8 @@ const
 var
   main_orig_freelists : pfreelists;
   main_relo_freelists : pfreelists;
+  orphaned_freelists : tfreelists;
+  orphaned_oslist_lock : trtlcriticalsection;
 threadvar
   freelists : tfreelists;
 
@@ -398,6 +403,14 @@ end;
 {$endif}
 
 
+{*****************************************************************************
+                                Forwards
+*****************************************************************************}
+
+procedure finish_waitfixedlist(loc_freelists: pfreelists); forward;
+procedure finish_waitvarlist(loc_freelists: pfreelists); forward;
+function  try_finish_waitfixedlist(loc_freelists: pfreelists): boolean; forward;
+procedure try_finish_waitvarlist(loc_freelists: pfreelists); forward;
 
 {*****************************************************************************
                                 List adding/removal
@@ -453,12 +466,19 @@ begin
     freelists.varlist := pmc^.next_var;
 end;
 
-procedure remove_all_from_list_fixed(chunksize: ptrint; poc: poschunk);
+procedure remove_freed_fixed_chunks(poc: poschunk);
+  { remove all fixed chunks from the fixed free list, as this os chunk
+    is going to be used for other purpose }
 var
   pmc, pmc_end: pmemchunk_fixed;
   fixedlist: ppmemchunk_fixed;
+  chunksize: ptrint;
 begin
+  { exit if this is a var size os chunk, function only applicable to fixed size }
+  if poc^.used < 0 then
+    exit;
   pmc := pmemchunk_fixed(pointer(poc)+fixedfirstoffset);
+  chunksize := pmc^.size and fixedsizemask;
   pmc_end := pmemchunk_fixed(pointer(poc)+(poc^.size and sizemask)-chunksize);
   fixedlist := @poc^.freelists^.fixedlists[chunksize shr blockshift];
   repeat
@@ -467,9 +487,24 @@ begin
   until pmc > pmc_end;
 end;
 
-procedure append_to_oslist(poc: poschunk; chunksize: ptrint);
+procedure free_oschunk(loc_freelists: pfreelists; poc: poschunk);
 var
   pocsize: ptrint;
+begin
+  remove_freed_fixed_chunks(poc);
+  if assigned(poc^.prev_any) then
+    poc^.prev_any^.next_any := poc^.next_any
+  else
+    loc_freelists^.oslist_all := poc^.next_any;
+  if assigned(poc^.next_any) then
+    poc^.next_any^.prev_any := poc^.prev_any;
+  pocsize := poc^.size and sizemask;
+  dec(loc_freelists^.internal_status.currheapsize, pocsize);
+  SysOSFree(poc, pocsize);
+end;
+
+procedure append_to_oslist(poc: poschunk);
+var
   loc_freelists: pfreelists;
 begin
   loc_freelists := poc^.freelists;
@@ -482,32 +517,22 @@ begin
     end;
   { decide whether to free block or add to list }
 {$ifdef HAS_SYSOSFREE}
-  pocsize := poc^.size and sizemask;
   if (loc_freelists^.oscount >= MaxKeptOSChunks) or
-     (pocsize > growheapsize2) then
+     ((poc^.size and sizemask) > growheapsize2) then
     begin
-      if chunksize <> 0 then
-        remove_all_from_list_fixed(chunksize, poc);
-      dec(loc_freelists^.internal_status.currheapsize, pocsize);
-      SysOSFree(poc, pocsize);
+      free_oschunk(loc_freelists, poc);
     end
   else
     begin
 {$endif}
-      poc^.next := loc_freelists^.oslist;
+      poc^.next_free := loc_freelists^.oslist;
       loc_freelists^.oslist := poc;
       inc(loc_freelists^.oscount);
 {$ifdef HAS_SYSOSFREE}
-   end;
+    end;
 {$endif}
 end;
 
-procedure clear_oschunk_on_freelist_fixed_flag(poc: poschunk); inline;
-  { prevent thinking this os chunk is on the fixed freelists }
-begin
-  pmemchunk_fixed(pointer(poc) + fixedfirstoffset)^.size := 0;
-end;
-
 procedure append_to_oslist_var(pmc: pmemchunk_var);
 var
   poc: poschunk;
@@ -515,8 +540,42 @@ begin
   // block eligable for freeing
   poc := pointer(pmc)-varfirstoffset;
   remove_from_list_var(pmc);
-  clear_oschunk_on_freelist_fixed_flag(poc);
-  append_to_oslist(poc, 0);
+  append_to_oslist(poc);
+end;
+
+procedure modify_oschunk_freelists(poc: poschunk; new_freelists: pfreelists);
+var
+  pmcv: pmemchunk_var;
+begin
+  poc^.freelists := new_freelists;
+  { only if oschunk contains var memchunks, we need additional assignments }
+  if poc^.used <> -1 then exit;
+  pmcv := pmemchunk_var(pointer(poc)+varfirstoffset);
+  repeat
+    pmcv^.freelists := new_freelists;
+    if (pmcv^.size and lastblockflag) <> 0 then
+      break;
+    pmcv := pmemchunk_var(pointer(pmcv)+(pmcv^.size and sizemask));
+  until false;
+end;
+
+function modify_freelists(loc_freelists, new_freelists: pfreelists): poschunk;
+var
+  poc: poschunk;
+begin
+  poc := loc_freelists^.oslist_all;
+  if assigned(poc) then
+  begin
+    repeat
+      { fixed and var freelist for orphaned freelists do not need maintenance }
+      { we assume the heap is not severely fragmented at thread exit }
+      modify_oschunk_freelists(poc, new_freelists);
+      if not assigned(poc^.next_any) then
+        exit(poc);
+      poc := poc^.next_any;
+    until false;
+  end;
+  modify_freelists := nil;
 end;
 
 {*****************************************************************************
@@ -627,29 +686,13 @@ end;
                                 Grow Heap
 *****************************************************************************}
 
-function alloc_oschunk(loc_freelists: pfreelists; chunkindex, size: ptrint): pointer;
+function find_free_oschunk(loc_freelists: pfreelists; 
+  minsize, maxsize: ptrint; var size: ptrint): poschunk;
 var
-  pmc,
-  pmc_next  : pmemchunk_fixed;
-  pmcv      : pmemchunk_var;
-  poc       : poschunk;
-  prev_poc  : poschunk;
-  minsize,
-  maxsize,
-  i         : ptrint;
-  chunksize : ptrint;
-  pocsize   : ptrint;
-  status    : pfpcheapstatus;
+  pmc: pmemchunk_fixed;
+  prev_poc, poc: poschunk;
+  pocsize: ptrint;
 begin
-  { increase size by size needed for os block header }
-  minsize := size + varfirstoffset;
-  { for fixed size chunks we keep offset from os chunk to mem chunk in
-    upper bits, so maximum os chunk size is 64K on 32bit for fixed size }
-  if chunkindex<>0 then
-    maxsize := 1 shl (32-fixedoffsetshift)
-  else
-    maxsize := high(ptrint);
-  { blocks available in freelist? }
   poc := loc_freelists^.oslist;
   prev_poc := nil;
   while poc <> nil do
@@ -658,11 +701,11 @@ begin
       begin
         { oops! we recycled this chunk; remove it from list }
         poc^.size := poc^.size and not ocrecycleflag;
-        poc := poc^.next;
+        poc := poc^.next_free;
         if prev_poc = nil then
           loc_freelists^.oslist := poc
         else
-          prev_poc^.next := poc;
+          prev_poc^.next_free := poc;
         continue;
       end;
       pocsize := poc^.size and sizemask;
@@ -671,17 +714,71 @@ begin
         begin
           size := pocsize;
           if prev_poc = nil then
-            loc_freelists^.oslist := poc^.next
+            loc_freelists^.oslist := poc^.next_free
           else
-            prev_poc^.next := poc^.next;
+            prev_poc^.next_free := poc^.next_free;
           dec(loc_freelists^.oscount);
-          pmc := pmemchunk_fixed(pointer(poc)+fixedfirstoffset);
-          if pmc^.size <> 0 then
-            remove_all_from_list_fixed(pmc^.size and fixedsizemask, poc);
+          remove_freed_fixed_chunks(poc);
           break;
         end;
       prev_poc := poc;
-      poc := poc^.next;
+      poc := poc^.next_free;
+    end;
+  result := poc;
+end;
+
+function alloc_oschunk(loc_freelists: pfreelists; chunkindex, size: ptrint): pointer;
+var
+  pmc,
+  pmc_next  : pmemchunk_fixed;
+  pmcv      : pmemchunk_var;
+  poc       : poschunk;
+  prev_poc  : poschunk;
+  minsize,
+  maxsize,
+  i         : ptrint;
+  chunksize : ptrint;
+  pocsize   : ptrint;
+  status    : pfpcheapstatus;
+begin
+  { increase size by size needed for os block header }
+  minsize := size + varfirstoffset;
+  { for fixed size chunks we keep offset from os chunk to mem chunk in
+    upper bits, so maximum os chunk size is 64K on 32bit for fixed size }
+  if chunkindex<>0 then
+    maxsize := 1 shl (32-fixedoffsetshift)
+  else
+    maxsize := high(ptrint);
+  { blocks available in freelist? }
+  poc := find_free_oschunk(loc_freelists, minsize, maxsize, size);
+  if not assigned(poc) and (assigned(orphaned_freelists.waitfixed) 
+      or assigned(orphaned_freelists.waitvar) or (orphaned_freelists.oscount > 0)) then
+    begin
+      entercriticalsection(orphaned_oslist_lock);
+      try_finish_waitfixedlist(@orphaned_freelists);
+      try_finish_waitvarlist(@orphaned_freelists);
+      if orphaned_freelists.oscount > 0 then
+        begin
+          { blocks available in orphaned freelist ? }
+          poc := find_free_oschunk(@orphaned_freelists, minsize, maxsize, size);
+          if assigned(poc) then
+            begin
+              { adopt this os chunk }
+              poc^.freelists := loc_freelists;
+              if assigned(poc^.prev_any) then
+                poc^.prev_any^.next_any := poc^.next_any
+              else
+                orphaned_freelists.oslist_all := poc^.next_any;
+              if assigned(poc^.next_any) then
+                poc^.next_any^.prev_any := poc^.prev_any;
+              poc^.next_any := loc_freelists^.oslist_all;
+              if assigned(loc_freelists^.oslist_all) then
+                loc_freelists^.oslist_all^.prev_any := poc;
+              poc^.prev_any := nil;
+              loc_freelists^.oslist_all := poc;
+            end;
+        end;
+      leavecriticalsection(orphaned_oslist_lock);
     end;
   if poc = nil then
     begin
@@ -730,10 +827,13 @@ begin
               HandleError(203);
           end;
       end;
-      { prevent thinking this os chunk is on some freelist }
-      clear_oschunk_on_freelist_fixed_flag(poc);
-      poc^.next := nil;
+      poc^.next_free := nil;
       poc^.freelists := loc_freelists;
+      poc^.prev_any := nil;
+      poc^.next_any := loc_freelists^.oslist_all;
+      if assigned(loc_freelists^.oslist_all) then
+        loc_freelists^.oslist_all^.prev_any := poc;
+      loc_freelists^.oslist_all := poc;
       { set the total new heap size }
       status := @loc_freelists^.internal_status;
       inc(status^.currheapsize, size);
@@ -741,10 +841,10 @@ begin
         status^.maxheapsize := status^.currheapsize;
     end;
   { initialize os-block }
-  poc^.used := 0;
   poc^.size := size;
   if chunkindex<>0 then
     begin
+      poc^.used := 0;
       { chop os chunk in fixedsize parts,
         maximum of $ffff elements are allowed, otherwise
         there will be an overflow }
@@ -774,6 +874,7 @@ begin
     end
   else
     begin
+      poc^.used := -1;
       { we need to align the user pointers to 8 byte at least for
         mmx/sse and doubles on sparc, align to 16 bytes }
       result := pointer(poc)+varfirstoffset;
@@ -789,9 +890,6 @@ end;
                                  SysGetMem
 *****************************************************************************}
 
-function finish_waitfixedlist(loc_freelists: pfreelists): boolean; forward;
-procedure finish_waitvarlist(loc_freelists: pfreelists); forward;
-
 function SysGetMem_Fixed(chunksize: ptrint): pointer;
 var
   pmc, pmc_next: pmemchunk_fixed;
@@ -814,7 +912,7 @@ begin
           dec(loc_freelists^.oscount);
         end;
     end
-  else if finish_waitfixedlist(loc_freelists) then
+  else if try_finish_waitfixedlist(loc_freelists) then
       { freed some to-be freed chunks, retry allocation }
     exit(SysGetMem_Fixed(chunksize))
   else
@@ -856,7 +954,7 @@ begin
   result:=nil;
   { free pending items }
   loc_freelists := @freelists;
-  finish_waitvarlist(loc_freelists);
+  try_finish_waitvarlist(loc_freelists);
   pbest := nil;
   pcurr := loc_freelists^.varlist;
   iter := high(longint);
@@ -893,7 +991,6 @@ begin
   size := split_block(pcurr, size);
   { flag block as used }
   pcurr^.size := pcurr^.size or usedflag;
-  pcurr^.freelists := loc_freelists;
   { statistics }
   with loc_freelists^.internal_status do
   begin
@@ -999,10 +1096,10 @@ begin
   if poc^.used <= 0 then
     begin
       { decrease used blocks count }
-      if poc^.used=-1 then
+      if poc^.used<0 then
         HandleError(204);
       { osblock can be freed? }
-      append_to_oslist(poc, chunksize);
+      append_to_oslist(poc);
     end;
   result := chunksize;
 end;
@@ -1064,14 +1161,11 @@ begin
     result := sysfreemem_fixed(pmc);
 end;
 
-function finish_waitfixedlist(loc_freelists: pfreelists): boolean;
+procedure finish_waitfixedlist(loc_freelists: pfreelists);
   { free to-be-freed chunks, return whether we freed anything }
 var
   pmc: pmemchunk_fixed;
 begin
-  if loc_freelists^.waitfixed = nil then 
-    exit(false);
-  entercriticalsection(loc_freelists^.lockfixed);
   while loc_freelists^.waitfixed <> nil do
   begin
     { keep next_fixed, might be destroyed }
@@ -1079,6 +1173,14 @@ begin
     loc_freelists^.waitfixed := pmc^.next_fixed;
     SysFreeMem_Fixed(pmc);
   end;
+end;
+
+function try_finish_waitfixedlist(loc_freelists: pfreelists): boolean;
+begin
+  if loc_freelists^.waitfixed = nil then 
+    exit(false);
+  entercriticalsection(loc_freelists^.lockfixed);
+  finish_waitfixedlist(loc_freelists);
   leavecriticalsection(loc_freelists^.lockfixed);
   result := true;
 end;
@@ -1088,10 +1190,6 @@ procedure finish_waitvarlist(loc_freelists: pfreelists);
 var
   pmcv: pmemchunk_var;
 begin
-  loc_freelists := @freelists;
-  if loc_freelists^.waitvar = nil then 
-    exit;
-  entercriticalsection(loc_freelists^.lockvar);
   while loc_freelists^.waitvar <> nil do
   begin
     { keep next_var, might be destroyed }
@@ -1099,6 +1197,14 @@ begin
     loc_freelists^.waitvar := pmcv^.next_var;
     SysFreeMem_Var(pmcv);
   end;
+end;
+
+procedure try_finish_waitvarlist(loc_freelists: pfreelists);
+begin
+  if loc_freelists^.waitvar = nil then 
+    exit;
+  entercriticalsection(loc_freelists^.lockvar);
+  finish_waitvarlist(loc_freelists);
   leavecriticalsection(loc_freelists^.lockvar);
 end;
 
@@ -1344,6 +1450,7 @@ begin
     not loaded yet }
   loc_freelists := @freelists;
   fillchar(loc_freelists^,sizeof(tfreelists),0);
+  fillchar(orphaned_freelists,sizeof(orphaned_freelists),0);
   { main freelist will be copied in memory }
   main_orig_freelists := loc_freelists;
 end;
@@ -1358,21 +1465,64 @@ begin
   main_relo_freelists := loc_freelists;
   initcriticalsection(loc_freelists^.lockfixed);
   initcriticalsection(loc_freelists^.lockvar);
+  initcriticalsection(orphaned_freelists.lockfixed);
+  initcriticalsection(orphaned_freelists.lockvar);
+  initcriticalsection(orphaned_oslist_lock);
+  modify_freelists(loc_freelists, main_relo_freelists);
   if MemoryManager.RelocateHeap <> nil then
     MemoryManager.RelocateHeap();
 end;
 
 procedure FinalizeHeap;
 var
-  poc : poschunk;
+  poc, poc_next: poschunk;
   i : longint;
   loc_freelists: pfreelists;
 begin
   loc_freelists := @freelists;
-  finish_waitfixedlist(loc_freelists);
-  finish_waitvarlist(loc_freelists);
   if main_relo_freelists <> nil then
   begin
+    entercriticalsection(loc_freelists^.lockfixed);
+    finish_waitfixedlist(loc_freelists);
+    entercriticalsection(loc_freelists^.lockvar);
+    finish_waitvarlist(loc_freelists);
+{$ifdef HAS_SYSOSFREE}
+  end;
+  poc := loc_freelists^.oslist;
+  while assigned(poc) do
+  begin
+    poc_next := poc^.next_free;
+    { check if this os chunk was 'recycled' i.e. taken in use again }
+    if (poc^.size and ocrecycleflag) = 0 then
+      free_oschunk(loc_freelists, poc);
+    poc := poc_next;
+  end;
+  loc_freelists^.oslist := nil;
+  loc_freelists^.oscount := 0;
+  if main_relo_freelists <> nil then
+  begin
+{$endif HAS_SYSOSFREE}
+    if main_relo_freelists = loc_freelists then
+    begin
+      donecriticalsection(orphaned_freelists.lockfixed);
+      donecriticalsection(orphaned_freelists.lockvar);
+      donecriticalsection(orphaned_oslist_lock);
+    end else begin
+      entercriticalsection(orphaned_oslist_lock);
+      entercriticalsection(orphaned_freelists.lockfixed);
+      entercriticalsection(orphaned_freelists.lockvar);
+      poc := modify_freelists(loc_freelists, @orphaned_freelists);
+      if assigned(poc) then
+      begin
+        poc^.next_any := orphaned_freelists.oslist_all;
+        if assigned(orphaned_freelists.oslist_all) then
+          orphaned_freelists.oslist_all^.prev_any := poc;
+        orphaned_freelists.oslist_all := loc_freelists^.oslist_all;
+      end;
+      leavecriticalsection(orphaned_freelists.lockvar);
+      leavecriticalsection(orphaned_freelists.lockfixed);
+      leavecriticalsection(orphaned_oslist_lock);
+    end;
     donecriticalsection(loc_freelists^.lockfixed);
     donecriticalsection(loc_freelists^.lockvar);
   end;
@@ -1388,15 +1538,6 @@ begin
   writeln('size >', sizeusagesize, ' usage ', maxsizeusage[sizeusageindex]);
   flush(output);
 {$endif}
-{$ifdef HAS_SYSOSFREE}
-  while assigned(loc_freelists^.oslist) do
-    begin
-      poc:=loc_freelists^.oslist^.next;
-      SysOSFree(loc_freelists^.oslist, loc_freelists^.oslist^.size and sizemask);
-      dec(loc_freelists^.oscount);
-      loc_freelists^.oslist:=poc;
-    end;
-{$endif HAS_SYSOSFREE}
 end;
 
 {$endif HAS_MEMORYMANAGER}

rtl/inc/heaptrc.pp

@@ -21,6 +21,7 @@ interface
 
 {$checkpointer off}
 {$goto on}
+{$typedpointer on}
 
 {$if defined(win32) or defined(wince)}
   {$define windows}
@@ -105,6 +106,7 @@ type
            end;
   end;
 
+  ppheap_mem_info = ^pheap_mem_info;
   pheap_mem_info = ^theap_mem_info;
 
   pheap_todo = ^theap_todo;
@@ -136,6 +138,24 @@ type
     extra_info      : pheap_extra_info;
   end;
 
+  pheap_info = ^theap_info;
+  theap_info = record
+{$ifdef EXTRA}
+    heap_valid_first,
+    heap_valid_last : pheap_mem_info;
+{$endif EXTRA}
+    heap_mem_root : pheap_mem_info;
+    heap_free_todo : theap_todo;
+    getmem_cnt,
+    freemem_cnt   : ptrint;
+    getmem_size,
+    freemem_size  : ptrint;
+    getmem8_size,
+    freemem8_size : ptrint;
+    error_in_heap : boolean;
+    inside_trace_getmem : boolean;
+  end;
+
 var
   useownfile : boolean;
   ownfile : text;
@@ -144,22 +164,9 @@ var
 {$endif EXTRA}
   main_orig_todolist: pheap_todo;
   main_relo_todolist: pheap_todo;
+  orphaned_info: theap_info;
 threadvar
-{$ifdef EXTRA}
-  heap_valid_first,
-  heap_valid_last : pheap_mem_info;
-{$endif EXTRA}
-  heap_mem_root : pheap_mem_info;
-  heap_free_todo : theap_todo;
-  getmem_cnt,
-  freemem_cnt   : ptrint;
-  getmem_size,
-  freemem_size   : ptrint;
-  getmem8_size,
-  freemem8_size   : ptrint;
-  error_in_heap : boolean;
-  inside_trace_getmem : boolean;
-
+  heap_info: theap_info;
 
 {*****************************************************************************
                                    Crc 32
@@ -249,6 +256,8 @@ end;
                                 Helpers
 *****************************************************************************}
 
+function InternalFreeMemSize(loc_info: pheap_info; p: pointer; pp: pheap_mem_info;
+  size: ptrint; release_orphaned_lock: boolean): ptrint; forward;
 function TraceFreeMem(p: pointer): ptrint; forward;
 
 procedure call_stack(pp : pheap_mem_info;var ptext : text);
@@ -331,13 +340,13 @@ begin
   call_stack(p,ptext);
 end;
 
-function is_in_getmem_list (p : pheap_mem_info) : boolean;
+function is_in_getmem_list (loc_info: pheap_info; p : pheap_mem_info) : boolean;
 var
   i  : ptrint;
   pp : pheap_mem_info;
 begin
   is_in_getmem_list:=false;
-  pp:=heap_mem_root;
+  pp:=loc_info^.heap_mem_root;
   i:=0;
   while pp<>nil do
    begin
@@ -355,7 +364,7 @@ begin
       is_in_getmem_list:=true;
      pp:=pp^.previous;
      inc(i);
-     if i>getmem_cnt-freemem_cnt then
+     if i>loc_info^.getmem_cnt-loc_info^.freemem_cnt then
        if useownfile then
          writeln(ownfile,'error in linked list of heap_mem_info')
        else
@@ -363,21 +372,31 @@ begin
    end;
 end;
 
-procedure finish_heap_free_todo_list;
+procedure finish_heap_free_todo_list(loc_info: pheap_info);
+var
+  bp: pointer;
+  pp: pheap_mem_info;
+  list: ppheap_mem_info;
+begin
+  list := @loc_info^.heap_free_todo.list;
+  repeat
+    pp := list^;
+    list^ := list^^.todonext;
+    bp := pointer(pp)+sizeof(theap_mem_info);
+    InternalFreeMemSize(loc_info,bp,pp,pp^.size,false);
+    //TraceFreeMem(bp);
+  until list^ = nil;
+end;
+
+procedure try_finish_heap_free_todo_list(loc_info: pheap_info);
 var
   bp: pointer;
-  loc_list: pheap_todo;
 begin
-  loc_list := @heap_free_todo;
-  if loc_list^.list <> nil then
+  if loc_info^.heap_free_todo.list <> nil then
   begin
-    entercriticalsection(loc_list^.lock);
-    repeat
-      bp := pointer(loc_list^.list)+sizeof(theap_mem_info);
-      loc_list^.list := loc_list^.list^.todonext;
-      TraceFreeMem(bp);
-    until loc_list^.list = nil;
-    leavecriticalsection(loc_list^.lock);
+    entercriticalsection(loc_info^.heap_free_todo.lock);
+    finish_heap_free_todo_list(loc_info);
+    leavecriticalsection(loc_info^.heap_free_todo.lock);
   end;
 end;
 
@@ -394,10 +413,12 @@ var
   pl : pdword;
   p  : pointer;
   pp : pheap_mem_info;
+  loc_info: pheap_info;
 begin
-  finish_heap_free_todo_list;
-  inc(getmem_size,size);
-  inc(getmem8_size,((size+7) div 8)*8);
+  loc_info := @heap_info;
+  try_finish_heap_free_todo_list(loc_info);
+  inc(loc_info^.getmem_size,size);
+  inc(loc_info^.getmem8_size,((size+7) div 8)*8);
 { Do the real GetMem, but alloc also for the info block }
 {$ifdef cpuarm}
   allocsize:=(size + 3) and not 3+sizeof(theap_mem_info)+extra_info_size;
@@ -418,7 +439,7 @@ begin
   inc(p,sizeof(theap_mem_info));
 { Create the info block }
   pp^.sig:=$DEADBEEF;
-  pp^.todolist:=@heap_free_todo;
+  pp^.todolist:=@loc_info^.heap_free_todo;
   pp^.todonext:=nil;
   pp^.size:=size;
   pp^.extra_info_size:=extra_info_size;
@@ -437,9 +458,9 @@ begin
      pp^.extra_info^.displayproc:=display_extra_info_proc;
      if assigned(fill_extra_info_proc) then
       begin
-        inside_trace_getmem:=true;
+        loc_info^.inside_trace_getmem:=true;
         fill_extra_info_proc(@pp^.extra_info^.data);
-        inside_trace_getmem:=false;
+        loc_info^.inside_trace_getmem:=false;
       end;
    end
   else
@@ -466,21 +487,21 @@ begin
        bp:=nil;
    end;
   { insert in the linked list }
-  if heap_mem_root<>nil then
-   heap_mem_root^.next:=pp;
-  pp^.previous:=heap_mem_root;
+  if loc_info^.heap_mem_root<>nil then
+   loc_info^.heap_mem_root^.next:=pp;
+  pp^.previous:=loc_info^.heap_mem_root;
   pp^.next:=nil;
 {$ifdef EXTRA}
-  pp^.prev_valid:=heap_valid_last;
-  heap_valid_last:=pp;
-  if not assigned(heap_valid_first) then
-    heap_valid_first:=pp;
+  pp^.prev_valid:=loc_info^.heap_valid_last;
+  loc_info^.heap_valid_last:=pp;
+  if not assigned(loc_info^.heap_valid_first) then
+    loc_info^.heap_valid_first:=pp;
 {$endif EXTRA}
-  heap_mem_root:=pp;
+  loc_info^.heap_mem_root:=pp;
   { must be changed before fill_extra_info is called
     because checkpointer can be called from within
     fill_extra_info PM }
-  inc(getmem_cnt);
+  inc(loc_info^.getmem_cnt);
   { update the signature }
   if usecrc then
     pp^.sig:=calculate_sig(pp);
@@ -492,60 +513,37 @@ end;
                                 TraceFreeMem
 *****************************************************************************}
 
-function TraceFreeMemSize(p:pointer;size:ptrint):ptrint;
+function CheckFreeMemSize(loc_info: pheap_info; pp: pheap_mem_info; 
+  size, ppsize: ptrint): boolean; inline;
 var
-  i,ppsize : ptrint;
+  i: ptrint;
   bp : pointer;
-  pp : pheap_mem_info;
+  ptext : ^text;
 {$ifdef EXTRA}
   pp2 : pheap_mem_info;
 {$endif}
-  extra_size : ptrint;
-  ptext : ^text;
 begin
-  if p=nil then
-    begin
-      TraceFreeMemSize:=0;
-      exit;
-    end;
-  pp:=pheap_mem_info(p-sizeof(theap_mem_info));
-  if @heap_free_todo <> pp^.todolist then
-  begin
-    if pp^.todolist = main_orig_todolist then
-      pp^.todolist := main_relo_todolist;
-    if @heap_free_todo <> pp^.todolist then
-    begin
-      entercriticalsection(pp^.todolist^.lock);
-      pp^.todonext := pp^.todolist^.list;
-      pp^.todolist^.list := pp;
-      leavecriticalsection(pp^.todolist^.lock);
-      exit(pp^.size);
-    end;
-  end;
   if useownfile then
     ptext:=@ownfile
   else
     ptext:=@stderr;
-  inc(freemem_size,size);
-  inc(freemem8_size,((size+7) div 8)*8);
-  ppsize:= size + sizeof(theap_mem_info)+pp^.extra_info_size;
-  if add_tail then
-    inc(ppsize,sizeof(ptrint));
+  inc(loc_info^.freemem_size,size);
+  inc(loc_info^.freemem8_size,((size+7) div 8)*8);
   if not quicktrace then
     begin
-      if not(is_in_getmem_list(pp)) then
+      if not(is_in_getmem_list(loc_info, pp)) then
        RunError(204);
     end;
   if (pp^.sig=$AAAAAAAA) and not usecrc then
     begin
-       error_in_heap:=true;
+       loc_info^.error_in_heap:=true;
        dump_already_free(pp,ptext^);
        if haltonerror then halt(1);
     end
   else if ((pp^.sig<>$DEADBEEF) or usecrc) and
         ((pp^.sig<>calculate_sig(pp)) or not usecrc) then
     begin
-       error_in_heap:=true;
+       loc_info^.error_in_heap:=true;
        dump_error(pp,ptext^);
 {$ifdef EXTRA}
        dump_error(pp,error_file);
@@ -556,7 +554,7 @@ begin
     end
   else if pp^.size<>size then
     begin
-       error_in_heap:=true;
+       loc_info^.error_in_heap:=true;
        dump_wrong_size(pp,size,ptext^);
 {$ifdef EXTRA}
        dump_wrong_size(pp,size,error_file);
@@ -565,8 +563,6 @@ begin
        { don't release anything in this case !! }
        exit;
     end;
-  { save old values }
-  extra_size:=pp^.extra_info_size;
   { now it is released !! }
   pp^.sig:=$AAAAAAAA;
   if not keepreleased then
@@ -575,8 +571,8 @@ begin
          pp^.next^.previous:=pp^.previous;
        if pp^.previous<>nil then
          pp^.previous^.next:=pp^.next;
-       if pp=heap_mem_root then
-         heap_mem_root:=heap_mem_root^.previous;
+       if pp=loc_info^.heap_mem_root then
+         loc_info^.heap_mem_root:=loc_info^.heap_mem_root^.previous;
     end
   else
     begin
@@ -587,48 +583,102 @@ begin
           bp:=get_caller_frame(bp);
         end;
     end;
-  inc(freemem_cnt);
-  { clear the memory }
-  fillchar(p^,size,#240); { $F0 will lead to GFP if used as pointer ! }
+  inc(loc_info^.freemem_cnt);
+  { clear the memory, $F0 will lead to GFP if used as pointer ! }
+  fillchar((pointer(pp)+sizeof(theap_mem_info))^,size,#240);
   { this way we keep all info about all released memory !! }
   if keepreleased then
     begin
 {$ifdef EXTRA}
        { We want to check if the memory was changed after release !! }
        pp^.release_sig:=calculate_release_sig(pp);
-       if pp=heap_valid_last then
+       if pp=loc_info^.heap_valid_last then
          begin
-            heap_valid_last:=pp^.prev_valid;
-            if pp=heap_valid_first then
-              heap_valid_first:=nil;
-            TraceFreememsize:=size;
-            exit;
+            loc_info^.heap_valid_last:=pp^.prev_valid;
+            if pp=loc_info^.heap_valid_first then
+              loc_info^.heap_valid_first:=nil;
+            exit(false);
          end;
-       pp2:=heap_valid_last;
+       pp2:=loc_info^.heap_valid_last;
        while assigned(pp2) do
          begin
             if pp2^.prev_valid=pp then
               begin
                  pp2^.prev_valid:=pp^.prev_valid;
-                 if pp=heap_valid_first then
-                   heap_valid_first:=pp2;
-                 TraceFreememsize:=size;
-                 exit;
+                 if pp=loc_info^.heap_valid_first then
+                   loc_info^.heap_valid_first:=pp2;
+                 exit(false);
               end
             else
               pp2:=pp2^.prev_valid;
          end;
 {$endif EXTRA}
-       TraceFreememsize:=size;
-       exit;
+       exit(false);
     end;
-   { release the normal memory at least }
-   i:=SysFreeMemSize(pp,ppsize);
-   { return the correct size }
-   dec(i,sizeof(theap_mem_info)+extra_size);
-   if add_tail then
-     dec(i,sizeof(ptrint));
-   TraceFreeMemSize:=i;
+  CheckFreeMemSize:=true;
+end;
+
+function InternalFreeMemSize(loc_info: pheap_info; p: pointer; pp: pheap_mem_info;
+  size: ptrint; release_orphaned_lock: boolean): ptrint;
+var
+  i,ppsize : ptrint;
+  bp : pointer;
+  extra_size: ptrint;
+  release_mem: boolean;
+begin
+  { save old values }
+  extra_size:=pp^.extra_info_size;
+  ppsize:= size+sizeof(theap_mem_info)+pp^.extra_info_size;
+  if add_tail then
+    inc(ppsize,sizeof(ptrint));
+  { do various checking }
+  release_mem := CheckFreeMemSize(loc_info, pp, size, ppsize);
+  if release_orphaned_lock then
+    leavecriticalsection(orphaned_info.heap_free_todo.lock);
+  if release_mem then
+  begin
+    { release the normal memory at least }
+    i:=SysFreeMemSize(pp,ppsize);
+    { return the correct size }
+    dec(i,sizeof(theap_mem_info)+extra_size);
+    if add_tail then
+      dec(i,sizeof(ptrint));
+    InternalFreeMemSize:=i;
+  end else
+    InternalFreeMemSize:=size;
+end;
+
+function TraceFreeMemSize(p:pointer;size:ptrint):ptrint;
+var
+  loc_info: pheap_info;
+  pp: pheap_mem_info;
+begin
+  if p=nil then
+    begin
+      TraceFreeMemSize:=0;
+      exit;
+    end;
+  loc_info:=@heap_info;
+  pp:=pheap_mem_info(p-sizeof(theap_mem_info));
+  if @loc_info^.heap_free_todo <> pp^.todolist then
+  begin
+    if pp^.todolist = main_orig_todolist then
+      pp^.todolist := main_relo_todolist;
+    entercriticalsection(pp^.todolist^.lock);
+    if pp^.todolist = @orphaned_info.heap_free_todo then
+    begin
+      loc_info := @orphaned_info;
+    end else 
+    if pp^.todolist <> @loc_info^.heap_free_todo then
+    begin
+      { allocated in different heap, push to that todolist }
+      pp^.todonext := pp^.todolist^.list;
+      pp^.todolist^.list := pp;
+      leavecriticalsection(pp^.todolist^.lock);
+      exit(pp^.size);
+    end;
+  end;
+  TraceFreeMemSize:=InternalFreeMemSize(loc_info,p,pp,size,loc_info = @orphaned_info);
 end;
 
 
@@ -691,6 +741,7 @@ var
   oldexactsize : ptrint;
   old_fill_extra_info_proc : tfillextrainfoproc;
   old_display_extra_info_proc : tdisplayextrainfoproc;
+  loc_info: pheap_info;
 begin
 { Free block? }
   if size=0 then
@@ -709,12 +760,13 @@ begin
      exit;
    end;
 { Resize block }
+  loc_info:=@heap_info;
   pp:=pheap_mem_info(p-sizeof(theap_mem_info));
   { test block }
   if ((pp^.sig<>$DEADBEEF) or usecrc) and
      ((pp^.sig<>calculate_sig(pp)) or not usecrc) then
    begin
-     error_in_heap:=true;
+     loc_info^.error_in_heap:=true;
      if useownfile then
        dump_error(pp,ownfile)
      else
@@ -795,10 +847,10 @@ begin
     end;
   { adjust like a freemem and then a getmem, so you get correct
     results in the summary display }
-  inc(freemem_size,oldsize);
-  inc(freemem8_size,((oldsize+7) div 8)*8);
-  inc(getmem_size,size);
-  inc(getmem8_size,((size+7) div 8)*8);
+  inc(loc_info^.freemem_size,oldsize);
+  inc(loc_info^.freemem8_size,((oldsize+7) div 8)*8);
+  inc(loc_info^.getmem_size,size);
+  inc(loc_info^.getmem8_size,((size+7) div 8)*8);
   { generate new backtrace }
   bp:=get_caller_frame(get_frame);
   for i:=1 to tracesize do
@@ -862,6 +914,7 @@ procedure CheckPointer(p : pointer); [public, alias : 'FPC_CHECKPOINTER'];
 var
   i  : ptrint;
   pp : pheap_mem_info;
+  loc_info: pheap_info;
 {$ifdef go32v2}
   get_ebp,stack_top : longword;
   data_end : longword;
@@ -877,7 +930,7 @@ begin
     runerror(204);
 
   i:=0;
-
+  loc_info:=@heap_info;
   if useownfile then
     ptext:=@ownfile
   else
@@ -953,7 +1006,7 @@ begin
   { first try valid list faster }
 
 {$ifdef EXTRA}
-  pp:=heap_valid_last;
+  pp:=loc_info^.heap_valid_last;
   while pp<>nil do
    begin
      { inside this valid block ! }
@@ -965,8 +1018,8 @@ begin
           if ((pp^.sig=$DEADBEEF) and not usecrc) or
              ((pp^.sig=calculate_sig(pp)) and usecrc) or
           { special case of the fill_extra_info call }
-             ((pp=heap_valid_last) and usecrc and (pp^.sig=$DEADBEEF)
-              and inside_trace_getmem) then
+             ((pp=loc_info^.heap_valid_last) and usecrc and (pp^.sig=$DEADBEEF)
+              and loc_info^.inside_trace_getmem) then
             goto _exit
           else
             begin
@@ -978,7 +1031,7 @@ begin
      else
        pp:=pp^.prev_valid;
      inc(i);
-     if i>getmem_cnt-freemem_cnt then
+     if i>loc_info^.getmem_cnt-loc_info^.freemem_cnt then
       begin
          writeln(ptext^,'error in linked list of heap_mem_info');
          halt(1);
@@ -986,7 +1039,7 @@ begin
    end;
   i:=0;
 {$endif EXTRA}
-  pp:=heap_mem_root;
+  pp:=loc_info^.heap_mem_root;
   while pp<>nil do
    begin
      { inside this block ! }
@@ -1004,7 +1057,7 @@ begin
          end;
      pp:=pp^.previous;
      inc(i);
-     if i>getmem_cnt then
+     if i>loc_info^.getmem_cnt then
       begin
          writeln(ptext^,'error in linked list of heap_mem_info');
          halt(1);
@@ -1027,16 +1080,21 @@ var
   ExpectedHeapFree : ptrint;
   status : TFPCHeapStatus;
   ptext : ^text;
+  loc_info: pheap_info;
 begin
+  loc_info:=@heap_info;
   if useownfile then
     ptext:=@ownfile
   else
     ptext:=@stderr;
-  pp:=heap_mem_root;
+  pp:=loc_info^.heap_mem_root;
   Writeln(ptext^,'Heap dump by heaptrc unit');
-  Writeln(ptext^,getmem_cnt, ' memory blocks allocated : ',getmem_size,'/',getmem8_size);
-  Writeln(ptext^,freemem_cnt,' memory blocks freed     : ',freemem_size,'/',freemem8_size);
-  Writeln(ptext^,getmem_cnt-freemem_cnt,' unfreed memory blocks : ',getmem_size-freemem_size);
+  Writeln(ptext^,loc_info^.getmem_cnt, ' memory blocks allocated : ',
+    loc_info^.getmem_size,'/',loc_info^.getmem8_size);
+  Writeln(ptext^,loc_info^.freemem_cnt,' memory blocks freed     : ',
+    loc_info^.freemem_size,'/',loc_info^.freemem8_size);
+  Writeln(ptext^,loc_info^.getmem_cnt-loc_info^.freemem_cnt,
+    ' unfreed memory blocks : ',loc_info^.getmem_size-loc_info^.freemem_size);
   status:=SysGetFPCHeapStatus;
   Write(ptext^,'True heap size : ',status.CurrHeapSize);
   if EntryMemUsed > 0 then
@@ -1044,11 +1102,13 @@ begin
   else
     Writeln(ptext^);
   Writeln(ptext^,'True free heap : ',status.CurrHeapFree);
-  ExpectedHeapFree:=status.CurrHeapSize-(getmem8_size-freemem8_size)-
-    (getmem_cnt-freemem_cnt)*(sizeof(theap_mem_info)+extra_info_size)-EntryMemUsed;
+  ExpectedHeapFree:=status.CurrHeapSize
+    -(loc_info^.getmem8_size-loc_info^.freemem8_size)
+    -(loc_info^.getmem_cnt-loc_info^.freemem_cnt)*(sizeof(theap_mem_info)+extra_info_size)
+    -EntryMemUsed;
   If ExpectedHeapFree<>status.CurrHeapFree then
     Writeln(ptext^,'Should be : ',ExpectedHeapFree);
-  i:=getmem_cnt-freemem_cnt;
+  i:=loc_info^.getmem_cnt-loc_info^.freemem_cnt;
   while pp<>nil do
    begin
      if i<0 then
@@ -1071,20 +1131,20 @@ begin
 {$ifdef EXTRA}
           dump_error(pp,error_file);
 {$endif EXTRA}
-          error_in_heap:=true;
+          loc_info^.error_in_heap:=true;
        end
 {$ifdef EXTRA}
      else if pp^.release_sig<>calculate_release_sig(pp) then
        begin
           dump_change_after(pp,ptext^);
           dump_change_after(pp,error_file);
-          error_in_heap:=true;
+          loc_info^.error_in_heap:=true;
        end
 {$endif EXTRA}
        ;
      pp:=pp^.previous;
    end;
-  if HaltOnNotReleased and (getmem_cnt<>freemem_cnt) then
+  if HaltOnNotReleased and (loc_info^.getmem_cnt<>loc_info^.freemem_cnt) then
     exitcode:=203;
 end;
 
@@ -1104,38 +1164,93 @@ end;
 *****************************************************************************}
 
 procedure TraceInitThread;
+var
+  loc_info: pheap_info;
 begin
+  loc_info := @heap_info;
 {$ifdef EXTRA}
-  heap_valid_first := nil;
-  heap_valid_last := nil;
+  loc_info^.heap_valid_first := nil;
+  loc_info^.heap_valid_last := nil;
 {$endif}
-  heap_mem_root := nil;
-  getmem_cnt := 0;
-  freemem_cnt := 0;
-  getmem_size := 0;
-  freemem_size := 0;
-  getmem8_size := 0;
-  freemem8_size := 0;
-  error_in_heap := false;
-  inside_trace_getmem := false;
+  loc_info^.heap_mem_root := nil;
+  loc_info^.getmem_cnt := 0;
+  loc_info^.freemem_cnt := 0;
+  loc_info^.getmem_size := 0;
+  loc_info^.freemem_size := 0;
+  loc_info^.getmem8_size := 0;
+  loc_info^.freemem8_size := 0;
+  loc_info^.error_in_heap := false;
+  loc_info^.inside_trace_getmem := false;
   EntryMemUsed := SysGetFPCHeapStatus.CurrHeapUsed;
   if main_relo_todolist <> nil then
-    initcriticalsection(heap_free_todo.lock);
+    initcriticalsection(loc_info^.heap_free_todo.lock);
 end;
 
 procedure TraceRelocateHeap;
 begin
-  main_relo_todolist := @heap_free_todo;
+  main_relo_todolist := @heap_info.heap_free_todo;
   initcriticalsection(main_relo_todolist^.lock);
+  initcriticalsection(orphaned_info.heap_free_todo.lock);
+end;
+
+procedure move_heap_info(src_info, dst_info: pheap_info);
+var
+  heap_mem: pheap_mem_info;
+begin
+  if src_info^.heap_free_todo.list <> nil then
+    finish_heap_free_todo_list(src_info);
+  if dst_info^.heap_free_todo.list <> nil then
+    finish_heap_free_todo_list(dst_info);
+  heap_mem := src_info^.heap_mem_root;
+  if heap_mem <> nil then
+  begin
+    repeat
+      heap_mem^.todolist := @dst_info^.heap_free_todo;
+      if heap_mem^.previous = nil then break;
+      heap_mem := heap_mem^.previous;
+    until false;
+    heap_mem^.previous := dst_info^.heap_mem_root;
+    if dst_info^.heap_mem_root <> nil then
+      dst_info^.heap_mem_root^.next := heap_mem;
+    dst_info^.heap_mem_root := src_info^.heap_mem_root;
+  end;
+  inc(dst_info^.getmem_cnt, src_info^.getmem_cnt);
+  inc(dst_info^.getmem_size, src_info^.getmem_size);
+  inc(dst_info^.getmem8_size, src_info^.getmem8_size);
+  inc(dst_info^.freemem_cnt, src_info^.freemem_cnt);
+  inc(dst_info^.freemem_size, src_info^.freemem_size);
+  inc(dst_info^.freemem8_size, src_info^.freemem8_size);
+  dst_info^.error_in_heap := dst_info^.error_in_heap or src_info^.error_in_heap;
+{$ifdef EXTRA}
+  if assigned(dst_info^.heap_valid_first) then
+    dst_info^.heap_valid_first^.prev_valid := src_info^.heap_valid_last
+  else
+    dst_info^.heap_valid_last := src_info^.heap_valid_last;
+  dst_info^.heap_valid_first := src_info^.heap_valid_first;
+{$endif}
 end;
 
 procedure TraceExitThread;
+var
+  loc_info: pheap_info;
+  heap_mem: pheap_mem_info;
 begin
-  finish_heap_free_todo_list;
-  if main_relo_todolist <> nil then
-    donecriticalsection(heap_free_todo.lock);
-  if not error_in_heap then
+  loc_info := @heap_info;
+  entercriticalsection(loc_info^.heap_free_todo.lock);
+  entercriticalsection(orphaned_info.heap_free_todo.lock);
+  { if not main thread exiting, move bookkeeping to orphaned heap }
+  if (@loc_info^.heap_free_todo <> main_orig_todolist) 
+    and (@loc_info^.heap_free_todo <> main_relo_todolist) then
+  begin
+    move_heap_info(loc_info, @orphaned_info);
+  end else
+  if not loc_info^.error_in_heap then
+  begin
+    move_heap_info(@orphaned_info, loc_info);
     Dumpheap;
+  end;
+  leavecriticalsection(orphaned_info.heap_free_todo.lock);
+  donecriticalsection(loc_info^.heap_free_todo.lock);
 end;
 
 function TraceGetHeapStatus:THeapStatus;
@@ -1207,7 +1322,7 @@ const
 procedure TraceInit;
 begin
   MakeCRC32Tbl;
-  main_orig_todolist := @heap_free_todo;
+  main_orig_todolist := @heap_info.heap_free_todo;
   main_relo_todolist := nil;
   TraceInitThread;
   SetMemoryManager(TraceManager);
@@ -1246,8 +1361,9 @@ begin
        exit;
     end;
   TraceExitThread;
-  if error_in_heap and (exitcode=0) then
+  if heap_info.error_in_heap and (exitcode=0) then
     exitcode:=203;
+  donecriticalsection(orphaned_info.heap_free_todo.lock);
 {$ifdef EXTRA}
   Close(error_file);
 {$endif EXTRA}