Merged MethodCallBack.pas and some changes to PythonEngine.pas from downstream.

Introduced function GlobalDelphiWrapper and used it in WrapVclThemes.pas

Author: pyscripter

Source/Definition.Inc

@@ -227,10 +227,8 @@
   {$LEGACYIFEND ON}
 {$ENDIF DELPHIXE4_OR_HIGHER}
 
-
 {$IFDEF DELPHIXE2_OR_HIGHER}
   {$IFDEF MACOS}
     {$DEFINE DARWIN}
   {$ENDIF MACOS}
 {$ENDIF DELPHIXE2_OR_HIGHER}
-

Source/MethodCallBack.pas

@@ -17,6 +17,7 @@
 (*      Morgan Martinet     ([email protected])                         *)
 (*      Samuel Iseli        ([email protected])                             *)
 (*      Andrey Gruzdev      ([email protected])                    *)
+(*      Lucas Belo          ([email protected])                         *)
 (**************************************************************************)
 (* This source code is distributed with no WARRANTY, for no reason or use.*)
 (* Everyone is allowed to use and change this code free, as long as this  *)
@@ -32,7 +33,7 @@ interface
 uses SysUtils;
 
 type
-  TCallType = (ctSTDCALL, ctCDECL);
+  TCallType = (ctSTDCALL, ctCDECL, ctARMSTD);
   TCallBack = procedure of object;
 
   function  GetCallBack( self: TObject; method: Pointer;
@@ -127,6 +128,9 @@ implementation
   PtrCalcType = NativeInt;
 {$ENDIF}
 
+  EMProtectError = class(Exception)
+  end;
+
 {$IFNDEF MSWINDOWS}
 {$IFDEF FPC}
 function mmap(Addr: Pointer; Len: Integer; Prot: Integer; Flags: Integer; FileDes: Integer; Off: Integer): Pointer; cdecl;
@@ -151,6 +155,9 @@ procedure GetCodeMem(var ptr: PByte; size: integer);
 var
   page: PCodeMemPage;
   block: PCodeMemBlock;
+  {$IFNDEF MSWINDOWS}
+  flags: integer;
+  {$ENDIF}
 begin
   //---allocates Block from executable memory
   // executable memory is requested in pages via VirtualAlloc
@@ -174,13 +181,40 @@ procedure GetCodeMem(var ptr: PByte; size: integer);
       ptr := nil;
       exit;
     end;
-    mprotect(page, PageSize, PROT_READ or PROT_WRITE or PROT_EXEC);
-	{$ENDIF}
+    {
+        macOS for M1 has a bug (Apple Feedback FB8994773) in which mprotect
+        rejects a permission change from NONE -> RWX, resulting a "Permission
+        Denied" error.
+        Solution: give RW permission, make memory changes, then change RW to X
+    }
+    {$IF DEFINED(OSX) AND DEFINED(CPUARM64)}
+    flags := PROT_READ or PROT_WRITE;
+    {$ELSE}
+    flags := PROT_READ or PROT_WRITE or PROT_EXEC;
+    {$IFEND}
+    if mprotect(page, PageSize, flags) <> 0 then
+      raise EMProtectError.CreateFmt('MProtect error: %s', [
+        SysErrorMessage(GetLastError())]);
+  {$ENDIF}
     page^.next:=CodeMemPages;
     CodeMemPages:=page;
     // init pointer to end of page
     page^.CodeBlocks:=Pointer(PtrCalcType(page) + PageSize);
+  {$IF DEFINED(OSX) AND DEFINED(CPUARM64)}
+  end else begin
+    {
+      macOS for M1 has a bug (Apple Feedback FB8994773) in which mprotect
+      rejects a permission change from NONE -> RWX.
+      Solution: give RW permission, make memory changes, then change RW to X
+    }
+    //RW permission to the entire page for new changes...
+    if mprotect(page, PageSize, PROT_READ or PROT_WRITE) <> 0 then
+      raise EMProtectError.CreateFmt('MProtect error: %s', [
+        SysErrorMessage(GetLastError())]);
   end;
+  {$ELSE}
+  end;
+  {$IFEND}
 
   //---blocks are assigned starting from the end of the page
   block:=Pointer(PtrCalcType(page^.codeBlocks) - (size + sizeof(PCodeMemBlock)));
@@ -258,6 +292,34 @@ function CodeMemPageCount: integer;
   end;
 end;
 
+procedure DeleteCallBack( Proc: Pointer);
+begin
+  FreeCodeMem(Proc);
+end;
+
+procedure FreeCallBacks;
+var
+  page, nextpage: PCodeMemPage;
+begin
+  // free each allocated page
+  page := CodeMemPages;
+  while page <> nil do
+  begin
+    nextpage := page^.Next;
+
+    // free the memory
+  {$IFDEF MSWINDOWS}
+    VirtualFree(page, 0, MEM_RELEASE);
+  {$ELSE}
+	//FreeMem(page);
+    munmap(page,PageSize);
+  {$ENDIF}
+
+    page := nextpage;
+  end;
+  CodeMemPages := nil;
+end;
+
 function  GetOfObjectCallBack( CallBack: TCallBack;
                                argnum: Integer; calltype: TCallType): Pointer;
 begin
@@ -266,15 +328,17 @@ function  GetOfObjectCallBack( CallBack: TCallBack;
                          argnum, calltype);
 end;
 
-{$IFDEF CPUX64}
-{$DEFINE 64_BIT_CALLBACK}
-{$ELSE}
-{$IFDEF MACOS}
-{$DEFINE ALIGNED_32_BIT_CALLBACK}
-{$ELSE}
-{$DEFINE SIMPLE_32_BIT_CALLBACK}
-{$ENDIF MACOS}
-{$ENDIF CPUX64}
+{$IFNDEF CPUARM}
+  {$IFDEF CPUX64}
+    {$DEFINE 64_BIT_CALLBACK}
+  {$ELSE}
+    {$IFDEF MACOS}
+      {$DEFINE ALIGNED_32_BIT_CALLBACK}
+    {$ELSE}
+      {$DEFINE SIMPLE_32_BIT_CALLBACK}
+    {$ENDIF MACOS}
+  {$ENDIF CPUX64}
+{$ENDIF CPUARM}
 
 {$IFDEF SIMPLE_32_BIT_CALLBACK}
 // win32 inplementation
@@ -565,35 +629,138 @@ function  GetCallBack( self: TObject; method: Pointer;
 end;
 {$ENDIF}
 
-procedure DeleteCallBack( Proc: Pointer);
+{$IFDEF CPUARM32}
+function  GetCallBack(Self: TObject; Method: Pointer; ArgNum: Integer;
+  CallType: TCallType): Pointer;
+const
+  S1: array[0..123] of byte = (
+//big-endian
+//offset     <start>:
+ {+  0:}	 $80, $40, $2d, $e9, // push	{r7, lr}
+ {+  4:}	 $0d, $70, $a0, $e1, // mov	r7, sp
+ {+  8:}	 $1e, $04, $2d, $e9, // push	{r1, r2, r3, r4, sl}
+ {+  c:}	 $5c, $40, $9f, $e5, // ldr	r4, [pc, #92]	; 70 <loop+0x1c>
+ {+ 10:}	 $00, $00, $54, $e3, // cmp	r4, #0
+ {+ 14:}	 $04, $d0, $4d, $c0, // subgt	sp, sp, r4
+ {+ 18:}	 $04, $50, $a0, $c1, // movgt	r5, r4
+ {+ 1c:}	 $04, $50, $85, $c2, // addgt	r5, r5, #4
+ {+ 20:}	 $04, $60, $a0, $c1, // movgt	r6, r4
+ {+ 24:}	 $04, $60, $46, $c2, // subgt	r6, r6, #4
+ {+ 28:}	 $09, $00, $00, $cb, // blgt	54 <loop>
+ {+ 2c:}	 $0f, $00, $2d, $e9, // push	{r0, r1, r2, r3}
+ {+ 30:}	 $3c, $00, $9f, $e5, // ldr	r0, [pc, #60]	; 74 <loop+0x20>
+ {+ 34:}	 $0e, $00, $bd, $e8, // pop	{r1, r2, r3}
+ {+ 38:}	 $38, $a0, $9f, $e5, // ldr	sl, [pc, #56]	; 78 <loop+0x24>
+ {+ 3c:}	 $3a, $ff, $2f, $e1, // blx	sl
+ {+ 40:}	 $00, $00, $54, $e3, // cmp	r4, #0
+ {+ 44:}	 $04, $d0, $8d, $c0, // addgt	sp, sp, r4
+ {+ 48:}	 $04, $40, $9d, $e4, // pop	{r4}		; (ldr r4, [sp], #4)
+ {+ 4c:}	 $1e, $04, $bd, $e8, // pop	{r1, r2, r3, r4, sl}
+ {+ 50:}	 $80, $80, $bd, $e8, // pop	{r7, pc}
+//offset + 00000054   <loop>:
+ {+ 54:}	 $05, $a0, $97, $e7, // ldr	sl, [r7, r5]
+ {+ 58:}	 $06, $a0, $8d, $e7, // str	sl, [sp, r6]
+ {+ 5c:}	 $04, $50, $45, $e2, // sub	r5, r5, #4
+ {+ 60:}	 $04, $60, $46, $e2, // sub	r6, r6, #4
+ {+ 64:}	 $00, $00, $56, $e3, // cmp	r6, #0
+ {+ 68:}	 $f9, $ff, $ff, $aa, // bge	54 <loop>
+ {+ 6c:}	 $1e, $ff, $2f, $e1, // bx	lr
+//offset + 00000070   <literal pool>
+ {+ 70:}	 $00, $00, $00, $00, // stack space for stack parameters
+ {+ 74:}	 $00, $00, $00, $00, // Self
+ {+ 78:}	 $00, $00, $00, $00  // Method
+);
+const
+  ARM_INSTRUCTION_SIZE = 4;
+  ARM_ARGUMENT_COUNT_IN_REGISTERS = 4;
+var
+  P, Q: PByte;
+  LLiteralPool: TArray<pointer>;
+  I: Integer;
 begin
-  FreeCodeMem(Proc);
+  GetCodeMem(Q, SizeOf(S1));
+  P := Q;
+  Move(S1, P^, SizeOf(S1));
+
+  LLiteralPool := TArray<pointer>.Create(
+    Pointer((ArgNum - ARM_ARGUMENT_COUNT_IN_REGISTERS) * ARM_INSTRUCTION_SIZE),
+    Self,
+    Method);
+
+  Inc(P, Length(S1) - (Length(LLiteralPool) * SizeOf(pointer)));
+  for I := Low(LLiteralPool) to High(LLiteralPool) do begin
+    Move(LLiteralPool[I], P^, SizeOf(pointer));
+    Inc(P, SizeOf(pointer));
+  end;
+
+  Result := Pointer(Q); //set arm mode
 end;
+{$ENDIF CPUARM32}
 
-procedure FreeCallBacks;
+{$IFDEF CPUARM64}
+function  GetCallBack(Self: TObject; Method: Pointer; ArgNum: Integer;
+  CallType: TCallType): Pointer;
+const
+  S1: array[0..79] of byte = (
+//big-endian
+//offset  <_start>:
+  $fd, $7b, $bf, $a9,  //	stp	x29, x30, [sp, #-16]!
+  $fd, $03, $00, $91,  //	mov	x29, sp
+  $e0, $07, $bf, $a9,  //	stp	x0, x1, [sp, #-16]!
+  $e2, $0f, $bf, $a9,  //	stp	x2, x3, [sp, #-16]!
+  $e4, $17, $bf, $a9,  //	stp	x4, x5, [sp, #-16]!
+  $e6, $1f, $bf, $a9,  //	stp	x6, x7, [sp, #-16]!
+  $0a, $00, $00, $10,  //	adr	x10, #0 <_start+0x18>
+  $40, $15, $40, $f9,  //	ldr	x0, [x10, #40]
+  $49, $19, $40, $f9,  //	ldr	x9, [x10, #48]
+  $e7, $2f, $c1, $a8,  //	ldp	x7, x11, [sp], #16
+  $e5, $1b, $c1, $a8,  //	ldp	x5, x6, [sp], #16
+  $e3, $13, $c1, $a8,  //	ldp	x3, x4, [sp], #16
+  $e1, $0b, $c1, $a8,  //	ldp	x1, x2, [sp], #16
+  $20, $01, $3f, $d6,  //	blr	x9
+  $fd, $7b, $c1, $a8,  //	ldp	x29, x30, [sp], #16
+  $c0, $03, $5f, $d6,  //	ret
+  $00, $00, $00, $00,  //	.word	0x00000000 //Self
+  $00, $00, $00, $00,  //	.word	0x00000000
+  $00, $00, $00, $00,  //	.word	0x00000000 //Method
+  $00, $00, $00, $00   //	.word	0x00000000
+);
 var
-  page, nextpage: PCodeMemPage;
+  P, Q: PByte;
+  LLiteralPool: TArray<pointer>;
+  I: Integer;
 begin
-  // free each allocated page
-  page := CodeMemPages;
-  while page <> nil do
-  begin
-    nextpage := page^.Next;
+  GetCodeMem(Q, SizeOf(S1));
+  P := Q;
+  Move(S1, P^, SizeOf(S1));
 
-    // free the memory
-  {$IFDEF MSWINDOWS}
-    VirtualFree(page, 0, MEM_RELEASE);
-  {$ELSE}
-	//FreeMem(page);
-    munmap(page,PageSize);
-  {$ENDIF}		  
+  LLiteralPool := TArray<pointer>.Create(Self, Method);
 
-    page := nextpage;
+  Inc(P, Length(S1) - (Length(LLiteralPool) * SizeOf(pointer)));
+  for I := Low(LLiteralPool) to High(LLiteralPool) do begin
+    Move(LLiteralPool[I], P^, SizeOf(pointer));
+    Inc(P, SizeOf(pointer));
   end;
-  CodeMemPages := nil;
+
+  {$IF DEFINED(OSX) AND DEFINED(CPUARM64)}
+    {
+      macOS for M1 has a bug (Apple Feedback FB8994773) in which mprotect
+      rejects a permission change from NONE -> RWX.
+      Solution: give RW permission, make memory changes, then change RW to X
+    }
+    //X permission to the entire page for executions...
+    if mprotect(CodeMemPages, PageSize, PROT_EXEC) <> 0 then
+      raise EMProtectError.CreateFmt('MProtect error: %s', [
+        SysErrorMessage(GetLastError())]);
+  {$IFEND}
+
+  Result := Pointer(Q); //set arm mode
 end;
+{$ENDIF CPUARM64}
 
 initialization
+
 finalization
   FreeCallBacks;
+
 end.