Delphi/pascalscript
Delphi/pascalscript
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

61: 64bits support

Browse Source 
git-svn-id: http://code.remobjects.com/svn/pascalscript@162 5c9d2617-0215-0410-a2ee-e80e04d1c6d8
This commit is contained in:
carlokok 2009-08-13 18:53:50 +00:00
parent 198b4b3586
commit ac92e2fd00
3 changed files with 230 additions and 352 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
Source/uPSRuntime.pas
View File

@ -722,27 +722,27 @@ type
constructor Create;
destructor Destroy; Override;
function RunScript: Boolean;
function LoadData(const s: tbtstring): Boolean; virtual;
procedure Clear; Virtual;
procedure Cleanup; Virtual;
procedure Stop; Virtual;
procedure Pause; Virtual;
property CallCleanup: Boolean read FCallCleanup write FCallCleanup;
property Status: TPSStatus Read FStatus;
property OnRunLine: TPSOnLineEvent Read FOnRunLine Write FOnRunLine;
procedure ClearspecialProcImports;
@ -761,23 +761,23 @@ type
function GetProcAsMethodN(const ProcName: tbtstring): TMethod;
procedure RegisterAttributeType(useproc: TPSAttributeUseProc; const TypeName: tbtstring);
procedure ClearFunctionList;
property ExceptionProcNo: Cardinal Read ExProc;
property ExceptionPos: Cardinal Read ExPos;
property ExceptionCode: TPSError Read ExEx;
property ExceptionString: tbtstring read ExParam;
property ExceptionObject: TObject read ExObject write ExObject;
procedure AddResource(Proc, P: Pointer);
function IsValidResource(Proc, P: Pointer): Boolean;
procedure DeleteResource(P: Pointer);
function FindProcResource(Proc: Pointer): Pointer;
@ -1002,13 +1002,13 @@ type
public
procedure RegisterConstructor(ProcPtr: Pointer; const Name: tbtstring);
procedure RegisterVirtualConstructor(ProcPtr: Pointer; const Name: tbtstring);
procedure RegisterMethod(ProcPtr: Pointer; const Name: tbtstring);
procedure RegisterVirtualMethod(ProcPtr: Pointer; const Name: tbtstring);
procedure RegisterVirtualAbstractMethod(ClassDef: TClass; ProcPtr: Pointer; const Name: tbtstring);
procedure RegisterPropertyHelper(ReadFunc, WriteFunc: Pointer; const Name: tbtstring);
@ -1018,7 +1018,7 @@ type
procedure RegisterEventPropertyHelper(ReadFunc, WriteFunc: Pointer; const Name: tbtstring);
constructor Create(aClass: TClass; const AName: tbtstring);
destructor Destroy; override;
end;
@ -1030,7 +1030,7 @@ type
constructor Create;
constructor CreateAndRegister(Exec: TPSexec; AutoFree: Boolean);
destructor Destroy; override;
function Add(aClass: TClass): TPSRuntimeClass;
@ -10705,7 +10705,7 @@ begin
begin
Pointer(Pointer((IPointer(n.dta)+PointerSize))^) := data.Data;
Pointer(Pointer((IPointer(n.dta)+PointerSize2))^) := data.Code;
end;
end;
DestroyHeapVariant(n2);
DisposePPSVariantIFCList(Params);
end;

546
Source/x64.inc
View File

@ -1,18 +1,74 @@
{ implementation of x86 abi }
{ implementation of x64 abi }
//procedure DebugBreak; external 'Kernel32.dll';
const
EmptyPchar: array[0..0] of char = #0;
{$ASMMODE INTEL}
procedure x64call(
Address: Pointer;
out _RAX: IPointer;
_RCX, _RDX, _R8, _R9: IPointer;
var _XMM0: Double;
_XMM1, _XMM2, _XMM3: Double;
aStack: Pointer; aItems: Integer);
asm
(* Registers:
RCX: Address
RDX: *_RAX
R8: _RCX
R9: _RDX
fpc inserts an 20h emty space
*)
push rcx // address
push rdx // _rax
push r8 // _rcx
push r9 // _rdx
mov rcx, aItems
jmp @compareitems
@work:
mov rdx,[aStack]
push rdx
dec rcx
add aStack,8
@compareitems:
or rcx, rcx
jnz @work
// copy registers
movd xmm0,[_XMM0]
movd xmm1,_XMM1
movd xmm2,_XMM2
movd xmm3,_XMM3
mov RAX, [rbp-40]
mov RCX, [rbp-56]
mov RDX, [rbp-62]
mov R8, _R8
mov R9, _R9
call RAX
// copy result back
mov RDX, [rbp-48]
mov [RDX], RAX
movd [_XMM0],xmm0
pop r9
pop r8
pop rdx
pop rcx
end;
function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
(*var
Stack: ansistring;
I: Longint;
var
Stack: array of Byte;
_RAX,
_RCX, _RDX, _R8, _R9: IPointer;
_XMM0, _XMM1, _XMM2, _XMM3: Double;
RegUsage: Byte;
CallData: TPSList;
I: Integer;
pp: ^Byte;
EAX, EDX, ECX: Longint;
function rp(p: PPSVariantIFC): PPSVariantIFC;
begin
if p = nil then
@ -22,12 +78,58 @@ function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingC
end;
if p.aType.BaseType = btPointer then
begin
p^.aType := Pointer(Pointer(IPointer(p^.dta) + 4)^);
p^.aType := Pointer(Pointer(IPointer(p^.dta) + PointerSize)^);
p^.Dta := Pointer(p^.dta^);
end;
Result := p;
end;
procedure StoreReg(data: IPointer); overload;
var p: Pointer;
begin
case RegUsage of
0: begin inc(RegUsage); _RCX:=Data; end;
1: begin inc(RegUsage); _RDX:=Data; end;
2: begin inc(RegUsage); _R8:=Data; end;
3: begin inc(RegUsage); _R9:=Data; end;
else begin
SetLength(Stack, Length(Stack)+8);
p := @Stack[LEngth(Stack)-7];
IPointer(p^) := data;
end;
end;
end;
procedure StoreStack(const aData; Len: Integer);
var
p: Pointer;
begin
if Len > 8 then
if Length(Stack) mod 16 <> 0 then begin
SetLength(Stack, Length(Stack)+ (16-(Length(Stack) mod 16)));
end;
SetLength(Stack, Length(Stack)+Len);
p := @Stack[Length(Stack)-Len-1];
Move(aData, p^, Len);
end;
procedure StoreReg(data: Double); overload;
var p: Pointer;
begin
case RegUsage of
0: begin inc(RegUsage); _XMM0:=Data; end;
1: begin inc(RegUsage); _XMM1:=Data; end;
2: begin inc(RegUsage); _XMM2:=Data; end;
3: begin inc(RegUsage); _XMM3:=Data; end;
else begin
SetLength(Stack, Length(Stack)+8);
p := @Stack[LEngth(Stack)-7];
Double(p^) := data;
end;
end;
end;
function GetPtr(fVar: PPSVariantIFC): Boolean;
var
varPtr: Pointer;
@ -47,32 +149,13 @@ function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingC
p := CreateOpenArray(True, Self, FVar);
if p = nil then exit;
CallData.Add(p);
case RegUsage of
0: begin EAX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
1: begin EDX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
2: begin ECX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
else begin
Stack := StringOfChar(AnsiChar(#0),4) + Stack;
Pointer((@Stack[1])^) := POpenArray(p)^.Data;
end;
end;
case RegUsage of
0: begin EAX := Longint(POpenArray(p)^.ItemCount - 1); Inc(RegUsage); end;
1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
else begin
Stack := StringOfChar(AnsiChar(#0),4) + Stack;
Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1;
end;
end;
StoreReg(IPointer(POpenArray(p)^.Data));
StoreReg(IPointer(POpenArray(p)^.ItemCount -1));
Result := True;
Exit;
end else begin
{$IFDEF PS_DYNARRAY}
varptr := fvar.Dta;
{$ELSE}
Exit;
{$ENDIF}
end;
end;
btVariant,
@ -91,27 +174,20 @@ function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingC
exit; //invalid type
end;
end; {case}
case RegUsage of
0: begin EAX := Longint(VarPtr); Inc(RegUsage); end;
1: begin EDX := Longint(VarPtr); Inc(RegUsage); end;
2: begin ECX := Longint(VarPtr); Inc(RegUsage); end;
else begin
Stack := StringOfChar(AnsiChar(#0),4) + Stack;
Pointer((@Stack[1])^) := VarPtr;
end;
end;
StoreReg(IPointer(VarPtr));
end else begin
UseReg := True;
case fVar^.aType.BaseType of
btSet:
begin
tempstr := StringOfChar(AnsiChar(#0),4);
case TPSTypeRec_Set(fvar.aType).aByteSize of
1: Byte((@tempstr[1])^) := byte(fvar.dta^);
2: word((@tempstr[1])^) := word(fvar.dta^);
3, 4: cardinal((@tempstr[1])^) := cardinal(fvar.dta^);
1: StoreReg(IPointer(byte(fvar.dta^)));
2: StoreReg(IPointer(word(fvar.dta^)));
3, 4: StoreReg(IPointer(cardinal(fvar.dta^)));
5,6,7,8: StoreReg(IPointer(fVar.Dta^));
else
pointer((@tempstr[1])^) := fvar.dta;
StoreReg(IPointer(fvar.Dta));
end;
end;
btArray:
@ -121,349 +197,151 @@ function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingC
p := CreateOpenArray(False, SElf, FVar);
if p =nil then exit;
CallData.Add(p);
case RegUsage of
0: begin EAX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
1: begin EDX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
2: begin ECX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
else begin
Stack := StringOfChar(AnsiChar(#0),4) + Stack;
Pointer((@Stack[1])^) := POpenArray(p)^.Data;
end;
end;
case RegUsage of
0: begin EAX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
else begin
Stack := StringOfChar(AnsiChar(#0),4) + Stack;
Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1;
end;
end;
StoreReg(IPointer(POpenArray(p)^.Data));
StoreReg(IPointer(POpenArray(p)^.ItemCount -1));
Result := True;
exit;
end else begin
{$IFDEF PS_DYNARRAY}
TempStr := StringOfChar(AnsiChar(#0),4);
Pointer((@TempStr[1])^) := Pointer(fvar.Dta^);
{$ELSE}
Exit;
{$ENDIF}
StoreReg(IPointer(FVar.Dta^));
end;
end;
btVariant
, btStaticArray, btRecord:
begin
TempStr := StringOfChar(AnsiChar(#0),4);
Pointer((@TempStr[1])^) := Pointer(fvar.Dta);
StoreReg(IPointer(fVar.Dta));
end;
btDouble: {8 bytes} begin
TempStr := StringOfChar(AnsiChar(#0),8);
UseReg := False;
double((@TempStr[1])^) := double(fvar.dta^);
btExtended, btDouble: {8 bytes} begin
StoreReg(double(fvar.dta^));
end;
btCurrency: {8 bytes} begin
TempStr := StringOfChar(AnsiChar(#0),8);
UseReg := False;
currency((@TempStr[1])^) := currency(fvar.dta^);
StoreReg(IPointer(fvar.dta^));
end;
btSingle: {4 bytes} begin
TempStr := StringOfChar(AnsiChar(#0),4);;
UseReg := False;
Single((@TempStr[1])^) := single(fvar.dta^);
StoreReg(single(fvar.dta^));
end;
btExtended: {10 bytes} begin
UseReg := False;
TempStr:= StringOfChar(AnsiChar(#0),12);
Extended((@TempStr[1])^) := extended(fvar.dta^);
end;
btChar,
btU8,
btS8: begin
TempStr := tbtchar(fVar^.dta^) + tbtstring(StringOfChar(AnsiChar(#0),3));
StoreReg(IPointer(byte(fVar^.dta^)));
end;
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}
btWideChar,
btu16, btS16: begin
TempStr := StringOfChar(AnsiChar(#0),4);
Word((@TempStr[1])^) := word(fVar^.dta^);
StoreReg(IPointer(word(fVar^.dta^)));
end;
btu32, bts32: begin
TempStr := StringOfChar(AnsiChar(#0),4);
Longint((@TempStr[1])^) := Longint(fVar^.dta^);
StoreReg(IPointer(cardinal(fVar^.dta^)));
end;
btPchar:
begin
TempStr := StringOfChar(AnsiChar(#0),4);
if pointer(fvar^.dta^) = nil then
Pointer((@TempStr[1])^) := @EmptyPchar
StoreReg(IPointer(@EmptyPchar))
else
Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
StoreReg(IPointer(fvar^.dta^));
end;
btclass, btinterface, btString:
begin
TempStr := StringOfChar(AnsiChar(#0),4);
Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
StoreReg(IPointer(fvar^.dta^));
end;
{$IFNDEF PS_NOWIDESTRING}
btWideString: begin
TempStr := StringOfChar(AnsiChar(#0),4);
Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
StoreReg(IPointer(fvar^.dta^));
end;
btUnicodeString: begin
TempStr := StringOfChar(AnsiChar(#0),4);
Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
StoreReg(IPointer(fvar^.dta^));
end;
{$ENDIF}
btProcPtr:
begin
tempstr := StringOfChar(AnsiChar(#0),8);
TMethod((@TempStr[1])^) := MKMethod(Self, Longint(FVar.Dta^));
UseReg := false;
GetMem(p, PointerSize2);
TMethod(p^) := MKMethod(Self, Longint(FVar.Dta^));
StoreStack(p^, Pointersize2);
FreeMem(p);
end;
{$IFNDEF PS_NOINT64}bts64:
bts64:
begin
TempStr:= StringOfChar(AnsiChar(#0),8);
Int64((@TempStr[1])^) := int64(fvar^.dta^);
UseReg := False;
end;{$ENDIF}
end; {case}
if UseReg then
begin
case RegUsage of
0: begin EAX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
1: begin EDX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
2: begin ECX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
else begin
{$IFDEF FPC_OLD_FIX}
if CallingConv = cdRegister then
Stack := Stack + TempStr
else
{$ENDIF}
Stack := TempStr + Stack;
end;
StoreReg(IPointer(int64(fvar^.dta^)));
end;
end else begin
{$IFDEF FPC_OLD_FIX}
if CallingConv = cdRegister then
Stack := Stack + TempStr
else
{$ENDIF}
Stack := TempStr + Stack;
end;
end; {case}
end;
Result := True;
end;*)
end;
begin
InnerfuseCall := False;
(* if Address = nil then
if Address = nil then
exit; // need address
Stack := '';
SetLength(Stack, 0);
CallData := TPSList.Create;
res := rp(res);
if res <> nil then
res.VarParam := true;
try
case CallingConv of
cdRegister: begin
EAX := 0;
EDX := 0;
ECX := 0;
RegUsage := 0;
if assigned(_Self) then begin
RegUsage := 1;
EAX := Longint(_Self);
end;
for I := 0 to Params.Count - 1 do
begin
if not GetPtr(rp(Params[I])) then Exit;
end;
if assigned(res) then begin
case res^.aType.BaseType of
{$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, {$ENDIF}
btInterface, btArray, btrecord, {$IFNDEF PS_FPCSTRINGWORKAROUND}btstring, {$ENDIF}btVariant, btStaticArray: GetPtr(res);
btSet:
begin
if TPSTypeRec_Set(res.aType).aByteSize >4 then GetPtr(res);
end;
end;
case res^.aType.BaseType of
btSet:
begin
case TPSTypeRec_Set(res.aType).aByteSize of
1: byte(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
2: word(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
3,
4: Longint(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
else RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil)
end;
end;
btSingle: tbtsingle(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
btDouble: tbtdouble(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
btExtended: tbtextended(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
btchar,btU8, btS8: tbtu8(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
btClass :
{$IFDEF FPC_OLD_FIX}
tbtu32(res.dta^) := RealCall_Register(Address, EDX, EAX, ECX,
@Stack[Length(Stack) - 3], Length(Stack) div 4, 4, nil);
{$ELSE}
tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX,
@Stack[Length(Stack) - 3], Length(Stack) div 4, 4, nil);
{$ENDIF}
btu32,bts32: tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
btPChar: pansichar(res.dta^) := Pansichar(RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
{$IFNDEF PS_NOINT64}bts64:
begin
EAX := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
tbts64(res.dta^) := Int64(Cardinal(EDX)) shl 32 or Cardinal(EAX);
end;
{$ENDIF}
btCurrency: tbtCurrency(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4) / 10000;
btInterface,
btVariant,
{$IFNDEF PS_NOWIDESTRING}btWidestring,btUnicodestring, {$ENDIF}
btStaticArray, btArray, btrecord{$IFNDEF PS_FPCSTRINGWORKAROUND}, btstring {$ENDIF}: RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
{$IFDEF PS_FPCSTRINGWORKAROUND}
btstring: begin
eax := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
Longint(res.dta^) := eax;
end;
{$ENDIF}
else
exit;
end;
end else
RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
Result := True;
end;
cdPascal: begin
RegUsage := 3;
for I := 0 to Params.Count - 1 do begin
if not GetPtr(Params[i]) then Exit;
end;
if assigned(res) then begin
case res^.aType.BaseType of
{$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, {$ENDIF}btInterface, btArray, btrecord, btstring, btVariant: GetPtr(res);
end;
end;
if assigned(_Self) then begin
Stack := StringOfChar(AnsiChar(#0),4) +Stack;
Pointer((@Stack[1])^) := _Self;
end;
if assigned(res) then begin
case res^.aType.BaseType of
btSingle: tbtsingle(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btDouble: tbtdouble(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btExtended: tbtextended(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btChar, btU8, btS8: tbtu8(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
btClass, btu32, bts32: tbtu32(res^.Dta^):= RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
btPChar: TBTSTRING(res^.dta^) := Pansichar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
{$IFNDEF PS_NOINT64}bts64:
begin
EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
tbts64(res^.dta^) := Int64(EAX) shl 32 or EDX;
end;
{$ENDIF}
btVariant,
btInterface, btrecord, btstring: RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
else
exit;
end;
end else
RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
Result := True;
end;
cdSafeCall: begin
RegUsage := 3;
if assigned(res) then begin
GetPtr(res);
end;
for I := Params.Count - 1 downto 0 do begin
if not GetPtr(Params[i]) then Exit;
end;
if assigned(_Self) then begin
Stack := StringOfChar(AnsiChar(#0),4) +Stack;
Pointer((@Stack[1])^) := _Self;
end;
OleCheck(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
Result := True;
end;
CdCdecl: begin
RegUsage := 3;
if assigned(_Self) then begin
Stack := StringOfChar(AnsiChar(#0),4);
Pointer((@Stack[1])^) := _Self;
end;
for I := Params.Count - 1 downto 0 do begin
if not GetPtr(Params[I]) then Exit;
end;
if assigned(res) then begin
case res^.aType.BaseType of
btSingle: tbtsingle(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btDouble: tbtdouble(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btExtended: tbtextended(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btCHar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
btClass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
btPChar: TBTSTRING(res^.dta^) := Pansichar(RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
{$IFNDEF PS_NOINT64}bts64:
begin
EAX := RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
tbts64(res^.Dta^) := Int64(EAX) shl 32 or EDX;
end;
{$ENDIF}
btVariant, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}
btInterface,
btArray, btrecord, btstring: begin GetPtr(res); RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end;
else
exit;
end;
end else begin
RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
end;
Result := True;
end;
CdStdCall: begin
RegUsage := 3;
for I := Params.Count - 1 downto 0 do begin
if not GetPtr(Params[I]) then exit;
end;
if assigned(_Self) then begin
Stack := StringOfChar(AnsiChar(#0),4) + Stack;
Pointer((@Stack[1])^) := _Self;
end;
if assigned(res) then begin
case res^.aType.BaseType of
btSingle: tbtsingle(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btDouble: tbtdouble(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btExtended: tbtextended(res^.dta^):= RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btChar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
btclass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
btPChar: TBTSTRING(res^.dta^) := Pansichar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
{$IFNDEF PS_NOINT64}bts64:
begin
EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
tbts64(res^.dta^) := Int64(EAX) shl 32 or EDX;
end;
{$ENDIF}
btVariant, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}
btInterface, btArray, btrecord, btstring: begin GetPtr(res); RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end;
else
exit;
end;
end else begin
RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
end;
Result := True;
end;
_RCX := 0;
_RDX := 0;
_R8 := 0;
_R9 := 0;
_XMM0 := 0;
_XMM1 := 0;
_XMM2 := 0;
_XMM3 := 0;
RegUsage := 0;
if assigned(_Self) then begin
RegUsage := 1;
_RCX := Longint(_Self);
end;
for I := 0 to Params.Count - 1 do
begin
if not GetPtr(rp(Params[I])) then Exit;
end;
if assigned(res) then begin
case res^.aType.BaseType of
btWideString, btUnicodeString,
btInterface, btArray, btrecord, btstring, btVariant, btStaticArray: GetPtr(res);
btSet:
begin
if TPSTypeRec_Set(res.aType).aByteSize > PointerSize then GetPtr(res);
end;
end;
if Length(Stack) = 0 then
x64call(Address, _RAX, _RCX, _RDX, _R8, _R9, _XMM0, _XMM1, _XMM2, _XMM3, Stack, 0)
else
x64call(Address, _RAX, _RCX, _RDX, _R8, _R9, _XMM0, _XMM1, _XMM2, _XMM3, @Stack[0], Length(Stack) div 8);
case res^.aType.BaseType of
btSet:
begin
case TPSTypeRec_Set(res.aType).aByteSize of
1: byte(res.Dta^) := _RAX;
2: word(res.Dta^) := _RAX;
3,
4: Longint(res.Dta^) := _RAX;
5,6,7,8: IPointer(res.dta^) := _RAX;
end;
end;
btSingle: tbtsingle(res.Dta^) := _XMM0;
btDouble: tbtdouble(res.Dta^) := _XMM0;
btExtended: tbtextended(res.Dta^) := _XMM0;
btchar,btU8, btS8: tbtu8(res.dta^) := _RAX;
btWideChar, btu16, bts16: tbtu16(res.dta^) := _RAX;
btClass : IPointer(res.dta^) := _RAX;
btu32,bts32: tbtu32(res.dta^) := _RAX;
btPChar: pansichar(res.dta^) := Pansichar(_RAX);
bts64: tbts64(res.dta^) := Int64(_RAX);
btCurrency: tbtCurrency(res.Dta^) := Int64(_RAX);
btInterface,
btVariant,
btWidestring,btUnicodestring,
btStaticArray, btArray, btrecord, btstring :;
else
exit;
end;
end else begin
if Length(Stack) = 0 then
x64call(Address, _RAX, _RCX, _RDX, _R8, _R9, _XMM0, _XMM1, _XMM2, _XMM3, Stack, 0)
else
x64call(Address, _RAX, _RCX, _RDX, _R8, _R9, _XMM0, _XMM1, _XMM2, _XMM3, @Stack[0], Length(Stack) div 8);
end;
Result := True;
finally
for i := CallData.Count -1 downto 0 do
begin
@ -473,7 +351,7 @@ begin
end;
end;
CallData.Free;
end;*)
end;
end;

2
Source/x86.inc
View File

@ -1,4 +1,4 @@
{ implementation of x86 abi }
{ implementation of x86 abi }
function RealFloatCall_Register(p: Pointer;
_EAX, _EDX, _ECX: Cardinal;