diff --git a/rtl/inc/threadh.inc b/rtl/inc/threadh.inc new file mode 100644 index 0000000000..9f72d538b9 --- /dev/null +++ b/rtl/inc/threadh.inc @@ -0,0 +1,48 @@ +{ + $Id$ + This file is part of the Free Pascal Run time library. + Copyright (c) 2000 by the Free Pascal development team + + This File contains the OS indenpendend declartions for multi + threading support in FPC + + 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. + + **********************************************************************} + + +{***************************************************************************** + Multithread Handling +*****************************************************************************} +function BeginThread(sa : Pointer;stacksize : dword; + ThreadFunction : tthreadfunc;p : pointer;creationFlags : dword; + var ThreadId : DWord) : DWord; + +{ add some simplfied forms which make lifer easier and porting } +{ to other OSes too ... } +function BeginThread(ThreadFunction : tthreadfunc) : DWord; +function BeginThread(ThreadFunction : tthreadfunc;p : pointer) : DWord; +function BeginThread(ThreadFunction : tthreadfunc;p : pointer; + var ThreadId : DWord) : DWord; + +procedure EndThread(ExitCode : DWord); +procedure EndThread; + +{ 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 : tcriticalsection); +procedure DoneCriticalsection(var cs : tcriticalsection); +procedure EnterCriticalsection(var cs : tcriticalsection); +procedure LeaveCriticalsection(var cs : tcriticalsection); +{ + $Log$ + Revision 1.1 2001-01-01 19:06:59 florian + + initial release + +} \ No newline at end of file diff --git a/rtl/win32/thread.inc b/rtl/win32/thread.inc new file mode 100644 index 0000000000..f9ce5d2ce4 --- /dev/null +++ b/rtl/win32/thread.inc @@ -0,0 +1,222 @@ +{ + $Id$ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team. + + Multithreading implementation for Win32 + + 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. + + **********************************************************************} +const + threadvarblocksize : dword = 0; + +type + tthreadinfo = record + f : tthreadfunc; + p : pointer; + end; + pthreadinfo = ^tthreadinfo; + +var + dataindex : dword; + +{ import the necessary stuff from windows } +function TlsAlloc : DWord;external 'kernel32' name 'TlsAlloc'; +function TlsGetValue(dwTlsIndex : DWord) : pointer; + external 'kernel32' name 'TlsGetValue'; +function TlsSetValue(dwTlsIndex : DWord;lpTlsValue : pointer) : LongBool; + external 'kernel32' name 'TlsSetValue'; +function TlsFree(dwTlsIndex : DWord) : LongBool; + external 'kernel32' name 'TlsFree'; +function CreateThread(lpThreadAttributes : pointer; + dwStackSize : DWord; lpStartAddress : pointer;lpParameter : pointer; + dwCreationFlags : DWord;var lpThreadId : DWord) : THandle; + external 'kernel32' name 'CreateThread'; +procedure ExitThread(dwExitCode : DWord); + external 'kernel32' name 'ExitThread'; + +procedure init_threadvar(var offset : dword;size : dword);[public,alias: 'FPC_INIT_THREADVAR']; + + begin + offset:=threadvarblocksize; + inc(threadvarblocksize,size); + end; + + +function relocate_threadvar(offset : dword) : pointer;[public,alias: 'FPC_RELOCATE_THREADVAR']; + + begin + relocate_threadvar:=TlsGetValue(dataindex)+offset; + end; + +procedure AllocateThreadVars; + + var + threadvars : pointer; + + begin + { we've to allocate the memory from windows } + { 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:=pointer(GlobalAlloc(GMEM_FIXED or GMEM_ZEROINIT, + threadvarblocksize)); + TlsSetValue(dataindex,threadvars); + 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; + + var + threadvars : pointer; + + begin + { release thread vars } + threadvars:=TlsGetValue(dataindex); + GlobalFree(threadvars); + end; + +function ThreadMain(param : pointer) : dword;stdcall; + + 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); + 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} + IsMultithreaded:=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:=CreateThread(sa,stacksize,@ThreadMain,ti, + creationflags,threadid); + 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); + end; + +procedure EndThread; + + begin + EndThread(0); + end; + +{ we implement these procedures for win32 by importing them } +{ directly from windows } + +procedure InitCriticalsection(var cs : tcriticalsection); + + begin + end; + +procedure DoneCriticalsection(var cs : tcriticalsection); + + begin + end; + +procedure EnterCriticalsection(var cs : tcriticalsection); + + begin + end; + +procedure LeaveCriticalsection(var cs : tcriticalsection); + + begin + end; + +{ +procedure InitCriticalSection(var cs : tcriticalsection); + external 'kernel32' name 'InitializeCriticalSection'; + +procedure DoneCriticalSection(var cs : tcriticalsection); + external 'kernel32' name 'DeleteCriticalSection'; + +procedure EnterCriticalSection(var cs : tcriticalsection); + external 'kernel32' name 'EnterCriticalSection'; + +procedure LeaveCriticalSection(var cs : tcriticalsection); + external 'kernel32' name 'LeaveCriticalSection'; +} +{ + $Log$ + Revision 1.1 2001-01-01 19:06:36 florian + + initial release + +} \ No newline at end of file