{
$Id: thread.inc,v 1.14 2003/10/13 21:17:31 hajny Exp $
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by the Free Pascal development team.
Multithreading implementation for OS/2
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
ThreadVarBlockSize: dword = 0;
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
TThreadInfo = record
F: TThreadFunc;
P: pointer;
end;
PThreadInfo = ^TThreadInfo;
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;
{ 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 Init_ThreadVar (var TVOffset: dword; Size: dword);
[public, alias: 'FPC_INIT_THREADVAR'];
begin
TVOffset := ThreadVarBlockSize;
Inc (ThreadVarBlockSize, Size);
end;
type ltvInitEntry =
record
varaddr : pdword;
size : longint;
end;
pltvInitEntry = ^ltvInitEntry;
procedure init_unit_threadvars (tableEntry : pltvInitEntry);
begin
while tableEntry^.varaddr <> nil do
begin
init_threadvar (tableEntry^.varaddr^, tableEntry^.size);
inc (pchar (tableEntry), sizeof (tableEntry^));
end;
end;
type TltvInitTablesTable =
record
count : dword;
tables: array [1..32767] of pltvInitEntry;
end;
var
ThreadvarTablesTable : TltvInitTablesTable; external name 'FPC_LOCALTHREADVARTABLES';
procedure init_all_unit_threadvars; [public,alias: 'FPC_INITIALIZELOCALTHREADVARS'];
var i : integer;
begin
{$ifdef DEBUG_MT}
WriteLn ('init_all_unit_threadvars (%d) units',ThreadvarTablesTable.count);
{$endif}
for i := 1 to ThreadvarTablesTable.count do
init_unit_threadvars (ThreadvarTablesTable.tables[i]);
end;
function Relocate_ThreadVar (TVOffset: dword): pointer;
[public,alias: 'FPC_RELOCATE_THREADVAR'];
begin
Relocate_ThreadVar := DataIndex^ + TVOffset;
end;
procedure AllocateThreadVars;
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 ReleaseThreadVars;
begin
{ release thread vars }
DosFreeMem (DataIndex^)
end;
procedure InitThread;
begin
InitFPU;
{ 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;
var
PTIB: PThreadInfoBlock;
PPIB: PProcessInfoBlock;
ThreadID: cardinal;
begin
ReleaseThreadVars;
DosGetInfoBlocks (@PTIB, @PPIB);
ThreadID := PTIB^.TIB2^.TID;
end;
function ThreadMain (Param: pointer): dword; 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;
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}
BeginThread := DosCreateThread (ThreadID, @ThreadMain, TI, CreationFlags,
StackSize);
end;
function BeginThread (ThreadFunction: TThreadFunc): dword;
var
Dummy: dword;
begin
(* The stack size of 0 causes 4 kB to be allocated for stack. *)
BeginThread := BeginThread (nil, 0, ThreadFunction, nil, dtStack_Commited,
Dummy);
end;
function BeginThread (ThreadFunction: TThreadFunc; P: pointer): dword;
var
Dummy: dword;
begin
(* The stack size of 0 causes 4 kB to be allocated for stack. *)
BeginThread := BeginThread (nil, 0, ThreadFunction, P, 0, Dummy);
end;
function BeginThread (ThreadFunction: TThreadFunc; P: pointer;
var ThreadID: dword): dword;
begin
(* The stack size of 0 causes 4 kB to be allocated for stack. *)
BeginThread := BeginThread (nil, 0, ThreadFunction, P, 0, ThreadID);
end;
procedure EndThread (ExitCode: dword);
begin
DoneThread;
DosExit (0, ExitCode);
end;
procedure EndThread;
begin
EndThread (0);
end;
procedure InitCriticalSection (var CS: TRTLCriticalSection);
begin
if DosCreateMutExSem (nil, CS.LockSemaphore2, 0, true) <> 0 then
HandleError (8);
DosEnterCritSec;
CS.LockCount := 0;
CS.OwningThread := $FFFF;
DosExitCritSec;
DosReleaseMutexSem (CS.LockSemaphore2);
end;
procedure DoneCriticalSection (var CS: TRTLCriticalSection);
begin
DosCloseMutExSem (CS.LockSemaphore2);
end;
procedure EnterCriticalSection (var CS: TRTLCriticalSection);
var
P, T, Cnt: cardinal;
PTIB: PThreadInfoBlock;
PPIB: PProcessInfoBlock;
begin
DosGetInfoBlocks (@PTIB, @PPIB);
DosEnterCritSec;
with CS do if (LockCount = 0) and
(DosQueryMutExSem (LockSemaphore2, P, T, Cnt) = 0) and (Cnt = 0) and
(T = PTIB^.TIB2^.TID) then
begin
LockCount := 1;
OwningThread2 := PTIB^.TIB2^.TID;
DosExitCritSec;
DosRequestMutExSem (LockSemaphore2, sem_Indefinite_Wait);
end else if PTIB^.TIB2^.TID = OwningThread2 then
begin
Inc (LockCount);
if LockCount = 0 then Dec (LockCount);
DosExitCritSec;
end else
begin
DosExitCritSec;
DosRequestMutExSem (LockSemaphore2, sem_Indefinite_Wait);
DosEnterCritSec;
LockCount := 1;
OwningThread2 := PTIB^.TIB2^.TID;
DosExitCritSec;
end;
end;
procedure LeaveCriticalSection (var CS: TRTLCriticalSection);
var
PTIB: PThreadInfoBlock;
PPIB: PProcessInfoBlock;
Err: boolean;
begin
Err := false;
DosGetInfoBlocks (@PTIB, @PPIB);
DosEnterCritSec;
with CS do if OwningThread2 <> PTIB^.TIB2^.TID then
begin
DosExitCritSec;
Err := true;
end else if LockCount = 1 then
begin
if DosReleaseMutExSem (LockSemaphore2) <> 0 then Err := true;
Dec (LockCount);
DosExitCritSec;
end else
begin
Dec (LockCount);
DosExitCritSec;
end;
if Err then HandleError (5);
end;
{$ENDIF MT}
{
$Log: thread.inc,v $
Revision 1.14 2003/10/13 21:17:31 hajny
* longint to cardinal corrections
Revision 1.13 2003/10/08 09:21:33 yuri
* EMX code removed. Most probably, MT broken. (EMX notification removed)
Revision 1.12 2003/10/08 05:22:47 yuri
* Some emx code removed
Revision 1.11 2003/10/07 21:26:35 hajny
* stdcall fixes and asm routines cleanup
Revision 1.10 2003/02/20 17:09:49 hajny
* fixes for OS/2 v2.1 incompatibility
Revision 1.9 2002/09/07 16:01:25 peter
* old logs removed and tabs fixed
Revision 1.8 2002/07/07 18:04:39 hajny
* correction by Yuri Prokushev
Revision 1.7 2002/03/28 16:34:29 armin
+ initialize threadvars defined local in units
}
syntax highlighted by Code2HTML, v. 0.9.1