|
|
@@ -1,390 +0,0 @@
|
|
|
-{
|
|
|
- $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.5 2002-09-07 16:01:21 peter
|
|
|
- * old logs removed and tabs fixed
|
|
|
-
|
|
|
- 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
|
|
|
-
|
|
|
-}
|
armin