+ initial release

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
+
+}

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
+
+}