mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-06 09:07:59 +02:00
+ heap manager now per thread, reduce heap lock contention
+ heap threading test git-svn-id: trunk@7407 -
This commit is contained in:
micha
parent
5cf2511283
commit
7f2a257102
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
|
||||
@ -155,6 +155,9 @@ Const
|
||||
AllocMem : @CAllocMem;
|
||||
ReallocMem : @CReAllocMem;
|
||||
MemSize : @CMemSize;
|
||||
InitThread : nil;
|
||||
DoneThread : nil;
|
||||
RelocateHeap : nil;
|
||||
GetHeapStatus : @CGetHeapStatus;
|
||||
GetFPCHeapStatus: @CGetFPCHeapStatus;
|
||||
);
|
||||
|
||||
619
rtl/inc/heap.inc
619
rtl/inc/heap.inc
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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
|
||||
*****************************************************************************}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
|
||||
@ -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);
|
||||
|
||||
@ -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,
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
|
||||
@ -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;
|
||||
|
||||
142
tests/test/heapthread.pas
Normal file
142
tests/test/heapthread.pas
Normal file
@ -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.
|
||||
Loading…
Reference in New Issue
Block a user