mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-12 16:29:21 +02:00
+ threads and winsock2 implemented
This commit is contained in:
armin
parent
c43735cc42
commit
8d292eb468
@ -1,15 +1,19 @@
|
|||||||
# Makefile for freepascal rtl for netware
|
# Makefile for freepascal rtl for netware
|
||||||
# Needs working nlmconv + i386-netware-ld
|
# Needs working nlmconv + i386-netware-ld
|
||||||
|
|
||||||
UNITDIR = /usr/lib/fpc/1.1/units/netware/rtl
|
UNITDIR = $(INSTALL_PREFIX)/usr/lib/fpc/1.1/units/netware/rtl
|
||||||
PPC386OPT = -n -di386 -dSYSTEMDEBUG -O3 -Sg -Tnetware -Aelf -a -al -FE.
|
#PPC386OPT = -n -dMT -dDEBUG_MT -di386 -dSYSTEMDEBUG -O3 -Sg -Tnetware -Aelf -a -al -gg -FE.
|
||||||
|
#PPC386OPT = -n -di386 -dSYSTEMDEBUG -O3 -Sg -Tnetware -Aelf -a -al -gg -FE.
|
||||||
|
PPC386OPT = -n -di386 -O3 -Sg -Tnetware -Aelf -a -al -FE.
|
||||||
|
PPC386OPTDBG = -n -di386 -O3 -Sg -Tnetware -Aelf -a -al -gg -FE.
|
||||||
INCLUDES = -I../inc -I../i386 -I../objpas
|
INCLUDES = -I../inc -I../i386 -I../objpas
|
||||||
|
|
||||||
SYSUNIT=system
|
SYSUNIT=system
|
||||||
|
NWPRE=nwpre
|
||||||
OBJEXT=on
|
OBJEXT=on
|
||||||
PPUEXT=ppn
|
PPUEXT=ppn
|
||||||
ASMEXT=s
|
ASMEXT=s
|
||||||
OBJS = $(SYSUNIT).$(OBJEXT) ../inc/strings.$(OBJEXT) dos.$(OBJEXT) nwpre.$(OBJEXT) ../objpas/objpas.$(OBJEXT) sysutils.$(OBJEXT) crt.$(OBJEXT) sockets.$(OBJEXT) mouse.$(OBJEXT) netware.$(OBJEXT) video.$(OBJEXT) keyboard.$(OBJEXT) ../objpas/math.$(OBJEXT) ../objpas/typinfo.$(OBJEXT) ../inc/objects.$(OBJEXT) ../inc/getopts.$(OBJEXT) ../inc/heaptrc.$(OBJEXT) varutils.$(OBJEXT) ../i386/cpu.$(OBJEXT) ../i386/mmx.$(OBJEXT)
|
OBJS = $(SYSUNIT).$(OBJEXT) $(NWPRE).$(OBJEXT) ../inc/os_types.$(OBJEXT) ../inc/strings.$(OBJEXT) dos.$(OBJEXT) ../objpas/objpas.$(OBJEXT) sysutils.$(OBJEXT) crt.$(OBJEXT) sockets.$(OBJEXT) mouse.$(OBJEXT) netware.$(OBJEXT) video.$(OBJEXT) keyboard.$(OBJEXT) ../objpas/math.$(OBJEXT) ../objpas/typinfo.$(OBJEXT) ../inc/objects.$(OBJEXT) ../inc/getopts.$(OBJEXT) ../inc/heaptrc.$(OBJEXT) varutils.$(OBJEXT) ../i386/cpu.$(OBJEXT) ../i386/mmx.$(OBJEXT) winsock2.$(OBJEXT)
|
||||||
|
|
||||||
|
|
||||||
all: $(OBJS)
|
all: $(OBJS)
|
||||||
@ -17,6 +21,9 @@ all: $(OBJS)
|
|||||||
$(SYSUNIT).$(OBJEXT): $(SYSUNIT).pp nwsys.inc
|
$(SYSUNIT).$(OBJEXT): $(SYSUNIT).pp nwsys.inc
|
||||||
ppc386 -Us $(PPC386OPT) $(INCLUDES) $(SYSUNIT).pp
|
ppc386 -Us $(PPC386OPT) $(INCLUDES) $(SYSUNIT).pp
|
||||||
|
|
||||||
|
$(NWPRE).$(OBJEXT): $(NWPRE).pp
|
||||||
|
ppc386 $(PPC386OPTDBG) $(INCLUDES) $(NWPRE).pp
|
||||||
|
|
||||||
%.$(OBJEXT): %.pp nwsys.inc
|
%.$(OBJEXT): %.pp nwsys.inc
|
||||||
ppc386 $(PPC386OPT) $(INCLUDES) $*.pp
|
ppc386 $(PPC386OPT) $(INCLUDES) $*.pp
|
||||||
|
|
||||||
@ -62,6 +69,9 @@ install: $(OBJS)
|
|||||||
cp -f cpu.$(PPUEXT) $(UNITDIR)
|
cp -f cpu.$(PPUEXT) $(UNITDIR)
|
||||||
cp -f mmx.$(OBJEXT) $(UNITDIR)
|
cp -f mmx.$(OBJEXT) $(UNITDIR)
|
||||||
cp -f mmx.$(PPUEXT) $(UNITDIR)
|
cp -f mmx.$(PPUEXT) $(UNITDIR)
|
||||||
|
cp -f os_types.$(PPUEXT) $(UNITDIR)
|
||||||
|
cp -f winsock2.$(OBJEXT) $(UNITDIR)
|
||||||
|
cp -f winsock2.$(PPUEXT) $(UNITDIR)
|
||||||
cp -f nwimp/*.imp $(UNITDIR)
|
cp -f nwimp/*.imp $(UNITDIR)
|
||||||
|
|
||||||
clean:
|
clean:
|
||||||
|
|||||||
@ -1,6 +1,8 @@
|
|||||||
News
|
News
|
||||||
====
|
====
|
||||||
|
|
||||||
|
2002/02/27 armin:
|
||||||
|
- changes for current fpc 1.1
|
||||||
2001/04/16 armin:
|
2001/04/16 armin:
|
||||||
- implemented CRT and SYSUTILS
|
- implemented CRT and SYSUTILS
|
||||||
- nwimp/convertimp to convert .imp files to unix
|
- nwimp/convertimp to convert .imp files to unix
|
||||||
@ -14,9 +16,9 @@
|
|||||||
General
|
General
|
||||||
=======
|
=======
|
||||||
|
|
||||||
Currently generating NetWare-NLM's only work under Linux. (may be under bsd also)
|
Currently generating NetWare-NLM's only work under Linux and win32. (may be under bsd also)
|
||||||
This is because nlmconv from binutils does not work with i.e. win32 coff object files.
|
For Win32 you need a win32 compiled binutils with netware target enabled. Because nlmconv
|
||||||
It works fine with ELF-Objects.
|
only works with elf objects, elf support in binutils is also needed.
|
||||||
|
|
||||||
|
|
||||||
Binutils with netware-support needed
|
Binutils with netware-support needed
|
||||||
@ -45,7 +47,7 @@
|
|||||||
linux on:
|
linux on:
|
||||||
http://home.sch.bme.hu/~keresztg/novell/howto/NLM-Linux-HOWTO.html.
|
http://home.sch.bme.hu/~keresztg/novell/howto/NLM-Linux-HOWTO.html.
|
||||||
|
|
||||||
Binutils-2.11 for win32 with netware support and a patched nlmconv
|
Binutils-2.11 for win32 and RedHat 7.2 with netware support and a patched nlmconv
|
||||||
that supports "copyright" are available from:
|
that supports "copyright" are available from:
|
||||||
http://home.t-online.de/home/armin-diehl/fpcnw
|
http://home.t-online.de/home/armin-diehl/fpcnw
|
||||||
or
|
or
|
||||||
@ -145,20 +147,25 @@
|
|||||||
|
|
||||||
FUNCTION rmdir (path : PCHAR) : LONGINT; CDECL; EXTERNAL;
|
FUNCTION rmdir (path : PCHAR) : LONGINT; CDECL; EXTERNAL;
|
||||||
|
|
||||||
If nlmlib.nlm is not loaded while loading yout nlm, you will get an error abount
|
If nlmlib.nlm is not loaded while loading your nlm, you will get an error about
|
||||||
unknown symbols.
|
unknown symbols.
|
||||||
|
|
||||||
|
|
||||||
- Debugging
|
- Debugging
|
||||||
---------
|
---------
|
||||||
|
|
||||||
Thats currently a problem. There is no source level debugger available. The only way
|
Thats currently a problem. As for as i know, there is no source level debugger
|
||||||
to debug is using the netware internal debugger or nwdbg. nwdbg is a debugger on
|
available that works with freepascal. (But i have a modified version of
|
||||||
assembler level written by Jan Beulich. Symbols are supported. You can get nwdbg for
|
Novells Rdebug that works with nlms generated by freepascal. Currently
|
||||||
netware 4.11,5.0 or 5.1 at developer.novell.com.
|
i'm waiting for novell to answer my questions about redistributing Rdebug.
|
||||||
|
|
||||||
|
The only way to debug i know is using the netware internal debugger or nwdbg.
|
||||||
|
Nwdbg is a debugger on assembler level written by Jan Beulich. Symbols are
|
||||||
|
supported. You can get nwdbg for netware 4.11,5.0 or 5.1 at developer.novell.com.
|
||||||
|
I have no Information about netware 6 yet.
|
||||||
|
|
||||||
I read about plans to adapt gdb to current netware versions. As soon as i have news
|
I also have a compiled version of gdbserve.nlm for gdb on my homepage
|
||||||
about gdb i will change this document.
|
but this does not seem to be stable and will only run on netwar 4.x.
|
||||||
|
|
||||||
- Netware SDK
|
- Netware SDK
|
||||||
-----------
|
-----------
|
||||||
@ -196,4 +203,7 @@
|
|||||||
- VARUTILS
|
- VARUTILS
|
||||||
- CPU
|
- CPU
|
||||||
- MMX
|
- MMX
|
||||||
|
- WinSock2
|
||||||
|
|
||||||
|
|
||||||
|
armin@freepascal.org
|
||||||
|
|||||||
@ -85,7 +85,7 @@ TYPE
|
|||||||
wchar_tSize : LONGINT;
|
wchar_tSize : LONGINT;
|
||||||
END;
|
END;
|
||||||
|
|
||||||
CONST NLM_INFO_SIGNATURE = 'NLMI'; // $494d3c3e;
|
CONST NLM_INFO_SIGNATURE = 'NLMI'; // 0x494d3c3e;
|
||||||
|
|
||||||
kNLMInfo : kNLMInfoT =
|
kNLMInfo : kNLMInfoT =
|
||||||
(Signature : NLM_INFO_SIGNATURE;
|
(Signature : NLM_INFO_SIGNATURE;
|
||||||
@ -152,7 +152,10 @@ END;
|
|||||||
end.
|
end.
|
||||||
{
|
{
|
||||||
$Log$
|
$Log$
|
||||||
Revision 1.3 2001-04-16 18:39:50 florian
|
Revision 1.4 2002-03-17 17:57:33 armin
|
||||||
|
+ threads and winsock2 implemented
|
||||||
|
|
||||||
|
Revision 1.3 2001/04/16 18:39:50 florian
|
||||||
* updates from Armin commited
|
* updates from Armin commited
|
||||||
|
|
||||||
Revision 1.2 2001/04/11 14:17:00 florian
|
Revision 1.2 2001/04/11 14:17:00 florian
|
||||||
|
|||||||
293
rtl/netware/qos.inc
Normal file
293
rtl/netware/qos.inc
Normal file
@ -0,0 +1,293 @@
|
|||||||
|
{
|
||||||
|
$Id$
|
||||||
|
This file is part of the Free Pascal run time library.
|
||||||
|
This unit contains the declarations for the WinSock2
|
||||||
|
Socket Library for Netware and Win32
|
||||||
|
|
||||||
|
Copyright (c) 1999-2002 by the Free Pascal development team
|
||||||
|
|
||||||
|
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.
|
||||||
|
|
||||||
|
**********************************************************************}
|
||||||
|
|
||||||
|
{ This module defines the Quality of Service structures and types used
|
||||||
|
by Winsock applications. }
|
||||||
|
|
||||||
|
{
|
||||||
|
Definitions for valued-based Service Type for each direction of data flow.
|
||||||
|
}
|
||||||
|
|
||||||
|
type
|
||||||
|
|
||||||
|
SERVICETYPE = u_long;
|
||||||
|
{ No data in this direction }
|
||||||
|
|
||||||
|
const
|
||||||
|
SERVICETYPE_NOTRAFFIC = $00000000;
|
||||||
|
{ Best Effort }
|
||||||
|
SERVICETYPE_BESTEFFORT = $00000001;
|
||||||
|
{ Controlled Load }
|
||||||
|
SERVICETYPE_CONTROLLEDLOAD = $00000002;
|
||||||
|
{ Guaranteed }
|
||||||
|
SERVICETYPE_GUARANTEED = $00000003;
|
||||||
|
{ Used to notify
|
||||||
|
change to user }
|
||||||
|
SERVICETYPE_NETWORK_UNAVAILABLE = $00000004;
|
||||||
|
{ corresponds to
|
||||||
|
"General Parameters"
|
||||||
|
defined by IntServ }
|
||||||
|
SERVICETYPE_GENERAL_INFORMATION = $00000005;
|
||||||
|
{ used to indicate
|
||||||
|
that the flow spec
|
||||||
|
contains no change
|
||||||
|
from any previous
|
||||||
|
one }
|
||||||
|
SERVICETYPE_NOCHANGE = $00000006;
|
||||||
|
{ Non-Conforming Traffic }
|
||||||
|
SERVICETYPE_NONCONFORMING = $00000009;
|
||||||
|
{ Custom ServiceType 1 }
|
||||||
|
SERVICETYPE_CUSTOM1 = $0000000A;
|
||||||
|
{ Custom ServiceType 2 }
|
||||||
|
SERVICETYPE_CUSTOM2 = $0000000B;
|
||||||
|
{ Custom ServiceType 3 }
|
||||||
|
SERVICETYPE_CUSTOM3 = $0000000C;
|
||||||
|
{ Custom ServiceType 4 }
|
||||||
|
SERVICETYPE_CUSTOM4 = $0000000D;
|
||||||
|
{
|
||||||
|
Definitions for bitmap-based Service Type for each direction of data flow.
|
||||||
|
}
|
||||||
|
SERVICE_BESTEFFORT = $80020000;
|
||||||
|
SERVICE_CONTROLLEDLOAD = $80040000;
|
||||||
|
SERVICE_GUARANTEED = $80080000;
|
||||||
|
SERVICE_CUSTOM1 = $80100000;
|
||||||
|
SERVICE_CUSTOM2 = $80200000;
|
||||||
|
SERVICE_CUSTOM3 = $80400000;
|
||||||
|
SERVICE_CUSTOM4 = $80800000;
|
||||||
|
{
|
||||||
|
Number of available Service Types.
|
||||||
|
}
|
||||||
|
NUM_SERVICETYPES = 8;
|
||||||
|
{
|
||||||
|
to turn on immediate traffic control, OR ( | ) this flag with the
|
||||||
|
ServiceType field in the FLOWSPEC
|
||||||
|
}
|
||||||
|
{ #define SERVICE_IMMEDIATE_TRAFFIC_CONTROL 0x80000000 // obsolete }
|
||||||
|
SERVICE_NO_TRAFFIC_CONTROL = $81000000;
|
||||||
|
{
|
||||||
|
this flag can be used with the immediate traffic control flag above to
|
||||||
|
prevent any rsvp signaling messages from being sent. Local traffic
|
||||||
|
control will be invoked, but no RSVP Path messages will be sent.This flag
|
||||||
|
can also be used in conjunction with a receiving flowspec to suppress
|
||||||
|
the automatic generation of a Reserve message. The application would
|
||||||
|
receive notification that a Path message had arrived and would then need
|
||||||
|
to alter the QOS by issuing WSAIoctl( SIO_SET_QOS ), to unset this flag
|
||||||
|
and thereby cause Reserve messages to go out.
|
||||||
|
}
|
||||||
|
SERVICE_NO_QOS_SIGNALING = $40000000;
|
||||||
|
{ rsvp status code }
|
||||||
|
STATUS_QOS_RELEASED = $10101010;
|
||||||
|
{
|
||||||
|
Flow Specifications for each direction of data flow.
|
||||||
|
}
|
||||||
|
{ In Bytes/sec }
|
||||||
|
{ In Bytes }
|
||||||
|
{ In Bytes/sec }
|
||||||
|
{ In microseconds }
|
||||||
|
{ In microseconds }
|
||||||
|
{ In Bytes }
|
||||||
|
{ In Bytes }
|
||||||
|
|
||||||
|
type
|
||||||
|
|
||||||
|
Tflowspec = record
|
||||||
|
TokenRate : u_long;
|
||||||
|
TokenBucketSize : u_long;
|
||||||
|
PeakBandwidth : u_long;
|
||||||
|
Latency : u_long;
|
||||||
|
DelayVariation : u_long;
|
||||||
|
ServiceType : SERVICETYPE;
|
||||||
|
MaxSduSize : u_long;
|
||||||
|
MinimumPolicedSize : u_long;
|
||||||
|
end;
|
||||||
|
PFLOWSPEC = ^Tflowspec;
|
||||||
|
LPFLOWSPEC = ^Tflowspec;
|
||||||
|
{
|
||||||
|
this value can be used in the FLOWSPEC structure to instruct the Rsvp Service
|
||||||
|
provider to derive the appropriate default value for the parameter. Note
|
||||||
|
that not all values in the FLOWSPEC structure can be defaults. In the
|
||||||
|
ReceivingFlowspec, all parameters can be defaulted except the ServiceType.
|
||||||
|
In the SendingFlowspec, the MaxSduSize and MinimumPolicedSize can be
|
||||||
|
defaulted. Other defaults may be possible. Refer to the appropriate
|
||||||
|
documentation.
|
||||||
|
}
|
||||||
|
|
||||||
|
const
|
||||||
|
QOS_NOT_SPECIFIED = $FFFFFFFF;
|
||||||
|
NULL_QOS_TYPE = $FFFFFFFD;
|
||||||
|
{
|
||||||
|
define a value that can be used for the PeakBandwidth, which will map into
|
||||||
|
positive infinity when the FLOWSPEC is converted into IntServ floating point
|
||||||
|
format. We can't use (-1) because that value was previously defined to mean
|
||||||
|
"select the default".
|
||||||
|
}
|
||||||
|
POSITIVE_INFINITY_RATE = $FFFFFFFE;
|
||||||
|
{
|
||||||
|
the provider specific structure can have a number of objects in it.
|
||||||
|
Each next structure in the
|
||||||
|
ProviderSpecific will be the QOS_OBJECT_HDR struct that prefaces the actual
|
||||||
|
data with a type and length for that object. This QOS_OBJECT struct can
|
||||||
|
repeat several times if there are several objects. This list of objects
|
||||||
|
terminates either when the buffer length has been reached ( WSABUF ) or
|
||||||
|
an object of type QOS_END_OF_LIST is encountered.
|
||||||
|
}
|
||||||
|
{ the length of object buffer INCLUDING
|
||||||
|
this header }
|
||||||
|
|
||||||
|
type
|
||||||
|
|
||||||
|
TQOS_OBJECT_HDR = record
|
||||||
|
ObjectType : u_long;
|
||||||
|
ObjectLength : u_long;
|
||||||
|
end;
|
||||||
|
LPQOS_OBJECT_HDR = ^TQOS_OBJECT_HDR;
|
||||||
|
PQOS_OBJECT_HDR = ^TQOS_OBJECT_HDR;
|
||||||
|
{
|
||||||
|
general QOS objects start at this offset from the base and have a range
|
||||||
|
of 1000
|
||||||
|
}
|
||||||
|
|
||||||
|
const
|
||||||
|
QOS_GENERAL_ID_BASE = 2000;
|
||||||
|
QOS_OBJECT_PRIORITY = $00000000 + QOS_GENERAL_ID_BASE;
|
||||||
|
{ QOS_PRIORITY structure passed }
|
||||||
|
QOS_OBJECT_END_OF_LIST = $00000001 + QOS_GENERAL_ID_BASE;
|
||||||
|
{ QOS_End_of_list structure passed }
|
||||||
|
QOS_OBJECT_SD_MODE = $00000002 + QOS_GENERAL_ID_BASE;
|
||||||
|
{ QOS_ShapeDiscard structure passed }
|
||||||
|
QOS_OBJECT_TRAFFIC_CLASS = $00000003 + QOS_GENERAL_ID_BASE;
|
||||||
|
{ QOS_Traffic class structure passed }
|
||||||
|
QOS_OBJECT_DESTADDR = $00000004 + QOS_GENERAL_ID_BASE;
|
||||||
|
{ QOS_DestAddr structure }
|
||||||
|
QOS_OBJECT_SHAPER_QUEUE_DROP_MODE = $00000005 + QOS_GENERAL_ID_BASE;
|
||||||
|
{ QOS_ShaperQueueDropMode structure }
|
||||||
|
QOS_OBJECT_SHAPER_QUEUE_LIMIT = $00000006 + QOS_GENERAL_ID_BASE;
|
||||||
|
{ QOS_ShaperQueueLimit structure }
|
||||||
|
{
|
||||||
|
This structure defines the absolute priorty of the flow. Priorities in the
|
||||||
|
range of 0-7 are currently defined. Receive Priority is not currently used,
|
||||||
|
but may at some point in the future.
|
||||||
|
}
|
||||||
|
{ this gets mapped to layer 2 priority. }
|
||||||
|
{ there are none currently defined. }
|
||||||
|
{ this could be used to decide who
|
||||||
|
gets forwarded up the stack first
|
||||||
|
- not used now }
|
||||||
|
|
||||||
|
type
|
||||||
|
|
||||||
|
TQOS_PRIORITY = record
|
||||||
|
ObjectHdr : TQOS_OBJECT_HDR;
|
||||||
|
SendPriority : u_char;
|
||||||
|
SendFlags : u_char;
|
||||||
|
ReceivePriority : u_char;
|
||||||
|
Unused : u_char;
|
||||||
|
end;
|
||||||
|
LPQOS_PRIORITY = ^TQOS_PRIORITY;
|
||||||
|
PQOS_PRIORITY = ^TQOS_PRIORITY;
|
||||||
|
{
|
||||||
|
This structure is used to define the behaviour that the traffic
|
||||||
|
control packet shaper will apply to the flow.
|
||||||
|
|
||||||
|
PS_NONCONF_BORROW - the flow will receive resources remaining
|
||||||
|
after all higher priority flows have been serviced. If a
|
||||||
|
TokenRate is specified, packets may be non-conforming and
|
||||||
|
will be demoted to less than best-effort priority.
|
||||||
|
|
||||||
|
PS_NONCONF_SHAPE - TokenRate must be specified. Non-conforming
|
||||||
|
packets will be retianed in the packet shaper until they become
|
||||||
|
conforming.
|
||||||
|
|
||||||
|
PS_NONCONF_DISCARD - TokenRate must be specified. Non-conforming
|
||||||
|
packets will be discarded.
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
TQOS_SD_MODE = record
|
||||||
|
ObjectHdr : TQOS_OBJECT_HDR;
|
||||||
|
ShapeDiscardMode : u_long;
|
||||||
|
end;
|
||||||
|
LPQOS_SD_MODE = ^TQOS_SD_MODE;
|
||||||
|
PQOS_SD_MODE = ^TQOS_SD_MODE;
|
||||||
|
|
||||||
|
const
|
||||||
|
TC_NONCONF_BORROW = 0;
|
||||||
|
TC_NONCONF_SHAPE = 1;
|
||||||
|
TC_NONCONF_DISCARD = 2;
|
||||||
|
TC_NONCONF_BORROW_PLUS = 3;
|
||||||
|
{
|
||||||
|
This structure may carry an 802.1 TrafficClass parameter which
|
||||||
|
has been provided to the host by a layer 2 network, for example,
|
||||||
|
in an 802.1 extended RSVP RESV message. If this object is obtained
|
||||||
|
from the network, hosts will stamp the MAC headers of corresponding
|
||||||
|
transmitted packets, with the value in the object. Otherwise, hosts
|
||||||
|
may select a value based on the standard Intserv mapping of
|
||||||
|
ServiceType to 802.1 TrafficClass.
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
type
|
||||||
|
|
||||||
|
TQOS_TRAFFIC_CLASS = record
|
||||||
|
ObjectHdr : TQOS_OBJECT_HDR;
|
||||||
|
TrafficClass : u_long;
|
||||||
|
end;
|
||||||
|
LPQOS_TRAFFIC_CLASS = ^TQOS_TRAFFIC_CLASS;
|
||||||
|
PQOS_TRAFFIC_CLASS = ^TQOS_TRAFFIC_CLASS;
|
||||||
|
{
|
||||||
|
This structure allows overriding of the default schema used to drop
|
||||||
|
packets when a flow's shaper queue limit is reached.
|
||||||
|
|
||||||
|
DropMethod -
|
||||||
|
QOS_SHAPER_DROP_FROM_HEAD - Drop packets from
|
||||||
|
the head of the queue until the new packet can be
|
||||||
|
accepted into the shaper under the current limit. This
|
||||||
|
behavior is the default.
|
||||||
|
QOS_SHAPER_DROP_INCOMING - Drop the incoming,
|
||||||
|
limit-offending packet.
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
TQOS_SHAPER_QUEUE_LIMIT_DROP_MODE = record
|
||||||
|
ObjectHdr : TQOS_OBJECT_HDR;
|
||||||
|
DropMode : u_long;
|
||||||
|
end;
|
||||||
|
LPQOS_SHAPER_QUEUE_LIMIT_DROP_MODE = ^TQOS_SHAPER_QUEUE_LIMIT_DROP_MODE;
|
||||||
|
PQOS_SHAPER_QUEUE_LIMIT_DROP_MODE = ^TQOS_SHAPER_QUEUE_LIMIT_DROP_MODE;
|
||||||
|
|
||||||
|
const
|
||||||
|
QOS_SHAPER_DROP_INCOMING = 0;
|
||||||
|
QOS_SHAPER_DROP_FROM_HEAD = 1;
|
||||||
|
|
||||||
|
{ This structure allows the default per-flow limit on the shaper queue
|
||||||
|
size to be overridden.
|
||||||
|
|
||||||
|
QueueSizeLimit - Limit, in bytes, of the size of the shaper queue }
|
||||||
|
|
||||||
|
type
|
||||||
|
|
||||||
|
TQOS_SHAPER_QUEUE_LIMIT = record
|
||||||
|
ObjectHdr : TQOS_OBJECT_HDR;
|
||||||
|
QueueSizeLimit : u_long;
|
||||||
|
end;
|
||||||
|
LPQOS_SHAPER_QUEUE_LIMIT = ^TQOS_SHAPER_QUEUE_LIMIT;
|
||||||
|
PQOS_SHAPER_QUEUE_LIMIT = ^TQOS_SHAPER_QUEUE_LIMIT;
|
||||||
|
|
||||||
|
{
|
||||||
|
$Log:
|
||||||
|
|
||||||
|
}
|
||||||
@ -585,7 +585,6 @@ procedure InitFPU;assembler;
|
|||||||
*****************************************************************************}
|
*****************************************************************************}
|
||||||
|
|
||||||
Begin
|
Begin
|
||||||
_EnterDebugger;
|
|
||||||
{$ifdef MT}
|
{$ifdef MT}
|
||||||
{ the exceptions use threadvars so do this _before_ initexceptions }
|
{ the exceptions use threadvars so do this _before_ initexceptions }
|
||||||
AllocateThreadVars;
|
AllocateThreadVars;
|
||||||
@ -615,8 +614,8 @@ _EnterDebugger;
|
|||||||
End.
|
End.
|
||||||
{
|
{
|
||||||
$Log$
|
$Log$
|
||||||
Revision 1.6 2002-03-08 19:13:49 armin
|
Revision 1.7 2002-03-17 17:57:33 armin
|
||||||
* changes for current rtl, basic MT support
|
+ threads and winsock2 implemented
|
||||||
|
|
||||||
Revision 1.5 2001/06/18 14:26:16 jonas
|
Revision 1.5 2001/06/18 14:26:16 jonas
|
||||||
* move platform independent constant declarations after inclusion of
|
* move platform independent constant declarations after inclusion of
|
||||||
|
|||||||
316
rtl/netware/thread.inc
Normal file
316
rtl/netware/thread.inc
Normal file
@ -0,0 +1,316 @@
|
|||||||
|
{
|
||||||
|
$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
|
||||||
|
|
||||||
|
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;
|
||||||
|
|
||||||
|
|
||||||
|
{$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'];
|
||||||
|
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}
|
||||||
|
ConsolePrintf(#13'threadvars allocated at (%x)'#13#10,longint(threadvars));
|
||||||
|
ConsolePrintf(#13'size of threadvars: %d'#13#10,threadvarblocksize);
|
||||||
|
{$endif DEBUG_MT}
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure ReleaseThreadVars;
|
||||||
|
|
||||||
|
var
|
||||||
|
threadvars : pointer;
|
||||||
|
|
||||||
|
begin
|
||||||
|
{ release thread vars }
|
||||||
|
threadvars:=_GetThreadDataAreaPtr;
|
||||||
|
_Free (threadvars);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure InitThread;
|
||||||
|
|
||||||
|
begin
|
||||||
|
InitFPU;
|
||||||
|
{ we don't need to set the data to 0 because we did this with }
|
||||||
|
{ the fillchar above, but it looks nicer }
|
||||||
|
|
||||||
|
{ ExceptAddrStack and ExceptObjectStack are threadvars }
|
||||||
|
{ so every thread has its on exception handling capabilities }
|
||||||
|
InitExceptions;
|
||||||
|
InOutRes:=0;
|
||||||
|
// ErrNo:=0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure DoneThread;
|
||||||
|
|
||||||
|
begin
|
||||||
|
{ release thread vars }
|
||||||
|
ReleaseThreadVars;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function ThreadMain(param : pointer) : dword;stdcall;
|
||||||
|
|
||||||
|
var
|
||||||
|
ti : tthreadinfo;
|
||||||
|
|
||||||
|
begin
|
||||||
|
{$ifdef DEBUG_MT}
|
||||||
|
writeln('New thread started, initialising ...');
|
||||||
|
{$endif DEBUG_MT}
|
||||||
|
AllocateThreadVars;
|
||||||
|
InitThread;
|
||||||
|
ti:=pthreadinfo(param)^;
|
||||||
|
dispose(pthreadinfo(param));
|
||||||
|
{$ifdef DEBUG_MT}
|
||||||
|
writeln('Jumping to thread function');
|
||||||
|
{$endif DEBUG_MT}
|
||||||
|
ThreadMain:=ti.f(ti.p);
|
||||||
|
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);
|
||||||
|
cs.SemaIsOpen := true;
|
||||||
|
SaveSema (cs.SemaHandle);
|
||||||
|
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.1 2002-03-17 17:57:33 armin
|
||||||
|
+ threads and winsock2 implemented
|
||||||
|
|
||||||
|
}
|
||||||
2371
rtl/netware/winsock2.pp
Normal file
2371
rtl/netware/winsock2.pp
Normal file
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user