* threads unit added for thread support

rtl/go32v2/dpmiexcp.pp

@@ -1437,14 +1437,6 @@ end.
 {$else IN_SYSTEM}
 
 const
-  FPU_Invalid = 1;
-  FPU_Denormal = 2;
-  FPU_DivisionByZero = 4;
-  FPU_Overflow = 8;
-  FPU_Underflow = $10;
-  FPU_StackUnderflow = $20;
-  FPU_StackOverflow = $40;
-  FPU_ExceptionMask = $ff;
   FPU_ControlWord : word = $1332;
 
 
@@ -1545,7 +1537,10 @@ end;
 {$endif IN_SYSTEM}
 {
   $Log$
-  Revision 1.10  2002-09-07 16:01:18  peter
+  Revision 1.11  2002-10-14 19:39:16  peter
+    * threads unit added for thread support
+
+  Revision 1.10  2002/09/07 16:01:18  peter
     * old logs removed and tabs fixed
 
   Revision 1.9  2002/02/03 09:51:41  peter

rtl/go32v2/system.pp

@@ -85,19 +85,6 @@ const
   LFNSupport = false;
 {$endif RTLLITE}
 
-type
-   { the fields of this record are os dependent  }
-   { and they shouldn't be used in a program     }
-   { only the type TCriticalSection is important }
-   TRTLCriticalSection = packed record
-      DebugInfo : pointer;
-      LockCount : longint;
-      RecursionCount : longint;
-      OwningThread : DWord;
-      LockSemaphore : DWord;
-      Reserved : DWord;
-   end;
-
 type
 { Dos Extender info }
   p_stub_info = ^t_stub_info;
@@ -1450,18 +1437,24 @@ begin
   CheckLFN:=(regs.realflags and carryflag=0) and (regs.realebx and $4000=$4000);
 end;
 
-{$ifdef MT}
-{$I thread.inc}
-{$endif MT}
-
 {$ifdef  EXCEPTIONS_IN_SYSTEM}
 {$define IN_SYSTEM}
 {$i dpmiexcp.pp}
 {$endif  EXCEPTIONS_IN_SYSTEM}
 
+procedure SysInitStdIO;
+begin
+  OpenStdIO(Input,fmInput,StdInputHandle);
+  OpenStdIO(Output,fmOutput,StdOutputHandle);
+  OpenStdIO(StdOut,fmOutput,StdOutputHandle);
+  OpenStdIO(StdErr,fmOutput,StdErrorHandle);
+end;
+
+
 var
   temp_int : tseginfo;
 Begin
+  StackLength := InitialStkLen;
   StackBottom := __stkbottom;
   { To be set if this is a GUI or console application }
   IsConsole := TRUE;
@@ -1479,18 +1472,9 @@ Begin
 {$endif EXCEPTIONS_IN_SYSTEM}
 { Setup heap }
   InitHeap;
-{$ifdef MT}
-  { before this, you can't use thread vars !!!! }
-  { threadvarblocksize is calculate before the initialization }
-  { of the system unit                                        }
-  mainprogramthreadblock :=  sysgetmem(threadvarblocksize);
-{$endif MT}
-  InitExceptions;
+  SysInitExceptions;
 { Setup stdin, stdout and stderr }
-  OpenStdIO(Input,fmInput,StdInputHandle);
-  OpenStdIO(Output,fmOutput,StdOutputHandle);
-  OpenStdIO(StdOut,fmOutput,StdOutputHandle);
-  OpenStdIO(StdErr,fmOutput,StdErrorHandle);
+  SysInitStdIO;
 { Setup environment and arguments }
   Setup_Environment;
   Setup_Arguments;
@@ -1510,7 +1494,10 @@ Begin
 End.
 {
   $Log$
-  Revision 1.22  2002-10-13 09:28:44  florian
+  Revision 1.23  2002-10-14 19:39:16  peter
+    * threads unit added for thread support
+
+  Revision 1.22  2002/10/13 09:28:44  florian
     + call to initvariantmanager inserted
 
   Revision 1.21  2002/09/07 21:32:08  carl

rtl/i386/i386.inc

@@ -1139,7 +1139,6 @@ function declocked(var l : longint) : boolean;assembler;
 
   asm
      movl       l,%edi
-{$ifdef MT}
      { this check should be done because a lock takes a lot }
      { of time!                                             }
      cmpb       $0,IsMultithread
@@ -1148,7 +1147,6 @@ function declocked(var l : longint) : boolean;assembler;
      decl       (%edi)
      jmp        .Ldeclockedend
 .Ldeclockednolock:
-{$endif MT}
      decl       (%edi);
 .Ldeclockedend:
      setzb      %al
@@ -1158,7 +1156,6 @@ procedure inclocked(var l : longint);assembler;
 
   asm
      movl       l,%edi
-{$ifdef MT}
      { this check should be done because a lock takes a lot }
      { of time!                                             }
      cmpb       $0,IsMultithread
@@ -1167,14 +1164,41 @@ procedure inclocked(var l : longint);assembler;
      incl       (%edi)
      jmp        .Linclockedend
 .Linclockednolock:
-{$endif MT}
      incl       (%edi)
 .Linclockedend:
   end ['EDI'];
 
+{****************************************************************************
+                                  FPU
+****************************************************************************}
+
+const
+  fpucw : word = $1332;
+  { Internal constants for use in system unit }
+  FPU_Invalid = 1;
+  FPU_Denormal = 2;
+  FPU_DivisionByZero = 4;
+  FPU_Overflow = 8;
+  FPU_Underflow = $10;
+  FPU_StackUnderflow = $20;
+  FPU_StackOverflow = $40;
+  FPU_ExceptionMask = $ff;
+
+{$define FPC_SYSTEM_HAS_SYSRESETFPU}
+Procedure SysResetFPU;assembler;{$ifdef SYSTEMINLINE}inline;{$endif}
+asm
+    fninit
+    fldcw   fpucw
+end;
+
+
+
 {
   $Log$
-  Revision 1.32  2002-10-05 14:20:16  peter
+  Revision 1.33  2002-10-14 19:39:16  peter
+    * threads unit added for thread support
+
+  Revision 1.32  2002/10/05 14:20:16  peter
     * fpc_pchar_length compilerproc and strlen alias
 
   Revision 1.31  2002/10/02 18:21:51  peter

rtl/inc/except.inc

@@ -39,11 +39,11 @@ Type
 
 Const
   CatchAllExceptions = -1;
-{$ifdef MT}
+{$ifdef SUPPORT_THREADVAR}
 ThreadVar
-{$else MT}
+{$else SUPPORT_THREADVAR}
 Var
-{$endif MT}
+{$endif SUPPORT_THREADVAR}
   ExceptAddrStack   : PExceptAddr;
   ExceptObjectStack : PExceptObject;
 
@@ -271,7 +271,7 @@ begin
 end;
 
 
-Procedure InitExceptions;
+Procedure SysInitExceptions;
 {
   Initialize exceptionsupport
 }
@@ -281,7 +281,10 @@ begin
 end;
 {
   $Log$
-  Revision 1.8  2002-09-07 15:07:45  peter
+  Revision 1.9  2002-10-14 19:39:17  peter
+    * threads unit added for thread support
+
+  Revision 1.8  2002/09/07 15:07:45  peter
     * old logs removed and tabs fixed
 
 }

rtl/inc/generic.inc

@@ -939,9 +939,22 @@ begin
 end;
 
 {$endif ndef FPC_SYSTEM_HAS_INT_STR_LONGWORD}
+
+{$ifndef FPC_SYSTEM_HAS_SYSRESETFPU}
+
+procedure SysResetFpu;
+begin
+  { nothing todo }
+end;
+
+{$endif FPC_SYSTEM_HAS_SYSRESETFPU}
+
 {
   $Log$
-  Revision 1.41  2002-10-12 20:32:41  carl
+  Revision 1.42  2002-10-14 19:39:17  peter
+    * threads unit added for thread support
+
+  Revision 1.41  2002/10/12 20:32:41  carl
     * RunError 220 -> RunError 219 to be more consistent with as operator
 
   Revision 1.40  2002/10/10 16:08:50  florian

rtl/inc/heap.inc

@@ -37,11 +37,6 @@
 {$define TestFreeLists}
 {$endif SYSTEMDEBUG}
 
-{$ifdef MT}
-var
-   cs_systemheap : TRTLCriticalSection;
-{$endif MT}
-
 const
   blocksize    = 16;  { at least size of freerecord }
   blockshr     = 4;   { shr value for blocksize=2^blockshr}
@@ -59,6 +54,12 @@ const
   {$define DUMPBLOCKS}
 {$endif}
 
+{ Forward defines }
+procedure SysHeapMutexInit;forward;
+procedure SysHeapMutexDone;forward;
+procedure SysHeapMutexLock;forward;
+procedure SysHeapMutexUnlock;forward;
+
 { Memory manager }
 const
   MemoryManager: TMemoryManager = (
@@ -73,6 +74,13 @@ const
     HeapSize: @SysHeapSize;
   );
 
+  MemoryMutexManager: TMemoryMutexManager = (
+    MutexInit: @SysHeapMutexInit;
+    MutexDone: @SysHeapMutexDone;
+    MutexLock: @SysHeapMutexLock;
+    MutexUnlock: @SysHeapMutexUnlock;
+  );
+
 type
   ppfreerecord = ^pfreerecord;
   pfreerecord  = ^tfreerecord;
@@ -111,20 +119,30 @@ const
                              Memory Manager
 *****************************************************************************}
 
+procedure SetMemoryMutexManager(var MutexMgr: TMemoryMutexManager);
+begin
+  { Release old mutexmanager, the default manager does nothing so
+    calling this without initializing is safe }
+  MutexMgr.MutexDone;
+  { Copy new mutexmanager }
+  MemoryMutexManager:=MutexMgr;
+  { Init new mutexmanager }
+  MutexMgr.MutexInit;
+end;
+
+
 procedure GetMemoryManager(var MemMgr:TMemoryManager);
 begin
-{$ifdef MT}
   if IsMultiThread then
    begin
      try
-       EnterCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexLock;
        MemMgr:=MemoryManager;
      finally
-       LeaveCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexUnlock;
      end;
    end
   else
-{$endif MT}
    begin
      MemMgr:=MemoryManager;
    end;
@@ -133,18 +151,16 @@ end;
 
 procedure SetMemoryManager(const MemMgr:TMemoryManager);
 begin
-{$ifdef MT}
   if IsMultiThread then
    begin
      try
-       EnterCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexLock;
        MemoryManager:=MemMgr;
      finally
-       LeaveCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexUnlock;
      end;
    end
   else
-{$endif MT}
    begin
      MemoryManager:=MemMgr;
    end;
@@ -153,19 +169,17 @@ end;
 
 function IsMemoryManagerSet:Boolean;
 begin
-{$ifdef MT}
   if IsMultiThread then
    begin
      try
-       EnterCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexLock;
        IsMemoryManagerSet:=(MemoryManager.GetMem<>@SysGetMem) or
                            (MemoryManager.FreeMem<>@SysFreeMem);
      finally
-       LeaveCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexUnlock;
      end;
    end
   else
-{$endif MT}
    begin
      IsMemoryManagerSet:=(MemoryManager.GetMem<>@SysGetMem) or
                          (MemoryManager.FreeMem<>@SysFreeMem);
@@ -175,18 +189,16 @@ end;
 
 procedure GetMem(Var p:pointer;Size:Longint);
 begin
-{$ifdef MT}
   if IsMultiThread then
    begin
      try
-       EnterCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexLock;
        p:=MemoryManager.GetMem(Size);
      finally
-       LeaveCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexUnlock;
      end;
    end
   else
-{$endif MT}
    begin
      p:=MemoryManager.GetMem(Size);
    end;
@@ -195,18 +207,16 @@ end;
 
 procedure FreeMem(p:pointer;Size:Longint);
 begin
-{$ifdef MT}
   if IsMultiThread then
    begin
      try
-       EnterCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexLock;
        MemoryManager.FreeMemSize(p,Size);
      finally
-       LeaveCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexUnlock;
      end;
    end
   else
-{$endif MT}
    begin
      MemoryManager.FreeMemSize(p,Size);
    end;
@@ -215,18 +225,16 @@ end;
 
 function MaxAvail:Longint;
 begin
-{$ifdef MT}
   if IsMultiThread then
    begin
      try
-       EnterCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexLock;
        MaxAvail:=MemoryManager.MaxAvail();
      finally
-       LeaveCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexUnlock;
      end;
    end
   else
-{$endif MT}
    begin
      MaxAvail:=MemoryManager.MaxAvail();
    end;
@@ -235,18 +243,16 @@ end;
 
 function MemAvail:Longint;
 begin
-{$ifdef MT}
   if IsMultiThread then
    begin
      try
-       EnterCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexLock;
        MemAvail:=MemoryManager.MemAvail();
      finally
-       LeaveCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexUnlock;
      end;
    end
   else
-{$endif MT}
    begin
      MemAvail:=MemoryManager.MemAvail();
    end;
@@ -256,18 +262,16 @@ end;
 { FPC Additions }
 function HeapSize:Longint;
 begin
-{$ifdef MT}
   if IsMultiThread then
    begin
      try
-       EnterCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexLock;
        HeapSize:=MemoryManager.HeapSize();
      finally
-       LeaveCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexUnlock;
      end;
    end
   else
-{$endif MT}
    begin
      HeapSize:=MemoryManager.HeapSize();
    end;
@@ -276,18 +280,16 @@ end;
 
 function MemSize(p:pointer):Longint;
 begin
-{$ifdef MT}
   if IsMultiThread then
    begin
      try
-       EnterCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexLock;
        MemSize:=MemoryManager.MemSize(p);
      finally
-       LeaveCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexUnlock;
      end;
    end
   else
-{$endif MT}
    begin
      MemSize:=MemoryManager.MemSize(p);
    end;
@@ -297,18 +299,16 @@ end;
 { Delphi style }
 function FreeMem(p:pointer):Longint;
 begin
-{$ifdef MT}
   if IsMultiThread then
    begin
      try
-       EnterCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexLock;
        Freemem:=MemoryManager.FreeMem(p);
      finally
-       LeaveCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexUnlock;
      end;
    end
   else
-{$endif MT}
    begin
      Freemem:=MemoryManager.FreeMem(p);
    end;
@@ -317,18 +317,16 @@ end;
 
 function GetMem(size:longint):pointer;
 begin
-{$ifdef MT}
   if IsMultiThread then
    begin
      try
-       EnterCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexLock;
        GetMem:=MemoryManager.GetMem(Size);
      finally
-       LeaveCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexUnlock;
      end;
    end
   else
-{$endif MT}
    begin
      GetMem:=MemoryManager.GetMem(Size);
    end;
@@ -337,18 +335,16 @@ end;
 
 function AllocMem(Size:Longint):pointer;
 begin
-{$ifdef MT}
   if IsMultiThread then
    begin
      try
-       EnterCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexLock;
        AllocMem:=MemoryManager.AllocMem(size);
      finally
-       LeaveCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexUnlock;
      end;
    end
   else
-{$endif MT}
    begin
      AllocMem:=MemoryManager.AllocMem(size);
    end;
@@ -357,18 +353,16 @@ end;
 
 function ReAllocMem(var p:pointer;Size:Longint):pointer;
 begin
-{$ifdef MT}
   if IsMultiThread then
    begin
      try
-       EnterCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexLock;
        ReAllocMem:=MemoryManager.ReAllocMem(p,size);
      finally
-       LeaveCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexUnlock;
      end;
    end
   else
-{$endif MT}
    begin
      ReAllocMem:=MemoryManager.ReAllocMem(p,size);
    end;
@@ -380,18 +374,16 @@ end;
 { Needed for calls from Assembler }
 function fpc_getmem(size:longint):pointer;compilerproc;[public,alias:'FPC_GETMEM'];
 begin
-{$ifdef MT}
   if IsMultiThread then
    begin
      try
-       EnterCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexLock;
        fpc_GetMem:=MemoryManager.GetMem(size);
      finally
-       LeaveCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexUnlock;
      end;
    end
   else
-{$endif MT}
    begin
      fpc_GetMem:=MemoryManager.GetMem(size);
    end;
@@ -411,19 +403,17 @@ end;
 
 procedure fpc_freemem(p:pointer);compilerproc;[public,alias:'FPC_FREEMEM'];
 begin
-{$ifdef MT}
   if IsMultiThread then
    begin
      try
-       EnterCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexLock;
        if p <> nil then
          MemoryManager.FreeMem(p);
      finally
-       LeaveCriticalSection(cs_systemheap);
+       MemoryMutexManager.MutexUnlock;
      end;
    end
   else
-{$endif MT}
    begin
      if p <> nil then
        MemoryManager.FreeMem(p);
@@ -914,16 +904,19 @@ end;
 
 function SysMemSize(p:pointer):longint;
 begin
-{$ifdef MT}
-  try
-    EnterCriticalSection(cs_systemheap);
-{$endif MT}
-  SysMemSize:=(pheaprecord(pointer(p)-sizeof(theaprecord))^.size and sizemask)-sizeof(theaprecord);
-{$ifdef MT}
-  finally
-    LeaveCriticalSection(cs_systemheap);
-  end;
-{$endif MT}
+  if IsMultiThread then
+   begin
+     try
+       MemoryMutexManager.MutexLock;
+       SysMemSize:=(pheaprecord(pointer(p)-sizeof(theaprecord))^.size and sizemask)-sizeof(theaprecord);
+     finally
+       MemoryMutexManager.MutexUnlock;
+     end;
+   end
+  else
+   begin
+     SysMemSize:=(pheaprecord(pointer(p)-sizeof(theaprecord))^.size and sizemask)-sizeof(theaprecord);
+   end;
 end;
 
 
@@ -1232,6 +1225,35 @@ begin
 end;
 
 
+{*****************************************************************************
+                       MemoryMutexManager default hooks
+*****************************************************************************}
+
+procedure SysHeapMutexInit;
+begin
+  { nothing todo }
+end;
+
+procedure SysHeapMutexDone;
+begin
+  { nothing todo }
+end;
+
+procedure SysHeapMutexLock;
+begin
+  { give an runtime error. the program is running multithreaded without
+    any heap protection. this will result in unpredictable errors so
+    stopping here with an error is more safe (PFV) }
+  runerror(244);
+end;
+
+procedure SysHeapMutexUnLock;
+begin
+  { see SysHeapMutexLock for comment }
+  runerror(244);
+end;
+
+
 {*****************************************************************************
                                  InitHeap
 *****************************************************************************}
@@ -1250,14 +1272,14 @@ begin
   HeapPtr:=HeapOrg;
   HeapEnd:=HeapOrg+internal_memavail;
   HeapError:=@GrowHeap;
-{$ifdef MT}
-  InitCriticalSection(cs_systemheap);
-{$endif MT}
 end;
 
 {
   $Log$
-  Revision 1.15  2002-09-07 15:07:45  peter
+  Revision 1.16  2002-10-14 19:39:17  peter
+    * threads unit added for thread support
+
+  Revision 1.15  2002/09/07 15:07:45  peter
     * old logs removed and tabs fixed
 
   Revision 1.14  2002/06/17 08:33:04  jonas

rtl/inc/heaph.inc

@@ -28,9 +28,16 @@ type
     MaxAvail    : Function:Longint;
     HeapSize    : Function:Longint;
   end;
+  TMemoryMutexManager = record
+    MutexInit : procedure;
+    MutexDone : procedure;
+    MutexLock : procedure;
+    MutexUnlock : procedure;
+  end;
 procedure GetMemoryManager(var MemMgr: TMemoryManager);
 procedure SetMemoryManager(const MemMgr: TMemoryManager);
 function  IsMemoryManagerSet: Boolean;
+procedure SetMemoryMutexManager(var MutexMgr: TMemoryMutexManager);
 
 { Variables }
 const
@@ -82,7 +89,10 @@ Procedure AsmFreemem(var p:pointer);
 
 {
   $Log$
-  Revision 1.4  2002-09-07 15:07:45  peter
+  Revision 1.5  2002-10-14 19:39:17  peter
+    * threads unit added for thread support
+
+  Revision 1.4  2002/09/07 15:07:45  peter
     * old logs removed and tabs fixed
 
 }

rtl/inc/system.inc

@@ -47,7 +47,7 @@ const
 { Used by the ansistrings and maybe also other things in the future }
 var
   emptychar : char;public name 'FPC_EMPTYCHAR';
-  stacklength : longint;external name '__stklen';
+  initialstklen : longint;external name '__stklen';
 
 
 {****************************************************************************
@@ -454,15 +454,15 @@ End;
 {$DEFINE STACKCHECK}
 {$ENDIF}
 {$S-}
-procedure fpc_stackcheck(stack_size:longint);[saveregisters,public,alias:'FPC_STACKCHECK'];
+procedure fpc_stackcheck(stack_size:Cardinal);[saveregisters,public,alias:'FPC_STACKCHECK'];
 var
- c: cardinal;
+  c : cardinal;
 begin
   { Avoid recursive calls when called from the exit routines }
   if StackError then
    exit;
-  c := cardinal(Sptr) - cardinal(stack_size) - STACK_MARGIN;
-  if (c <= cardinal(StackBottom)) then
+  c := cardinal(Sptr) - stack_size - STACK_MARGIN;
+  if (c <= StackBottom) then
    begin
      StackError:=true;
      HandleError(202);
@@ -757,7 +757,10 @@ end;
 
 {
   $Log$
-  Revision 1.35  2002-09-18 18:32:01  carl
+  Revision 1.36  2002-10-14 19:39:17  peter
+    * threads unit added for thread support
+
+  Revision 1.35  2002/09/18 18:32:01  carl
     * assert now halts with exitcode 227 (as Delphi does)
 
   Revision 1.34  2002/09/07 15:07:46  peter

rtl/inc/systemh.inc

@@ -28,6 +28,11 @@
   {$define SYSTEMINLINE}
 {$endif}
 
+{ Use threadvars when the compiler supports it }
+{$ifdef HASTHREADVAR}
+  {$define SUPPORT_THREADVAR}
+{$endif HASTHREADVAR}
+
 { don't use FPU registervariables on the i386 }
 {$ifdef i386}
   {$maxfpuregisters 0}
@@ -247,30 +252,35 @@ const
   Filemode : byte = 2;
   CmdLine : PChar = nil;
 
- { Delphi Compatibility }
- { assume that this program will not spawn other threads. }
+  { assume that this program will not spawn other threads, when the
+    first thread is started the following constants need to be filled }
   IsMultiThread : boolean = FALSE;
- { Indicates if there was an error }
+  { Indicates if there was an error }
   StackError : boolean = FALSE;
 
 var
-{ Standard In- and Output }
-  Output,
-  Input,
-  StdOut,
-  StdErr      : Text;
   ExitCode    : Word;
-  StackBottom,
   RandSeed    : Cardinal;
   { Delphi compatibility }
   IsLibrary : boolean;
   IsConsole : boolean;
-{$ifdef MT}
+  { Threading support }
+  fpc_threadvar_relocate_proc : pointer; public name 'FPC_THREADVAR_RELOCATE';
+
+{$ifdef SUPPORT_THREADVAR}
 ThreadVar
-{$else MT}
+{$else SUPPORT_THREADVAR}
 Var
-{$endif MT}
+{$endif SUPPORT_THREADVAR}
+  { Standard In- and Output }
+  Output,
+  Input,
+  StdOut,
+  StdErr      : Text;
   InOutRes    : Word;
+  { Stack checking }
+  StackBottom,
+  StackLength : Cardinal;
 
 {****************************************************************************
                         Processor specific routines
@@ -556,6 +566,10 @@ Procedure halt(errnum:byte);
 Procedure AddExitProc(Proc:TProcedure);
 Procedure halt;{$ifdef SYSTEMINLINE}inline;{$endif}
 
+{ Need to be exported for threads unit }
+Procedure SysInitExceptions;
+procedure SysInitStdIO;
+Procedure SysResetFPU;
 
 {*****************************************************************************
                          Abstract/Assert/Error Handling
@@ -612,7 +626,10 @@ const
 
 {
   $Log$
-  Revision 1.58  2002-10-06 13:56:47  carl
+  Revision 1.59  2002-10-14 19:39:17  peter
+    * threads unit added for thread support
+
+  Revision 1.58  2002/10/06 13:56:47  carl
     - remove stack checking for every target in system unit
 
   Revision 1.57  2002/10/02 18:21:51  peter

rtl/inc/thread.inc

@@ -0,0 +1,73 @@
+{
+    $Id$
+    This file is part of the Free Pascal Run time library.
+    Copyright (c) 2000 by the Free Pascal development team
+
+    OS independent thread functions/overloads
+
+    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.
+
+ **********************************************************************}
+
+{*****************************************************************************
+                           Threadvar initialization
+*****************************************************************************}
+
+
+{*****************************************************************************
+                            Overloaded functions
+*****************************************************************************}
+
+    function BeginThread(sa : Pointer;stacksize : dword;
+                         ThreadFunction : tthreadfunc;p : pointer;creationFlags : dword;
+                         var ThreadId : Longint) : DWord;
+      begin
+        BeginThread:=BeginThread(nil,DefaultStackSize,ThreadFunction,p,creationFlags,Dword(THreadId));
+      end;
+
+
+    function BeginThread(ThreadFunction : tthreadfunc) : DWord;
+      var
+        dummy : dword;
+      begin
+        BeginThread:=BeginThread(nil,DefaultStackSize,ThreadFunction,nil,0,dummy);
+      end;
+
+
+    function BeginThread(ThreadFunction : tthreadfunc;p : pointer) : DWord;
+      var
+        dummy : dword;
+      begin
+        BeginThread:=BeginThread(nil,DefaultStackSize,ThreadFunction,p,0,dummy);
+      end;
+
+
+    function BeginThread(ThreadFunction : tthreadfunc;p : pointer;var ThreadId : DWord) : DWord;
+      begin
+        BeginThread:=BeginThread(nil,DefaultStackSize,ThreadFunction,p,0,ThreadId);
+      end;
+
+
+    function BeginThread(ThreadFunction : tthreadfunc;p : pointer;var ThreadId : Longint) : DWord;
+      begin
+        BeginThread:=BeginThread(nil,DefaultStackSize,ThreadFunction,p,0,Dword(ThreadId));
+      end;
+
+
+    procedure EndThread;
+      begin
+        EndThread(0);
+      end;
+
+
+{
+  $Log$
+  Revision 1.1  2002-10-14 19:39:17  peter
+    * threads unit added for thread support
+
+}

rtl/inc/threadh.inc

@@ -15,12 +15,13 @@
 
  **********************************************************************}
 
-{$ifdef MT}
 type
    TThreadFunc = function(parameter : pointer) : longint;
+
 {*****************************************************************************
                          Multithread Handling
 *****************************************************************************}
+
 function BeginThread(sa : Pointer;stacksize : dword;
   ThreadFunction : tthreadfunc;p : pointer;creationFlags : dword;
   var ThreadId : DWord) : DWord;
@@ -33,10 +34,8 @@ function BeginThread(sa : Pointer;stacksize : dword;
 { 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;
-function BeginThread(ThreadFunction : tthreadfunc;p : pointer;
-  var ThreadId : Longint) : DWord;
+function BeginThread(ThreadFunction : tthreadfunc;p : pointer; var ThreadId : DWord) : DWord;
+function BeginThread(ThreadFunction : tthreadfunc;p : pointer; var ThreadId : Longint) : DWord;
 
 procedure EndThread(ExitCode : DWord);
 procedure EndThread;
@@ -49,11 +48,12 @@ procedure DoneCriticalsection(var cs : TRTLCriticalSection);
 procedure EnterCriticalsection(var cs : TRTLCriticalSection);
 procedure LeaveCriticalsection(var cs : TRTLCriticalSection);
 
-{$endif MT}
-
 {
   $Log$
-  Revision 1.7  2002-09-07 15:07:46  peter
+  Revision 1.8  2002-10-14 19:39:17  peter
+    * threads unit added for thread support
+
+  Revision 1.7  2002/09/07 15:07:46  peter
     * old logs removed and tabs fixed
 
   Revision 1.6  2002/07/28 20:43:48  florian

rtl/inc/threadvar.inc

@@ -0,0 +1,95 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Michael Van Canneyt
+    member of the Free Pascal development team
+
+    Threadvar support, platform independent part
+
+    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.
+
+ **********************************************************************}
+
+
+{*****************************************************************************
+                           Threadvar support
+*****************************************************************************}
+
+{$ifdef HASTHREADVAR}
+
+type
+  pltvInitEntry = ^ltvInitEntry;
+  ltvInitEntry = packed record
+     varaddr : pdword;
+     size    : longint;
+  end;
+
+  TltvInitTablesTable = record
+    count  : dword;
+    tables : array [1..32767] of pltvInitEntry;
+  end;
+
+var
+  ThreadvarTablesTable : TltvInitTablesTable; external name 'FPC_THREADVARTABLES';
+
+procedure init_unit_threadvars (tableEntry : pltvInitEntry);
+begin
+  while tableEntry^.varaddr <> nil do
+   begin
+     SysInitThreadvar (tableEntry^.varaddr^, tableEntry^.size);
+     inc (pchar (tableEntry), sizeof (tableEntry^));
+   end;
+end;
+
+
+procedure init_all_unit_threadvars;
+var
+  i : integer;
+begin
+{$ifdef DEBUG_MT}
+  WriteLn ('init_all_unit_threadvars (',ThreadvarTablesTable.count,') units');
+{$endif}
+  for i := 1 to ThreadvarTablesTable.count do
+    init_unit_threadvars (ThreadvarTablesTable.tables[i]);
+end;
+
+
+procedure copy_unit_threadvars (tableEntry : pltvInitEntry);
+var
+  oldp,
+  newp : pointer;
+begin
+  while tableEntry^.varaddr <> nil do
+   begin
+     newp:=SysRelocateThreadVar(tableEntry^.varaddr^);
+     oldp:=pointer(pchar(tableEntry^.varaddr)+4);
+     move(oldp^,newp^,tableEntry^.size);
+     inc (pchar (tableEntry), sizeof (tableEntry^));
+   end;
+end;
+
+
+procedure copy_all_unit_threadvars;
+var
+  i : integer;
+begin
+{$ifdef DEBUG_MT}
+  WriteLn ('copy_all_unit_threadvars (',ThreadvarTablesTable.count,') units');
+{$endif}
+  for i := 1 to ThreadvarTablesTable.count do
+    copy_unit_threadvars (ThreadvarTablesTable.tables[i]);
+end;
+
+{$endif HASTHREADVAR}
+
+{
+  $Log$
+  Revision 1.1  2002-10-14 19:39:17  peter
+    * threads unit added for thread support
+
+}

rtl/linux/Makefile

@@ -1,5 +1,5 @@
 #
-# Don't edit, this file is generated by FPCMake Version 1.1 [2002/08/24]
+# Don't edit, this file is generated by FPCMake Version 1.1 [2002/10/07]
 #
 default: all
 MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx
@@ -58,6 +58,9 @@ ifdef inUnix
 PATHSEP=/
 else
 PATHSEP:=$(subst /,\,/)
+ifneq ($(findstring sh.exe,$(SHELL)),)
+PATHSEP=/
+endif
 endif
 ifdef PWD
 BASEDIR:=$(subst \,/,$(shell $(PWD)))
@@ -87,7 +90,7 @@ endif
 endif
 export ECHO
 endif
-OS_TARGET=linux
+override OS_TARGET_DEFAULT=linux
 override DEFAULT_FPCDIR=../..
 ifndef FPC
 ifdef PP
@@ -141,6 +144,16 @@ ifndef OS_TARGET
 OS_TARGET:=$(shell $(FPC) -iTO)
 endif
 endif
+ifndef CPU_TARGET
+ifdef CPU_TARGET_DEFAULT
+CPU_TARGET=$(CPU_TARGET_DEFAULT)
+endif
+endif
+ifndef OS_TARGET
+ifdef OS_TARGET_DEFAULT
+OS_TARGET=$(OS_TARGET_DEFAULT)
+endif
+endif
 FULL_TARGET=$(CPU_TARGET)-$(OS_TARGET)
 FULL_SOURCE=$(CPU_SOURCE)-$(OS_SOURCE)
 ifneq ($(FULL_TARGET),$(FULL_SOURCE))
@@ -229,7 +242,7 @@ GRAPHDIR=$(INC)/graph
 ifndef USELIBGGI
 USELIBGGI=NO
 endif
-override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings $(LINUXUNIT) unix initc $(CPU_UNITS) dos crt objects printer ggigraph sysutils typinfo math varutils charset ucomplex getopts heaptrc lineinfo errors sockets gpm ipc serial terminfo dl dynlibs video mouse keyboard variants types
+override TARGET_UNITS+=$(SYSTEMUNIT) threads objpas strings heaptrc lineinfo $(LINUXUNIT) unix initc $(CPU_UNITS) dos crt objects printer ggigraph sysutils typinfo math varutils charset ucomplex getopts errors sockets gpm ipc serial terminfo dl dynlibs video mouse keyboard variants types
 override TARGET_LOADERS+=prt0 dllprt0 cprt0 gprt0 cprt21 gprt21
 override TARGET_RSTS+=math varutils typinfo variants
 override CLEAN_UNITS+=syslinux linux
@@ -1111,6 +1124,7 @@ fpc_baseinfo:
 	@$(ECHO)  Rm........ $(RMPROG)
 	@$(ECHO)  GInstall.. $(GINSTALL)
 	@$(ECHO)  Echo...... $(ECHO)
+	@$(ECHO)  Shell..... $(SHELL)
 	@$(ECHO)  Date...... $(DATE)
 	@$(ECHO)  FPCMake... $(FPCMAKE)
 	@$(ECHO)  PPUMove... $(PPUMOVE)
@@ -1210,6 +1224,7 @@ gprt21$(OEXT) : $(CPU_TARGET)/gprt0.as
 	$(AS) -o gprt21$(OEXT) $(CPU_TARGET)/gprt0.as
 $(SYSTEMUNIT)$(PPUEXT) : $(SYSTEMUNIT).pp sysconst.inc systypes.inc syscalls.inc $(SYSDEPS)
 	$(COMPILER) -Us -Sg $(SYSTEMUNIT).pp
+threads$(PPUEXT): threads.pp $(INC)/threadh.inc $(SYSTEMUNIT)$(PPUEXT)
 objpas$(PPUEXT): $(OBJPASDIR)/objpas.pp $(INC)/except.inc $(SYSTEMUNIT)$(PPUEXT)
 	$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/objpas.pp
 strings$(PPUEXT) : $(INC)/strings.pp $(INC)/stringsi.inc\

rtl/linux/Makefile.fpc

@@ -7,11 +7,12 @@ main=rtl
 
 [target]
 loaders=prt0 dllprt0 cprt0 gprt0 cprt21 gprt21
-units=$(SYSTEMUNIT) objpas strings \
+units=$(SYSTEMUNIT) threads objpas strings \
+      heaptrc lineinfo \
       $(LINUXUNIT) unix initc $(CPU_UNITS) \
       dos crt objects printer ggigraph \
       sysutils typinfo math varutils \
-      charset ucomplex getopts heaptrc lineinfo \
+      charset ucomplex getopts \
       errors sockets gpm ipc serial terminfo dl dynlibs \
       video mouse keyboard variants types
 rsts=math varutils typinfo variants
@@ -137,6 +138,8 @@ gprt21$(OEXT) : $(CPU_TARGET)/gprt0.as
 $(SYSTEMUNIT)$(PPUEXT) : $(SYSTEMUNIT).pp sysconst.inc systypes.inc syscalls.inc $(SYSDEPS)
         $(COMPILER) -Us -Sg $(SYSTEMUNIT).pp
 
+threads$(PPUEXT): threads.pp $(INC)/threadh.inc $(SYSTEMUNIT)$(PPUEXT)
+
 objpas$(PPUEXT): $(OBJPASDIR)/objpas.pp $(INC)/except.inc $(SYSTEMUNIT)$(PPUEXT)
         $(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/objpas.pp
 
@@ -208,7 +211,7 @@ varutils$(PPUEXT) : $(OBJPASDIR)/cvarutil.inc $(OBJPASDIR)/varutils.inc \
         $(COMPILER) -I$(OBJPASDIR) $(UNIXINC)/varutils.pp
 
 types$(PPUEXT) : $(OBJPASDIR/types.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
-	$(COMPILER) $(OBJPASDIR)/types.pp
+        $(COMPILER) $(OBJPASDIR)/types.pp
 
 #
 # Other $(SYSTEMUNIT)-independent RTL Units

rtl/linux/syscalls.inc

@@ -13,159 +13,13 @@
 
  **********************************************************************}
 
-{No debugging for syslinux include !}
-{$IFDEF SYS_LINUX}
-  {$UNDEF SYSCALL_DEBUG}
-{$ENDIF SYS_LINUX}
-
+{ Include syscall itself }
+{$i syscall.inc}
 
 {*****************************************************************************
-                     --- Main:The System Call Self ---
+               --- Time:Time handling related calls ---
 *****************************************************************************}
 
-
-
-Procedure Do_SysCall( callnr:longint;var regs : SysCallregs );assembler;
-{
-  This function puts the registers in place, does the call, and then
-  copies back the registers as they are after the SysCall.
-}
-{$ifdef i386}
-{$ASMMODE ATT}
-{$define fpc_syscall_ok}
-asm
-{ load the registers... }
-  movl 12(%ebp),%eax
-  movl 4(%eax),%ebx
-  movl 8(%eax),%ecx
-  movl 12(%eax),%edx
-  movl 16(%eax),%esi
-  movl 20(%eax),%edi
-{ set the call number }
-  movl 8(%ebp),%eax
-{ Go ! }
-  int $0x80
-{ Put back the registers... }
-  pushl %eax
-  movl 12(%ebp),%eax
-  movl %edi,20(%eax)
-  movl %esi,16(%eax)
-  movl %edx,12(%eax)
-  movl %ecx,8(%eax)
-  movl %ebx,4(%eax)
-  popl %ebx
-  movl %ebx,(%eax)
-end;
-{$ASMMODE DEFAULT}
-{$endif i386}
-{$ifdef m68k}
-{$define fpc_syscall_ok}
-asm
-{ load the registers... }
-  move.l 12(a6),a0
-  move.l 4(a0),d1
-  move.l 8(a0),d2
-  move.l 12(a0),d3
-  move.l 16(a0),d4
-  move.l 20(a0),d5
-{ set the call number }
-  move.l 8(a6),d0
-{ Go ! }
-  trap #0
-{ Put back the registers... }
-  move.l d0,-(sp)
-  move.l 12(a6),a0
-  move.l d5,20(a0)
-  move.l d4,16(a0)
-  move.l d3,12(a0)
-  move.l d2,8(a0)
-  move.l d1,4(a0)
-  move.l (sp)+,d1
-  move.l d1,(a0)
-end;
-{$endif m68k}
-{$ifdef powerpc}
-{$define fpc_syscall_ok}
-asm
-{ load the registers... }
-  lwz  r5, 12(r4)
-  lwz  r6, 16(r4)
-  lwz  r7, 20(r4)
-  mr   r0, r3
-  lwz  r3, 4(r4)
-  stw  r4, regs
-  lwz  r4, 8(r4)
-{ Go ! }
-  sc
-  nop
-{ Put back the registers... }
-  lwz    r8, regs
-  stw    r3, 0(r8)
-  stw    r4, 4(r8)
-  stw    r5, 8(r8)
-  stw    r6, 12(r8)
-  stw    r7, 16(r8)
-end;
-{$endif powerpc}
-{$ifndef fpc_syscall_ok}
-{$error Cannot decide which processor you have!}
-asm
-end;
-{$endif not fpc_syscall_ok}
-
-{$IFDEF SYSCALL_DEBUG}
-Const
-  DoSysCallDebug : Boolean = False;
-
-var
-  LastCnt,
-  LastEax,
-  LastCall : longint;
-  DebugTxt : string[20];
-{$ENDIF}
-Function SysCall( callnr:longint;var regs : SysCallregs ):longint;
-{
-  This function serves as an interface to do_SysCall.
-  If the SysCall returned a negative number, it returns -1, and puts the
-  SysCall result in errno. Otherwise, it returns the SysCall return value
-}
-begin
-  do_SysCall(callnr,regs);
-  if regs.reg1<0 then
-   begin
-{$IFDEF SYSCALL_DEBUG}
-     If DoSysCallDebug then
-       debugtxt:=' syscall error: ';
-{$endif}
-     ErrNo:=-regs.reg1;
-     SysCall:=-1;
-   end
-  else
-   begin
-{$IFDEF SYSCALL_DEBUG}
-  if DoSysCallDebug then
-       debugtxt:=' syscall returned: ';
-{$endif}
-     SysCall:=regs.reg1;
-     errno:=0
-   end;
-{$IFDEF SYSCALL_DEBUG}
-  if DoSysCallDebug then
-    begin
-    inc(lastcnt);
-    if (callnr<>lastcall) or (regs.reg1<>lasteax) then
-      begin
-      if lastcnt>1 then
-        writeln(sys_nr_txt[lastcall],debugtxt,lasteax,' (',lastcnt,'x)');
-      lastcall:=callnr;
-      lasteax:=regs.reg1;
-      lastcnt:=0;
-      writeln(sys_nr_txt[lastcall],debugtxt,lasteax);
-      end;
-    end;
-{$endif}
-end;
-
 Function Sys_Time:longint;
 var
   regs : SysCallregs;
@@ -581,7 +435,10 @@ end;
 
 {
   $Log$
-  Revision 1.14  2002-09-10 21:32:14  jonas
+  Revision 1.15  2002-10-14 19:39:17  peter
+    * threads unit added for thread support
+
+  Revision 1.14  2002/09/10 21:32:14  jonas
     + added "nop" after sc instruction, since normally in case of success,
       sc returns to the second instruction after itself
 

rtl/os2/system.pas

@@ -76,9 +76,6 @@ type
         Reserved2: longint);
     end;
 
-{ include threading stuff }
-{$i threadh.inc}
-
 {$I heaph.inc}
 
 {Platform specific information}
@@ -893,31 +890,21 @@ begin
 end;
 
 
-{****************************************************************************
-
-                             Thread Handling
-
-*****************************************************************************}
-
-const
-    fpucw: word = $1332;
-
-procedure InitFPU; assembler;
-
-asm
-    fninit
-    fldcw fpucw
-end;
-
-{ include threading stuff, this is os independend part }
-{$I thread.inc}
-
 {*****************************************************************************
 
                         System unit initialization.
 
 ****************************************************************************}
 
+procedure SysInitStdIO;
+begin
+    OpenStdIO(Input,fmInput,StdInputHandle);
+    OpenStdIO(Output,fmOutput,StdOutputHandle);
+    OpenStdIO(StdOut,fmOutput,StdOutputHandle);
+    OpenStdIO(StdErr,fmOutput,StdErrorHandle);
+end;
+
+
 function GetFileHandleCount: longint;
 var L1, L2: longint;
 begin
@@ -1008,13 +995,10 @@ begin
     initheap;
 
     { ... and exceptions }
-    InitExceptions;
+    SysInitExceptions;
 
-
-    OpenStdIO(Input,fmInput,StdInputHandle);
-    OpenStdIO(Output,fmOutput,StdOutputHandle);
-    OpenStdIO(StdOut,fmOutput,StdOutputHandle);
-    OpenStdIO(StdErr,fmOutput,StdErrorHandle);
+    { ... and I/O }
+    SysInitStdIO;
 
     { no I/O-Error }
     inoutres:=0;
@@ -1025,7 +1009,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.24  2002-10-13 09:28:45  florian
+  Revision 1.25  2002-10-14 19:39:17  peter
+    * threads unit added for thread support
+
+  Revision 1.24  2002/10/13 09:28:45  florian
     + call to initvariantmanager inserted
 
   Revision 1.23  2002/09/07 16:01:25  peter

rtl/unix/sysunix.inc

@@ -43,31 +43,6 @@ var
                        Misc. System Dependent Functions
 *****************************************************************************}
 
-{$ifdef I386}
-{ this should be defined in i386 directory !! PM }
-const
-  fpucw : word = $1332;
-  FPU_Invalid = 1;
-  FPU_Denormal = 2;
-  FPU_DivisionByZero = 4;
-  FPU_Overflow = 8;
-  FPU_Underflow = $10;
-  FPU_StackUnderflow = $20;
-  FPU_StackOverflow = $40;
-
-{$endif I386}
-
-Procedure ResetFPU;
-begin
-{$ifdef I386}
-  asm
-    fninit
-    fldcw   fpucw
-  end;
-{$endif I386}
-end;
-
-
 procedure prthaltproc;external name '_haltproc';
 
 Procedure System_exit;
@@ -315,6 +290,44 @@ Begin
 End;
 
 
+{Function Do_Write(Handle,Addr,Len:Longint):longint;
+var
+  total,
+  res : longint;
+Begin
+  total:=0;
+  repeat
+    res:=sys_write(Handle,pchar(pchar(addr)+total),len-total);
+    if res>0 then
+     inc(total,res);
+  until ErrNo<>Sys_EINTR;
+  Errno2Inoutres;
+  if res<0 then
+   Do_Write:=0
+  else
+   Do_Write:=total;
+End;
+
+
+Function Do_Read(Handle,Addr,Len:Longint):Longint;
+var
+  total,
+  res : longint;
+Begin
+  total:=0;
+  repeat
+    res:=sys_read(Handle,pchar(pchar(addr)+total),len-total);
+    if res>0 then
+     inc(total,res);
+  until ErrNo<>Sys_EINTR;
+  Errno2Inoutres;
+  if res<0 then
+   Do_Read:=0
+  else
+   Do_Read:=total;
+End;
+}
+
 Function Do_FilePos(Handle: Longint): Longint;
 Begin
   Do_FilePos:=sys_lseek(Handle, 0, Seek_Cur);
@@ -590,14 +603,6 @@ begin
   dir:=thedir
 end;
 
-{$ifdef Unix}
-{*****************************************************************************
-                             Thread Handling
-*****************************************************************************}
-
-{ include threading stuff, this is os independend part }
-{$I thread.inc}
-{$endif Unix}
 
 {*****************************************************************************
                          SystemUnit Initialization
@@ -656,7 +661,7 @@ begin
                 res:=207;  {'Coprocessor Error'}
             end;
 {$endif I386}
-          ResetFPU;
+          SysResetFPU;
         end;
    SIGILL,
    SIGBUS,
@@ -696,7 +701,7 @@ const
   oldact: PSigActionRec = Nil;          {Probably not necessary anymore, now
                                          VAR is removed}
 begin
-  ResetFPU;
+  SysResetFPU;
   SigAction(SIGFPE,@act,oldact);
 {$ifndef Solaris}
   SigAction(SIGSEGV,@act,oldact);
@@ -763,22 +768,30 @@ begin
 end;
 
 
+procedure SysInitStdIO;
+begin
+  OpenStdIO(Input,fmInput,StdInputHandle);
+  OpenStdIO(Output,fmOutput,StdOutputHandle);
+  OpenStdIO(StdOut,fmOutput,StdOutputHandle);
+  OpenStdIO(StdErr,fmOutput,StdErrorHandle);
+end;
+
+
 Begin
   IsConsole := TRUE;
   IsLibrary := FALSE;
+{ Setup stack checking variables }
+  StackLength := InitialStkLen;
   StackBottom := Sptr - StackLength;
 { Set up signals handlers }
   InstallSignals;
 { Setup heap }
   InitHeap;
-  InitExceptions;
+  SysInitExceptions;
 { Arguments }
   SetupCmdLine;
 { Setup stdin, stdout and stderr }
-  OpenStdIO(Input,fmInput,StdInputHandle);
-  OpenStdIO(Output,fmOutput,StdOutputHandle);
-  OpenStdIO(StdOut,fmOutput,StdOutputHandle);
-  OpenStdIO(StdErr,fmOutput,StdErrorHandle);
+  SysInitStdIO;
 { Reset IO Error }
   InOutRes:=0;
 { Setup variant support }
@@ -789,7 +802,10 @@ End.
 
 {
   $Log$
-  Revision 1.30  2002-10-13 09:20:56  peter
+  Revision 1.31  2002-10-14 19:39:17  peter
+    * threads unit added for thread support
+
+  Revision 1.30  2002/10/13 09:20:56  peter
     * added initvariantmanager
 
   Revision 1.29  2002/09/07 16:01:27  peter

rtl/unix/thread.inc

@@ -1,189 +0,0 @@
-{
-    $Id$
-    This file is part of the Free Pascal run time library.
-    Copyright (c) 2001 by the Free Pascal development team.
-
-    Multithreading implementation for Linux
-
-    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.
-
- **********************************************************************}
-{$ifdef MT}
-
-    const
-      DefaultStackSize = 16384;
-      threadvarblocksize : dword = 0;
-
-    type
-      pthreadinfo = ^tthreadinfo;
-      tthreadinfo = record
-        f : tthreadfunc;
-        p : pointer;
-      end;
-
-    var
-      dataindex : pointer;
-
-    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 := DataIndex + Offset;
-      end;
-
-
-    procedure AllocateThreadVars;
-      begin
-        { we've to allocate the memory from system  }
-        { 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 }
-        DataIndex:=Pointer(Sys_mmap(0,threadvarblocksize,3,MAP_PRIVATE+MAP_ANONYMOUS,-1,0));
-        FillChar(DataIndex^,threadvarblocksize,0);
-      end;
-
-
-    procedure ReleaseThreadVars;
-      begin
-        Sys_munmap(Longint(dataindex),threadvarblocksize);
-      end;
-
-
-    procedure InitThread;
-      begin
-        ResetFPU;
-        { 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;
-      begin
-        { release thread vars }
-        ReleaseThreadVars;
-      end;
-
-
-    function ThreadMain(param : pointer) : longint;cdecl;
-      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;
-        FStackPointer : pointer;
-        Flags : longint;
-      begin
-{$ifdef DEBUG_MT}
-        writeln('Creating new thread');
-{$endif DEBUG_MT}
-        IsMultithread:=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}
-        Flags := CLONE_VM + CLONE_FS + CLONE_FILES + CLONE_SIGHAND + SIGCHLD;
-        { Setup stack }
-        Getmem(pointer(FStackPointer),StackSize);
-        inc(FStackPointer,StackSize);
-        { Clone }
-        ThreadID:=Clone(@ThreadMain,pointer(FStackPointer),Flags,ti);
-      end;
-
-
-    function BeginThread(ThreadFunction : tthreadfunc) : DWord;
-      var
-        dummy : dword;
-      begin
-        BeginThread:=BeginThread(nil,DefaultStackSize,ThreadFunction,nil,0,dummy);
-      end;
-
-
-    function BeginThread(ThreadFunction : tthreadfunc;p : pointer) : DWord;
-      var
-        dummy : dword;
-      begin
-        BeginThread:=BeginThread(nil,DefaultStackSize,ThreadFunction,p,0,dummy);
-      end;
-
-
-    function BeginThread(ThreadFunction : tthreadfunc;p : pointer;var ThreadId : DWord) : DWord;
-      begin
-        BeginThread:=BeginThread(nil,DefaultStackSize,ThreadFunction,p,0,ThreadId);
-      end;
-
-
-    procedure EndThread(ExitCode : DWord);
-      begin
-        DoneThread;
-        Sys_Exit(ExitCode);
-      end;
-
-
-    procedure EndThread;
-      begin
-        EndThread(0);
-      end;
-
-    procedure InitCriticalSection(var cs : TRTLCriticalSection);
-      begin
-      end;
-
-    procedure DoneCriticalSection(var cs : TRTLCriticalSection);
-      begin
-      end;
-
-
-    procedure EnterCriticalSection(var cs : TRTLCriticalSection);
-      begin
-      end;
-
-    procedure LeaveCriticalSection(var cs : TRTLCriticalSection);
-      begin
-      end;
-
-{$endif MT}
-
-{
-  $Log$
-  Revision 1.3  2002-09-07 16:01:28  peter
-    * old logs removed and tabs fixed
-
-}

rtl/unix/threads.pp

@@ -0,0 +1,544 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2002 by Peter Vreman,
+    member of the Free Pascal development team.
+
+    Linux (pthreads) threading support implementation
+
+    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 threads;
+interface
+
+{$S-}
+
+{$linklib c}
+{$linklib pthread}
+
+  type
+     PRTLCriticalSection = ^TRTLCriticalSection;
+     TRTLCriticalSection = record
+          m_spinlock : longint;
+          m_count : longint;
+          m_owner : pointer {pthread_t};
+          m_kind : longint;
+          m_waiting : record
+            head,tail : pointer;
+          end; {_pthread_queue}
+       end;
+
+{ Include generic thread interface }
+{$i threadh.inc}
+
+
+implementation
+
+
+{*****************************************************************************
+                   Local POSIX Threads (pthread) imports
+*****************************************************************************}
+
+  { Attributes  }
+  const
+     THREAD_PRIORITY_IDLE               = 1;
+     THREAD_PRIORITY_LOWEST             = 15;
+     THREAD_PRIORITY_BELOW_NORMAL       = 30;
+     THREAD_PRIORITY_NORMAL             = 50;
+     THREAD_PRIORITY_ABOVE_NORMAL       = 70;
+     THREAD_PRIORITY_HIGHEST            = 80;
+     THREAD_PRIORITY_TIME_CRITICAL      = 99;
+     PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP : array [0..5]of Integer = (0, 0, 0, 1, 0, 0);
+
+  type
+     TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest, tpTimeCritical);
+
+  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
+     );
+
+  type
+     psched_param = ^sched_param;
+     sched_param = record
+        sched_priority : LongInt;
+     end;
+
+     ptimespec = ^timespec;
+     timespec = record
+        tv_sec : LongInt;
+        tv_nsec : LongInt;
+     end;
+
+     psigset_t = ^sigset_t;
+     sigset_t = DWORD; // unsigned long 32 bits
+
+  const
+     _POSIX_THREAD_THREADS_MAX = 64;
+     PTHREAD_THREADS_MAX = 512;
+     _POSIX_THREAD_KEYS_MAX = 128;
+     PTHREAD_KEYS_MAX = 128;
+
+  type
+    pthread_t = pointer;
+    ppthread_t = ^pthread_t;
+
+     p_pthread_queue = ^_pthread_queue;
+     _pthread_queue = record
+          head : pthread_t;
+          tail : pthread_t;
+       end;
+
+     ppthread_mutex_t = PRtlCriticalSection;
+     pthread_mutex_t = TRtlCriticalSection;
+
+     ppthread_cond_t = ^pthread_cond_t;
+     pthread_cond_t = record
+          c_spinlock : longint;
+          c_waiting : _pthread_queue;
+       end;
+
+     { Attributes  }
+
+    const
+      PTHREAD_CREATE_JOINABLE = 0;
+      PTHREAD_CREATE_DETACHED = 1;
+      PTHREAD_INHERIT_SCHED   = 0;
+      PTHREAD_EXPLICIT_SCHED  = 1;
+      PTHREAD_SCOPE_SYSTEM    = 0;
+      PTHREAD_SCOPE_PROCESS   = 1;
+
+    type
+       size_t = longint;
+
+       ppthread_attr_t = ^pthread_attr_t;
+       pthread_attr_t = record
+            detachstate : longint;
+            schedpolicy : longint;
+            schedparam : sched_param;
+            inheritsched : longint;
+            scope : longint;
+            __guardsize : size_t;
+            __stackaddr_set : longint;
+            __stackaddr : pointer;
+            __stacksize : size_t;
+         end;
+
+       ppthread_mutexattr_t = ^pthread_mutexattr_t;
+       pthread_mutexattr_t = record
+            mutexkind : longint;
+         end;
+
+
+       ppthread_condattr_t = ^pthread_condattr_t;
+       pthread_condattr_t = record
+            dummy : longint;
+         end;
+
+       ppthread_key_t = ^pthread_key_t;
+       pthread_key_t = cardinal;
+
+       ppthread_once_t = ^pthread_once_t;
+       pthread_once_t = longint;
+
+    const
+       PTHREAD_ONCE_INIT = 0;
+
+    type
+       tpcb_routine = Procedure(P:Pointer); cdecl;
+
+       p_pthread_cleanup_buffer = ^_pthread_cleanup_buffer;
+       _pthread_cleanup_buffer = record
+          routine : tpcb_routine;             { Function to call. }
+          arg : Pointer;                      { Its argument.  }
+          canceltype:LongInt;                 { Saved cancellation type. }
+          prev : p_pthread_cleanup_buffer; { Chaining of cleanup functions.  }
+       end;
+
+     __start_routine_t = function (_para1:pointer):pointer;cdecl;
+     __destr_function_t = procedure (_para1:pointer);
+     t_pthread_cleanup_push_routine = procedure (_para1:pointer);
+     t_pthread_cleanup_push_defer_routine = procedure (_para1:pointer);
+
+    function pthread_create(__thread:ppthread_t; __attr:ppthread_attr_t;__start_routine: __start_routine_t;__arg:pointer):longint;cdecl;external;
+    function pthread_self:pthread_t;cdecl;external;
+    function pthread_equal(__thread1:pthread_t; __thread2:pthread_t):longint;cdecl;external;
+    procedure pthread_exit(__retval:pointer);cdecl;external;
+    function pthread_join(__th:pthread_t; __thread_return:ppointer):longint;cdecl;external;
+    function pthread_detach(__th:pthread_t):longint;cdecl;external;
+    function pthread_attr_init(__attr:ppthread_attr_t):longint;cdecl;external;
+    function pthread_attr_destroy(__attr:ppthread_attr_t):longint;cdecl;external;
+    function pthread_attr_setdetachstate(__attr:ppthread_attr_t; __detachstate:longint):longint;cdecl;external;
+    function pthread_attr_getdetachstate(__attr:ppthread_attr_t; __detachstate:plongint):longint;cdecl;external;
+    function pthread_attr_setschedparam(__attr:ppthread_attr_t; __param:psched_param):longint;cdecl;external;
+    function pthread_attr_getschedparam(__attr:ppthread_attr_t; __param:psched_param):longint;cdecl;external;
+    function pthread_attr_setschedpolicy(__attr:ppthread_attr_t; __policy:longint):longint;cdecl;external;
+    function pthread_attr_getschedpolicy(__attr:ppthread_attr_t; __policy:plongint):longint;cdecl;external;
+    function pthread_attr_setinheritsched(__attr:ppthread_attr_t; __inherit:longint):longint;cdecl;external;
+    function pthread_attr_getinheritsched(__attr:ppthread_attr_t; __inherit:plongint):longint;cdecl;external;
+    function pthread_attr_setscope(__attr:ppthread_attr_t; __scope:longint):longint;cdecl;external;
+    function pthread_attr_getscope(__attr:ppthread_attr_t; __scope:plongint):longint;cdecl;external;
+    function pthread_setschedparam(__target_thread:pthread_t; __policy:longint; __param:psched_param):longint;cdecl;external;
+    function pthread_getschedparam(__target_thread:pthread_t; __policy:plongint; __param:psched_param):longint;cdecl;external;
+    function pthread_mutex_init(__mutex:ppthread_mutex_t; __mutex_attr:ppthread_mutexattr_t):longint;cdecl;external;
+    function pthread_mutex_destroy(__mutex:ppthread_mutex_t):longint;cdecl;external;
+    function pthread_mutex_trylock(__mutex:ppthread_mutex_t):longint;cdecl;external;
+    function pthread_mutex_lock(__mutex:ppthread_mutex_t):longint;cdecl;external;
+    function pthread_mutex_unlock(__mutex:ppthread_mutex_t):longint;cdecl;external;
+    function pthread_mutexattr_init(__attr:ppthread_mutexattr_t):longint;cdecl;external;
+    function pthread_mutexattr_destroy(__attr:ppthread_mutexattr_t):longint;cdecl;external;
+    function pthread_mutexattr_setkind_np(__attr:ppthread_mutexattr_t; __kind:longint):longint;cdecl;external;
+    function pthread_mutexattr_getkind_np(__attr:ppthread_mutexattr_t; __kind:plongint):longint;cdecl;external;
+    function pthread_cond_init(__cond:ppthread_cond_t; __cond_attr:ppthread_condattr_t):longint;cdecl;external;
+    function pthread_cond_destroy(__cond:ppthread_cond_t):longint;cdecl;external;
+    function pthread_cond_signal(__cond:ppthread_cond_t):longint;cdecl;external;
+    function pthread_cond_broadcast(__cond:ppthread_cond_t):longint;cdecl;external;
+    function pthread_cond_wait(__cond:ppthread_cond_t; __mutex:ppthread_mutex_t):longint;cdecl;external;
+    function pthread_cond_timedwait(__cond:ppthread_cond_t; __mutex:ppthread_mutex_t; __abstime:ptimespec):longint;cdecl;external;
+    function pthread_condattr_init(__attr:ppthread_condattr_t):longint;cdecl;external;
+    function pthread_condattr_destroy(__attr:ppthread_condattr_t):longint;cdecl;external;
+    function pthread_key_create(__key:ppthread_key_t; __destr_function:__destr_function_t):longint;cdecl;external;
+    function pthread_key_delete(__key:pthread_key_t):longint;cdecl;external;
+    function pthread_setspecific(__key:pthread_key_t; __pointer:pointer):longint;cdecl;external;
+    function pthread_getspecific(__key:pthread_key_t):pointer;cdecl;external;
+    function pthread_once(__once_control:ppthread_once_t; __init_routine:tprocedure ):longint;cdecl;external;
+    function pthread_setcancelstate(__state:longint; __oldstate:plongint):longint;cdecl;external;
+    function pthread_setcanceltype(__type:longint; __oldtype:plongint):longint;cdecl;external;
+    function pthread_cancel(__thread:pthread_t):longint;cdecl;external;
+    procedure pthread_testcancel;cdecl;external;
+    procedure _pthread_cleanup_push(__buffer:p_pthread_cleanup_buffer;__routine:t_pthread_cleanup_push_routine; __arg:pointer);cdecl;external;
+    procedure _pthread_cleanup_push_defer(__buffer:p_pthread_cleanup_buffer;__routine:t_pthread_cleanup_push_defer_routine; __arg:pointer);cdecl;external;
+    function pthread_sigmask(__how:longint; __newmask:psigset_t; __oldmask:psigset_t):longint;cdecl;external;
+    function pthread_kill(__thread:pthread_t; __signo:longint):longint;cdecl;external;
+    function sigwait(__set:psigset_t; __sig:plongint):longint;cdecl;external;
+    function pthread_atfork(__prepare:tprocedure ; __parent:tprocedure ; __child:tprocedure ):longint;cdecl;external;
+    procedure pthread_kill_other_threads_np;cdecl;external;
+
+
+{*****************************************************************************
+                       System dependent memory allocation
+*****************************************************************************}
+
+const
+  syscall_nr_mmap                        = 90;
+  syscall_nr_munmap                      = 91;
+
+  { Constansts for MMAP }
+  MAP_PRIVATE   =2;
+  MAP_ANONYMOUS =$20;
+
+type
+  SysCallRegs=record
+    reg1,reg2,reg3,reg4,reg5,reg6 : longint;
+  end;
+
+var
+  Errno : longint;
+
+{ Include syscall itself }
+{$i syscall.inc}
+
+Function Sys_mmap(adr,len,prot,flags,fdes,off:longint):longint;
+type
+  tmmapargs=packed record
+    address : longint;
+    size    : longint;
+    prot    : longint;
+    flags   : longint;
+    fd      : longint;
+    offset  : longint;
+  end;
+var
+  t : syscallregs;
+  mmapargs : tmmapargs;
+begin
+  mmapargs.address:=adr;
+  mmapargs.size:=len;
+  mmapargs.prot:=prot;
+  mmapargs.flags:=flags;
+  mmapargs.fd:=fdes;
+  mmapargs.offset:=off;
+  t.reg2:=longint(@mmapargs);
+  Sys_mmap:=syscall(syscall_nr_mmap,t);
+end;
+
+Function Sys_munmap(adr,len:longint):longint;
+var
+  t : syscallregs;
+begin
+  t.reg2:=adr;
+  t.reg3:=len;
+  Sys_munmap:=syscall(syscall_nr_munmap,t);
+end;
+
+
+{*****************************************************************************
+                             Threadvar support
+*****************************************************************************}
+
+{$ifdef HASTHREADVAR}
+    const
+      threadvarblocksize : dword = 0;
+
+    var
+      TLSKey : pthread_key_t;
+
+    procedure SysInitThreadvar(var offset : dword;size : dword);
+      begin
+        offset:=threadvarblocksize;
+        inc(threadvarblocksize,size);
+      end;
+
+
+    function SysRelocateThreadvar(offset : dword) : pointer;
+      begin
+        SysRelocateThreadvar:=pthread_getspecific(tlskey)+Offset;
+      end;
+
+
+    procedure SysAllocateThreadVars;
+      var
+        dataindex : pointer;
+      begin
+        { we've to allocate the memory from system  }
+        { 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 }
+        DataIndex:=Pointer(Sys_mmap(0,threadvarblocksize,3,MAP_PRIVATE+MAP_ANONYMOUS,-1,0));
+        FillChar(DataIndex^,threadvarblocksize,0);
+        pthread_setspecific(tlskey,dataindex);
+      end;
+
+
+    procedure SysReleaseThreadVars;
+      begin
+        Sys_munmap(longint(pthread_getspecific(tlskey)),threadvarblocksize);
+      end;
+
+{ Include OS independent Threadvar initialization }
+{$i threadvar.inc}
+
+    procedure InitThreadVars;
+      begin
+        { We're still running in single thread mode, setup the TLS }
+        pthread_key_create(@TLSKey,nil);
+        { initialize threadvars }
+        init_all_unit_threadvars;
+        { allocate mem for main thread threadvars }
+        SysAllocateThreadVars;
+        { copy main thread threadvars }
+        copy_all_unit_threadvars;
+        { install threadvar handler }
+        fpc_threadvar_relocate_proc:=@SysRelocateThreadvar;
+      end;
+
+{$endif HASTHREADVAR}
+
+
+{*****************************************************************************
+                            Thread starting
+*****************************************************************************}
+
+    const
+      DefaultStackSize = 32768; { including 16384 margin for stackchecking }
+
+    type
+      pthreadinfo = ^tthreadinfo;
+      tthreadinfo = record
+        f : tthreadfunc;
+        p : pointer;
+        stklen : cardinal;
+      end;
+
+    procedure InitThread(stklen:cardinal);
+      begin
+        SysResetFPU;
+        { ExceptAddrStack and ExceptObjectStack are threadvars       }
+        { so every thread has its on exception handling capabilities }
+        SysInitExceptions;
+        { Open all stdio fds again }
+        SysInitStdio;
+        InOutRes:=0;
+        // ErrNo:=0;
+        { Stack checking }
+        StackLength:=stklen;
+        StackBottom:=Sptr - StackLength;
+      end;
+
+
+    procedure DoneThread;
+      begin
+        { Release Threadvars }
+{$ifdef HASTHREADVAR}
+        SysReleaseThreadVars;
+{$endif HASTHREADVAR}
+      end;
+
+
+    function ThreadMain(param : pointer) : pointer;cdecl;
+      var
+        ti : tthreadinfo;
+      begin
+{$ifdef HASTHREADVAR}
+        { Allocate local thread vars, this must be the first thing,
+          because the exception management and io depends on threadvars }
+        SysAllocateThreadVars;
+{$endif HASTHREADVAR}
+        { Copy parameter to local data }
+{$ifdef DEBUG_MT}
+        writeln('New thread started, initialising ...');
+{$endif DEBUG_MT}
+        ti:=pthreadinfo(param)^;
+        dispose(pthreadinfo(param));
+        { Initialize thread }
+        InitThread(ti.stklen);
+        { Start thread function }
+{$ifdef DEBUG_MT}
+        writeln('Jumping to thread function');
+{$endif DEBUG_MT}
+        ThreadMain:=pointer(ti.f(ti.p));
+      end;
+
+
+    function BeginThread(sa : Pointer;stacksize : dword;
+                         ThreadFunction : tthreadfunc;p : pointer;
+                         creationFlags : dword; var ThreadId : DWord) : DWord;
+      var
+        ti : pthreadinfo;
+        thread_attr : pthread_attr_t;
+      begin
+{$ifdef DEBUG_MT}
+        writeln('Creating new thread');
+{$endif DEBUG_MT}
+        { Initialize multithreading if not done }
+        if not IsMultiThread then
+         begin
+{$ifdef HASTHREADVAR}
+           InitThreadVars;
+{$endif HASTHREADVAR}
+           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;
+        { call pthread_create }
+{$ifdef DEBUG_MT}
+        writeln('Starting new thread');
+{$endif DEBUG_MT}
+        pthread_attr_init(@thread_attr);
+        pthread_attr_setinheritsched(@thread_attr, PTHREAD_EXPLICIT_SCHED);
+        pthread_attr_setscope(@thread_attr, PTHREAD_SCOPE_PROCESS);
+        pthread_attr_setdetachstate(@thread_attr, PTHREAD_CREATE_DETACHED);
+        pthread_create(@threadid, @thread_attr, @ThreadMain,ti);
+        BeginThread:=threadid;
+      end;
+      
+      
+    procedure EndThread(ExitCode : DWord);
+      begin
+        DoneThread;
+        pthread_exit(pointer(ExitCode));
+      end;
+
+
+{*****************************************************************************
+                          Delphi/Win32 compatibility
+*****************************************************************************}
+
+    procedure InitCriticalSection(var CS:TRTLCriticalSection);
+      begin
+         cs.m_spinlock:=0;
+         cs.m_count:=0;
+         cs.m_owner:=0;
+         cs.m_kind:=1;
+         cs.m_waiting.head:=0;
+         cs.m_waiting.tail:=0;
+         pthread_mutex_init(@CS,NIL);
+      end;
+
+    procedure EnterCriticalSection(var CS:TRTLCriticalSection);
+      begin
+         pthread_mutex_lock(@CS);
+      end;
+
+    procedure LeaveCriticalSection(var CS:TRTLCriticalSection);
+      begin
+         pthread_mutex_unlock(@CS);
+      end;
+
+    procedure DoneCriticalSection(var CS:TRTLCriticalSection);
+      begin
+         pthread_mutex_destroy(@CS);
+      end;
+
+
+{*****************************************************************************
+                           Heap Mutex Protection
+*****************************************************************************}
+
+    var
+      HeapMutex : pthread_mutex_t;
+
+    procedure PThreadHeapMutexInit;
+      begin
+         pthread_mutex_init(@heapmutex,nil);
+      end;
+
+    procedure PThreadHeapMutexDone;
+      begin
+         pthread_mutex_destroy(@heapmutex);
+      end;
+
+    procedure PThreadHeapMutexLock;
+      begin
+         pthread_mutex_lock(@heapmutex);
+      end;
+
+    procedure PThreadHeapMutexUnlock;
+      begin
+         pthread_mutex_unlock(@heapmutex);
+      end;
+
+    const
+      PThreadMemoryMutexManager : TMemoryMutexManager = (
+        MutexInit : @PThreadHeapMutexInit;
+        MutexDone : @PThreadHeapMutexDone;
+        MutexLock : @PThreadHeapMutexLock;
+        MutexUnlock : @PThreadHeapMutexUnlock;
+      );
+
+    procedure InitHeapMutexes;
+      begin
+        SetMemoryMutexManager(PThreadMemoryMutexManager);
+      end;
+
+
+{*****************************************************************************
+                             Generic overloaded 
+*****************************************************************************}
+
+{ Include generic overloaded routines }
+{$i thread.inc}
+
+initialization
+  InitHeapMutexes;
+end.
+{
+  $Log$
+  Revision 1.1  2002-10-14 19:39:17  peter
+    * threads unit added for thread support
+
+}
+  

rtl/win32/Makefile

@@ -1,8 +1,8 @@
 #
-# Don't edit, this file is generated by FPCMake Version 1.1 [2002/04/23]
+# Don't edit, this file is generated by FPCMake Version 1.1 [2002/10/07]
 #
 default: all
-MAKEFILETARGETS=win32
+MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx
 override PATH:=$(subst \,/,$(PATH))
 ifeq ($(findstring ;,$(PATH)),)
 inUnix=1
@@ -42,6 +42,9 @@ endif
 ifeq ($(OS_TARGET),netbsd)
 BSDhier=1
 endif
+ifeq ($(OS_TARGET),openbsd)
+BSDhier=1
+endif
 ifdef inUnix
 BATCHEXT=.sh
 else
@@ -55,6 +58,9 @@ ifdef inUnix
 PATHSEP=/
 else
 PATHSEP:=$(subst /,\,/)
+ifneq ($(findstring sh.exe,$(SHELL)),)
+PATHSEP=/
+endif
 endif
 ifdef PWD
 BASEDIR:=$(subst \,/,$(shell $(PWD)))
@@ -84,7 +90,7 @@ endif
 endif
 export ECHO
 endif
-OS_TARGET=win32
+override OS_TARGET_DEFAULT=win32
 override DEFAULT_FPCDIR=../..
 ifndef FPC
 ifdef PP
@@ -138,6 +144,16 @@ ifndef OS_TARGET
 OS_TARGET:=$(shell $(FPC) -iTO)
 endif
 endif
+ifndef CPU_TARGET
+ifdef CPU_TARGET_DEFAULT
+CPU_TARGET=$(CPU_TARGET_DEFAULT)
+endif
+endif
+ifndef OS_TARGET
+ifdef OS_TARGET_DEFAULT
+OS_TARGET=$(OS_TARGET_DEFAULT)
+endif
+endif
 FULL_TARGET=$(CPU_TARGET)-$(OS_TARGET)
 FULL_SOURCE=$(CPU_SOURCE)-$(OS_SOURCE)
 ifneq ($(FULL_TARGET),$(FULL_SOURCE))
@@ -218,7 +234,7 @@ OBJPASDIR=$(RTL)/objpas
 GRAPHDIR=$(INC)/graph
 include $(WININC)/makefile.inc
 WINDOWS_SOURCE_FILES=$(addprefix $(WININC)/,$(addsuffix .inc,$(WINDOWS_FILES)))
-override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings windows ole2 activex opengl32 winsock initc dos crt objects graph messages sysutils typinfo math varutils cpu mmx charset ucomplex getopts heaptrc lineinfo wincrt winmouse winevent sockets printer dynlibs video mouse keyboard variants types comobj
+override TARGET_UNITS+=$(SYSTEMUNIT) threads objpas strings lineinfo heaptrc windows ole2 activex opengl32 winsock initc dos crt objects graph messages sysutils typinfo math varutils variants cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer dynlibs video mouse keyboard types comobj
 override TARGET_LOADERS+=wprt0 wdllprt0
 override TARGET_RSTS+=math varutils typinfo
 override INSTALL_FPCPACKAGE=y
@@ -241,9 +257,15 @@ endif
 ifeq ($(OS_TARGET),netbsd)
 UNIXINSTALLDIR=1
 endif
+ifeq ($(OS_TARGET),openbsd)
+UNIXINSTALLDIR=1
+endif
 ifeq ($(OS_TARGET),sunos)
 UNIXINSTALLDIR=1
 endif
+ifeq ($(OS_TARGET),qnx)
+UNIXINSTALLDIR=1
+endif
 else
 ifeq ($(OS_SOURCE),linux)
 UNIXINSTALLDIR=1
@@ -254,9 +276,15 @@ endif
 ifeq ($(OS_SOURCE),netbsd)
 UNIXINSTALLDIR=1
 endif
+ifeq ($(OS_SOURCE),openbsd)
+UNIXINSTALLDIR=1
+endif
 ifeq ($(OS_TARGET),sunos)
 UNIXINSTALLDIR=1
 endif
+ifeq ($(OS_TARGET),qnx)
+UNIXINSTALLDIR=1
+endif
 endif
 ifndef INSTALL_PREFIX
 ifdef PREFIX
@@ -452,6 +480,12 @@ HASSHAREDLIB=1
 FPCMADE=fpcmade.netbsd
 ZIPSUFFIX=netbsd
 endif
+ifeq ($(OS_TARGET),openbsd)
+EXEEXT=
+HASSHAREDLIB=1
+FPCMADE=fpcmade.openbsd
+ZIPSUFFIX=openbsd
+endif
 ifeq ($(OS_TARGET),win32)
 PPUEXT=.ppw
 OEXT=.ow
@@ -477,7 +511,7 @@ ECHO=echo
 endif
 ifeq ($(OS_TARGET),amiga)
 EXEEXT=
-PPUEXT=.ppa
+PPUEXT=.ppu
 ASMEXT=.asm
 OEXT=.o
 SMARTEXT=.sl
@@ -486,7 +520,7 @@ SHAREDLIBEXT=.library
 FPCMADE=fpcmade.amg
 endif
 ifeq ($(OS_TARGET),atari)
-PPUEXT=.ppt
+PPUEXT=.ppu
 ASMEXT=.s
 OEXT=.o
 SMARTEXT=.sl
@@ -763,6 +797,9 @@ endif
 ifneq ($(OS_TARGET),$(OS_SOURCE))
 override FPCOPT+=-T$(OS_TARGET)
 endif
+ifeq ($(OS_SOURCE),openbsd)
+override FPCOPT+=-FD$(NEW_BINUTILS_PATH)
+endif
 ifdef UNITDIR
 override FPCOPT+=$(addprefix -Fu,$(UNITDIR))
 endif
@@ -1078,6 +1115,7 @@ fpc_baseinfo:
 	@$(ECHO)  Rm........ $(RMPROG)
 	@$(ECHO)  GInstall.. $(GINSTALL)
 	@$(ECHO)  Echo...... $(ECHO)
+	@$(ECHO)  Shell..... $(SHELL)
 	@$(ECHO)  Date...... $(DATE)
 	@$(ECHO)  FPCMake... $(FPCMAKE)
 	@$(ECHO)  PPUMove... $(PPUMOVE)

rtl/win32/Makefile.fpc

@@ -7,13 +7,14 @@ main=rtl
 
 [target]
 loaders=wprt0 wdllprt0
-units=$(SYSTEMUNIT) objpas strings \
+units=$(SYSTEMUNIT) threads objpas strings \
+      lineinfo heaptrc \
       windows ole2 activex opengl32 winsock initc \
       dos crt objects graph messages \
-      sysutils typinfo math varutils \
-      cpu mmx charset ucomplex getopts heaptrc lineinfo \
+      sysutils typinfo math varutils variants \
+      cpu mmx charset ucomplex getopts \
       wincrt winmouse winevent sockets printer dynlibs \
-      video mouse keyboard variants types comobj
+      video mouse keyboard types comobj
 rsts=math varutils typinfo
 
 [require]
@@ -180,10 +181,10 @@ varutils$(PPUEXT) : varutils.pp $(OBJPASDIR)/cvarutil.inc \
         $(COMPILER) -I$(OBJPASDIR) varutils.pp
 
 types$(PPUEXT) : $(OBJPASDIR/types.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
-	$(COMPILER) $(OBJPASDIR)/types.pp
+        $(COMPILER) $(OBJPASDIR)/types.pp
 
 comobj$(PPUEXT) : comobj.pp activex$(PPUEXT) sysutils$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) $(OBJPASDIR)/comobjh.inc $(OBJPASDIR)/comobj.inc
-	$(COMPILER) -I$(OBJPASDIR) comobj.pp
+        $(COMPILER) -I$(OBJPASDIR) comobj.pp
 
 #
 # Other system-independent RTL Units

rtl/win32/system.pp

@@ -41,28 +41,12 @@ const
 { FileNameCaseSensitive is defined separately below!!! }
 
 type
-   { the fields of this record are os dependent  }
-   { and they shouldn't be used in a program     }
-   { only the type TCriticalSection is important }
-   TRTLCriticalSection = packed record
-      DebugInfo : pointer;
-      LockCount : longint;
-      RecursionCount : longint;
-      OwningThread : DWord;
-      LockSemaphore : DWord;
-      Reserved : DWord;
-   end;
-
    PEXCEPTION_FRAME = ^TEXCEPTION_FRAME;
    TEXCEPTION_FRAME = record
      next : PEXCEPTION_FRAME;
      handler : pointer;
    end;
 
-
-{ include threading stuff }
-{$i threadh.inc}
-
 { include heap support headers }
 {$I heaph.inc}
 
@@ -178,11 +162,11 @@ CONST
 {   Removing that error allows eof to works as on other OSes }
     ERROR_BROKEN_PIPE = 109;
 
-{$IFDEF MT}
+{$IFDEF SUPPORT_THREADVAR}
 threadvar
-{$ELSE MT}
+{$ELSE SUPPORT_THREADVAR}
 var
-{$ENDIF MT}
+{$ENDIF SUPPORT_THREADVAR}
     errno : longint;
 
 {$ASMMODE ATT}
@@ -223,42 +207,6 @@ var
    end;
 
 
-{$ifdef dummy}
-procedure int_stackcheck(stack_size:longint);[public,alias: 'STACKCHECK'];
-{
-  called when trying to get local stack if the compiler directive $S
-  is set this function must preserve esi !!!! because esi is set by
-  the calling proc for methods it must preserve all registers !!
-
-  With a 2048 byte safe area used to write to StdIo without crossing
-  the stack boundary
-
-}
-begin
-  asm
-        pushl   %eax
-        pushl   %ebx
-        movl    stack_size,%ebx
-        addl    $2048,%ebx
-        movl    %esp,%eax
-        subl    %ebx,%eax
-        movl    stacklimit,%ebx
-        cmpl    %eax,%ebx
-        jae     .L__short_on_stack
-        popl    %ebx
-        popl    %eax
-        leave
-        ret     $4
-.L__short_on_stack:
-        { can be usefull for error recovery !! }
-        popl    %ebx
-        popl    %eax
-  end['EAX','EBX'];
-  HandleError(202);
-end;
-{$endif dummy}
-
-
 function paramcount : longint;
 begin
   paramcount := argc - 1;
@@ -706,24 +654,6 @@ begin
    dir:=upcase(dir);
 end;
 
-
-{*****************************************************************************
-                             Thread Handling
-*****************************************************************************}
-
-const
-  fpucw : word = $1332;
-
-procedure InitFPU;assembler;
-
-  asm
-     fninit
-     fldcw   fpucw
-  end;
-
-{ include threading stuff, this is os independend part }
-{$I thread.inc}
-
 {*****************************************************************************
                          SystemUnit Initialization
 *****************************************************************************}
@@ -1037,9 +967,7 @@ var
        DLL_THREAD_ATTACH :
          begin
            inc(Thread_count);
-{$ifdef MT}
-           AllocateThreadVars;
-{$endif MT}
+{$warning Allocate Threadvars !}
            if assigned(Dll_Thread_Attach_Hook) then
              Dll_Thread_Attach_Hook(DllParam);
            Dll_entry:=true; { return value is ignored }
@@ -1049,9 +977,7 @@ var
            dec(Thread_count);
            if assigned(Dll_Thread_Detach_Hook) then
              Dll_Thread_Detach_Hook(DllParam);
-{$ifdef MT}
-           ReleaseThreadVars;
-{$endif MT}
+{$warning Release Threadvars !}
            Dll_entry:=true; { return value is ignored }
          end;
        DLL_PROCESS_DETACH :
@@ -1079,7 +1005,7 @@ end;
 
 {$ifdef Set_i386_Exception_handler}
 
-(*
+{
   Error code definitions for the Win32 API functions
 
 
@@ -1101,7 +1027,7 @@ end;
       R - is a reserved bit
       Facility - is the facility code
       Code - is the facility's status code
-*)
+}
 
 const
         SEVERITY_SUCCESS                = $00000000;
@@ -1515,32 +1441,9 @@ begin
   Rewrite(T);
 end;
 
-const
-   Exe_entry_code : pointer = @Exe_entry;
-   Dll_entry_code : pointer = @Dll_entry;
 
+procedure SysInitStdIO;
 begin
-  StackBottom := Sptr - StackLength;
-  { get some helpful informations }
-  GetStartupInfo(@startupinfo);
-  { some misc Win32 stuff }
-  hprevinst:=0;
-  if not IsLibrary then
-    HInstance:=getmodulehandle(GetCommandFile);
-  MainInstance:=HInstance;
-  cmdshow:=startupinfo.wshowwindow;
-  { real test stack depth        }
-  {   stacklimit := setupstack;  }
-{$ifdef MT}
-  { allocate one threadvar entry from windows, we use this entry }
-  { for a pointer to our threadvars                              }
-  dataindex:=TlsAlloc;
-  { the exceptions use threadvars so do this _before_ initexceptions }
-  AllocateThreadVars;
-{$endif MT}
-  { Setup heap }
-  InitHeap;
-  InitExceptions;
   { Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be
     displayed in and messagebox }
   StdInputHandle:=longint(GetStdHandle(cardinal(STD_INPUT_HANDLE)));
@@ -1560,6 +1463,28 @@ begin
      OpenStdIO(StdOut,fmOutput,StdOutputHandle);
      OpenStdIO(StdErr,fmOutput,StdErrorHandle);
    end;
+end;
+
+
+const
+   Exe_entry_code : pointer = @Exe_entry;
+   Dll_entry_code : pointer = @Dll_entry;
+
+begin
+  StackLength := InitialStkLen;
+  StackBottom := Sptr - StackLength;
+  { get some helpful informations }
+  GetStartupInfo(@startupinfo);
+  { some misc Win32 stuff }
+  hprevinst:=0;
+  if not IsLibrary then
+    HInstance:=getmodulehandle(GetCommandFile);
+  MainInstance:=HInstance;
+  cmdshow:=startupinfo.wshowwindow;
+  { Setup heap }
+  InitHeap;
+  SysInitExceptions;
+  SysInitStdIO;
   { Arguments }
   setup_arguments;
   { Reset IO Error }
@@ -1573,7 +1498,10 @@ end.
 
 {
   $Log$
-  Revision 1.33  2002-10-13 09:28:45  florian
+  Revision 1.34  2002-10-14 19:39:17  peter
+    * threads unit added for thread support
+
+  Revision 1.33  2002/10/13 09:28:45  florian
     + call to initvariantmanager inserted
 
   Revision 1.32  2002/09/07 21:28:10  carl

rtl/win32/thread.inc

@@ -1,284 +0,0 @@
-{
-    $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.
-
- **********************************************************************}
-{$ifdef MT}
-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';
-function GlobalAlloc(uFlags:UINT; dwBytes:DWORD):Pointer;
-  external 'kernel32' name 'GlobalAlloc';
-function GlobalFree(hMem : Pointer):Pointer; external 'kernel32' name 'GlobalFree';
-
-const
-  { GlobalAlloc, GlobalFlags  }
-  GMEM_FIXED = 0;
-  GMEM_ZEROINIT = 64;
-
-procedure init_threadvar(var offset : dword;size : dword);[public,alias: 'FPC_INIT_THREADVAR'];
-
-  begin
-     offset:=threadvarblocksize;
-     inc(threadvarblocksize,size);
-  end;
-
-
-type
-   ltvInitEntry = packed record
-      varaddr : pdword;
-      size    : longint;
-   end;
-   pltvInitEntry = ^ltvInitEntry;
-
-procedure init_unit_threadvars (tableEntry : pltvInitEntry);
-begin
-  while tableEntry^.varaddr <> nil do
-  begin
-    init_threadvar (tableEntry^.varaddr^, tableEntry^.size);
-    inc (pchar (tableEntry), sizeof (tableEntry^));
-  end;
-end;
-
-type TltvInitTablesTable =
-  record
-    count : dword;
-    tables: array [1..32767] of pltvInitEntry;
-  end;
-
-var
-  ThreadvarTablesTable : TltvInitTablesTable; external name 'FPC_LOCALTHREADVARTABLES';
-
-procedure init_all_unit_threadvars; [public,alias: 'FPC_INITIALIZELOCALTHREADVARS'];
-var i : integer;
-begin
-  {$ifdef DEBUG_MT}
-  WriteLn ('init_all_unit_threadvars (%d) units',ThreadvarTablesTable.count);
-  {$endif}
-  for i := 1 to ThreadvarTablesTable.count do
-    init_unit_threadvars (ThreadvarTablesTable.tables[i]);
-end;
-
-
-function relocate_threadvar(offset : dword) : pointer;[public,alias: 'FPC_RELOCATE_THREADVAR'];
-
-  begin
-     asm
-        pushal
-     end;
-     relocate_threadvar:=TlsGetValue(dataindex)+offset;
-     asm
-        popal
-     end;
-  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 ReleaseThreadVars;
-
-  var
-     threadvars : pointer;
-
-  begin
-     { release thread vars }
-     threadvars:=TlsGetValue(dataindex);
-     GlobalFree(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 own exception handling capabilities }
-     InitExceptions;
-     InOutRes:=0;
-     // ErrNo:=0;
-  end;
-
-procedure DoneThread;
-
-  begin
-     { release thread vars }
-     ReleaseThreadVars;
-  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);
-     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}
-     writeln('Creating new thread');
-{$endif DEBUG_MT}
-     IsMultithread:=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;
-
-function BeginThread(ThreadFunction : tthreadfunc;p : pointer;
-  var ThreadId : Longint) : DWord;
-  begin
-     BeginThread:=BeginThread(nil,0,ThreadFunction,p,0,DWord(ThreadId));
-  end;
-
-
-function BeginThread(sa : Pointer;stacksize : dword;
-  ThreadFunction : tthreadfunc;p : pointer;creationFlags : dword;
-  var ThreadId : Longint) : DWord;
-  begin
-     BeginThread:=BeginThread(sa,stacksize,ThreadFunction,p,creationflags,DWord(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 : TRTLCriticalSection);
-  external 'kernel32' name 'InitializeCriticalSection';
-
-procedure DoneCriticalSection(var cs : TRTLCriticalSection);
-  external 'kernel32' name 'DeleteCriticalSection';
-
-procedure EnterCriticalSection(var cs : TRTLCriticalSection);
-  external 'kernel32' name 'EnterCriticalSection';
-
-procedure LeaveCriticalSection(var cs : TRTLCriticalSection);
-  external 'kernel32' name 'LeaveCriticalSection';
-
-{$endif MT}
-
-{
-  $Log$
-  Revision 1.10  2002-09-07 16:01:29  peter
-    * old logs removed and tabs fixed
-
-  Revision 1.9  2002/07/28 20:43:50  florian
-    * several fixes for linux/powerpc
-    * several fixes to MT
-
-  Revision 1.8  2002/03/31 10:03:13  armin
-  + call to DoneThread was missing
-
-  Revision 1.7  2002/03/28 16:31:35  armin
-  + initialize threadvars defined local in units
-
-}

rtl/win32/threads.pp

@@ -0,0 +1,313 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2002 by Peter Vreman,
+    member of the Free Pascal development team.
+
+    Win32 threading support implementation
+
+    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 threads;
+interface
+
+{$S-}
+
+  type
+    { the fields of this record are os dependent  }
+    { and they shouldn't be used in a program     }
+    { only the type TCriticalSection is important }
+    PRTLCriticalSection = ^TRTLCriticalSection;
+    TRTLCriticalSection = packed record
+      DebugInfo : pointer;
+      LockCount : longint;
+      RecursionCount : longint;
+      OwningThread : DWord;
+      LockSemaphore : DWord;
+      Reserved : DWord;
+    end;
+
+{ Include generic thread interface }
+{$i threadh.inc}
+
+
+implementation
+
+
+{*****************************************************************************
+                           Local WINApi imports
+*****************************************************************************}
+
+const
+  { GlobalAlloc, GlobalFlags  }
+  GMEM_FIXED = 0;
+  GMEM_ZEROINIT = 64;
+
+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) : Dword;
+  external 'kernel32' name 'CreateThread';
+procedure ExitThread(dwExitCode : DWord);
+  external 'kernel32' name 'ExitThread';
+function GlobalAlloc(uFlags:DWord; dwBytes:DWORD):Pointer;
+  external 'kernel32' name 'GlobalAlloc';
+function GlobalFree(hMem : Pointer):Pointer; external 'kernel32' name 'GlobalFree';
+
+{*****************************************************************************
+                             Threadvar support
+*****************************************************************************}
+
+{$ifdef HASTHREADVAR}
+    const
+      threadvarblocksize : dword = 0;
+
+    var
+      TLSKey : Dword;
+
+    procedure SysInitThreadvar(var offset : dword;size : dword);
+      begin
+        offset:=threadvarblocksize;
+        inc(threadvarblocksize,size);
+      end;
+
+
+    function SysRelocateThreadvar(offset : dword) : pointer;
+      begin
+        SysRelocateThreadvar:=TlsGetValue(tlskey)+Offset;
+      end;
+
+
+    procedure SysAllocateThreadVars;
+      var
+        dataindex : pointer;
+      begin
+        { we've to allocate the memory from system  }
+        { 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 }
+        dataindex:=pointer(GlobalAlloc(GMEM_FIXED or GMEM_ZEROINIT,threadvarblocksize));
+        TlsSetValue(tlskey,dataindex);
+      end;
+
+
+    procedure SysReleaseThreadVars;
+      begin
+        GlobalFree(TlsGetValue(tlskey));
+      end;
+
+{ Include OS independent Threadvar initialization }
+{$i threadvar.inc}
+
+    procedure InitThreadVars;
+      begin
+        { We're still running in single thread mode, setup the TLS }
+        TLSKey:=TlsAlloc;
+        { initialize threadvars }
+        init_all_unit_threadvars;
+        { allocate mem for main thread threadvars }
+        SysAllocateThreadVars;
+        { copy main thread threadvars }
+        copy_all_unit_threadvars;
+        { install threadvar handler }
+        fpc_threadvar_relocate_proc:=@SysRelocateThreadvar;
+      end;
+
+{$endif HASTHREADVAR}
+
+
+{*****************************************************************************
+                            Thread starting
+*****************************************************************************}
+
+    const
+      DefaultStackSize = 32768; { including 16384 margin for stackchecking }
+
+    type
+      pthreadinfo = ^tthreadinfo;
+      tthreadinfo = record
+        f : tthreadfunc;
+        p : pointer;
+        stklen : cardinal;
+      end;
+
+    procedure InitThread(stklen:cardinal);
+      begin
+        SysResetFPU;
+        { ExceptAddrStack and ExceptObjectStack are threadvars       }
+        { so every thread has its on exception handling capabilities }
+        SysInitExceptions;
+        { Open all stdio fds again }
+        SysInitStdio;
+        InOutRes:=0;
+        // ErrNo:=0;
+        { Stack checking }
+        StackLength:=stklen;
+        StackBottom:=Sptr - StackLength;
+      end;
+
+
+    procedure DoneThread;
+      begin
+        { Release Threadvars }
+{$ifdef HASTHREADVAR}
+        SysReleaseThreadVars;
+{$endif HASTHREADVAR}
+      end;
+
+
+    function ThreadMain(param : pointer) : pointer;cdecl;
+      var
+        ti : tthreadinfo;
+      begin
+{$ifdef HASTHREADVAR}
+        { Allocate local thread vars, this must be the first thing,
+          because the exception management and io depends on threadvars }
+        SysAllocateThreadVars;
+{$endif HASTHREADVAR}
+        { Copy parameter to local data }
+{$ifdef DEBUG_MT}
+        writeln('New thread started, initialising ...');
+{$endif DEBUG_MT}
+        ti:=pthreadinfo(param)^;
+        dispose(pthreadinfo(param));
+        { Initialize thread }
+        InitThread(ti.stklen);
+        { Start thread function }
+{$ifdef DEBUG_MT}
+        writeln('Jumping to thread function');
+{$endif DEBUG_MT}
+        ThreadMain:=pointer(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}
+        { Initialize multithreading if not done }
+        if not IsMultiThread then
+         begin
+{$ifdef HASTHREADVAR}
+           InitThreadVars;
+{$endif HASTHREADVAR}
+           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;
+        { call pthread_create }
+{$ifdef DEBUG_MT}
+        writeln('Starting new thread');
+{$endif DEBUG_MT}
+        BeginThread:=CreateThread(sa,stacksize,@ThreadMain,ti,creationflags,threadid);
+        BeginThread:=threadid;
+      end;
+
+
+    procedure EndThread(ExitCode : DWord);
+      begin
+        DoneThread;
+        ExitThread(ExitCode);
+      end;
+
+
+{*****************************************************************************
+                          Delphi/Win32 compatibility
+*****************************************************************************}
+
+{ we implement these procedures for win32 by importing them }
+{ directly from windows                                     }
+procedure InitCriticalSection(var cs : TRTLCriticalSection);
+  external 'kernel32' name 'InitializeCriticalSection';
+
+procedure DoneCriticalSection(var cs : TRTLCriticalSection);
+  external 'kernel32' name 'DeleteCriticalSection';
+
+procedure EnterCriticalSection(var cs : TRTLCriticalSection);
+  external 'kernel32' name 'EnterCriticalSection';
+
+procedure LeaveCriticalSection(var cs : TRTLCriticalSection);
+  external 'kernel32' name 'LeaveCriticalSection';
+
+
+{*****************************************************************************
+                           Heap Mutex Protection
+*****************************************************************************}
+
+    var
+      HeapMutex : TRTLCriticalSection;
+
+    procedure Win32HeapMutexInit;
+      begin
+         InitCriticalSection(heapmutex);
+      end;
+
+    procedure Win32HeapMutexDone;
+      begin
+         DoneCriticalSection(heapmutex);
+      end;
+
+    procedure Win32HeapMutexLock;
+      begin
+         EnterCriticalSection(heapmutex);
+      end;
+
+    procedure Win32HeapMutexUnlock;
+      begin
+         LeaveCriticalSection(heapmutex);
+      end;
+
+    const
+      Win32MemoryMutexManager : TMemoryMutexManager = (
+        MutexInit : @Win32HeapMutexInit;
+        MutexDone : @Win32HeapMutexDone;
+        MutexLock : @Win32HeapMutexLock;
+        MutexUnlock : @Win32HeapMutexUnlock;
+      );
+
+    procedure InitHeapMutexes;
+      begin
+        SetMemoryMutexManager(Win32MemoryMutexManager);
+      end;
+
+
+{*****************************************************************************
+                             Generic overloaded
+*****************************************************************************}
+
+{ Include generic overloaded routines }
+{$i thread.inc}
+
+initialization
+  InitHeapMutexes;
+end.
+{
+  $Log$
+  Revision 1.1  2002-10-14 19:39:18  peter
+    * threads unit added for thread support
+
+}
+