paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 14:29:14 +02:00
Code Issues Packages Projects Releases Wiki Activity

amicommon/AThreads: use shared semaphores locks where possible for read-only access; preparations to be built in the RTL; code cleanups

Browse Source 
git-svn-id: trunk@30924 -
This commit is contained in:
Károly Balogh 2015-05-28 01:10:38 +00:00
parent 6afcca7cd3
commit b4ce380cd4
1 changed files with 28 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
rtl/amicommon/athreads.pp
View File

@ -19,18 +19,25 @@ unit athreads;
interface interface
{$WARNING These should be in the system unit }
{ some BeginThread flags we support }
const
CREATE_SUSPENDED = 1;
STACK_SIZE_PARAM_IS_A_RESERVATION = 2;
procedure SetAThreadBaseName(s: String); procedure SetAThreadBaseName(s: String);
implementation implementation
{ enable this to compile athreads easily outside the RTL }
{.$DEFINE ATHREADS_STANDALONE}
{$IFDEF ATHREADS_STANDALONE}
uses uses
exec, amigados, utility; exec, amigados, utility;
{$ELSE}
{ * Include sytem specific includes * }
{$include execd.inc}
{$include execf.inc}
{$include timerd.inc}
{$include doslibd.inc}
{$include doslibf.inc}
{$ENDIF}
const const
threadvarblocksize : dword = 0; threadvarblocksize : dword = 0;
@ -195,7 +202,7 @@ begin
if l = nil then if l = nil then
exit; exit;
ObtainSemaphore(@AThreadListSemaphore); ObtainSemaphoreShared(@AThreadListSemaphore);
p:=l; p:=l;
while (p <> nil) and (p^.threadID <> threadID) do while (p <> nil) and (p^.threadID <> threadID) do
p:=p^.nextThread; p:=p^.nextThread;
@ -209,7 +216,7 @@ var
p: PThreadInfo; p: PThreadInfo;
begin begin
CountRunningThreads:=0; CountRunningThreads:=0;
ObtainSemaphore(@AThreadListSemaphore); ObtainSemaphoreShared(@AThreadListSemaphore);
p:=l; p:=l;
while p <> nil do while p <> nil do
begin begin
@ -255,7 +262,7 @@ end;
function GetAThreadBaseName: String; function GetAThreadBaseName: String;
begin begin
ObtainSemaphore(@AThreadListSemaphore); ObtainSemaphoreShared(@AThreadListSemaphore);
GetAThreadBaseName:=SubThreadBaseName; GetAThreadBaseName:=SubThreadBaseName;
ReleaseSemaphore(@AThreadListSemaphore); ReleaseSemaphore(@AThreadListSemaphore);
end; end;
@ -383,11 +390,6 @@ begin
end; end;
{$IFDEF DEBUG_MT}
{$PUSH}
{ Because the string concat in SysDebugLn causes exception frames }
{$IMPLICITEXCEPTIONS OFF}
{$ENDIF}
procedure ThreadFunc; cdecl; procedure ThreadFunc; cdecl;
var var
thisThread: PProcess; thisThread: PProcess;
@ -472,18 +474,11 @@ begin
threadInfo^.exited:=true; threadInfo^.exited:=true;
PutMsg(threadInfo^.replyPort,threadInfo^.replyMsg); PutMsg(threadInfo^.replyPort,threadInfo^.replyMsg);
end; end;
{$IFDEF DEBUG_MT}
{$POP} { reset implicitexceptions state }
{$ENDIF}
function CreateNewProc(Tags : Array Of PtrUInt) : PProcess; function CreateNewProcess(const Tags : Array Of PtrUInt) : PProcess;
begin begin
{$IFDEF AROS} result:=CreateNewProc(@Tags[0]);
CreateNewProc:=AmigaDOS.CreateNewProc(@Tags[0]);
{$ELSE}
CreateNewProc:=CreateNewProcTagList(@Tags);
{$ENDIF}
end; end;
function ABeginThread(sa : Pointer;stacksize : PtrUInt; function ABeginThread(sa : Pointer;stacksize : PtrUInt;
@ -519,15 +514,14 @@ begin
{$ifdef DEBUG_MT} {$ifdef DEBUG_MT}
SysDebugLn('FPC AThreads: Starting new thread... Stack size: '+IToStr(threadInfo^.stackLen)); SysDebugLn('FPC AThreads: Starting new thread... Stack size: '+IToStr(threadInfo^.stackLen));
{$endif} {$endif}
subThread:=CreateNewProc([ subThread:=CreateNewProcess([NP_Entry,PtrUInt(@ThreadFunc),
{$IFDEF MORPHOS} {$IFDEF MORPHOS}
NP_CodeType,CODETYPE_PPC, NP_CodeType,CODETYPE_PPC,
NP_PPCStackSize, threadInfo^.stacklen, NP_PPCStackSize,threadInfo^.stacklen,
{$ELSE} {$ELSE}
NP_StackSize, threadInfo^.stacklen, NP_StackSize,threadInfo^.stacklen,
{$ENDIF} {$ENDIF}
NP_Entry,PtrUInt(@ThreadFunc), TAG_DONE]);
TAG_DONE]);
if subThread = nil then if subThread = nil then
begin begin
{$ifdef DEBUG_MT} {$ifdef DEBUG_MT}
@ -927,7 +921,7 @@ begin
running in the background... So even waiting here forever is better than running in the background... So even waiting here forever is better than
exiting with active threads, which will most likely just kill the OS exiting with active threads, which will most likely just kill the OS
immediately. (KB) } immediately. (KB) }
ObtainSemaphore(@AThreadListSemaphore); ObtainSemaphoreShared(@AThreadListSemaphore);
{$IFDEF DEBUG_MT} {$IFDEF DEBUG_MT}
if AThreadListLen > 1 then if AThreadListLen > 1 then
@ -943,7 +937,7 @@ begin
ReleaseSemaphore(@AThreadListSemaphore); ReleaseSemaphore(@AThreadListSemaphore);
DOSDelay(1); DOSDelay(1);
{ Reobtain the semaphore... } { Reobtain the semaphore... }
ObtainSemaphore(@AThreadListSemaphore); ObtainSemaphoreShared(@AThreadListSemaphore);
end; end;
{$IFDEF DEBUG_MT} {$IFDEF DEBUG_MT}