delphi - 让 Allen Bauer 的 TMulticastEvent 正常工作

Question

我一直在研究 Allen Bauer 的通用多播事件调度程序代码(请参阅他关于它的博客文章 here )。

他提供了足够的代码让我想使用它，不幸的是他没有发布完整的源代码。我很想让它工作起来，但我的汇编技能根本不存在。

我的问题是InternalSetDispatcher方法。简单的方法是使用与其他 InternalXXX 方法相同的汇编器:

procedure InternalSetDispatcher;
begin
   XCHG  EAX,[ESP]
   POP   EAX
   POP   EBP
   JMP   SetEventDispatcher
end;

但这用于具有一个 const 参数的过程，如下所示:

procedure Add(const AMethod: T); overload;

而SetDispatcher有两个参数，一个是var:

procedure SetEventDispatcher(var ADispatcher: T; ATypeData: PTypeData);

所以，我认为堆栈会被损坏。我知道代码在做什么(通过弹出对 self 的隐藏引用来清理对 InternalSetDispatcher 的调用中的堆栈帧，并且我假设返回地址)，但我只是无法弄清楚那一点汇编程序来获取整个事情进展顺利。

编辑:只是为了澄清一下，我正在寻找的是可以用来使InternalSetDispatcher方法正常工作的汇编器，即用于清理具有两个参数(一个是var)的过程堆栈的汇编器。

EDIT2:我对问题做了一些修改，感谢梅森到目前为止的回答。我应该提到上面的代码不起作用，当 SetEventDispatcher 返回时，会引发 AV。

Answer 1

我在网上进行了大量的搜索之后，得到的答案是，汇编器假设在调用InternalSetDispatcher 时存在堆栈帧。

似乎没有为调用 InternalSetDispatcher 生成堆栈帧。

因此，修复就像使用 {$stackframes on} 编译器指令打开堆栈帧并重建一样简单。

感谢梅森帮助我找到这个答案。 :)

<小时/>

编辑 2012-08-08:如果您热衷于使用此功能，您可能需要查看 Delphi Sping Framework 中的实现。 。我还没有测试过它，但看起来它比这段代码更好地处理不同的调用约定。

<小时/>

编辑:根据要求，我对艾伦代码的解释如下。除了需要打开堆栈帧之外，我还需要在项目级别打开优化才能使其正常工作:

unit MulticastEvent;

interface

uses
  Classes, SysUtils, Generics.Collections, ObjAuto, TypInfo;

type

  // you MUST also have optimization turned on in your project options for this
  // to work! Not sure why.
  {$stackframes on}
  {$ifopt O-}
    {$message Fatal 'optimisation _must_ be turned on for this unit to work!'}
  {$endif}
  TMulticastEvent = class
  strict protected
    type TEvent = procedure of object;
  strict private
    FHandlers: TList<TMethod>;
    FInternalDispatcher: TMethod;

    procedure InternalInvoke(Params: PParameters; StackSize: Integer);
    procedure SetDispatcher(var AMethod: TMethod; ATypeData: PTypeData);
    procedure Add(const AMethod: TEvent); overload;
    procedure Remove(const AMethod: TEvent); overload;
    function IndexOf(const AMethod: TEvent): Integer; overload;
  protected
    procedure InternalAdd;
    procedure InternalRemove;
    procedure InternalIndexOf;
    procedure InternalSetDispatcher;

  public
    constructor Create;
    destructor Destroy; override;

  end;

  TMulticastEvent<T> = class(TMulticastEvent)
  strict private
    FInvoke: T;
    procedure SetEventDispatcher(var ADispatcher: T; ATypeData: PTypeData);
  public
    constructor Create;
    procedure Add(const AMethod: T); overload;
    procedure Remove(const AMethod: T); overload;
    function IndexOf(const AMethod: T): Integer; overload;

    property Invoke: T read FInvoke;
  end;

implementation

{ TMulticastEvent }

procedure TMulticastEvent.Add(const AMethod: TEvent);
begin
  FHandlers.Add(TMethod(AMethod))
end;

constructor TMulticastEvent.Create;
begin
  inherited;
  FHandlers := TList<TMethod>.Create;
end;

destructor TMulticastEvent.Destroy;
begin
  ReleaseMethodPointer(FInternalDispatcher);
  FreeAndNil(FHandlers);
  inherited;
end;

function TMulticastEvent.IndexOf(const AMethod: TEvent): Integer;
begin
  result := FHandlers.IndexOf(TMethod(AMethod));
end;

procedure TMulticastEvent.InternalAdd;
asm
  XCHG  EAX,[ESP]
  POP   EAX
  POP   EBP
  JMP   Add
end;

procedure TMulticastEvent.InternalIndexOf;
asm
  XCHG  EAX,[ESP]
  POP   EAX
  POP   EBP
  JMP   IndexOf
end;

procedure TMulticastEvent.InternalInvoke(Params: PParameters; StackSize: Integer);
var
  LMethod: TMethod;
begin
  for LMethod in FHandlers do
  begin
    // Check to see if there is anything on the stack.
    if StackSize > 0 then
      asm
        // if there are items on the stack, allocate the space there and
        // move that data over.
        MOV ECX,StackSize
        SUB ESP,ECX
        MOV EDX,ESP
        MOV EAX,Params
        LEA EAX,[EAX].TParameters.Stack[8]
        CALL System.Move
      end;
    asm
      // Now we need to load up the registers. EDX and ECX may have some data
      // so load them on up.
      MOV EAX,Params
      MOV EDX,[EAX].TParameters.Registers.DWORD[0]
      MOV ECX,[EAX].TParameters.Registers.DWORD[4]
      // EAX is always "Self" and it changes on a per method pointer instance, so
      // grab it out of the method data.
      MOV EAX,LMethod.Data
      // Now we call the method. This depends on the fact that the called method
      // will clean up the stack if we did any manipulations above.
      CALL LMethod.Code
    end;
  end;
end;

procedure TMulticastEvent.InternalRemove;
asm
  XCHG  EAX,[ESP]
  POP   EAX
  POP   EBP
  JMP   Remove
end;

procedure TMulticastEvent.InternalSetDispatcher;
asm
  XCHG  EAX,[ESP]
  POP   EAX
  POP   EBP
  JMP   SetDispatcher;
end;

procedure TMulticastEvent.Remove(const AMethod: TEvent);
begin
  FHandlers.Remove(TMethod(AMethod));
end;

procedure TMulticastEvent.SetDispatcher(var AMethod: TMethod;
  ATypeData: PTypeData);
begin
  if Assigned(FInternalDispatcher.Code) and Assigned(FInternalDispatcher.Data) then
    ReleaseMethodPointer(FInternalDispatcher);
  FInternalDispatcher := CreateMethodPointer(InternalInvoke, ATypeData);
  AMethod := FInternalDispatcher;
end;

{ TMulticastEvent<T> }

procedure TMulticastEvent<T>.Add(const AMethod: T);
begin
  InternalAdd;
end;

constructor TMulticastEvent<T>.Create;
var
  MethInfo: PTypeInfo;
  TypeData: PTypeData;
begin
  MethInfo := TypeInfo(T);
  TypeData := GetTypeData(MethInfo);
  inherited Create;
  Assert(MethInfo.Kind = tkMethod, 'T must be a method pointer type');
  SetEventDispatcher(FInvoke, TypeData);
end;

function TMulticastEvent<T>.IndexOf(const AMethod: T): Integer;
begin
  InternalIndexOf;
end;

procedure TMulticastEvent<T>.Remove(const AMethod: T);
begin
  InternalRemove;
end;

procedure TMulticastEvent<T>.SetEventDispatcher(var ADispatcher: T;
  ATypeData: PTypeData);
begin
  InternalSetDispatcher;
end;

end.