Patchset BSD and more.

SQLite3/mORMot.pas

@@ -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;

SynCommons.pas

@@ -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;