Skip to content
Permalink
Browse files
Patchset BSD and more.
  • Loading branch information
LongDirtyAnimAlf committed Mar 17, 2020
1 parent 421f551 commit 2958b7fc64dd6d6aae6a6436b324cbed4cadb9b1
Showing 13 changed files with 503 additions and 131 deletions.
@@ -54528,7 +54528,7 @@ function StubCallAllocMem(const Size, flProtect: DWORD): pointer;
fpmunmap(result,STUB_SIZE);
end;
end;
result := nil; // error
result := MAP_FAILED; // error
end;
{$else} // other platforms (Intel+Arm64) use absolute call
begin
@@ -54553,6 +54553,9 @@ TFakeStubBuffer = class

var
CurrentFakeStubBuffer: TFakeStubBuffer;
{$ifdef UNIX}
MemoryProtection:boolean=false;
{$endif UNIX}

constructor TFakeStubBuffer.Create;
begin
@@ -54562,11 +54565,21 @@ constructor TFakeStubBuffer.Create;
{$ifdef KYLIX3}
fStub := mmap(nil,STUB_SIZE,PROT_READ OR PROT_WRITE OR PROT_EXEC,MAP_PRIVATE OR MAP_ANONYMOUS,-1,0);
{$else}
fStub := StubCallAllocMem(STUB_SIZE,PROT_READ OR PROT_WRITE OR PROT_EXEC);
if (NOT MemoryProtection) then fStub := StubCallAllocMem(STUB_SIZE,PROT_READ OR PROT_WRITE OR PROT_EXEC);
if ((fStub=MAP_FAILED) OR MemoryProtection) then
begin
// i.e. on OpenBSD, we can have w^x protection
fStub := StubCallAllocMem(STUB_SIZE,PROT_READ OR PROT_WRITE);
if (fStub<>MAP_FAILED) then MemoryProtection:=True;
end;
{$endif KYLIX3}
{$endif MSWINDOWS}
if fStub=nil then
raise EServiceException.CreateUTF8('%.Create: OS allocation failed',[self]);
{$ifdef MSWINDOWS}
if (fStub=nil) then
{$else}
if (fStub=MAP_FAILED) then
{$endif}
raise EServiceException.CreateUTF8('%.Create: OS memory allocation failed',[Self]);
end;

destructor TFakeStubBuffer.Destroy;
@@ -54602,6 +54615,9 @@ class function TFakeStubBuffer.Reserve(size: Cardinal): pointer;
function TInterfaceFactory.GetMethodsVirtualTable: pointer;
var i, tmp: cardinal;
P: PCardinal;
{$ifdef UNIX}
PageAlignedFakeStub:pointer;
{$endif UNIX}
{$ifdef CPUAARCH64}stub: PtrUInt;{$endif}
begin
if fFakeVTable=nil then begin
@@ -54621,8 +54637,21 @@ function TInterfaceFactory.GetMethodsVirtualTable: pointer;
{$ifdef CPUARM}fMethodsCount*12{$endif}
{$ifdef CPUAARCH64}($120 shr 2)+fMethodsCount*28{$endif};
fFakeStub := TFakeStubBuffer.Reserve(tmp);
PtrUInt(fFakeStub) := PtrUInt(fFakeStub){$ifdef CPUAARCH64} + $120{$endif};
P := pointer(fFakeStub);
{$ifdef CPUAARCH64}
PtrUInt(P) := PtrUInt(P)+$120;
{$endif};

{$ifdef UNIX}
if MemoryProtection then
begin
// Disable execution permission of memory to be able to write into memory
PageAlignedFakeStub := Pointer((PtrUInt(P) DIV SystemInfo.dwPageSize) * SystemInfo.dwPageSize);
if SynMProtect(PageAlignedFakeStub , (SystemInfo.dwPageSize shl 1), PROT_READ OR PROT_WRITE)<0 then
raise EServiceException.CreateUTF8('%.Create: SynMProtect write failure.',[self]);
end;
{$endif UNIX}

for i := 0 to fMethodsCount-1 do begin
fFakeVTable[i+RESERVED_VTABLE_SLOTS] := P;
{$ifdef CPUX64}
@@ -54673,6 +54702,16 @@ function TInterfaceFactory.GetMethodsVirtualTable: pointer;
inc(PByte(P),3);
{$endif CPUX86}
end;

{$ifdef UNIX}
if MemoryProtection then
begin
// Enable execution permission of memory
if SynMProtect(PageAlignedFakeStub , (SystemInfo.dwPageSize shl 1), PROT_READ OR PROT_EXEC)<0 then
raise EServiceException.CreateUTF8('%.Create: SynMProtect exec failure.',[self]);
end;
{$endif UNIX}

end;
finally
InterfaceFactoryCache.Safe.UnLock;
@@ -2278,13 +2278,13 @@ procedure MoveFast(const src; var dst; cnt: PtrInt);
// - on non-Intel CPUs, it will fallback to the default RTL FillChar()
// - note: Delphi x86_64 is far from efficient: even ERMS was wrongly
// introduced in latest updates
var FillcharFast: procedure(var Dest; count: PtrInt; Value: byte) {$ifdef FPC} = FillChar {$endif};
var FillcharFast: procedure(var Dest; count: PtrInt; Value: byte);

/// our fast version of move()
// - on Delphi Intel i386/x86_64, will use fast SSE2 instructions (if available),
// or optimized X87 assembly implementation for older CPUs
// - on non-Intel CPUs, it will fallback to the default RTL Move()
var MoveFast: procedure(const Source; var Dest; Count: PtrInt) {$ifdef FPC} = Move {$endif};
var MoveFast: procedure(const Source; var Dest; Count: PtrInt);

{$endif CPUX64}
{$endif ABSOLUTEPASCAL}
@@ -13641,8 +13641,10 @@ function GetNextFieldPropSameLine(var P: PUTF8Char; var Prop: ShortString): bool
VTYPE_STATIC = $BFE8;

{$ifdef FPC}
{$if not defined (CPUARM3264) and not defined(BSD)}
/// overloaded function which can be properly inlined
procedure VarClear(var v: variant); inline;
{$endif}
{$endif FPC}

/// same as Dest := TVarData(Source) for simple values
@@ -13710,6 +13712,10 @@ function VarIs(const V: Variant; const VTypes: TVarDataTypes): Boolean;

{$ifndef NOVARIANTS}

{$ifdef FPC}
function SynMProtect(addr:pointer;size:size_t;prot:integer):longint;
{$endif}

type
/// custom variant handler with easier/faster access of variant properties,
// and JSON serialization support
@@ -16763,14 +16769,49 @@ implementation
UTF8_FIRSTBYTE: array[2..6] of byte = ($c0,$e0,$f0,$f8,$fc);

{$ifdef FPC}

{$if not defined (CPUARM3264) and not defined(BSD)}
procedure VarClear(var v: variant); // defined here for proper inlining
(*
Alf.
This has been a very long standing issue on all arm/arm64 and BSD systems.
The sockets got corrupted by the variants test, leading to TestSQL3 failures.
Been hunting this for more than 2 years ...
It should/ could be investigated in more detail.
Also due to the fact that, for FPC this VTYPE_STATIC is often disabled in the source by defines !
*)
var p: pointer; // more efficient generated asm with an explicit temp variable
begin
p := @v;
if integer(PVarData(p)^.VType) and VTYPE_STATIC=0 then
PPtrInt(p)^ := 0 else
PPtrInt(p)^ := 0
else
VarClearProc(PVarData(p)^);
end;
{$endif}

{$ifdef BSD}
function mprotect(Addr: Pointer; Len: size_t; Prot: Integer): Integer;
{$ifdef Darwin} cdecl external 'libc.dylib' name 'mprotect';
{$else} cdecl external 'libc.so' name 'mprotect'; {$endif}
{$endif BSD}

function SynMProtect(addr:pointer;size:size_t;prot:integer):longint;
begin
result:=-1;
{$ifdef UNIX}
{$ifdef BSD}
result:=mprotect(addr,size,prot);
{$else}
if (Do_SysCall(syscall_nr_mprotect,PtrUInt(addr),size,prot)>=0) then result:=0;
//More modern FPC:
//result:=Fpmprotect(addr,size,prot);
{$endif}
{$endif UNIX}
{$ifdef KYLIX3}
result:=mprotect(addr,size,prot);
{$endif UNIX}
end;
{$endif FPC}

procedure MoveSmall(Source, Dest: Pointer; Count: PtrUInt);
@@ -16863,16 +16904,18 @@ function TSynTempBuffer.InitZero(ZeroLen: PtrInt): pointer;
procedure TSynTempBuffer.Done;
begin
if (buf<>@tmp) and (buf<>nil) then
begin
FreeMem(buf);
buf:=nil;
end;
end;

procedure TSynTempBuffer.Done(EndBuf: pointer; var Dest: RawUTF8);
begin
if EndBuf=nil then
Dest := '' else
FastSetString(Dest,buf,PAnsiChar(EndBuf)-PAnsiChar(buf));
if (buf<>@tmp) and (buf<>nil) then
FreeMem(buf);
Done;
end;


@@ -35102,7 +35145,7 @@ function StrCompSSE42(Str1, Str2: pointer): PtrInt;

function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
{$ifdef FPC}nostackframe; assembler; asm {$else}
asm .noframe // ecx=crc, rdx=buf, r8=len (Linux: edi,rsi,rdx)
asm .noframe // ecx=crc, rdx=buf, r8=len (Linux: edi,rsi,edx)
{$endif FPC}
mov eax, crc
not eax
@@ -39811,16 +39854,6 @@ function GetSystemPath(kind: TSystemPath): TFileName;
end;
{$endif MSWINDOWS}

{$ifdef BSD}
function mprotect(Addr: Pointer; Len: size_t; Prot: Integer): Integer;
{$ifdef Darwin} cdecl external 'libc.dylib' name 'mprotect';
{$else} cdecl external 'libc.so' name 'mprotect'; {$endif}
{$define USEMPROTECT}
{$endif BSD}
{$ifdef KYLIX3}
{$define USEMPROTECT}
{$endif KYLIX3}

procedure PatchCode(Old,New: pointer; Size: integer; Backup: pointer;
LeaveUnprotected: boolean);
{$ifdef MSWINDOWS}
@@ -39842,24 +39875,35 @@ procedure PatchCode(Old,New: pointer; Size: integer; Backup: pointer;
end;
end;
{$else}
var PageSize, AlignedAddr: PtrUInt;
var
PageSize: PtrUInt;
AlignedAddr: pointer;
i: integer;
ProtectedResult:boolean;
ProtectedMemory:boolean;
begin
if Backup<>nil then
for i := 0 to Size-1 do // do not use Move() here
PByteArray(Backup)^[i] := PByteArray(Old)^[i];
PageSize := SystemInfo.dwPageSize;
AlignedAddr := PtrUInt(Old) and not (PageSize-1);
while PtrUInt(Old)+PtrUInt(Size)>=AlignedAddr+PageSize do
AlignedAddr := Pointer((PtrUInt(Old) DIV SystemInfo.dwPageSize) * SystemInfo.dwPageSize);
while PtrUInt(Old)+PtrUInt(Size)>=PtrUInt(AlignedAddr)+PageSize do
Inc(PageSize,SystemInfo.dwPageSize);
{$ifdef USEMPROTECT}
if mprotect(Pointer(AlignedAddr),PageSize,PROT_READ or PROT_WRITE or PROT_EXEC)=0 then
{$else}
Do_SysCall(syscall_nr_mprotect,PtrUInt(AlignedAddr),PageSize,PROT_READ or PROT_WRITE or PROT_EXEC);
{$endif USEMPROTECT}

ProtectedResult:=(SynMProtect(AlignedAddr,PageSize,PROT_READ or PROT_WRITE or PROT_EXEC) = 0);
ProtectedMemory:=False;
if (NOT ProtectedResult) then begin
ProtectedMemory:=True;
ProtectedResult:=(SynMProtect(AlignedAddr,PageSize,PROT_READ or PROT_WRITE) = 0);
end;

if ProtectedResult then
try
for i := 0 to Size-1 do // do not use Move() here
PByteArray(Old)^[i] := PByteArray(New)^[i];
if (NOT LeaveUnprotected) then
if (ProtectedMemory) then
SynMProtect(AlignedAddr,PageSize,PROT_READ or PROT_EXEC);
except
end;
end;
@@ -44343,7 +44387,7 @@ procedure ClearVariantForString(var Value: variant); {$ifdef HASINLINE} inline;
Finalize(RawByteString(TVarData(Value).VAny))
else
begin
if v and VTYPE_STATIC <> 0 then
{$ifndef FPC}if v and VTYPE_STATIC <> 0 then{$endif}
{$ifdef NOVARCOPYPROC}VarClear(Value){$else}VarClearProc(TVarData(Value)){$endif};
TVarData(Value).VType := varString;
TVarData(Value).VAny := nil; // to avoid GPF when assigned to a RawByteString
@@ -44956,8 +45000,10 @@ procedure TSynInvokeableVariantType.Lookup(var Dest: TVarData; const Instance: T
v := PVarData(v.VPointer)^;
until false;
repeat
{$ifndef FPC}
if vt and VTYPE_STATIC=0 then
exit; // we need a complex type to lookup
{$endif}
GetNextItemShortString(FullName,itemName,'.');
if itemName[0] in [#0,#255] then
exit;
@@ -48421,6 +48467,10 @@ function SortDynArrayVariantComp(const A,B: TVarData; caseInsensitive: boolean):
result := AnsiICompW(A.VAny,B.VAny) else
result := StrCompW(A.VAny,B.VAny);
else
(*
Alf:
Is this correct for FPC
*)
if AT and VTYPE_STATIC=0 then
result := ICMP[VarCompareValue(variant(A),variant(B))] else
result := CMP[caseInsensitive](variant(A),variant(B));
@@ -55098,7 +55148,10 @@ destructor TTextWriter.Destroy;
if twoStreamIsOwned in fCustomOptions then
fStream.Free;
if not (twoBufferIsExternal in fCustomOptions) then
begin
FreeMem(fTempBuf);
fTempBuf:=nil;
end;
fInternalJSONWriter.Free;
inherited;
end;
@@ -59686,12 +59739,17 @@ procedure TMemoryMap.UnMap;
fMap := 0;
end;
{$else}
if (fBuf<>nil) and (fBufSize>0) then
(*
Alf:
A map is only created when a file is mapped.
On BSD systems, you cannot unmap a memory area that has not been mapped before.
*)
if (fBuf<>nil) and (fBufSize>0) and (fFile<>0) then
{$ifdef KYLIX3}munmap{$else}fpmunmap{$endif}(fBuf,fBufSize);
{$endif}
fBuf := nil;
fBufSize := 0;
if fFile<>0 then begin
if (fFile<>0) then begin
if fFileLocal then
FileClose(fFile);
fFile := 0;
@@ -60850,6 +60908,7 @@ constructor TMemoryMapText.Create(const aFileName: TFileName);
destructor TMemoryMapText.Destroy;
begin
Freemem(fLines);
fLines:=nil;
fMap.UnMap;
inherited;
end;
@@ -61864,6 +61923,19 @@ procedure InitFunctionsRedirection;
GetBitsCountPtrInt := @GetBitsCountSSE42;
{$endif CPUINTEL}
{$endif ABSOLUTEPASCAL}

{$ifdef FPC}
{$ifdef ABSOLUTEPASCAL}
if Addr(MoveFast)=nil then MoveFast := @System.Move;
if Addr(FillCharFast)=nil then FillCharFast := @System.FillChar; // fallback to FPC cross-platform RTL
{$else}
{$ifndef CPUX64}
if Addr(MoveFast)=nil then MoveFast := @System.Move;
if Addr(FillCharFast)=nil then FillCharFast := @System.FillChar; // fallback to FPC cross-platform RTL
{$endif}
{$endif}
{$endif FPC}

InterningHasher := DefaultHasher;
end;

0 comments on commit 2958b7f

Please sign in to comment.