* more platform independent thread routines, needs to be implemented for unix

fcl/netware/thread.inc

@@ -13,15 +13,6 @@
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
  **********************************************************************}
- 
-{ additional functions needed for netware that are not defined in systhrds }
-
-function SuspendThread (threadId : longint) : longint; cdecl; external 'clib' name 'SuspendThread';
-function ResumeThread (threadId : longint) : longint; cdecl; external 'clib' name 'ResumeThread';
-procedure ThreadSwitchWithDelay; cdecl; external 'clib' name 'ThreadSwitchWithDelay';
-function GetThreadName  (threadId : longint; var threadName) : longint; cdecl; external 'clib' name 'GetThreadName';
-function RenameThread (threadId : longint; threadName:pchar) : longint; cdecl; external 'clib' name 'RenameThread';
-     
 
 
 type
@@ -146,7 +137,6 @@ end;
 constructor TThread.Create(CreateSuspended: Boolean);
 var
   Flags: Integer;
-  nam : string [18];  {17 chars is the maximum}
 begin
   inherited Create;
   AddThread(self);
@@ -154,8 +144,6 @@ begin
   { Create new thread }
   FHandle := BeginThread (@ThreadProc,self);
   if FSuspended then Suspend;
-  nam := copy (ClassName,1,17)+#0;
-  RenameThread (FHandle, @nam[1]);
   FThreadID := FHandle;
   //IsMultiThread := TRUE;  {already set by systhrds}
 end;
@@ -170,7 +158,7 @@ begin
      WaitFor;
    end;
   if FHandle <> -1 then
-    SuspendThread (FHandle);  {something went wrong, this will crash the server at unload}
+    KillThread (FHandle);  {something went wrong, kill the thread (not possible on netware)}
   inherited Destroy;
   RemoveThread(self);
 end;
@@ -188,24 +176,40 @@ begin
 end;
 
 
+const
+  Priorities: array [TThreadPriority] of Integer =
+   (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
+    THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,
+    THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);
+
 function TThread.GetPriority: TThreadPriority;
+var
+  P: Integer;
+  I: TThreadPriority;
 begin
-  result := tpNormal;
+  P := ThreadGetPriority(FHandle);
+  Result := tpNormal;
+  for I := Low(TThreadPriority) to High(TThreadPriority) do
+    if Priorities[I] = P then Result := I;
 end;
 
 
 procedure TThread.SetPriority(Value: TThreadPriority);
 begin
+  ThreadSetPriority(FHandle, Priorities[Value]);
 end;
 
-
+{does not make sense for netware}
 procedure TThread.Synchronize(Method: TThreadMethod);
 begin
+  {$ifndef netware}
   FSynchronizeException := nil;
   FMethod := Method;
 {  SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self)); }
+  {$warning Synchronize needs implementation}
   if Assigned(FSynchronizeException) then
     raise FSynchronizeException;
+  {$endif}
 end;
 
 
@@ -236,24 +240,23 @@ end;
 procedure TThread.Terminate;
 begin
   FTerminated := True;
-  ThreadSwitchWithDelay;
+  ThreadSwitch;
 end;
 
+
 function TThread.WaitFor: Integer;
-var
-  status : longint;
-  buf : array [0..50] of char;
 begin
-  repeat
-    status := GetThreadName (FHandle,Buf); {should return EBADHNDL if thread is terminated}
-    ThreadSwitchWithDelay;
-  until status <> 0;    
-  Result:=0;
+  Result := WaitForThreadTerminate (FHandle,0);
+  if Result = 0 then
+    FHandle := -1;
 end;
 
 {
   $Log$
-  Revision 1.1  2003-03-25 17:56:19  armin
+  Revision 1.2  2003-03-27 17:14:27  armin
+  * more platform independent thread routines, needs to be implemented for unix
+
+  Revision 1.1  2003/03/25 17:56:19  armin
   * first fcl implementation for netware
 
   Revision 1.7  2002/12/18 20:44:36  peter

rtl/inc/threadh.inc

@@ -14,7 +14,7 @@
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
  **********************************************************************}
- 
+
 const
    DefaultStackSize = 32768; { including 16384 margin for stackchecking }
 
@@ -44,6 +44,17 @@ function BeginThread(ThreadFunction : tthreadfunc;p : pointer; var ThreadId : Lo
 procedure EndThread(ExitCode : DWord);
 procedure EndThread;
 
+{some thread support functions}
+function  SuspendThread (threadHandle : dword) : dword;
+function  ResumeThread  (threadHandle : dword) : dword;
+procedure ThreadSwitch;                                                                {give time to other threads}
+function  KillThread (threadHandle : dword) : dword;
+function  WaitForThreadTerminate (threadHandle : dword; TimeoutMs : longint) : dword;  {0=no timeout}
+function  ThreadSetPriority (threadHandle : dword; Prio: longint): boolean;            {-15..+15, 0=normal}
+function  ThreadGetPriority (threadHandle : dword): Integer;
+function  GetCurrentThreadHandle : dword;
+
+
 { this allows to do a lot of things in MT safe way }
 { it is also used to make the heap management      }
 { thread safe                                      }
@@ -54,7 +65,10 @@ procedure LeaveCriticalsection(var cs : TRTLCriticalSection);
 
 {
   $Log$
-  Revision 1.9  2002-10-16 19:04:27  michael
+  Revision 1.10  2003-03-27 17:14:27  armin
+  * more platform independent thread routines, needs to be implemented for unix
+
+  Revision 1.9  2002/10/16 19:04:27  michael
   + More system-independent thread routines
 
   Revision 1.8  2002/10/14 19:39:17  peter

rtl/netware/systhrds.pp

@@ -32,6 +32,16 @@ interface
 { Include generic thread interface }
 {$i threadh.inc }
 
+{Delphi/Windows compatible priority constants, they are also defined for Unix and Win32}
+const
+   THREAD_PRIORITY_IDLE          = -15;
+   THREAD_PRIORITY_LOWEST        = -2;
+   THREAD_PRIORITY_BELOW_NORMAL  = -1;
+   THREAD_PRIORITY_NORMAL        = 0;
+   THREAD_PRIORITY_ABOVE_NORMAL  = 1;
+   THREAD_PRIORITY_HIGHEST       = 2;
+   THREAD_PRIORITY_TIME_CRITICAL = 15;
+
 implementation
 
 {$i thread.inc }
@@ -198,6 +208,73 @@ begin
 end;
 
 
+{*****************************************************************************
+                            Thread handling
+*****************************************************************************}
+
+
+function __SuspendThread (threadId : dword) : dword; cdecl; external 'clib' name 'SuspendThread';
+function __ResumeThread (threadId : dword) : dword; cdecl; external 'clib' name 'ResumeThread';
+procedure __ThreadSwitchWithDelay; cdecl; external 'clib' name 'ThreadSwitchWithDelay';
+
+{redefined because the interface has not cdecl calling convention}
+function SuspendThread (threadHandle : dword) : dword;
+begin
+  SuspendThread := __SuspendThread (threadHandle);
+end;
+
+
+function ResumeThread (threadHandle : dword) : dword;
+begin
+  ResumeThread := __ResumeThread (threadHandle);
+end;
+
+
+procedure ThreadSwitch;
+begin
+  __ThreadSwitchWithDelay;
+end;
+
+
+function  KillThread (threadHandle : dword) : dword;
+begin
+  KillThread := 1;  {not supported for netware}
+end;
+
+function GetThreadName  (threadId : longint; var threadName) : longint; cdecl; external 'clib' name 'GetThreadName';
+//function __RenameThread (threadId : longint; threadName:pchar) : longint; cdecl; external 'clib' name 'RenameThread';
+
+function  WaitForThreadTerminate (threadHandle : dword; TimeoutMs : longint) : dword;
+var
+  status : longint;
+  buf : array [0..50] of char;
+begin
+  {$warning timeout needs to be implemented}
+  repeat
+    status := GetThreadName (ThreadHandle,Buf); {should return EBADHNDL if thread is terminated}
+    ThreadSwitch;
+  until status <> 0;
+  WaitForThreadTerminate:=0;
+end;
+
+function  ThreadSetPriority (threadHandle : dword; Prio: longint): boolean; {-15..+15, 0=normal}
+begin
+  ThreadSetPriority := true;
+end;
+
+function  ThreadGetPriority (threadHandle : dword): Integer;
+begin
+  ThreadGetPriority := 0;
+end;
+
+function GetThreadID : dword; cdecl; external 'clib' name 'GetThreadID';
+
+function  GetCurrentThreadHandle : dword;
+begin
+  GetCurrentThreadHandle := GetThreadID;
+end;
+
+
 { netware requires all allocated semaphores }
 { to be closed before terminating the nlm, otherwise }
 { the server will abend (except for netware 6 i think) }
@@ -329,20 +406,20 @@ end;
 {*****************************************************************************
                            Heap Mutex Protection
 *****************************************************************************}
-			   
+			
 var
   HeapMutex : TRTLCriticalSection;
-				     
+				
 procedure NWHeapMutexInit;
 begin
   InitCriticalSection(heapmutex);
 end;
-							      
+							
 procedure NWHeapMutexDone;
 begin
   DoneCriticalSection(heapmutex);
 end;
-										       
+										
 procedure NWHeapMutexLock;
 begin
   EnterCriticalSection(heapmutex);
@@ -352,7 +429,7 @@ procedure NWHeapMutexUnlock;
 begin
   LeaveCriticalSection(heapmutex);
 end;
-																 
+																
 const
   NWMemoryMutexManager : TMemoryMutexManager = (
            MutexInit : @NWHeapMutexInit;
@@ -360,7 +437,7 @@ const
            MutexLock : @NWHeapMutexLock;
     	   MutexUnlock : @NWHeapMutexUnlock;
   );
-																							 
+																							
 procedure InitHeapMutexes;
 begin
   SetMemoryMutexManager(NWMemoryMutexManager);
@@ -377,7 +454,10 @@ end.
 
 {
   $Log$
-  Revision 1.1  2003-02-16 17:12:15  armin
+  Revision 1.2  2003-03-27 17:14:27  armin
+  * more platform independent thread routines, needs to be implemented for unix
+
+  Revision 1.1  2003/02/16 17:12:15  armin
   * systhrds fir netware added
 
 

rtl/unix/systhrds.pp

@@ -46,7 +46,7 @@ interface
 implementation
 
 {*****************************************************************************
-                             Generic overloaded 
+                             Generic overloaded
 *****************************************************************************}
 
 { Include generic overloaded routines }
@@ -296,8 +296,8 @@ CONST
         pthread_create(@threadid, @thread_attr, @ThreadMain,ti);
         BeginThread:=threadid;
       end;
-      
-      
+
+
     procedure EndThread(ExitCode : DWord);
       begin
         DoneThread;
@@ -305,6 +305,49 @@ CONST
       end;
 
 
+    function  SuspendThread (threadHandle : dword) : dword;
+    begin
+      {$Warning SuspendThread needs to be implemented}
+    end;
+
+    function  ResumeThread  (threadHandle : dword) : dword;
+    begin
+      {$Warning ResumeThread needs to be implemented}
+    end;
+
+    procedure ThreadSwitch;  {give time to other threads}
+    begin
+      {extern int pthread_yield (void) __THROW;}
+      {$Warning ThreadSwitch needs to be implemented}
+    end;
+
+    function  KillThread (threadHandle : dword) : dword;
+    begin
+      {$Warning KillThread needs to be implemented}
+    end;
+
+    function  WaitForThreadTerminate (threadHandle : dword; TimeoutMs : longint) : dword;  {0=no timeout}
+    begin
+      {$Warning WaitForThreadTerminate needs to be implemented}
+    end;
+
+    function  ThreadSetPriority (threadHandle : dword; Prio: longint): boolean; {-15..+15, 0=normal}
+    begin
+      {$Warning ThreadSetPriority needs to be implemented}
+    end;
+
+
+    function  ThreadGetPriority (threadHandle : dword): Integer;
+    begin
+      {$Warning ThreadGetPriority needs to be implemented}
+    end;
+
+    function  GetCurrentThreadHandle : dword;
+    begin
+      {$Warning ThreadGetPriority needs to be implemented}
+    end;
+
+
 {*****************************************************************************
                           Delphi/Win32 compatibility
 *****************************************************************************}
@@ -382,7 +425,10 @@ initialization
 end.
 {
   $Log$
-  Revision 1.7  2003-01-05 19:11:32  marco
+  Revision 1.8  2003-03-27 17:14:27  armin
+  * more platform independent thread routines, needs to be implemented for unix
+
+  Revision 1.7  2003/01/05 19:11:32  marco
    * small changes originating from introduction of Baseunix to FreeBSD
 
   Revision 1.6  2002/11/11 21:41:06  marco
@@ -409,4 +455,4 @@ end.
     * threads unit added for thread support
 
 }
-  
+

rtl/win32/systhrds.pp

@@ -73,6 +73,15 @@ procedure ExitThread(dwExitCode : DWord);
 function GlobalAlloc(uFlags:DWord; dwBytes:DWORD):Pointer;
   external 'kernel32' name 'GlobalAlloc';
 function GlobalFree(hMem : Pointer):Pointer; external 'kernel32' name 'GlobalFree';
+procedure Sleep(dwMilliseconds: DWord); external 'kernel32' name 'Sleep';
+function  SuspendThread (threadHandle : dword) : dword; external 'kernel32' name 'SuspendThread';
+function  ResumeThread  (threadHandle : dword) : dword; external 'kernel32' name 'ResumeThread';
+function  TerminateThread  (threadHandle : dword; var exitCode : dword) : boolean; external 'kernel32' name 'TerminateThread';
+function  GetLastError : dword; external 'kernel32' name 'GetLastError';
+function  WaitForSingleObject (hHandle,Milliseconds: dword): dword; external 'kernel32' name 'WaitForSingleObject';
+function  ThreadSetPriority (threadHandle : dword; Prio: longint): boolean; external 'kernel32' name 'SetThreadPriority';
+function  ThreadGetPriority (threadHandle : dword): Integer; external 'kernel32' name 'GetThreadPriority';
+function  GetCurrentThreadHandle : dword; external 'kernel32' name 'GetCurrentThread';
 
 {*****************************************************************************
                              Threadvar support
@@ -209,6 +218,29 @@ function GlobalFree(hMem : Pointer):Pointer; external 'kernel32' name 'GlobalFre
       end;
 
 
+    procedure ThreadSwitch;
+    begin
+      Sleep(0);
+    end;
+
+
+    function  KillThread (threadHandle : dword) : dword;
+    var exitCode : dword;
+    begin
+      if not TerminateThread (threadHandle, exitCode) then
+        KillThread := GetLastError
+      else
+        KillThread := 0;
+    end;
+
+    function  WaitForThreadTerminate (threadHandle : dword; TimeoutMs : longint) : dword;
+    begin
+      if timeoutMs = 0 then dec (timeoutMs);  // $ffffffff is INFINITE
+      WaitForThreadTerminate := WaitForSingleObject(threadHandle, TimeoutMs);
+    end;
+
+
+
 {*****************************************************************************
                           Delphi/Win32 compatibility
 *****************************************************************************}
@@ -274,7 +306,10 @@ initialization
 end.
 {
   $Log$
-  Revision 1.3  2003-03-24 16:12:01  jonas
+  Revision 1.4  2003-03-27 17:14:27  armin
+  * more platform independent thread routines, needs to be implemented for unix
+
+  Revision 1.3  2003/03/24 16:12:01  jonas
     * BeginThread() now returns the thread handle instead of the threadid
       (needed because you have to free the handle after your thread is
        finished, and the threadid is already returned via a var-parameter)
@@ -289,4 +324,4 @@ end.
     * threads unit added for thread support
 
 }
-  
+