mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-17 17:59:26 +02:00
392 lines
11 KiB
ObjectPascal
392 lines
11 KiB
ObjectPascal
{
|
|
$Id$
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 2002 by the Free Pascal development team.
|
|
|
|
OS/2 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.
|
|
|
|
**********************************************************************}
|
|
unit systhrds;
|
|
interface
|
|
|
|
{$S-}
|
|
|
|
type
|
|
{ the fields of this record are os dependent }
|
|
{ and they shouldn't be used in a program }
|
|
{ only the type TCriticalSection is important }
|
|
PRTLCriticalSection = ^TRTLCriticalSection;
|
|
TRTLCriticalSection = packed record
|
|
DebugInfo : pointer;
|
|
LockCount : longint;
|
|
RecursionCount : longint;
|
|
OwningThread : DWord;
|
|
LockSemaphore : DWord;
|
|
Reserved : DWord;
|
|
end;
|
|
|
|
{ Include generic thread interface }
|
|
{$i threadh.inc}
|
|
|
|
|
|
implementation
|
|
|
|
|
|
{*****************************************************************************
|
|
Local Api imports
|
|
*****************************************************************************}
|
|
|
|
const
|
|
pag_Read = 1;
|
|
pag_Write = 2;
|
|
pag_Execute = 4;
|
|
pag_Guard = 8;
|
|
pag_Commit = $10;
|
|
obj_Tile = $40;
|
|
sem_Indefinite_Wait = -1;
|
|
dtSuspended = 1;
|
|
dtStack_Commited = 2;
|
|
|
|
type
|
|
TByteArray = array [0..$ffff] of byte;
|
|
PByteArray = ^TByteArray;
|
|
|
|
TSysThreadIB = record
|
|
TID,
|
|
Priority,
|
|
Version: cardinal;
|
|
MCCount,
|
|
MCForceFlag: word;
|
|
end;
|
|
PSysThreadIB = ^TSysThreadIB;
|
|
|
|
TThreadInfoBlock = record
|
|
PExChain,
|
|
Stack,
|
|
StackLimit: pointer;
|
|
TIB2: PSysThreadIB;
|
|
Version,
|
|
Ordinal: cardinal;
|
|
end;
|
|
PThreadInfoBlock = ^TThreadInfoBlock;
|
|
PPThreadInfoBlock = ^PThreadInfoBlock;
|
|
|
|
TProcessInfoBlock = record
|
|
PID,
|
|
ParentPid,
|
|
Handle: cardinal;
|
|
Cmd,
|
|
Env: PByteArray;
|
|
Status,
|
|
ProcType: cardinal;
|
|
end;
|
|
PProcessInfoBlock = ^TProcessInfoBlock;
|
|
PPProcessInfoBlock = ^PProcessInfoBlock;
|
|
|
|
|
|
{ import the necessary stuff from the OS }
|
|
function DosAllocThreadLocalMemory (Count: cardinal; var P: pointer): cardinal;
|
|
cdecl; external 'DOSCALLS' index 454;
|
|
|
|
function DosFreeThreadLocalMemory (P: pointer): cardinal; cdecl;
|
|
external 'DOSCALLS' index 455;
|
|
|
|
function DosCreateThread (var TID: cardinal; Address: pointer;
|
|
(* TThreadFunc *)
|
|
aParam: pointer; Flags: cardinal; StackSize: cardinal): cardinal; cdecl;
|
|
external 'DOSCALLS' index 311;
|
|
|
|
procedure DosExit (Action, Result: cardinal); cdecl;
|
|
external 'DOSCALLS' index 234;
|
|
|
|
function DosCreateMutExSem (Name: PChar; var Handle: longint; Attr: cardinal;
|
|
State: boolean): cardinal; cdecl; external 'DOSCALLS' index 331;
|
|
|
|
function DosCloseMutExSem (Handle: longint): cardinal; cdecl;
|
|
external 'DOSCALLS' index 333;
|
|
|
|
function DosQueryMutExSem (Handle: longint; var PID, TID, Count: cardinal):
|
|
cardinal; cdecl; external 'DOSCALLS' index 336;
|
|
|
|
function DosRequestMutExSem (Handle:longint; Timeout: cardinal): cardinal; cdecl;
|
|
external 'DOSCALLS' index 334;
|
|
|
|
function DosReleaseMutExSem (Handle: longint): cardinal; cdecl;
|
|
external 'DOSCALLS' index 335;
|
|
|
|
function DosAllocMem (var P: pointer; Size, Flag: cardinal): cardinal; cdecl;
|
|
external 'DOSCALLS' index 299;
|
|
|
|
function DosFreeMem (P: pointer): cardinal; cdecl;
|
|
external 'DOSCALLS' index 304;
|
|
|
|
function DosEnterCritSec:cardinal; cdecl; external 'DOSCALLS' index 232;
|
|
|
|
function DosExitCritSec:cardinal; cdecl; external 'DOSCALLS' index 233;
|
|
|
|
procedure DosGetInfoBlocks (PATIB: PPThreadInfoBlock;
|
|
PAPIB: PPProcessInfoBlock); cdecl;
|
|
external 'DOSCALLS' index 312;
|
|
|
|
|
|
{*****************************************************************************
|
|
Threadvar support
|
|
*****************************************************************************}
|
|
|
|
{$ifdef HASTHREADVAR}
|
|
const
|
|
ThreadVarBlockSize: dword = 0;
|
|
|
|
var
|
|
(* Pointer to an allocated dword space within the local thread *)
|
|
(* memory area. Pointer to the real memory block allocated for *)
|
|
(* thread vars in this block is then stored in this dword. *)
|
|
DataIndex: PPointer;
|
|
|
|
procedure SysInitThreadvar (var Offset: dword; Size: dword);
|
|
begin
|
|
Offset := ThreadVarBlockSize;
|
|
Inc (ThreadVarBlockSize, Size);
|
|
end;
|
|
|
|
function SysRelocateThreadVar (Offset: dword): pointer;
|
|
begin
|
|
SysRelocateThreadVar := DataIndex^ + Offset;
|
|
end;
|
|
|
|
procedure SysAllocateThreadVars;
|
|
begin
|
|
{ we've to allocate the memory from the OS }
|
|
{ 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 }
|
|
if DosAllocMem (DataIndex^, ThreadVarBlockSize, pag_Read or pag_Write
|
|
or pag_Commit) <> 0 then HandleError (8);
|
|
end;
|
|
|
|
procedure SysReleaseThreadVars;
|
|
begin
|
|
{ release thread vars }
|
|
DosFreeMem (DataIndex^);
|
|
end;
|
|
|
|
{ Include OS independent Threadvar initialization }
|
|
{$i threadvar.inc}
|
|
|
|
procedure InitThreadVars;
|
|
begin
|
|
{ allocate one ThreadVar entry from the OS, we use this entry }
|
|
{ for a pointer to our threadvars }
|
|
if DosAllocThreadLocalMemory (1, DataIndex) <> 0 then HandleError (8);
|
|
{ initialize threadvars }
|
|
init_all_unit_threadvars;
|
|
{ allocate mem for main thread threadvars }
|
|
SysAllocateThreadVars;
|
|
{ copy main thread threadvars }
|
|
copy_all_unit_threadvars;
|
|
{ install threadvar handler }
|
|
fpc_threadvar_relocate_proc := @SysRelocateThreadvar;
|
|
end;
|
|
|
|
{$endif HASTHREADVAR}
|
|
|
|
|
|
{*****************************************************************************
|
|
Thread starting
|
|
*****************************************************************************}
|
|
|
|
const
|
|
DefaultStackSize = 32768; { including 16384 margin for stackchecking }
|
|
|
|
type
|
|
pthreadinfo = ^tthreadinfo;
|
|
tthreadinfo = record
|
|
f : tthreadfunc;
|
|
p : pointer;
|
|
stklen : cardinal;
|
|
end;
|
|
|
|
procedure InitThread(stklen:cardinal);
|
|
begin
|
|
SysResetFPU;
|
|
{ ExceptAddrStack and ExceptObjectStack are threadvars }
|
|
{ so every thread has its on exception handling capabilities }
|
|
SysInitExceptions;
|
|
{ Open all stdio fds again }
|
|
SysInitStdio;
|
|
InOutRes:=0;
|
|
// ErrNo:=0;
|
|
{ Stack checking }
|
|
StackLength:=stklen;
|
|
StackBottom:=Sptr - StackLength;
|
|
end;
|
|
|
|
|
|
procedure DoneThread;
|
|
begin
|
|
{ Release Threadvars }
|
|
{$ifdef HASTHREADVAR}
|
|
SysReleaseThreadVars;
|
|
{$endif HASTHREADVAR}
|
|
end;
|
|
|
|
|
|
function ThreadMain(param : pointer) : pointer;cdecl;
|
|
var
|
|
ti : tthreadinfo;
|
|
begin
|
|
{$ifdef HASTHREADVAR}
|
|
{ Allocate local thread vars, this must be the first thing,
|
|
because the exception management and io depends on threadvars }
|
|
SysAllocateThreadVars;
|
|
{$endif HASTHREADVAR}
|
|
{ Copy parameter to local data }
|
|
{$ifdef DEBUG_MT}
|
|
writeln('New thread started, initialising ...');
|
|
{$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));
|
|
end;
|
|
|
|
|
|
function BeginThread(sa : Pointer;stacksize : dword;
|
|
ThreadFunction : tthreadfunc;p : pointer;
|
|
creationFlags : dword; var ThreadId : DWord) : DWord;
|
|
var
|
|
ti : pthreadinfo;
|
|
begin
|
|
{$ifdef DEBUG_MT}
|
|
writeln('Creating new thread');
|
|
{$endif DEBUG_MT}
|
|
{ Initialize multithreading if not done }
|
|
if not IsMultiThread then
|
|
begin
|
|
{$ifdef HASTHREADVAR}
|
|
InitThreadVars;
|
|
{$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}
|
|
BeginThread:=CreateThread(sa,stacksize,@ThreadMain,ti,creationflags,threadid);
|
|
BeginThread:=threadid;
|
|
end;
|
|
|
|
|
|
procedure EndThread(ExitCode : DWord);
|
|
begin
|
|
DoneThread;
|
|
ExitThread(ExitCode);
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
Delphi/Win32 compatibility
|
|
*****************************************************************************}
|
|
|
|
{ we implement these procedures for win32 by importing them }
|
|
{ directly from windows }
|
|
procedure InitCriticalSection(var cs : TRTLCriticalSection);
|
|
external 'kernel32' name 'InitializeCriticalSection';
|
|
|
|
procedure DoneCriticalSection(var cs : TRTLCriticalSection);
|
|
external 'kernel32' name 'DeleteCriticalSection';
|
|
|
|
procedure EnterCriticalSection(var cs : TRTLCriticalSection);
|
|
external 'kernel32' name 'EnterCriticalSection';
|
|
|
|
procedure LeaveCriticalSection(var cs : TRTLCriticalSection);
|
|
external 'kernel32' name 'LeaveCriticalSection';
|
|
|
|
|
|
{*****************************************************************************
|
|
Heap Mutex Protection
|
|
*****************************************************************************}
|
|
|
|
var
|
|
HeapMutex : TRTLCriticalSection;
|
|
|
|
procedure OS2HeapMutexInit;
|
|
begin
|
|
InitCriticalSection(heapmutex);
|
|
end;
|
|
|
|
procedure OS2HeapMutexDone;
|
|
begin
|
|
DoneCriticalSection(heapmutex);
|
|
end;
|
|
|
|
procedure OS2HeapMutexLock;
|
|
begin
|
|
EnterCriticalSection(heapmutex);
|
|
end;
|
|
|
|
procedure OS2HeapMutexUnlock;
|
|
begin
|
|
LeaveCriticalSection(heapmutex);
|
|
end;
|
|
|
|
const
|
|
OS2MemoryMutexManager : TMemoryMutexManager = (
|
|
MutexInit : @OS2HeapMutexInit;
|
|
MutexDone : @OS2HeapMutexDone;
|
|
MutexLock : @OS2HeapMutexLock;
|
|
MutexUnlock : @OS2HeapMutexUnlock;
|
|
);
|
|
|
|
procedure InitHeapMutexes;
|
|
begin
|
|
SetMemoryMutexManager(Win32MemoryMutexManager);
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
Generic overloaded
|
|
*****************************************************************************}
|
|
|
|
{ Include generic overloaded routines }
|
|
{$i thread.inc}
|
|
|
|
finalization
|
|
DosFreeThreadLocalMemory (DataIndex);
|
|
end;
|
|
|
|
initialization
|
|
InitHeapMutexes;
|
|
end.
|
|
{
|
|
$Log$
|
|
Revision 1.2 2003-10-13 21:17:31 hajny
|
|
* longint to cardinal corrections
|
|
|
|
Revision 1.1 2002/11/17 22:31:46 hajny
|
|
+ first (incomplete) version of systhrds
|
|
|
|
Revision 1.1 2002/10/14 19:39:18 peter
|
|
* threads unit added for thread support
|
|
|
|
}
|
|
|