1
0
mirror of https://github.com/moparisthebest/Simba synced 2024-08-13 16:53:59 -04:00
Simba/Units/PascalScript/x64.inc
2010-03-12 18:10:10 +01:00

668 lines
16 KiB
PHP

{ implementation of x64 abi }
//procedure DebugBreak; external 'Kernel32.dll';
const
EmptyPchar: array[0..0] of char = #0;
{$ASMMODE INTEL}
{$IFDEF WINDOWS}
procedure x64call(
Address: Pointer;
out _RAX: IPointer;
_RCX, _RDX, _R8, _R9: IPointer;
var _XMM0: Double;
_XMM1, _XMM2, _XMM3: Double;
aStack: Pointer; aItems: Integer); assembler; nostackframe;
asm
(* Registers:
RCX: Address
RDX: *_RAX
R8: _RCX
R9: _RDX
fpc inserts an 20h emty space
*)
push rbp
mov rbp,rsp
// call debugbreak
push rcx // address
push rdx // _rax
push r8 // _rcx
push r9 // _rdx
mov rcx, aItems
mov rdx, aStack
jmp @compareitems
@work:
push [rdx]
dec rcx
sub rdx,8
@compareitems:
or rcx, rcx
jnz @work
// copy registers
movd xmm0,[_XMM0]
movd xmm1,_XMM1
movd xmm2,_XMM2
movd xmm3,_XMM3
mov RAX, [rbp-8]
mov RCX, [rbp-24]
mov RDX, [rbp-32]
mov R8, _R8
mov R9, _R9
// weird thing on windows, it needs 32 bytes in the CALLEE side to do whatever in
sub RSP, 32
call RAX
add RSP, 32 // undo the damage done earlier
// copy result back
mov RDX, [rbp-16]
mov [RDX], RAX
movd [_XMM0],xmm0
pop r9
pop r8
pop rdx
pop rcx
leave
ret
end;
{$ELSE}
type
TRegisters = packed record
_RDI, // 0
_RSI, // 8
_RDX, // 16
_RCX, // 24
_R8, // 32
_R9: IPointer; // 40
_XMM1, // 48
_XMM2, // 56
_XMM3, // 64
_XMM4, // 72
_XMM5, // 80
_XMM6, // 88
_XMM7: Double; // 96
SingleBits: Integer; //104
end;
procedure x64call(
Address: Pointer;
out _RAX: IPointer;
var Registers: TRegisters;
aStack: Pointer; aItems: Integer; var _XMM0: Double); assembler; nostackframe;
asm
(* Registers:
RDI: Address
RSI: _RAX
RDX: Registers
RCX: aStack
R8: aItems
R9: XMM0
rbp-8 addr
rbp-16 _rax
rbp-24 _xmm0
rbp-32 regs
*)
push rbp
mov rbp,rsp
push rdi // address
push rsi // _rax
push r9 // xmm0
push rdx
{$IFDEF PS_STACKALIGN}
bt r8, 0
jnc @skipjump
sub rsp, 8
@skipjump:
{$ENDIF}
mov rax, rdx
jmp @compareitems
@work:
push [rcx]
dec r8
sub rcx,8
@compareitems:
or r8, r8
jnz @work
// copy registers
// xmm0
mov rdx,[rbp-24]
bt [rax+104], 0
jnc @skipxmm0
cvtsd2ss xmm0,[rdx]
jmp @skipxmm0re
@skipxmm0:
movd xmm0,[rdx]
@skipxmm0re:
// xmm1
bt [rax+104], 1
jnc @skipxmm1
cvtsd2ss xmm1,[rax+48]
jmp @skipxmm1re
@skipxmm1:
movd xmm1,[rax+48]
@skipxmm1re:
// xmm2
bt [rax+104], 2
jnc @skipxmm2
cvtsd2ss xmm2,[rax+56]
jmp @skipxmm2re
@skipxmm2:
movd xmm2,[rax+56]
@skipxmm2re:
// xmm3
bt [rax+104], 3
jnc @skipxmm3
cvtsd2ss xmm3,[rax+64]
jmp @skipxmm3re
@skipxmm3:
movd xmm3,[rax+64]
@skipxmm3re:
// xmm4
bt [rax+104], 4
jnc @skipxmm4
cvtsd2ss xmm4,[rax+72]
jmp @skipxmm4re
@skipxmm4:
movd xmm4,[rax+72]
@skipxmm4re:
// xmm5
bt [rax+104], 5
jnc @skipxmm5
cvtsd2ss xmm5,[rax+80]
jmp @skipxmm5re
@skipxmm5:
movd xmm5,[rax+80]
@skipxmm5re:
// xmm6
bt [rax+104], 6
jnc @skipxmm6
cvtsd2ss xmm6,[rax+88]
jmp @skipxmm6re
@skipxmm6:
movd xmm6,[rax+88]
@skipxmm6re:
// xmm7
bt [rax+104], 7
jnc @skipxmm7
cvtsd2ss xmm7,[rax+96]
jmp @skipxmm7re
@skipxmm7:
movd xmm7,[rax+96]
@skipxmm7re:
mov RDI, [rax]
mov RSI, [rax+ 8]
mov RDX, [rax+16]
mov RCX, [rax+24]
mov R8, [rax+32]
mov R9, [rax+40]
// weird thing on windows, it needs 32 bytes in the CALLEE side to do whatever in; not sure about linux
//sub RSP, 32
mov rax, [rbp-8]
call RAX
// add rsp, 8
// add RSP, 32 // undo the damage done earlier
// copy result back
mov rsi, [rbp-16]
mov [rsi], RAX
mov rsi, [rbp-24]
// xmm0 res
mov rax, [rbp-32]
bt [rax+104], 8
jnc @skipres
cvtss2sd xmm1,xmm0
movd [rsi],xmm1
jmp @skipresre
@skipres:
movd [rsi],xmm0
@skipresre:
pop rdx
pop r9 // xmm0
pop rsi // _rax
pop rdi // address
leave
ret
end;
{$ENDIF}
function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
var
Stack: array of Byte;
_RAX: IPointer;
{$IFDEF WINDOWS}
_RCX, _RDX, _R8, _R9: IPointer;
_XMM0, _XMM1, _XMM2, _XMM3: Double;
{$ELSE}
_XMM0: Double;
Registers: TRegisters;
RegUsageFloat: Byte;
{$ENDIF}
RegUsage: Byte;
CallData: TPSList;
I: Integer;
pp: ^Byte;
function rp(p: PPSVariantIFC): PPSVariantIFC;
begin
if p = nil then
begin
result := nil;
exit;
end;
if p.aType.BaseType = btPointer then
begin
p^.aType := Pointer(Pointer(IPointer(p^.dta) + PointerSize)^);
p^.Dta := Pointer(p^.dta^);
end;
Result := p;
end;
{$IFDEF WINDOWS}
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)-8];
IPointer(p^) := data;
end;
end;
end;
{$ELSE}
procedure StoreReg(data: IPointer); overload;
var p: Pointer;
begin
case RegUsage of
0: begin inc(RegUsage); Registers._RDI:=Data; end;
1: begin inc(RegUsage); Registers._RSI:=Data; end;
2: begin inc(RegUsage); Registers._RDX:=Data; end;
3: begin inc(RegUsage); Registers._RCX:=Data; end;
4: begin inc(RegUsage); Registers._R8:=Data; end;
5: begin inc(RegUsage); Registers._R9:=Data; end;
else begin
SetLength(Stack, Length(Stack)+8);
p := @Stack[LEngth(Stack)-8];
IPointer(p^) := data;
end;
end;
end;
{$ENDIF}
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];
Move(aData, p^, Len);
end;
{$IFDEF WINDOWS}
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)-8];
Double(p^) := data;
end;
end;
end;
{$ELSE}
procedure StoreReg(data: Double); overload;
var p: Pointer;
begin
case RegUsageFloat of
0: begin inc(RegUsageFloat); _XMM0:=Data; end;
1: begin inc(RegUsageFloat); Registers._XMM1:=Data; end;
2: begin inc(RegUsageFloat); Registers._XMM2:=Data; end;
3: begin inc(RegUsageFloat); Registers._XMM3:=Data; end;
4: begin inc(RegUsageFloat); Registers._XMM4:=Data; end;
5: begin inc(RegUsageFloat); Registers._XMM5:=Data; end;
6: begin inc(RegUsageFloat); Registers._XMM6:=Data; end;
7: begin inc(RegUsageFloat); Registers._XMM7:=Data; end;
else begin
SetLength(Stack, Length(Stack)+8);
p := @Stack[LEngth(Stack)-8];
Double(p^) := data;
end;
end;
end;
procedure StoreReg(data: Single); overload;
var p: Pointer;
begin
case RegUsageFloat of
0: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 1; _XMM0:=Data; end;
1: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 2; Registers._XMM1:=Data; end;
2: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 4; Registers._XMM2:=Data; end;
3: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 8; Registers._XMM3:=Data; end;
4: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 16; Registers._XMM4:=Data; end;
5: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 32; Registers._XMM5:=Data; end;
6: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 64; Registers._XMM6:=Data; end;
7: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 128; Registers._XMM7:=Data; end;
else begin
SetLength(Stack, Length(Stack)+8);
p := @Stack[LEngth(Stack)-8];
Double(p^) := data;
end;
end;
end;
{$ENDIF}
function GetPtr(fVar: PPSVariantIFC): Boolean;
var
varPtr: Pointer;
//UseReg: Boolean;
//tempstr: tbtstring;
p: Pointer;
begin
Result := False;
if FVar = nil then exit;
if fVar.VarParam then
begin
case fvar.aType.BaseType of
btArray:
begin
if Copy(fvar.aType.ExportName, 1, 10) = '!OPENARRAY' then
begin
p := CreateOpenArray(True, Self, FVar);
if p = nil then exit;
CallData.Add(p);
StoreReg(IPointer(POpenArray(p)^.Data));
StoreReg(IPointer(POpenArray(p)^.ItemCount -1));
Result := True;
Exit;
end else begin
varptr := fvar.Dta;
// Exit;
end;
end;
btVariant,
btSet,
btStaticArray,
btRecord,
btInterface,
btClass,
{$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, {$ENDIF} btU8, btS8, btU16,
btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency
{$IFNDEF PS_NOINT64}, bts64{$ENDIF}:
begin
Varptr := fvar.Dta;
end;
else begin
exit; //invalid type
end;
end; {case}
StoreReg(IPointer(VarPtr));
end else begin
// UseReg := True;
case fVar^.aType.BaseType of
btSet:
begin
case TPSTypeRec_Set(fvar.aType).aByteSize of
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
StoreReg(IPointer(fvar.Dta));
end;
end;
btArray:
begin
if Copy(fvar^.aType.ExportName, 1, 10) = '!OPENARRAY' then
begin
p := CreateOpenArray(False, SElf, FVar);
if p =nil then exit;
CallData.Add(p);
StoreReg(IPointer(POpenArray(p)^.Data));
StoreReg(IPointer(POpenArray(p)^.ItemCount -1));
Result := True;
exit;
end else begin
{$IFDEF FPC}
StoreReg(IPointer(FVar.Dta));
{$ELSE}
StoreReg(IPointer(FVar.Dta^));
{$ENDIF}
end;
end;
btRecord:
begin
if fvar^.aType.RealSize <= sizeof(IPointer) then
StoreReg(IPointer(fvar.dta^))
else
StoreReg(IPointer(fVar.Dta));
end;
btVariant
, btStaticArray:
begin
StoreReg(IPointer(fVar.Dta));
end;
btExtended, btDouble: {8 bytes} begin
StoreReg(double(fvar.dta^));
end;
btCurrency: {8 bytes} begin
StoreReg(IPointer(fvar.dta^));
end;
btSingle: {4 bytes} begin
StoreReg(single(fvar.dta^));
end;
btChar,
btU8,
btS8: begin
StoreReg(IPointer(byte(fVar^.dta^)));
end;
btWideChar,
btu16, btS16: begin
StoreReg(IPointer(word(fVar^.dta^)));
end;
btu32, bts32: begin
StoreReg(IPointer(cardinal(fVar^.dta^)));
end;
btPchar:
begin
if pointer(fvar^.dta^) = nil then
StoreReg(IPointer(@EmptyPchar))
else
StoreReg(IPointer(fvar^.dta^));
end;
btclass, btinterface, btString:
begin
StoreReg(IPointer(fvar^.dta^));
end;
btWideString: begin
StoreReg(IPointer(fvar^.dta^));
end;
btUnicodeString: begin
StoreReg(IPointer(fvar^.dta^));
end;
btProcPtr:
begin
GetMem(p, PointerSize2);
TMethod(p^) := MKMethod(Self, Longint(FVar.Dta^));
StoreStack(p^, Pointersize2);
FreeMem(p);
end;
bts64:
begin
StoreReg(IPointer(int64(fvar^.dta^)));
end;
end; {case}
end;
Result := True;
end;
begin
InnerfuseCall := False;
if Address = nil then
exit; // need address
SetLength(Stack, 0);
CallData := TPSList.Create;
res := rp(res);
if res <> nil then
res.VarParam := true;
try
{$IFNDEF WINDOWS}
(*_RSI := 0;
_RDI := 0;
_XMM4 := 0;
_XMM5 := 0;
_XMM6 := 0;
_XMM7 := 0;*)
FillChar(Registers, Sizeof(REgisters), 0);
_XMM0 := 0;
RegUsageFloat := 0;
{$ELSE}
_RCX := 0;
_RDX := 0;
_R8 := 0;
_R9 := 0;
_XMM0 := 0;
_XMM1 := 0;
_XMM2 := 0;
_XMM3 := 0;
{$ENDIF}
_RAX := 0;
RegUsage := 0;
if assigned(_Self) then begin
StoreReg(IPointer(_Self));
end;
{$IFNDEF WINDOWS}
if assigned(res) and (res^.atype.basetype = btSingle) then begin
Registers.Singlebits := Registers.Singlebits or 256;
end;
{$ENDIF}
{$IFDEF PS_RESBEFOREPARAMETERS}
if assigned(res) then begin
case res^.aType.BaseType of
{$IFDEF x64_string_result_as_varparameter}
btstring, btWideString, btUnicodeString,
{$ENDIF}
btInterface, btArray, btVariant, btStaticArray:
GetPtr(res);
btSet:
begin
if res.aType.RealSize > PointerSize then GetPtr(res);
end;
end;
end;
{$ENDIF}
for I := 0 to Params.Count - 1 do
begin
if not GetPtr(rp(Params[I])) then Exit;
end;
if assigned(res) then begin
{$IFNDEF PS_RESBEFOREPARAMETERS}
case res^.aType.BaseType of
{$IFDEF x64_string_result_as_varparameter}
btstring, btWideString, btUnicodeString,
{$ENDIF}
btInterface, btArray, btVariant, btStaticArray:
GetPtr(res);
btSet:
begin
if res.aType.RealSize > PointerSize then GetPtr(res);
end;
end;
{$ENDIF}
if Stack = nil then pp := nil else pp := @Stack[Length(Stack) -8];
{$IFDEF WINDOWS}
x64call(Address, _RAX, _RCX, _RDX, _R8, _R9, _XMM0, _XMM1, _XMM2, _XMM3, pp, Length(Stack) div 8);
{$ELSE}
x64call(Address, _RAX, Registers, pp, Length(Stack) div 8, _XMM0);
{$ENDIF}
case res^.aType.BaseType of
btRecord, btSet:
begin
case res.aType.RealSize 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,
{$IFDEF x64_string_result_as_varparameter}
btWidestring,btUnicodestring, btstring ,
{$ENDIF}
btStaticArray, btArray:;
{$IFNDEF x64_string_result_as_varparameter}
btUnicodeString, btWideString, btstring: Int64(res.dta^) := _RAX;
{$ENDIF}
else
exit;
end;
end else begin
if Stack = nil then pp := nil else pp := @Stack[Length(Stack) -8];
{$IFDEF WINDOWS}
x64call(Address, _RAX, _RCX, _RDX, _R8, _R9, _XMM0, _XMM1, _XMM2, _XMM3, pp, Length(Stack) div 8);
{$ELSE}
x64call(Address, _RAX, Registers, pp, Length(Stack) div 8, _XMM0);
{$ENDIF}
end;
Result := True;
finally
for i := CallData.Count -1 downto 0 do
begin
pp := CallData[i];
case pp^ of
0: DestroyOpenArray(Self, Pointer(pp));
end;
end;
CallData.Free;
end;
end;