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

* Moved to unix/

Browse Source
This commit is contained in:
marco 2001-10-17 10:28:22 +00:00
parent 13132aa761
commit 24073dd23f
1 changed files with 0 additions and 189 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

189
rtl/linux/thread.inc
View File

@ -1,189 +0,0 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2001 by the Free Pascal development team.
Multithreading implementation for Linux
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.
**********************************************************************}
{$ifdef MT}
const
DefaultStackSize = 16384;
threadvarblocksize : dword = 0;
type
pthreadinfo = ^tthreadinfo;
tthreadinfo = record
f : tthreadfunc;
p : pointer;
end;
var
dataindex : pointer;
procedure init_threadvar(var offset : dword;size : dword);[public,alias: 'FPC_INIT_THREADVAR'];
begin
offset:=threadvarblocksize;
inc(threadvarblocksize,size);
end;
function relocate_threadvar(offset : dword) : pointer;[public,alias: 'FPC_RELOCATE_THREADVAR'];
begin
Relocate_ThreadVar := DataIndex + Offset;
end;
procedure AllocateThreadVars;
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(Sys_mmap(0,threadvarblocksize,3,MAP_PRIVATE+MAP_ANONYMOUS,-1,0));
FillChar(DataIndex^,threadvarblocksize,0);
end;
procedure ReleaseThreadVars;
begin
Sys_munmap(Longint(dataindex),threadvarblocksize);
end;
procedure InitThread;
begin
ResetFPU;
{ we don't need to set the data to 0 because we did this with }
{ the fillchar above, but it looks nicer }
{ ExceptAddrStack and ExceptObjectStack are threadvars }
{ so every thread has its on exception handling capabilities }
InitExceptions;
InOutRes:=0;
// ErrNo:=0;
end;
procedure DoneThread;
begin
{ release thread vars }
ReleaseThreadVars;
end;
function ThreadMain(param : pointer) : longint;cdecl;
var
ti : tthreadinfo;
begin
{$ifdef DEBUG_MT}
writeln('New thread started, initialising ...');
{$endif DEBUG_MT}
AllocateThreadVars;
InitThread;
ti:=pthreadinfo(param)^;
dispose(pthreadinfo(param));
{$ifdef DEBUG_MT}
writeln('Jumping to thread function');
{$endif DEBUG_MT}
ThreadMain:=ti.f(ti.p);
end;
function BeginThread(sa : Pointer;stacksize : dword;
ThreadFunction : tthreadfunc;p : pointer;
creationFlags : dword; var ThreadId : DWord) : DWord;
var
ti : pthreadinfo;
FStackPointer : pointer;
Flags : longint;
begin
{$ifdef DEBUG_MT}
writeln('Creating new thread');
{$endif DEBUG_MT}
IsMultithread:=true;
{ 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;
{$ifdef DEBUG_MT}
writeln('Starting new thread');
{$endif DEBUG_MT}
Flags := CLONE_VM + CLONE_FS + CLONE_FILES + CLONE_SIGHAND + SIGCHLD;
{ Setup stack }
Getmem(pointer(FStackPointer),StackSize);
inc(FStackPointer,StackSize);
{ Clone }
ThreadID:=Clone(@ThreadMain,pointer(FStackPointer),Flags,ti);
end;
function BeginThread(ThreadFunction : tthreadfunc) : DWord;
var
dummy : dword;
begin
BeginThread:=BeginThread(nil,DefaultStackSize,ThreadFunction,nil,0,dummy);
end;
function BeginThread(ThreadFunction : tthreadfunc;p : pointer) : DWord;
var
dummy : dword;
begin
BeginThread:=BeginThread(nil,DefaultStackSize,ThreadFunction,p,0,dummy);
end;
function BeginThread(ThreadFunction : tthreadfunc;p : pointer;var ThreadId : DWord) : DWord;
begin
BeginThread:=BeginThread(nil,DefaultStackSize,ThreadFunction,p,0,ThreadId);
end;
procedure EndThread(ExitCode : DWord);
begin
DoneThread;
Sys_Exit(ExitCode);
end;
procedure EndThread;
begin
EndThread(0);
end;
procedure InitCriticalSection(var cs : tcriticalsection);
begin
end;
procedure DoneCriticalSection(var cs : tcriticalsection);
begin
end;
procedure EnterCriticalSection(var cs : tcriticalsection);
begin
end;
procedure LeaveCriticalSection(var cs : tcriticalsection);
begin
end;
{$endif MT}
{
$Log$
Revision 1.1 2001-10-14 13:33:20 peter
* start of thread support for linux
}