+ heap manager now per thread, reduce heap lock contention

+ heap threading test

git-svn-id: trunk@7407 -

.gitattributes

@@ -6711,6 +6711,7 @@ tests/test/cg/variants/tvarol98.pp svneol=native#text/plain
 tests/test/cg/variants/tvarol99.pp svneol=native#text/plain
 tests/test/dumpclass.pp svneol=native#text/plain
 tests/test/dumpmethods.pp svneol=native#text/plain
+tests/test/heapthread.pas svneol=native#text/plain
 tests/test/opt/README -text
 tests/test/opt/tcmov.pp svneol=native#text/plain
 tests/test/opt/tcse1.pp svneol=native#text/plain

rtl/emx/systhrd.inc

@@ -149,44 +149,12 @@ procedure SysLeaveCriticalSection(var cs : TRTLCriticalSection);
 
 
 {*****************************************************************************
-                           Heap Mutex Protection
+                           Thread management
 *****************************************************************************}
 
-    var
-      HeapMutex : TRTLCriticalSection;
-
-    procedure OS2HeapMutexInit;
-      begin
-         SysInitCriticalSection(heapmutex);
-      end;
-
-    procedure OS2HeapMutexDone;
-      begin
-         SysDoneCriticalSection(heapmutex);
-      end;
-
-    procedure OS2HeapMutexLock;
-      begin
-         SysEnterCriticalSection(heapmutex);
-      end;
-
-    procedure OS2HeapMutexUnlock;
-      begin
-         SysLeaveCriticalSection(heapmutex);
-      end;
-
-    const
-      OS2MemoryMutexManager : TMemoryMutexManager = (
-        MutexInit : @OS2HeapMutexInit;
-        MutexDone : @OS2HeapMutexDone;
-        MutexLock : @OS2HeapMutexLock;
-        MutexUnlock : @OS2HeapMutexUnlock;
-      );
-
     procedure InitSystemThreads;
       begin
         SetNoThreadManager;
-        SetMemoryMutexManager(OS2MemoryMutexManager);
       end;
 
 

rtl/inc/cmem.pp

@@ -155,6 +155,9 @@ Const
       AllocMem : @CAllocMem;
       ReallocMem : @CReAllocMem;
       MemSize : @CMemSize;
+      InitThread : nil;
+      DoneThread : nil;
+      RelocateHeap : nil;
       GetHeapStatus : @CGetHeapStatus;
       GetFPCHeapStatus: @CGetFPCHeapStatus;	
     );

rtl/inc/heaph.inc

@@ -44,21 +44,16 @@ type
     AllocMem            : Function(Size:ptrint):Pointer;
     ReAllocMem          : Function(var p:pointer;Size:ptrint):Pointer;
     MemSize             : function(p:pointer):ptrint;
+    InitThread          : procedure;
+    DoneThread          : procedure;
+    RelocateHeap        : procedure;
     GetHeapStatus       : function :THeapStatus;
     GetFPCHeapStatus    : function :TFPCHeapStatus;
   end;
 
-  TMemoryMutexManager = record
-    MutexInit : procedure;
-    MutexDone : procedure;
-    MutexLock : procedure;
-    MutexUnlock : procedure;
-  end;
-
 procedure GetMemoryManager(var MemMgr: TMemoryManager);
 procedure SetMemoryManager(const MemMgr: TMemoryManager);
 function  IsMemoryManagerSet: Boolean;
-procedure SetMemoryMutexManager(var MutexMgr: TMemoryMutexManager);
 
 { Variables }
 const

rtl/inc/heaptrc.pp

@@ -91,8 +91,6 @@ const
   { function to fill this info up }
   fill_extra_info_proc : TFillExtraInfoProc = nil;
   display_extra_info_proc : TDisplayExtraInfoProc = nil;
-  error_in_heap : boolean = false;
-  inside_trace_getmem : boolean = false;
   { indicates where the output will be redirected }
   { only set using environment variables          }
   outputstr : shortstring = '';
@@ -107,16 +105,25 @@ type
            end;
   end;
 
+  pheap_mem_info = ^theap_mem_info;
+
+  pheap_todo = ^theap_todo;
+  theap_todo = record
+    lock : trtlcriticalsection;
+    list : pheap_mem_info;
+  end;
+
   { warning the size of theap_mem_info
     must be a multiple of 8
     because otherwise you will get
     problems when releasing the usual memory part !!
     sizeof(theap_mem_info = 16+tracesize*4 so
     tracesize must be even !! PM }
-  pheap_mem_info = ^theap_mem_info;
   theap_mem_info = record
     previous,
     next     : pheap_mem_info;
+    todolist : pheap_todo;
+    todonext : pheap_mem_info;
     size     : ptrint;
     sig      : longword;
 {$ifdef EXTRA}
@@ -134,16 +141,24 @@ var
   ownfile : text;
 {$ifdef EXTRA}
   error_file : text;
+{$endif EXTRA}
+  main_orig_todolist: pheap_todo;
+  main_relo_todolist: pheap_todo;
+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;
 
 
 {*****************************************************************************
@@ -234,6 +249,8 @@ end;
                                 Helpers
 *****************************************************************************}
 
+function TraceFreeMem(p: pointer): ptrint; forward;
+
 procedure call_stack(pp : pheap_mem_info;var ptext : text);
 var
   i  : ptrint;
@@ -314,7 +331,6 @@ begin
   call_stack(p,ptext);
 end;
 
-
 function is_in_getmem_list (p : pheap_mem_info) : boolean;
 var
   i  : ptrint;
@@ -347,6 +363,24 @@ begin
    end;
 end;
 
+procedure finish_heap_free_todo_list;
+var
+  bp: pointer;
+  loc_list: pheap_todo;
+begin
+  loc_list := @heap_free_todo;
+  if loc_list^.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);
+  end;
+end;
+
 
 {*****************************************************************************
                                TraceGetMem
@@ -361,6 +395,7 @@ var
   p  : pointer;
   pp : pheap_mem_info;
 begin
+  finish_heap_free_todo_list;
   inc(getmem_size,size);
   inc(getmem8_size,((size+7) div 8)*8);
 { Do the real GetMem, but alloc also for the info block }
@@ -383,6 +418,8 @@ begin
   inc(p,sizeof(theap_mem_info));
 { Create the info block }
   pp^.sig:=$DEADBEEF;
+  pp^.todolist:=@heap_free_todo;
+  pp^.todonext:=nil;
   pp^.size:=size;
   pp^.extra_info_size:=extra_info_size;
   pp^.exact_info_size:=exact_info_size;
@@ -462,18 +499,31 @@ var
   extra_size : ptrint;
   ptext : ^text;
 begin
-  if useownfile then
-    ptext:=@ownfile
-  else
-    ptext:=@stderr;
   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);
-  pp:=pheap_mem_info(p-sizeof(theap_mem_info));
   ppsize:= size + sizeof(theap_mem_info)+pp^.extra_info_size;
   if add_tail then
     inc(ppsize,sizeof(ptrint));
@@ -1045,6 +1095,36 @@ end;
                             No specific tracing calls
 *****************************************************************************}
 
+procedure TraceInitThread;
+begin
+{$ifdef EXTRA}
+  heap_valid_first := nil;
+  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;
+  EntryMemUsed := SysGetFPCHeapStatus.CurrHeapUsed;
+end;
+
+procedure TraceRelocateHeap;
+begin
+  main_relo_todolist := @heap_free_todo;
+end;
+
+procedure TraceExitThread;
+begin
+  finish_heap_free_todo_list;
+  if not error_in_heap then
+    Dumpheap;
+end;
+
 function TraceGetHeapStatus:THeapStatus;
 begin
   TraceGetHeapStatus:=SysGetHeapStatus;
@@ -1104,18 +1184,18 @@ const
     AllocMem : @TraceAllocMem;
     ReAllocMem : @TraceReAllocMem;
     MemSize : @TraceMemSize;
+    InitThread: @TraceInitThread;
+    DoneThread: @TraceExitThread;
+    RelocateHeap: @TraceRelocateHeap;
     GetHeapStatus : @TraceGetHeapStatus;
     GetFPCHeapStatus : @TraceGetFPCHeapStatus;
   );
 
-
 procedure TraceInit;
-var
-  initheapstatus : TFPCHeapStatus;
 begin
-  initheapstatus:=SysGetFPCHeapStatus;
-  EntryMemUsed:=initheapstatus.CurrHeapUsed;
   MakeCRC32Tbl;
+  main_orig_todolist := @heap_free_todo;
+  TraceInitThread;
   SetMemoryManager(TraceManager);
   useownfile:=false;
   if outputstr <> '' then
@@ -1126,7 +1206,6 @@ begin
 {$endif EXTRA}
 end;
 
-
 procedure TraceExit;
 begin
   { no dump if error
@@ -1152,8 +1231,7 @@ begin
          end;
        exit;
     end;
-  if not error_in_heap then
-    Dumpheap;
+  TraceExitThread;
   if error_in_heap and (exitcode=0) then
     exitcode:=203;
 {$ifdef EXTRA}

rtl/inc/thread.inc

@@ -24,6 +24,10 @@ Var
     procedure InitThread(stklen:SizeUInt);
       begin
         SysResetFPU;
+        { initialize this thread's heap }
+        InitHeap;
+        if MemoryManager.InitThread <> nil then
+          MemoryManager.InitThread();
         { ExceptAddrStack and ExceptObjectStack are threadvars       }
         { so every thread has its on exception handling capabilities }
         SysInitExceptions;
@@ -37,6 +41,14 @@ Var
         ThreadID := CurrentTM.GetCurrentThreadID();
       end;
 
+    procedure DoneThread;
+      begin
+        FinalizeHeap;
+        if MemoryManager.DoneThread <> nil then
+          MemoryManager.DoneThread();
+        CurrentTM.ReleaseThreadVars;
+      end;
+
 {*****************************************************************************
                             Overloaded functions
 *****************************************************************************}

rtl/inc/threadh.inc

@@ -106,6 +106,7 @@ Function SetThreadManager(Const NewTM : TThreadManager) : Boolean;
 // Needs to be exported, so the manager can call it.
 procedure InitThreadVars(RelocProc : Pointer);
 procedure InitThread(stklen:SizeUInt);
+procedure DoneThread;
 
 {*****************************************************************************
                          Multithread Handling

rtl/inc/threadvr.inc

@@ -94,6 +94,9 @@ begin
    copy_all_unit_threadvars;
    { install threadvar handler }
    fpc_threadvar_relocate_proc:=RelocProc;
+{$ifdef FPC_HAS_FEATURE_HEAP}
+   RelocateHeap;
+{$endif}
 end;
 
 

rtl/netware/systhrd.inc

@@ -121,14 +121,6 @@ type
 
 
 
-procedure DoneThread;
-
-  begin
-     { release thread vars }
-     SysReleaseThreadVars;
-  end;
-
-
 function ThreadMain(param : pointer) : dword; cdecl;
 
   var
@@ -400,46 +392,6 @@ end;
 
 
 
-{*****************************************************************************
-                           Heap Mutex Protection
-*****************************************************************************}
-
-var
-  HeapMutex : TRTLCriticalSection;
-
-procedure NWHeapMutexInit;
-begin
-  InitCriticalSection(heapmutex);
-end;
-
-procedure NWHeapMutexDone;
-begin
-  DoneCriticalSection(heapmutex);
-end;
-
-procedure NWHeapMutexLock;
-begin
-  EnterCriticalSection(heapmutex);
-end;
-
-procedure NWHeapMutexUnlock;
-begin
-  LeaveCriticalSection(heapmutex);
-end;
-
-const
-  NWMemoryMutexManager : TMemoryMutexManager = (
-           MutexInit : @NWHeapMutexInit;
-           MutexDone : @NWHeapMutexDone;
-           MutexLock : @NWHeapMutexLock;
-           MutexUnlock : @NWHeapMutexUnlock;
-  );
-
-procedure InitHeapMutexes;
-begin
-  SetMemoryMutexManager(NWMemoryMutexManager);
-end;
-
 Var
   NWThreadManager : TThreadManager;
 
@@ -475,7 +427,6 @@ begin
     basiceventWaitFor      :=@NobasiceventWaitFor;
     end;
   SetThreadManager(NWThreadManager);
-  InitHeapMutexes;
   NWSysSetThreadFunctions (@SysCloseAllRemainingSemaphores,
                            @SysReleaseThreadVars,
                            @SysSetThreadDataAreaPtr);

rtl/netwlibc/systhrd.inc

@@ -95,14 +95,6 @@
         stklen : cardinal;
       end;
 
-    procedure DoneThread;
-      begin
-        { Release Threadvars }
-        WRITE_DEBUG('DoneThread, releasing threadvars'#13#10);
-        SysReleaseThreadVars;
-      end;
-
-
     function ThreadMain(param : pointer) : pointer;cdecl;
       var
         ti : tthreadinfo;
@@ -120,6 +112,7 @@
         { Start thread function }
         WRITE_DEBUG('Jumping to thread function'#13#10);
         ThreadMain:=pointer(ti.f(ti.p));
+        WRITE_DEBUG('DoneThread, releasing threadvars'#13#10);
         DoneThread;
         //pthread_detach(pointer(pthread_self));
         pthread_exit (nil);
@@ -260,46 +253,6 @@
       end;
 
 
-{*****************************************************************************
-                           Heap Mutex Protection
-*****************************************************************************}
-
-    var
-      HeapMutex : pthread_mutex_t;
-
-    procedure PThreadHeapMutexInit;
-      begin
-         pthread_mutex_init(@heapmutex,nil);
-      end;
-
-    procedure PThreadHeapMutexDone;
-      begin
-         pthread_mutex_destroy(@heapmutex);
-      end;
-
-    procedure PThreadHeapMutexLock;
-      begin
-         pthread_mutex_lock(@heapmutex);
-      end;
-
-    procedure PThreadHeapMutexUnlock;
-      begin
-         pthread_mutex_unlock(@heapmutex);
-      end;
-
-    const
-      PThreadMemoryMutexManager : TMemoryMutexManager = (
-        MutexInit : @PThreadHeapMutexInit;
-        MutexDone : @PThreadHeapMutexDone;
-        MutexLock : @PThreadHeapMutexLock;
-        MutexUnlock : @PThreadHeapMutexUnlock;
-      );
-
-    procedure InitHeapMutexes;
-      begin
-        SetMemoryMutexManager(PThreadMemoryMutexManager);
-      end;
-
 type
      Tbasiceventstate=record
          FSem: Pointer;
@@ -426,7 +379,6 @@ begin
     BasiceventWaitFor      :=@intBasiceventWaitFor;
     end;
   SetThreadManager(NWThreadManager);
-  InitHeapMutexes;
   ThVarAllocResourceTag := AllocateResourceTag(getnlmhandle,'Threadvar Memory',AllocSignature);
   NWSysSetThreadFunctions (@SysAllocateThreadVars,
                            @SysReleaseThreadVars,

rtl/os2/systhrd.inc

@@ -154,13 +154,6 @@ end;
 *)
 
 
-    procedure DoneThread;
-      begin
-        { Release Threadvars }
-        SysReleaseThreadVars;
-      end;
-
-
     function ThreadMain(param : pointer) : pointer;cdecl;
       var
         ti : tthreadinfo;
@@ -330,53 +323,6 @@ end;
 
 
 
-{*****************************************************************************
-                           Heap Mutex Protection
-*****************************************************************************}
-
-    var
-      HeapMutex: TRTLCriticalSection;
-
-
-    procedure OS2HeapMutexInit;
-      begin
-         InitCriticalSection (HeapMutex);
-      end;
-
-
-    procedure OS2HeapMutexDone;
-      begin
-         DoneCriticalSection (HeapMutex);
-      end;
-
-
-    procedure OS2HeapMutexLock;
-      begin
-         EnterCriticalSection (HeapMutex);
-      end;
-
-
-    procedure OS2HeapMutexUnlock;
-      begin
-         LeaveCriticalSection (HeapMutex);
-      end;
-
-
-    const
-      OS2MemoryMutexManager : TMemoryMutexManager = (
-        MutexInit : @OS2HeapMutexInit;
-        MutexDone : @OS2HeapMutexDone;
-        MutexLock : @OS2HeapMutexLock;
-        MutexUnlock : @OS2HeapMutexUnlock;
-      );
-
-
-    procedure InitHeapMutexes;
-      begin
-        SetMemoryMutexManager (OS2MemoryMutexManager);
-      end;
-
-
 type
   TBasicEventState = record
                       FHandle: THandle;
@@ -523,7 +469,6 @@ begin
     RTLEventWaitFor        :=@IntRTLEventWaitFor;
     end;
   SetThreadManager (OS2ThreadManager);
-  InitHeapMutexes;
 end;
 
 

rtl/unix/cthreads.pp

@@ -173,13 +173,6 @@ Type  PINTRTLEvent = ^TINTRTLEvent;
         stklen : cardinal;
       end;
 
-    procedure DoneThread;
-      begin
-        { Release Threadvars }
-        CReleaseThreadVars;
-      end;
-
-
     function ThreadMain(param : pointer) : pointer;cdecl;
       var
         ti : tthreadinfo;
@@ -511,47 +504,6 @@ begin
 end;
 
 
-{*****************************************************************************
-                           Heap Mutex Protection
-*****************************************************************************}
-
-    var
-      HeapMutex : pthread_mutex_t;
-
-    procedure PThreadHeapMutexInit;
-      begin
-         CInitCriticalSection(heapmutex);
-      end;
-
-    procedure PThreadHeapMutexDone;
-      begin
-         CDoneCriticalSection(heapmutex);
-      end;
-
-    procedure PThreadHeapMutexLock;
-      begin
-         CEnterCriticalSection(heapmutex);
-      end;
-
-    procedure PThreadHeapMutexUnlock;
-      begin
-         CLeaveCriticalSection(heapmutex);
-      end;
-
-    const
-      PThreadMemoryMutexManager : TMemoryMutexManager = (
-        MutexInit : @PThreadHeapMutexInit;
-        MutexDone : @PThreadHeapMutexDone;
-        MutexLock : @PThreadHeapMutexLock;
-        MutexUnlock : @PThreadHeapMutexUnlock;
-      );
-
-    procedure InitHeapMutexes;
-      begin
-        SetMemoryMutexManager(PThreadMemoryMutexManager);
-      end;
-
-
 type
      TPthreadMutex = pthread_mutex_t;
      Tbasiceventstate=record
@@ -893,7 +845,6 @@ begin
     SemaphorePost          :=@cSemaphorePost;
   end;
   SetThreadManager(CThreadManager);
-  InitHeapMutexes;
 end;
 
 

rtl/win/systhrd.inc

@@ -134,13 +134,6 @@ CONST
         stklen : cardinal;
       end;
 
-    procedure DoneThread;
-      begin
-        { Release Threadvars }
-        SysReleaseThreadVars;
-      end;
-
-
     function ThreadMain(param : pointer) : Longint; {$ifdef wince}cdecl{$else}stdcall{$endif};
       var
         ti : tthreadinfo;
@@ -295,49 +288,6 @@ begin
 end;
 
 
-{*****************************************************************************
-                           Heap Mutex Protection
-*****************************************************************************}
-
-{$ifndef HAS_MT_MEMORYMANAGER}
-    var
-      HeapMutex : TRTLCriticalSection;
-
-    procedure Win32HeapMutexInit;
-      begin
-         InitCriticalSection(heapmutex);
-      end;
-
-    procedure Win32HeapMutexDone;
-      begin
-         DoneCriticalSection(heapmutex);
-      end;
-
-    procedure Win32HeapMutexLock;
-      begin
-         EnterCriticalSection(heapmutex);
-      end;
-
-    procedure Win32HeapMutexUnlock;
-      begin
-         LeaveCriticalSection(heapmutex);
-      end;
-
-    const
-      Win32MemoryMutexManager : TMemoryMutexManager = (
-        MutexInit : @Win32HeapMutexInit;
-        MutexDone : @Win32HeapMutexDone;
-        MutexLock : @Win32HeapMutexLock;
-        MutexUnlock : @Win32HeapMutexUnlock;
-      );
-
-    procedure InitHeapMutexes;
-      begin
-        SetMemoryMutexManager(Win32MemoryMutexManager);
-      end;
-      
-{$endif HAS_MT_MEMORYMANAGER}
-
 Const
         wrSignaled = 0;
         wrTimeout  = 1;
@@ -467,8 +417,5 @@ begin
     RTLEventWaitForTimeout :=@intRTLEventWaitForTimeout;
     end;
   SetThreadManager(WinThreadManager);
-{$ifndef HAS_MT_MEMORYMANAGER}
-  InitHeapMutexes;
-{$endif HAS_MT_MEMORYMANAGER}
   ThreadID := GetCurrentThreadID;
 end;

tests/test/heapthread.pas

@@ -0,0 +1,142 @@
+{$mode objfpc}{$h+}
+
+uses
+{$ifdef UNIX}
+  cthreads,
+{$endif}
+  sysutils,
+  classes;
+
+type
+  tproducethread = class(tthread)
+    procedure execute; override;
+  end;
+
+  tconsumethread = class(tthread)
+    procedure execute; override;
+  end;
+
+var
+  readindex: integer;
+  writeindex: integer;
+  fifo: array[0..1023] of pointer;
+  done: boolean;
+
+type
+  ttestarray = array[0..31] of pointer;
+
+procedure exercise_heap(var p: ttestarray; var i, j: integer);
+begin
+  if p[i] = nil then
+    p[i] := getmem(((j*11) mod 532)+8)
+  else begin
+    freemem(p[i]);
+    p[i] := nil;
+  end;
+  inc(i);
+  if i >= 32 then
+    dec(i, 32);
+  inc(j, 13);
+  if j >= 256 then
+    dec(j, 256);
+end;
+
+procedure freearray(p: ppointer; count: integer);
+var
+  i: integer;
+begin
+  for i := 0 to count-1 do
+  begin
+    freemem(p[i]);
+    p[i] := nil;
+  end;
+end;
+
+procedure producer;
+var
+  p: ttestarray;
+  i, j, k: longint;
+begin
+  filldword(p, sizeof(p) div sizeof(dword), 0);
+  i := 0;
+  j := 0;
+  k := 0;
+  while not done do
+  begin
+    if ((writeindex+1) mod 1024) <> readindex then
+    begin
+      freemem(fifo[writeindex]);
+      fifo[writeindex] := getmem(((writeindex*17) mod 520)+8);
+      writeindex := (writeindex + 1) mod 1024;
+    end else begin
+      exercise_heap(p,i,j);
+      inc(k);
+      if k = 100 then
+      begin
+        k := 0;
+        ThreadSwitch;
+      end;
+    end;
+  end;
+  freearray(p, sizeof(p) div sizeof(pointer));
+  freearray(fifo, sizeof(fifo) div sizeof(pointer));
+end;
+
+procedure consumer;
+var
+  p: ttestarray;
+  i, j, k: longint;
+begin
+  filldword(p, sizeof(p) div sizeof(dword), 0);
+  i := 0;
+  j := 0;
+  k := 0;
+  while not done do
+  begin
+    if readindex <> writeindex then
+    begin
+      freemem(fifo[readindex]);
+      fifo[readindex] := getmem(((writeindex*17) mod 520)+8);
+      readindex := (readindex + 1) mod 1024;
+    end else begin
+      exercise_heap(p,i,j);
+      inc(k);
+      if k = 100 then
+      begin
+        k := 0;
+        ThreadSwitch;
+      end;
+    end;
+  end;
+  freearray(p, sizeof(p) div sizeof(pointer));
+end;
+
+procedure tproducethread.execute;
+begin
+  producer;
+  sleep(100);
+end;
+
+procedure tconsumethread.execute;
+begin
+  consumer;
+  sleep(100);
+end;
+
+var
+  produce_thread: tproducethread;
+  consume_thread: tconsumethread;
+begin
+  done := false;
+  filldword(fifo, sizeof(fifo) div sizeof(dword), 0);
+  readindex := 0;
+  writeindex := 0;
+  produce_thread := tproducethread.create(false);
+  consume_thread := tconsumethread.create(false);
+  sleep(10000);
+  done := true;
+  produce_thread.waitfor;
+  consume_thread.waitfor;
+  produce_thread.free;
+  consume_thread.free;
+end.