mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-23 07:32:17 +02:00
+ added support for intialising/finalising threads not started via the FPC
runtime git-svn-id: trunk@15557 -
This commit is contained in:
parent
547f082abc
commit
bfc1a6ff1c
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -9137,6 +9137,7 @@ tests/test/texception6.pp svneol=native#text/plain
|
||||
tests/test/texception7.pp svneol=native#text/plain
|
||||
tests/test/texception8.pp svneol=native#text/plain
|
||||
tests/test/texception9.pp svneol=native#text/plain
|
||||
tests/test/textthr.pp svneol=native#text/plain
|
||||
tests/test/tfillchr.pp svneol=native#text/plain
|
||||
tests/test/tfinal1.pp svneol=native#text/pascal
|
||||
tests/test/tfinal2.pp svneol=native#text/pascal
|
||||
|
@ -107,7 +107,8 @@ Type PINTRTLEvent = ^TINTRTLEvent;
|
||||
|
||||
|
||||
var
|
||||
TLSKey : pthread_key_t;
|
||||
TLSKey,
|
||||
CleanupKey : pthread_key_t;
|
||||
|
||||
procedure CInitThreadvar(var offset : dword;size : dword);
|
||||
begin
|
||||
@ -160,22 +161,54 @@ Type PINTRTLEvent = ^TINTRTLEvent;
|
||||
pthread_setspecific(tlskey,dataindex);
|
||||
end;
|
||||
|
||||
|
||||
procedure CthreadCleanup(p: pointer); cdecl;
|
||||
{$ifdef DEBUG_MT}
|
||||
var
|
||||
s: string[100]; // not an ansistring
|
||||
{$endif DEBUG_MT}
|
||||
begin
|
||||
{$ifdef DEBUG_MT}
|
||||
s := 'finishing externally started thread'#10;
|
||||
fpwrite(0,s[1],length(s));
|
||||
{$endif DEBUG_MT}
|
||||
{ clean up }
|
||||
DoneThread;
|
||||
{ the pthread routine that calls us is supposed to do this, but doesn't
|
||||
at least on Mac OS X 10.6 }
|
||||
pthread_setspecific(CleanupKey,nil);
|
||||
end;
|
||||
|
||||
|
||||
procedure HookThread;
|
||||
begin
|
||||
{ Allocate local thread vars, this must be the first thing,
|
||||
because the exception management and io depends on threadvars }
|
||||
CAllocateThreadVars;
|
||||
{ we cannot know the stack size of the current thread, so pretend it
|
||||
is really large to prevent spurious stack overflow errors }
|
||||
InitThread(1000000000);
|
||||
{ instruct the pthreads system to clean up this thread when it exits }
|
||||
pthread_setspecific(CleanupKey,pointer(1));
|
||||
end;
|
||||
|
||||
|
||||
function CRelocateThreadvar(offset : dword) : pointer;
|
||||
|
||||
var
|
||||
P : Pointer;
|
||||
|
||||
var
|
||||
P : Pointer;
|
||||
begin
|
||||
P:=pthread_getspecific(tlskey);
|
||||
{ a thread which we did not create? }
|
||||
if (P=Nil) then
|
||||
begin
|
||||
CAllocateThreadvars;
|
||||
// If this also goes wrong: bye bye threadvars...
|
||||
P:=pthread_getspecific(tlskey);
|
||||
HookThread;
|
||||
// If this also goes wrong: bye bye threadvars...
|
||||
P:=pthread_getspecific(tlskey);
|
||||
end;
|
||||
CRelocateThreadvar:=P+Offset;
|
||||
end;
|
||||
|
||||
|
||||
procedure CReleaseThreadVars;
|
||||
begin
|
||||
Fpmunmap(pointer(pthread_getspecific(tlskey)),threadvarblocksize);
|
||||
@ -276,6 +309,16 @@ Type PINTRTLEvent = ^TINTRTLEvent;
|
||||
{ We're still running in single thread mode, setup the TLS }
|
||||
pthread_key_create(@TLSKey,nil);
|
||||
InitThreadVars(@CRelocateThreadvar);
|
||||
{ used to clean up threads that we did not create ourselves:
|
||||
a) the default value for a key (and hence also this one) in
|
||||
new threads is NULL, and if it's still like that when the
|
||||
thread terminates, nothing will happen
|
||||
b) if it's non-NULL, the destructor routine will be called
|
||||
when the thread terminates
|
||||
-> we will set it to 1 if the threadvar relocation routine is
|
||||
called from a thread we did not create, so that we can
|
||||
clean up everything at the end }
|
||||
pthread_key_create(@CleanupKey,@CthreadCleanup);
|
||||
end
|
||||
end;
|
||||
{ the only way to pass data to the newly created thread
|
||||
|
86
tests/test/textthr.pp
Normal file
86
tests/test/textthr.pp
Normal file
@ -0,0 +1,86 @@
|
||||
{ %os=darwin,linux,freebsd,solaris,haiku }
|
||||
|
||||
{$mode objfpc}
|
||||
uses
|
||||
cthreads, pthreads, classes, unixtype;
|
||||
|
||||
type
|
||||
tc = class(tthread)
|
||||
procedure execute;override;
|
||||
end;
|
||||
|
||||
procedure tc.execute;
|
||||
begin
|
||||
end;
|
||||
|
||||
function threadproc(arg: pointer): pointer; cdecl;
|
||||
var
|
||||
p: pointer;
|
||||
a: ansistring;
|
||||
begin
|
||||
setlength(a,4000000);
|
||||
getmem(p,5);
|
||||
writeln('hi from thread ',ptruint(arg));
|
||||
freemem(p);
|
||||
result:=pointer(ptruint(arg)+10);
|
||||
end;
|
||||
|
||||
var
|
||||
t1, t2, t3: pthread_t;
|
||||
res: pointer;
|
||||
begin
|
||||
{ initialise threading system }
|
||||
with tc.create(false) do
|
||||
begin
|
||||
waitfor;
|
||||
free;
|
||||
end;
|
||||
if pthread_create(@t1,nil,@threadproc,pointer(1))<>0 then
|
||||
begin
|
||||
writeln('error creating 1');
|
||||
halt(1);
|
||||
end;
|
||||
if pthread_create(@t2,nil,@threadproc,pointer(2))<>0 then
|
||||
begin
|
||||
writeln('error creating 2');
|
||||
halt(1);
|
||||
end;
|
||||
if pthread_create(@t3,nil,@threadproc,pointer(3))<>0 then
|
||||
begin
|
||||
writeln('error creating 3');
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
if pthread_join(t1,@res)<>0 then
|
||||
begin
|
||||
writeln('error joining 1');
|
||||
halt(1);
|
||||
end;
|
||||
if res<>pointer(11) then
|
||||
begin
|
||||
writeln('error 1');
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
if pthread_join(t2,@res)<>0 then
|
||||
begin
|
||||
writeln('error joining 1');
|
||||
halt(1);
|
||||
end;
|
||||
if res<>pointer(12) then
|
||||
begin
|
||||
writeln('error 2');
|
||||
halt(2);
|
||||
end;
|
||||
|
||||
if pthread_join(t3,@res)<>0 then
|
||||
begin
|
||||
writeln('error joining 1');
|
||||
halt(1);
|
||||
end;
|
||||
if res<>pointer(13) then
|
||||
begin
|
||||
writeln('error 3');
|
||||
halt(3);
|
||||
end;
|
||||
end.
|
Loading…
Reference in New Issue
Block a user