mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-09-03 10:30:29 +02:00
+ beginning of the OS/2 version
This commit is contained in:
parent
a3caaec3a0
commit
c9a940fe1d
@ -877,6 +877,17 @@ begin
|
||||
end;
|
||||
exitproc:=nil;
|
||||
|
||||
{$ifdef MT}
|
||||
if os_mode = os_OS2 then
|
||||
begin
|
||||
{ allocate one ThreadVar entry from the OS, we use this entry }
|
||||
{ for a pointer to our threadvars }
|
||||
DataIndex := TlsAlloc;
|
||||
{ the exceptions use threadvars so do this _before_ initexceptions }
|
||||
AllocateThreadVars;
|
||||
end;
|
||||
{$endif MT}
|
||||
|
||||
{Initialize the heap.}
|
||||
initheap;
|
||||
|
||||
@ -896,7 +907,10 @@ begin
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.4 2000-11-13 21:23:38 hajny
|
||||
Revision 1.5 2001-01-23 20:38:59 hajny
|
||||
+ beginning of the OS/2 version
|
||||
|
||||
Revision 1.4 2000/11/13 21:23:38 hajny
|
||||
* ParamStr (0) fixed
|
||||
|
||||
Revision 1.3 2000/11/11 23:12:39 hajny
|
||||
|
183
rtl/os2/thread.inc
Normal file
183
rtl/os2/thread.inc
Normal file
@ -0,0 +1,183 @@
|
||||
{
|
||||
$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 OS/2
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
const
|
||||
ThreadVarBlockSize: dword = 0;
|
||||
|
||||
type
|
||||
TThreadInfo = record
|
||||
F: TThreadFunc;
|
||||
P: pointer;
|
||||
end;
|
||||
PThreadInfo = ^TThreadInfo;
|
||||
PPointer = ^pointer;
|
||||
|
||||
var
|
||||
(* Pointer to an allocated dword space within the local thread *)
|
||||
(* memory area. Pointer to the real memory block allocated for *)
|
||||
(* thread vars in this block is then stored in this dword. *)
|
||||
DataIndex: PPointer;
|
||||
|
||||
{ import the necessary stuff from the OS }
|
||||
function DosAllocThreadLocalMemory (Count: cardinal; var P: pointer): longint;
|
||||
cdecl; external 'DOSCALLS' index 454;
|
||||
|
||||
function DosFreeThreadLocalMemory (P: pointer): longint; cdecl;
|
||||
external 'DOSCALLS' index 455;
|
||||
|
||||
function DosCreateThread (var TID: longint; Address: TThreadEntry;
|
||||
aParam: pointer; Flags: longint; StackSize: longint): longint; cdecl;
|
||||
external 'DOSCALLS' index 311;
|
||||
|
||||
procedure DosExit (Action, Result: longint); cdecl;
|
||||
external 'DOSCALLS' index 233;
|
||||
|
||||
procedure Init_ThreadVar (var TVOffset: dword; Size: dword);
|
||||
[public, alias: 'FPC_INIT_THREADVAR'];
|
||||
begin
|
||||
TVOffset := ThreadVarBlockSize;
|
||||
Inc (ThreadVarBlockSize, Size);
|
||||
end;
|
||||
|
||||
function Relocate_ThreadVar (TVOffset: dword): pointer;
|
||||
[public,alias: 'FPC_RELOCATE_THREADVAR'];
|
||||
begin
|
||||
Relocate_ThreadVar := DataIndex + TVOffset;
|
||||
end;
|
||||
|
||||
procedure AllocateThreadVars;
|
||||
begin
|
||||
{ we've to allocate the memory from the OS }
|
||||
{ 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 }
|
||||
if DosAllocMem (DataIndex^, ThreadVarBlockSize, ) <> 0 then RunError (8);
|
||||
end;
|
||||
|
||||
procedure InitThread;
|
||||
begin
|
||||
InitFPU;
|
||||
{ we don't need to set the data to 0 because we did this with }
|
||||
{ the fillchar above, but it looks nicer }
|
||||
|
||||
{ ExceptAddrStack and ExceptObjectStack are threadvars }
|
||||
{ so every thread has its on exception handling capabilities }
|
||||
InitExceptions;
|
||||
InOutRes := 0;
|
||||
ErrNo := 0;
|
||||
end;
|
||||
|
||||
procedure DoneThread;
|
||||
begin
|
||||
{ release thread vars }
|
||||
DosFreeMem (DataIndex^);
|
||||
end;
|
||||
|
||||
function ThreadMain (Param: pointer): dword; 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;
|
||||
begin
|
||||
{$ifdef DEBUG_MT}
|
||||
WriteLn ('Creating new thread');
|
||||
{$endif DEBUG_MT}
|
||||
IsMultiThreaded := true;
|
||||
{ the only way to pass data to the newly created thread }
|
||||
{ in a MT safe way, is to use the heap }
|
||||
New (TI);
|
||||
TI^.F := ThreadFunction;
|
||||
TI^.P := P;
|
||||
{$ifdef DEBUG_MT}
|
||||
WriteLn ('Starting new thread');
|
||||
{$endif DEBUG_MT}
|
||||
BeginThread := CreateThread (sa,stacksize,@ThreadMain,ti,
|
||||
creationflags,threadid);
|
||||
end;
|
||||
|
||||
function BeginThread (ThreadFunction: TThreadFunc): dword;
|
||||
var
|
||||
Dummy: dword;
|
||||
begin
|
||||
BeginThread := BeginThread (nil, 0, ThreadFunction, nil, 0, Dummy);
|
||||
end;
|
||||
|
||||
function BeginThread (ThreadFunction: TThreadFunc; P: pointer): dword;
|
||||
var
|
||||
Dummy: dword;
|
||||
begin
|
||||
BeginThread := BeginThread (nil, 0, ThreadFunction, P, 0, Dummy);
|
||||
end;
|
||||
|
||||
function BeginThread (ThreadFunction: TThreadFunc; P: pointer;
|
||||
var ThreadID: dword): dword;
|
||||
begin
|
||||
BeginThread := BeginThread (nil, 0, ThreadFunction, P, 0, ThreadID);
|
||||
end;
|
||||
|
||||
procedure EndThread (ExitCode: dword);
|
||||
begin
|
||||
DoneThread;
|
||||
DosExit (0, 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;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2001-01-23 20:38:59 hajny
|
||||
+ beginning of the OS/2 version
|
||||
|
||||
Revision 1.1 2001/01/01 19:06:36 florian
|
||||
+ initial release
|
||||
|
||||
}
|
Loading…
Reference in New Issue
Block a user