mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-09-12 17:49:07 +02:00
* TCriticalSection.Tryenter support (Mantis 15928) + short test/demo
tested on FreeBSD (general Unix) and Windows. Note that Haiku seems to have a native threadmgr rather than the Unix one. Will notify maintainer (Olivier) git-svn-id: trunk@15026 -
This commit is contained in:
parent
0f9f3600c5
commit
c477df5046
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -1548,6 +1548,7 @@ packages/fcl-base/examples/b64test2.pp svneol=native#text/plain
|
||||
packages/fcl-base/examples/base64decodingtestcase.pas svneol=native#text/plain
|
||||
packages/fcl-base/examples/cachetest.pp svneol=native#text/plain
|
||||
packages/fcl-base/examples/cfgtest.pp svneol=native#text/plain
|
||||
packages/fcl-base/examples/crittest.pp svneol=native#text/plain
|
||||
packages/fcl-base/examples/daemon.pp svneol=native#text/plain
|
||||
packages/fcl-base/examples/daemon.txt svneol=native#text/plain
|
||||
packages/fcl-base/examples/dbugsrv.pp svneol=native#text/plain
|
||||
|
47
packages/fcl-base/examples/crittest.pp
Normal file
47
packages/fcl-base/examples/crittest.pp
Normal file
@ -0,0 +1,47 @@
|
||||
program crittest;
|
||||
// originally a test to test .tryenter.
|
||||
// A thread holds a lock for 5sec, while the main thread tries to lock
|
||||
// it.
|
||||
|
||||
{$mode Delphi}
|
||||
|
||||
Uses {$ifdef unix}cthreads,{$endif} syncobjs,sysutils,classes;
|
||||
|
||||
type TTestthread = class(tthread)
|
||||
procedure execute; override;
|
||||
end;
|
||||
|
||||
var crit : TCriticalSection;
|
||||
|
||||
procedure TTestThread.Execute;
|
||||
|
||||
begin
|
||||
crit.acquire;
|
||||
sleep(5000);
|
||||
crit.release;
|
||||
end;
|
||||
|
||||
|
||||
var thr : TTestthread;
|
||||
I : integer;
|
||||
|
||||
begin
|
||||
crit:=TCriticalsection.create;
|
||||
thr :=TTestthread.Create(false);
|
||||
|
||||
sleep(500); // give thread time to start.
|
||||
|
||||
writeln('tryenter');
|
||||
|
||||
i:=0;
|
||||
while not(crit.tryenter) do
|
||||
begin
|
||||
writeln('tryenter attempt ',i);
|
||||
inc(i);
|
||||
sleep(100);
|
||||
end;
|
||||
writeln('lock acquired in mainthread!');
|
||||
writeln('no payload, so releasing');
|
||||
crit.release;
|
||||
thr.waitfor;
|
||||
end.
|
@ -42,6 +42,7 @@ type
|
||||
procedure Acquire;override;
|
||||
procedure Release;override;
|
||||
procedure Enter;
|
||||
function TryEnter:boolean;
|
||||
procedure Leave;
|
||||
constructor Create;
|
||||
destructor Destroy;override;
|
||||
@ -100,6 +101,10 @@ begin
|
||||
Release;
|
||||
end;
|
||||
|
||||
function TCriticalSection.TryEnter:boolean;
|
||||
begin
|
||||
result:=TryEnterCriticalSection(CriticalSection)<>0;
|
||||
end;
|
||||
|
||||
procedure TCriticalSection.Acquire;
|
||||
|
||||
|
@ -55,6 +55,7 @@ function pthread_self:pthread_t; cdecl;external;
|
||||
function pthread_mutex_init (p:ppthread_mutex_t;o:ppthread_mutex_attr_t):cint; cdecl;external;
|
||||
function pthread_mutex_destroy (p:ppthread_mutex_attr_t):cint; cdecl;external;
|
||||
function pthread_mutex_lock (p:ppthread_mutex_attr_t):cint; cdecl;external;
|
||||
function pthread_mutex_trylock (p:ppthread_mutex_attr_t):cint; cdecl;external;
|
||||
function pthread_mutex_unlock (p:ppthread_mutex_attr_t):cint; cdecl;external;
|
||||
function pthread_cancel(_para1:pthread_t):cint;cdecl;external;
|
||||
function pthread_detach(_para1:pthread_t):cint;cdecl;external;
|
||||
|
@ -55,6 +55,7 @@ function pthread_self:pthread_t; cdecl;external;
|
||||
function pthread_mutex_init (p:ppthread_mutex_t;o:ppthread_mutex_attr_t):cint; cdecl;external;
|
||||
function pthread_mutex_destroy (p:ppthread_mutex_attr_t):cint; cdecl;external;
|
||||
function pthread_mutex_lock (p:ppthread_mutex_attr_t):cint; cdecl;external;
|
||||
function pthread_mutex_trylock (p:ppthread_mutex_attr_t):cint; cdecl;external;
|
||||
function pthread_mutex_unlock (p:ppthread_mutex_attr_t):cint; cdecl;external;
|
||||
function pthread_cancel(_para1:pthread_t):cint;cdecl;external;
|
||||
function pthread_detach(_para1:pthread_t):cint;cdecl;external;
|
||||
|
@ -196,6 +196,12 @@ begin
|
||||
CurrentTM.EnterCriticalSection(cs);
|
||||
end;
|
||||
|
||||
function TryEnterCriticalsection(var cs : TRTLCriticalSection):longint;
|
||||
|
||||
begin
|
||||
result:=CurrentTM.TryEnterCriticalSection(cs);
|
||||
end;
|
||||
|
||||
procedure LeaveCriticalsection(var cs : TRTLCriticalSection);
|
||||
|
||||
begin
|
||||
@ -389,6 +395,15 @@ begin
|
||||
ThreadingAlreadyUsed:=true;
|
||||
end;
|
||||
|
||||
function NoTryEnterCriticalSection(var CS):longint;
|
||||
|
||||
begin
|
||||
if IsMultiThread then
|
||||
NoThreadError
|
||||
else
|
||||
ThreadingAlreadyUsed:=true;
|
||||
end;
|
||||
|
||||
procedure NoInitThreadvar(var offset : dword;size : dword);
|
||||
|
||||
begin
|
||||
@ -578,6 +593,7 @@ begin
|
||||
InitCriticalSection :=@NoCriticalSection;
|
||||
DoneCriticalSection :=@NoCriticalSection;
|
||||
EnterCriticalSection :=@NoCriticalSection;
|
||||
TryEnterCriticalSection:=@NoTryEnterCriticalSection;
|
||||
LeaveCriticalSection :=@NoCriticalSection;
|
||||
InitThreadVar :=@NoInitThreadVar;
|
||||
RelocateThreadVar :=@NoRelocateThreadVar;
|
||||
|
@ -35,6 +35,7 @@ type
|
||||
TThreadGetPriorityHandler = Function (threadHandle : TThreadID): longint;
|
||||
TGetCurrentThreadIdHandler = Function : TThreadID;
|
||||
TCriticalSectionHandler = Procedure (var cs);
|
||||
TCriticalSectionHandlerTryEnter = function (var cs):longint;
|
||||
TInitThreadVarHandler = Procedure(var offset : dword;size : dword);
|
||||
TRelocateThreadVarHandler = Function(offset : dword) : pointer;
|
||||
TAllocateThreadVarsHandler = Procedure;
|
||||
@ -69,6 +70,7 @@ type
|
||||
InitCriticalSection : TCriticalSectionHandler;
|
||||
DoneCriticalSection : TCriticalSectionHandler;
|
||||
EnterCriticalSection : TCriticalSectionHandler;
|
||||
TryEnterCriticalSection: TCriticalSectionHandlerTryEnter;
|
||||
LeaveCriticalSection : TCriticalSectionHandler;
|
||||
InitThreadVar : TInitThreadVarHandler;
|
||||
RelocateThreadVar : TRelocateThreadVarHandler;
|
||||
@ -146,7 +148,7 @@ procedure InitCriticalSection(var cs : TRTLCriticalSection);
|
||||
procedure DoneCriticalsection(var cs : TRTLCriticalSection);
|
||||
procedure EnterCriticalsection(var cs : TRTLCriticalSection);
|
||||
procedure LeaveCriticalsection(var cs : TRTLCriticalSection);
|
||||
|
||||
function TryEnterCriticalsection(var cs : TRTLCriticalSection):longint;
|
||||
function BasicEventCreate(EventAttributes : Pointer; AManualReset,InitialState : Boolean;const Name : ansistring):pEventState;
|
||||
procedure basiceventdestroy(state:peventstate);
|
||||
procedure basiceventResetEvent(state:peventstate);
|
||||
|
@ -431,6 +431,14 @@ Type PINTRTLEvent = ^TINTRTLEvent;
|
||||
fpc_threaderror
|
||||
end;
|
||||
|
||||
function CTryEnterCriticalSection(var CS):longint;
|
||||
begin
|
||||
if pthread_mutex_Trylock(@CS)=0 then
|
||||
result:=1 // succes
|
||||
else
|
||||
result:=0; // failure
|
||||
end;
|
||||
|
||||
procedure CLeaveCriticalSection(var CS);
|
||||
begin
|
||||
if pthread_mutex_unlock(@CS) <> 0 then
|
||||
@ -943,6 +951,7 @@ begin
|
||||
InitCriticalSection :=@CInitCriticalSection;
|
||||
DoneCriticalSection :=@CDoneCriticalSection;
|
||||
EnterCriticalSection :=@CEnterCriticalSection;
|
||||
TryEnterCriticalSection:=@CTryEnterCriticalSection;
|
||||
LeaveCriticalSection :=@CLeaveCriticalSection;
|
||||
InitThreadVar :=@CInitThreadVar;
|
||||
RelocateThreadVar :=@CRelocateThreadVar;
|
||||
|
@ -65,6 +65,9 @@ procedure WinDoneCriticalSection(var cs : TRTLCriticalSection);
|
||||
procedure WinEnterCriticalSection(var cs : TRTLCriticalSection);
|
||||
{$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'EnterCriticalSection';
|
||||
|
||||
function WinTryEnterCriticalSection(var cs : TRTLCriticalSection):longint;
|
||||
{$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'TryEnterCriticalSection';
|
||||
|
||||
procedure WinLeaveCriticalSection(var cs : TRTLCriticalSection);
|
||||
{$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'LeaveCriticalSection';
|
||||
|
||||
@ -343,6 +346,10 @@ begin
|
||||
WinEnterCriticalSection(PRTLCriticalSection(@cs)^);
|
||||
end;
|
||||
|
||||
function SysTryEnterCriticalSection(var cs):longint;
|
||||
begin
|
||||
result:=WinTryEnterCriticalSection(PRTLCriticalSection(@cs)^);
|
||||
end;
|
||||
|
||||
procedure SySLeaveCriticalSection(var cs);
|
||||
begin
|
||||
@ -461,6 +468,7 @@ begin
|
||||
InitCriticalSection :=@SysInitCriticalSection;
|
||||
DoneCriticalSection :=@SysDoneCriticalSection;
|
||||
EnterCriticalSection :=@SysEnterCriticalSection;
|
||||
TryEnterCriticalSection:=@SysTryEnterCriticalSection;
|
||||
LeaveCriticalSection :=@SysLeaveCriticalSection;
|
||||
InitThreadVar :=@SysInitThreadVar;
|
||||
RelocateThreadVar :=@SysRelocateThreadVar;
|
||||
|
Loading…
Reference in New Issue
Block a user