mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-10-31 08:21:39 +01:00
422 lines
12 KiB
PHP
422 lines
12 KiB
PHP
{ implementation of the powerpc osx abi for function calls in pascal script
|
|
Copyright (c) 2007 by Henry Vermaak (henry.vermaak@gmail.com) }
|
|
|
|
{$ifndef darwin}
|
|
{$WARNING This code is Darwin specific at the moment!}
|
|
{$endif}
|
|
|
|
{$ifndef cpu32}
|
|
{$WARNING This code is 32bit specific at the moment!}
|
|
{$endif}
|
|
// FPC does not always push a copy of r3 - r10 to the stack (24(r1) - 52(r1)
|
|
// The API states that the space must be reserved, if the regiser contents are not placed there.
|
|
{$define NeedRegCopyOnStack}
|
|
const
|
|
rtINT = 0;
|
|
rtINT64 = 1;
|
|
rtFLOAT = 2;
|
|
|
|
type
|
|
Trint = array[1..8] of dword;
|
|
Trfloat = array[1..13] of double;
|
|
|
|
{$goto on}
|
|
{ define labels }
|
|
label
|
|
rfloat_loop,
|
|
stack_loop,
|
|
load_regs,
|
|
int_result,
|
|
int64_result,
|
|
float_result,
|
|
asmcall_end;
|
|
|
|
{ call a function from a pointer }
|
|
{ resulttype: 0 = int, 1 = int64, 2 = float }
|
|
function ppcasmcall(rint: Trint; rfloat: Trfloat; proc, stack: pointer; stacksize, resulttype: integer): pointer; assembler; nostackframe;
|
|
asm
|
|
mflr r0
|
|
stw r0, 8(r1)
|
|
|
|
{ save non-volatile register/s - make sure the stack size is sufficient! }
|
|
stw r31, -4(r1) { stacksize }
|
|
|
|
stwu r1, -240(r1) { create stack }
|
|
|
|
{ get all the params into the stack }
|
|
stw r3, 48(r1) { rint }
|
|
stw r4, 52(r1) { rfloat }
|
|
stw r5, 56(r1) { proc }
|
|
stw r6, 60(r1) { stack }
|
|
stw r7, 64(r1) { stacksize }
|
|
stw r8, 68(r1) { resulttype }
|
|
{ result is stored in 72(r1) and 76(r1) (if returning int64) }
|
|
|
|
{ write rint array into stack }
|
|
lwz r2, 48(r1) { rint }
|
|
lfd f0, 0(r2)
|
|
stfd f0, 80(r1) { rint[1], rint[2] }
|
|
lfd f0, 8(r2)
|
|
stfd f0, 88(r1) { rint[3], rint[4] }
|
|
lfd f0, 16(r2)
|
|
stfd f0, 96(r1) { rint[5], rint[6] }
|
|
lfd f0, 24(r2)
|
|
stfd f0, 104(r1) { rint[7], rint[8] }
|
|
|
|
{ write rfloat array into stack }
|
|
lwz r2, 52(r1) { rfloat }
|
|
addi r4, r1, 112 { rfloat[1] from here upwards (8 bytes apart) }
|
|
subi r2, r2, 8 { src }
|
|
subi r4, r4, 8 { dest }
|
|
li r3, 13 { counter }
|
|
|
|
rfloat_loop:
|
|
subic. r3, r3, 1 { dec counter }
|
|
lfdu f0, 8(r2) { load rfloat[x] + update }
|
|
stfdu f0, 8(r4) { store rfloat[x] + update }
|
|
bne cr0, rfloat_loop
|
|
|
|
{ create new stack }
|
|
mflr r0
|
|
stw r0, 8(r1)
|
|
mr r12, r1 { remember previous stack to fill in regs later }
|
|
|
|
lwz r31, 64(r12) { load stacksize into r31 }
|
|
neg r3, r31 { negate }
|
|
stwux r1, r1, r3 { create new stack }
|
|
|
|
{ build up the stack here }
|
|
mr r3, r31 { counter }
|
|
subic. r3, r3, 24 { don't write first 24 }
|
|
ble cr0, load_regs { don't fill in stack if there is none }
|
|
|
|
lwz r2, 60(r12) { pointer to stack }
|
|
addi r2, r2, 24 { start of params }
|
|
subi r2, r2, 1 { src }
|
|
|
|
addi r4, r1, 24 { start of params }
|
|
subi r4, r4, 1 { dest }
|
|
|
|
stack_loop:
|
|
subic. r3, r3, 1 { dec counter }
|
|
lbzu r5, 1(r2) { load stack + update }
|
|
stbu r5, 1(r4) { store stack + update }
|
|
bne cr0, stack_loop
|
|
|
|
load_regs: { now load the registers from the previous stack in r12 }
|
|
lwz r3, 80(r12)
|
|
lwz r4, 84(r12)
|
|
lwz r5, 88(r12)
|
|
lwz r6, 92(r12)
|
|
lwz r7, 96(r12)
|
|
lwz r8, 100(r12)
|
|
lwz r9, 104(r12)
|
|
lwz r10, 108(r12)
|
|
|
|
lfd f1, 112(r12)
|
|
lfd f2, 120(r12)
|
|
lfd f3, 128(r12)
|
|
lfd f4, 136(r12)
|
|
lfd f5, 144(r12)
|
|
lfd f6, 152(r12)
|
|
lfd f7, 160(r12)
|
|
lfd f8, 168(r12)
|
|
lfd f9, 176(r12)
|
|
lfd f10, 184(r12)
|
|
lfd f11, 192(r12)
|
|
lfd f12, 200(r12)
|
|
lfd f13, 208(r12)
|
|
|
|
{ now call this function }
|
|
lwz r2, 56(r12) { proc }
|
|
mtctr r2 { move to ctr }
|
|
bctrl { branch and link to ctr }
|
|
|
|
{ restore stack - use stacksize in r31 }
|
|
add r1, r1, r31
|
|
lwz r0, 8(r1)
|
|
mtlr r0
|
|
|
|
{ check resulttype and put appropriate pointer into r3 }
|
|
lwz r2, 68(r1) { resulttype }
|
|
cmpwi cr0, r2, 0 { int result? }
|
|
beq cr0, int_result { branch if equal }
|
|
|
|
cmpwi cr0, r2, 1 { single result? }
|
|
beq cr0, int64_result { branch if equal }
|
|
|
|
|
|
float_result: { the result is a double}
|
|
stfd f1, 72(r1) { write f1 to result on stack }
|
|
b asmcall_end
|
|
|
|
|
|
int64_result: { the result is a single }
|
|
stw r3, 72(r1) { write high dword to result on stack }
|
|
stw r4, 76(r1) { write low dword to result on stack }
|
|
b asmcall_end
|
|
|
|
|
|
int_result: { the result is dword }
|
|
stw r3, 72(r1) { write r3 to result on stack }
|
|
|
|
|
|
asmcall_end: { epilogue }
|
|
addi r3, r1, 72 { pointer to result on the stack }
|
|
addi r1, r1, 240 { restore stack }
|
|
|
|
{ restore non-volatile register/s }
|
|
lwz r31, -4(r1)
|
|
|
|
lwz r0, 8(r1)
|
|
mtlr r0
|
|
blr
|
|
end;
|
|
|
|
function FlipHiLo(v: byte): byte;
|
|
var
|
|
i: integer;
|
|
j, k: byte;
|
|
begin
|
|
Result := 0;
|
|
k := $80;
|
|
j := $01;
|
|
for i := 0 to 7 do begin
|
|
if (v and k) <> 0 then
|
|
Result := Result or j;
|
|
k := k div 2;
|
|
j := j * 2;
|
|
end;
|
|
end;
|
|
|
|
function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
|
|
var
|
|
rint: Trint; { registers r3 to r10 }
|
|
rfloat: Trfloat; { registers f1 to f13 }
|
|
st: packed array of byte; { stack }
|
|
i, j, n, m, rindex, findex, stindex: integer;
|
|
fvar: PPSVariantIFC;
|
|
IsConstructor: Boolean;
|
|
fSetHelper: dword;
|
|
fSetP1, fsetP2: PByte;
|
|
|
|
{ add a dword to stack }
|
|
procedure addstackdword(value: dword);
|
|
begin
|
|
{$ifndef NeedRegCopyOnStack}
|
|
if stindex = 0 then begin
|
|
stindex := 56; // leave empty space for registers on stack
|
|
end;
|
|
{$endif}
|
|
setlength(st, stindex+4);
|
|
pdword(@st[stindex])^ := value;
|
|
inc(stindex, 4);
|
|
end;
|
|
|
|
{ add a float to stack }
|
|
procedure addstackfloat(value: pointer; size: integer);
|
|
begin
|
|
{$ifndef NeedRegCopyOnStack}
|
|
if stindex = 0 then begin
|
|
stindex := 56; // leave empty space for registers on stack
|
|
end;
|
|
{$endif}
|
|
setlength(st, stindex + (size * 4));
|
|
if size = 1
|
|
then psingle(@st[stindex])^ := single(value^)
|
|
else pdouble(@st[stindex])^ := double(value^);
|
|
inc(stindex, size*4);
|
|
end;
|
|
|
|
{ add to the general registers or overflow to stack }
|
|
procedure addgen(value: dword);
|
|
begin
|
|
if rindex <= 8
|
|
then begin
|
|
rint[rindex] := value;
|
|
inc(rindex);
|
|
{$ifdef NeedRegCopyOnStack}
|
|
addstackdword(value);
|
|
{$endif}
|
|
end
|
|
else begin
|
|
addstackdword(value);
|
|
end;
|
|
end;
|
|
{ add to the float registers or overflow to stack }
|
|
{ size = 1 for single, 2 for double }
|
|
procedure addfloat(value: pointer; size: integer);
|
|
begin
|
|
if findex <= 13
|
|
then begin
|
|
if size = 1
|
|
then rfloat[findex] := single(value^)
|
|
else rfloat[findex] := double(value^);
|
|
inc(findex);
|
|
inc(rindex, size);
|
|
{$ifdef NeedRegCopyOnStack}
|
|
addstackfloat(value, size);
|
|
{$endif}
|
|
end
|
|
else begin
|
|
addstackfloat(value, size);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
|
|
{$ifndef darwin}
|
|
raise exception.create('This code is Darwin specific at the moment!');
|
|
{$endif}
|
|
|
|
{$ifndef cpu32}
|
|
raise exception.create('This code is 32bit specific at the moment!');
|
|
{$endif}
|
|
|
|
if (Integer(CallingConv) and 64) <> 0 then begin
|
|
IsConstructor := true;
|
|
CAllingConv := TPSCallingConvention(Integer(CallingConv) and not 64);
|
|
end else IsConstructor := false;
|
|
|
|
rindex := 1;
|
|
findex := 1;
|
|
{$ifdef NeedRegCopyOnStack}
|
|
stindex := 24;
|
|
{$else}
|
|
stindex := 0; // do not create a stack, if only registers are used
|
|
{$endif}
|
|
setlength(st, stindex);
|
|
Result := False;
|
|
|
|
if assigned(_Self) then begin
|
|
addgen(dword(_Self));
|
|
end;
|
|
|
|
{ the pointer of the result needs to be passed first in the case of some result types }
|
|
if assigned(res)
|
|
then begin
|
|
case res.atype.basetype of
|
|
btStaticArray, btRecord, btString: addgen(dword(res.dta));
|
|
end;
|
|
end;
|
|
|
|
{ process all parameters }
|
|
for i := 0 to Params.Count-1 do begin
|
|
if Params[i] = nil
|
|
then Exit;
|
|
fvar := Params[i];
|
|
|
|
{ cook dynamic arrays - fpc stores size-1 at @array-4 }
|
|
if (fvar.aType.BaseType = btArray)
|
|
then dec(pdword(pointer(fvar.dta^)-4)^);
|
|
|
|
if fvar.varparam
|
|
then begin { var param }
|
|
case fvar.aType.BaseType of
|
|
{ add var params here }
|
|
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
|
|
{$IFNDEF PS_NOINT64}, bts64{$ENDIF}: addgen(dword(fvar.dta)); { TODO: test all }
|
|
else begin
|
|
writeln(stderr, 'Parameter type not recognised!');
|
|
Exit;
|
|
end;
|
|
end; { case }
|
|
end else begin { not a 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
|
|
// {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: writeln('normal param');
|
|
|
|
{ add normal params here }
|
|
btString: addgen(dword(pstring(fvar.dta)^));
|
|
btU8, btS8: addgen(dword(pbyte(fvar.dta)^));
|
|
btU16, BtS16: addgen(dword(pword(fvar.dta)^));
|
|
btU32, btS32: addgen(dword(pdword(fvar.dta)^));
|
|
btSingle: addfloat(fvar.dta, 1);
|
|
btDouble, btExtended: addfloat(fvar.dta, 2);
|
|
btPChar: addgen(dword(ppchar(fvar.dta)^));
|
|
btChar: addgen(dword(pchar(fvar.dta)^));
|
|
{$IFNDEF PS_NOINT64}bts64:{$ENDIF} begin
|
|
addgen(dword(pint64(fvar.dta)^ shr 32));
|
|
addgen(dword(pint64(fvar.dta)^ and $ffffffff));
|
|
end;
|
|
btStaticArray: addgen(dword(fvar.dta));
|
|
btRecord: for j := 0 to (fvar.atype.realsize div 4)-1 do
|
|
addgen(pdword(fvar.dta + j*4)^);
|
|
btArray: addgen(dword(fvar.dta^));
|
|
btSet: begin
|
|
|
|
fSetP1 := fvar.dta;
|
|
fSetP2 := @fSetHelper;
|
|
fSetHelper := 0;
|
|
for n := 1 to TPSTypeRec_Set(fvar.aType).aByteSize do
|
|
begin
|
|
fSetP2^ := fliphilo(fSetP1^);
|
|
inc(fSetP1);
|
|
inc(fSetP2);
|
|
if n and 3 = 0
|
|
then begin
|
|
addgen(fSetHelper);
|
|
fSetP2 := @fSetHelper;
|
|
fSetHelper := 0;
|
|
end;
|
|
end;
|
|
if TPSTypeRec_Set(fvar.aType).aByteSize and 3 <> 0
|
|
then addgen(fSetHelper);
|
|
|
|
end;
|
|
|
|
{ TODO add and test }
|
|
{ btVariant, btSet, btInterface, btClass }
|
|
|
|
else begin
|
|
writeln(stderr, 'Parameter type not implemented!');
|
|
Exit;
|
|
end;
|
|
end; { case }
|
|
end; { else }
|
|
end; { for }
|
|
|
|
if (stindex mod 16) <> 0 then begin
|
|
stindex := stindex + 16 - (stindex mod 16);
|
|
setlength(st, stindex);
|
|
end;
|
|
|
|
if not assigned(res)
|
|
then begin
|
|
ppcasmcall(rint, rfloat, address, st, stindex, rtINT); { ignore return }
|
|
end
|
|
else begin
|
|
case res.atype.basetype of
|
|
{ add result types here }
|
|
btString: ppcasmcall(rint, rfloat, address, st, stindex, rtINT);
|
|
btU8, btS8: pbyte(res.dta)^ := byte(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^);
|
|
btU16, btS16: pword(res.dta)^ := word(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^);
|
|
btU32, btS32: pdword(res.dta)^ := pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^;
|
|
btSingle: psingle(res.dta)^ := pdouble(ppcasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^;
|
|
btDouble, btExtended: pdouble(res.dta)^ := pdouble(ppcasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^;
|
|
btPChar: ppchar(res.dta)^ := pchar(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^);
|
|
btChar: pchar(res.dta)^ := char(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^);
|
|
btStaticArray, btRecord: ppcasmcall(rint, rfloat, address, st, stindex, rtINT);
|
|
btArray: res.dta := ppcasmcall(rint, rfloat, address, st, stindex, rtINT);
|
|
|
|
{ TODO add and test }
|
|
|
|
else begin
|
|
writeln(stderr, 'Result type not implemented!');
|
|
exit;
|
|
end; { else }
|
|
end; { case }
|
|
end;
|
|
|
|
{ cook dynamic arrays - fpc stores size-1 at @array-4 }
|
|
for i := 0 to Params.Count-1 do begin
|
|
fvar := Params[i];
|
|
if (fvar.aType.BaseType = btArray)
|
|
then inc(pdword(pointer(fvar.dta^)-4)^);
|
|
end;
|
|
|
|
Result := True;
|
|
end;
|