mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-22 09:45:22 +02:00
* exiting threads at nlm unload
This commit is contained in:
armin
parent
173aea0681
commit
0f1fec0de1
@ -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
|
||||
MAKEFILETARGETS=netware
|
||||
@ -225,8 +225,8 @@ else
|
||||
SYSTEMUNIT=sysnetwa
|
||||
endif
|
||||
override FPCOPT+=-Ur
|
||||
override FPCOPT+=-dMT -dDEBUG_MT
|
||||
CREATESMART=0
|
||||
override FPCOPT+=-dMT
|
||||
CREATESMART=1
|
||||
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_LOADERS+=nwpre prelude
|
||||
|
||||
@ -60,11 +60,10 @@ override FPCOPT+=-Ur
|
||||
|
||||
|
||||
# for netware always use multithread
|
||||
override FPCOPT+=-dMT -dDEBUG_MT
|
||||
override FPCOPT+=-dMT
|
||||
|
||||
# and alway use smartlinking
|
||||
#CREATESMART=1
|
||||
CREATESMART=0
|
||||
CREATESMART=1
|
||||
|
||||
# Paths
|
||||
OBJPASDIR=$(RTL)/objpas
|
||||
|
||||
@ -38,10 +38,20 @@ implementation
|
||||
{ OS - independent class implementations are in /inc directory. }
|
||||
{$i classes.inc}
|
||||
|
||||
initialization
|
||||
CommonInit;
|
||||
|
||||
finalization
|
||||
DoneThreads;
|
||||
CommonCleanup;
|
||||
|
||||
end.
|
||||
{
|
||||
$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 /
|
||||
* long namespace by default
|
||||
* dos.exec implemented
|
||||
|
||||
@ -1929,5 +1929,8 @@
|
||||
y1,
|
||||
YearsSince1970,
|
||||
yn,
|
||||
__ZBuf2F
|
||||
__ZBuf2F,
|
||||
# GetKey,UnGetKey from server.nlm (or syscalls)
|
||||
GetKey,
|
||||
UngetKey
|
||||
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,8 +1,8 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 1999-2000 by the Free Pascal development team
|
||||
Copyright (c) 2001 Armin Diehl
|
||||
Copyright (c) 1999-2004 by the Free Pascal development team
|
||||
Copyright (c) 2001-2004 Armin Diehl
|
||||
|
||||
Interface to netware clib
|
||||
|
||||
@ -17,6 +17,7 @@
|
||||
|
||||
|
||||
CONST Clib = 'clib';
|
||||
ThreadsNlm = 'threads';
|
||||
|
||||
TYPE
|
||||
dev_t = LONGINT;
|
||||
@ -69,9 +70,16 @@ FUNCTION _BeginThread (func, stack : pointer; Stacksize : LONGINT; arg : pointer
|
||||
FUNCTION _GetThreadDataAreaPtr : POINTER; CDecl; EXTERNAL CLib NAME 'GetThreadDataAreaPtr';
|
||||
PROCEDURE _SaveThreadDataAreaPtr (P : POINTER); CDecl; EXTERNAL CLib NAME 'SaveThreadDataAreaPtr';
|
||||
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 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';
|
||||
// this gives internal compiler error 1234124 ??
|
||||
//PROCEDURE ConsolePrintf (FormatStr : PCHAR; Param : array of const); CDecl; EXTERNAL CLib;
|
||||
@ -340,28 +348,31 @@ CONST
|
||||
NW_NS_LONG = 4;
|
||||
|
||||
function _NWAddSearchPathAtEnd (searchPath : pchar; var number : longint) : longint; cdecl; external Clib name 'NWAddSearchPathAtEnd';
|
||||
function _NWDeleteSearchPath (searchPathNumber : longint) : longint; cdecl; external Clib name 'NWDeleteSearchPath';
|
||||
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';
|
||||
|
||||
|
||||
// values for __mode used with spawnxx()
|
||||
CONST
|
||||
P_WAIT = 0;
|
||||
P_NOWAIT = 1;
|
||||
P_OVERLAY = 2;
|
||||
P_NOWAITO = 4;
|
||||
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 _NWDeleteSearchPath (searchPathNumber : longint) : longint; cdecl; external Clib name 'NWDeleteSearchPath';
|
||||
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';
|
||||
|
||||
|
||||
// values for __mode used with spawnxx()
|
||||
CONST
|
||||
P_WAIT = 0;
|
||||
P_NOWAIT = 1;
|
||||
P_OVERLAY = 2;
|
||||
P_NOWAITO = 4;
|
||||
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):longint;cdecl;external Clib name 'spawnlp';
|
||||
function spawnvp(mode:longint; path:Pchar; argv:PPchar):longint;cdecl;external Clib name 'spawnvp';
|
||||
|
||||
|
||||
{
|
||||
$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 /
|
||||
* long namespace by default
|
||||
* dos.exec implemented
|
||||
|
||||
@ -11,8 +11,8 @@
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{$mode objfpc}
|
||||
{$R-}
|
||||
unit Sockets;
|
||||
|
||||
Interface
|
||||
@ -20,9 +20,10 @@ Interface
|
||||
{$macro on}
|
||||
{$define maybelibc:=}
|
||||
|
||||
{$R-}
|
||||
|
||||
Uses
|
||||
winsock;
|
||||
Uses
|
||||
winsock;
|
||||
|
||||
Type
|
||||
cushort=word;
|
||||
@ -52,6 +53,14 @@ Implementation
|
||||
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;
|
||||
begin
|
||||
fpSocket:=WinSock.Socket(Domain,xtype,ProtoCol);
|
||||
@ -80,7 +89,7 @@ begin
|
||||
SocketError:=0;
|
||||
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
|
||||
fpRecv:=WinSock.Recv(S,Buf,Len,Flags);
|
||||
if fpRecv<0 then
|
||||
@ -89,10 +98,10 @@ begin
|
||||
SocketError:=0;
|
||||
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
|
||||
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
|
||||
SocketError:=WSAGetLastError
|
||||
else
|
||||
@ -109,7 +118,7 @@ begin
|
||||
SocketError:=0;
|
||||
end;
|
||||
|
||||
function fpshutdown (s:cint; how:cint):cint;
|
||||
function fpshutdown (s:cint; how:cint):cint;
|
||||
begin
|
||||
fpShutDown:=WinSock.ShutDown(S,How);
|
||||
if fpShutDown<0 then
|
||||
@ -165,16 +174,16 @@ begin
|
||||
SocketError:=0;
|
||||
end;
|
||||
|
||||
function fpaccept (s:cint; addrx : psockaddr; addrlen : psocklen):cint;
|
||||
function fpaccept (s:cint; addrx : psockaddr; addrlen : psocklen):cint;
|
||||
begin
|
||||
fpAccept:=WinSock.Accept(S,WinSock.PSockAddr(Addrx),plongint(@AddrLen));
|
||||
fpAccept:=WinSock.Accept(S,WinSock.PSockAddr(Addrx),plongint(AddrLen));
|
||||
if fpAccept<0 then
|
||||
SocketError:=WSAGetLastError
|
||||
else
|
||||
SocketError:=0;
|
||||
end;
|
||||
|
||||
function fpgetsockname (s:cint; name : psockaddr; namelen : psocklen):cint;
|
||||
function fpgetsockname (s:cint; name : psockaddr; namelen : psocklen):cint;
|
||||
|
||||
begin
|
||||
fpGetSockName:=WinSock.GetSockName(S,WinSock.TSockAddr(name^),nameLen^);
|
||||
@ -184,7 +193,7 @@ begin
|
||||
SocketError:=0;
|
||||
end;
|
||||
|
||||
function fpgetpeername (s:cint; name : psockaddr; namelen : psocklen):cint;
|
||||
function fpgetpeername (s:cint; name : psockaddr; namelen : psocklen):cint;
|
||||
begin
|
||||
fpGetPeerName:=WinSock.GetPeerName(S,WinSock.TSockAddr(name^),NameLen^);
|
||||
if fpGetPeerName<0 then
|
||||
@ -193,7 +202,7 @@ begin
|
||||
SocketError:=0;
|
||||
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
|
||||
fpGetSockOpt:=WinSock.GetSockOpt(S,Level,OptName,OptVal,OptLen^);
|
||||
if fpGetSockOpt<0 then
|
||||
@ -202,7 +211,7 @@ begin
|
||||
SocketError:=0;
|
||||
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
|
||||
fpSetSockOpt:=WinSock.SetSockOpt(S,Level,OptName,OptVal,OptLen);
|
||||
@ -212,9 +221,9 @@ begin
|
||||
SocketError:=0;
|
||||
end;
|
||||
|
||||
function fpsocketpair (d:cint; xtype:cint; protocol:cint; sv:pcint):cint;
|
||||
function fpsocketpair (d:cint; xtype:cint; protocol:cint; sv:pcint):cint;
|
||||
begin
|
||||
fpsocketpair := -1;
|
||||
fpSocketPair := -1;
|
||||
end;
|
||||
|
||||
Function CloseSocket(Sock:Longint):Longint;
|
||||
@ -228,7 +237,7 @@ begin
|
||||
end else
|
||||
begin
|
||||
CloseSocket := 0;
|
||||
SocketError := 0;
|
||||
SocketError := 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -285,7 +294,7 @@ end;
|
||||
|
||||
Function SocketPair(Domain,SocketType,Protocol:Longint;var Pair:TSockArray):Longint;
|
||||
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;
|
||||
end;
|
||||
|
||||
@ -385,7 +394,10 @@ finalization
|
||||
end.
|
||||
{
|
||||
$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
|
||||
|
||||
Revision 1.5 2004/07/30 15:05:25 armin
|
||||
|
||||
@ -69,20 +69,24 @@ VAR
|
||||
NetwareCheckFunction : TNWCheckFunction;
|
||||
NetwareMainThreadGroupID: longint;
|
||||
NetwareCodeStartAddress : dword;
|
||||
NetwareUnloadProc : pointer = nil; {like exitProc but for nlm unload only}
|
||||
|
||||
CONST
|
||||
envp : ppchar = nil; {dummy to make heaptrc happy}
|
||||
|
||||
|
||||
PROCEDURE ConsolePrintf (FormatStr : PCHAR; Param : LONGINT); CDecl;
|
||||
PROCEDURE ConsolePrintf3 (FormatStr : PCHAR; P1,P2,P3 : LONGINT); CDecl;
|
||||
PROCEDURE ConsolePrintf (FormatStr : PCHAR); CDecl;
|
||||
procedure ConsolePrintf (FormatStr : PCHAR; Param : LONGINT); CDecl;
|
||||
procedure ConsolePrintf (FormatStr : PCHAR; Param : 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;
|
||||
TSysReleaseThreadVars = procedure;
|
||||
TSysSetThreadDataAreaPtr = function (newPtr:pointer):pointer;
|
||||
|
||||
|
||||
procedure NWSysSetThreadFunctions (crs:TSysCloseAllRemainingSemaphores;
|
||||
rtv:TSysReleaseThreadVars;
|
||||
stdata:TSysSetThreadDataAreaPtr);
|
||||
@ -101,10 +105,13 @@ implementation
|
||||
{$I errno.inc}
|
||||
|
||||
|
||||
var
|
||||
var
|
||||
CloseAllRemainingSemaphores : TSysCloseAllRemainingSemaphores = nil;
|
||||
ReleaseThreadVars : TSysReleaseThreadVars = 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;
|
||||
rtv:TSysReleaseThreadVars;
|
||||
@ -113,9 +120,9 @@ begin
|
||||
CloseAllRemainingSemaphores := crs;
|
||||
ReleaseThreadVars := rtv;
|
||||
SetThreadDataAreaPtr := stdata;
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
procedure __EnterDebugger; cdecl; external 'clib' name 'EnterDebugger';
|
||||
|
||||
|
||||
procedure PASCALMAIN;external name 'PASCALMAIN';
|
||||
@ -161,6 +168,18 @@ var SigTermHandlerActive : boolean;
|
||||
|
||||
Procedure system_exit;
|
||||
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 (ReleaseThreadVars) then ReleaseThreadVars;
|
||||
|
||||
@ -746,13 +765,13 @@ begin
|
||||
oldTG := _SetThreadGroupID (NetwareMainThreadGroupID);
|
||||
{ to allow use of threadvars, we simply set the threadvar-memory
|
||||
from the main thread }
|
||||
if assigned (SetThreadDataAreaPtr) then
|
||||
if assigned (SetThreadDataAreaPtr) then
|
||||
oldPtr := SetThreadDataAreaPtr (NIL); { nil means main threadvars }
|
||||
result := 0;
|
||||
NetwareCheckFunction (result);
|
||||
if assigned (SetThreadDataAreaPtr) then
|
||||
SetThreadDataAreaPtr (oldPtr);
|
||||
|
||||
|
||||
_SetThreadGroupID (oldTG);
|
||||
end else
|
||||
result := 0;
|
||||
@ -812,7 +831,13 @@ end;
|
||||
procedure TermSigHandler (Sig:longint); CDecl;
|
||||
var oldTG : longint;
|
||||
oldPtr: pointer;
|
||||
err : longint;
|
||||
current_exit : procedure;
|
||||
ThreadName : array [0..20] of char;
|
||||
HadExitProc : boolean;
|
||||
Count : longint;
|
||||
begin
|
||||
|
||||
oldTG := _SetThreadGroupID (NetwareMainThreadGroupID); { this is only needed for nw 3.11 }
|
||||
|
||||
{ _GetThreadDataAreaPtr will not be valid because the signal
|
||||
@ -821,25 +846,88 @@ begin
|
||||
here }
|
||||
if assigned (SetThreadDataAreaPtr) then
|
||||
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 }
|
||||
do_exit; { calls finalize units }
|
||||
if assigned (SetThreadDataAreaPtr) then
|
||||
SetThreadDataAreaPtr (oldPtr);
|
||||
SetThreadDataAreaPtr (oldPtr);
|
||||
_SetThreadGroupID (oldTG);
|
||||
{$ifdef DEBUG_MT}
|
||||
ConsolePrintf (#13'TermSigHandler: all done'#13#10);
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
|
||||
procedure SysInitStdIO;
|
||||
begin
|
||||
{ Setup stdin, stdout and stderr }
|
||||
StdInputHandle := _fileno (LONGINT (_GetStdIn^)); // GetStd** returns **FILE !
|
||||
StdInputHandle := _fileno (LONGINT (_GetStdIn^)); // GetStd** returns **FILE
|
||||
StdOutputHandle:= _fileno (LONGINT (_GetStdOut^));
|
||||
StdErrorHandle := _fileno (LONGINT (_GetStdErr^));
|
||||
|
||||
OpenStdIO(Input,fmInput,StdInputHandle);
|
||||
OpenStdIO(Output,fmOutput,StdOutputHandle);
|
||||
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
|
||||
|
||||
|
||||
{$ifdef StdErrToConsole}
|
||||
AssignStdErrConsole(StdErr);
|
||||
{$else}
|
||||
@ -870,7 +958,7 @@ Begin
|
||||
else
|
||||
_SetCurrentNameSpace (NW_NS_DOS);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
{$endif useLongNamespaceByDefault}
|
||||
|
||||
{ Setup heap }
|
||||
@ -880,11 +968,12 @@ Begin
|
||||
{ Reset IO Error }
|
||||
InOutRes:=0;
|
||||
|
||||
(* This should be changed to a real value during *)
|
||||
(* thread driver initialization if appropriate. *)
|
||||
ThreadID := 1;
|
||||
|
||||
SysInitStdIO;
|
||||
ThreadID := _GetThreadID;
|
||||
{$ifdef DEBUG_MT}
|
||||
ConsolePrintf (#13'Start system, ThreadID: %x'#13#10,ThreadID);
|
||||
{$endif}
|
||||
|
||||
SysInitStdIO;
|
||||
|
||||
{Delphi Compatible}
|
||||
IsLibrary := FALSE;
|
||||
@ -896,7 +985,10 @@ Begin
|
||||
End.
|
||||
{
|
||||
$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
|
||||
|
||||
Revision 1.25 2004/09/03 19:26:27 olle
|
||||
|
||||
@ -81,7 +81,7 @@ begin
|
||||
offset:=threadvarblocksize;
|
||||
inc(threadvarblocksize,size);
|
||||
{$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}
|
||||
end;
|
||||
|
||||
@ -120,7 +120,7 @@ procedure SysAllocateThreadVars;
|
||||
fillchar (threadvars^, threadvarblocksize, 0);
|
||||
_SaveThreadDataAreaPtr (threadvars);
|
||||
{$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}
|
||||
if thredvarsmainthread = nil then
|
||||
thredvarsmainthread := threadvars;
|
||||
@ -187,7 +187,7 @@ function ThreadMain(param : pointer) : dword; cdecl;
|
||||
SysAllocateThreadVars;
|
||||
{$endif HASTHREADVAR}
|
||||
{$ifdef DEBUG_MT}
|
||||
ConsolePrintf(#13'New thread started, initialising ...'#13#10);
|
||||
ConsolePrintf(#13'New thread %x started, initialising ...'#13#10,_GetThreadID);
|
||||
{$endif DEBUG_MT}
|
||||
ti:=pthreadinfo(param)^;
|
||||
InitThread(ti.stklen);
|
||||
@ -215,7 +215,7 @@ function SysBeginThread(sa : Pointer;stacksize : dword;
|
||||
InitThreadVars(@SysRelocateThreadvar);
|
||||
IsMultithread:=true;
|
||||
end;
|
||||
{$endif}
|
||||
{$endif}
|
||||
{ the only way to pass data to the newly created thread }
|
||||
{ in a MT safe way, is to use the heap }
|
||||
new(ti);
|
||||
@ -232,6 +232,9 @@ function SysBeginThread(sa : Pointer;stacksize : dword;
|
||||
|
||||
procedure SysEndThread(ExitCode : DWord);
|
||||
begin
|
||||
{$ifdef DEBUG_MT}
|
||||
ConsolePrintf (#13'SysEndThread %x'#13#10,_GetThreadID);
|
||||
{$endif}
|
||||
DoneThread;
|
||||
ExitThread(ExitCode , TSR_THREAD);
|
||||
end;
|
||||
@ -270,6 +273,7 @@ begin
|
||||
end;
|
||||
|
||||
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 SysWaitForThreadTerminate (threadHandle : dword; TimeoutMs : longint) : dword;
|
||||
@ -278,6 +282,9 @@ var
|
||||
buf : array [0..50] of char;
|
||||
begin
|
||||
{$warning timeout needs to be implemented}
|
||||
{$ifdef DEBUG_MT}
|
||||
ConsolePrintf (#13'SysWaitForThreadTerminate ThreadID:%x Handle:%x'#13#10,GetThreadID,threadHandle);
|
||||
{$endif}
|
||||
repeat
|
||||
status := GetThreadName (ThreadHandle,Buf); {should return EBADHNDL if thread is terminated}
|
||||
ThreadSwitch;
|
||||
@ -295,7 +302,7 @@ begin
|
||||
SysThreadGetPriority := 0;
|
||||
end;
|
||||
|
||||
function GetThreadID : dword; cdecl; external 'clib' name 'GetThreadID';
|
||||
|
||||
|
||||
function SysGetCurrentThreadId : dword;
|
||||
begin
|
||||
@ -535,7 +542,10 @@ end.
|
||||
|
||||
{
|
||||
$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
|
||||
|
||||
Revision 1.3 2003/10/01 21:00:09 peter
|
||||
|
||||
@ -1,9 +1,10 @@
|
||||
{
|
||||
$Id$
|
||||
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,
|
||||
for details about the copyright.
|
||||
@ -25,7 +26,7 @@ type
|
||||
var
|
||||
ThreadRoot : PThreadRec;
|
||||
ThreadsInited : boolean;
|
||||
// MainThreadID: longint;
|
||||
DisableRemoveThread : boolean;
|
||||
|
||||
Const
|
||||
ThreadCount: longint = 0;
|
||||
@ -55,19 +56,24 @@ procedure InitThreads;
|
||||
begin
|
||||
ThreadRoot:=nil;
|
||||
ThreadsInited:=true;
|
||||
DisableRemoveThread:=false;
|
||||
end;
|
||||
|
||||
|
||||
{DoneThreads will terminate all remaining threads}
|
||||
procedure DoneThreads;
|
||||
var
|
||||
hp : PThreadRec;
|
||||
hp,next : PThreadRec;
|
||||
begin
|
||||
DisableRemoveThread := true; {to avoid that Destroy calling RemoveThread modifies Thread List}
|
||||
while assigned(ThreadRoot) do
|
||||
begin
|
||||
ThreadRoot^.Thread.Destroy;
|
||||
hp:=ThreadRoot;
|
||||
ThreadRoot:=ThreadRoot^.Next;
|
||||
dispose(hp);
|
||||
{$ifdef DEBUG_MT}
|
||||
ConsolePrintf(#13'DoneThreads: called destroy, remaining threads: %d ThreadRoot: %x'#13#10,ThreadCount,longint(ThreadRoot));
|
||||
{$endif}
|
||||
end;
|
||||
ThreadsInited:=false;
|
||||
end;
|
||||
@ -87,7 +93,7 @@ begin
|
||||
hp^.next:=ThreadRoot;
|
||||
ThreadRoot:=hp;
|
||||
|
||||
inc(ThreadCount, 1);
|
||||
inc(ThreadCount);
|
||||
end;
|
||||
|
||||
|
||||
@ -95,25 +101,28 @@ procedure RemoveThread(t:TThread);
|
||||
var
|
||||
lasthp,hp : PThreadRec;
|
||||
begin
|
||||
hp:=ThreadRoot;
|
||||
lasthp:=nil;
|
||||
while assigned(hp) do
|
||||
begin
|
||||
if hp^.Thread=t then
|
||||
if not DisableRemoveThread then {disabled while in DoneThreads}
|
||||
begin
|
||||
hp:=ThreadRoot;
|
||||
lasthp:=nil;
|
||||
while assigned(hp) do
|
||||
begin
|
||||
if hp^.Thread=t then
|
||||
begin
|
||||
if assigned(lasthp) then
|
||||
lasthp^.next:=hp^.next
|
||||
else
|
||||
ThreadRoot:=hp^.next;
|
||||
dispose(hp);
|
||||
Dec(ThreadCount);
|
||||
if ThreadCount = 0 then ThreadsInited := false;
|
||||
exit;
|
||||
end;
|
||||
lasthp:=hp;
|
||||
hp:=hp^.next;
|
||||
end;
|
||||
|
||||
Dec(ThreadCount, 1);
|
||||
if ThreadCount = 0 then DoneThreads;
|
||||
lasthp:=hp;
|
||||
hp:=hp^.next;
|
||||
end;
|
||||
end else
|
||||
dec(ThreadCount);
|
||||
end;
|
||||
|
||||
|
||||
@ -133,7 +142,10 @@ begin
|
||||
Thread.FFinished := True;
|
||||
Thread.DoTerminate;
|
||||
if FreeThread then
|
||||
begin
|
||||
Thread.Destroy;
|
||||
Thread.Free;
|
||||
end;
|
||||
EndThread(Result);
|
||||
end;
|
||||
|
||||
@ -149,25 +161,24 @@ begin
|
||||
FHandle := BeginThread (@ThreadProc,pointer(self));
|
||||
if FSuspended then Suspend;
|
||||
FThreadID := FHandle;
|
||||
//IsMultiThread := TRUE; {already set by systhrds}
|
||||
FFatalException := nil;
|
||||
end;
|
||||
|
||||
|
||||
destructor TThread.Destroy;
|
||||
begin
|
||||
if not FFinished {and not Suspended} then
|
||||
begin
|
||||
if Suspended then ResumeThread (FHandle); {netware can not kill a thread}
|
||||
Terminate;
|
||||
WaitFor;
|
||||
end;
|
||||
{if FHandle <> -1 then
|
||||
KillThread (FHandle);} {something went wrong, kill the thread (not possible on netware)}
|
||||
if not FFinished then
|
||||
begin
|
||||
Terminate;
|
||||
if Suspended then
|
||||
ResumeThread (FHandle); {netware can not kill a thread, the thread has to}
|
||||
{leave it's execute routine if terminated is true}
|
||||
WaitFor; {wait for the thread to terminate}
|
||||
end;
|
||||
FFatalException.Free;
|
||||
FFatalException := nil;
|
||||
inherited Destroy;
|
||||
RemoveThread(self);
|
||||
RemoveThread(self); {remove it from the list of active threads}
|
||||
end;
|
||||
|
||||
|
||||
@ -209,14 +220,14 @@ end;
|
||||
{does not make sense for netware}
|
||||
procedure TThread.Synchronize(Method: TThreadMethod);
|
||||
begin
|
||||
{$ifndef netware}
|
||||
(*
|
||||
FSynchronizeException := nil;
|
||||
FMethod := Method;
|
||||
{ SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self)); }
|
||||
{$warning Synchronize needs implementation}
|
||||
if Assigned(FSynchronizeException) then
|
||||
raise FSynchronizeException;
|
||||
{$endif}
|
||||
*)
|
||||
end;
|
||||
|
||||
|
||||
@ -260,7 +271,10 @@ end;
|
||||
|
||||
{
|
||||
$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
|
||||
|
||||
Revision 1.1 2003/10/06 21:01:06 peter
|
||||
|
||||
@ -2417,15 +2417,33 @@ IOW, there _must_ be 3 versions then: var/const, pchar and pointer}
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
oldUnloadProc : pointer;
|
||||
|
||||
procedure exitProc;
|
||||
begin
|
||||
{$ifdef DEBUG_MT}
|
||||
ConsolePrintf (#13'winsock.exitProc called'#13#10);
|
||||
{$endif}
|
||||
NetwareUnloadProc := oldUnloadProc;
|
||||
WSACleanup;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
initialization
|
||||
WSAstartupData.wVersion := $ffff;
|
||||
oldUnloadProc := NetwareUnloadProc;
|
||||
NetwareUnloadProc := @exitProc;
|
||||
finalization
|
||||
WSACleanUp;
|
||||
end.
|
||||
{
|
||||
$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
|
||||
|
||||
Revision 1.3 2003/10/25 23:42:35 hajny
|
||||
|
||||
Loading…
Reference in New Issue
Block a user