* systhrds fir netware added

rtl/netware/systhrds.pp

@@ -0,0 +1,384 @@
+{
+    $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.
+
+ **********************************************************************}
+unit systhrds;
+interface
+
+{$S-}
+
+{ Multithreading for netware, armin 16 Mar 2002
+  - threads are basicly tested and working
+  - 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.
+}
+{ Include generic thread interface }
+{$i threadh.inc }
+
+implementation
+
+{$i thread.inc }
+
+{ some declarations for Netware API calls }
+{$I nwsys.inc}
+
+{  define DEBUG_MT}
+
+const
+   threadvarblocksize : dword = 0;     // total size of allocated threadvars
+   thredvarsmainthread: pointer = nil; // to free the threadvars in the signal handler
+
+
+procedure SysInitThreadvar (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;
+
+
+{$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 SysRelocateThreadvar (offset : dword) : pointer;
+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);
+     SysRelocateThreadvar := @dummy_buff;
+     exit;
+   end;
+ {$endif DEBUG_MT}
+ SysRelocateThreadvar:= _GetThreadDataAreaPtr + offset;
+end;
+
+procedure SysAllocateThreadVars;
+
+  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 SysReleaseThreadVars;
+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);
+       _SaveThreadDataAreaPtr (nil);
+     end;
+  end;
+end;
+
+
+{ Include OS independent Threadvar initialization }
+{$i threadvr.inc}
+
+
+{*****************************************************************************
+                            Thread starting
+*****************************************************************************}
+
+type
+   tthreadinfo = record
+      f : tthreadfunc;
+      p : pointer;
+      stklen: cardinal;
+   end;
+   pthreadinfo = ^tthreadinfo;
+
+
+
+procedure DoneThread;
+
+  begin
+     { release thread vars }
+     SysReleaseThreadVars;
+  end;
+
+
+function ThreadMain(param : pointer) : dword; cdecl;
+
+  var
+     ti : tthreadinfo;
+
+  begin
+     SysAllocateThreadVars;
+{$ifdef DEBUG_MT}
+     ConsolePrintf(#13'New thread started, initialising ...'#13#10);
+{$endif DEBUG_MT}
+     ti:=pthreadinfo(param)^;
+     InitThread(ti.stklen);
+     dispose(pthreadinfo(param));
+{$ifdef DEBUG_MT}
+     ConsolePrintf(#13'Jumping to thread function'#13#10);
+{$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}
+     ConsolePrintf(#13'Creating new thread'#13#10);
+{$endif DEBUG_MT}
+     if not IsMultiThread then
+     begin
+       InitThreadVars(@SysRelocateThreadvar);
+       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;
+{$ifdef DEBUG_MT}
+     ConsolePrintf(#13'Starting new thread'#13#10);
+{$endif DEBUG_MT}
+     BeginThread :=
+       _BeginThread (@ThreadMain,NIL,Stacksize,ti);
+  end;
+
+
+procedure EndThread(ExitCode : DWord);
+begin
+  DoneThread;
+  ExitThread(ExitCode , TSR_THREAD);
+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;
+
+
+function SetThreadDataAreaPtr (newPtr:pointer):pointer;
+begin
+  SetThreadDataAreaPtr := _GetThreadDataAreaPtr;
+  if newPtr = nil then
+    newPtr := thredvarsmainthread;
+  _SaveThreadDataAreaPtr     (newPtr);
+end;
+
+
+
+{*****************************************************************************
+                           Heap Mutex Protection
+*****************************************************************************}
+			   
+var
+  HeapMutex : TRTLCriticalSection;
+				     
+procedure NWHeapMutexInit;
+begin
+  InitCriticalSection(heapmutex);
+end;
+							      
+procedure NWHeapMutexDone;
+begin
+  DoneCriticalSection(heapmutex);
+end;
+										       
+procedure NWHeapMutexLock;
+begin
+  EnterCriticalSection(heapmutex);
+end;
+														
+procedure NWHeapMutexUnlock;
+begin
+  LeaveCriticalSection(heapmutex);
+end;
+																 
+const
+  NWMemoryMutexManager : TMemoryMutexManager = (
+           MutexInit : @NWHeapMutexInit;
+           MutexDone : @NWHeapMutexDone;
+           MutexLock : @NWHeapMutexLock;
+    	   MutexUnlock : @NWHeapMutexUnlock;
+  );
+																							 
+procedure InitHeapMutexes;
+begin
+  SetMemoryMutexManager(NWMemoryMutexManager);
+end;
+
+
+
+initialization
+  InitHeapMutexes;
+  NWSysSetThreadFunctions (@CloseAllRemainingSemaphores,
+                           @SysReleaseThreadVars,
+                           @SetThreadDataAreaPtr);
+end.
+
+{
+  $Log$
+  Revision 1.1  2003-02-16 17:12:15  armin
+  * systhrds fir netware added
+
+
+}