1 (**************************************************************************)
2 (* *)
3 (* Module: Unit 'MethodCallback' Copyright (c) 1998 *)
4 (* *)
5 (* Version: 0.0 Dr. Dietmar Budelsky *)
6 (* Sub-Version: 0.3 dbudelsky@web.de *)
7 (* Germany *)
8 (* *)
9 (**************************************************************************)
10 (* Functionality: Generates synthetic callback functions which calls *)
11 (* DELPHI Class Methods. A callback mechanism (DDE, PYTHON, TCL) can now *)
12 (* use DELPHI objects. *)
13 (* *)
14 (**************************************************************************)
15 (* Contributors: *)
16 (* Grzegorz Makarewicz (mak@mikroplan.com.pl) *)
17 (* Morgan Martinet (p4d@mmm-experts.com) *)
18 (* Samuel Iseli (iseli@vertec.ch) *)
19 (* Andrey Gruzdev (andrey.gruzdev@gmail.com) *)
20 (**************************************************************************)
21 (* This source code is distributed with no WARRANTY, for no reason or use.*)
22 (* Everyone is allowed to use and change this code free, as long as this *)
23 (* header and its copyright text is intact. *)
24 (* Dr. Dietmar Budelsky, 1998-01-07 *)
25 (**************************************************************************)
26
27 {$I Definition.Inc}
28
29 unit MethodCallBack;
30
31 interface
32 uses SysUtils;
33
34 type
35 TCallType = (ctSTDCALL, ctCDECL);
36 TCallBack = procedure of object;
37
GetCallBacknull38 function GetCallBack( self: TObject; method: Pointer;
39 argnum: Integer; calltype: tcalltype): Pointer;
40 // Call for example with
41 // CallBackProc := GetCallBack( self, @TSelfObject.Method, 2, ctSTDCALL);
42 //
43 // "self" is a valid TSelfObject,
44 // "Method" is a pointer to the class method, which should be triggered,
45 // when CallBackProc is called. It has to be declared according to the
46 // calltype!
47 // argnum is the number of callback parameters. There are the following
48 // exceptions: Double and Currency count for two. (sure)
49 // Float counts for two (not tested yet)
50 // Extended counts for three (not tested yet)
51 // Records count for SizeOf(record)/4 rounded up.
52 // calltype is the calling convention of the callback function.
53
GetOfObjectCallBacknull54 function GetOfObjectCallBack( CallBack: TCallBack;
55 argnum: Integer; calltype: TCallType): Pointer;
56 // More sophisticated interface for standardized callback mechanisms.
57 // Usage for example:
58 // type
59 // TMyCallBack = function(x: Integer):Integer of object; cdecl;
60 // TMyClass = Class
61 // CallBackProc: Pointer;
ynull62 // function y(x: Integer):Integer; cdecl;
63 // procedure Init;
64 // end;
65 // ...
66 // function SetCallBack(f: TMyCallBack): Pointer;
67 // begin
68 // result := GetOfObjectCallBack( TCallBack(f), 1, ctCDECL);
69 // end;
70 // procedure TMyClass.Init;
71 // begin
72 // CallBackProc := SetCallBack(y);
73 // end;
74
75 procedure DeleteCallBack( Proc: Pointer );
76 // frees the memory used for Proc. Call with
77 // DeleteCallBack( CallBackProc);
78
CodeMemPageCountnull79 function CodeMemPageCount: integer;
80 // returns the page count allocated for callbacks
81 // mainly for test purposes
82
83 procedure FreeCallBacks;
84 // frees all callbacks
85 // is called on finalize unit
86 // should only be called explicitely for testing
87
88 implementation
89
90 uses
91 {$IFDEF MSWINDOWS}
92 Windows,
93 {$ELSE WINDOWS}
94 {$IFDEF FPC}
95 {$ELSE}
96 Posix.SysMMan,
97 {$ENDIF}
98 {$ENDIF WINDOWS}
99 Classes;
100
101 type
102 PByte = ^Byte;
103
104 PCodeMemBlock = ^TCodeMemBlock;
105 TCodeMemBlock = packed record
106 Next: PCodeMemBlock;
107 // code length is variable
108 Code: array[0..1] of byte;
109 end;
110
111 PCodeMemPage = ^TCodeMemPage;
112 TCodeMemPage = packed record
113 Next: PCodeMemPage;
114 CodeBlocks: PCodeMemBlock;
115 end;
116
117 const
118 PageSize = 4096;
119
120 var
121 CodeMemPages: PCodeMemPage;
122
123 type
124 {$IFDEF FPC}
125 PtrCalcType = PtrUInt;
126 {$ELSE}
127 PtrCalcType = NativeInt;
128 {$ENDIF}
129
130 {$IFNDEF MSWINDOWS}
131 {$IFDEF FPC}
mmapnull132 function mmap(Addr: Pointer; Len: Integer; Prot: Integer; Flags: Integer; FileDes: Integer; Off: Integer): Pointer; cdecl;
133 external 'c' name 'mmap';
134
mprotectnull135 function mprotect(Addr: Pointer; Len: Integer; Prot: Integer): Integer; cdecl;
136 external 'c' name 'mprotect';
137
munmapnull138 function munmap(Addr: Pointer; Len: Integer): Integer; cdecl;
139 external 'c' name 'munmap';
140 const
141 PROT_NONE =0;
142 PROT_READ =1;
143 PROT_WRITE =2;
144 PROT_EXEC =4;
145 MAP_PRIVATE =2;
146 MAP_ANON=$1000;
147 {$ENDIF}
148 {$ENDIF}
149
150 procedure GetCodeMem(var ptr: PByte; size: integer);
151 var
152 page: PCodeMemPage;
153 block: PCodeMemBlock;
154 begin
155 //---allocates Block from executable memory
156 // executable memory is requested in pages via VirtualAlloc
157 // handed back in blocks of requested size
158
159 // determine if there is already a page assigned and
160 // that it has enough space requested block
161 page:=CodeMemPages;
162 if (page = nil) or (PtrCalcType(CodeMemPages^.CodeBlocks) - PtrCalcType(Pointer(CodeMemPages)) <= (size + 3*sizeof(PCodeMemBlock))) then
163 begin
164 // allocate new Page
165 {$IFDEF MSWINDOWS}
166 page:=VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
167 {$ELSE}
168 //page := GetMem(PageSize);
169 {$WARN SYMBOL_PLATFORM OFF}
170 page := mmap(Pointer($10000000), PageSize, PROT_NONE, MAP_PRIVATE or MAP_ANON, -1, 0);
171 {$WARN SYMBOL_PLATFORM ON}
172 if page=Pointer(-1) then //MMAP_FAILED result?
173 begin
174 ptr := nil;
175 exit;
176 end;
177 mprotect(page, PageSize, PROT_READ or PROT_WRITE or PROT_EXEC);
178 {$ENDIF}
179 page^.next:=CodeMemPages;
180 CodeMemPages:=page;
181 // init pointer to end of page
182 page^.CodeBlocks:=Pointer(PtrCalcType(page) + PageSize);
183 end;
184
185 //---blocks are assigned starting from the end of the page
186 block:=Pointer(PtrCalcType(page^.codeBlocks) - (size + sizeof(PCodeMemBlock)));
187 block^.Next:=page^.CodeBlocks;
188 page^.CodeBlocks:=block;
189
190 ptr:=@(block^.Code[0]);
191 end;
192
193 procedure FreeCodeMem(ptr: Pointer);
194 var
195 page, lastpage: PCodeMemPage;
196 block, lastblock: PCodeMemBlock;
197 begin
198 //---freeing code mem is not very efficient
199 // we need to search through all the assigned blocks
200 // A page is only released when all blocks in it have been freed
201 page:=CodeMemPages;
202 lastpage:=nil;
203
204 while page <> nil do
205 begin
206 lastblock:=nil;
207 block:=page^.CodeBlocks;
208 while PtrCalcType(block) < (PtrCalcType(page) + pagesize) do
209 begin
210 if @(block^.Code[0]) = ptr then
211 begin
212 // we found our block
213 // remove it
214 if lastblock <> nil then
215 lastblock^.Next:=block^.Next
216 else
217 page^.CodeBlocks:=block^.Next;
218
219 // return the page if it is empty
220 if PtrCalcType(page^.CodeBlocks) = PtrCalcType(page) + pagesize then
221 begin
222 if lastpage <> nil then
223 lastpage^.Next:=page^.Next
224 else
225 CodeMemPages:=page^.Next;
226
227 // free the memory
228 {$IFDEF MSWINDOWS}
229 VirtualFree(page, 0, MEM_RELEASE);
230 {$ELSE}
231 // FreeMem(page);
232 munmap(page,PageSize);
233 {$ENDIF}
234 end;
235
236 exit;
237 end;
238 lastblock:=block;
239 block:=block^.Next;
240 end;
241 lastpage:=page;
242 page:=page^.Next;
243 end;
244 end;
245
CodeMemPageCountnull246 function CodeMemPageCount: integer;
247 var
248 page: PCodeMemPage;
249 begin
250 //---counts the used codemem pages
251 result:=0;
252 page:=CodeMemPages;
253
254 while page <> nil do
255 begin
256 inc(result);
257 page:=page^.Next;
258 end;
259 end;
260
GetOfObjectCallBacknull261 function GetOfObjectCallBack( CallBack: TCallBack;
262 argnum: Integer; calltype: TCallType): Pointer;
263 begin
264 result := GetCallBack( TObject(TMethod(CallBack).Data),
265 TMethod(CallBack).Code,
266 argnum, calltype);
267 end;
268
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}
278
279 {$IFDEF SIMPLE_32_BIT_CALLBACK}
280 // win32 inplementation
GetCallBacknull281 function GetCallBack( self: TObject; method: Pointer;
282 argnum: Integer; calltype: tcalltype): Pointer;
283 const
284 // Short handling of stdcalls:
285 S1: array [0..14] of byte = (
286 $5A, //00 pop edx // pop return address
287 $B8,0,0,0,0, //01 mov eax, self
288 $50, //06 push eax
289 $52, //07 push edx // now push return address
290 // call the real callback
291 $B8,0,0,0,0, //08 mov eax, Method
292 $FF,$E0); //13 jmp eax
293
294 //Handling for ctCDECL:
295 C1: array [0..2] of byte = (
296 // begin of call
297 $55, //00 push ebp
298 $8B,$EC); //01 mov ebp, esp
299
300 // push arguments
301 // for i:= argnum-1 downto 0 do begin
302 C2: array [0..3] of byte = (
303 $8B,$45,0, //03+4*s mov eax,[ebp+8+4*i]
304 $50); //06+4*s push eax
305 // end;
306
307 // self parameter
308 C3: array [0..17] of byte = (
309 $B8,0,0,0,0, //03+4*s mov eax, self
310 $50, //08+4*s push eax
311 // call the real callback
312 $B8,0,0,0,0, //09+4*s mov eax,Method
313 $FF,$D0, //14+4*s call eax
314 // clear stack
315 $83,$C4,0, //16+4*s add esp, 4+bytes
316 $5D, //19+4*s pop ebp
317 $C3); //20+4*s ret
318 var
319 bytes: Word;
320 i: Integer;
321 P,Q: PByte;
322 begin
323 if calltype = ctSTDCALL then begin
324 GetCodeMem(Q,15);
325 P := Q;
326 move(S1,P^,SizeOf(S1));
327 Inc(P,2);
328 move(self,P^,SizeOf(self));
329 Inc(P,7);
330 move(method,P^,SizeOf(method));
331 {Inc(P,6); End of proc}
332 end else begin {ctCDECL}
333 bytes := argnum * 4;
334 GetCodeMem(Q,21+4*argnum);
335 P := Q;
336 move(C1,P^,SizeOf(C1));
337 Inc(P,SizeOf(C1));
338 for i:=argnum-1 downto 0 do begin
339 move(C2,P^,SizeOf(C2));
340 Inc(P,2);
341 P^:=8+4*i;
342 Inc(P,2);
343 end;
344 move(C3,P^,SizeOf(C3));
345 Inc(P,1);
346 move(self,P^,SizeOf(self));
347 Inc(P,6);
348 move(method,P^,SizeOf(method));
349 Inc(P,8);
350 P^ := 4+bytes;
351 {Inc(P,3); End of proc}
352 end;
353 result := Q;
354 end;
355 {$ENDIF SIMPLE_32_BIT_CALLBACK}
356
357 {$IFDEF 64_BIT_CALLBACK}
GetCallBacknull358 function GetCallBack( self: TObject; method: Pointer;
359 argnum: Integer; calltype: tcalltype): Pointer;
360 const
361 {$IFDEF MSWINDOWS}
362 RegParamCount = 4;
363 ShadowParamCount = 4;
364 {$ELSE}
365 RegParamCount = 6;
366 ShadowParamCount = 0;
367 {$ENDIF}
368
369 Size32Bit = 4;
370 Size64Bit = 8;
371
372 ShadowStack = ShadowParamCount * Size64Bit;
373 SkipParamCount = RegParamCount - ShadowParamCount;
374
375 StackSrsOffset = 3;
376 c64stack: array[0..14] of byte = (
377 $48, $81, $ec, 00, 00, 00, 00,// sub rsp,$0
378 $4c, $89, $8c, $24, ShadowStack, 00, 00, 00// mov [rsp+$20],r9
379 );
380
381 CopySrcOffset=4;
382 CopyDstOffset=4;
383 c64copy: array[0..15] of byte = (
384 $4c, $8b, $8c, $24, 00, 00, 00, 00,// mov r9,[rsp+0]
385 $4c, $89, $8c, $24, 00, 00, 00, 00// mov [rsp+0],r9
386 );
387
388 RegMethodOffset = 10;
389 {$IFDEF MSWINDOWS}
390 RegSelfOffset = 11;
391 c64regs: array[0..28] of byte = (
392 $4d, $89, $c1, // mov r9,r8
393 $49, $89, $d0, // mov r8,rdx
394 $48, $89, $ca, // mov rdx,rcx
395 $48, $b9, 00, 00, 00, 00, 00, 00, 00, 00, // mov rcx, self
396 $48, $b8, 00, 00, 00, 00, 00, 00, 00, 00 // mov rax, method
397 );
398 {$ELSE}
399 RegSelfOffset = 17;
400 c64regs: array[0..34] of byte = (
401 $4d, $89, $c1, // mov r9,r8
402 $49, $89, $c8, // mov r8,rcx
403 $48, $89, $d1, // mov rcx,rdx
404 $48, $89, $f2, // mov rdx,rsi
405 $48, $89, $fe, // mov rsi,rdi
406 $48, $bf, 00, 00, 00, 00, 00, 00, 00, 00, // mov rdi, self
407 $48, $b8, 00, 00, 00, 00, 00, 00, 00, 00 // mov rax, method
408 );
409 {$ENDIF}
410
411
412 c64jump: array[0..2] of byte = (
413 $48, $ff, $e0 // jump rax
414 );
415
416 CallOffset = 6;
417 c64call: array[0..10] of byte = (
418 $48, $ff, $d0, // call rax
419 $48, $81,$c4, 00, 00, 00, 00, // add rsp,$0
420 $c3// ret
421 );
422 var
423 i: Integer;
424 P,PP,Q: PByte;
425 lCount : integer;
426 lSize : integer;
427 lOffset : integer;
428 begin
429 lCount := SizeOf(c64regs);
430 if argnum>=RegParamCount then
431 Inc(lCount,sizeof(c64stack)+(argnum-RegParamCount)*sizeof(c64copy)+sizeof(c64call))
432 else
433 Inc(lCount,sizeof(c64jump));
434
435 GetCodeMem(Q,lCount);
436 if Q=nil then exit(nil);
437 P := Q;
438
439 lSize := 0;
440 if argnum>=RegParamCount then
441 begin
442 lSize := ( 1+ ((argnum + 1 - SkipParamCount) div 2) * 2 )* Size64Bit; // 16 byte stack align
443
444 pp := p;
445 move(c64stack,P^,SizeOf(c64stack));
446 Inc(P,StackSrsOffset);
447 move(lSize,P^,Size32Bit);
448 p := pp;
449 Inc(P,SizeOf(c64stack));
450 for I := 0 to argnum - RegParamCount -1 do
451 begin
452 pp := p;
453 move(c64copy,P^,SizeOf(c64copy));
454 Inc(P,CopySrcOffset);
455 lOffset := lSize + (i+ShadowParamCount+1)*Size64Bit;
456 move(lOffset,P^,Size32Bit);
457 Inc(P,CopyDstOffset+Size32Bit);
458 lOffset := (i+ShadowParamCount+1)*Size64Bit;
459 move(lOffset,P^,Size32Bit);
460 p := pp;
461 Inc(P,SizeOf(c64copy));
462 end;
463 end;
464
465 pp := p;
466 move(c64regs,P^,SizeOf(c64regs));
467 Inc(P,RegSelfOffset);
468 move(self,P^,SizeOf(self));
469 Inc(P,RegMethodOffset);
470 move(method,P^,SizeOf(method));
471 p := pp;
472 Inc(P,SizeOf(c64regs));
473
474 if argnum<RegParamCount then
475 move(c64jump,P^,SizeOf(c64jump))
476 else
477 begin
478 move(c64call,P^,SizeOf(c64call));
479 Inc(P,CallOffset);
480 move(lSize,P^,Size32Bit);
481 end;
482 result := Q;
483 end;
484 {$ENDIF 64_BIT_CALLBACK}
485
486 {$IFDEF ALIGNED_32_BIT_CALLBACK}
487 // 32 bit with stack align
GetCallBacknull488 function GetCallBack( self: TObject; method: Pointer;
489 argnum: Integer; calltype: tcalltype): Pointer;
490 const
491
492 //Handling for ctCDECL:
493 C1: array [0..5] of byte = (
494 // begin of call
495 $55, //00 push ebp
496 $8B,$EC, //01 mov ebp, esp
497 $83,$EC,$0); //03 sub esp, align
498
499 // push arguments
500 // for i:= argnum-1 downto 0 do begin
501 C2: array [0..3] of byte = (
502 $8B,$45,0, //06+4*s mov eax,[ebp+8+4*i]
503 $50); //09+4*s push eax
504 // end;
505
506 // self parameter
507 C3: array [0..19] of byte = (
508 $B8,0,0,0,0, //06+4*s mov eax, self
509 $50, //11+4*s push eax
510 // call the real callback
511 $B8,0,0,0,0, //12+4*s mov eax,Method
512 $FF,$D0, //17+4*s call eax
513 // clear stack
514 $83,$C4,0, //20+4*s add esp, 4+bytes+align
515 $5D, //23+4*s pop ebp
516 $C2,00,00); //24+4*s ret [0]
517
518 var
519 bytes: Word;
520 i: Integer;
521 P,Q: PByte;
522 align : integer;
523 begin
524 // On mac FPC ctSTDCALL and ctCDECL are the same
525 {$IFDEF FPC}
526 {$IFDEF MACOS32}
527 calltype := ctCDECL;
528 {$ENDIF}
529 {$ENDIF}
530
531 bytes := argnum * 4;
532 align := ($10 - (bytes + 4{self} + 4{address} + 4{push bp}) and $f) and $f; // align to $10 for Mac compatibility
533
534 GetCodeMem(Q,sizeof(c1)+sizeof(c3)+sizeof(c2)*argnum);
535 P := Q;
536 move(C1,P^,SizeOf(C1));
537 Inc(P,SizeOf(C1)-1);
538 p^ := align;
539 Inc(P);
540 for i:=argnum-1 downto 0 do begin
541 move(C2,P^,SizeOf(C2));
542 Inc(P,2);
543 P^:=8+4*i;
544 Inc(P,2);
545 end;
546 move(C3,P^,SizeOf(C3));
547 Inc(P,1);
548 move(self,P^,SizeOf(self));
549 Inc(P,6);
550 move(method,P^,SizeOf(method));
551 Inc(P,8);
552 if calltype = ctCDECL then
553 begin
554 P^ := 4+bytes+align;
555 end
556 else
557 begin
558 P^ := {4+}align;
559 Inc(P,3);
560 P^ := bytes;
561 end;
562
563
564 result := Q;
565 end;
566 {$ENDIF}
567
568 procedure DeleteCallBack( Proc: Pointer);
569 begin
570 FreeCodeMem(Proc);
571 end;
572
573 procedure FreeCallBacks;
574 var
575 page, nextpage: PCodeMemPage;
576 begin
577 // free each allocated page
578 page := CodeMemPages;
579 while page <> nil do
580 begin
581 nextpage := page^.Next;
582
583 // free the memory
584 {$IFDEF MSWINDOWS}
585 VirtualFree(page, 0, MEM_RELEASE);
586 {$ELSE}
587 //FreeMem(page);
588 munmap(page,PageSize);
589 {$ENDIF}
590
591 page := nextpage;
592 end;
593 CodeMemPages := nil;
594 end;
595
596 initialization
597 finalization
598 FreeCallBacks;
599 end.
600