Delphi x64: как передать локальную процедуру в качестве процедурного параметра (обратный вызов) - PullRequest
Новая
       49

Delphi x64: как передать локальную процедуру в качестве процедурного параметра (обратный вызов)

0 голосов
/ 26 февраля 2020

Несколько лет go Я портировал старое приложение unix на Delphi 5. Для итераций связанных списков он использовал локальные процедуры, передаваемые по адресу глобальной функции 'итератора'.

Ниже приведен упрощенный пример: 

type TPerformProc = procedure;

procedure Perform(proc:TPerformProc);
begin
  proc;
end;

procedure Test;
var loc_var:integer;

  procedure loc_proc;
  begin
    loc_var:=loc_var+10;
  end;

begin
  loc_var:=0;
  writeln('loc var: ',loc_var);
  Perform(addr(loc_proc));
  writeln('loc var: ',loc_var);
  writeln('-----');
end;

В примере процедуры происходит сбой в Delphi, но она работает на unix просто отлично.

С некоторой помощью я смог заставить его работать так: 

type TPerformProc = procedure;

var loc_bp:integer;

procedure Perform(proc:TPerformProc);
begin
  asm
    push loc_bp
  end;
  proc;
  asm
    pop eax
  end;
end;

procedure Test;
var loc_var:integer;

  procedure loc_proc;
  begin
    loc_var:=loc_var+10;
  end;

begin
  loc_var:=0;
  writeln('loc var: ',loc_var);
  asm
    mov loc_bp,ebp
  end;
  Perform(addr(loc_proc));
  writeln('loc var: ',loc_var);
  writeln('-----');
end;

Чтобы решить проблему, я сохраняю ссылку на кадр стека локальной процедуры, а затем Я вызываю локальную процедуру.

Мне ясно, что вышеприведенное решение - это не правильное решение, а скорее взлом, и я понимаю, что новая версия Delphi может обрабатывать локальные процедуры по-другому и сломать взломать. К счастью, эта часть Delphi осталась прежней, и код работает нормально даже с последней версией Delhi.

Однако я хочу скомпилировать приложение как 64-битное, и хак больше не работает. До сих пор я не смог найти аналогичное решение, но для 64-битной. Здесь кто-то может помочь?

Спасибо.

Ответы [ 3 ]

1 голос
/ 26 февраля 2020

Вариант ответа @J ..., также с использованием анонимных методов. 

program Project163;

{$APPTYPE CONSOLE}

uses
  SysUtils;

procedure Perform(proc:TProc);
begin
  WriteLn('doing something else important...');
  proc;
end;

procedure Test;
var
  loc_var:integer;

  function _LocalProc : TProc;
  begin
    Result :=
      procedure
      begin
        loc_var := loc_var+10;
      end;
  end;

begin
  loc_var:=0;
  writeln('loc var: ',loc_var);
  Perform(_LocalProc());
  writeln('loc var: ',loc_var);
  writeln('-----');
end;

begin
  Test; ReadLn;
end.

_LocalProc превращается в функцию, возвращающую анонимный метод, идентичный исходной локальной процедуре ,

Обратите внимание на дополнительный паратез в вызове Perform(_LocalProc()), чтобы компилятор понял, как передать полученный анонимный метод в качестве параметра.

1 голос
/ 26 февраля 2020

Самое чистое решение здесь - использовать анонимные методы. Нет никакого способа обойтись без небольшого рефакторинга, но вы могли бы сделать это безболезненно, как это: 

program Project1;    
{$APPTYPE CONSOLE}    
uses
  SysUtils;

procedure Perform(proc:TProc);
begin
  WriteLn('doing something else important...');
  proc;
end;

procedure Test;
var
  loc_var:integer;

  procedure PerformExt;
  begin
    Perform(procedure
            begin
              loc_var := loc_var+10;
            end);
  end;    
begin
  loc_var:=0;
  writeln('loc var: ',loc_var);
  PerformExt;
  writeln('loc var: ',loc_var);
  writeln('-----');
end;    

begin
  Test; ReadLn;
end.

Это приводит к выводу: 

 loc var: 0  
 doing something else important...  
 loc var: 10  
 -----

Обратите внимание, что определение для Perform должен измениться, чтобы принять TProc вместо вашего пользовательского procedure псевдонима.

0 голосов
/ 28 февраля 2020

Мое редактирование в исходном сообщении было отменено с просьбой опубликовать его в качестве ответа, поэтому здесь мы go.

После дальнейших действий, кажется, следующее работает правильно для 32- и 64-битной платформы. : 

type TPerformProc = procedure;

var my_bp:NativeInt;

procedure SimpleFixPerform(proc:TPerformProc);
asm
  {$ifdef WIN64}
    mov rax,proc
    push rbp
    mov rbp,my_bp
    mov rcx,my_bp
    call rax
    pop rbp
  {$else}
    push my_bp
    call proc
    pop eax
  {$endif}
end;

procedure SetupBP;
asm
  {$ifdef WIN64}
    mov my_bp,rbp
  {$else}
    mov my_bp,ebp
  {$endif}
end;

procedure SimpleFixTest;
var loc_var:integer;

  procedure loc_proc;
  begin
    loc_var:=loc_var+10;
  end;

begin
  loc_var:=0;
  loc_proc;
  writeln('SimpleFix var: ',loc_var);
  SetupBP;
  SimpleFixPerform(@loc_proc);
  writeln('SimpleFix var: ',loc_var);
  writeln('-----');
end;

Мои навыки ассемблера немного заржавели, поэтому, если вы видите ошибку в коде, пожалуйста, прокомментируйте

...