paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-25 05:31:31 +02:00
Code Issues Packages Projects Releases Wiki Activity

* exiting threads at nlm unload

Browse Source
This commit is contained in:
armin 2004-09-26 19:25:49 +00:00
parent 173aea0681
commit 0f1fec0de1
11 changed files with 5165 additions and 4923 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
rtl/netware/Makefile
View File

@ -1,5 +1,5 @@
# #
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/09/16] # Don't edit, this file is generated by FPCMake Version 1.1 [2004/09/22]
# #
default: all default: all
MAKEFILETARGETS=netware MAKEFILETARGETS=netware
@ -225,8 +225,8 @@ else
SYSTEMUNIT=sysnetwa SYSTEMUNIT=sysnetwa
endif endif
override FPCOPT+=-Ur override FPCOPT+=-Ur
override FPCOPT+=-dMT -dDEBUG_MT override FPCOPT+=-dMT
CREATESMART=0 CREATESMART=1
OBJPASDIR=$(RTL)/objpas OBJPASDIR=$(RTL)/objpas
override TARGET_UNITS+=$(SYSTEMUNIT) systhrds objpas macpas strings lineinfo winsock heaptrc matrix initc dos crt objects sysutils classes typinfo math varutils cpu mmx getopts sockets video mouse keyboard types dateutils rtlconst sysconst strutils convutils aio nwsnut nwserv nwnit nwprot override TARGET_UNITS+=$(SYSTEMUNIT) systhrds objpas macpas strings lineinfo winsock heaptrc matrix initc dos crt objects sysutils classes typinfo math varutils cpu mmx getopts sockets video mouse keyboard types dateutils rtlconst sysconst strutils convutils aio nwsnut nwserv nwnit nwprot
override TARGET_LOADERS+=nwpre prelude override TARGET_LOADERS+=nwpre prelude

5
rtl/netware/Makefile.fpc
View File

@ -60,11 +60,10 @@ override FPCOPT+=-Ur
# for netware always use multithread # for netware always use multithread
override FPCOPT+=-dMT -dDEBUG_MT override FPCOPT+=-dMT
# and alway use smartlinking # and alway use smartlinking
#CREATESMART=1 CREATESMART=1
CREATESMART=0
# Paths # Paths
OBJPASDIR=$(RTL)/objpas OBJPASDIR=$(RTL)/objpas

12
rtl/netware/classes.pp
View File

@ -38,10 +38,20 @@ implementation
{ OS - independent class implementations are in /inc directory. } { OS - independent class implementations are in /inc directory. }
{$i classes.inc} {$i classes.inc}
initialization
CommonInit;
finalization
DoneThreads;
CommonCleanup;
end. end.
{ {
$Log$ $Log$
Revision 1.4 2004-08-01 20:02:48 armin Revision 1.5 2004-09-26 19:25:49 armin
* exiting threads at nlm unload
Revision 1.4 2004/08/01 20:02:48 armin
* changed dir separator from \ to / * changed dir separator from \ to /
* long namespace by default * long namespace by default
* dos.exec implemented * dos.exec implemented

5
rtl/netware/clib.imp
View File

@ -1929,5 +1929,8 @@
y1, y1,
YearsSince1970, YearsSince1970,
yn, yn,
__ZBuf2F __ZBuf2F,
# GetKey,UnGetKey from server.nlm (or syscalls)
GetKey,
UngetKey

9715
rtl/netware/nwserv.pp
View File

File diff suppressed because it is too large Load Diff

49
rtl/netware/nwsys.inc
View File

@ -1,8 +1,8 @@
{ {
$Id$ $Id$
This file is part of the Free Pascal run time library. This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by the Free Pascal development team Copyright (c) 1999-2004 by the Free Pascal development team
Copyright (c) 2001 Armin Diehl Copyright (c) 2001-2004 Armin Diehl
Interface to netware clib Interface to netware clib
@ -17,6 +17,7 @@
CONST Clib = 'clib'; CONST Clib = 'clib';
ThreadsNlm = 'threads';
TYPE TYPE
dev_t = LONGINT; dev_t = LONGINT;
@ -69,9 +70,16 @@ FUNCTION _BeginThread (func, stack : pointer; Stacksize : LONGINT; arg : pointer
FUNCTION _GetThreadDataAreaPtr : POINTER; CDecl; EXTERNAL CLib NAME 'GetThreadDataAreaPtr'; FUNCTION _GetThreadDataAreaPtr : POINTER; CDecl; EXTERNAL CLib NAME 'GetThreadDataAreaPtr';
PROCEDURE _SaveThreadDataAreaPtr (P : POINTER); CDecl; EXTERNAL CLib NAME 'SaveThreadDataAreaPtr'; PROCEDURE _SaveThreadDataAreaPtr (P : POINTER); CDecl; EXTERNAL CLib NAME 'SaveThreadDataAreaPtr';
PROCEDURE _exit (ExitCode : LONGINT); CDecl; EXTERNAL CLib; PROCEDURE _exit (ExitCode : LONGINT); CDecl; EXTERNAL CLib;
function _SuspendThread(threadID:longint):longint; cdecl;external ThreadsNlm name 'SuspendThread';
function _GetThreadID:longint; cdecl;external ThreadsNlm name 'GetThreadID';
procedure _ThreadSwitchWithDelay; cdecl;external ThreadsNlm name 'ThreadSwitchWithDelay';
function _GetThreadName(threadID:longint; var tName):longint; cdecl;external ThreadsNlm name 'GetThreadName';
PROCEDURE ConsolePrintf (FormatStr : PCHAR; Param : LONGINT); CDecl; EXTERNAL CLib Name 'ConsolePrintf'; PROCEDURE ConsolePrintf (FormatStr : PCHAR; Param : LONGINT); CDecl; EXTERNAL CLib Name 'ConsolePrintf';
PROCEDURE ConsolePrintf3 (FormatStr : PCHAR; P1,P2,P3 : LONGINT); CDecl; EXTERNAL CLib Name 'ConsolePrintf'; PROCEDURE ConsolePrintf (FormatStr : PCHAR; Param : pchar); CDecl; EXTERNAL CLib Name 'ConsolePrintf';
PROCEDURE ConsolePrintf (FormatStr : PCHAR; P1,P2 : LONGINT); CDecl; EXTERNAL CLib Name 'ConsolePrintf';
PROCEDURE ConsolePrintf (FormatStr : PCHAR; P1,P2,P3 : LONGINT); CDecl; EXTERNAL CLib Name 'ConsolePrintf';
PROCEDURE ConsolePrintf (FormatStr : PCHAR; P1,P2,P3,P4 : LONGINT); CDecl; EXTERNAL CLib Name 'ConsolePrintf';
PROCEDURE ConsolePrintf (FormatStr : PCHAR); CDecl; EXTERNAL CLib Name 'ConsolePrintf'; PROCEDURE ConsolePrintf (FormatStr : PCHAR); CDecl; EXTERNAL CLib Name 'ConsolePrintf';
// this gives internal compiler error 1234124 ?? // this gives internal compiler error 1234124 ??
//PROCEDURE ConsolePrintf (FormatStr : PCHAR; Param : array of const); CDecl; EXTERNAL CLib; //PROCEDURE ConsolePrintf (FormatStr : PCHAR; Param : array of const); CDecl; EXTERNAL CLib;
@ -340,28 +348,31 @@ CONST
NW_NS_LONG = 4; NW_NS_LONG = 4;
function _NWAddSearchPathAtEnd (searchPath : pchar; var number : longint) : longint; cdecl; external Clib name 'NWAddSearchPathAtEnd'; function _NWAddSearchPathAtEnd (searchPath : pchar; var number : longint) : longint; cdecl; external Clib name 'NWAddSearchPathAtEnd';
function _NWDeleteSearchPath (searchPathNumber : longint) : longint; cdecl; external Clib name 'NWDeleteSearchPath'; function _NWDeleteSearchPath (searchPathNumber : longint) : longint; cdecl; external Clib name 'NWDeleteSearchPath';
function _NWInsertSearchPath (searchPathNumber : longint; path : pchar) : longint; cdecl; external Clib name 'NWInsertSearchPath'; function _NWInsertSearchPath (searchPathNumber : longint; path : pchar) : longint; cdecl; external Clib name 'NWInsertSearchPath';
function _NWGetSearchPathElement (searchPathNumber : longint; var isDOSSearchPath : longint; searchPath : pchar) : longint; cdecl; external Clib name 'NWGetSearchPathElement'; function _NWGetSearchPathElement (searchPathNumber : longint; var isDOSSearchPath : longint; searchPath : pchar) : longint; cdecl; external Clib name 'NWGetSearchPathElement';
// values for __mode used with spawnxx() // values for __mode used with spawnxx()
CONST CONST
P_WAIT = 0; P_WAIT = 0;
P_NOWAIT = 1; P_NOWAIT = 1;
P_OVERLAY = 2; P_OVERLAY = 2;
P_NOWAITO = 4; P_NOWAITO = 4;
P_SPAWN_IN_CURRENT_DOMAIN = 8; P_SPAWN_IN_CURRENT_DOMAIN = 8;
//function spawnlp(mode:longint; path:Pchar; arg0:Pchar; args:array of const):longint;cdecl;external CLib name 'spawnlp'; //function spawnlp(mode:longint; path:Pchar; arg0:Pchar; args:array of const):longint;cdecl;external CLib name 'spawnlp';
function spawnlp(mode:longint; path:Pchar; arg0:Pchar):longint;cdecl;external Clib name 'spawnlp'; function spawnlp(mode:longint; path:Pchar; arg0:Pchar):longint;cdecl;external Clib name 'spawnlp';
function spawnvp(mode:longint; path:Pchar; argv:PPchar):longint;cdecl;external Clib name 'spawnvp'; function spawnvp(mode:longint; path:Pchar; argv:PPchar):longint;cdecl;external Clib name 'spawnvp';
{ {
$Log$ $Log$
Revision 1.10 2004-08-01 20:02:48 armin Revision 1.11 2004-09-26 19:25:49 armin
* exiting threads at nlm unload
Revision 1.10 2004/08/01 20:02:48 armin
* changed dir separator from \ to / * changed dir separator from \ to /
* long namespace by default * long namespace by default
* dos.exec implemented * dos.exec implemented

48
rtl/netware/sockets.pp
View File

@ -11,8 +11,8 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************} **********************************************************************}
{$mode objfpc} {$mode objfpc}
{$R-}
unit Sockets; unit Sockets;
Interface Interface
@ -20,9 +20,10 @@ Interface
{$macro on} {$macro on}
{$define maybelibc:=} {$define maybelibc:=}
{$R-}
Uses Uses
winsock; winsock;
Type Type
cushort=word; cushort=word;
@ -52,6 +53,14 @@ Implementation
Basic Socket Functions Basic Socket Functions
******************************************************************************} ******************************************************************************}
//function fprecvmsg (s:cint; msg: pmsghdr; flags:cint):ssize_t;
//function fpsendmsg (s:cint; hdr: pmsghdr; flags:cint):ssize;
//function fpsocket (domain:cint; xtype:cint; protocol: cint):cint;
function fpsocket (domain:cint; xtype:cint; protocol: cint):cint; function fpsocket (domain:cint; xtype:cint; protocol: cint):cint;
begin begin
fpSocket:=WinSock.Socket(Domain,xtype,ProtoCol); fpSocket:=WinSock.Socket(Domain,xtype,ProtoCol);
@ -80,7 +89,7 @@ begin
SocketError:=0; SocketError:=0;
end; end;
function fprecv (s:cint; buf: pointer; len: size_t; flags: cint):ssize_t; function fprecv (s:cint; buf: pointer; len: size_t; flags: cint):ssize_t;
begin begin
fpRecv:=WinSock.Recv(S,Buf,Len,Flags); fpRecv:=WinSock.Recv(S,Buf,Len,Flags);
if fpRecv<0 then if fpRecv<0 then
@ -89,10 +98,10 @@ begin
SocketError:=0; SocketError:=0;
end; end;
function fprecvfrom (s:cint; buf: pointer; len: size_t; flags: cint; from : psockaddr; fromlen : psocklen):ssize_t; function fprecvfrom (s:cint; buf: pointer; len: size_t; flags: cint; from : psockaddr; fromlen : psocklen):ssize_t;
begin begin
fpRecvFrom:=WinSock.RecvFrom(S,Buf,Len,Flags,Winsock.TSockAddr(from^),FromLen^); fpRecvFrom:=WinSock.RecvFrom(S,Buf,Len,Flags,Winsock.TSockAddr(from^),FromLen^);
if fpRecvFrom<0 then if fpRecvFrom<0 then
SocketError:=WSAGetLastError SocketError:=WSAGetLastError
else else
@ -109,7 +118,7 @@ begin
SocketError:=0; SocketError:=0;
end; end;
function fpshutdown (s:cint; how:cint):cint; function fpshutdown (s:cint; how:cint):cint;
begin begin
fpShutDown:=WinSock.ShutDown(S,How); fpShutDown:=WinSock.ShutDown(S,How);
if fpShutDown<0 then if fpShutDown<0 then
@ -165,16 +174,16 @@ begin
SocketError:=0; SocketError:=0;
end; end;
function fpaccept (s:cint; addrx : psockaddr; addrlen : psocklen):cint; function fpaccept (s:cint; addrx : psockaddr; addrlen : psocklen):cint;
begin begin
fpAccept:=WinSock.Accept(S,WinSock.PSockAddr(Addrx),plongint(@AddrLen)); fpAccept:=WinSock.Accept(S,WinSock.PSockAddr(Addrx),plongint(AddrLen));
if fpAccept<0 then if fpAccept<0 then
SocketError:=WSAGetLastError SocketError:=WSAGetLastError
else else
SocketError:=0; SocketError:=0;
end; end;
function fpgetsockname (s:cint; name : psockaddr; namelen : psocklen):cint; function fpgetsockname (s:cint; name : psockaddr; namelen : psocklen):cint;
begin begin
fpGetSockName:=WinSock.GetSockName(S,WinSock.TSockAddr(name^),nameLen^); fpGetSockName:=WinSock.GetSockName(S,WinSock.TSockAddr(name^),nameLen^);
@ -184,7 +193,7 @@ begin
SocketError:=0; SocketError:=0;
end; end;
function fpgetpeername (s:cint; name : psockaddr; namelen : psocklen):cint; function fpgetpeername (s:cint; name : psockaddr; namelen : psocklen):cint;
begin begin
fpGetPeerName:=WinSock.GetPeerName(S,WinSock.TSockAddr(name^),NameLen^); fpGetPeerName:=WinSock.GetPeerName(S,WinSock.TSockAddr(name^),NameLen^);
if fpGetPeerName<0 then if fpGetPeerName<0 then
@ -193,7 +202,7 @@ begin
SocketError:=0; SocketError:=0;
end; end;
function fpgetsockopt (s:cint; level:cint; optname:cint; optval:pointer; optlen : psocklen):cint; function fpgetsockopt (s:cint; level:cint; optname:cint; optval:pointer; optlen : psocklen):cint;
begin begin
fpGetSockOpt:=WinSock.GetSockOpt(S,Level,OptName,OptVal,OptLen^); fpGetSockOpt:=WinSock.GetSockOpt(S,Level,OptName,OptVal,OptLen^);
if fpGetSockOpt<0 then if fpGetSockOpt<0 then
@ -202,7 +211,7 @@ begin
SocketError:=0; SocketError:=0;
end; end;
function fpsetsockopt (s:cint; level:cint; optname:cint; optval:pointer; optlen :tsocklen):cint; function fpsetsockopt (s:cint; level:cint; optname:cint; optval:pointer; optlen :tsocklen):cint;
begin begin
fpSetSockOpt:=WinSock.SetSockOpt(S,Level,OptName,OptVal,OptLen); fpSetSockOpt:=WinSock.SetSockOpt(S,Level,OptName,OptVal,OptLen);
@ -212,9 +221,9 @@ begin
SocketError:=0; SocketError:=0;
end; end;
function fpsocketpair (d:cint; xtype:cint; protocol:cint; sv:pcint):cint; function fpsocketpair (d:cint; xtype:cint; protocol:cint; sv:pcint):cint;
begin begin
fpsocketpair := -1; fpSocketPair := -1;
end; end;
Function CloseSocket(Sock:Longint):Longint; Function CloseSocket(Sock:Longint):Longint;
@ -228,7 +237,7 @@ begin
end else end else
begin begin
CloseSocket := 0; CloseSocket := 0;
SocketError := 0; SocketError := 0;
end; end;
end; end;
@ -285,7 +294,7 @@ end;
Function SocketPair(Domain,SocketType,Protocol:Longint;var Pair:TSockArray):Longint; Function SocketPair(Domain,SocketType,Protocol:Longint;var Pair:TSockArray):Longint;
begin begin
// SocketPair:=SocketCall(Socket_Sys_SocketPair,Domain,SocketType,Protocol,longint(@Pair),0,0);a // SocketPair:=SocketCall(Socket_Sys_SocketPair,Domain,SocketType,Protocol,longint(@Pair),0,0);
SocketPair := -1; SocketPair := -1;
end; end;
@ -385,7 +394,10 @@ finalization
end. end.
{ {
$Log$ $Log$
Revision 1.6 2004-09-18 23:45:43 armin Revision 1.7 2004-09-26 19:25:49 armin
* exiting threads at nlm unload
Revision 1.6 2004/09/18 23:45:43 armin
* make winsock more compatible to win32 version * make winsock more compatible to win32 version
Revision 1.5 2004/07/30 15:05:25 armin Revision 1.5 2004/07/30 15:05:25 armin

132
rtl/netware/system.pp
View File

@ -69,20 +69,24 @@ VAR
NetwareCheckFunction : TNWCheckFunction; NetwareCheckFunction : TNWCheckFunction;
NetwareMainThreadGroupID: longint; NetwareMainThreadGroupID: longint;
NetwareCodeStartAddress : dword; NetwareCodeStartAddress : dword;
NetwareUnloadProc : pointer = nil; {like exitProc but for nlm unload only}
CONST CONST
envp : ppchar = nil; {dummy to make heaptrc happy} envp : ppchar = nil; {dummy to make heaptrc happy}
PROCEDURE ConsolePrintf (FormatStr : PCHAR; Param : LONGINT); CDecl; procedure ConsolePrintf (FormatStr : PCHAR; Param : LONGINT); CDecl;
PROCEDURE ConsolePrintf3 (FormatStr : PCHAR; P1,P2,P3 : LONGINT); CDecl; procedure ConsolePrintf (FormatStr : PCHAR; Param : pchar); CDecl;
PROCEDURE ConsolePrintf (FormatStr : PCHAR); CDecl; procedure ConsolePrintf (FormatStr : PCHAR; P1,P2 : LONGINT); CDecl;
procedure ConsolePrintf (FormatStr : PCHAR; P1,P2,P3 : LONGINT); CDecl;
procedure ConsolePrintf (FormatStr : PCHAR); CDecl;
procedure __EnterDebugger; cdecl;
type type
TSysCloseAllRemainingSemaphores = procedure; TSysCloseAllRemainingSemaphores = procedure;
TSysReleaseThreadVars = procedure; TSysReleaseThreadVars = procedure;
TSysSetThreadDataAreaPtr = function (newPtr:pointer):pointer; TSysSetThreadDataAreaPtr = function (newPtr:pointer):pointer;
procedure NWSysSetThreadFunctions (crs:TSysCloseAllRemainingSemaphores; procedure NWSysSetThreadFunctions (crs:TSysCloseAllRemainingSemaphores;
rtv:TSysReleaseThreadVars; rtv:TSysReleaseThreadVars;
stdata:TSysSetThreadDataAreaPtr); stdata:TSysSetThreadDataAreaPtr);
@ -101,10 +105,13 @@ implementation
{$I errno.inc} {$I errno.inc}
var var
CloseAllRemainingSemaphores : TSysCloseAllRemainingSemaphores = nil; CloseAllRemainingSemaphores : TSysCloseAllRemainingSemaphores = nil;
ReleaseThreadVars : TSysReleaseThreadVars = nil; ReleaseThreadVars : TSysReleaseThreadVars = nil;
SetThreadDataAreaPtr : TSysSetThreadDataAreaPtr = nil; SetThreadDataAreaPtr : TSysSetThreadDataAreaPtr = nil;
TerminatingThreadID : longint = 0; {used for unload, the signal handler will}
{be called from the console thread. avoid}
{calling _exit in another thread}
procedure NWSysSetThreadFunctions (crs:TSysCloseAllRemainingSemaphores; procedure NWSysSetThreadFunctions (crs:TSysCloseAllRemainingSemaphores;
rtv:TSysReleaseThreadVars; rtv:TSysReleaseThreadVars;
@ -113,9 +120,9 @@ begin
CloseAllRemainingSemaphores := crs; CloseAllRemainingSemaphores := crs;
ReleaseThreadVars := rtv; ReleaseThreadVars := rtv;
SetThreadDataAreaPtr := stdata; SetThreadDataAreaPtr := stdata;
end; end;
procedure __EnterDebugger; cdecl; external 'clib' name 'EnterDebugger';
procedure PASCALMAIN;external name 'PASCALMAIN'; procedure PASCALMAIN;external name 'PASCALMAIN';
@ -161,6 +168,18 @@ var SigTermHandlerActive : boolean;
Procedure system_exit; Procedure system_exit;
begin begin
if TerminatingThreadID <> 0 then
if TerminatingThreadID <> ThreadId then
if TerminatingThreadID <> _GetThreadID then
begin
{$ifdef DEBUG_MT}
ConsolePrintf ('Terminating Thread %x because halt was called while Thread %x terminates nlm'#13#10,_GetThreadId,TerminatingThreadId);
{$endif}
ExitThread (EXIT_THREAD,0);
// only for the case ExitThread fails
while true do
_ThreadSwitchWithDelay;
end;
if assigned (CloseAllRemainingSemaphores) then CloseAllRemainingSemaphores; if assigned (CloseAllRemainingSemaphores) then CloseAllRemainingSemaphores;
if assigned (ReleaseThreadVars) then ReleaseThreadVars; if assigned (ReleaseThreadVars) then ReleaseThreadVars;
@ -746,13 +765,13 @@ begin
oldTG := _SetThreadGroupID (NetwareMainThreadGroupID); oldTG := _SetThreadGroupID (NetwareMainThreadGroupID);
{ to allow use of threadvars, we simply set the threadvar-memory { to allow use of threadvars, we simply set the threadvar-memory
from the main thread } from the main thread }
if assigned (SetThreadDataAreaPtr) then if assigned (SetThreadDataAreaPtr) then
oldPtr := SetThreadDataAreaPtr (NIL); { nil means main threadvars } oldPtr := SetThreadDataAreaPtr (NIL); { nil means main threadvars }
result := 0; result := 0;
NetwareCheckFunction (result); NetwareCheckFunction (result);
if assigned (SetThreadDataAreaPtr) then if assigned (SetThreadDataAreaPtr) then
SetThreadDataAreaPtr (oldPtr); SetThreadDataAreaPtr (oldPtr);
_SetThreadGroupID (oldTG); _SetThreadGroupID (oldTG);
end else end else
result := 0; result := 0;
@ -812,7 +831,13 @@ end;
procedure TermSigHandler (Sig:longint); CDecl; procedure TermSigHandler (Sig:longint); CDecl;
var oldTG : longint; var oldTG : longint;
oldPtr: pointer; oldPtr: pointer;
err : longint;
current_exit : procedure;
ThreadName : array [0..20] of char;
HadExitProc : boolean;
Count : longint;
begin begin
oldTG := _SetThreadGroupID (NetwareMainThreadGroupID); { this is only needed for nw 3.11 } oldTG := _SetThreadGroupID (NetwareMainThreadGroupID); { this is only needed for nw 3.11 }
{ _GetThreadDataAreaPtr will not be valid because the signal { _GetThreadDataAreaPtr will not be valid because the signal
@ -821,25 +846,88 @@ begin
here } here }
if assigned (SetThreadDataAreaPtr) then if assigned (SetThreadDataAreaPtr) then
oldPtr := SetThreadDataAreaPtr (NIL); { nil means main thread } oldPtr := SetThreadDataAreaPtr (NIL); { nil means main thread }
{this signal handler is called within the console command
thread, the main thread is still running. Via NetwareUnloadProc
running threads may terminate itself}
TerminatingThreadID := _GetThreadID;
{$ifdef DEBUG_MT}
ConsolePrintf (#13'TermSigHandler Called, MainThread:%x, OurThread: %x'#13#10,ThreadId,TerminatingThreadId);
if NetwareUnloadProc <> nil then
ConsolePrintf (#13'Calling NetwareUnloadProcs'#13#10);
{$endif}
HadExitProc := false;
{we need to finalize winock to release threads
waiting on a blocking socket call. If that thread
calls halt, we have to avoid that unit finalization
is called by that thread because we are doing it
here
like the old exitProc, mainly to allow winsock to release threads
blocking in a winsock calls }
while NetwareUnloadProc<>nil Do
Begin
InOutRes:=0;
current_exit:=tProcedure(NetwareUnloadProc);
NetwareUnloadProc:=nil;
current_exit();
_ThreadSwitchWithDelay;
hadExitProc := true;
End;
err := 0;
if hadExitProc then
begin {give the main thread a little bit of time to terminate}
count := 0;
repeat
err := _GetThreadName(ThreadID,ThreadName);
if err = 0 then _Delay (200);
inc(count);
until (err <> 0) or (count > 100); {about 20 seconds}
{$ifdef DEBUG_MT}
if err = 0 then
ConsolePrintf (#13,'Main Thread not terminated'#13#10)
else
ConsolePrintf (#13'Main Thread has ended'#13#10);
{$endif}
end;
if err = 0 then
{$ifdef DEBUG_MT}
begin
err := _SuspendThread(ThreadId);
ConsolePrintf (#13'SuspendThread(%x) returned %d'#13#10,ThreadId,err);
end;
{$else}
_SuspendThread(ThreadId);
{$endif}
_ThreadSwitchWithDelay;
{$ifdef DEBUG_MT}
ConsolePrintf (#13'Calling do_exit'#13#10);
{$endif}
SigTermHandlerActive := true; { to avoid that system_exit calls _exit } SigTermHandlerActive := true; { to avoid that system_exit calls _exit }
do_exit; { calls finalize units } do_exit; { calls finalize units }
if assigned (SetThreadDataAreaPtr) then if assigned (SetThreadDataAreaPtr) then
SetThreadDataAreaPtr (oldPtr); SetThreadDataAreaPtr (oldPtr);
_SetThreadGroupID (oldTG); _SetThreadGroupID (oldTG);
{$ifdef DEBUG_MT}
ConsolePrintf (#13'TermSigHandler: all done'#13#10);
{$endif}
end; end;
procedure SysInitStdIO; procedure SysInitStdIO;
begin begin
{ Setup stdin, stdout and stderr } { Setup stdin, stdout and stderr }
StdInputHandle := _fileno (LONGINT (_GetStdIn^)); // GetStd** returns **FILE ! StdInputHandle := _fileno (LONGINT (_GetStdIn^)); // GetStd** returns **FILE
StdOutputHandle:= _fileno (LONGINT (_GetStdOut^)); StdOutputHandle:= _fileno (LONGINT (_GetStdOut^));
StdErrorHandle := _fileno (LONGINT (_GetStdErr^)); StdErrorHandle := _fileno (LONGINT (_GetStdErr^));
OpenStdIO(Input,fmInput,StdInputHandle); OpenStdIO(Input,fmInput,StdInputHandle);
OpenStdIO(Output,fmOutput,StdOutputHandle); OpenStdIO(Output,fmOutput,StdOutputHandle);
OpenStdIO(StdOut,fmOutput,StdOutputHandle); OpenStdIO(StdOut,fmOutput,StdOutputHandle);
{$ifdef StdErrToConsole} {$ifdef StdErrToConsole}
AssignStdErrConsole(StdErr); AssignStdErrConsole(StdErr);
{$else} {$else}
@ -870,7 +958,7 @@ Begin
else else
_SetCurrentNameSpace (NW_NS_DOS); _SetCurrentNameSpace (NW_NS_DOS);
end; end;
end; end;
{$endif useLongNamespaceByDefault} {$endif useLongNamespaceByDefault}
{ Setup heap } { Setup heap }
@ -880,11 +968,12 @@ Begin
{ Reset IO Error } { Reset IO Error }
InOutRes:=0; InOutRes:=0;
(* This should be changed to a real value during *) ThreadID := _GetThreadID;
(* thread driver initialization if appropriate. *) {$ifdef DEBUG_MT}
ThreadID := 1; ConsolePrintf (#13'Start system, ThreadID: %x'#13#10,ThreadID);
{$endif}
SysInitStdIO;
SysInitStdIO;
{Delphi Compatible} {Delphi Compatible}
IsLibrary := FALSE; IsLibrary := FALSE;
@ -896,7 +985,10 @@ Begin
End. End.
{ {
$Log$ $Log$
Revision 1.26 2004-09-17 18:29:07 armin Revision 1.27 2004-09-26 19:25:49 armin
* exiting threads at nlm unload
Revision 1.26 2004/09/17 18:29:07 armin
* added NWGetCodeStart, needed for lineinfo * added NWGetCodeStart, needed for lineinfo
Revision 1.25 2004/09/03 19:26:27 olle Revision 1.25 2004/09/03 19:26:27 olle

22
rtl/netware/systhrds.pp
View File

@ -81,7 +81,7 @@ begin
offset:=threadvarblocksize; offset:=threadvarblocksize;
inc(threadvarblocksize,size); inc(threadvarblocksize,size);
{$ifdef DEBUG_MT} {$ifdef DEBUG_MT}
ConsolePrintf3(#13'init_threadvar, new offset: (%d), Size:%d'#13#10,offset,size,0); ConsolePrintf(#13'init_threadvar, new offset: (%d), Size:%d'#13#10,offset,size,0);
{$endif DEBUG_MT} {$endif DEBUG_MT}
end; end;
@ -120,7 +120,7 @@ procedure SysAllocateThreadVars;
fillchar (threadvars^, threadvarblocksize, 0); fillchar (threadvars^, threadvarblocksize, 0);
_SaveThreadDataAreaPtr (threadvars); _SaveThreadDataAreaPtr (threadvars);
{$ifdef DEBUG_MT} {$ifdef DEBUG_MT}
ConsolePrintf3(#13'threadvars allocated at (%x), size: %d'#13#10,longint(threadvars),threadvarblocksize,0); ConsolePrintf(#13'threadvars allocated at (%x), size: %d'#13#10,longint(threadvars),threadvarblocksize,0);
{$endif DEBUG_MT} {$endif DEBUG_MT}
if thredvarsmainthread = nil then if thredvarsmainthread = nil then
thredvarsmainthread := threadvars; thredvarsmainthread := threadvars;
@ -187,7 +187,7 @@ function ThreadMain(param : pointer) : dword; cdecl;
SysAllocateThreadVars; SysAllocateThreadVars;
{$endif HASTHREADVAR} {$endif HASTHREADVAR}
{$ifdef DEBUG_MT} {$ifdef DEBUG_MT}
ConsolePrintf(#13'New thread started, initialising ...'#13#10); ConsolePrintf(#13'New thread %x started, initialising ...'#13#10,_GetThreadID);
{$endif DEBUG_MT} {$endif DEBUG_MT}
ti:=pthreadinfo(param)^; ti:=pthreadinfo(param)^;
InitThread(ti.stklen); InitThread(ti.stklen);
@ -215,7 +215,7 @@ function SysBeginThread(sa : Pointer;stacksize : dword;
InitThreadVars(@SysRelocateThreadvar); InitThreadVars(@SysRelocateThreadvar);
IsMultithread:=true; IsMultithread:=true;
end; end;
{$endif} {$endif}
{ the only way to pass data to the newly created thread } { the only way to pass data to the newly created thread }
{ in a MT safe way, is to use the heap } { in a MT safe way, is to use the heap }
new(ti); new(ti);
@ -232,6 +232,9 @@ function SysBeginThread(sa : Pointer;stacksize : dword;
procedure SysEndThread(ExitCode : DWord); procedure SysEndThread(ExitCode : DWord);
begin begin
{$ifdef DEBUG_MT}
ConsolePrintf (#13'SysEndThread %x'#13#10,_GetThreadID);
{$endif}
DoneThread; DoneThread;
ExitThread(ExitCode , TSR_THREAD); ExitThread(ExitCode , TSR_THREAD);
end; end;
@ -270,6 +273,7 @@ begin
end; end;
function GetThreadName (threadId : longint; var threadName) : longint; cdecl; external 'clib' name 'GetThreadName'; function GetThreadName (threadId : longint; var threadName) : longint; cdecl; external 'clib' name 'GetThreadName';
function GetThreadID : dword; cdecl; external 'clib' name 'GetThreadID';
//function __RenameThread (threadId : longint; threadName:pchar) : longint; cdecl; external 'clib' name 'RenameThread'; //function __RenameThread (threadId : longint; threadName:pchar) : longint; cdecl; external 'clib' name 'RenameThread';
function SysWaitForThreadTerminate (threadHandle : dword; TimeoutMs : longint) : dword; function SysWaitForThreadTerminate (threadHandle : dword; TimeoutMs : longint) : dword;
@ -278,6 +282,9 @@ var
buf : array [0..50] of char; buf : array [0..50] of char;
begin begin
{$warning timeout needs to be implemented} {$warning timeout needs to be implemented}
{$ifdef DEBUG_MT}
ConsolePrintf (#13'SysWaitForThreadTerminate ThreadID:%x Handle:%x'#13#10,GetThreadID,threadHandle);
{$endif}
repeat repeat
status := GetThreadName (ThreadHandle,Buf); {should return EBADHNDL if thread is terminated} status := GetThreadName (ThreadHandle,Buf); {should return EBADHNDL if thread is terminated}
ThreadSwitch; ThreadSwitch;
@ -295,7 +302,7 @@ begin
SysThreadGetPriority := 0; SysThreadGetPriority := 0;
end; end;
function GetThreadID : dword; cdecl; external 'clib' name 'GetThreadID';
function SysGetCurrentThreadId : dword; function SysGetCurrentThreadId : dword;
begin begin
@ -535,7 +542,10 @@ end.
{ {
$Log$ $Log$
Revision 1.4 2004-07-30 15:05:25 armin Revision 1.5 2004-09-26 19:25:49 armin
* exiting threads at nlm unload
Revision 1.4 2004/07/30 15:05:25 armin
make netware rtl compilable under 1.9.5 make netware rtl compilable under 1.9.5
Revision 1.3 2003/10/01 21:00:09 peter Revision 1.3 2003/10/01 21:00:09 peter

74
rtl/netware/tthread.inc
View File

@ -1,9 +1,10 @@
{ {
$Id$ $Id$
This file is part of the Free Component Library (FCL) This file is part of the Free Component Library (FCL)
Copyright (c) 1999-2003 by the Free Pascal development team Copyright (c) 2003-2004 Armin Diehl, member of the Free Pascal
development team
Netware TThread implementation Netware clib TThread implementation
See the file COPYING.FPC, included in this distribution, See the file COPYING.FPC, included in this distribution,
for details about the copyright. for details about the copyright.
@ -25,7 +26,7 @@ type
var var
ThreadRoot : PThreadRec; ThreadRoot : PThreadRec;
ThreadsInited : boolean; ThreadsInited : boolean;
// MainThreadID: longint; DisableRemoveThread : boolean;
Const Const
ThreadCount: longint = 0; ThreadCount: longint = 0;
@ -55,19 +56,24 @@ procedure InitThreads;
begin begin
ThreadRoot:=nil; ThreadRoot:=nil;
ThreadsInited:=true; ThreadsInited:=true;
DisableRemoveThread:=false;
end; end;
{DoneThreads will terminate all remaining threads}
procedure DoneThreads; procedure DoneThreads;
var var
hp : PThreadRec; hp,next : PThreadRec;
begin begin
DisableRemoveThread := true; {to avoid that Destroy calling RemoveThread modifies Thread List}
while assigned(ThreadRoot) do while assigned(ThreadRoot) do
begin begin
ThreadRoot^.Thread.Destroy; ThreadRoot^.Thread.Destroy;
hp:=ThreadRoot; hp:=ThreadRoot;
ThreadRoot:=ThreadRoot^.Next; ThreadRoot:=ThreadRoot^.Next;
dispose(hp); dispose(hp);
{$ifdef DEBUG_MT}
ConsolePrintf(#13'DoneThreads: called destroy, remaining threads: %d ThreadRoot: %x'#13#10,ThreadCount,longint(ThreadRoot));
{$endif}
end; end;
ThreadsInited:=false; ThreadsInited:=false;
end; end;
@ -87,7 +93,7 @@ begin
hp^.next:=ThreadRoot; hp^.next:=ThreadRoot;
ThreadRoot:=hp; ThreadRoot:=hp;
inc(ThreadCount, 1); inc(ThreadCount);
end; end;
@ -95,25 +101,28 @@ procedure RemoveThread(t:TThread);
var var
lasthp,hp : PThreadRec; lasthp,hp : PThreadRec;
begin begin
hp:=ThreadRoot; if not DisableRemoveThread then {disabled while in DoneThreads}
lasthp:=nil; begin
while assigned(hp) do hp:=ThreadRoot;
begin lasthp:=nil;
if hp^.Thread=t then while assigned(hp) do
begin
if hp^.Thread=t then
begin begin
if assigned(lasthp) then if assigned(lasthp) then
lasthp^.next:=hp^.next lasthp^.next:=hp^.next
else else
ThreadRoot:=hp^.next; ThreadRoot:=hp^.next;
dispose(hp); dispose(hp);
Dec(ThreadCount);
if ThreadCount = 0 then ThreadsInited := false;
exit; exit;
end; end;
lasthp:=hp; lasthp:=hp;
hp:=hp^.next; hp:=hp^.next;
end; end;
end else
Dec(ThreadCount, 1); dec(ThreadCount);
if ThreadCount = 0 then DoneThreads;
end; end;
@ -133,7 +142,10 @@ begin
Thread.FFinished := True; Thread.FFinished := True;
Thread.DoTerminate; Thread.DoTerminate;
if FreeThread then if FreeThread then
begin
Thread.Destroy;
Thread.Free; Thread.Free;
end;
EndThread(Result); EndThread(Result);
end; end;
@ -149,25 +161,24 @@ begin
FHandle := BeginThread (@ThreadProc,pointer(self)); FHandle := BeginThread (@ThreadProc,pointer(self));
if FSuspended then Suspend; if FSuspended then Suspend;
FThreadID := FHandle; FThreadID := FHandle;
//IsMultiThread := TRUE; {already set by systhrds}
FFatalException := nil; FFatalException := nil;
end; end;
destructor TThread.Destroy; destructor TThread.Destroy;
begin begin
if not FFinished {and not Suspended} then if not FFinished then
begin begin
if Suspended then ResumeThread (FHandle); {netware can not kill a thread} Terminate;
Terminate; if Suspended then
WaitFor; ResumeThread (FHandle); {netware can not kill a thread, the thread has to}
end; {leave it's execute routine if terminated is true}
{if FHandle <> -1 then WaitFor; {wait for the thread to terminate}
KillThread (FHandle);} {something went wrong, kill the thread (not possible on netware)} end;
FFatalException.Free; FFatalException.Free;
FFatalException := nil; FFatalException := nil;
inherited Destroy; inherited Destroy;
RemoveThread(self); RemoveThread(self); {remove it from the list of active threads}
end; end;
@ -209,14 +220,14 @@ end;
{does not make sense for netware} {does not make sense for netware}
procedure TThread.Synchronize(Method: TThreadMethod); procedure TThread.Synchronize(Method: TThreadMethod);
begin begin
{$ifndef netware} (*
FSynchronizeException := nil; FSynchronizeException := nil;
FMethod := Method; FMethod := Method;
{ SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self)); } { SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self)); }
{$warning Synchronize needs implementation} {$warning Synchronize needs implementation}
if Assigned(FSynchronizeException) then if Assigned(FSynchronizeException) then
raise FSynchronizeException; raise FSynchronizeException;
{$endif} *)
end; end;
@ -260,7 +271,10 @@ end;
{ {
$Log$ $Log$
Revision 1.2 2004-07-30 15:05:25 armin Revision 1.3 2004-09-26 19:25:49 armin
* exiting threads at nlm unload
Revision 1.2 2004/07/30 15:05:25 armin
make netware rtl compilable under 1.9.5 make netware rtl compilable under 1.9.5
Revision 1.1 2003/10/06 21:01:06 peter Revision 1.1 2003/10/06 21:01:06 peter

20
rtl/netware/winsock.pp
View File

@ -2417,15 +2417,33 @@ IOW, there _must_ be 3 versions then: var/const, pchar and pointer}
end; end;
end; end;
var
oldUnloadProc : pointer;
procedure exitProc;
begin
{$ifdef DEBUG_MT}
ConsolePrintf (#13'winsock.exitProc called'#13#10);
{$endif}
NetwareUnloadProc := oldUnloadProc;
WSACleanup;
end;
initialization initialization
WSAstartupData.wVersion := $ffff; WSAstartupData.wVersion := $ffff;
oldUnloadProc := NetwareUnloadProc;
NetwareUnloadProc := @exitProc;
finalization finalization
WSACleanUp; WSACleanUp;
end. end.
{ {
$Log$ $Log$
Revision 1.4 2004-09-18 23:45:43 armin Revision 1.5 2004-09-26 19:25:49 armin
* exiting threads at nlm unload
Revision 1.4 2004/09/18 23:45:43 armin
* make winsock more compatible to win32 version * make winsock more compatible to win32 version
Revision 1.3 2003/10/25 23:42:35 hajny Revision 1.3 2003/10/25 23:42:35 hajny