Default Generic Comparer for methods returns incorrect results

Question

In using a proposed multicast delegate approach in response to the Signals and slots implementation in Delphi question, the code fails to add more than one event handler.

The problem is related to adding methods to the event list in TDelegateImpl<T>.Add(), the TList<T>.IndexOf method uses a Compare method to find existing methods and the result is always 0 - meaning Left and Right is the same for a TMethod. The Equals method uses a TMethod type cast and explicitly compares TMethod.Code and TMethod.Data, where Compare casts to an address which is always the same.

Why is Compare used in TList<T>.IndexOf and not Equals?

Answer 1

The problem is this function:

function Compare_Method(Inst: PSimpleInstance; const Left, Right: TMethodPointer): Integer;
begin
  if PInt64(@Left)^ < PInt64(@Right)^ then
    Result := -1
  else if PInt64(@Left)^ > PInt64(@Right)^ then
    Result := 1
  else
    Result := 0;
end;

This compares methods as Int64s. That doesn't work, since @ probably has no effect here.

The CPU view confirms this:

System.Generics.Defaults.pas.1089: begin
00447690 55               push ebp
00447691 8BEC             mov ebp,esp
System.Generics.Defaults.pas.1090: if PInt64(@Left)^ < PInt64(@Right)^ then
00447693 8B4510           mov eax,[ebp+$10]
00447696 8B5004           mov edx,[eax+$04]
00447699 8B00             mov eax,[eax]
0044769B 8B4D08           mov ecx,[ebp+$08]
0044769E 3B5104           cmp edx,[ecx+$04]
004476A1 7506             jnz $004476a9
004476A3 3B01             cmp eax,[ecx]
004476A5 7309             jnb $004476b0
004476A7 EB02             jmp $004476ab
004476A9 7D05             jnl $004476b0
System.Generics.Defaults.pas.1091: Result := -1
004476AB 83C8FF           or eax,-$01
004476AE EB21             jmp $004476d1
System.Generics.Defaults.pas.1092: else if PInt64(@Left)^ > PInt64(@Right)^ then
004476B0 8B4510           mov eax,[ebp+$10]
etc...

To compare two TMethods as Int64s, this should be:

System.Generics.Defaults.pas.1090: if PInt64(@Left)^ < PInt64(@Right)^ then
00447693 8B4510           lea eax,[ebp+$10] // not MOV
00447696 8B5004           mov edx,[eax+$04]
00447699 8B00             mov eax,[eax]
0044769B 8B4D08           lea ecx,[ebp+$08] // not MOV
0044769E 3B5104           cmp edx,[ecx+$04]
004476A1 7506             jnz $004476a9
004476A3 3B01             cmp eax,[ecx]
etc...

This clearly shows that PInt64(@Left)^ is interpreted as PInt64(Left)^.

A proper implementation should more or less look like this, for both Delphi 32 and Delphi 64:

function Compare_Method(Inst: PSimpleInstance; const Left, Right: TMethodPointer): Integer;
var
  LCode, LData: PByte;
  RCode, RData: PByte;
begin
  LCode := PByte(TMethod(Left).Code);
  LData := PByte(TMethod(Left).Data);
  RCode := PByte(TMethod(Right).Code);
  RData := PByte(TMethod(Right).Data);
  if LData < RData then
    Result := -1
  else if LData > RData then
    Result := 1
  else if LCode < RCode then
    Result := -1
  else if LCode > RCode then
    Result := 1
  else
    Result := 0;
end;

Answer 2

I can reproduce this and it is very clearly a bug in the default comparer for methods.

I have filed QC#98942.

Here's my code:

program TMethodComparer;

{$APPTYPE CONSOLE}

uses
  SysUtils, Generics.Collections;

type
  TMyMethod = procedure of object;

type
  TMyClass = class
  published
    procedure P1;
    procedure P2;
    procedure P3;
  end;

{ TMyClass }

procedure TMyClass.P1;
begin
end;

procedure TMyClass.P2;
begin
end;

procedure TMyClass.P3;
begin
end;

var
  List: TList<TMyMethod>;
  MyObject1, MyObject2: TMyClass;

begin
  MyObject1 := TMyClass.Create;
  MyObject2 := TMyClass.Create;
  List := TList<TMyMethod>.Create;
  List.Add(MyObject1.P1);
  List.Add(MyObject1.P2);
  List.Add(MyObject2.P1);
  List.Add(MyObject2.P2);
  Writeln(List.IndexOf(MyObject1.P1));
  Writeln(List.IndexOf(MyObject1.P2));
  Writeln(List.IndexOf(MyObject2.P1));
  Writeln(List.IndexOf(MyObject2.P2));
  Writeln(List.IndexOf(MyObject1.P3));
end.

Output

0
0
0
0
0

Expected output

0
1
2
3
-1

The default comparer in Generics.Defaults is implemented like this:

type
  TMethodPointer = procedure of object;

function Compare_Method(Inst: PSimpleInstance; const Left, Right: TMethodPointer): Integer;
begin
  if PInt64(@Left)^ < PInt64(@Right)^ then
    Result := -1
  else if PInt64(@Left)^ > PInt64(@Right)^ then
    Result := 1
  else
    Result := 0;
end;

I can understand what this is attempting to do, but it fails miserably. I still can't work out how these casts pan out.

I believe that the 32 bit version of Compare_Method should have been written this way:

function Compare_Method(Inst: PSimpleInstance; const Left, Right: TMethod): Integer;
begin
  if Int64(Left) < Int64(Right) then
    Result := -1
  else if Int64(Left) > Int64(Right) then
    Result := 1
  else
    Result := 0;
end;

And this does lead to the expected output.

Clearly for a 64 bit target (i.e. in XE2) no approach based on aliasing with a 64 bit integer will work.

So, in order to workaround the bug, you can add the following functions:

function Compare_Method(const Left, Right: TMethod): Integer;
var
  LCode, LData: PByte;
  RCode, RData: PByte;
begin
  LCode := PByte(Left.Code);
  LData := PByte(Left.Data);
  RCode := PByte(Right.Code);
  RData := PByte(Right.Data);
  if LData<RData then
    Result := -1
  else if LData>RData then
    Result := 1
  else if LCode<RCode then
    Result := -1
  else if LCode>RCode then
    Result := 1
  else
    Result := 0;
end;

function CompareMyMethod(const Left, Right: TMyMethod): Integer;
begin
  Result := Compare_Method(TMethod(Left), TMethod(Right))
end;

And then create the list like this:

List := TList<TMyMethod>.Create(
  TComparer<TMyMethod>.Construct(CompareMyMethod)
);