Watch, Follow, &
Connect with Us
Public Report
Report From: Delphi-BCB/Compiler/Delphi/RTTI    [ Add a report in this area ]  
Report #:  127560   Status: Open
TVirtualInterface corrupts stack on call of intercepted safecall procedure
Project:  Delphi Build #:  XE2, ... XE6
Version:    20.0 Submitted By:   Sergiy Kheylyk
Report Type:  Crash / Data loss / Total failure Date Reported:  9/12/2014 11:13:07 PM
Severity:    Critical / Show Stopper Last Updated: 9/13/2014 3:16:02 AM
Platform:    All platforms Internal Tracking #:   55121
Resolution: None (Resolution Comments) Resolved in Build: : None
Duplicate of:  None
Voting and Rating
Overall Rating: (2 Total Ratings)
5.00 out of 5
Total Votes: 59
Description
If use TVirtualInterface to intercept safecall methods, it corrupts stack on return from safecall procedures.
At the same time intercepting other calling conventions and even safecall functions works ok.
Steps to Reproduce:
I attached .zip archive with two console projects - TestWithAsm.dpr and TestWithFor.dpr.
Open either of them in IDE, and run.
Final result in both cases will be program crash.

---------
program TestWithAsm;
{$APPTYPE CONSOLE}

uses
  System.Rtti,
  System.TypInfo;

type
{$M+}
  IBar = interface
    function SomeFunction: boolean; safecall;
    procedure SomeProc; safecall;
  end;
{$M-}

var
  SP1: LongWord;
  SP2: LongWord;
  V: IBar;
begin
  with TVirtualInterface.Create(TypeInfo(IBar),
    procedure(Method: TRttiMethod; const Args: TArray<TValue>; out Result: TValue)
    begin
    end)
  do
    QueryInterface(GetTypeData(TypeInfo(IBar)).Guid, V);

  Write('Function - ');
  asm mov SP1, ESP end;

  V.SomeFunction;

  asm mov SP2, ESP end;
  if SP1 = SP2 then
    Writeln('ok')
  else
    Writeln('ERROR - stack was corrupted');


  Write('Procedure - ');
  asm mov SP1, ESP end;

  V.SomeProc;

  asm mov SP2, ESP end;
  if SP1 = SP2 then
    Writeln('ok')
  else
    Writeln('ERROR - stack was corrupted');

  Readln;
end.
---------

---------
program TestWithFor;
{$APPTYPE CONSOLE}

uses
  System.Rtti,
  System.TypInfo;

type
{$M+}
  IBar = interface
    function SomeFunction: boolean; safecall;
    procedure SomeProc; safecall;
  end;
{$M-}

var
  V: IBar;
  I: Integer;
begin
  with TVirtualInterface.Create(TypeInfo(IBar),
    procedure(Method: TRttiMethod; const Args: TArray<TValue>; out Result: TValue)
    begin
    end)
  do
    QueryInterface(GetTypeData(TypeInfo(IBar)).Guid, V);

  Write('Function - ');
  for i := 0 to 10000 do
    V.SomeFunction;
  Writeln('ok');

  Write('Procedure - ');
  for i := 0 to 10000 do
    V.SomeProc;
  Writeln('ok');

  Readln;
end.
---------
Workarounds
Sometimes it can be workarounded by pushing 0 before call ("asm push 0 end;"). However, this is not work 100% ok, as stack still seems to be corrupted in some way, just problems will happen later.
Attachment
TVirtualIntefaceError.zip
Comments

Sergiy Kheylyk at 9/13/2014 12:22:39 AM -
Looks like this issue can be fixed by modifying System.Rtti.pas, line 8263, so that it will check for nil FReturnType:
  if (FCC = ccSafeCall) and (FReturnType <> nil) then

Below is diff generated by TortoiseSVN:
===== Diff start =====
--- C:/Users/user/Desktop/System.Rtti.pas
Wed May  9 04:25:46 2012
+++ C:/Users/user/Desktop/System.Rtti.Fixed.pas
Sat Sep 13 10:15:51 2014
@@ -8260,7 +8260,7 @@ begin
   else
     freeRegs := rsNone;

-  if (FCC = ccSafeCall) then
+  if (FCC = ccSafeCall) and (FReturnType <> nil) then
   begin
     FResultLoc := TParamLoc.Create(FReturnType, True);
     PutRefArg(FResultLoc);
===== Diff end =====

To use this "fix", you'll need to copy System.Rtti.pas to your own folder and modify it there

Sergiy Kheylyk at 9/13/2014 12:26:24 AM -
A bit more info in case System.Rtti.pas was changed in next versions:
modified line is in procedure TMethodImplementation.TInvokeInfo.Seal, after its begin:

begin
  // Relative top of stack
  top := 0;
  
  if FCC = ccReg then
    freeRegs := rsAll
  else
    freeRegs := rsNone;

  if (FCC = ccSafeCall) then // <== modify this line

Server Response from: ETNACODE01