diff --git a/fcl/netware/thread.inc b/fcl/netware/thread.inc index 5a04d99c70..eb535583cd 100644 --- a/fcl/netware/thread.inc +++ b/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 diff --git a/rtl/inc/threadh.inc b/rtl/inc/threadh.inc index 1d97087ee2..f084cb6e73 100644 --- a/rtl/inc/threadh.inc +++ b/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 diff --git a/rtl/netware/systhrds.pp b/rtl/netware/systhrds.pp index fe5a5e24e8..bf479e9c42 100644 --- a/rtl/netware/systhrds.pp +++ b/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 diff --git a/rtl/unix/systhrds.pp b/rtl/unix/systhrds.pp index 289980e01b..aedf1b4861 100644 --- a/rtl/unix/systhrds.pp +++ b/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 } - \ No newline at end of file + diff --git a/rtl/win32/systhrds.pp b/rtl/win32/systhrds.pp index a995ababce..d3c663040d 100644 --- a/rtl/win32/systhrds.pp +++ b/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 } - +