diff options
author | florian <florian@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2010-01-07 18:47:04 +0000 |
---|---|---|
committer | florian <florian@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2010-01-07 18:47:04 +0000 |
commit | 6f99ceb6aa51f2de9ec36a9c0031483a17676eda (patch) | |
tree | bd10bd75cfd8f82bb6e932eeffa6236427d784fa /rtl | |
parent | 7a2cab35de443d177969b1078dc0345c5f4e6367 (diff) | |
download | fpc-6f99ceb6aa51f2de9ec36a9c0031483a17676eda.tar.gz |
+ patch by Sven Barth to add native NT rtl support to the fpc rtl, resolves #14887
git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@14568 3ad0048d-3df7-0310-abae-a5850022a9f2
Diffstat (limited to 'rtl')
-rw-r--r-- | rtl/Makefile | 59 | ||||
-rw-r--r-- | rtl/Makefile.fpc | 1 | ||||
-rw-r--r-- | rtl/nativent/Makefile.fpc | 108 | ||||
-rw-r--r-- | rtl/nativent/buildrtl.lpi | 67 | ||||
-rw-r--r-- | rtl/nativent/buildrtl.pp | 10 | ||||
-rw-r--r-- | rtl/nativent/ddk.pas | 59 | ||||
-rw-r--r-- | rtl/nativent/ddk/ddkex.inc | 20 | ||||
-rw-r--r-- | rtl/nativent/ddk/ddktypes.inc | 75 | ||||
-rw-r--r-- | rtl/nativent/ndk.pas | 33 | ||||
-rw-r--r-- | rtl/nativent/ndkutils.pas | 59 | ||||
-rw-r--r-- | rtl/nativent/sysheap.inc | 160 | ||||
-rw-r--r-- | rtl/nativent/sysndk.inc | 219 | ||||
-rw-r--r-- | rtl/nativent/sysos.inc | 18 | ||||
-rw-r--r-- | rtl/nativent/sysosh.inc | 58 | ||||
-rw-r--r-- | rtl/nativent/system.pp | 218 |
15 files changed, 1162 insertions, 2 deletions
diff --git a/rtl/Makefile b/rtl/Makefile index 5d647bee8f..8f3bfed0fa 100644 --- a/rtl/Makefile +++ b/rtl/Makefile @@ -1,8 +1,8 @@ # -# Don't edit, this file is generated by FPCMake Version 2.0.0 [2009/12/07] +# Don't edit, this file is generated by FPCMake Version 2.0.0 [2010/01/07] # default: all -MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-solaris x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded avr-embedded armeb-linux armeb-embedded mipsel-linux +MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-solaris x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded avr-embedded armeb-linux armeb-embedded mipsel-linux BSDs = freebsd netbsd openbsd darwin UNIXs = linux $(BSDs) solaris qnx haiku LIMIT83fs = go32v2 os2 emx watcom @@ -314,6 +314,9 @@ endif ifeq ($(FULL_TARGET),i386-symbian) override TARGET_DIRS+=symbian endif +ifeq ($(FULL_TARGET),i386-nativent) +override TARGET_DIRS+=nativent +endif ifeq ($(FULL_TARGET),m68k-linux) override TARGET_DIRS+=linux endif @@ -772,6 +775,10 @@ ifeq ($(OS_TARGET),symbian) SHAREDLIBEXT=.dll SHORTSUFFIX=symbian endif +ifeq ($(OS_TARGET),NativeNT) +SHAREDLIBEXT=.dll +SHORTSUFFIX=nativent +endif else ifeq ($(OS_TARGET),go32v1) PPUEXT=.pp1 @@ -1730,6 +1737,9 @@ endif ifeq ($(FULL_TARGET),i386-symbian) TARGET_DIRS_SYMBIAN=1 endif +ifeq ($(FULL_TARGET),i386-nativent) +TARGET_DIRS_NATIVENT=1 +endif ifeq ($(FULL_TARGET),m68k-linux) TARGET_DIRS_LINUX=1 endif @@ -2564,6 +2574,51 @@ symbian: $(MAKE) -C symbian all .PHONY: symbian_all symbian_debug symbian_smart symbian_release symbian_units symbian_examples symbian_shared symbian_install symbian_sourceinstall symbian_exampleinstall symbian_distinstall symbian_zipinstall symbian_zipsourceinstall symbian_zipexampleinstall symbian_zipdistinstall symbian_clean symbian_distclean symbian_cleanall symbian_info symbian_makefiles symbian endif +ifdef TARGET_DIRS_NATIVENT +nativent_all: + $(MAKE) -C nativent all +nativent_debug: + $(MAKE) -C nativent debug +nativent_smart: + $(MAKE) -C nativent smart +nativent_release: + $(MAKE) -C nativent release +nativent_units: + $(MAKE) -C nativent units +nativent_examples: + $(MAKE) -C nativent examples +nativent_shared: + $(MAKE) -C nativent shared +nativent_install: + $(MAKE) -C nativent install +nativent_sourceinstall: + $(MAKE) -C nativent sourceinstall +nativent_exampleinstall: + $(MAKE) -C nativent exampleinstall +nativent_distinstall: + $(MAKE) -C nativent distinstall +nativent_zipinstall: + $(MAKE) -C nativent zipinstall +nativent_zipsourceinstall: + $(MAKE) -C nativent zipsourceinstall +nativent_zipexampleinstall: + $(MAKE) -C nativent zipexampleinstall +nativent_zipdistinstall: + $(MAKE) -C nativent zipdistinstall +nativent_clean: + $(MAKE) -C nativent clean +nativent_distclean: + $(MAKE) -C nativent distclean +nativent_cleanall: + $(MAKE) -C nativent cleanall +nativent_info: + $(MAKE) -C nativent info +nativent_makefiles: + $(MAKE) -C nativent makefiles +nativent: + $(MAKE) -C nativent all +.PHONY: nativent_all nativent_debug nativent_smart nativent_release nativent_units nativent_examples nativent_shared nativent_install nativent_sourceinstall nativent_exampleinstall nativent_distinstall nativent_zipinstall nativent_zipsourceinstall nativent_zipexampleinstall nativent_zipdistinstall nativent_clean nativent_distclean nativent_cleanall nativent_info nativent_makefiles nativent +endif ifdef TARGET_DIRS_AMIGA amiga_all: $(MAKE) -C amiga all diff --git a/rtl/Makefile.fpc b/rtl/Makefile.fpc index 6a3aa9716b..9923acbb87 100644 --- a/rtl/Makefile.fpc +++ b/rtl/Makefile.fpc @@ -31,6 +31,7 @@ dirs_gba=gba dirs_nds=nds dirs_symbian=symbian dirs_embedded=embedded +dirs_nativent=nativent [install] fpcpackage=y diff --git a/rtl/nativent/Makefile.fpc b/rtl/nativent/Makefile.fpc new file mode 100644 index 0000000000..0db1a6b233 --- /dev/null +++ b/rtl/nativent/Makefile.fpc @@ -0,0 +1,108 @@ +# +# Makefile.fpc for Free Pascal NativeNT RTL +# + +[package] +main=rtl + +[target] +loaders= +#units=system objpas macpas buildrtl lineinfo lnfodwrf +units=system objpas buildrtl +implicitunits=ndk ndkutils ddk +# ctypes strings +# heaptrc matrix \ +# windows winsock winsock2 initc cmem dynlibs signals \ +# dos crt objects messages \ +# rtlconsts sysconst sysutils math types \ +# strutils dateutils varutils variants typinfo fgl classes \ +# convutils stdconvs cpu mmx charset ucomplex getopts \ +# winevent sockets printer \ +# video mouse keyboard fmtbcd \ +# winsysut sharemem exeinfo fpintres + +# shared=$(DLLS) + +rsts=math varutils typinfo variants classes dateutils sysconst + +[require] +nortl=y + +[install] +fpcpackage=y + +[default] +fpcdir=../.. +target=nativent + +[compiler] +includedir=$(INC) $(PROCINC) $(DDKINC) +sourcedir=$(INC) $(PROCINC) $(COMMON) + + +[prerules] +RTL=.. +INC=$(RTL)/inc +COMMON=$(RTL)/common +PROCINC=$(RTL)/$(CPU_TARGET) +DDKINC=ddk + +UNITPREFIX=rtl + +ifneq ($(findstring 2.0.,$(FPC_VERSION)),) +#LOADERS=wprt0 wdllprt0 gprt0 wcygprt0 +DLLS= +else +DLLS=fpcmemdll +endif + +# Paths +OBJPASDIR=$(RTL)/objpas + +# Files used by windows.pp +#include $(WININC)/makefile.inc + +WINDOWS_SOURCE_FILES=$(addprefix $(WININC)/,$(addsuffix .inc,$(WINDOWS_FILES))) + + +[rules] +.NOTPARALLEL: +SYSTEMPPU=$(addsuffix $(PPUEXT),system) + +# Get the system independent include file names. +# This will set the following variables : +# SYSINCNAMES +include $(INC)/makefile.inc +SYSINCDEPS=$(addprefix $(INC)/,$(SYSINCNAMES)) + +# Get the processor dependent include file names. +# This will set the following variables : +# CPUINCNAMES +include $(PROCINC)/makefile.cpu +SYSCPUDEPS=$(addprefix $(PROCINC)/,$(CPUINCNAMES)) + +# Put system unit dependencies together. +SYSDEPS=$(SYSINCDEPS) $(SYSCPUDEPS) + + +# +# Loaders +# + +# none + +# +# Unit specific rules +# + +system$(PPUEXT) : system.pp $(SYSDEPS) + $(COMPILER) -Us -Sg system.pp + +objpas$(PPUEXT): $(OBJPASDIR)/objpas.pp $(INC)/except.inc system$(PPUEXT) + $(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/objpas.pp + +#macpas$(PPUEXT) : $(INC)/macpas.pp objpas$(PPUEXT) buildrtl$(PPUEXT) +# $(COMPILER) $(INC)/macpas.pp $(REDIR) + +buildrtl$(PPUEXT): buildrtl.pp system$(PPUEXT) objpas$(PPUEXT) + $(COMPILER) -Fi$(OBJPASDIR)/sysutils -Fi$(OBJPASDIR)/classes -Fu$(PROCINC) -I$(OBJPASDIR) -Fi$(DDKINC) -I$(INC) -Fu$(INC) -Fu$(OBJPASDIR) buildrtl diff --git a/rtl/nativent/buildrtl.lpi b/rtl/nativent/buildrtl.lpi new file mode 100644 index 0000000000..2d8feb17a4 --- /dev/null +++ b/rtl/nativent/buildrtl.lpi @@ -0,0 +1,67 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <PathDelim Value="\"/> + <Version Value="7"/> + <General> + <Flags> + <MainUnitHasUsesSectionForAllUnits Value="False"/> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + <Runnable Value="False"/> + <LRSInOutputDirectory Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <TargetFileExt Value=".exe"/> + <Title Value="buildrtl"/> + </General> + <VersionInfo> + <ProjectVersion Value=""/> + </VersionInfo> + <PublishOptions> + <Version Value="2"/> + <IgnoreBinaries Value="False"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/> + </local> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="buildrtl.pp"/> + <IsPartOfProject Value="True"/> + <UnitName Value="buildrtl"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="8"/> + <PathDelim Value="\"/> + <SearchPaths> + <IncludeFiles Value="..\inc\;..\$TargetCPU()\;ddk\;..\objpas\;..\objpas\classes\;..\objpas\sysutils\"/> + <UnitOutputDirectory Value="..\units\i386-nativent"/> + </SearchPaths> + <Parsing> + <Style Value="2"/> + <SyntaxOptions> + <SyntaxMode Value="fpc"/> + </SyntaxOptions> + </Parsing> + <Other> + <Verbosity> + <ShowNotes Value="False"/> + <ShowHints Value="False"/> + </Verbosity> + <CustomOptions Value="-dKMODE"/> + <CompilerPath Value="$(CompPath)"/> + <ExecuteBefore> + <ShowAllMessages Value="True"/> + </ExecuteBefore> + </Other> + </CompilerOptions> +</CONFIG> diff --git a/rtl/nativent/buildrtl.pp b/rtl/nativent/buildrtl.pp new file mode 100644 index 0000000000..c588164789 --- /dev/null +++ b/rtl/nativent/buildrtl.pp @@ -0,0 +1,10 @@ +unit buildrtl; + + interface + + uses + ndk, ndkutils, ddk; + + implementation + +end. diff --git a/rtl/nativent/ddk.pas b/rtl/nativent/ddk.pas new file mode 100644 index 0000000000..130b4722e6 --- /dev/null +++ b/rtl/nativent/ddk.pas @@ -0,0 +1,59 @@ +{ + Driver Development Kit for Native NT + + This file is part of the Free Pascal run time library. + Copyright (c) 2009 by Sven Barth + + 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. + + **********************************************************************} + +unit DDK; + +interface + +uses + NDK; + +const + // we distinguish the user- AND kernel-mode imports (NDK.ntdll) from the pure + // kernel mode imports (ntkrnl) + ntkrnl = 'ntoskrnl.exe'; + +{$include ddktypes.inc} + +// these two only return not Nil in main routine of a device driver +function RegistryPath: PNtUnicodeString; inline; +function DriverObject: PDriverObject; inline; + +function DbgPrint(aFormat: PChar): LongWord; cdecl; varargs; external ntkrnl name 'DbgPrint'; + +function PoolTag(aTag: TTagString): LongWord; + +{$include ddkex.inc} + +implementation + +function RegistryPath: PNtUnicodeString; inline; +begin + RegistryPath := SysRegistryPath; +end; + +function DriverObject: PDriverObject; inline; +begin + DriverObject := SysDriverObject; +end; + +function PoolTag(aTag: TTagString): LongWord; +begin + PoolTag := Ord(aTag[1]) + Ord(aTag[2]) shl 8 + + Ord(aTag[3]) shl 16 + Ord(aTag[4]) shl 24; +end; + +end. + diff --git a/rtl/nativent/ddk/ddkex.inc b/rtl/nativent/ddk/ddkex.inc new file mode 100644 index 0000000000..3e44826a94 --- /dev/null +++ b/rtl/nativent/ddk/ddkex.inc @@ -0,0 +1,20 @@ +{%MainUnit ddk.pas} +{ + Driver Development Kit for Native NT + Imports for Executive + + This file is part of the Free Pascal run time library. + Copyright (c) 2009 by Sven Barth + + 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. + + **********************************************************************} + +function ExAllocatePoolWithTag(PoolType: TPoolType; NumberOfBytes: PtrUInt; Tag: LongWord): Pointer; stdcall; external ntkrnl name 'ExAllocatePoolWithTag'; +procedure ExFreePoolWithTag(P: Pointer; Tag: LongWord); stdcall; external ntkrnl name 'ExFreePoolWithTag'; + diff --git a/rtl/nativent/ddk/ddktypes.inc b/rtl/nativent/ddk/ddktypes.inc new file mode 100644 index 0000000000..fb0a9c4f27 --- /dev/null +++ b/rtl/nativent/ddk/ddktypes.inc @@ -0,0 +1,75 @@ +{%MainUnit ddk.pas} +{ + Driver Development Kit for Native NT + Basic types used in Kernel Mode + + This file is part of the Free Pascal run time library. + Copyright (c) 2009 by Sven Barth + + 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. + + **********************************************************************} + +type + _DEVICE_OBJECT = packed record + + end; + TDeviceObject = _DEVICE_OBJECT; + PDeviceObject = ^TDeviceObject; + + _FAST_IO_DISPATCH = packed record + + end; + TFastIODispatch = _FAST_IO_DISPATCH; + PFastIODispatch = ^TFastIODispatch; + + _DRIVER_EXTENSION = packed record + + end; + TDriverExtension = _DRIVER_EXTENSION; + PDriverExtension = ^TDriverExtension; + + _DRIVER_OBJECT = packed record + _Type: SmallInt; + Size: SmallInt; + DeviceObject: PDeviceObject; + Flags: LongWord; + DriverStart: Pointer; + DriverSize: LongWord; + DriverSection: Pointer; + DriverExtension: PDriverExtension; + DriverName: TNtUnicodeString; + HardwareDatabase: PNtUnicodeString; + FastIoDispatch: PFastIODispatch; + DriverInit: PLongInt; + DriverStartIo: Pointer; + DriverUnload: Pointer; + MajorFunction: array[0..27] of PLongInt; + end; + TDriverObject = _Driver_Object; + PDriverObject = ^TDriverObject; + + POOL_TYPE = ( + NonPagedPool, + PagedPool, + NonPagedPoolMustSucceed, + DontUseThisType, + NonPagedPoolCacheAligned, + PagedPoolCacheAligned, + NonPagedPoolCacheAlignedMustS, + MaxPoolType, + NonPagedPoolSession = 32, + PagedPoolSession, + NonPagedPoolMustSucceedSession, + DontUseThisTypeSession, + NonPagedPoolCacheAlignedSession, + PagedPoolCacheAlignedSession, + NonPagedPoolCacheAlignedMustSSession + ); + TPoolType = POOL_TYPE; + diff --git a/rtl/nativent/ndk.pas b/rtl/nativent/ndk.pas new file mode 100644 index 0000000000..de83c74646 --- /dev/null +++ b/rtl/nativent/ndk.pas @@ -0,0 +1,33 @@ +{ + Native Development Kit for Native NT + + This file is part of the Free Pascal run time library. + Copyright (c) 2009 by Sven Barth + + 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. + + **********************************************************************} + +unit NDK; + +interface + +{$I sysndk.inc} + +function NtDelayExecution(aAlertable: Boolean; aInterval: PLargeInteger): NTSTATUS; stdcall; external ntdll; + + +function LdrGetProcedureAddress(hModule: THandle; psName: PNtUnicodeString; dwOrdinal: LongWord; var pProcedure: Pointer): NTSTATUS; stdcall; external ntdll; +function LdrLoadDll(pwPath : PWord; pdwFlags : LongWord; pusPath : PNtUnicodeString; var phModule : THandle): NTSTATUS; stdcall; external ntdll; +function LdrUnloadDll(hModule: THandle): NTSTATUS; stdcall; external ntdll; + + +implementation + +end. + diff --git a/rtl/nativent/ndkutils.pas b/rtl/nativent/ndkutils.pas new file mode 100644 index 0000000000..d50e07b71b --- /dev/null +++ b/rtl/nativent/ndkutils.pas @@ -0,0 +1,59 @@ +{ + FPC Utility Function for Native NT applications + + This file is part of the Free Pascal run time library. + Copyright (c) 2009 by Sven Barth + + 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. + + **********************************************************************} + +unit NDKUtils; + +{.$H+} + +interface + +uses + NDK; + +procedure ShortStrToNTStr(aStr: ShortString; var aNTStr: TNtUnicodeString); +//procedure AnsiStrToNTStr(const aStr: String; var aNTStr: TNtUnicodeString); + +implementation + +procedure ShortStrToNTStr(aStr: ShortString; var aNTStr: TNtUnicodeString); +var + buf: Pointer; + i: Integer; +begin + FillChar(aNTStr, SizeOf(TNtUnicodeString), 0); + aNTStr.Length := Length(aStr) * 2; + aNTStr.buffer := GetMem(aNTStr.Length); + buf := aNTStr.buffer; + for i := 1 to Length(aStr) do begin + PWord(buf)^ := Word(aStr[i]); + buf := Pointer(PtrUInt(buf) + SizeOf(Word)); + end; + aNTStr.MaximumLength := aNTStr.Length; +end; + +procedure InitializeObjectAttributes(var aObjectAttr: TObjectAttributes; aName: PNtUnicodeString; aAttributes: ULONG; aRootDir: THandle; aSecurity: Pointer); +begin + with aObjectAttr do begin + Length := SizeOf(TObjectAttributes); + RootDirectory := aRootDir; + Attributes := aAttributes; + ObjectName := aName; + SecurityDescriptor := aSecurity; + SecurityQualityOfService := Nil; + end; +end; + +end. + diff --git a/rtl/nativent/sysheap.inc b/rtl/nativent/sysheap.inc new file mode 100644 index 0000000000..6fa04e224a --- /dev/null +++ b/rtl/nativent/sysheap.inc @@ -0,0 +1,160 @@ +{ + Basic heap handling for windows platforms + + This file is part of the Free Pascal run time library. + Copyright (c) 2001-2005 by 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. + + **********************************************************************} + + +{***************************************************************************** + OS Memory allocation / deallocation + ****************************************************************************} + + { In kernel mode we can either use FPC's build in memory manager or we use a + custom non-chunking manager. The problem with the build in one is that the + driver developer has far less control of the allocated memory blocks. } + + { memory functions } +{$ifdef KMODE} + function ExAllocatePoolWithTag(PoolType: LongInt; NumberOfBytes: PtrUInt; Tag: LongWord): Pointer; stdcall; external ntdll name 'ExAllocatePoolWithTag'; + procedure ExFreePoolWithTag(P: Pointer; Tag: LongWord); stdcall; external ntdll name 'ExFreePoolWithTag'; +{$else KMODE} + function RtlAllocateHeap(hHeap : THandle; dwFlags : LongWord; Size : Longword): Pointer; + stdcall; external ntdll name 'RtlAllocateHeap'; + function RtlFreeHeap(hHeap : THandle; dwFlags : LongWord; MemoryPointer : Pointer): Boolean; + stdcall; external ntdll name 'RtlFreeHeap'; + function RtlCreateHeap(Flags: LongWord; Base: Pointer; SizeToReserve: PtrUInt; + SizeToCommit: PtrUInt; Lock: PVOID; Parameters: Pointer): THandle; + stdcall; external ntdll name 'RtlCreateHeap'; + +var + SysHeap: THandle = Nil; + +procedure PrepareSysHeap; +begin + if IsLibrary then + // create a new heap (flag is HEAP_GROWABLE) + SysHeap := RtlCreateHeap(2, Nil, 65534, 65534, Nil, Nil) + else + // use the heap passed on startup + SysHeap := PPEB(CurrentPEB)^.ProcessHeap; +end; + +{$endif KMODE} + +{$ifndef KMODE} + +// default memory manager + +function SysOSAlloc(size: ptruint): pointer; +begin + if SysHeap = Nil then + PrepareSysHeap; + SysOSAlloc := RtlAllocateHeap(SysHeap, 0, size); +end; + +{$define HAS_SYSOSFREE} + +procedure SysOSFree(p: pointer; size: ptruint); +begin + // if heap isn't set, then nothing was allocated + if SysHeap <> Nil then + RtlFreeHeap(SysHeap, 0, p); +end; + +{$else KMODE} + +// custom non-chunking memory manager for kernel mode + +// memory layout: +// <PtrUInt>: Size of reserved chunk +// <Tag>: Tag that was used in ExAllocateFromPoolWithTag (needed in free) +// <...>: Userdata + +function SysGetMem(Size: PtrUInt): Pointer; +var + tag: LongWord; + pooltype: LongInt; +begin + if HeapUsePagedPool then + pooltype := 1 + else + pooltype := 0; + tag := Ord(HeapPoolTag[1]) + Ord(HeapPoolTag[2]) shl 8 + + Ord(HeapPoolTag[3]) shl 16 + Ord(HeapPoolTag[4]) shl 24; + // the kernel keeps track of our memory, but there's no way to ask it + // so we need to track the size by ourself + SysGetMem := ExAllocatePoolWithTag(pooltype, Size + SizeOf(PtrUInt) + SizeOf(LongWord), tag); + // save the size + PPtrUInt(SysGetMem)^ := Size; + SysGetMem := SysGetMem + SizeOf(PtrUInt); + // save the tag + PLongWord(SysGetMem)^ := tag; + SysGetMem := SysGetMem + SizeOf(LongWord); +end; + +function SysFreeMem(p: Pointer): PtrUInt; +var + tag: PLongWord; +begin + tag := p - SizeOf(LongWord); + // we need to pass the tag we used to allocate the memory (else: BSOD) + ExFreePoolWithTag(p - SizeOf(PtrUInt) - SizeOf(LongWord), tag^); + SysFreeMem := 0; +end; + +function SysFreeMemSize(p: Pointer; Size: PtrUInt): PtrUInt; +begin + SysFreeMemSize := 0; + if (Size > 0) and (p <> nil) then + Result := SysFreeMem(p); +end; + +Function SysAllocMem(Size: PtrUInt): Pointer; +begin + SysAllocMem := SysGetMem(Size); + if SysAllocMem <> nil then + FillChar(SysAllocMem^, Size, 0); +end; + +Function SysReAllocMem (var p: pointer; Size: PtrUInt): Pointer; +begin + SysReAllocMem := SysGetMem(Size); + Move(p^, SysReAllocMem^, Size); + p := SysReAllocMem; +end; + +function SysTryResizeMem(var p: Pointer; size: PtrUInt): Boolean; +var + res: pointer; +begin + res := SysGetMem(Size); + SysTryResizeMem := (res <> Nil) or (Size = 0); + if SysTryResizeMem then + p := res; +end; + +function SysMemSize(P : pointer): PtrUInt; +begin + SysMemSize := PPtrUInt(P - SizeOf(PtrUInt) - SizeOf(LongWord))^; +end; + +function SysGetHeapStatus: THeapStatus; +begin + FillChar(SysGetHeapStatus, SizeOf(SysGetHeapStatus), 0); +end; + +function SysGetFPCHeapStatus: TFPCHeapStatus; +begin + FillChar(SysGetFPCHeapStatus, SizeOf(SysGetHeapStatus), 0); +end; + +{$endif KMODE} diff --git a/rtl/nativent/sysndk.inc b/rtl/nativent/sysndk.inc new file mode 100644 index 0000000000..32f06861ee --- /dev/null +++ b/rtl/nativent/sysndk.inc @@ -0,0 +1,219 @@ +// These datatypes are used in system.pas and ndk.pas + +const +{$ifdef kmode} + ntdll = 'ntoskrnl.exe'; +{$else} + ntdll = 'ntdll.dll'; +{$endif} + +type + // + // some basic types + // + HANDLE = THandle; + PVOID = Pointer; + LONG = LongInt; + ULONG = LongWord; + + + NTSTATUS = LongInt; + + UNICODE_STRING = packed record + Length: Word; // used characters in buffer + MaximumLength: Word; // maximum characters in buffer + Buffer: PWideChar; + end; + PUNICODE_STRING = ^UNICODE_STRING; + // alias to differ from TUnicodeString + TNtUnicodeString = UNICODE_STRING; + PNtUnicodeString = ^TNtUnicodeString; + + // using Int64 is an alternative (QWord might have unintended side effects) + LARGE_INTEGER = packed record + case Boolean of + True:(LowPart: LongWord; + HighPart: LongInt); + False:(QuadPart: Int64); + end; + PLARGE_INTEGER = ^LARGE_INTEGER; + TLargeInteger = LARGE_INTEGER; + PLargeInteger = ^TLargeInteger; + + +// +// Object Attributes structure +// + POBJECT_ATTRIBUTES = ^OBJECT_ATTRIBUTES; + _OBJECT_ATTRIBUTES = record + Length: ULONG; + RootDirectory: HANDLE; + ObjectName: PUNICODE_STRING; + Attributes: ULONG; + SecurityDescriptor: PVOID; // Points to type SECURITY_DESCRIPTOR + SecurityQualityOfService: PVOID; // Points to type SECURITY_QUALITY_OF_SERVICE + end; + OBJECT_ATTRIBUTES = _OBJECT_ATTRIBUTES; + TObjectAttributes = OBJECT_ATTRIBUTES; + PObjectAttributes = POBJECT_ATTRIBUTES; + + TRtlDriveLetterCurDir = packed record + Flags: Word; + Length: Word; + TimeStamp: LongWord; + DosPath: TNtUnicodeString; + end; + + TCurDir = packed record + DosPath: TNtUnicodeString; + Handle: THandle; + end; + + TRtlUserProcessParameters = packed record + MaximumLength: LongWord; + Length: LongWord; + Flags: LongWord; + DebugFlags: LongWord; + ConsoleHandle: THandle; + ConsoleFlags: LongWord; + StandardInput: THandle; + StandardOutput: THandle; + StandardError: THandle; + CurrentDirectory: TCurDir; + DllPath: TNtUnicodeString; + ImagePathName: TNtUnicodeString; + CommandLine: TNtUnicodeString; + Environment: ^Word; // PWSTR + StartingX: LongWord; + StartingY: LongWord; + CountX: LongWord; + CountY: LongWord; + CountCharsX: LongWord; + CountCharsY: LongWord; + FillAttribute: LongWord; + WindowFlags: LongWord; + ShowWindowFlags: LongWord; + WindowTitle: TNtUnicodeString; + DesktopInfo: TNtUnicodeString; + ShellInfo: TNtUnicodeString; + RuntimeData: TNtUnicodeString; + CurrentDirectories: array[0..31] of TRtlDriveLetterCurDir; + end; + PRtlUserProcessParameters = ^TRtlUserProcessParameters; + + TSimplePEB = packed record + InheritedAddressSpace: Byte; + ReadImageFileExecOptions: Byte; + BeingDebugged: Byte; +//#if (NTDDI_VERSION >= NTDDI_WS03) +// struct + { + UCHAR ImageUsesLargePages:1; + #if (NTDDI_VERSION >= NTDDI_LONGHORN) + UCHAR IsProtectedProcess:1; + UCHAR IsLegacyProcess:1; + UCHAR SpareBits:5; + #else + UCHAR SpareBits:7; + #endif + }//; +//#else + SpareBool: Byte; +//#endif + Mutant: THandle; + ImageBaseAddress: Pointer; + Ldr: Pointer; // PPEB_LDR_DATA + ProcessParameters: PRtlUserProcessParameters; + SubSystemData: Pointer; + ProcessHeap: Pointer; +//#if (NTDDI_VERSION >= NTDDI_LONGHORN) +(* struct _RTL_CRITICAL_SECTION *FastPebLock; + PVOID AltThunkSListPtr; + PVOID IFEOKey; + ULONG Spare; + union + { + PVOID* KernelCallbackTable; + PVOID UserSharedInfoPtr; + }; + ULONG SystemReserved[1]; + ULONG SpareUlong;*) +//#else + FastPebLock: Pointer; + FastPebLockRoutine: Pointer; // PPEBLOCKROUTINE + FastPebUnlockRoutine: Pointer; // PPEBLOCKROUTINE + EnvironmentUpdateCount: LongWord; + KernelCallbackTable: Pointer; // PVOID* + EventLogSection: Pointer; + EventLog: Pointer; +//#endif + FreeList: Pointer; // PPEB_FREE_BLOCK + TlsExpansionCounter: LongWord; + TlsBitmap: Pointer; + TlsBitmapBits: array[0..1] of LongWord; //TlsBitmapBits[0x2] + ReadOnlySharedMemoryBase: Pointer; + ReadOnlySharedMemoryHeap: Pointer; + ReadOnlyStaticServerData: Pointer; //PVOID* + AnsiCodePageData: Pointer; + OemCodePageData: Pointer; + UnicodeCaseTableData: Pointer; + NumberOfProcessors: LongWord; + NtGlobalFlag: LongWord; + CriticalSectionTimeout: Int64; // LARGE_INTEGER + HeapSegmentReserve: LongWord; + HeapSegmentCommit: LongWord; + HeapDeCommitTotalFreeThreshold: LongWord; + HeapDeCommitFreeBlockThreshold: LongWord; + NumberOfHeaps: LongWord; + MaximumNumberOfHeaps: LongWord; + ProcessHeaps: Pointer; // PVOID* + GdiSharedHandleTable: Pointer; + ProcessStarterHelper: Pointer; + GdiDCAttributeList: LongWord; +//#if (NTDDI_VERSION >= NTDDI_LONGHORN) +// struct _RTL_CRITICAL_SECTION *LoaderLock; +//#else + LoaderLock: Pointer; +//#endif + OSMajorVersion: LongWord; + OSMinorVersion: LongWord; + OSBuildNumber: Word; // USHORT + OSCSDVersion: Word; // USHORT + OSPlatformId: LongWord; + ImageSubSystem: LongWord; + ImageSubSystemMajorVersion: LongWord; + ImageSubSystemMinorVersion: LongWord; + ImageProcessAffinityMask: LongWord; + GdiHandleBuffer: array[0..$21] of LongWord; // GdiHandleBuffer[0x22] + PostProcessInitRoutine: Pointer; //PPOST_PROCESS_INIT_ROUTINE + TlsExpansionBitmap: Pointer; //struct _RTL_BITMAP *TlsExpansionBitmap + TlsExpansionBitmapBits: array[0..$19] of Word; //TlsExpansionBitmapBits[0x20] + SessionId: LongWord; +{#if (NTDDI_VERSION >= NTDDI_WINXP) + ULARGE_INTEGER AppCompatFlags; + ULARGE_INTEGER AppCompatFlagsUser; + PVOID pShimData; + PVOID AppCompatInfo; + UNICODE_STRING CSDVersion; + struct _ACTIVATION_CONTEXT_DATA *ActivationContextData; + struct _ASSEMBLY_STORAGE_MAP *ProcessAssemblyStorageMap; + struct _ACTIVATION_CONTEXT_DATA *SystemDefaultActivationContextData; + struct _ASSEMBLY_STORAGE_MAP *SystemAssemblyStorageMap; + ULONG MinimumStackCommit; +#endif +#if (NTDDI_VERSION >= NTDDI_WS03) + PVOID *FlsCallback; + LIST_ENTRY FlsListHead; + struct _RTL_BITMAP *FlsBitmap; + ULONG FlsBitmapBits[4]; + ULONG FlsHighIndex; +#endif +#if (NTDDI_VERSION >= NTDDI_LONGHORN) + PVOID WerRegistrationData; + PVOID WerShipAssertPtr; +#endif} + end; + PPEB = ^TSimplePEB; + +function NtDisplayString(aString: PNtUnicodeString): NTSTATUS; stdcall; external ntdll; + diff --git a/rtl/nativent/sysos.inc b/rtl/nativent/sysos.inc new file mode 100644 index 0000000000..a3e0630d86 --- /dev/null +++ b/rtl/nativent/sysos.inc @@ -0,0 +1,18 @@ +{ + Basic stuff for NativeNT RTLs + + This file is part of the Free Pascal run time library. + Copyright (c) 2009 by Sven Barth + + 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. + + **********************************************************************} + +// some needed types from NDK.pas +{$include sysndk.inc} + diff --git a/rtl/nativent/sysosh.inc b/rtl/nativent/sysosh.inc new file mode 100644 index 0000000000..6cb478d6b4 --- /dev/null +++ b/rtl/nativent/sysosh.inc @@ -0,0 +1,58 @@ +{ + Basic Native NT stuff + + This file is part of the Free Pascal run time library. + Copyright (c) 2009 by Sven Barth + + 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. + + **********************************************************************} + +{ Platform specific information } +type + THandle = Pointer; + ULONG_PTR = PtrUInt; + TThreadID = THandle; + SIZE_T = ULONG_PTR; + + { the fields of this record are os dependent } + { and they shouldn't be used in a program } + { only the type TCriticalSection is important } + PRTLCriticalSection = ^TRTLCriticalSection; + TRTLCriticalSection = packed record + DebugInfo : pointer; + LockCount : longint; + RecursionCount : longint; + OwningThread : THandle; + LockSemaphore : THandle; + SpinCount : ULONG_PTR; + end; + +var + { the following variables are only set if apptype=native and the RTL is + compiled with -dKMODE (device driver) + they are exported with their real types in unit DDK } + // real type: PNtUnicodeString; only valid during PascalMain + SysRegistryPath: Pointer = Nil; + // real type: PDriverObject; only valid during PascalMain + SysDriverObject: Pointer = Nil; + +type + TTagString = String[4]; + +{$ifdef KMODE} +const + DefaultPoolTag = 'fpc'; + +var + // tells the heap whether to use paged memory or not + HeapUsePagedPool: Boolean = True; + // the tag is a four byte string to identify the memory allocated by our + // driver, which must not be empty + HeapPoolTag: TTagString = DefaultPoolTag; +{$endif KMODE} diff --git a/rtl/nativent/system.pp b/rtl/nativent/system.pp new file mode 100644 index 0000000000..290938b22b --- /dev/null +++ b/rtl/nativent/system.pp @@ -0,0 +1,218 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2009 by Sven Barth + + FPC Pascal system unit for the WinNT API. + + 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. + + **********************************************************************} +unit System; +interface + +{$ifdef SYSTEMDEBUG} + {$define SYSTEMEXCEPTIONDEBUG} +{$endif SYSTEMDEBUG} + +{.$define FPC_HAS_INDIRECT_MAIN_INFORMATION} + +{$ifdef cpui386} + {$define Set_i386_Exception_handler} +{$endif cpui386} + +{.$define DISABLE_NO_THREAD_MANAGER} + +{$ifdef KMODE} + {$define HAS_MEMORYMANAGER} +{$endif KMODE} + +{ include system-independent routine headers } +{$I systemh.inc} + +var + CurrentPeb: Pointer; + IsDeviceDriver: Boolean = False; + +const + LineEnding = #13#10; + LFNSupport = true; + DirectorySeparator = '\'; + DriveSeparator = '\'; + ExtensionSeparator = '.'; + PathSeparator = ';'; + AllowDirectorySeparators : set of char = ['\']; + AllowDriveSeparators : set of char = []; + +{ FileNameCaseSensitive is defined separately below!!! } + maxExitCode = High(LongInt); + MaxPathLen = High(Word); + AllFilesMask = '*'; + +type + PEXCEPTION_FRAME = ^TEXCEPTION_FRAME; + TEXCEPTION_FRAME = record + next : PEXCEPTION_FRAME; + handler : pointer; + end; + +{$ifndef kmode} +type + TDLL_Entry_Hook = procedure (dllparam : longint); + +const + Dll_Process_Detach_Hook : TDLL_Entry_Hook = nil; + Dll_Thread_Attach_Hook : TDLL_Entry_Hook = nil; + Dll_Thread_Detach_Hook : TDLL_Entry_Hook = nil; +{$endif} + +const + // NT is case sensitive + FileNameCaseSensitive : boolean = true; + // todo: check whether this is really the case on NT + CtrlZMarksEOF: boolean = true; (* #26 is considered as end of file *) + + sLineBreak = LineEnding; + + { Thread count for DLL } + Thread_count : longint = 0; + System_exception_frame : PEXCEPTION_FRAME =nil; + +implementation + +{ include system independent routines } +{$I system.inc} + +procedure KeQueryTickCount(TickCount: PLargeInteger); stdcall; external ntdll name 'KeQueryTickCount'; + +procedure randomize; +var + tc: PLargeInteger; +begin + FillChar(tc, SizeOf(TLargeInteger), 0); + KeQueryTickCount(@tc); + // the lower part should differ most on system startup + randseed := tc^.LowPart; +end; + +{***************************************************************************** + System Dependent Exit code +*****************************************************************************} + +procedure PascalMain;stdcall;external name 'PASCALMAIN'; + +{$ifndef KMODE} +function NtTerminateProcess(aProcess: THandle; aStatus: NTSTATUS): NTSTATUS; stdcall; external ntdll name 'NtTerminateProcess'; +{$endif KMODE} + +Procedure system_exit; +begin + if IsLibrary or IsDeviceDriver then + Exit; +{$ifndef KMODE} + NtTerminateProcess(THandle(-1), ExitCode); +{$endif KMODE} +end; + +{$ifdef kmode} +function FPCDriverStartup(aDriverObject: Pointer; aRegistryPath: Pointer): NTSTATUS; [public, alias: 'FPC_DriverStartup']; +begin + IsDeviceDriver := True; + IsConsole := True; + IsLibrary := True; + + SysDriverObject := aDriverObject; + SysRegistryPath := aRegistryPath; + + PASCALMAIN; + + SysDriverObject := Nil; + SysRegistryPath := Nil; + + Result := ExitCode; +end; +{$else} + +const + DLL_PROCESS_ATTACH = 1; + DLL_THREAD_ATTACH = 2; + DLL_PROCESS_DETACH = 0; + DLL_THREAD_DETACH = 3; + +function FPCDLLEntry(aHInstance: Pointer; aDLLReason: LongInt; aDLLParam: LongInt): LongBool; [public, alias: 'FPC_DLLEntry']; +begin + IsLibrary := True; + FPCDLLEntry := True; + case aDLLReason of + DLL_PROCESS_ATTACH: begin + PascalMain; + FPCDLLEntry := ExitCode = 0; + end; + DLL_THREAD_ATTACH: begin + if Dll_Thread_Attach_Hook <> Nil then + Dll_Thread_Attach_Hook(aDllParam); + end; + DLL_THREAD_DETACH: begin + if Dll_Thread_Detach_Hook <> Nil then + Dll_Thread_Detach_Hook(aDllParam); + end; + DLL_PROCESS_DETACH: begin + if Dll_Process_Detach_Hook <> Nil then + Dll_Process_Detach_Hook(aDllParam); + // finalize units + do_exit; + end; + end; +end; + +procedure FPCProcessStartup(aArgument: Pointer);[public, alias: 'FPC_ProcessStartup']; +begin + IsConsole := True; + IsLibrary := False; + CurrentPeb := aArgument; + + PASCALMAIN; + + system_exit; +end; +{$endif} + +{$ifdef kmode} + +// Kernel Mode Entry Point + +function NtDriverEntry( aDriverObject: Pointer; aRegistryPath: Pointer ): LongInt; stdcall; [public, alias: '_NtDriverEntry']; +begin + NtDriverEntry := FPCDriverStartup(aDriverObject, aRegistryPath); +end; +{$else} + +// User Mode Entry Points + +procedure NtProcessStartup( aArgument: Pointer ); stdcall; [public, alias: '_NtProcessStartup']; +begin + FPCProcessStartup(aArgument); +end; + +function DLLMainStartup( aHInstance: Pointer; aDLLReason, aDLLParam: LongInt ): LongBool; stdcall; [public, alias: '_DLLMainStartup']; +begin + DLLMainStartup := FPCDLLEntry(aHInstance, aDLLReason, aDLLParam); +end; +{$endif} + +begin +{$if not defined(KMODE) and not defined(HAS_MEMORYMANAGER)} + { Setup heap } + InitHeap; +{$endif ndef KMODE and ndef HAS_MEMORYMANAGER} + SysInitExceptions; + initvariantmanager; + { we do not use winlike widestrings and also the RTL can't be compiled with + 2.2, so we can savely use the UnicodeString manager only. } + initunicodestringmanager; +end. + |