search

remobjects / pascalscript

pascalscript
Other
447 stars 178 forks source link

Error when calling delphi function in x64 mode #266

Closed Alekcvp closed 1 year ago

Alekcvp commented 1 year ago

I have imported delphi function: s.AddDelphiFunction('function PackSize(Value: Int64): string;'); FPSExec.RegisterDelphiFunction(@PackSize, 'PackSize', cdRegister);

In x64 mode, when calling it, Delphi passes a reference to the Result in the RCX, and the Value in the RDX. Pascal Script calls it with Value in RCX and Result (? Pointer to nil) in RDX.

x86 mode working perfectly.

evgeny-k commented 1 year ago

the https://github.com/remobjects/pascalscript/commit/f68967d58fe4efe0fd293fcc4a2c9bdd27af5f80 commit should fix some x64 issues.

if it doesn't work in your case, can you create and attach a simple testcase that reproduces this issue, pls?

Alekcvp commented 1 year ago

In my particular case, I fixed it by adding the following changes to InvokeCall.inc:

    case res.atype.basetype of
      { add result types here }
      btString:                tbtstring(res.dta^) := tbtstring(Invoke(Address, Args, SysCalConv, TypeInfo(String),
                                 {$IFDEF WIN64} _Self = nil {$ELSE} False {$ENDIF},IsConstr).AsString);
      {$IFNDEF PS_NOWIDESTRING}
      btUnicodeString:         tbtunicodestring(res.dta^) := Invoke(Address, Args, SysCalConv, TypeInfo(String),
                                 {$IFDEF WIN64} _Self = nil {$ELSE} False {$ENDIF}, IsConstr).AsString;
      btWideString:            tbtWideString(res.dta^) := Invoke(Address, Args, SysCalConv, TypeInfo(String),
                                 {$IFDEF WIN64} _Self = nil {$ELSE} False {$ENDIF}, IsConstr).AsString;

But I can not call it a suitable solution in general due to insufficient experience.

Alekcvp commented 1 year ago

Simple testcase to reproduce the error:

program PSTestCase;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils, uPSCompiler, uPSRuntime, uPSUtils;

procedure Print(const Text: string);
begin
  WriteLn(Text);
end;

function Test(Value: Int64): string;
begin
  Result := IntToStr(Value); // --> x64 AV here and 'Value' has a wrong value
end;

function PSOnUses(Sender: TPSPascalCompiler; const Name: tbtString): Boolean;
begin
  Sender.AddDelphiFunction('function Test(Value: Int64): string;');
  Sender.AddDelphiFunction('procedure Print(const Text: string);');
  Result := True;
end;

var
  C: TPSPascalCompiler;
  E: TPSExec;
  Data: AnsiString;
begin
  C := TPSPascalCompiler.Create;
  E := TPSExec.Create;
  try
    C.OnUses := PSOnUses;
    C.Compile('begin Print(Test(832794832)); end.');
    C.GetOutput(Data);
    E.RegisterDelphiFunction(@Print, 'Print', cdRegister);
    E.RegisterDelphiFunction(@Test, 'Test', cdRegister);
    E.LoadData(Data);
    E.RunScript;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  E.Free;
  C.Free;
  ReadLn;
end.
evgeny-k commented 1 year ago

use this InvokeCall.inc:

function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
var SysCalConv : TCallConv;
    Args: TArray<TValue>;
    Arg : TValue;
    i : Integer;
    fvar: PPSVariantIFC;
    IsConstr : Boolean;
    IsStatic : Boolean;
    ctx: TRTTIContext;
    RttiType : TRttiType;
    ResValue : TValue;
begin
  Result := False;
  IsStatic := _Self = nil;
  case CallingConv of
    cdRegister : SysCalConv := ccReg;
    cdPascal : SysCalConv := ccPascal;
    cdCdecl : SysCalConv := ccCdecl;
    cdStdCall : SysCalConv := ccStdCall;
    cdSafeCall : SysCalConv := ccSafeCall;
  else
    SysCalConv := ccReg;//to prevent warning "W1036 Variable might not have been initialized"
  end;

  if not IsStatic then begin
    {$IFDEF CPUX86}
    if CallingConv <> cdPascal then
    {$ENDIF CPUX86}
      Args := Args + [TValue.From<Pointer>( _Self )];
  end;

  for I := 0 to Params.Count - 1 do
  begin
    if Params[i] = nil
      then Exit;
    fvar := Params[i];

    if fvar.varparam then
    begin { var param }
      case fvar.aType.BaseType of
        btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btWideString, btWideChar, {$ENDIF}
        btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency,
        btUnicodeString
        {$IFNDEF PS_NOINT64}, bts64{$ENDIF}:
          Arg := TValue.From<Pointer>( Pointer(fvar.dta) );
        else
          begin
            Exit;
          end;
      end;
    end
    else
    begin  { not a var param }
      case fvar.aType.BaseType of
        { add normal params here }
        {$IFNDEF PS_NOWIDESTRING}
        btWidestring,
        btUnicodestring,
        {$ENDIF}
        btString:                          Arg := TValue.From<String>(pstring(fvar.dta)^);
        btU8, btS8:                        Arg := TValue.From<Byte>(pbyte(fvar.dta)^);
        btU16, BtS16:                      Arg := TValue.From<Word>(pword(fvar.dta)^);
        btU32, btS32:                      Arg := TValue.From<Cardinal>(pCardinal(fvar.dta)^);
        {$IFNDEF PS_NOINT64}bts64:{$ENDIF} Arg := TValue.From<Int64>(pint64(fvar.dta)^);
        btSingle:                          Arg := TValue.From<Single>(PSingle(fvar.dta)^);
        btDouble:                          Arg := TValue.From<Double>(PDouble(fvar.dta)^);
        btExtended:                        Arg := TValue.From<Extended>(PExtended(fvar.dta)^);
        btPChar:                           Arg := TValue.From<PChar>(ppchar(fvar.dta)^);
        btChar:                            Arg := TValue.From<Char>(pchar(fvar.dta)^);
        btClass:                           Arg := TValue.From<TObject>(TObject(fvar.dta^));
        btRecord:                          Arg := TValue.From<Pointer>(fvar.dta);
        btStaticArray:                     Arg := TValue.From<Pointer>(fvar.dta);
        btVariant:
          Arg := TValue.From(Variant(fvar.dta^));
        btArray:
          begin
             if Copy(fvar.aType.ExportName, 1, 10) = '!OPENARRAY' then
             begin  //openarray
               //in case of openarray we should provide TWO params: first is pointer to array,
               Args := Args + [TValue.From<Pointer>(Pointer(fvar.Dta^))];
               //2nd - integer with arraylength - 1 (high)
               Arg := TValue.From<Integer>(PSDynArrayGetLength(Pointer(fvar.Dta^), fvar.aType)-1);// = High of OpenArray
             end
             else //dynarray = just push pointer
               Arg := TValue.From<Pointer>(fvar.dta);
          end;
        btSet:
          begin
            case TPSTypeRec_Set(fvar.aType).aByteSize  of
              1: Arg := TValue.From<Byte>(pbyte(fvar.dta)^);
              2: Arg := TValue.From<Word>(pWord(fvar.dta)^);
              3,
              4: Arg := TValue.From<Cardinal>(pCardinal(fvar.dta)^);
              else
                Arg := TValue.From<Pointer>(fvar.dta);
            end;
          end;
        else
//            writeln(stderr, 'Parameter type not implemented!');
          Exit;
      end;  { case }
    end;
    Args := Args + [Arg];
  end;

  if not IsStatic then begin
    {$IFDEF CPUX86}
    if CallingConv <> cdPascal then
      Args := Args + [TValue.From<Pointer>( _Self )];
    {$ENDIF CPUX86}
  end;

  IsConstr := (Integer(CallingConv) and 64) <> 0;
  if not assigned(res) then
  begin
    Invoke(Address,Args,SysCalConv,nil,IsStatic, IsConstr);  { ignore return }
  end
  else begin
    case res.atype.basetype of
      { add result types here }
      btString:                tbtstring(res.dta^) := tbtstring(Invoke(Address,Args,SysCalConv,TypeInfo(String),IsStatic, IsConstr).AsString)
      ;
      {$IFNDEF PS_NOWIDESTRING}
      btUnicodeString:         tbtunicodestring(res.dta^) := Invoke(Address,Args,SysCalConv,TypeInfo(String),IsStatic, IsConstr).AsString;
      btWideString:            tbtWideString(res.dta^) := Invoke(Address,Args,SysCalConv,TypeInfo(String),IsStatic, IsConstr).AsString;
      {$ENDIF}
      btU8, btS8:              pbyte(res.dta)^ := Byte(Invoke(Address,Args,SysCalConv,TypeInfo(Byte),IsStatic, IsConstr).AsInteger);
      btU16, btS16:            pword(res.dta)^ := word(Invoke(Address,Args,SysCalConv,TypeInfo(Word),IsStatic, IsConstr).AsInteger);
      btU32, btS32:            pCardinal(res.dta)^ := Cardinal(Invoke(Address,Args,SysCalConv,TypeInfo(Cardinal),IsStatic, IsConstr).AsInteger);
      {$IFNDEF PS_NOINT64}bts64:{$ENDIF}   pInt64(res.dta)^ := Int64(Invoke(Address,Args,SysCalConv,TypeInfo(Int64),IsStatic, IsConstr).AsInt64);
      btSingle:                psingle(res.dta)^ := Double(Invoke(Address,Args,SysCalConv,TypeInfo(Single),IsStatic, IsConstr).AsExtended);
      btDouble:                pdouble(res.dta)^ := Double(Invoke(Address,Args,SysCalConv,TypeInfo(Double),IsStatic, IsConstr).AsExtended);
      btExtended:              pextended(res.dta)^ := Extended(Invoke(Address,Args,SysCalConv,TypeInfo(Extended),IsStatic, IsConstr).AsExtended);
      {$IFDEF FPC}
      btPChar:                 ppchar(res.dta)^ := pchar(Invoke(Address,Args,SysCalConv,TypeInfo(PChar),IsStatic, IsConstr).AsOrdinal);
      btChar:                  pchar(res.dta)^ := Char(Invoke(Address,Args,SysCalConv,TypeInfo(Char),IsStatic, IsConstr).AsChar);
      {$ELSE}
      btPChar:                 ppchar(res.dta)^ := pchar(Invoke(Address,Args,SysCalConv,TypeInfo(PChar),IsStatic, IsConstr).AsType<PChar>());
      btChar:                  pchar(res.dta)^ := Char(Invoke(Address,Args,SysCalConv,TypeInfo(Char),IsStatic, IsConstr).AsType<Char>());
      {$ENDIF}
      btSet:
        begin
          case TPSTypeRec_Set(res.aType).aByteSize  of
            1: byte(res.Dta^) := Byte(Invoke(Address,Args,SysCalConv,TypeInfo(Byte),IsStatic, IsConstr).AsInteger);
            2: word(res.Dta^) := word(Invoke(Address,Args,SysCalConv,TypeInfo(Word),IsStatic, IsConstr).AsInteger);
            3,
            4: Longint(res.Dta^) := Cardinal(Invoke(Address,Args,SysCalConv,TypeInfo(Cardinal),IsStatic, IsConstr).AsInteger);
            {$IFNDEF FPC}
            else
            begin
              for RttiType in ctx.GetTypes do
                if (RttiType.Name.ToUpper.EndsWith(String(res.aType.FExportName))) and (RttiType.TypeKind = tkSet)
                  and (RttiType.TypeSize = TPSTypeRec_Set(res.aType).aByteSize) then
                begin
                  Invoke(Address,Args,SysCalConv,RttiType.Handle,IsStatic, IsConstr).ExtractRawData(res.dta);
                  Break;
                end;
            end;
            {$ENDIF}
          end;
        end;
      btClass:
      begin
        {$IFNDEF FPC}for RttiType in ctx.GetTypes do
          if (RttiType.Name.ToUpper.EndsWith(String(res.aType.FExportName))) and (RttiType.TypeKind = tkClass) then{$ENDIF}
          begin
            TObject(res.dta^) := Invoke(Address,Args,SysCalConv,{$IFDEF FPC}TypeInfo(TObject){$ELSE}RttiType.Handle{$ENDIF},IsStatic, IsConstr).AsObject;
            {$IFNDEF FPC}Break;{$ENDIF}
          end;
      end;
      {$IFNDEF FPC}
      btStaticArray:
      begin
        for RttiType in ctx.GetTypes do
          if (RttiType.Name.ToUpper.EndsWith(String(res.aType.FExportName))) and (RttiType.TypeKind = tkArray) then
          begin
            CopyArrayContents(res.dta, Invoke(Address,Args,SysCalConv,RttiType.Handle,IsStatic, IsConstr).GetReferenceToRawData, TPSTypeRec_StaticArray(res.aType).Size, TPSTypeRec_StaticArray(res.aType).ArrayType);
            Break;
          end;
      end;
      btRecord:
      begin
        for RttiType in ctx.GetTypes do
          if (RttiType.Name.ToUpper.EndsWith(String(res.aType.FExportName))) and (RttiType.TypeKind = tkRecord) then
          begin
            CopyArrayContents(res.dta, (Invoke(Address,Args,SysCalConv,RttiType.Handle,IsStatic, IsConstr).GetReferenceToRawData), 1, res.aType);
            Break;
          end;
      end;
      btArray: //need to check with open arrays
      begin
        for RttiType in ctx.GetTypes do
          if (RttiType.Name.ToUpper.EndsWith(String(res.aType.FExportName))) and (RttiType.TypeKind = tkDynArray) then
          begin
            ResValue := Invoke(Address,Args,SysCalConv,RttiType.Handle,IsStatic, IsConstr);
            if ResValue.GetArrayLength > 0 then
              CopyArrayContents(res.dta, ResValue.GetReferenceToRawData, 1, res.aType)
            else
              res.dta := nil;
            Break;
          end;
      end;
      btVariant:
        begin
          PVariant(res.dta)^ := Invoke(Address, Args, SysCalConv, TypeInfo(Variant), IsStatic, IsConstr).AsVariant;
        end;
      {$ENDIF}
      else
//          writeln(stderr, 'Result type not implemented!');
        Exit;
    end;  { case }
  end; //assigned(res)

  Result := True;
end;