paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-11 16:50:11 +02:00
Code Issues Packages Projects Releases Wiki Activity

haiku: zapped the old bethreads unit. it's apparently just an ancient version of cthreads, and haiku seems to use cthreads itself since day one.

Browse Source 
git-svn-id: trunk@40826 -
This commit is contained in:
Károly Balogh 2019-01-10 04:20:04 +00:00
parent 8b424b0867
commit 93ee468fcb
2 changed files with 0 additions and 520 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -9403,7 +9403,6 @@ rtl/go32v2/v2prt0.as svneol=native#text/plain
rtl/haiku/Makefile svneol=native#text/plain
rtl/haiku/Makefile.fpc svneol=native#text/plain
rtl/haiku/baseunix.pp svneol=native#text/plain
rtl/haiku/bethreads.pp svneol=native#text/plain
rtl/haiku/classes.pp svneol=native#text/plain
rtl/haiku/errno.inc svneol=native#text/plain
rtl/haiku/errnostr.inc svneol=native#text/plain

519
rtl/haiku/bethreads.pp
View File

@ -1,519 +0,0 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2002 by Peter Vreman,
member of the Free Pascal development team.
BeOS (bethreads) threading support implementation
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$mode objfpc}
unit bethreads;
interface
{$S-}
Procedure SetBeThreadManager;
implementation
Uses
systhrds,
BaseUnix,
unix,
unixtype,
sysutils;
{*****************************************************************************
Generic overloaded
*****************************************************************************}
{ Include OS specific parts. }
{*****************************************************************************
Threadvar support
*****************************************************************************}
{$ifdef HASTHREADVAR}
const
threadvarblocksize : dword = 0;
var
TLSKey : pthread_key_t;
procedure BeInitThreadvar(var offset : dword;size : dword);
begin
offset:=threadvarblocksize;
inc(threadvarblocksize,size);
end;
function BeRelocateThreadvar(offset : dword) : pointer;
begin
BeRelocateThreadvar:=pthread_getspecific(tlskey)+Offset;
end;
procedure BeAllocateThreadVars;
var
dataindex : pointer;
begin
{ we've to allocate the memory from system }
{ because the FPC heap management uses }
{ exceptions which use threadvars but }
{ these aren't allocated yet ... }
{ allocate room on the heap for the thread vars }
DataIndex:=Pointer(Fpmmap(nil,threadvarblocksize,3,MAP_PRIVATE+MAP_ANONYMOUS,-1,0));
FillChar(DataIndex^,threadvarblocksize,0);
pthread_setspecific(tlskey,dataindex);
end;
procedure BeReleaseThreadVars;
begin
{$ifdef ver1_0}
Fpmunmap(longint(pthread_getspecific(tlskey)),threadvarblocksize);
{$else}
Fpmunmap(pointer(pthread_getspecific(tlskey)),threadvarblocksize);
{$endif}
end;
{ Include OS independent Threadvar initialization }
{$endif HASTHREADVAR}
{*****************************************************************************
Thread starting
*****************************************************************************}
type
pthreadinfo = ^tthreadinfo;
tthreadinfo = record
f : tthreadfunc;
p : pointer;
stklen : cardinal;
end;
procedure DoneThread;
begin
{ Release Threadvars }
{$ifdef HASTHREADVAR}
CReleaseThreadVars;
{$endif HASTHREADVAR}
end;
function ThreadMain(param : pointer) : pointer;cdecl;
var
ti : tthreadinfo;
{$ifdef DEBUG_MT}
// in here, don't use write/writeln before having called
// InitThread! I wonder if anyone ever debugged these routines,
// because they will have crashed if DEBUG_MT was enabled!
// this took me the good part of an hour to figure out
// why it was crashing all the time!
// this is kind of a workaround, we simply write(2) to fd 0
s: string[100]; // not an ansistring
{$endif DEBUG_MT}
begin
{$ifdef DEBUG_MT}
s := 'New thread started, initing threadvars'#10;
fpwrite(0,s[1],length(s));
{$endif DEBUG_MT}
{$ifdef HASTHREADVAR}
{ Allocate local thread vars, this must be the first thing,
because the exception management and io depends on threadvars }
CAllocateThreadVars;
{$endif HASTHREADVAR}
{ Copy parameter to local data }
{$ifdef DEBUG_MT}
s := 'New thread started, initialising ...'#10;
fpwrite(0,s[1],length(s));
{$endif DEBUG_MT}
ti:=pthreadinfo(param)^;
dispose(pthreadinfo(param));
{ Initialize thread }
InitThread(ti.stklen);
{ Start thread function }
{$ifdef DEBUG_MT}
writeln('Jumping to thread function');
{$endif DEBUG_MT}
ThreadMain:=pointer(ti.f(ti.p));
DoneThread;
pthread_detach(pthread_t(pthread_self()));
end;
function BeBeginThread(sa : Pointer;stacksize : dword;
ThreadFunction : tthreadfunc;p : pointer;
creationFlags : dword; var ThreadId : THandle) : DWord;
var
ti : pthreadinfo;
thread_attr : pthread_attr_t;
begin
{$ifdef DEBUG_MT}
writeln('Creating new thread');
{$endif DEBUG_MT}
{ Initialize multithreading if not done }
if not IsMultiThread then
begin
{$ifdef HASTHREADVAR}
{ We're still running in single thread mode, setup the TLS }
pthread_key_create(@TLSKey,nil);
InitThreadVars(@CRelocateThreadvar);
{$endif HASTHREADVAR}
IsMultiThread:=true;
end;
{ the only way to pass data to the newly created thread
in a MT safe way, is to use the heap }
new(ti);
ti^.f:=ThreadFunction;
ti^.p:=p;
ti^.stklen:=stacksize;
{ call pthread_create }
{$ifdef DEBUG_MT}
writeln('Starting new thread');
{$endif DEBUG_MT}
pthread_attr_init(@thread_attr);
pthread_attr_setinheritsched(@thread_attr, PTHREAD_EXPLICIT_SCHED);
// will fail under linux -- apparently unimplemented
pthread_attr_setscope(@thread_attr, PTHREAD_SCOPE_PROCESS);
// don't create detached, we need to be able to join (waitfor) on
// the newly created thread!
//pthread_attr_setdetachstate(@thread_attr, PTHREAD_CREATE_DETACHED);
if pthread_create(@threadid, @thread_attr, @ThreadMain,ti) <> 0 then begin
threadid := 0;
end;
BeBeginThread:=threadid;
{$ifdef DEBUG_MT}
writeln('BeginThread returning ',BeBeginThread);
{$endif DEBUG_MT}
end;
procedure BeEndThread(ExitCode : DWord);
begin
DoneThread;
pthread_detach(pthread_t(pthread_self()));
pthread_exit(pointer(ExitCode));
end;
{$warning threadhandle can be larger than a dword}
function BeSuspendThread (threadHandle : dword) : dword;
begin
{$Warning SuspendThread needs to be implemented}
end;
{$warning threadhandle can be larger than a dword}
function BeResumeThread (threadHandle : dword) : dword;
begin
{$Warning ResumeThread needs to be implemented}
end;
procedure CThreadSwitch; {give time to other threads}
begin
{extern int pthread_yield (void) __THROW;}
{$Warning ThreadSwitch needs to be implemented}
end;
{$warning threadhandle can be larger than a dword}
function BeKillThread (threadHandle : dword) : dword;
begin
pthread_detach(pthread_t(threadHandle));
CKillThread := pthread_cancel(pthread_t(threadHandle));
end;
{$warning threadhandle can be larger than a dword}
function BeWaitForThreadTerminate (threadHandle : dword; TimeoutMs : longint) : dword; {0=no timeout}
var
LResultP: Pointer;
LResult: DWord;
begin
LResult := 0;
LResultP := @LResult;
pthread_join(pthread_t(threadHandle), @LResultP);
CWaitForThreadTerminate := LResult;
end;
{$warning threadhandle can be larger than a dword}
function BeThreadSetPriority (threadHandle : dword; Prio: longint): boolean; {-15..+15, 0=normal}
begin
{$Warning ThreadSetPriority needs to be implemented}
end;
{$warning threadhandle can be larger than a dword}
function BeThreadGetPriority (threadHandle : dword): Integer;
begin
{$Warning ThreadGetPriority needs to be implemented}
end;
{$warning threadhandle can be larger than a dword}
function BeGetCurrentThreadId : dword;
begin
CGetCurrentThreadId:=dword(pthread_self());
end;
{*****************************************************************************
Delphi/Win32 compatibility
*****************************************************************************}
procedure BeInitCriticalSection(var CS);
var
MAttr : pthread_mutexattr_t;
res: longint;
begin
res:=pthread_mutexattr_init(@MAttr);
if res=0 then
begin
res:=pthread_mutexattr_settype(@MAttr,longint(_PTHREAD_MUTEX_RECURSIVE));
if res=0 then
res := pthread_mutex_init(@CS,@MAttr)
else
{ No recursive mutex support :/ }
res := pthread_mutex_init(@CS,NIL);
end
else
res:= pthread_mutex_init(@CS,NIL);
pthread_mutexattr_destroy(@MAttr);
if res <> 0 then
runerror(6);
end;
procedure BeEnterCriticalSection(var CS);
begin
if pthread_mutex_lock(@CS) <> 0 then
runerror(6);
end;
procedure BeLeaveCriticalSection(var CS);
begin
if pthread_mutex_unlock(@CS) <> 0 then
runerror(6)
end;
procedure BeDoneCriticalSection(var CS);
begin
if pthread_mutex_destroy(@CS) <> 0 then
runerror(6);
end;
{*****************************************************************************
Heap Mutex Protection
*****************************************************************************}
var
HeapMutex : pthread_mutex_t;
procedure BeThreadHeapMutexInit;
begin
pthread_mutex_init(@heapmutex,nil);
end;
procedure BeThreadHeapMutexDone;
begin
pthread_mutex_destroy(@heapmutex);
end;
procedure BeThreadHeapMutexLock;
begin
pthread_mutex_lock(@heapmutex);
end;
procedure BeThreadHeapMutexUnlock;
begin
pthread_mutex_unlock(@heapmutex);
end;
const
BeThreadMemoryMutexManager : TMemoryMutexManager = (
MutexInit : @BeThreadHeapMutexInit;
MutexDone : @BeThreadHeapMutexDone;
MutexLock : @BeThreadHeapMutexLock;
MutexUnlock : @BeThreadHeapMutexUnlock;
);
procedure InitHeapMutexes;
begin
SetMemoryMutexManager(BeThreadMemoryMutexManager);
end;
Function BeInitThreads : Boolean;
begin
{$ifdef DEBUG_MT}
Writeln('Entering InitThreads.');
{$endif}
{$ifndef dynpthreads}
Result:=True;
{$else}
Result:=LoadPthreads;
{$endif}
ThreadID := SizeUInt (pthread_self);
{$ifdef DEBUG_MT}
Writeln('InitThreads : ',Result);
{$endif DEBUG_MT}
end;
Function BeDoneThreads : Boolean;
begin
{$ifndef dynpthreads}
Result:=True;
{$else}
Result:=UnloadPthreads;
{$endif}
end;
type
TPthreadMutex = pthread_mutex_t;
Tbasiceventstate=record
FSem: Pointer;
FManualReset: Boolean;
FEventSection: TPthreadMutex;
end;
plocaleventstate = ^tbasiceventstate;
// peventstate=pointer;
Const
wrSignaled = 0;
wrTimeout = 1;
wrAbandoned= 2;
wrError = 3;
function IntBasicEventCreate(EventAttributes : Pointer; AManualReset,InitialState : Boolean;const Name : ansistring):pEventState;
var
MAttr : pthread_mutexattr_t;
res : cint;
begin
new(plocaleventstate(result));
plocaleventstate(result)^.FManualReset:=AManualReset;
plocaleventstate(result)^.FSem:=New(PSemaphore); //sem_t.
// plocaleventstate(result)^.feventsection:=nil;
res:=pthread_mutexattr_init(@MAttr);
if res=0 then
begin
res:=pthread_mutexattr_settype(@MAttr,longint(_PTHREAD_MUTEX_RECURSIVE));
if Res=0 then
Res:=pthread_mutex_init(@plocaleventstate(result)^.feventsection,@MAttr)
else
res:=pthread_mutex_init(@plocaleventstate(result)^.feventsection,nil);
end
else
res:=pthread_mutex_init(@plocaleventstate(result)^.feventsection,nil);
pthread_mutexattr_destroy(@MAttr);
if res <> 0 then
runerror(6);
if sem_init(psem_t(plocaleventstate(result)^.FSem),ord(False),Ord(InitialState)) <> 0 then
runerror(6);
end;
procedure Intbasiceventdestroy(state:peventstate);
begin
sem_destroy(psem_t( plocaleventstate(state)^.FSem));
end;
procedure IntbasiceventResetEvent(state:peventstate);
begin
While sem_trywait(psem_t( plocaleventstate(state)^.FSem))=0 do
;
end;
procedure IntbasiceventSetEvent(state:peventstate);
Var
Value : Longint;
begin
pthread_mutex_lock(@plocaleventstate(state)^.feventsection);
Try
sem_getvalue(plocaleventstate(state)^.FSem,@value);
if Value=0 then
sem_post(psem_t( plocaleventstate(state)^.FSem));
finally
pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
end;
end;
function IntbasiceventWaitFor(Timeout : Cardinal;state:peventstate) : longint;
begin
If TimeOut<>Cardinal($FFFFFFFF) then
result:=wrError
else
begin
sem_wait(psem_t(plocaleventstate(state)^.FSem));
result:=wrSignaled;
if plocaleventstate(state)^.FManualReset then
begin
pthread_mutex_lock(@plocaleventstate(state)^.feventsection);
Try
intbasiceventresetevent(State);
sem_post(psem_t( plocaleventstate(state)^.FSem));
Finally
pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
end;
end;
end;
end;
Var
BeThreadManager : TThreadManager;
Procedure SetBeThreadManager;
begin
With BeThreadManager do
begin
InitManager :=@BeInitThreads;
DoneManager :=@BeDoneThreads;
BeginThread :=@BeBeginThread;
EndThread :=@BeEndThread;
SuspendThread :=@BeSuspendThread;
ResumeThread :=@BeResumeThread;
KillThread :=@BeKillThread;
ThreadSwitch :=@BeThreadSwitch;
WaitForThreadTerminate :=@BeWaitForThreadTerminate;
ThreadSetPriority :=@BeThreadSetPriority;
ThreadGetPriority :=@BeThreadGetPriority;
GetCurrentThreadId :=@BeGetCurrentThreadId;
InitCriticalSection :=@BeInitCriticalSection;
DoneCriticalSection :=@BeDoneCriticalSection;
EnterCriticalSection :=@BeEnterCriticalSection;
LeaveCriticalSection :=@BeLeaveCriticalSection;
{$ifdef hasthreadvar}
InitThreadVar :=@BeInitThreadVar;
RelocateThreadVar :=@BeRelocateThreadVar;
AllocateThreadVars :=@BeAllocateThreadVars;
ReleaseThreadVars :=@BeReleaseThreadVars;
{$endif}
BasicEventCreate :=@intBasicEventCreate;
BasicEventDestroy :=@intBasicEventDestroy;
BasicEventResetEvent :=@intBasicEventResetEvent;
BasicEventSetEvent :=@intBasicEventSetEvent;
BasiceventWaitFor :=@intBasiceventWaitFor;
end;
SetThreadManager(BeThreadManager);
InitHeapMutexes;
end;
initialization
SetBeThreadManager;
end.