freepascal.compiler/compiler/powerpc64/cpupara.pas

{
    Copyright (c) 2002 by Florian Klaempfl

    PowerPC64 specific calling conventions

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 ****************************************************************************
}
unit cpupara;

{$I fpcdefs.inc}

interface

uses
  globtype,
  aasmtai,aasmdata,
  cpubase,
  symconst, symtype, symdef, symsym,
  paramgr, parabase, cgbase, cgutils;

type
  tppcparamanager = class(tparamanager)
    function get_volatile_registers_int(calloption: tproccalloption):
      tcpuregisterset; override;
    function get_volatile_registers_fpu(calloption: tproccalloption):
      tcpuregisterset; override;
    function push_addr_param(varspez: tvarspez; def: tdef; calloption:
      tproccalloption): boolean; override;

    procedure getintparaloc(pd : tabstractprocdef; nr: longint; var cgpara: tcgpara); override;
    function create_paraloc_info(p: tabstractprocdef; side: tcallercallee): longint; override;
    function create_varargs_paraloc_info(p: tabstractprocdef; varargspara:
      tvarargsparalist): longint; override;
    function get_funcretloc(p : tabstractprocdef; side: tcallercallee; forcetempdef: tdef): tcgpara;override;

  private
    procedure init_values(var curintreg, curfloatreg, curmmreg: tsuperregister;
      var cur_stack_offset: aword);
    function create_paraloc_info_intern(p: tabstractprocdef; side:
      tcallercallee; paras: tparalist;
      var curintreg, curfloatreg, curmmreg: tsuperregister; var
        cur_stack_offset: aword; isVararg : boolean): longint;
    function parseparaloc(p: tparavarsym; const s: string): boolean; override;
    procedure create_paraloc_for_def(var para: TCGPara; varspez: tvarspez; paradef: tdef; var nextfloatreg, nextintreg: tsuperregister; var stack_offset: longint; const isVararg, forceintmem: boolean; const side: tcallercallee; const p: tabstractprocdef);
  end;

implementation

uses
  verbose, systems,
  defutil,symtable,symcpu,
  procinfo, cpupi;

function tppcparamanager.get_volatile_registers_int(calloption:
  tproccalloption): tcpuregisterset;
begin
  result := [RS_R0,RS_R3..RS_R12];
  if (target_info.system = system_powerpc64_darwin) then
    include(result,RS_R2);
end;

function tppcparamanager.get_volatile_registers_fpu(calloption:
  tproccalloption): tcpuregisterset;
begin
  result := [RS_F0..RS_F13];
end;

procedure tppcparamanager.getintparaloc(pd : tabstractprocdef; nr: longint; var cgpara: tcgpara);
var
  paraloc: pcgparalocation;
  psym: tparavarsym;
  pdef: tdef;
begin
  psym:=tparavarsym(pd.paras[nr-1]);
  pdef:=psym.vardef;
  if push_addr_param(psym.varspez,pdef,pd.proccalloption) then
    pdef:=getpointerdef(pdef);
  cgpara.reset;
  cgpara.size := def_cgsize(pdef);
  cgpara.intsize := tcgsize2size[cgpara.size];
  cgpara.alignment := get_para_align(pd.proccalloption);
  cgpara.def:=pdef;
  paraloc := cgpara.add_location;
  with paraloc^ do begin
    size := def_cgsize(pdef);
    def := pdef;
    if (nr <= 8) then begin
      if (nr = 0) then
        internalerror(200309271);
      loc := LOC_REGISTER;
      register := newreg(R_INTREGISTER, RS_R2 + nr, R_SUBWHOLE);
    end else begin
      loc := LOC_REFERENCE;
      paraloc^.reference.index := NR_STACK_POINTER_REG;
      reference.offset := sizeof(aint) * (nr - 8);
    end;
  end;
end;

function getparaloc(p: tdef): tcgloc;

begin
  { Later, the LOC_REFERENCE is in most cases changed into LOC_REGISTER
    if push_addr_param for the def is true
  }
  case p.typ of
    orddef:
      result := LOC_REGISTER;
    floatdef:
      result := LOC_FPUREGISTER;
    enumdef:
      result := LOC_REGISTER;
    pointerdef:
      result := LOC_REGISTER;
    formaldef:
      result := LOC_REGISTER;
    classrefdef:
      result := LOC_REGISTER;
    procvardef,
    recorddef:
      result := LOC_REGISTER;
    objectdef:
      if is_object(p) then
        result := LOC_REFERENCE
      else
        result := LOC_REGISTER;
    stringdef:
      if is_shortstring(p) or is_longstring(p) then
        result := LOC_REFERENCE
      else
        result := LOC_REGISTER;
    filedef:
      result := LOC_REGISTER;
    arraydef:
      result := LOC_REFERENCE;
    setdef:
      if is_smallset(p) then
        result := LOC_REGISTER
      else
        result := LOC_REFERENCE;
    variantdef:
      result := LOC_REFERENCE;
    { avoid problems with errornous definitions }
    errordef:
      result := LOC_REGISTER;
  else
    internalerror(2002071001);
  end;
end;

function tppcparamanager.push_addr_param(varspez: tvarspez; def: tdef;
  calloption: tproccalloption): boolean;
begin
  result := false;
  { var,out,constref always require address }
  if varspez in [vs_var, vs_out, vs_constref] then
  begin
    result := true;
    exit;
  end;
  case def.typ of
    variantdef,
    formaldef:
      result := true;
    procvardef,
    recorddef:
      result :=
        ((varspez = vs_const) and
         (
          (not (calloption in [pocall_cdecl, pocall_cppdecl]) and
          (def.size > 8))
         ) or
         (calloption = pocall_mwpascal)
        );
    arraydef:
      result := (tarraydef(def).highrange >= tarraydef(def).lowrange) or
        is_open_array(def) or
        is_array_of_const(def) or
        is_array_constructor(def);
    objectdef:
      result := is_object(def);
    setdef:
      result := not is_smallset(def);
    stringdef:
      result := tstringdef(def).stringtype in [st_shortstring, st_longstring];
  end;
end;

procedure tppcparamanager.init_values(var curintreg, curfloatreg, curmmreg:
  tsuperregister; var cur_stack_offset: aword);
begin
  { register parameter save area begins at 48(r2) }
  cur_stack_offset := 48;
  curintreg := RS_R3;
  curfloatreg := RS_F1;
  curmmreg := RS_M2;
end;

function tppcparamanager.get_funcretloc(p : tabstractprocdef; side:
  tcallercallee; forcetempdef: tdef): tcgpara;
var
  paraloc : pcgparalocation;
  retcgsize  : tcgsize;
begin
  if set_common_funcretloc_info(p,forcetempdef,retcgsize,result) then
    exit;

  paraloc:=result.add_location;
  { Return in FPU register? }
  if result.def.typ=floatdef then
    begin
      paraloc^.loc:=LOC_FPUREGISTER;
      paraloc^.register:=NR_FPU_RESULT_REG;
      paraloc^.size:=retcgsize;
      paraloc^.def:=result.def;
    end
  else
   { Return in register }
    begin
       paraloc^.loc:=LOC_REGISTER;
       if side=callerside then
         paraloc^.register:=newreg(R_INTREGISTER,RS_FUNCTION_RESULT_REG,cgsize2subreg(R_INTREGISTER,retcgsize))
       else
         paraloc^.register:=newreg(R_INTREGISTER,RS_FUNCTION_RETURN_REG,cgsize2subreg(R_INTREGISTER,retcgsize));
       paraloc^.size:=retcgsize;
       paraloc^.def:=result.def;
     end;
end;

function tppcparamanager.create_paraloc_info(p: tabstractprocdef; side:
  tcallercallee): longint;
var
  cur_stack_offset: aword;
  curintreg, curfloatreg, curmmreg : tsuperregister;
begin
  init_values(curintreg, curfloatreg, curmmreg, cur_stack_offset);

  result := create_paraloc_info_intern(p, side, p.paras, curintreg, curfloatreg,
    curmmreg, cur_stack_offset, false);

  create_funcretloc_info(p, side);
end;

function tppcparamanager.create_paraloc_info_intern(p: tabstractprocdef; side:
  tcallercallee; paras: tparalist;
  var curintreg, curfloatreg, curmmreg: tsuperregister; var cur_stack_offset:
  aword; isVararg : boolean): longint;
var
  stack_offset: longint;
  nextintreg, nextfloatreg, nextmmreg : tsuperregister;
  i: integer;
  hp: tparavarsym;
  paraloc: pcgparalocation;
  delphi_nestedfp: boolean;

begin
{$IFDEF extdebug}
  if po_explicitparaloc in p.procoptions then
    internalerror(200411141);
{$ENDIF extdebug}

  result := 0;
  nextintreg := curintreg;
  nextfloatreg := curfloatreg;
  nextmmreg := curmmreg;
  stack_offset := cur_stack_offset;

  for i := 0 to paras.count - 1 do begin
    hp := tparavarsym(paras[i]);

    { Syscall for Morphos can have already a paraloc set; not supported on ppc64 }
    if (vo_has_explicit_paraloc in hp.varoptions) then begin
      internalerror(200412153);
    end;

    { currently only support C-style array of const }
    if (p.proccalloption in [pocall_cdecl, pocall_cppdecl]) and
      is_array_of_const(hp.vardef) then begin
      paraloc := hp.paraloc[side].add_location;
      { hack: the paraloc must be valid, but is not actually used }
      paraloc^.loc := LOC_REGISTER;
      paraloc^.register := NR_R0;
      paraloc^.size := OS_ADDR;
      paraloc^.def := voidpointertype;
      break;
    end;
    delphi_nestedfp:=(vo_is_parentfp in hp.varoptions) and (po_delphi_nested_cc in p.procoptions);
    create_paraloc_for_def(hp.paraloc[side], hp.varspez, hp.vardef,
      nextfloatreg, nextintreg, stack_offset, isVararg, delphi_nestedfp, side, p);
  end;

  curintreg := nextintreg;
  curfloatreg := nextfloatreg;
  curmmreg := nextmmreg;
  cur_stack_offset := stack_offset;
  result := stack_offset;
end;

procedure tppcparamanager.create_paraloc_for_def(var para: TCGPara; varspez: tvarspez; paradef: tdef; var nextfloatreg, nextintreg: tsuperregister; var stack_offset: longint; const isVararg, forceintmem: boolean; const side: tcallercallee; const p: tabstractprocdef);
var
  paracgsize: tcgsize;
  loc: tcgloc;
  paraloc: pcgparalocation;
  { def to use for all paralocs if <> nil }
  alllocdef,
  { def to use for the current paraloc }
  locdef,
  tmpdef: tdef;
  paralen: aint;
  parashift: byte;
  tailpadding,
  firstparaloc,
  paraaligned: boolean;
begin
  alllocdef:=nil;
  locdef:=nil;
  parashift := 0;
  para.reset;
  if push_addr_param(varspez, paradef, p.proccalloption) then begin
    paradef := getpointerdef(paradef);
    loc := LOC_REGISTER;
    paracgsize := OS_ADDR;
    paralen := tcgsize2size[OS_ADDR];
  end else begin
    if not is_special_array(paradef) then
      paralen := paradef.size
    else
      paralen := tcgsize2size[def_cgsize(paradef)];
    { default rules:
      * integer parameters sign/zero-extended to 64 bit
      * floating point register used -> skip equivalent GP register
      * floating point parameters passed as is (32/64 bit)
      * floating point parameters to variable arguments -> in int registers
      * aggregates passed in consecutive integer registers
      * all *aggregate* data in integer registers exactly mirrors the data
        in memory -> on big endian it's left aligned (passed in most
        significant part of the 64 bit word if it's < 64 bit), on little
        endian it's right aligned (least significant part of the 64 bit
        word)

      special rules:

implemented
   |
   | * AIX/ELFv1/SysV ppc64 ABI (big endian only):
   x    a) single precision floats are stored in the second word of a 64 bit
           location when passed on the stack
   x    b) aggregate with 1 floating point element passed like a floating
           point parameter of the same size
   x    c) aggregates smaller than 64 bit are aligned in least significant bits
           of a single 64bit location (incl. register) (AIX exception: it puts
           them in the most significant bits)

      * ELFv2 ppc64 ABI:
   x    a) so-called "homogeneous" aggregates, i.e. struct, arrays, or unions
           that (recursively) contain only elements of the same floating-
           point or vector type, are passed as if those elements were passed as
           separate arguments. This is done for up to 8 such elements.
   x    b) other than a), it's the same as the AIX ppc64 ABI

      * Darwin ppc64 ABI:

      - as in the general case, aggregates in registers mirror their place in
        memory, so if e.g. a struct starts with a 32 bit integer, it's
        placed in the upper 32 bits of a the corresponding register. A plain
        32 bit integer para is however passed in the lower 32 bits, since it
        is promoted to a 64 bit int first (see below)

   x    a) aggregates with sizes 1, 2 and 4 bytes are padded with 0s on the left
          (-> aligned in least significant bits of 64 bit word on big endian) to
          a multiple of *4 bytes* (when passed by memory, don't occupy 8 bytes)
   x    b) other aggregates are padded with 0s on the right (-> aligned in most
           signifcant bits of 64 bit word of integer register) to a multiple of
           *4 bytes*
   x    c) all floating pointer parameters (not in aggregates) are promoted to
           double (doesn't seem to be correct: 8 bytes are reserved in the
           stack frame, but the compiler still stores a single in it (in the
           lower 4 bytes -- like with SysV a) )
   x    d) all integer parameters (not in aggregates) are promoted to 64 bit
  (x)   e) aggregates (incl. arrays) of exactly 16 bytes passed in two integer
           registers
        f) floats in *structures without unions* are processed per rule c)
           (similar for vector fields)
        g) other fields in *structures without unions* are processed
           recursively according to e) / f) if they are aggragates, and h)
           otherwise (i.e, without promotion!)
  (x)   h) everything else (structures with unions and size<>16, arrays with
           size<>16, ...) is passed "normally" in integer registers
    }
    { should the tail be shifted into the most significant bits? }
    tailpadding:=false;
    { have we ensured that the next parameter location will be aligned to the
      next 8 byte boundary? }
    paraaligned:=false;
    { ELFv2 a) }
    if (target_info.abi=abi_powerpc_elfv2) and
       (((paradef.typ=recorddef) and
         tcpurecorddef(paradef).has_single_type_elfv2(tmpdef)) or
        ((paradef.typ=arraydef) and
         tcpuarraydef(paradef).has_single_type_elfv2(tmpdef))) and
       (tmpdef.typ=floatdef { or vectordef }) and
       (paradef.size<=(8*tmpdef.size)) then
      begin
        alllocdef:=tmpdef;
        loc:=getparaloc(alllocdef);
        paracgsize:=def_cgsize(paradef);
      end
    { AIX/ELFv1 b) }
    else if (target_info.abi in [abi_powerpc_aix,abi_powerpc_sysv]) and
       (paradef.typ=recorddef) and
       tabstractrecordsymtable(tabstractrecorddef(paradef).symtable).has_single_field(tmpdef) and
       (tmpdef.typ=floatdef) then
      begin
        paradef:=tmpdef;
        loc:=getparaloc(paradef);
        paracgsize:=def_cgsize(paradef)
      end
    else if (((paradef.typ=arraydef) and not
         is_special_array(paradef)) or
        (paradef.typ=recorddef)) then
      begin
        { should handle Darwin f/g/h) now, but can't model that yet }

        { general rule: aggregate data is aligned in the most significant bits
          except for ELFv1 c) and Darwin a) }
        if (target_info.endian=endian_big) and
           ((target_info.abi in [abi_powerpc_aix,abi_powerpc_elfv2]) or
            ((target_info.abi=abi_powerpc_sysv) and
             (paralen>8)) or
            ((target_info.abi=abi_powerpc_darwin) and
             not(paralen in [1,2,4]))) then
          tailpadding:=true
        { if we don't add tailpadding on the caller side, the callee will have
          to shift the value in the register before it can store it to memory }
        else if (target_info.endian=endian_big) and
           (paralen in [3,5,6,7]) then
          parashift:=(8-paralen)*8;
        { general fallback rule: pass aggregate types in integer registers
          without special adjustments (incl. Darwin h) }
        loc:=LOC_REGISTER;
        paracgsize:=int_cgsize(paralen);
      end
    else
      begin
        loc:=getparaloc(paradef);
        paracgsize:=def_cgsize(paradef);
        { for things like formaldef }
        if (paracgsize=OS_NO) then
          begin
            paracgsize:=OS_ADDR;
            paralen:=tcgsize2size[OS_ADDR];
          end;
      end
  end;

  { patch FPU values into integer registers if we are processing varargs }
  if (isVararg) and (paradef.typ = floatdef) then begin
    loc := LOC_REGISTER;
    if paracgsize = OS_F64 then
      paracgsize := OS_64
    else
      paracgsize := OS_32;
  end;

  { AIX/SysV a), Darwin c) -> skip 4 bytes in the stack frame }
 if (target_info.endian=endian_big) and
    (paradef.typ=floatdef) and
    (tfloatdef(paradef).floattype=s32real) and
    (nextfloatreg>RS_F13) then
   begin
     inc(stack_offset,4);
     paraaligned:=true;
   end;

 { Darwin d) }
  if (target_info.abi=abi_powerpc_darwin) and
     (paradef.typ in [orddef,enumdef]) and
     (paralen<8) and
     { we don't have to sign/zero extend the lower 8/16/32 bit on the callee
       side since it's done on the caller side; however, if the value is
       passed via memory, we do have to modify the stack offset since this
       is big endian and otherwise we'll load/store the wrong bytes) }
     ((side=callerside) or
      forceintmem or
      (nextintreg>RS_R10)) then
     begin
      if side=callerside then
        begin
          paralen:=8;
          paradef:=s64inttype;
          paracgsize:=OS_S64;
        end
      else
        begin
          inc(stack_offset,8-paralen);
          paraaligned:=true;
        end;
    end;

  para.alignment := std_param_align;
  para.size := paracgsize;
  para.intsize := paralen;
  para.def := paradef;
  if (paralen = 0) then
    if (paradef.typ = recorddef) then begin
      paraloc := para.add_location;
      paraloc^.loc := LOC_VOID;
    end else
      internalerror(2005011310);
  if not assigned(alllocdef) then
    locdef:=paradef
  else
    begin
      locdef:=alllocdef;
      paracgsize:=def_cgsize(locdef);
    end;
  firstparaloc:=true;
  { can become < 0 for e.g. 3-byte records }
  while (paralen > 0) do begin
    paraloc := para.add_location;
    { In case of po_delphi_nested_cc, the parent frame pointer
      is always passed on the stack. }
    if (loc = LOC_REGISTER) and
       (nextintreg <= RS_R10) and
       not forceintmem then begin
      paraloc^.loc := loc;
      paraloc^.shiftval := parashift;

      { make sure we don't lose whether or not the type is signed }
      if (paracgsize <> OS_NO) and
         (paradef.typ <> orddef) and
         not assigned(alllocdef) then
        begin
          paracgsize := int_cgsize(paralen);
          locdef:=get_paraloc_def(paradef, paralen, firstparaloc);
        end;

      { Partial aggregate data may have to be left-aligned. If so, add tail
        padding }
      if tailpadding and
         (paralen < sizeof(aint)) then
        begin
          paraloc^.shiftval := (sizeof(aint)-paralen)*(-8);
          paraloc^.size := OS_INT;
          paraloc^.def := u64inttype;
        end
      else if (paracgsize in [OS_NO, OS_128, OS_S128]) then
        begin
          paraloc^.size := OS_INT;
          paraloc^.def := osuinttype;
        end
      else
        begin
          paraloc^.size := paracgsize;
          paraloc^.def := locdef;
        end;

      paraloc^.register := newreg(R_INTREGISTER, nextintreg, R_SUBNONE);
      inc(nextintreg);
      dec(paralen, tcgsize2size[paraloc^.size]);

      inc(stack_offset, sizeof(pint));
    end else if (loc = LOC_FPUREGISTER) and
      (nextfloatreg <= RS_F13) then begin
      paraloc^.loc := loc;
      paraloc^.size := paracgsize;
      paraloc^.def := locdef;
      paraloc^.register := newreg(R_FPUREGISTER, nextfloatreg, R_SUBWHOLE);
      { the PPC64 ABI says that the GPR index is increased for every parameter, no matter
      which type it is stored in }
      inc(nextintreg);
      inc(nextfloatreg);
      dec(paralen, tcgsize2size[paraloc^.size]);

      inc(stack_offset, tcgsize2size[OS_FLOAT]);
    end else if (loc = LOC_MMREGISTER) then begin
      { Altivec not supported }
      internalerror(200510192);
    end else begin
      { either LOC_REFERENCE, or one of the above which must be passed on the
      stack because of insufficient registers }
      paraloc^.loc := LOC_REFERENCE;
      case loc of
        LOC_FPUREGISTER:
          begin
            paraloc^.size:=int_float_cgsize(paralen);
            case paraloc^.size of
              OS_F32: paraloc^.def:=s32floattype;
              OS_F64: paraloc^.def:=s64floattype;
              else
                internalerror(2013060122);
            end;
          end;
        LOC_REGISTER,
        LOC_REFERENCE:
          begin
            paraloc^.size:=int_cgsize(paralen);
            paraloc^.def:=get_paraloc_def(paradef, paralen, firstparaloc);
          end;
        else
          internalerror(2006011101);
      end;
      if (side = callerside) then
        paraloc^.reference.index := NR_STACK_POINTER_REG
      else begin
        { during procedure entry, NR_OLD_STACK_POINTER_REG contains the old stack pointer }
        paraloc^.reference.index := NR_OLD_STACK_POINTER_REG;
        { create_paraloc_info_intern might be also called when being outside of
          code generation so current_procinfo might be not set }
        if assigned(current_procinfo) then
          tppcprocinfo(current_procinfo).needs_frame_pointer := true;
      end;
      paraloc^.reference.offset := stack_offset;

      { align temp contents to next register size }
      if not paraaligned then
        inc(stack_offset, align(paralen, 8))
      else
        inc(stack_offset, paralen);
      paralen := 0;
    end;
    firstparaloc:=false;
  end;
end;

function tppcparamanager.create_varargs_paraloc_info(p: tabstractprocdef;
  varargspara: tvarargsparalist): longint;
var
  cur_stack_offset: aword;
  parasize, l: longint;
  curintreg, firstfloatreg, curfloatreg, curmmreg: tsuperregister;
  i: integer;
  hp: tparavarsym;
  paraloc: pcgparalocation;
begin
  init_values(curintreg, curfloatreg, curmmreg, cur_stack_offset);
  firstfloatreg := curfloatreg;

  result := create_paraloc_info_intern(p, callerside, p.paras, curintreg,
    curfloatreg, curmmreg, cur_stack_offset, false);
  if (p.proccalloption in [pocall_cdecl, pocall_cppdecl, pocall_mwpascal]) then begin
    { just continue loading the parameters in the registers }
    result := create_paraloc_info_intern(p, callerside, varargspara, curintreg,
      curfloatreg, curmmreg, cur_stack_offset, true);
    { varargs routines have to reserve at least 64 bytes for the PPC64 ABI }
    if (result < 64) then
      result := 64;
  end else begin
    parasize := cur_stack_offset;
    for i := 0 to varargspara.count - 1 do begin
      hp := tparavarsym(varargspara[i]);
      hp.paraloc[callerside].alignment := 8;
      paraloc := hp.paraloc[callerside].add_location;
      paraloc^.loc := LOC_REFERENCE;
      paraloc^.size := def_cgsize(hp.vardef);
      paraloc^.def := hp.vardef;
      paraloc^.reference.index := NR_STACK_POINTER_REG;
      l := push_size(hp.varspez, hp.vardef, p.proccalloption);
      paraloc^.reference.offset := parasize;
      parasize := parasize + l;
    end;
    result := parasize;
  end;
  if curfloatreg <> firstfloatreg then
    include(varargspara.varargsinfo, va_uses_float_reg);
end;

function tppcparamanager.parseparaloc(p: tparavarsym; const s: string): boolean;
begin
  { not supported/required for PowerPC64-linux target }
  internalerror(200404182);
  result := true;
end;


begin
  paramanager := tppcparamanager.create;
end.