Skip to content

Commit d271451

Browse files
pyscripterpyscripter
committed
Merged MethodCallBack.pas and some changes to PythonEngine.pas from downstream.
Introduced function GlobalDelphiWrapper and used it in WrapVclThemes.pas
1 parent cdba8ee commit d271451

File tree

5 files changed

+262
-42
lines changed

5 files changed

+262
-42
lines changed

‎Source/Definition.Inc

-2
Original file line numberDiff line numberDiff line change
@@ -227,10 +227,8 @@
227227
{$LEGACYIFEND ON}
228228
{$ENDIF DELPHIXE4_OR_HIGHER}
229229

230-
231230
{$IFDEF DELPHIXE2_OR_HIGHER}
232231
{$IFDEF MACOS}
233232
{$DEFINE DARWIN}
234233
{$ENDIF MACOS}
235234
{$ENDIF DELPHIXE2_OR_HIGHER}
236-

‎Source/MethodCallBack.pas

+197-30
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@
1717
(* Morgan Martinet (p4d@mmm-experts.com) *)
1818
(* Samuel Iseli (iseli@vertec.ch) *)
1919
(* Andrey Gruzdev (andrey.gruzdev@gmail.com) *)
20+
(* Lucas Belo (lucas.belo@live.com) *)
2021
(**************************************************************************)
2122
(* This source code is distributed with no WARRANTY, for no reason or use.*)
2223
(* Everyone is allowed to use and change this code free, as long as this *)
@@ -32,7 +33,7 @@ interface
3233
uses SysUtils;
3334

3435
type
35-
TCallType = (ctSTDCALL, ctCDECL);
36+
TCallType = (ctSTDCALL, ctCDECL, ctARMSTD);
3637
TCallBack = procedure of object;
3738

3839
function GetCallBack( self: TObject; method: Pointer;
@@ -127,6 +128,9 @@ implementation
127128
PtrCalcType = NativeInt;
128129
{$ENDIF}
129130

131+
EMProtectError = class(Exception)
132+
end;
133+
130134
{$IFNDEF MSWINDOWS}
131135
{$IFDEF FPC}
132136
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);
151155
var
152156
page: PCodeMemPage;
153157
block: PCodeMemBlock;
158+
{$IFNDEF MSWINDOWS}
159+
flags: integer;
160+
{$ENDIF}
154161
begin
155162
//---allocates Block from executable memory
156163
// executable memory is requested in pages via VirtualAlloc
@@ -174,13 +181,40 @@ procedure GetCodeMem(var ptr: PByte; size: integer);
174181
ptr := nil;
175182
exit;
176183
end;
177-
mprotect(page, PageSize, PROT_READ or PROT_WRITE or PROT_EXEC);
178-
{$ENDIF}
184+
{
185+
macOS for M1 has a bug (Apple Feedback FB8994773) in which mprotect
186+
rejects a permission change from NONE -> RWX, resulting a "Permission
187+
Denied" error.
188+
Solution: give RW permission, make memory changes, then change RW to X
189+
}
190+
{$IF DEFINED(OSX) AND DEFINED(CPUARM64)}
191+
flags := PROT_READ or PROT_WRITE;
192+
{$ELSE}
193+
flags := PROT_READ or PROT_WRITE or PROT_EXEC;
194+
{$IFEND}
195+
if mprotect(page, PageSize, flags) <> 0 then
196+
raise EMProtectError.CreateFmt('MProtect error: %s', [
197+
SysErrorMessage(GetLastError())]);
198+
{$ENDIF}
179199
page^.next:=CodeMemPages;
180200
CodeMemPages:=page;
181201
// init pointer to end of page
182202
page^.CodeBlocks:=Pointer(PtrCalcType(page) + PageSize);
203+
{$IF DEFINED(OSX) AND DEFINED(CPUARM64)}
204+
end else begin
205+
{
206+
macOS for M1 has a bug (Apple Feedback FB8994773) in which mprotect
207+
rejects a permission change from NONE -> RWX.
208+
Solution: give RW permission, make memory changes, then change RW to X
209+
}
210+
//RW permission to the entire page for new changes...
211+
if mprotect(page, PageSize, PROT_READ or PROT_WRITE) <> 0 then
212+
raise EMProtectError.CreateFmt('MProtect error: %s', [
213+
SysErrorMessage(GetLastError())]);
183214
end;
215+
{$ELSE}
216+
end;
217+
{$IFEND}
184218

185219
//---blocks are assigned starting from the end of the page
186220
block:=Pointer(PtrCalcType(page^.codeBlocks) - (size + sizeof(PCodeMemBlock)));
@@ -258,6 +292,34 @@ function CodeMemPageCount: integer;
258292
end;
259293
end;
260294

295+
procedure DeleteCallBack( Proc: Pointer);
296+
begin
297+
FreeCodeMem(Proc);
298+
end;
299+
300+
procedure FreeCallBacks;
301+
var
302+
page, nextpage: PCodeMemPage;
303+
begin
304+
// free each allocated page
305+
page := CodeMemPages;
306+
while page <> nil do
307+
begin
308+
nextpage := page^.Next;
309+
310+
// free the memory
311+
{$IFDEF MSWINDOWS}
312+
VirtualFree(page, 0, MEM_RELEASE);
313+
{$ELSE}
314+
//FreeMem(page);
315+
munmap(page,PageSize);
316+
{$ENDIF}
317+
318+
page := nextpage;
319+
end;
320+
CodeMemPages := nil;
321+
end;
322+
261323
function GetOfObjectCallBack( CallBack: TCallBack;
262324
argnum: Integer; calltype: TCallType): Pointer;
263325
begin
@@ -266,15 +328,17 @@ function GetOfObjectCallBack( CallBack: TCallBack;
266328
argnum, calltype);
267329
end;
268330

269-
{$IFDEF CPUX64}
270-
{$DEFINE 64_BIT_CALLBACK}
271-
{$ELSE}
272-
{$IFDEF MACOS}
273-
{$DEFINE ALIGNED_32_BIT_CALLBACK}
274-
{$ELSE}
275-
{$DEFINE SIMPLE_32_BIT_CALLBACK}
276-
{$ENDIF MACOS}
277-
{$ENDIF CPUX64}
331+
{$IFNDEF CPUARM}
332+
{$IFDEF CPUX64}
333+
{$DEFINE 64_BIT_CALLBACK}
334+
{$ELSE}
335+
{$IFDEF MACOS}
336+
{$DEFINE ALIGNED_32_BIT_CALLBACK}
337+
{$ELSE}
338+
{$DEFINE SIMPLE_32_BIT_CALLBACK}
339+
{$ENDIF MACOS}
340+
{$ENDIF CPUX64}
341+
{$ENDIF CPUARM}
278342

279343
{$IFDEF SIMPLE_32_BIT_CALLBACK}
280344
// win32 inplementation
@@ -565,35 +629,138 @@ function GetCallBack( self: TObject; method: Pointer;
565629
end;
566630
{$ENDIF}
567631

568-
procedure DeleteCallBack( Proc: Pointer);
632+
{$IFDEF CPUARM32}
633+
function GetCallBack(Self: TObject; Method: Pointer; ArgNum: Integer;
634+
CallType: TCallType): Pointer;
635+
const
636+
S1: array[0..123] of byte = (
637+
//big-endian
638+
//offset <start>:
639+
{+ 0:} $80, $40, $2d, $e9, // push {r7, lr}
640+
{+ 4:} $0d, $70, $a0, $e1, // mov r7, sp
641+
{+ 8:} $1e, $04, $2d, $e9, // push {r1, r2, r3, r4, sl}
642+
{+ c:} $5c, $40, $9f, $e5, // ldr r4, [pc, #92] ; 70 <loop+0x1c>
643+
{+ 10:} $00, $00, $54, $e3, // cmp r4, #0
644+
{+ 14:} $04, $d0, $4d, $c0, // subgt sp, sp, r4
645+
{+ 18:} $04, $50, $a0, $c1, // movgt r5, r4
646+
{+ 1c:} $04, $50, $85, $c2, // addgt r5, r5, #4
647+
{+ 20:} $04, $60, $a0, $c1, // movgt r6, r4
648+
{+ 24:} $04, $60, $46, $c2, // subgt r6, r6, #4
649+
{+ 28:} $09, $00, $00, $cb, // blgt 54 <loop>
650+
{+ 2c:} $0f, $00, $2d, $e9, // push {r0, r1, r2, r3}
651+
{+ 30:} $3c, $00, $9f, $e5, // ldr r0, [pc, #60] ; 74 <loop+0x20>
652+
{+ 34:} $0e, $00, $bd, $e8, // pop {r1, r2, r3}
653+
{+ 38:} $38, $a0, $9f, $e5, // ldr sl, [pc, #56] ; 78 <loop+0x24>
654+
{+ 3c:} $3a, $ff, $2f, $e1, // blx sl
655+
{+ 40:} $00, $00, $54, $e3, // cmp r4, #0
656+
{+ 44:} $04, $d0, $8d, $c0, // addgt sp, sp, r4
657+
{+ 48:} $04, $40, $9d, $e4, // pop {r4} ; (ldr r4, [sp], #4)
658+
{+ 4c:} $1e, $04, $bd, $e8, // pop {r1, r2, r3, r4, sl}
659+
{+ 50:} $80, $80, $bd, $e8, // pop {r7, pc}
660+
//offset + 00000054 <loop>:
661+
{+ 54:} $05, $a0, $97, $e7, // ldr sl, [r7, r5]
662+
{+ 58:} $06, $a0, $8d, $e7, // str sl, [sp, r6]
663+
{+ 5c:} $04, $50, $45, $e2, // sub r5, r5, #4
664+
{+ 60:} $04, $60, $46, $e2, // sub r6, r6, #4
665+
{+ 64:} $00, $00, $56, $e3, // cmp r6, #0
666+
{+ 68:} $f9, $ff, $ff, $aa, // bge 54 <loop>
667+
{+ 6c:} $1e, $ff, $2f, $e1, // bx lr
668+
//offset + 00000070 <literal pool>
669+
{+ 70:} $00, $00, $00, $00, // stack space for stack parameters
670+
{+ 74:} $00, $00, $00, $00, // Self
671+
{+ 78:} $00, $00, $00, $00 // Method
672+
);
673+
const
674+
ARM_INSTRUCTION_SIZE = 4;
675+
ARM_ARGUMENT_COUNT_IN_REGISTERS = 4;
676+
var
677+
P, Q: PByte;
678+
LLiteralPool: TArray<pointer>;
679+
I: Integer;
569680
begin
570-
FreeCodeMem(Proc);
681+
GetCodeMem(Q, SizeOf(S1));
682+
P := Q;
683+
Move(S1, P^, SizeOf(S1));
684+
685+
LLiteralPool := TArray<pointer>.Create(
686+
Pointer((ArgNum - ARM_ARGUMENT_COUNT_IN_REGISTERS) * ARM_INSTRUCTION_SIZE),
687+
Self,
688+
Method);
689+
690+
Inc(P, Length(S1) - (Length(LLiteralPool) * SizeOf(pointer)));
691+
for I := Low(LLiteralPool) to High(LLiteralPool) do begin
692+
Move(LLiteralPool[I], P^, SizeOf(pointer));
693+
Inc(P, SizeOf(pointer));
694+
end;
695+
696+
Result := Pointer(Q); //set arm mode
571697
end;
698+
{$ENDIF CPUARM32}
572699

573-
procedure FreeCallBacks;
700+
{$IFDEF CPUARM64}
701+
function GetCallBack(Self: TObject; Method: Pointer; ArgNum: Integer;
702+
CallType: TCallType): Pointer;
703+
const
704+
S1: array[0..79] of byte = (
705+
//big-endian
706+
//offset <_start>:
707+
$fd, $7b, $bf, $a9, // stp x29, x30, [sp, #-16]!
708+
$fd, $03, $00, $91, // mov x29, sp
709+
$e0, $07, $bf, $a9, // stp x0, x1, [sp, #-16]!
710+
$e2, $0f, $bf, $a9, // stp x2, x3, [sp, #-16]!
711+
$e4, $17, $bf, $a9, // stp x4, x5, [sp, #-16]!
712+
$e6, $1f, $bf, $a9, // stp x6, x7, [sp, #-16]!
713+
$0a, $00, $00, $10, // adr x10, #0 <_start+0x18>
714+
$40, $15, $40, $f9, // ldr x0, [x10, #40]
715+
$49, $19, $40, $f9, // ldr x9, [x10, #48]
716+
$e7, $2f, $c1, $a8, // ldp x7, x11, [sp], #16
717+
$e5, $1b, $c1, $a8, // ldp x5, x6, [sp], #16
718+
$e3, $13, $c1, $a8, // ldp x3, x4, [sp], #16
719+
$e1, $0b, $c1, $a8, // ldp x1, x2, [sp], #16
720+
$20, $01, $3f, $d6, // blr x9
721+
$fd, $7b, $c1, $a8, // ldp x29, x30, [sp], #16
722+
$c0, $03, $5f, $d6, // ret
723+
$00, $00, $00, $00, // .word 0x00000000 //Self
724+
$00, $00, $00, $00, // .word 0x00000000
725+
$00, $00, $00, $00, // .word 0x00000000 //Method
726+
$00, $00, $00, $00 // .word 0x00000000
727+
);
574728
var
575-
page, nextpage: PCodeMemPage;
729+
P, Q: PByte;
730+
LLiteralPool: TArray<pointer>;
731+
I: Integer;
576732
begin
577-
// free each allocated page
578-
page := CodeMemPages;
579-
while page <> nil do
580-
begin
581-
nextpage := page^.Next;
733+
GetCodeMem(Q, SizeOf(S1));
734+
P := Q;
735+
Move(S1, P^, SizeOf(S1));
582736

583-
// free the memory
584-
{$IFDEF MSWINDOWS}
585-
VirtualFree(page, 0, MEM_RELEASE);
586-
{$ELSE}
587-
//FreeMem(page);
588-
munmap(page,PageSize);
589-
{$ENDIF}
737+
LLiteralPool := TArray<pointer>.Create(Self, Method);
590738

591-
page := nextpage;
739+
Inc(P, Length(S1) - (Length(LLiteralPool) * SizeOf(pointer)));
740+
for I := Low(LLiteralPool) to High(LLiteralPool) do begin
741+
Move(LLiteralPool[I], P^, SizeOf(pointer));
742+
Inc(P, SizeOf(pointer));
592743
end;
593-
CodeMemPages := nil;
744+
745+
{$IF DEFINED(OSX) AND DEFINED(CPUARM64)}
746+
{
747+
macOS for M1 has a bug (Apple Feedback FB8994773) in which mprotect
748+
rejects a permission change from NONE -> RWX.
749+
Solution: give RW permission, make memory changes, then change RW to X
750+
}
751+
//X permission to the entire page for executions...
752+
if mprotect(CodeMemPages, PageSize, PROT_EXEC) <> 0 then
753+
raise EMProtectError.CreateFmt('MProtect error: %s', [
754+
SysErrorMessage(GetLastError())]);
755+
{$IFEND}
756+
757+
Result := Pointer(Q); //set arm mode
594758
end;
759+
{$ENDIF CPUARM64}
595760

596761
initialization
762+
597763
finalization
598764
FreeCallBacks;
765+
599766
end.

0 commit comments

Comments
 (0)