paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-03 15:29:26 +01:00
Code Issues Packages Projects Releases Wiki Activity

* threads unit added for thread support

Browse Source
This commit is contained in:
peter 2002-10-14 19:39:16 +00:00
parent bf93b60f51
commit 5fff238567
24 changed files with 1444 additions and 973 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
rtl/go32v2/dpmiexcp.pp
View File

@ -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

45
rtl/go32v2/system.pp
View File

@ -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

34
rtl/i386/i386.inc
View File

@ -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

13
rtl/inc/except.inc
View File

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

15
rtl/inc/generic.inc
View File

@ -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

180
rtl/inc/heap.inc
View File

@ -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

12
rtl/inc/heaph.inc
View File

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

15
rtl/inc/system.inc
View File

@ -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

43
rtl/inc/systemh.inc
View File

@ -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

73
rtl/inc/thread.inc Normal file
View File

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

16
rtl/inc/threadh.inc
View File

@ -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

95
rtl/inc/threadvar.inc Normal file
View File

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

21
rtl/linux/Makefile
View File

@ -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\

9
rtl/linux/Makefile.fpc
View File

@ -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

157
rtl/linux/syscalls.inc
View File

@ -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

45
rtl/os2/system.pas
View File

@ -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

98
rtl/unix/sysunix.inc
View File

@ -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

189
rtl/unix/thread.inc
View File

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

544
rtl/unix/threads.pp Normal file
View File

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

50
rtl/win32/Makefile
View File

@ -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)

13
rtl/win32/Makefile.fpc
View File

@ -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

140
rtl/win32/system.pp
View File

@ -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

284
rtl/win32/thread.inc
View File

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

313
rtl/win32/threads.pp Normal file
View File

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