mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-06-02 01:42:52 +02:00
388 lines
10 KiB
PHP
388 lines
10 KiB
PHP
{
|
|
$Id$
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 2001-2002 by the Free Pascal development team.
|
|
|
|
Multithreading implementation for NetWare
|
|
|
|
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}
|
|
|
|
{ Multithreading for netware, armin 16 Mar 2002
|
|
- threads are basicly tested and working
|
|
- threadvars should work but currently there is a bug in the
|
|
compiler preventing using multithreading
|
|
- TRTLCriticalSections are working but NEVER call Enter or
|
|
LeaveCriticalSection with uninitialized CriticalSections.
|
|
Critial Sections are based on local semaphores and the
|
|
Server will abend if the semaphore handles are invalid. There
|
|
are basic tests in the rtl but this will not work in every case.
|
|
Not closed semaphores will be closed by the rtl on program
|
|
termination because some versions of netware will abend if there
|
|
are open semaphores on nlm unload.
|
|
}
|
|
|
|
const
|
|
threadvarblocksize : dword = 0; // total size of allocated threadvars
|
|
thredvarsmainthread: pointer = nil; // to free the threadvars in the signal handler
|
|
|
|
type
|
|
tthreadinfo = record
|
|
f : tthreadfunc;
|
|
p : pointer;
|
|
end;
|
|
pthreadinfo = ^tthreadinfo;
|
|
|
|
{ all needed import stuff is in nwsys.inc and already included by
|
|
system.pp }
|
|
|
|
|
|
procedure init_threadvar(var offset : dword;size : dword);[public,alias: 'FPC_INIT_THREADVAR'];
|
|
begin
|
|
offset:=threadvarblocksize;
|
|
inc(threadvarblocksize,size);
|
|
{$ifdef DEBUG_MT}
|
|
ConsolePrintf3(#13'init_threadvar, new offset: (%d), Size:%d'#13#10,offset,size,0);
|
|
{$endif DEBUG_MT}
|
|
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}
|
|
ConsolePrintf(#13'init_all_unit_threadvars (%d) units'#13#10,ThreadvarTablesTable.count);
|
|
{$endif}
|
|
for i := 1 to ThreadvarTablesTable.count do
|
|
begin
|
|
{$ifdef DEBUG_MT}
|
|
ConsolePrintf(#13'init_unit_threadvars for unit (%d):'#13#10,i);
|
|
{$endif}
|
|
init_unit_threadvars (ThreadvarTablesTable.tables[i]);
|
|
{$ifdef DEBUG_MT}
|
|
ConsolePrintf(#13'init_unit_threadvars for unit (%d) done'#13#10,i);
|
|
{$endif}
|
|
end;
|
|
end;
|
|
|
|
{$ifdef DEBUG_MT}
|
|
var dummy_buff : array [0..255] of char; // to avoid abends (for current compiler error that not all threadvars are initialized)
|
|
{$endif}
|
|
|
|
function relocate_threadvar(offset : dword) : pointer;[public,alias: 'FPC_RELOCATE_THREADVAR'];
|
|
var p : pointer;
|
|
begin
|
|
{$ifdef DEBUG_MT}
|
|
// ConsolePrintf(#13'relocate_threadvar, offset: (%d)'#13#10,offset);
|
|
if offset > threadvarblocksize then
|
|
begin
|
|
// ConsolePrintf(#13'relocate_threadvar, invalid offset'#13#10,0);
|
|
relocate_threadvar := @dummy_buff;
|
|
exit;
|
|
end;
|
|
{$endif DEBUG_MT}
|
|
relocate_threadvar:= _GetThreadDataAreaPtr + offset;
|
|
end;
|
|
|
|
procedure AllocateThreadVars;
|
|
|
|
var
|
|
threadvars : pointer;
|
|
|
|
begin
|
|
{ we've to allocate the memory from netware }
|
|
{ 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 }
|
|
threadvars := _malloc (threadvarblocksize);
|
|
fillchar (threadvars^, threadvarblocksize, 0);
|
|
_SaveThreadDataAreaPtr (threadvars);
|
|
{$ifdef DEBUG_MT}
|
|
ConsolePrintf3(#13'threadvars allocated at (%x), size: %d'#13#10,longint(threadvars),threadvarblocksize,0);
|
|
{$endif DEBUG_MT}
|
|
if thredvarsmainthread = nil then
|
|
thredvarsmainthread := threadvars;
|
|
end;
|
|
|
|
procedure ReleaseThreadVars;
|
|
var threadvars : pointer;
|
|
begin
|
|
{ release thread vars }
|
|
if threadvarblocksize > 0 then
|
|
begin
|
|
threadvars:=_GetThreadDataAreaPtr;
|
|
if threadvars <> nil then
|
|
begin
|
|
{$ifdef DEBUG_MT}
|
|
ConsolePrintf (#13'free threadvars'#13#10,0);
|
|
{$endif DEBUG_MT}
|
|
_Free (threadvars);
|
|
end;
|
|
end;
|
|
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;
|
|
|
|
begin
|
|
{ release thread vars }
|
|
ReleaseThreadVars;
|
|
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);
|
|
DoneThread;
|
|
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 :=
|
|
_BeginThread (@ThreadMain,NIL,Stacksize,ti);
|
|
end;
|
|
|
|
function BeginThread(ThreadFunction : tthreadfunc) : DWord;
|
|
var dummy : dword;
|
|
begin
|
|
BeginThread:=BeginThread(nil,0,ThreadFunction,nil,0,dummy);
|
|
end;
|
|
|
|
function BeginThread(ThreadFunction : tthreadfunc;p : pointer) : DWord;
|
|
var dummy : dword;
|
|
begin
|
|
BeginThread:=BeginThread(nil,0,ThreadFunction,p,0,dummy);
|
|
end;
|
|
|
|
function BeginThread(ThreadFunction : tthreadfunc;p : pointer;var ThreadId : DWord) : DWord;
|
|
begin
|
|
BeginThread:=BeginThread(nil,0,ThreadFunction,p,0,ThreadId);
|
|
end;
|
|
|
|
procedure EndThread(ExitCode : DWord);
|
|
begin
|
|
DoneThread;
|
|
ExitThread(ExitCode, TSR_THREAD);
|
|
end;
|
|
|
|
procedure EndThread;
|
|
begin
|
|
EndThread(0);
|
|
end;
|
|
|
|
|
|
{ netware requires all allocated semaphores }
|
|
{ to be closed before terminating the nlm, otherwise }
|
|
{ the server will abend (except for netware 6 i think) }
|
|
|
|
TYPE TSemaList = ARRAY [1..1000] OF LONGINT;
|
|
PSemaList = ^TSemaList;
|
|
|
|
CONST NumSemaOpen : LONGINT = 0;
|
|
NumEntriesMax : LONGINT = 0;
|
|
SemaList : PSemaList = NIL;
|
|
|
|
PROCEDURE SaveSema (Handle : LONGINT);
|
|
BEGIN
|
|
{$ifdef DEBUG_MT}
|
|
ConsolePrintf(#13'new Semaphore allocated (%x)'#13#10,Handle);
|
|
{$endif DEBUG_MT}
|
|
_EnterCritSec;
|
|
IF NumSemaOpen = NumEntriesMax THEN
|
|
BEGIN
|
|
IF SemaList = NIL THEN
|
|
BEGIN
|
|
SemaList := _malloc (32 * SIZEOF (TSemaList[0]));
|
|
NumEntriesMax := 32;
|
|
END ELSE
|
|
BEGIN
|
|
INC (NumEntriesMax, 16);
|
|
SemaList := _realloc (SemaList, NumEntriesMax * SIZEOF (TSemaList[0]));
|
|
END;
|
|
END;
|
|
INC (NumSemaOpen);
|
|
SemaList^[NumSemaOpen] := Handle;
|
|
_ExitCritSec;
|
|
END;
|
|
|
|
PROCEDURE ReleaseSema (Handle : LONGINT);
|
|
VAR I : LONGINT;
|
|
BEGIN
|
|
{$ifdef DEBUG_MT}
|
|
ConsolePrintf(#13'Semaphore released (%x)'#13#10,Handle);
|
|
{$endif DEBUG_MT}
|
|
_EnterCritSec;
|
|
IF SemaList <> NIL then
|
|
if NumSemaOpen > 0 then
|
|
begin
|
|
for i := 1 to NumSemaOpen do
|
|
if SemaList^[i] = Handle then
|
|
begin
|
|
if i < NumSemaOpen then
|
|
SemaList^[i] := SemaList^[NumSemaOpen];
|
|
dec (NumSemaOpen);
|
|
_ExitCritSec;
|
|
exit;
|
|
end;
|
|
end;
|
|
_ExitCritSec;
|
|
ConsolePrintf (#13'fpc-rtl: ReleaseSema, Handle not found'#13#10,0);
|
|
END;
|
|
|
|
|
|
PROCEDURE CloseAllRemainingSemaphores;
|
|
var i : LONGINT;
|
|
begin
|
|
IF SemaList <> NIL then
|
|
begin
|
|
if NumSemaOpen > 0 then
|
|
for i := 1 to NumSemaOpen do
|
|
_CloseLocalSemaphore (SemaList^[i]);
|
|
_free (SemaList);
|
|
SemaList := NIL;
|
|
NumSemaOpen := 0;
|
|
NumEntriesMax := 0;
|
|
end;
|
|
end;
|
|
|
|
{ this allows to do a lot of things in MT safe way }
|
|
{ it is also used to make the heap management }
|
|
{ thread safe }
|
|
procedure InitCriticalSection(var cs : TRTLCriticalSection);
|
|
begin
|
|
cs.SemaHandle := _OpenLocalSemaphore (1);
|
|
if cs.SemaHandle <> 0 then
|
|
begin
|
|
cs.SemaIsOpen := true;
|
|
SaveSema (cs.SemaHandle);
|
|
end else
|
|
begin
|
|
cs.SemaIsOpen := false;
|
|
ConsolePrintf (#13'fpc-rtl: InitCriticalsection, OpenLocalSemaphore returned error'#13#10,0);
|
|
end;
|
|
end;
|
|
|
|
procedure DoneCriticalsection(var cs : TRTLCriticalSection);
|
|
begin
|
|
if cs.SemaIsOpen then
|
|
begin
|
|
_CloseLocalSemaphore (cs.SemaHandle);
|
|
ReleaseSema (cs.SemaHandle);
|
|
cs.SemaIsOpen := FALSE;
|
|
end;
|
|
end;
|
|
|
|
procedure EnterCriticalsection(var cs : TRTLCriticalSection);
|
|
begin
|
|
if cs.SemaIsOpen then
|
|
_WaitOnLocalSemaphore (cs.SemaHandle)
|
|
else
|
|
ConsolePrintf (#13'fpc-rtl: EnterCriticalsection, TRTLCriticalSection not open'#13#10,0);
|
|
end;
|
|
|
|
procedure LeaveCriticalsection(var cs : TRTLCriticalSection);
|
|
begin
|
|
if cs.SemaIsOpen then
|
|
_SignalLocalSemaphore (cs.SemaHandle)
|
|
else
|
|
ConsolePrintf (#13'fpc-rtl: LeaveCriticalsection, TRTLCriticalSection not open'#13#10,0);
|
|
end;
|
|
|
|
|
|
{$endif MT}
|
|
|
|
{
|
|
$Log$
|
|
Revision 1.4 2002-04-01 15:20:08 armin
|
|
+ unload module no longer shows: Module did not release...
|
|
+ check-function will no longer be removed when smartlink is on
|
|
|
|
Revision 1.3 2002/04/01 10:47:31 armin
|
|
makefile.fpc for netware
|
|
stderr to netware console
|
|
free all memory (threadvars and heap) to avoid error message while unloading nlm
|
|
|
|
Revision 1.2 2002/03/28 16:11:17 armin
|
|
+ initialize threadvars defined local in units
|
|
|
|
Revision 1.1 2002/03/17 17:57:33 armin
|
|
+ threads and winsock2 implemented
|
|
|
|
}
|