mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-21 03:02:57 +02:00
* changes for new threadvar support
This commit is contained in:
armin
parent
1a3fb171dc
commit
abb6577ccd
@ -1,8 +1,8 @@
|
||||
#
|
||||
# Don't edit, this file is generated by FPCMake Version 1.1 [2003/01/14]
|
||||
# Don't edit, this file is generated by FPCMake Version 1.1 [2002/04/16]
|
||||
#
|
||||
default: all
|
||||
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos macosx
|
||||
MAKEFILETARGETS=netware
|
||||
override PATH:=$(subst \,/,$(PATH))
|
||||
ifeq ($(findstring ;,$(PATH)),)
|
||||
inUnix=1
|
||||
@ -42,9 +42,6 @@ endif
|
||||
ifeq ($(OS_TARGET),netbsd)
|
||||
BSDhier=1
|
||||
endif
|
||||
ifeq ($(OS_TARGET),openbsd)
|
||||
BSDhier=1
|
||||
endif
|
||||
ifdef inUnix
|
||||
BATCHEXT=.sh
|
||||
else
|
||||
@ -58,9 +55,6 @@ ifdef inUnix
|
||||
PATHSEP=/
|
||||
else
|
||||
PATHSEP:=$(subst /,\,/)
|
||||
ifdef inCygWin
|
||||
PATHSEP=/
|
||||
endif
|
||||
endif
|
||||
ifdef PWD
|
||||
BASEDIR:=$(subst \,/,$(shell $(PWD)))
|
||||
@ -90,7 +84,7 @@ endif
|
||||
endif
|
||||
export ECHO
|
||||
endif
|
||||
override OS_TARGET_DEFAULT=netware
|
||||
OS_TARGET=netware
|
||||
override DEFAULT_FPCDIR=../..
|
||||
ifndef FPC
|
||||
ifdef PP
|
||||
@ -112,38 +106,37 @@ endif
|
||||
override FPC:=$(subst $(SRCEXEEXT),,$(FPC))
|
||||
override FPC:=$(subst \,/,$(FPC))$(SRCEXEEXT)
|
||||
ifndef FPC_VERSION
|
||||
FPC_COMPILERINFO:=$(shell $(FPC) -iVSPTPSOTO)
|
||||
FPC_VERSION:=$(word 1,$(FPC_COMPILERINFO))
|
||||
FPC_VERSION:=$(shell $(FPC) -iV)
|
||||
endif
|
||||
export FPC FPC_VERSION FPC_COMPILERINFO
|
||||
export FPC FPC_VERSION
|
||||
unexport CHECKDEPEND ALLDEPENDENCIES
|
||||
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
|
||||
ifneq ($(words $(FPC_COMPILERINFO)),5)
|
||||
FPC_COMPILERINFO+=$(shell $(FPC) -iSP)
|
||||
FPC_COMPILERINFO+=$(shell $(FPC) -iTP)
|
||||
FPC_COMPILERINFO+=$(shell $(FPC) -iSO)
|
||||
FPC_COMPILERINFO+=$(shell $(FPC) -iTO)
|
||||
endif
|
||||
ifeq ($(findstring 1.0.,$(FPC_VERSION)),)
|
||||
COMPILERINFO:=$(shell $(FPC) -iSP -iTP -iSO -iTO)
|
||||
ifndef CPU_SOURCE
|
||||
CPU_SOURCE:=$(word 2,$(FPC_COMPILERINFO))
|
||||
CPU_SOURCE:=$(word 1,$(COMPILERINFO))
|
||||
endif
|
||||
ifndef CPU_TARGET
|
||||
CPU_TARGET:=$(word 3,$(FPC_COMPILERINFO))
|
||||
CPU_TARGET:=$(word 2,$(COMPILERINFO))
|
||||
endif
|
||||
ifndef OS_SOURCE
|
||||
OS_SOURCE:=$(word 4,$(FPC_COMPILERINFO))
|
||||
OS_SOURCE:=$(word 3,$(COMPILERINFO))
|
||||
endif
|
||||
ifndef OS_TARGET
|
||||
OS_TARGET:=$(word 5,$(FPC_COMPILERINFO))
|
||||
OS_TARGET:=$(word 4,$(COMPILERINFO))
|
||||
endif
|
||||
else
|
||||
ifndef CPU_SOURCE
|
||||
CPU_SOURCE:=$(shell $(FPC) -iSP)
|
||||
endif
|
||||
ifndef CPU_TARGET
|
||||
CPU_TARGET:=$(shell $(FPC) -iTP)
|
||||
endif
|
||||
ifndef OS_SOURCE
|
||||
OS_SOURCE:=$(shell $(FPC) -iSO)
|
||||
endif
|
||||
ifndef OS_TARGET
|
||||
OS_TARGET:=$(shell $(FPC) -iTO)
|
||||
endif
|
||||
endif
|
||||
FULL_TARGET=$(CPU_TARGET)-$(OS_TARGET)
|
||||
FULL_SOURCE=$(CPU_SOURCE)-$(OS_SOURCE)
|
||||
@ -218,7 +211,7 @@ override FPCOPT+=-Ur
|
||||
override FPCOPT+=-dMT
|
||||
CREATESMART=1
|
||||
OBJPASDIR=$(RTL)/objpas
|
||||
override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings netware winsock2 dos crt objects sysutils typinfo math cpu mmx getopts heaptrc lineinfo sockets aio varutils video mouse keyboard types
|
||||
override TARGET_UNITS+=$(SYSTEMUNIT) systhrds objpas strings netware winsock2 dos crt objects sysutils typinfo math cpu mmx getopts heaptrc lineinfo sockets aio varutils video mouse keyboard types
|
||||
override TARGET_LOADERS+=nwpre prelude
|
||||
override TARGET_RSTS+=math typinfo varutils
|
||||
override INSTALL_FPCPACKAGE=y
|
||||
@ -241,15 +234,9 @@ 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
|
||||
@ -260,15 +247,9 @@ 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
|
||||
@ -464,12 +445,6 @@ 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
|
||||
@ -495,7 +470,7 @@ ECHO=echo
|
||||
endif
|
||||
ifeq ($(OS_TARGET),amiga)
|
||||
EXEEXT=
|
||||
PPUEXT=.ppu
|
||||
PPUEXT=.ppa
|
||||
ASMEXT=.asm
|
||||
OEXT=.o
|
||||
SMARTEXT=.sl
|
||||
@ -504,7 +479,7 @@ SHAREDLIBEXT=.library
|
||||
FPCMADE=fpcmade.amg
|
||||
endif
|
||||
ifeq ($(OS_TARGET),atari)
|
||||
PPUEXT=.ppu
|
||||
PPUEXT=.ppt
|
||||
ASMEXT=.s
|
||||
OEXT=.o
|
||||
SMARTEXT=.sl
|
||||
@ -554,15 +529,6 @@ FPCMADE=fpcmade.nw
|
||||
ZIPSUFFIX=nw
|
||||
EXEEXT=.nlm
|
||||
endif
|
||||
ifeq ($(OS_TARGET),macos)
|
||||
PPUEXT=.ppu
|
||||
ASMEXT=.s
|
||||
OEXT=.o
|
||||
SMARTEXT=.sl
|
||||
STATICLIBEXT=.a
|
||||
EXEEXT=
|
||||
FPCMADE=fpcmade.mcc
|
||||
endif
|
||||
ifndef ECHO
|
||||
ECHO:=$(strip $(wildcard $(addsuffix /gecho$(SRCEXEEXT),$(SEARCHPATH))))
|
||||
ifeq ($(ECHO),)
|
||||
@ -790,9 +756,6 @@ 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
|
||||
@ -874,11 +837,6 @@ override COMPILER_UNITTARGETDIR=$(COMPILER_TARGETDIR)
|
||||
override UNITTARGETDIRPREFIX=$(TARGETDIRPREFIX)
|
||||
endif
|
||||
endif
|
||||
ifeq ($(OS_TARGET),linux)
|
||||
ifeq ($(FPC_VERSION),1.0.6)
|
||||
override FPCOPTDEF+=HASUNIX
|
||||
endif
|
||||
endif
|
||||
ifdef OPT
|
||||
override FPCOPT+=$(OPT)
|
||||
endif
|
||||
@ -1113,7 +1071,6 @@ fpc_baseinfo:
|
||||
@$(ECHO) Rm........ $(RMPROG)
|
||||
@$(ECHO) GInstall.. $(GINSTALL)
|
||||
@$(ECHO) Echo...... $(ECHO)
|
||||
@$(ECHO) Shell..... $(SHELL)
|
||||
@$(ECHO) Date...... $(DATE)
|
||||
@$(ECHO) FPCMake... $(FPCMAKE)
|
||||
@$(ECHO) PPUMove... $(PPUMOVE)
|
||||
|
||||
@ -7,7 +7,7 @@ main=rtl
|
||||
|
||||
[target]
|
||||
loaders=nwpre prelude
|
||||
units=$(SYSTEMUNIT) objpas strings \
|
||||
units=$(SYSTEMUNIT) systhrds objpas strings \
|
||||
netware winsock2 \
|
||||
dos crt objects \
|
||||
sysutils typinfo math \
|
||||
@ -52,6 +52,10 @@ endif
|
||||
override FPCOPT+=-Ur
|
||||
# endif
|
||||
|
||||
#override FPCOPT+=-a
|
||||
#override FPCOPT+=-al
|
||||
|
||||
|
||||
# for netware always use multithread
|
||||
override FPCOPT+=-dMT
|
||||
|
||||
|
||||
@ -1,6 +1,8 @@
|
||||
News
|
||||
====
|
||||
|
||||
2003/02/15 armin:
|
||||
- changes for new threadvars
|
||||
2002/02/27 armin:
|
||||
- changes for current fpc 1.1
|
||||
2001/04/16 armin:
|
||||
@ -166,6 +168,10 @@
|
||||
|
||||
I also have a compiled version of gdbserve.nlm for gdb on my homepage
|
||||
but this does not seem to be stable and will only run on netwar 4.x.
|
||||
|
||||
I also have a patched version of novells RDebug, you can try
|
||||
http://home.arcor.de/armin.diehl/fpcnw/Rdebug.exe
|
||||
|
||||
|
||||
- Netware SDK
|
||||
-----------
|
||||
@ -204,6 +210,7 @@
|
||||
- CPU
|
||||
- MMX
|
||||
- WinSock2
|
||||
- SYSTHRDS
|
||||
|
||||
|
||||
armin@freepascal.org
|
||||
|
||||
@ -51,7 +51,7 @@ type
|
||||
end;
|
||||
|
||||
{ include threading stuff }
|
||||
{$i threadh.inc}
|
||||
{ i threadh.inc}
|
||||
|
||||
{ include heap support headers }
|
||||
{$I heaph.inc}
|
||||
@ -85,6 +85,14 @@ PROCEDURE ConsolePrintf (FormatStr : PCHAR; Param : LONGINT); CDecl;
|
||||
PROCEDURE ConsolePrintf3 (FormatStr : PCHAR; P1,P2,P3 : LONGINT); CDecl;
|
||||
PROCEDURE ConsolePrintf (FormatStr : PCHAR); CDecl;
|
||||
|
||||
type
|
||||
TSysCloseAllRemainingSemaphores = procedure;
|
||||
TSysReleaseThreadVars = procedure;
|
||||
TSysSetThreadDataAreaPtr = function (newPtr:pointer):pointer;
|
||||
|
||||
procedure NWSysSetThreadFunctions (crs:TSysCloseAllRemainingSemaphores;
|
||||
rtv:TSysReleaseThreadVars;
|
||||
stdata:TSysSetThreadDataAreaPtr);
|
||||
|
||||
implementation
|
||||
{ Indicate that stack checking is taken care by OS}
|
||||
@ -107,6 +115,21 @@ begin
|
||||
end;
|
||||
}
|
||||
|
||||
var
|
||||
CloseAllRemainingSemaphores : TSysCloseAllRemainingSemaphores = nil;
|
||||
ReleaseThreadVars : TSysReleaseThreadVars = nil;
|
||||
SetThreadDataAreaPtr : TSysSetThreadDataAreaPtr = nil;
|
||||
|
||||
procedure NWSysSetThreadFunctions (crs:TSysCloseAllRemainingSemaphores;
|
||||
rtv:TSysReleaseThreadVars;
|
||||
stdata:TSysSetThreadDataAreaPtr);
|
||||
begin
|
||||
CloseAllRemainingSemaphores := crs;
|
||||
ReleaseThreadVars := rtv;
|
||||
SetThreadDataAreaPtr := stdata;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
|
||||
procedure PASCALMAIN;external name 'PASCALMAIN';
|
||||
@ -122,16 +145,11 @@ PROCEDURE nlm_main (_ArgC : LONGINT; _ArgV : ppchar); CDECL; [public,alias: '_nl
|
||||
BEGIN
|
||||
ArgC := _ArgC;
|
||||
ArgV := _ArgV;
|
||||
fpc_threadvar_relocate_proc := nil;
|
||||
PASCALMAIN;
|
||||
END;
|
||||
|
||||
|
||||
{$ifdef MT}
|
||||
procedure CloseAllRemainingSemaphores; FORWARD;
|
||||
procedure ReleaseThreadVars; FORWARD;
|
||||
{$endif}
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
System Dependent Exit code
|
||||
*****************************************************************************}
|
||||
@ -142,10 +160,9 @@ var SigTermHandlerActive : boolean;
|
||||
|
||||
Procedure system_exit;
|
||||
begin
|
||||
{$ifdef MT}
|
||||
CloseAllRemainingSemaphores;
|
||||
ReleaseThreadVars;
|
||||
{$endif}
|
||||
if assigned (CloseAllRemainingSemaphores) then CloseAllRemainingSemaphores;
|
||||
if assigned (ReleaseThreadVars) then ReleaseThreadVars;
|
||||
|
||||
FreeSbrkMem; { free memory allocated by heapmanager }
|
||||
|
||||
if not SigTermHandlerActive then
|
||||
@ -202,6 +219,10 @@ end;
|
||||
Heap Management
|
||||
*****************************************************************************}
|
||||
|
||||
var
|
||||
heap : longint;external name 'HEAP';
|
||||
intern_heapsize : longint;external name 'HEAPSIZE';
|
||||
|
||||
{ first address of heap }
|
||||
function getheapstart:pointer;
|
||||
assembler;
|
||||
@ -213,7 +234,7 @@ end ['EAX'];
|
||||
function getheapsize:longint;
|
||||
assembler;
|
||||
asm
|
||||
movl HEAPSIZE,%eax
|
||||
movl intern_HEAPSIZE,%eax
|
||||
end ['EAX'];
|
||||
|
||||
const HeapInitialMaxBlocks = 32;
|
||||
@ -240,8 +261,8 @@ begin
|
||||
if HeapSbrkBlockList = nil then
|
||||
begin
|
||||
_free (P);
|
||||
Sbrk := -1;
|
||||
exit;
|
||||
Sbrk := -1;
|
||||
exit;
|
||||
end;
|
||||
fillchar (HeapSbrkBlockList^,sizeof(HeapSbrkBlockList^),0);
|
||||
HeapSbrkAllocated := HeapInitialMaxBlocks;
|
||||
@ -252,8 +273,8 @@ begin
|
||||
if p2 = nil then
|
||||
begin
|
||||
_free (P);
|
||||
Sbrk := -1;
|
||||
exit;
|
||||
Sbrk := -1;
|
||||
exit;
|
||||
end;
|
||||
inc (HeapSbrkAllocated, HeapInitialMaxBlocks);
|
||||
end;
|
||||
@ -628,9 +649,6 @@ end;
|
||||
Thread Handling
|
||||
*****************************************************************************}
|
||||
|
||||
const
|
||||
fpucw : word = $1332;
|
||||
|
||||
procedure InitFPU;assembler;
|
||||
|
||||
asm
|
||||
@ -639,9 +657,6 @@ procedure InitFPU;assembler;
|
||||
end;
|
||||
|
||||
|
||||
{ include threading stuff, this is os dependend part }
|
||||
{$I thread.inc}
|
||||
|
||||
{ if return-value is <> 0, netware shows the message
|
||||
Unload Anyway ?
|
||||
To Disable unload at all, SetNLMDontUnloadFlag can be used on
|
||||
@ -658,11 +673,13 @@ begin
|
||||
oldTG := _SetThreadGroupID (NetwareMainThreadGroupID);
|
||||
{ to allow use of threadvars, we simply set the threadvar-memory
|
||||
from the main thread }
|
||||
oldPtr:= _GetThreadDataAreaPtr;
|
||||
_SaveThreadDataAreaPtr (thredvarsmainthread);
|
||||
if assigned (SetThreadDataAreaPtr) then
|
||||
oldPtr := SetThreadDataAreaPtr (NIL); { nil means main threadvars }
|
||||
result := 0;
|
||||
NetwareCheckFunction (result);
|
||||
_SaveThreadDataAreaPtr (oldPtr);
|
||||
if assigned (SetThreadDataAreaPtr) then
|
||||
SetThreadDataAreaPtr (oldPtr);
|
||||
|
||||
_SetThreadGroupID (oldTG);
|
||||
end else
|
||||
result := 0;
|
||||
@ -729,35 +746,18 @@ begin
|
||||
handler is called by netware with a differnt thread. To avoid
|
||||
problems in the exit routines, we set the data of the main thread
|
||||
here }
|
||||
oldPtr:= _GetThreadDataAreaPtr;
|
||||
_SaveThreadDataAreaPtr (thredvarsmainthread);
|
||||
if assigned (SetThreadDataAreaPtr) then
|
||||
oldPtr := SetThreadDataAreaPtr (NIL); { nil means main thread }
|
||||
SigTermHandlerActive := true; { to avoid that system_exit calls _exit }
|
||||
do_exit; { calls finalize units }
|
||||
_SaveThreadDataAreaPtr (oldPtr);
|
||||
if assigned (SetThreadDataAreaPtr) then
|
||||
SetThreadDataAreaPtr (oldPtr);
|
||||
_SetThreadGroupID (oldTG);
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
SystemUnit Initialization
|
||||
*****************************************************************************}
|
||||
|
||||
Begin
|
||||
StackBottom := SPtr - StackLength;
|
||||
{$ifdef MT}
|
||||
{ the exceptions use threadvars so do this _before_ initexceptions }
|
||||
AllocateThreadVars;
|
||||
{$endif MT}
|
||||
SigTermHandlerActive := false;
|
||||
NetwareCheckFunction := nil;
|
||||
NetwareMainThreadGroupID := _GetThreadGroupID;
|
||||
|
||||
_Signal (_SIGTERM, @TermSigHandler);
|
||||
|
||||
{ Setup heap }
|
||||
InitHeap;
|
||||
InitExceptions;
|
||||
|
||||
procedure SysInitStdIO;
|
||||
begin
|
||||
{ Setup stdin, stdout and stderr }
|
||||
StdInputHandle := _fileno (LONGINT (_GetStdIn^)); // GetStd** returns **FILE !
|
||||
StdOutputHandle:= _fileno (LONGINT (_GetStdOut^));
|
||||
@ -766,20 +766,36 @@ Begin
|
||||
OpenStdIO(Input,fmInput,StdInputHandle);
|
||||
OpenStdIO(Output,fmOutput,StdOutputHandle);
|
||||
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
|
||||
|
||||
|
||||
{$ifdef StdErrToConsole}
|
||||
AssignStdErrConsole(StdErr);
|
||||
{$else}
|
||||
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
SystemUnit Initialization
|
||||
*****************************************************************************}
|
||||
|
||||
Begin
|
||||
StackBottom := SPtr - StackLength;
|
||||
SigTermHandlerActive := false;
|
||||
NetwareCheckFunction := nil;
|
||||
NetwareMainThreadGroupID := _GetThreadGroupID;
|
||||
|
||||
_Signal (_SIGTERM, @TermSigHandler);
|
||||
|
||||
{ Setup heap }
|
||||
InitHeap;
|
||||
SysInitExceptions;
|
||||
SysInitStdIO;
|
||||
|
||||
{ Setup environment and arguments }
|
||||
{Setup_Environment;
|
||||
Setup_Arguments;
|
||||
}
|
||||
{ Reset IO Error }
|
||||
InOutRes:=0;
|
||||
{Delphi Compatible}
|
||||
|
||||
{Delphi Compatible}
|
||||
IsLibrary := FALSE;
|
||||
IsConsole := TRUE;
|
||||
ExitCode := 0;
|
||||
@ -789,7 +805,10 @@ Begin
|
||||
End.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.15 2002-10-13 09:28:45 florian
|
||||
Revision 1.16 2003-02-15 19:12:54 armin
|
||||
* changes for new threadvar support
|
||||
|
||||
Revision 1.15 2002/10/13 09:28:45 florian
|
||||
+ call to initvariantmanager inserted
|
||||
|
||||
Revision 1.14 2002/09/07 16:01:21 peter
|
||||
|
||||
@ -97,6 +97,12 @@ begin
|
||||
FileCreate:=_open(Pchar(FileName),O_RdWr or O_Creat or O_Trunc,0);
|
||||
end;
|
||||
|
||||
Function FileCreate (Const FileName : String; mode:longint) : Longint;
|
||||
|
||||
begin
|
||||
FileCreate:=FileCreate (FileName);
|
||||
end;
|
||||
|
||||
|
||||
Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint;
|
||||
|
||||
@ -481,7 +487,10 @@ end.
|
||||
{
|
||||
|
||||
$Log$
|
||||
Revision 1.7 2002-09-07 16:01:21 peter
|
||||
Revision 1.8 2003-02-15 19:12:54 armin
|
||||
* changes for new threadvar support
|
||||
|
||||
Revision 1.7 2002/09/07 16:01:21 peter
|
||||
* old logs removed and tabs fixed
|
||||
|
||||
Revision 1.6 2002/04/01 10:47:31 armin
|
||||
|
||||
@ -2,11 +2,11 @@
|
||||
# Needs working nlmconv + i386-netware-ld
|
||||
# AD 8/2000
|
||||
|
||||
UNITDIR = /usr/lib/fpc/1.1/units/netware/rtl
|
||||
UNITDIR = /usr/lib/fpc/1.1/cross/i386-netware/units/rtl
|
||||
PPC386OPT = -a -al -Or -O3 -XX -Tnetware -Fi$(UNITDIR)
|
||||
INCLUDES = -Fo$(UNITDIR) -Fu$(UNITDIR)
|
||||
|
||||
OBJS = test.on
|
||||
OBJS = test.on thrd.on
|
||||
|
||||
%.on: %.pas
|
||||
ppc386 $(PPC386OPT) $(INCLUDES) $*.pas
|
||||
@ -18,16 +18,11 @@ all: $(OBJS)
|
||||
|
||||
# mount netware and copy test.nlm to sys:test on 4.11 and 5.1 server
|
||||
install: all
|
||||
[ -d nw ] || mkdir nw
|
||||
ncpmount -S FS-DEVELOP -U linux.home.ad -V sys -n nw
|
||||
cp -f test.nlm nw/test/test.nlm
|
||||
umount nw
|
||||
ncpmount -S FS-AD -U linux.home.ad -V sys -n nw
|
||||
cp -f test.nlm nw/test/test.nlm
|
||||
umount nw
|
||||
ncftpput -u linux -p linux fs-develop /sys/test *.nlm
|
||||
ncftpput -u linux -p linux fs-ad /sys/test *.nlm
|
||||
|
||||
|
||||
clean:
|
||||
rm -f *.on *.nlm *.ppn *.s *.bak *.o
|
||||
[ -d nw ] && rmdir nw
|
||||
|
||||
dist: clean
|
||||
|
||||
@ -1,390 +0,0 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2001-2002 by the Free Pascal development team.
|
||||
|
||||
Multithreading implementation for NetWare
|
||||
|
||||
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}
|
||||
|
||||
{ Multithreading for netware, armin 16 Mar 2002
|
||||
- threads are basicly tested and working
|
||||
- threadvars should work but currently there is a bug in the
|
||||
compiler preventing using multithreading
|
||||
- TRTLCriticalSections are working but NEVER call Enter or
|
||||
LeaveCriticalSection with uninitialized CriticalSections.
|
||||
Critial Sections are based on local semaphores and the
|
||||
Server will abend if the semaphore handles are invalid. There
|
||||
are basic tests in the rtl but this will not work in every case.
|
||||
Not closed semaphores will be closed by the rtl on program
|
||||
termination because some versions of netware will abend if there
|
||||
are open semaphores on nlm unload.
|
||||
}
|
||||
|
||||
const
|
||||
threadvarblocksize : dword = 0; // total size of allocated threadvars
|
||||
thredvarsmainthread: pointer = nil; // to free the threadvars in the signal handler
|
||||
|
||||
type
|
||||
tthreadinfo = record
|
||||
f : tthreadfunc;
|
||||
p : pointer;
|
||||
end;
|
||||
pthreadinfo = ^tthreadinfo;
|
||||
|
||||
{ all needed import stuff is in nwsys.inc and already included by
|
||||
system.pp }
|
||||
|
||||
|
||||
procedure init_threadvar(var offset : dword;size : dword);[public,alias: 'FPC_INIT_THREADVAR'];
|
||||
begin
|
||||
offset:=threadvarblocksize;
|
||||
inc(threadvarblocksize,size);
|
||||
{$ifdef DEBUG_MT}
|
||||
ConsolePrintf3(#13'init_threadvar, new offset: (%d), Size:%d'#13#10,offset,size,0);
|
||||
{$endif DEBUG_MT}
|
||||
end;
|
||||
|
||||
type ltvInitEntry =
|
||||
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}
|
||||
ConsolePrintf(#13'init_all_unit_threadvars (%d) units'#13#10,ThreadvarTablesTable.count);
|
||||
{$endif}
|
||||
for i := 1 to ThreadvarTablesTable.count do
|
||||
begin
|
||||
{$ifdef DEBUG_MT}
|
||||
ConsolePrintf(#13'init_unit_threadvars for unit (%d):'#13#10,i);
|
||||
{$endif}
|
||||
init_unit_threadvars (ThreadvarTablesTable.tables[i]);
|
||||
{$ifdef DEBUG_MT}
|
||||
ConsolePrintf(#13'init_unit_threadvars for unit (%d) done'#13#10,i);
|
||||
{$endif}
|
||||
end;
|
||||
end;
|
||||
|
||||
{$ifdef DEBUG_MT}
|
||||
var dummy_buff : array [0..255] of char; // to avoid abends (for current compiler error that not all threadvars are initialized)
|
||||
{$endif}
|
||||
|
||||
function relocate_threadvar(offset : dword) : pointer;[public,alias: 'FPC_RELOCATE_THREADVAR'];
|
||||
var p : pointer;
|
||||
begin
|
||||
{$ifdef DEBUG_MT}
|
||||
// ConsolePrintf(#13'relocate_threadvar, offset: (%d)'#13#10,offset);
|
||||
if offset > threadvarblocksize then
|
||||
begin
|
||||
// ConsolePrintf(#13'relocate_threadvar, invalid offset'#13#10,0);
|
||||
relocate_threadvar := @dummy_buff;
|
||||
exit;
|
||||
end;
|
||||
{$endif DEBUG_MT}
|
||||
relocate_threadvar:= _GetThreadDataAreaPtr + offset;
|
||||
end;
|
||||
|
||||
procedure AllocateThreadVars;
|
||||
|
||||
var
|
||||
threadvars : pointer;
|
||||
|
||||
begin
|
||||
{ we've to allocate the memory from netware }
|
||||
{ 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 := _malloc (threadvarblocksize);
|
||||
fillchar (threadvars^, threadvarblocksize, 0);
|
||||
_SaveThreadDataAreaPtr (threadvars);
|
||||
{$ifdef DEBUG_MT}
|
||||
ConsolePrintf3(#13'threadvars allocated at (%x), size: %d'#13#10,longint(threadvars),threadvarblocksize,0);
|
||||
{$endif DEBUG_MT}
|
||||
if thredvarsmainthread = nil then
|
||||
thredvarsmainthread := threadvars;
|
||||
end;
|
||||
|
||||
procedure ReleaseThreadVars;
|
||||
var threadvars : pointer;
|
||||
begin
|
||||
{ release thread vars }
|
||||
if threadvarblocksize > 0 then
|
||||
begin
|
||||
threadvars:=_GetThreadDataAreaPtr;
|
||||
if threadvars <> nil then
|
||||
begin
|
||||
{$ifdef DEBUG_MT}
|
||||
ConsolePrintf (#13'free threadvars'#13#10,0);
|
||||
{$endif DEBUG_MT}
|
||||
_Free (threadvars);
|
||||
end;
|
||||
end;
|
||||
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 }
|
||||
ReleaseThreadVars;
|
||||
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);
|
||||
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 :=
|
||||
_BeginThread (@ThreadMain,NIL,Stacksize,ti);
|
||||
end;
|
||||
|
||||
function BeginThread(ThreadFunction : tthreadfunc) : DWord;
|
||||
var dummy : dword;
|
||||
begin
|
||||
BeginThread:=BeginThread(nil,0,ThreadFunction,nil,0,dummy);
|
||||
end;
|
||||
|
||||
function BeginThread(ThreadFunction : tthreadfunc;p : pointer) : DWord;
|
||||
var dummy : dword;
|
||||
begin
|
||||
BeginThread:=BeginThread(nil,0,ThreadFunction,p,0,dummy);
|
||||
end;
|
||||
|
||||
function BeginThread(ThreadFunction : tthreadfunc;p : pointer;var ThreadId : DWord) : DWord;
|
||||
begin
|
||||
BeginThread:=BeginThread(nil,0,ThreadFunction,p,0,ThreadId);
|
||||
end;
|
||||
|
||||
procedure EndThread(ExitCode : DWord);
|
||||
begin
|
||||
DoneThread;
|
||||
ExitThread(ExitCode, TSR_THREAD);
|
||||
end;
|
||||
|
||||
procedure EndThread;
|
||||
begin
|
||||
EndThread(0);
|
||||
end;
|
||||
|
||||
|
||||
{ netware requires all allocated semaphores }
|
||||
{ to be closed before terminating the nlm, otherwise }
|
||||
{ the server will abend (except for netware 6 i think) }
|
||||
|
||||
TYPE TSemaList = ARRAY [1..1000] OF LONGINT;
|
||||
PSemaList = ^TSemaList;
|
||||
|
||||
CONST NumSemaOpen : LONGINT = 0;
|
||||
NumEntriesMax : LONGINT = 0;
|
||||
SemaList : PSemaList = NIL;
|
||||
|
||||
PROCEDURE SaveSema (Handle : LONGINT);
|
||||
BEGIN
|
||||
{$ifdef DEBUG_MT}
|
||||
ConsolePrintf(#13'new Semaphore allocated (%x)'#13#10,Handle);
|
||||
{$endif DEBUG_MT}
|
||||
_EnterCritSec;
|
||||
IF NumSemaOpen = NumEntriesMax THEN
|
||||
BEGIN
|
||||
IF SemaList = NIL THEN
|
||||
BEGIN
|
||||
SemaList := _malloc (32 * SIZEOF (TSemaList[0]));
|
||||
NumEntriesMax := 32;
|
||||
END ELSE
|
||||
BEGIN
|
||||
INC (NumEntriesMax, 16);
|
||||
SemaList := _realloc (SemaList, NumEntriesMax * SIZEOF (TSemaList[0]));
|
||||
END;
|
||||
END;
|
||||
INC (NumSemaOpen);
|
||||
SemaList^[NumSemaOpen] := Handle;
|
||||
_ExitCritSec;
|
||||
END;
|
||||
|
||||
PROCEDURE ReleaseSema (Handle : LONGINT);
|
||||
VAR I : LONGINT;
|
||||
BEGIN
|
||||
{$ifdef DEBUG_MT}
|
||||
ConsolePrintf(#13'Semaphore released (%x)'#13#10,Handle);
|
||||
{$endif DEBUG_MT}
|
||||
_EnterCritSec;
|
||||
IF SemaList <> NIL then
|
||||
if NumSemaOpen > 0 then
|
||||
begin
|
||||
for i := 1 to NumSemaOpen do
|
||||
if SemaList^[i] = Handle then
|
||||
begin
|
||||
if i < NumSemaOpen then
|
||||
SemaList^[i] := SemaList^[NumSemaOpen];
|
||||
dec (NumSemaOpen);
|
||||
_ExitCritSec;
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
_ExitCritSec;
|
||||
ConsolePrintf (#13'fpc-rtl: ReleaseSema, Handle not found'#13#10,0);
|
||||
END;
|
||||
|
||||
|
||||
PROCEDURE CloseAllRemainingSemaphores;
|
||||
var i : LONGINT;
|
||||
begin
|
||||
IF SemaList <> NIL then
|
||||
begin
|
||||
if NumSemaOpen > 0 then
|
||||
for i := 1 to NumSemaOpen do
|
||||
_CloseLocalSemaphore (SemaList^[i]);
|
||||
_free (SemaList);
|
||||
SemaList := NIL;
|
||||
NumSemaOpen := 0;
|
||||
NumEntriesMax := 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ this allows to do a lot of things in MT safe way }
|
||||
{ it is also used to make the heap management }
|
||||
{ thread safe }
|
||||
procedure InitCriticalSection(var cs : TRTLCriticalSection);
|
||||
begin
|
||||
cs.SemaHandle := _OpenLocalSemaphore (1);
|
||||
if cs.SemaHandle <> 0 then
|
||||
begin
|
||||
cs.SemaIsOpen := true;
|
||||
SaveSema (cs.SemaHandle);
|
||||
end else
|
||||
begin
|
||||
cs.SemaIsOpen := false;
|
||||
ConsolePrintf (#13'fpc-rtl: InitCriticalsection, OpenLocalSemaphore returned error'#13#10,0);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure DoneCriticalsection(var cs : TRTLCriticalSection);
|
||||
begin
|
||||
if cs.SemaIsOpen then
|
||||
begin
|
||||
_CloseLocalSemaphore (cs.SemaHandle);
|
||||
ReleaseSema (cs.SemaHandle);
|
||||
cs.SemaIsOpen := FALSE;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure EnterCriticalsection(var cs : TRTLCriticalSection);
|
||||
begin
|
||||
if cs.SemaIsOpen then
|
||||
_WaitOnLocalSemaphore (cs.SemaHandle)
|
||||
else
|
||||
ConsolePrintf (#13'fpc-rtl: EnterCriticalsection, TRTLCriticalSection not open'#13#10,0);
|
||||
end;
|
||||
|
||||
procedure LeaveCriticalsection(var cs : TRTLCriticalSection);
|
||||
begin
|
||||
if cs.SemaIsOpen then
|
||||
_SignalLocalSemaphore (cs.SemaHandle)
|
||||
else
|
||||
ConsolePrintf (#13'fpc-rtl: LeaveCriticalsection, TRTLCriticalSection not open'#13#10,0);
|
||||
end;
|
||||
|
||||
|
||||
{$endif MT}
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.5 2002-09-07 16:01:21 peter
|
||||
* old logs removed and tabs fixed
|
||||
|
||||
Revision 1.4 2002/04/01 15:20:08 armin
|
||||
+ unload module no longer shows: Module did not release...
|
||||
+ check-function will no longer be removed when smartlink is on
|
||||
|
||||
Revision 1.3 2002/04/01 10:47:31 armin
|
||||
makefile.fpc for netware
|
||||
stderr to netware console
|
||||
free all memory (threadvars and heap) to avoid error message while unloading nlm
|
||||
|
||||
Revision 1.2 2002/03/28 16:11:17 armin
|
||||
+ initialize threadvars defined local in units
|
||||
|
||||
Revision 1.1 2002/03/17 17:57:33 armin
|
||||
+ threads and winsock2 implemented
|
||||
|
||||
}
|
||||
@ -35,7 +35,7 @@ unit winsock2;
|
||||
interface
|
||||
|
||||
uses
|
||||
os_types,netware;
|
||||
netware;
|
||||
|
||||
const
|
||||
{
|
||||
@ -47,6 +47,11 @@ unit winsock2;
|
||||
FD_SETSIZE = 64;
|
||||
|
||||
type
|
||||
tOS_INT = LongInt;
|
||||
tOS_UINT = DWord;
|
||||
ptOS_INT = ^tOS_INT;
|
||||
ptOS_UINT = ^tOS_UINT;
|
||||
|
||||
u_char = char;
|
||||
u_short = word;
|
||||
u_int = tOS_UINT;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user