* start of thread support for linux

rtl/freebsd/sysconst.inc

@@ -42,8 +42,8 @@ Const
   { The waitpid uses the following options:}
   Wait_NoHang   = 1;
   Wait_UnTraced = 2;
-  Wait_Any      = -1; 
-  Wait_MyPGRP   = 0;  
+  Wait_Any      = -1;
+  Wait_MyPGRP   = 0;
   { Constants to check stat.mode -  checked all STAT constants with BSD}
   STAT_IFMT   = $f000; {00170000 }
   STAT_IFSOCK = $c000; {0140000 }
@@ -55,12 +55,12 @@ Const
   STAT_IFIFO  = $1000; {0010000 }
   STAT_ISUID  = $0800; {0004000 }
   STAT_ISGID  = $0400; {0002000 }
-  STAT_ISVTX  = $0200; {0001000} 
+  STAT_ISVTX  = $0200; {0001000}
   { Constants to check permissions all }
-  STAT_IRWXO = $7;         
-  STAT_IROTH = $4;         
-  STAT_IWOTH = $2;         
-  STAT_IXOTH = $1;         
+  STAT_IRWXO = $7;
+  STAT_IROTH = $4;
+  STAT_IWOTH = $2;
+  STAT_IXOTH = $1;
 
   STAT_IRWXG = STAT_IRWXO shl 3;
   STAT_IRGRP = STAT_IROTH shl 3;
@@ -92,10 +92,23 @@ Const
   {Constansts Termios/Ioctl (used in Do_IsDevice) }
   IOCtl_TCGETS=$5401; // TCGETS is also in termios.inc, but the sysunix needs only this
 
+  {Checked for BSD using Linuxthreads port}
+  { cloning flags }
+  CSIGNAL       = $000000ff; // signal mask to be sent at exit
+  CLONE_VM      = $00000100; // set if VM shared between processes
+  CLONE_FS      = $00000200; // set if fs info shared between processes
+  CLONE_FILES   = $00000400; // set if open files shared between processes
+  CLONE_SIGHAND = $00000800; // set if signal handlers shared
+  CLONE_PID     = $00001000; // set if pid shared
+type
+  TCloneFunc=function(args:pointer):longint;cdecl;
 
 {
   $Log$
-  Revision 1.4  2001-06-19 08:34:16  marco
+  Revision 1.5  2001-10-14 13:33:20  peter
+    * start of thread support for linux
+
+  Revision 1.4  2001/06/19 08:34:16  marco
    * Peter didn't merge the FreeBSD directory when he merged the Unix one. Fixed
 
   Revision 1.3  2001/01/23 20:37:14  marco

rtl/linux/syscalls.inc

@@ -445,6 +445,95 @@ begin
   Sys_mmap:=syscall(syscall_nr_mmap,t);
 end;
 
+Function Sys_munmap(adr,len:longint):longint; // moved from sysunix.inc, used in sbrk
+var
+  t     : syscallregs;
+begin
+  t.reg2:=adr;
+  t.reg3:=len;
+  Sys_munmap:=syscall(syscall_nr_munmap,t);
+end;
+
+
+function Clone(func:TCloneFunc;sp:pointer;flags:longint;args:pointer):longint;
+begin
+  if (pointer(func)=nil) or (sp=nil) then
+   exit(-1); // give an error result
+{$ifdef i386}
+  asm
+        { Insert the argument onto the new stack. }
+        movl    sp,%ecx
+        subl    $8,%ecx
+        movl    args,%eax
+        movl    %eax,4(%ecx)
+
+        { Save the function pointer as the zeroth argument.
+          It will be popped off in the child in the ebx frobbing below. }
+        movl    func,%eax
+        movl    %eax,0(%ecx)
+
+        { Do the system call }
+        pushl   %ebx
+        movl    flags,%ebx
+        movl    SysCall_nr_clone,%eax
+        int     $0x80
+        popl    %ebx
+        test    %eax,%eax
+        jnz     .Lclone_end
+
+        { We're in the new thread }
+        subl    %ebp,%ebp       { terminate the stack frame }
+        call    *%ebx
+        { exit process }
+        movl    %eax,%ebx
+        movl    $1,%eax
+        int     $0x80
+
+.Lclone_end:
+        movl    %eax,__RESULT
+  end;
+{$endif i386}
+{$ifdef m68k}
+  { No yet translated, my m68k assembler is too weak for such things PM }
+(*
+  asm
+        { Insert the argument onto the new stack. }
+        movl    sp,%ecx
+        subl    $8,%ecx
+        movl    args,%eax
+        movl    %eax,4(%ecx)
+
+        { Save the function pointer as the zeroth argument.
+          It will be popped off in the child in the ebx frobbing below. }
+        movl    func,%eax
+        movl    %eax,0(%ecx)
+
+        { Do the system call }
+        pushl   %ebx
+        movl    flags,%ebx
+        movl    SysCall_nr_clone,%eax
+        int     $0x80
+        popl    %ebx
+        test    %eax,%eax
+        jnz     .Lclone_end
+
+        { We're in the new thread }
+        subl    %ebp,%ebp       { terminate the stack frame }
+        call    *%ebx
+        { exit process }
+        movl    %eax,%ebx
+        movl    $1,%eax
+        int     $0x80
+
+.Lclone_end:
+        movl    %eax,__RESULT
+  end;
+  *)
+{$endif m68k}
+end;
+
+
+
 {
   Interface to Unix ioctl call.
   Performs various operations on the filedescriptor Handle.
@@ -465,7 +554,10 @@ end;
 
 {
   $Log$
-  Revision 1.4  2001-06-02 00:31:30  peter
+  Revision 1.5  2001-10-14 13:33:20  peter
+    * start of thread support for linux
+
+  Revision 1.4  2001/06/02 00:31:30  peter
     * merge unix updates from the 1.0 branch, mostly related to the
       solaris target
 

rtl/linux/sysconst.inc

@@ -32,9 +32,9 @@ Const
   Open_NDelay    = Open_NonBlock;
   Open_Sync      = 1 shl 12;
   Open_Direct    = 4 shl 12;
-  Open_LargeFile = 1 shl 15; 
-  Open_Directory = 2 shl 15; 
-  Open_NoFollow  = 4 shl 15; 
+  Open_LargeFile = 1 shl 15;
+  Open_Directory = 2 shl 15;
+  Open_NoFollow  = 4 shl 15;
   { The waitpid uses the following options:}
   Wait_NoHang   = 1;
   Wait_UnTraced = 2;
@@ -88,10 +88,25 @@ Const
 
   {Constansts Termios/Ioctl (used in Do_IsDevice) }
   IOCtl_TCGETS=$5401; // TCGETS is also in termios.inc, but the sysunix needs only this
-  
+
+  {Checked for BSD using Linuxthreads port}
+  { cloning flags }
+  CSIGNAL       = $000000ff; // signal mask to be sent at exit
+  CLONE_VM      = $00000100; // set if VM shared between processes
+  CLONE_FS      = $00000200; // set if fs info shared between processes
+  CLONE_FILES   = $00000400; // set if open files shared between processes
+  CLONE_SIGHAND = $00000800; // set if signal handlers shared
+  CLONE_PID     = $00001000; // set if pid shared
+type
+  TCloneFunc=function(args:pointer):longint;cdecl;
+
+
 {
   $Log$
-  Revision 1.4  2001-06-02 00:31:30  peter
+  Revision 1.5  2001-10-14 13:33:20  peter
+    * start of thread support for linux
+
+  Revision 1.4  2001/06/02 00:31:30  peter
     * merge unix updates from the 1.0 branch, mostly related to the
       solaris target
 

rtl/linux/thread.inc

@@ -0,0 +1,189 @@
+{
+    $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 : tcriticalsection);
+      begin
+      end;
+
+    procedure DoneCriticalSection(var cs : tcriticalsection);
+      begin
+      end;
+
+
+    procedure EnterCriticalSection(var cs : tcriticalsection);
+      begin
+      end;
+
+    procedure LeaveCriticalSection(var cs : tcriticalsection);
+      begin
+      end;
+
+{$endif MT}
+
+{
+  $Log$
+  Revision 1.1  2001-10-14 13:33:20  peter
+    * start of thread support for linux
+
+}

rtl/linux/unixsysc.inc

@@ -29,87 +29,6 @@ begin
 End;
 
 
-function clone(func:TCloneFunc;sp:pointer;flags:longint;args:pointer):longint;
-begin
-  if (pointer(func)=nil) or (sp=nil) then
-   begin
-     LinuxError:=Sys_EInval;
-     exit(-1); // give an error result
-   end;
-{$ifdef i386}
-  asm
-        { Insert the argument onto the new stack. }
-        movl    sp,%ecx
-        subl    $8,%ecx
-        movl    args,%eax
-        movl    %eax,4(%ecx)
-
-        { Save the function pointer as the zeroth argument.
-          It will be popped off in the child in the ebx frobbing below. }
-        movl    func,%eax
-        movl    %eax,0(%ecx)
-
-        { Do the system call }
-        pushl   %ebx
-        movl    flags,%ebx
-        movl    SysCall_nr_clone,%eax
-        int     $0x80
-        popl    %ebx
-        test    %eax,%eax
-        jnz     .Lclone_end
-
-        { We're in the new thread }
-        subl    %ebp,%ebp       { terminate the stack frame }
-        call    *%ebx
-        { exit process }
-        movl    %eax,%ebx
-        movl    $1,%eax
-        int     $0x80
-
-.Lclone_end:
-        movl    %eax,__RESULT
-  end;
-{$endif i386}
-{$ifdef m68k}
-  { No yet translated, my m68k assembler is too weak for such things PM }
-(*
-  asm
-        { Insert the argument onto the new stack. }
-        movl    sp,%ecx
-        subl    $8,%ecx
-        movl    args,%eax
-        movl    %eax,4(%ecx)
-
-        { Save the function pointer as the zeroth argument.
-          It will be popped off in the child in the ebx frobbing below. }
-        movl    func,%eax
-        movl    %eax,0(%ecx)
-
-        { Do the system call }
-        pushl   %ebx
-        movl    flags,%ebx
-        movl    SysCall_nr_clone,%eax
-        int     $0x80
-        popl    %ebx
-        test    %eax,%eax
-        jnz     .Lclone_end
-
-        { We're in the new thread }
-        subl    %ebp,%ebp       { terminate the stack frame }
-        call    *%ebx
-        { exit process }
-        movl    %eax,%ebx
-        movl    $1,%eax
-        int     $0x80
-
-.Lclone_end:
-        movl    %eax,__RESULT
-  end;
-  *)
-{$endif m68k}
-end;
-
-
 Procedure Execve(path:pathstr;args:ppchar;ep:ppchar);
 {
   Replaces the current program by the program specified in path,
@@ -966,7 +885,10 @@ end;
 
 {
   $Log$
-  Revision 1.4  2001-07-15 11:57:16  peter
+  Revision 1.5  2001-10-14 13:33:20  peter
+    * start of thread support for linux
+
+  Revision 1.4  2001/07/15 11:57:16  peter
     * merged m68k updates
 
   Revision 1.3  2001/06/03 20:19:09  peter

rtl/unix/linux.pp

@@ -33,17 +33,6 @@ var
 {********************
       Process
 ********************}
-const
-  {Checked for BSD using Linuxthreads port}
-  { cloning flags }
-  CSIGNAL       = $000000ff; // signal mask to be sent at exit
-  CLONE_VM      = $00000100; // set if VM shared between processes
-  CLONE_FS      = $00000200; // set if fs info shared between processes
-  CLONE_FILES   = $00000400; // set if open files shared between processes
-  CLONE_SIGHAND = $00000800; // set if signal handlers shared
-  CLONE_PID     = $00001000; // set if pid shared
-type
-  TCloneFunc=function(args:pointer):longint;cdecl;
 
 const
   { For getting/setting priority }
@@ -392,7 +381,7 @@ Function NanoSleep(const req : timespec;var rem : timespec) : longint;
 
 Function  IOCtl(Handle,Ndx: Longint;Data: Pointer):boolean;
 Function  TCGetAttr(fd:longint;var tios:TermIOS):boolean;
-Function  TCSetAttr(fd:longint;OptAct:longint;var tios:TermIOS):boolean;
+Function  TCSetAttr(fd:longint;OptAct:longint;const tios:TermIOS):boolean;
 Procedure CFSetISpeed(var tios:TermIOS;speed:Longint);
 Procedure CFSetOSpeed(var tios:TermIOS;speed:Longint);
 Procedure CFMakeRaw(var tios:TermIOS);
@@ -1935,7 +1924,7 @@ end;
 
 
 
-Function TCSetAttr(fd:longint;OptAct:longint;var tios:TermIOS):boolean;
+Function TCSetAttr(fd:longint;OptAct:longint;const tios:TermIOS):boolean;
 var
   nr:longint;
 begin
@@ -2957,7 +2946,10 @@ End.
 
 {
   $Log$
-  Revision 1.16  2001-09-17 21:36:31  peter
+  Revision 1.17  2001-10-14 13:33:20  peter
+    * start of thread support for linux
+
+  Revision 1.16  2001/09/17 21:36:31  peter
     * merged fixes
 
   Revision 1.15  2001/08/12 18:08:59  peter

rtl/unix/sysunix.inc

@@ -43,6 +43,31 @@ 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;
@@ -514,36 +539,18 @@ begin
   dir:=thedir
 end;
 
-
+{$ifdef linux}
 {*****************************************************************************
-                         SystemUnit Initialization
+                             Thread Handling
 *****************************************************************************}
 
+{ include threading stuff, this is os independend part }
+{$I thread.inc}
+{$endif linux}
 
-{$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;
-
+{*****************************************************************************
+                         SystemUnit Initialization
+*****************************************************************************}
 
 {$ifdef BSD}
  procedure SignalToRunerror(Sig: longint; SigContext: SigContextRec;someptr:pointer); cdecl;
@@ -724,7 +731,10 @@ End.
 
 {
   $Log$
-  Revision 1.17  2001-09-30 21:10:20  peter
+  Revision 1.18  2001-10-14 13:33:21  peter
+    * start of thread support for linux
+
+  Revision 1.17  2001/09/30 21:10:20  peter
     * erase(directory) returns now 2 to be tp compatible
 
   Revision 1.16  2001/08/05 12:24:20  peter

rtl/unix/sysunixh.inc

@@ -18,6 +18,25 @@
 {$define newsignal}
 
 {$I systemh.inc}
+
+{$ifdef linux}
+type
+   { the fields of this record are os dependent  }
+   { and they shouldn't be used in a program     }
+   { only the type TCriticalSection is important }
+   TCriticalSection = packed record
+      DebugInfo : pointer;
+      LockCount : longint;
+      RecursionCount : longint;
+      OwningThread : DWord;
+      LockSemaphore : DWord;
+      Reserved : DWord;
+   end;
+
+{ include threading stuff }
+{$i threadh.inc}
+{$endif linux}
+
 {$I heaph.inc}
 
 {$ifdef m68k}
@@ -54,7 +73,10 @@ var
 
 {
   $Log$
-  Revision 1.10  2001-06-27 21:37:39  peter
+  Revision 1.11  2001-10-14 13:33:21  peter
+    * start of thread support for linux
+
+  Revision 1.10  2001/06/27 21:37:39  peter
     * v10 merges
 
   Revision 1.9  2001/06/18 14:26:16  jonas

rtl/unix/unix.pp

@@ -33,18 +33,6 @@ var
 {********************
       Process
 ********************}
-const
-  {Checked for BSD using Linuxthreads port}
-  { cloning flags }
-  CSIGNAL       = $000000ff; // signal mask to be sent at exit
-  CLONE_VM      = $00000100; // set if VM shared between processes
-  CLONE_FS      = $00000200; // set if fs info shared between processes
-  CLONE_FILES   = $00000400; // set if open files shared between processes
-  CLONE_SIGHAND = $00000800; // set if signal handlers shared
-  CLONE_PID     = $00001000; // set if pid shared
-type
-  TCloneFunc=function(args:pointer):longint;cdecl;
-
 const
   { For getting/setting priority }
   Prio_Process = 0;
@@ -379,7 +367,7 @@ Function NanoSleep(const req : timespec;var rem : timespec) : longint;
 
 Function  IOCtl(Handle,Ndx: Longint;Data: Pointer):boolean;
 Function  TCGetAttr(fd:longint;var tios:TermIOS):boolean;
-Function  TCSetAttr(fd:longint;OptAct:longint;var tios:TermIOS):boolean;
+Function  TCSetAttr(fd:longint;OptAct:longint;const tios:TermIOS):boolean;
 Procedure CFSetISpeed(var tios:TermIOS;speed:Longint);
 Procedure CFSetOSpeed(var tios:TermIOS;speed:Longint);
 Procedure CFMakeRaw(var tios:TermIOS);
@@ -1916,7 +1904,7 @@ end;
 
 
 
-Function TCSetAttr(fd:longint;OptAct:longint;var tios:TermIOS):boolean;
+Function TCSetAttr(fd:longint;OptAct:longint;const tios:TermIOS):boolean;
 var
   nr:longint;
 begin
@@ -2934,7 +2922,10 @@ End.
 
 {
   $Log$
-  Revision 1.16  2001-09-17 21:36:31  peter
+  Revision 1.17  2001-10-14 13:33:21  peter
+    * start of thread support for linux
+
+  Revision 1.16  2001/09/17 21:36:31  peter
     * merged fixes
 
   Revision 1.15  2001/08/12 18:05:19  peter