Skip to content

/ mORMot

Permalink
Browse files

Patchset BSD and more.

  • Loading branch information
@LongDirtyAnimAlf
LongDirtyAnimAlf committed Mar 17, 2020
1 parent 421f551 commit 2958b7fc64dd6d6aae6a6436b324cbed4cadb9b1
Unified Split
Showing with 503 additions and 131 deletions.
  1. +44 −5 SQLite3/mORMot.pas
  2. +99 −27 SynCommons.pas
  3. +33 −9 SynCrtSock.pas
  4. +5 −1 SynCrypto.pas
  5. +32 −8 SynFPCLinux.pas
  6. +34 −10 SynFPCSock.pas
  7. +154 −0 SynFPCSockLIBC.inc
  8. +3 −3 SynSM.pas
  9. +1 −1 SynSMAPI.pas
  10. +2 −0 SynSQLite3.pas
  11. +58 −43 SynSQLite3Static.pas
  12. +23 −16 SynSelfTests.pas
  13. +15 −8 Synopse.inc
49 SQLite3/mORMot.pas
View file
fpmunmap(result,STUB_SIZE);
end;
end;
result := nil; // error
result := MAP_FAILED; // error
end;
{$else} // other platforms (Intel+Arm64) use absolute call
begin

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

constructor TFakeStubBuffer.Create;
begin
{$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;
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
{$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}
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;
126 SynCommons.pas
View file
@@ -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}
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

{$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
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);
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;



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
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}
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;
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
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;
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));
if twoStreamIsOwned in fCustomOptions then
fStream.Free;
if not (twoBufferIsExternal in fCustomOptions) then
begin
FreeMem(fTempBuf);
fTempBuf:=nil;
end;
fInternalJSONWriter.Free;
inherited;
end;
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;
destructor TMemoryMapText.Destroy;
begin
Freemem(fLines);
fLines:=nil;
fMap.UnMap;
inherited;
end;
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.
You can’t perform that action at this time.