fpc/compiler/llvm/hlcgllvm.pas
Jonas Maebe ab581c5c30 LLVM: override thlcgobj.g_undefined_ok
Uses the freeze instruction available in LLVM 10.0+. If we don't freeze undef/
poison values before using them in a calculation (even if that calculation is
something like "and 0", which masks the result completely), the result will
still be undef/poison and will keep propagating.
2023-01-20 21:07:18 +01:00

2330 lines
92 KiB
ObjectPascal

{
Copyright (c) 2010, 2013 by Jonas Maebe
Member of the Free Pascal development team
This unit implements the LLVM high level code generator
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 hlcgllvm;
{$i fpcdefs.inc}
interface
uses
globtype,cclasses,
aasmbase,aasmdata,
symbase,symconst,symtype,symdef,symsym,
cpubase, hlcgobj, cgbase, cgutils, parabase, tgobj;
type
{ thlcgllvm }
thlcgllvm = class(thlcgobj)
constructor create;
procedure a_load_reg_cgpara(list: TAsmList; size: tdef; r: tregister; const cgpara: TCGPara); override;
procedure a_load_ref_cgpara(list: TAsmList; size: tdef; const r: treference; const cgpara: TCGPara); override;
procedure a_load_undefined_cgpara(list: TAsmList; size: tdef; const cgpara: TCGPara); override;
procedure a_load_const_cgpara(list: TAsmList; tosize: tdef; a: tcgint; const cgpara: TCGPara); override;
protected
procedure a_load_ref_cgpara_init_src(list: TAsmList; const para: tcgpara; const initialref: treference; var refsize: tdef; out newref: treference);
public
procedure getcpuregister(list: TAsmList; r: Tregister); override;
procedure ungetcpuregister(list: TAsmList; r: Tregister); override;
procedure alloccpuregisters(list: TAsmList; rt: Tregistertype; const r: Tcpuregisterset); override;
procedure allocallcpuregisters(list: TAsmList); override;
procedure deallocallcpuregisters(list: TAsmList); override;
procedure recordnewsymloc(list: TAsmList; sym: tsym; def: tdef; const ref: treference); override;
class function def2regtyp(def: tdef): tregistertype; override;
public
procedure a_bit_test_reg_reg_reg(list: TAsmList; bitnumbersize, valuesize, destsize: tdef; bitnumber, value, destreg: tregister); override;
procedure a_bit_set_reg_reg(list: TAsmList; doset: boolean; bitnumbersize, destsize: tdef; bitnumber, dest: tregister); override;
protected
procedure a_call_common(list: TAsmList; pd: tabstractprocdef; const paras: array of pcgpara; const forceresdef: tdef; out res: tregister; out hlretdef: tdef; out llvmretdef: tdef; out callparas: tfplist);
public
function a_call_name(list : TAsmList;pd : tprocdef;const s : TSymStr; const paras: array of pcgpara; forceresdef: tdef; weak: boolean): tcgpara;override;
function a_call_reg(list: TAsmList; pd: tabstractprocdef; reg: tregister; const paras: array of pcgpara): tcgpara; override;
procedure a_load_const_reg(list : TAsmList;tosize : tdef;a : tcgint;register : tregister);override;
procedure a_load_const_ref(list: TAsmList; tosize: tdef; a: tcgint; const ref: treference);override;
procedure a_load_reg_ref(list : TAsmList;fromsize, tosize : tdef;register : tregister;const ref : treference);override;
procedure a_load_reg_reg(list : TAsmList;fromsize, tosize : tdef;reg1,reg2 : tregister);override;
protected
procedure gen_load_refaddrfull_anyreg(list: TAsmList; fromsize, tosize : tdef; const simpleref: treference; register: tregister; shuffle: pmmshuffle);
function handle_agg_load_ref_anyreg(list: TasmList; var fromsize, tosize: tdef; var simpleref: treference; register: tregister; shuffle: pmmshuffle): boolean;
public
procedure a_load_ref_reg(list : TAsmList;fromsize, tosize : tdef;const ref : treference;register : tregister);override;
procedure a_load_ref_ref(list: TAsmList; fromsize, tosize: tdef; const sref: treference; const dref: treference); override;
protected
procedure a_loadaddr_ref_reg_intern(list : TAsmList;fromsize, tosize : tdef;const ref : treference;r : tregister; makefromsizepointer: boolean);
public
procedure a_loadaddr_ref_reg(list : TAsmList;fromsize, tosize : tdef;const ref : treference;r : tregister);override;
procedure a_op_const_reg(list: TAsmList; Op: TOpCG; size: tdef; a: tcgint; reg: TRegister); override;
procedure a_op_const_reg_reg(list: TAsmList; op: TOpCg; size: tdef; a: tcgint; src, dst: tregister); override;
procedure a_op_reg_reg_reg(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister); override;
procedure a_op_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; reg1, reg2: TRegister); override;
procedure a_op_const_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; a: tcgint; src, dst: tregister;setflags : boolean;var ovloc : tlocation); override;
procedure a_op_reg_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister;setflags : boolean;var ovloc : tlocation); override;
procedure a_cmp_const_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: tcgint; reg: tregister; l: tasmlabel); override;
procedure a_cmp_reg_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg1, reg2: tregister; l: tasmlabel); override;
procedure a_jmp_always(list : TAsmList;l: tasmlabel); override;
procedure g_unreachable(list: TAsmList); override;
procedure g_concatcopy(list : TAsmList;size: tdef; const source,dest : treference);override;
procedure g_undefined_ok(list: TAsmList; size: tdef; reg: tregister); override;
procedure a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister); override;
procedure a_loadfpu_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference); override;
procedure a_loadfpu_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister); override;
protected
procedure gen_fpconstrained_intrinsic(list: TAsmList; const intrinsic: TIDString; fromsize, tosize: tdef; fromreg, toreg: tregister; roundingmode: boolean);
public
procedure gen_proc_symbol(list: TAsmList); override;
procedure handle_external_proc(list: TAsmList; pd: tprocdef; const importname: TSymStr); override;
procedure g_proc_entry(list : TAsmList;localsize : longint;nostackframe:boolean); override;
procedure g_proc_exit(list : TAsmList;parasize:longint;nostackframe:boolean); override;
protected
procedure gen_load_uninitialized_function_result(list: TAsmList; pd: tprocdef; resdef: tdef; const resloc: tcgpara); override;
public
procedure g_overflowcheck(list: TAsmList; const Loc: tlocation; def: tdef); override;
procedure g_overflowCheck_loc(List:TAsmList;const Loc:TLocation;def:TDef;var ovloc : tlocation); override;
procedure g_ptrtypecast_reg(list: TAsmList; fromdef, todef: tdef; var reg: tregister); override;
procedure g_ptrtypecast_ref(list: TAsmList; fromdef, todef: tdef; var ref: treference); override;
procedure g_set_addr_nonbitpacked_field_ref(list: TAsmList; recdef: tabstractrecorddef; field: tfieldvarsym; var recref: treference); override;
procedure a_loadmm_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister; shuffle: pmmshuffle); override;
procedure a_loadmm_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference; shuffle: pmmshuffle); override;
procedure a_loadmm_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister; shuffle: pmmshuffle); override;
procedure a_opmm_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; src, dst: tregister; shuffle: pmmshuffle); override;
procedure a_loadmm_intreg_reg(list: TAsmList; fromsize, tosize: tdef; intreg, mmreg: tregister; shuffle: pmmshuffle); override;
procedure a_loadmm_reg_intreg(list: TAsmList; fromsize, tosize: tdef; mmreg, intreg: tregister; shuffle: pmmshuffle); override;
function get_call_result_cgpara(pd: tabstractprocdef; forceresdef: tdef): tcgpara; override;
protected
procedure gen_load_loc_function_result(list: TAsmList; vardef: tdef; const l: tlocation); override;
public
procedure gen_load_loc_cgpara(list: TAsmList; vardef: tdef; const l: tlocation; const cgpara: tcgpara); override;
procedure gen_load_cgpara_loc(list: TAsmList; vardef: tdef; const para: TCGPara; var destloc: tlocation; reusepara: boolean); override;
{$ifdef cpuflags}
{ llvm doesn't have flags, but cpuflags is defined in case the real cpu
has flags and we have to override the abstract methods to prevent
warnings }
procedure a_jmp_flags(list: TAsmList; const f: TResFlags; l: tasmlabel); override;
procedure g_flags2reg(list: TAsmList; size: tdef; const f: tresflags; reg: TRegister); override;
procedure g_flags2ref(list: TAsmList; size: tdef; const f: tresflags; const ref: TReference); override;
{$endif cpuflags}
{ unimplemented or unnecessary routines }
procedure a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; srcsize, dstsize: tdef; src, dst: tregister); override;
procedure g_stackpointer_alloc(list: TAsmList; size: longint); override;
procedure g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint); override;
procedure g_adjust_self_value(list: TAsmList; procdef: tprocdef; ioffset: aint); override;
procedure g_local_unwind(list: TAsmList; l: TAsmLabel); override;
procedure gen_stack_check_size_para(list: TAsmList); override;
procedure gen_stack_check_call(list: TAsmList); override;
procedure varsym_set_localloc(list: TAsmList; vs: tabstractnormalvarsym); override;
procedure paravarsym_set_initialloc_to_paraloc(vs: tparavarsym); override;
procedure g_external_wrapper(list: TAsmList; procdef: tprocdef; const wrappername, externalname: string; global: boolean); override;
{ def is a pointerdef or implicit pointer type (class, classref, procvar,
dynamic array, ...). }
function make_simple_ref_ptr(list: TAsmList; const ref: treference; ptrdef: tdef): treference;
{ def is the type of the data stored in memory pointed to by ref, not
a pointer to this type }
function make_simple_ref(list: TAsmList; const ref: treference; def: tdef): treference;
protected
procedure paraloctoloc(const paraloc: pcgparalocation; out hloc: tlocation);
procedure set_call_function_result(const list: TAsmList; const pd: tabstractprocdef; const llvmretdef, hlretdef: tdef; const resval: tregister; var retpara: tcgpara);
end;
implementation
uses
verbose,cutils,globals,fmodule,constexp,systems,
defutil,llvmdef,llvmsym,
aasmtai,aasmcpu,
aasmllvm,aasmllvmmetadata,llvmbase,llvminfo,tgllvm,
symtable,symllvm,
paramgr,
pass_2,procinfo,llvmpi,cpuinfo,cgobj,cgllvm,cghlcpu,
cgcpu,hlcgcpu;
var
create_hlcodegen_cpu: TProcedure = nil;
const
topcg2llvmop: array[topcg] of tllvmop =
{ OP_NONE OP_MOVE OP_ADD OP_AND OP_DIV OP_IDIV OP_IMUL OP_MUL }
(la_none, la_none, la_add, la_and, la_udiv, la_sdiv, la_mul, la_mul,
{ OP_NEG OP_NOT OP_OR OP_SAR OP_SHL OP_SHR OP_SUB OP_XOR }
la_none, la_none, la_or, la_ashr, la_shl, la_lshr, la_sub, la_xor,
{ OP_ROL OP_ROR }
la_none, la_none);
constructor thlcgllvm.create;
begin
inherited
end;
procedure thlcgllvm.a_load_reg_cgpara(list: TAsmList; size: tdef; r: tregister; const cgpara: TCGPara);
begin
if size<>llvm_metadatatype then
begin
inherited;
exit;
end;
{ overwrite with the reference to the metadata (stored in the register's supreg) }
cgpara.location^.register:=r;
end;
procedure thlcgllvm.a_load_ref_cgpara(list: TAsmList; size: tdef; const r: treference; const cgpara: TCGPara);
var
tmpref, initialref, ref: treference;
fielddef,
orgsize: tdef;
location: pcgparalocation;
sizeleft,
totaloffset: asizeint;
paralocidx: longint;
userecord: boolean;
begin
location:=cgpara.location;
sizeleft:=cgpara.intsize;
totaloffset:=0;
orgsize:=size;
a_load_ref_cgpara_init_src(list,cgpara,r,size,initialref);
if initialref.refaddr=addr_full then
begin
cgpara.check_simple_location;
location^.llvmvalueloc:=true;
location^.llvmloc.loc:=LOC_REFERENCE;
location^.llvmloc.sym:=initialref.symbol;
exit;
end;
userecord:=
(orgsize<>size) and
assigned(cgpara.location^.next);
paralocidx:=0;
fielddef:=nil;
while assigned(location) do
begin
if userecord then
begin
{ llvmparadef is a record in this case, with every field
corresponding to a single paraloc (fielddef is unused, because
it will be equivalent to location^.def -- see below) }
g_setup_load_field_by_name(list,trecorddef(size),'F'+tostr(paralocidx),initialref,tmpref,fielddef);
end
else
tmpref:=initialref;
paramanager.allocparaloc(list,location);
case location^.loc of
LOC_REGISTER,LOC_CREGISTER:
begin
{ byval parameter -> load the address rather than the value }
if not location^.llvmvalueloc then
a_loadaddr_ref_reg(list,tpointerdef(location^.def).pointeddef,location^.def,tmpref,location^.register)
{ if this parameter is split into multiple paralocs via
record fields, load the current paraloc. The type of the
paraloc and of the current record field will match by
construction (the record is build from the paraloc
types) }
else if userecord then
a_load_ref_reg(list,fielddef,location^.def,tmpref,location^.register)
{ if the parameter is passed in a single paraloc, the
paraloc's type may be different from the declared type
-> use the original complete parameter size as source so
we can insert a type conversion if necessary }
else
a_load_ref_reg(list,size,location^.def,tmpref,location^.register)
end;
LOC_REFERENCE,LOC_CREFERENCE:
begin
if assigned(location^.next) then
internalerror(2010052901);
reference_reset_base(ref,cpointerdef.getreusable(size),location^.reference.index,location^.reference.offset,ctempposinvalid,newalignment(cgpara.alignment,cgpara.intsize-sizeleft),[]);
if (def_cgsize(size)<>OS_NO) and
(size.size=sizeleft) and
(sizeleft<=sizeof(aint)) then
a_load_ref_ref(list,size,location^.def,tmpref,ref)
else
{ use concatcopy, because the parameter can be larger than }
{ what the OS_* constants can handle }
g_concatcopy(list,location^.def,tmpref,ref);
end;
LOC_MMREGISTER,LOC_CMMREGISTER:
begin
case location^.size of
OS_F32,
OS_F64,
OS_F128:
a_loadmm_ref_reg(list,location^.def,location^.def,tmpref,location^.register,mms_movescalar);
OS_M8..OS_M128,
OS_32..OS_128,
{ OS_NO is for records of non-power-of-two sizes that have to
be passed in MM registers -> never scalar floats }
OS_NO:
a_loadmm_ref_reg(list,location^.def,location^.def,tmpref,location^.register,nil);
else
internalerror(2010053105);
end;
end
else
internalerror(2010053107);
end;
inc(totaloffset,tcgsize2size[location^.size]);
dec(sizeleft,tcgsize2size[location^.size]);
location:=location^.next;
inc(paralocidx);
end;
end;
procedure thlcgllvm.a_load_undefined_cgpara(list: TAsmList; size: tdef; const cgpara: TCGPara);
var
hreg: tregister;
begin
hreg:=getregisterfordef(list,size);
list.concat(taillvm.op_reg_size_undef(la_bitcast,hreg,size));
a_load_reg_cgpara(list,size,hreg,cgpara);
end;
procedure thlcgllvm.a_load_const_cgpara(list: TAsmList; tosize: tdef; a: tcgint; const cgpara: TCGPara);
begin
if is_ordinal(cgpara.def) then
begin
cgpara.check_simple_location;
paramanager.alloccgpara(list,cgpara);
if cgpara.location^.shiftval<0 then
a:=a shl -cgpara.location^.shiftval;
cgpara.location^.llvmloc.loc:=LOC_CONSTANT;
cgpara.location^.llvmloc.value:=a;
end
else
inherited;
end;
procedure thlcgllvm.a_load_ref_cgpara_init_src(list: TAsmList; const para: tcgpara; const initialref: treference; var refsize: tdef; out newref: treference);
var
newrefsize: tdef;
reg: tregister;
tmpref: treference;
begin
newrefsize:=llvmgetcgparadef(para,true,callerside);
if (refsize<>newrefsize) and
(initialref.refaddr<>addr_full) then
begin
if refsize.size>=newrefsize.size then
begin
reg:=getaddressregister(list,cpointerdef.getreusable(newrefsize));
a_loadaddr_ref_reg(list,refsize,cpointerdef.getreusable(newrefsize),initialref,reg);
reference_reset_base(newref,cpointerdef.getreusable(newrefsize),reg,0,initialref.temppos,initialref.alignment,initialref.volatility);
refsize:=newrefsize;
end
else
begin
tg.gethltemp(list,newrefsize,newrefsize.size,tt_normal,newref);
reg:=getaddressregister(list,cpointerdef.getreusable(refsize));
a_loadaddr_ref_reg(list,newrefsize,cpointerdef.getreusable(refsize),newref,reg);
reference_reset_base(tmpref,refsize,reg,0,newref.temppos,newref.alignment,initialref.volatility);
g_concatcopy(list,refsize,initialref,tmpref);
refsize:=newrefsize;
end;
end
else
newref:=initialref;
end;
procedure thlcgllvm.getcpuregister(list: TAsmList; r: Tregister);
begin
{ don't do anything }
end;
procedure thlcgllvm.ungetcpuregister(list: TAsmList; r: Tregister);
begin
{ don't do anything }
end;
procedure thlcgllvm.alloccpuregisters(list: TAsmList; rt: Tregistertype; const r: Tcpuregisterset);
begin
{ don't do anything }
end;
procedure thlcgllvm.allocallcpuregisters(list: TAsmList);
begin
{ don't do anything }
end;
procedure thlcgllvm.deallocallcpuregisters(list: TAsmList);
begin
{ don't do anything }
end;
procedure thlcgllvm.recordnewsymloc(list: TAsmList; sym: tsym; def: tdef; const ref: treference);
var
varmetapara,
symmetadatapara,
exprmetapara: tcgpara;
pd: tprocdef;
begin
if assigned(sym) and
(sym.visibility<>vis_hidden) and
(cs_debuginfo in current_settings.moduleswitches) then
begin
pd:=search_system_proc('llvm_dbg_addr');
varmetapara.init;
symmetadatapara.init;
exprmetapara.init;
paramanager.getcgtempparaloc(current_asmdata.CurrAsmList,pd,1,varmetapara);
paramanager.getcgtempparaloc(current_asmdata.CurrAsmList,pd,1,symmetadatapara);
paramanager.getcgtempparaloc(current_asmdata.CurrAsmList,pd,1,exprmetapara);
{ the local location of the var/para }
varmetapara.Location^.def:=cpointerdef.getreusable(def);
varmetapara.Location^.register:=ref.base;
{ the variable/para metadata }
symmetadatapara.Location^.llvmloc.loc:=LOC_CREFERENCE;
symmetadatapara.Location^.llvmloc.localsym:=sym;
{ dummy for the expression metadata }
exprmetapara.Location^.llvmloc.loc:=LOC_CONSTANT;
exprmetapara.Location^.llvmloc.value:=0;
g_call_system_proc(list,pd,[@varmetapara,@symmetadatapara,@exprmetapara],nil).resetiftemp;
varmetapara.done;
symmetadatapara.done;
exprmetapara.done;
end;
end;
class function thlcgllvm.def2regtyp(def: tdef): tregistertype;
begin
if (def.typ=arraydef) and
tarraydef(def).is_hwvector then
result:=R_INTREGISTER
else
result:=inherited;
end;
procedure thlcgllvm.a_bit_test_reg_reg_reg(list: TAsmList; bitnumbersize, valuesize, destsize: tdef; bitnumber, value, destreg: tregister);
var
tmpbitnumberreg: tregister;
begin
{ unlike other architectures, llvm requires the bitnumber register to
have the same size as the shifted register }
if bitnumbersize.size<>valuesize.size then
begin
tmpbitnumberreg:=hlcg.getintregister(list,valuesize);
a_load_reg_reg(list,bitnumbersize,valuesize,bitnumber,tmpbitnumberreg);
bitnumbersize:=valuesize;
bitnumber:=tmpbitnumberreg;
end;
inherited;
end;
procedure thlcgllvm.a_bit_set_reg_reg(list: TAsmList; doset: boolean; bitnumbersize, destsize: tdef; bitnumber, dest: tregister);
var
tmpbitnumberreg: tregister;
begin
{ unlike other architectures, llvm requires the bitnumber register to
have the same size as the shifted register }
if bitnumbersize.size<>destsize.size then
begin
tmpbitnumberreg:=hlcg.getintregister(list,destsize);
a_load_reg_reg(list,bitnumbersize,destsize,bitnumber,tmpbitnumberreg);
bitnumbersize:=destsize;
bitnumber:=tmpbitnumberreg;
end;
inherited;
end;
function get_call_pd(pd: tabstractprocdef): tdef;
begin
if (pd.typ=procdef) or
not pd.is_addressonly then
{ we get a pointerdef rather than a procvardef so that if we have to
insert an external declaration for this procdef in llvmtype, we don't
have to create another procdef from the procvardef we've just created.
With a pointerdef, we can just get the pointeddef again. A pointerdef
is also much cheaper to create, and in llvm a provardef is a "function
pointer", so a pointer to a procdef is the same as a procvar as far
as llvm is concerned }
result:=cpointerdef.getreusable(pd)
else
result:=pd
end;
procedure thlcgllvm.a_call_common(list: TAsmList; pd: tabstractprocdef; const paras: array of pcgpara; const forceresdef: tdef; out res: tregister; out hlretdef: tdef; out llvmretdef: tdef; out callparas: tfplist);
procedure load_ref_anyreg(def: tdef; const ref: treference; reg: tregister);
begin
case getregtype(reg) of
R_INTREGISTER,
R_ADDRESSREGISTER:
begin
a_load_ref_reg(list,def,def,ref,reg);
end;
R_FPUREGISTER:
begin
a_loadfpu_ref_reg(list,def,def,ref,reg);
end;
R_MMREGISTER:
begin
a_loadmm_ref_reg(list,def,def,ref,reg,mms_movescalar);
end;
else
internalerror(2014012213);
end;
end;
var
i: longint;
href: treference;
callpara: pllvmcallpara;
paraloc: pcgparalocation;
firstparaloc: boolean;
begin
callparas:=tfplist.Create;
for i:=0 to high(paras) do
begin
{ skip parameters without data }
if paras[i]^.isempty then
continue;
paraloc:=paras[i]^.location;
firstparaloc:=true;
while assigned(paraloc) do
begin
new(callpara,init(paraloc^.def,std_param_align,lve_none,[]));
if paras[i]^.def=llvm_metadatatype then
include(callpara^.flags,lcp_metadata);
callpara^.def:=paraloc^.def;
{ if the paraloc doesn't contain the value itself, it's a byval
parameter }
if paraloc^.retvalloc then
begin
include(callpara^.flags,lcp_sret);
end
else
begin
if not paraloc^.llvmvalueloc then
include(callpara^.flags,lcp_byval);
end;
if firstparaloc and
(lcp_byval in callpara^.flags) then
callpara^.alignment:=paras[i]^.Alignment;
llvmextractvalueextinfo(paras[i]^.def, callpara^.def, callpara^.valueext);
case paraloc^.llvmloc.loc of
LOC_CONSTANT:
begin
callpara^.loadconst(paraloc^.llvmloc.value);
end;
LOC_REFERENCE:
begin
callpara^.loadsym(paraloc^.llvmloc.sym);
end;
LOC_CREFERENCE:
begin
callpara^.loadlocalsym(paraloc^.llvmloc.localsym);
end
else
begin
case paraloc^.loc of
LOC_REFERENCE:
begin
if paraloc^.llvmvalueloc then
internalerror(2014012307)
else
begin
reference_reset_base(href, cpointerdef.getreusable(callpara^.def), paraloc^.reference.index, paraloc^.reference.offset, ctempposinvalid, paraloc^.def.alignment, []);
res:=getregisterfordef(list, paraloc^.def);
load_ref_anyreg(callpara^.def, href, res);
callpara^.loadreg(res);
end;
end;
LOC_REGISTER,
LOC_FPUREGISTER,
LOC_MMREGISTER:
begin
{ undo explicit value extension }
if callpara^.valueext<>lve_none then
begin
res:=getregisterfordef(list, callpara^.def);
a_load_reg_reg(list, paraloc^.def, callpara^.def, paraloc^.register, res);
paraloc^.register:=res;
end;
callpara^.loadreg(paraloc^.register);
end;
{ empty records }
LOC_VOID:
begin
callpara^.loadundef;
end
else
internalerror(2014010605);
end;
end;
end;
callparas.add(callpara);
paraloc:=paraloc^.next;
firstparaloc:=false;
end;
end;
{ the Pascal level may expect a different returndef compared to the
declared one }
if pd.generate_safecall_wrapper then
begin
hlretdef:=ossinttype;
llvmretdef:=ossinttype;
end
else
begin
if not assigned(forceresdef) then
hlretdef:=pd.returndef
else
hlretdef:=forceresdef;
{ llvm will always expect the original return def }
if not paramanager.ret_in_param(hlretdef, pd) or
pd.generate_safecall_wrapper then
llvmretdef:=llvmgetcgparadef(pd.funcretloc[callerside], true, callerside)
else
llvmretdef:=voidtype;
end;
if not is_void(llvmretdef) then
res:=getregisterfordef(list, llvmretdef)
else
res:=NR_NO;
{ if this is a complex procvar, get the non-tmethod-like equivalent }
if (pd.typ=procvardef) and
not pd.is_addressonly then
pd:=tprocvardef(cprocvardef.getreusableprocaddr(pd,pc_address_only));
end;
function thlcgllvm.a_call_name(list: TAsmList; pd: tprocdef; const s: TSymStr; const paras: array of pcgpara; forceresdef: tdef; weak: boolean): tcgpara;
var
callparas: tfplist;
llvmretdef,
hlretdef: tdef;
res: tregister;
nextinslab,
exceptlab: TAsmLabel;
begin
a_call_common(list,pd,paras,forceresdef,res,hlretdef,llvmretdef,callparas);
if not(fc_catching_exceptions in flowcontrol) or
{ no invoke for intrinsics }
(copy(s,1,5)='llvm.') then
list.concat(taillvm.call_size_name_paras(get_call_pd(pd),pd.proccalloption,res,llvmretdef,current_asmdata.RefAsmSymbol(s,AT_FUNCTION),callparas))
else
begin
current_asmdata.getjumplabel(nextinslab);
exceptlab:=tllvmprocinfo(current_procinfo).CurrExceptLabel;
list.concat(taillvm.invoke_size_name_paras_retlab_exceptlab(get_call_pd(pd),pd.proccalloption,res,llvmretdef,current_asmdata.RefAsmSymbol(s,AT_FUNCTION),callparas,nextinslab,exceptlab));
a_label(list,nextinslab);
end;
result:=get_call_result_cgpara(pd,forceresdef);
set_call_function_result(list,pd,llvmretdef,hlretdef,res,result);
end;
function thlcgllvm.a_call_reg(list: TAsmList; pd: tabstractprocdef; reg: tregister; const paras: array of pcgpara): tcgpara;
var
callparas: tfplist;
llvmretdef,
hlretdef: tdef;
res: tregister;
nextinslab,
exceptlab: TAsmLabel;
begin
a_call_common(list,pd,paras,nil,res,hlretdef,llvmretdef,callparas);
if not(fc_catching_exceptions in flowcontrol) then
list.concat(taillvm.call_size_reg_paras(get_call_pd(pd),pd.proccalloption,res,llvmretdef,reg,callparas))
else
begin
current_asmdata.getjumplabel(nextinslab);
exceptlab:=tllvmprocinfo(current_procinfo).CurrExceptLabel;
list.concat(taillvm.invoke_size_reg_paras_retlab_exceptlab(get_call_pd(pd),pd.proccalloption,res,llvmretdef,reg,callparas,nextinslab,exceptlab));
a_label(list,nextinslab);
end;
result:=get_call_result_cgpara(pd,nil);
set_call_function_result(list,pd,llvmretdef,hlretdef,res,result);
end;
procedure thlcgllvm.a_load_const_reg(list: TAsmList; tosize: tdef; a: tcgint; register: tregister);
var
fromsize: tdef;
begin
if tosize=llvm_metadatatype then
internalerror(2019122804);
if tosize.size<=ptrsinttype.size then
fromsize:=ptrsinttype
else
fromsize:=tosize;
list.concat(taillvm.op_reg_size_const_size(llvmconvop(fromsize,tosize,false),register,fromsize,a,tosize))
end;
procedure thlcgllvm.a_load_const_ref(list: TAsmList; tosize: tdef; a: tcgint; const ref: treference);
var
sref: treference;
begin
{ llvm instructions do not support pointer constants -> only directly
encode for integers; a_load_const_reg() handles pointers properly }
if is_ordinal(tosize) or
is_64bit(tosize) then
begin
sref:=make_simple_ref(list,ref,tosize);
list.concat(taillvm.op_size_const_size_ref(la_store,tosize,a,cpointerdef.getreusable(tosize),sref))
end
else
inherited;
end;
function def2intdef(fromsize, tosize: tdef): tdef;
begin
{ we cannot zero-extend from/to anything but ordinal/enum
types }
if not(tosize.typ in [orddef,enumdef]) then
internalerror(2014012305);
{ will give an internalerror if def_cgsize() returns OS_NO, which is
what we want }
result:=cgsize_orddef(def_cgsize(fromsize));
end;
procedure thlcgllvm.a_load_reg_ref(list: TAsmList; fromsize, tosize: tdef; register: tregister; const ref: treference);
var
tmpref,
sref: treference;
hreg,
hreg2: tregister;
tmpsize: tdef;
begin
if (fromsize=llvm_metadatatype) or
(tosize=llvm_metadatatype) then
internalerror(2019122812);
sref:=make_simple_ref(list,ref,tosize);
hreg:=register;
(* typecast the pointer to the value instead of the value itself if
they have the same size but are of different kinds, because we can't
e.g. typecast a loaded <{i32, i32}> to an i64 *)
if (llvmaggregatetype(fromsize) or
llvmaggregatetype(tosize)) and
(fromsize<>tosize) then
begin
if fromsize.size>tosize.size then
begin
{ if source size is larger than the target size, we have to
truncate it before storing. Unfortunately, we cannot truncate
records (nor bitcast them to integers), so we first have to
store them to memory and then bitcast the pointer to them
We can't truncate an integer to 3/5/6/7 bytes either, so also
pass via a temp in that case
}
if (fromsize.typ in [arraydef,recorddef]) or
(is_set(fromsize) and not is_smallset(fromsize)) or
(tosize.size in [3,5,6,7]) then
begin
{ store struct/array-in-register to memory }
tg.gethltemp(list,fromsize,fromsize.size,tt_normal,tmpref);
a_load_reg_ref(list,fromsize,fromsize,register,tmpref);
{ typecast pointer to memory into pointer to integer type }
hreg:=getaddressregister(list,cpointerdef.getreusable(tosize));
a_loadaddr_ref_reg(list,fromsize,cpointerdef.getreusable(tosize),tmpref,hreg);
reference_reset_base(sref,cpointerdef.getreusable(tosize),hreg,0,tmpref.temppos,tmpref.alignment,tmpref.volatility);
{ load the integer from the temp into the destination }
a_load_ref_ref(list,tosize,tosize,sref,ref);
tg.ungettemp(list,tmpref);
end
else
begin
tmpsize:=def2intdef(tosize,fromsize);
hreg:=getintregister(list,tmpsize);
{ truncate the integer }
a_load_reg_reg(list,fromsize,tmpsize,register,hreg);
{ store it to memory (it will now be of the same size as the
struct, and hence another path will be followed in this
method) }
a_load_reg_ref(list,tmpsize,tosize,hreg,sref);
end;
exit;
end
else
begin
hreg2:=getaddressregister(list,cpointerdef.getreusable(fromsize));
a_loadaddr_ref_reg(list,tosize,cpointerdef.getreusable(fromsize),sref,hreg2);
reference_reset_base(sref,cpointerdef.getreusable(fromsize),hreg2,0,sref.temppos,sref.alignment,sref.volatility);
tosize:=fromsize;
end;
end
else if fromsize<>tosize then
begin
hreg:=getregisterfordef(list,tosize);
a_load_reg_reg(list,fromsize,tosize,register,hreg);
end;
list.concat(taillvm.op_size_reg_size_ref(la_store,tosize,hreg,cpointerdef.getreusable(tosize),sref));
end;
procedure thlcgllvm.a_load_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister);
var
op: tllvmop;
tmpreg: tregister;
tmpintdef: tdef;
begin
if (fromsize=llvm_metadatatype) or
(tosize=llvm_metadatatype) then
internalerror(2019122805);
op:=llvmconvop(fromsize,tosize,true);
{ converting from pointer to something else and vice versa is only
possible via an intermediate pass to integer. Same for "something else"
to pointer. }
case op of
la_ptrtoint_to_x,
la_x_to_inttoptr:
begin
{ convert via an integer with the same size as "x" }
if op=la_ptrtoint_to_x then
begin
tmpintdef:=cgsize_orddef(def_cgsize(tosize));
op:=la_bitcast
end
else
begin
tmpintdef:=cgsize_orddef(def_cgsize(fromsize));
op:=la_inttoptr;
end;
tmpreg:=getintregister(list,tmpintdef);
a_load_reg_reg(list,fromsize,tmpintdef,reg1,tmpreg);
reg1:=tmpreg;
fromsize:=tmpintdef;
end;
else
;
end;
{ inttoptr performs zero extension -> avoid inc(ptr,longint(-1)) from
increasing ptr by 4GB on a 64bit platform }
if (op=la_inttoptr) and
(fromsize.size<tosize.size) then
begin
tmpreg:=getintregister(list,fromsize);
a_load_reg_reg(list,fromsize,ptrsinttype,reg1,tmpreg);
reg1:=tmpreg;
fromsize:=ptrsinttype;
end;
{ reg2 = bitcast fromsize reg1 to tosize }
list.concat(taillvm.op_reg_size_reg_size(op,reg2,fromsize,reg1,tosize));
end;
procedure thlcgllvm.gen_load_refaddrfull_anyreg(list: TAsmList; fromsize, tosize: tdef; const simpleref: treference; register: tregister; shuffle: pmmshuffle);
var
tmpref,
tmpref2: treference;
begin
{ can't bitcast records/arrays }
if (llvmaggregatetype(fromsize) or
llvmaggregatetype(tosize)) and
(fromsize<>tosize) then
begin
if fromsize.size>tosize.size then
begin
tg.gethltemp(list,fromsize,fromsize.size,tt_normal,tmpref);
tmpref2:=tmpref;
g_ptrtypecast_ref(list,cpointerdef.getreusable(fromsize),cpointerdef.getreusable(tosize),tmpref2);
end
else
begin
tg.gethltemp(list,tosize,tosize.size,tt_normal,tmpref);
tmpref2:=tmpref;
g_ptrtypecast_ref(list,cpointerdef.getreusable(tosize),cpointerdef.getreusable(fromsize),tmpref);
end;
list.concat(taillvm.op_size_ref_size_ref(la_store,fromsize,simpleref,cpointerdef.getreusable(fromsize),tmpref));
case getregtype(register) of
R_INTREGISTER,
R_ADDRESSREGISTER:
a_load_ref_reg(list,tosize,tosize,tmpref2,register);
R_FPUREGISTER:
a_loadfpu_ref_reg(list,tosize,tosize,tmpref2,register);
R_MMREGISTER:
a_loadmm_ref_reg(list,tosize,tosize,tmpref2,register,shuffle);
else
internalerror(2016061901);
end;
tg.ungettemp(list,tmpref);
end
else
list.concat(taillvm.op_reg_size_ref_size(llvmconvop(fromsize,tosize,false),register,fromsize,simpleref,tosize))
end;
function thlcgllvm.handle_agg_load_ref_anyreg(list: TasmList; var fromsize, tosize: tdef; var simpleref: treference; register: tregister; shuffle: pmmshuffle): boolean;
var
tmpref,
tmpref2: treference;
firstshuffle: pmmshuffle;
begin
if fromsize.size<tosize.size then
begin
{ allocate a temp of size tosize, typecast it to the
(smaller) fromsize, load the source in it, and then
load the destination from it. The extra bits will contain
garbage, but they should never be used. }
tg.gethltemp(list,tosize,tosize.size,tt_persistent,tmpref);
tmpref2:=tmpref;
g_ptrtypecast_ref(list,cpointerdef.getreusable(tosize),cpointerdef.getreusable(fromsize),tmpref2);
case getregtype(register) of
R_INTREGISTER,
R_ADDRESSREGISTER:
begin
a_load_ref_ref(list,fromsize,fromsize,simpleref,tmpref2);
a_load_ref_reg(list,tosize,tosize,tmpref,register);
end;
R_FPUREGISTER:
begin
a_loadfpu_ref_ref(list,fromsize,fromsize,simpleref,tmpref2);
a_loadfpu_ref_reg(list,tosize,tosize,tmpref,register);
end;
R_MMREGISTER:
begin
{ don't shuffle twice }
if shuffle=mms_movescalar then
firstshuffle:=shuffle
else
firstshuffle:=nil;
a_loadmm_ref_ref(list,fromsize,fromsize,simpleref,tmpref2,firstshuffle);
a_loadmm_ref_reg(list,tosize,tosize,tmpref,register,shuffle);
end;
else
internalerror(2019051040);
end;
tg.ungettemp(list,tmpref);
result:=true;
end
else
begin
(* typecast the pointer to the value instead of the value
itself if tosize<=fromsize but they are of different
kinds, because we can't e.g. bitcast a loaded <{i32, i32}>
to an i64 *)
g_ptrtypecast_ref(list,cpointerdef.getreusable(fromsize),cpointerdef.getreusable(tosize),simpleref);
fromsize:=tosize;
result:=false;
end;
end;
procedure thlcgllvm.a_load_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; register: tregister);
var
sref: treference;
hreg: tregister;
begin
if (fromsize=llvm_metadatatype) or
(tosize=llvm_metadatatype) then
internalerror(2019122803);
sref:=make_simple_ref(list,ref,fromsize);
{ "named register"? }
if sref.refaddr=addr_full then
gen_load_refaddrfull_anyreg(list,fromsize,tosize,sref,register,nil)
else
begin
if ((fromsize.typ in [arraydef,recorddef]) or
(tosize.typ in [arraydef,recorddef]) or
(is_set(fromsize) and not is_smallset(fromsize)) or
(is_set(tosize) and not is_smallset(tosize))) and
(fromsize<>tosize) then
begin
if handle_agg_load_ref_anyreg(list,fromsize,tosize,sref,register,nil) then
exit;
end;
hreg:=register;
if fromsize<>tosize then
hreg:=getregisterfordef(list,fromsize);
list.concat(taillvm.op_reg_size_ref(la_load,hreg,cpointerdef.getreusable(fromsize),sref));
if hreg<>register then
a_load_reg_reg(list,fromsize,tosize,hreg,register);
end;
end;
procedure thlcgllvm.a_load_ref_ref(list: TAsmList; fromsize, tosize: tdef; const sref: treference; const dref: treference);
var
sdref: treference;
begin
if (fromsize=tosize) and
(sref.refaddr=addr_full) then
begin
sdref:=make_simple_ref(list,dref,tosize);
list.concat(taillvm.op_size_ref_size_ref(la_store,fromsize,sref,cpointerdef.getreusable(tosize),sdref));
end
else if (fromsize=tosize) and
not(fromsize.typ in [orddef,floatdef,enumdef]) and
(sref.refaddr<>addr_full) and
(fromsize.size>2*sizeof(aint)) then
g_concatcopy(list,fromsize,sref,dref)
else
inherited
end;
procedure thlcgllvm.a_loadaddr_ref_reg_intern(list: TAsmList; fromsize, tosize: tdef; const ref: treference; r: tregister; makefromsizepointer: boolean);
var
sref: treference;
begin
{ can't take the address of a 'named register' }
if ref.refaddr=addr_full then
internalerror(2013102306);
if makefromsizepointer then
fromsize:=cpointerdef.getreusable(fromsize);
sref:=make_simple_ref_ptr(list,ref,fromsize);
list.concat(taillvm.op_reg_size_ref_size(la_bitcast,r,fromsize,sref,tosize));
end;
procedure thlcgllvm.a_loadaddr_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; r: tregister);
begin
a_loadaddr_ref_reg_intern(list,fromsize,tosize,ref,r,true);
end;
procedure thlcgllvm.a_op_const_reg(list: TAsmList; Op: TOpCG; size: tdef; a: tcgint; reg: TRegister);
begin
a_op_const_reg_reg(list,op,size,a,reg,reg);
end;
procedure thlcgllvm.a_op_const_reg_reg(list: TAsmList; op: TOpCg; size: tdef; a: tcgint; src, dst: tregister);
var
tmpreg: tregister;
begin
if (def2regtyp(size)=R_INTREGISTER) and
(topcg2llvmop[op]<>la_none) then
list.concat(taillvm.op_reg_size_reg_const(topcg2llvmop[op],dst,size,src,a))
else
begin
{ default implementation is not SSA-safe }
tmpreg:=getregisterfordef(list,size);
a_load_const_reg(list,size,a,tmpreg);
a_op_reg_reg_reg(list,op,size,tmpreg,src,dst);
end;
end;
procedure thlcgllvm.a_op_reg_reg_reg(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister);
var
orgdst,
tmpreg1,
tmpreg2,
tmpreg3: tregister;
opsize: tdef;
begin
orgdst:=dst;
opsize:=size;
{ always perform using integer registers, because math operations on
pointers are not supported (except via getelementptr, possible future
optimization) }
if def2regtyp(size)=R_ADDRESSREGISTER then
begin
opsize:=ptruinttype;
tmpreg1:=getintregister(list,ptruinttype);
a_load_reg_reg(list,size,ptruinttype,src1,tmpreg1);
src1:=tmpreg1;
tmpreg1:=getintregister(list,ptruinttype);
a_load_reg_reg(list,size,ptruinttype,src2,tmpreg1);
src2:=tmpreg1;
dst:=getintregister(list,ptruinttype);
end;
if topcg2llvmop[op]<>la_none then
list.concat(taillvm.op_reg_size_reg_reg(topcg2llvmop[op],dst,opsize,src2,src1))
else
begin
case op of
OP_NEG:
{ %dst = sub size 0, %src1 }
list.concat(taillvm.op_reg_size_const_reg(la_sub,dst,opsize,0,src1));
OP_NOT:
{ %dst = xor size -1, %src1 }
list.concat(taillvm.op_reg_size_const_reg(la_xor,dst,opsize,-1,src1));
OP_ROL:
begin
tmpreg1:=getintregister(list,opsize);
tmpreg2:=getintregister(list,opsize);
tmpreg3:=getintregister(list,opsize);
{ tmpreg1 := (tcgsize2size[size]*8 - (src1 and (tcgsize2size[size]*8-1) }
list.concat(taillvm.op_reg_size_const_reg(la_and,tmpreg1,opsize,opsize.size*8-1,src1));
list.concat(taillvm.op_reg_size_const_reg(la_sub,tmpreg2,opsize,opsize.size*8,tmpreg1));
{ tmpreg3 := src2 shr tmpreg2 }
a_op_reg_reg_reg(list,OP_SHR,opsize,tmpreg2,src2,tmpreg3);
{ tmpreg2:= src2 shl tmpreg1 }
tmpreg2:=getintregister(list,opsize);
a_op_reg_reg_reg(list,OP_SHL,opsize,tmpreg1,src2,tmpreg2);
{ dst := tmpreg2 or tmpreg3 }
a_op_reg_reg_reg(list,OP_OR,opsize,tmpreg2,tmpreg3,dst);
end;
OP_ROR:
begin
tmpreg1:=getintregister(list,size);
tmpreg2:=getintregister(list,size);
tmpreg3:=getintregister(list,size);
{ tmpreg1 := (tcgsize2size[size]*8 - (src1 and (tcgsize2size[size]*8-1) }
list.concat(taillvm.op_reg_size_const_reg(la_and,tmpreg1,opsize,opsize.size*8-1,src1));
list.concat(taillvm.op_reg_size_const_reg(la_sub,tmpreg2,opsize,opsize.size*8,tmpreg1));
{ tmpreg3 := src2 shl tmpreg2 }
a_op_reg_reg_reg(list,OP_SHL,opsize,tmpreg2,src2,tmpreg3);
{ tmpreg2:= src2 shr tmpreg1 }
tmpreg2:=getintregister(list,opsize);
a_op_reg_reg_reg(list,OP_SHR,opsize,tmpreg1,src2,tmpreg2);
{ dst := tmpreg2 or tmpreg3 }
a_op_reg_reg_reg(list,OP_OR,opsize,tmpreg2,tmpreg3,dst);
end;
else
internalerror(2010081310);
end;
end;
if dst<>orgdst then
a_load_reg_reg(list,opsize,size,dst,orgdst);
end;
procedure thlcgllvm.a_op_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; reg1, reg2: TRegister);
begin
a_op_reg_reg_reg(list,op,size,reg1,reg2,reg2);
end;
procedure thlcgllvm.a_op_const_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; a: tcgint; src, dst: tregister; setflags: boolean; var ovloc: tlocation);
var
hreg: tregister;
begin
if not setflags then
begin
inherited;
exit;
end;
hreg:=getintregister(list,size);
a_load_const_reg(list,size,a,hreg);
a_op_reg_reg_reg_checkoverflow(list,op,size,hreg,src,dst,setflags,ovloc);
end;
procedure thlcgllvm.a_op_reg_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister; setflags: boolean; var ovloc: tlocation);
var
calcsize: tdef;
tmpsrc1,
tmpsrc2,
tmpdst: tregister;
signed,
docheck: boolean;
begin
docheck:=size.size>=ossinttype.size;
if not setflags or
not docheck then
begin
inherited a_op_reg_reg_reg_checkoverflow(list,op,size,src1,src2,dst,false,ovloc);
exit;
end;
{ extend values to twice their original width (one bit extra is enough,
but adding support for 9/17/33/65 bit types just for this is overkill) }
signed:=is_signed(size);
case size.size of
1:
if signed then
calcsize:=s16inttype
else
calcsize:=u16inttype;
2:
if signed then
calcsize:=s32inttype
else
calcsize:=u32inttype;
4:
if signed then
calcsize:=s64inttype
else
calcsize:=u64inttype;
8:
if signed then
calcsize:=s128inttype
else
calcsize:=u128inttype;
else
internalerror(2015122503);
end;
tmpsrc1:=getintregister(list,calcsize);
a_load_reg_reg(list,size,calcsize,src1,tmpsrc1);
tmpsrc2:=getintregister(list,calcsize);
a_load_reg_reg(list,size,calcsize,src2,tmpsrc2);
tmpdst:=getintregister(list,calcsize);
{ perform the calculation with twice the width }
a_op_reg_reg_reg(list,op,calcsize,tmpsrc1,tmpsrc2,tmpdst);
{ signed/unsigned overflow occurs if signed/unsigned truncation of the
result is different from the actual result -> extend again and compare }
a_load_reg_reg(list,calcsize,size,tmpdst,dst);
tmpsrc1:=getintregister(list,calcsize);
a_load_reg_reg(list,size,calcsize,dst,tmpsrc1);
location_reset(ovloc,LOC_REGISTER,OS_8);
ovloc.register:=getintregister(list,llvmbool1type);
list.concat(taillvm.op_reg_cond_size_reg_reg(la_icmp,ovloc.register,OC_NE,calcsize,tmpsrc1,tmpdst));
end;
procedure thlcgllvm.a_cmp_const_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: tcgint; reg: tregister; l: tasmlabel);
var
tmpreg : tregister;
invert: boolean;
fallthroughlab, falselab, tmplab: tasmlabel;
begin
tmpreg:=getregisterfordef(list,size);
a_load_const_reg(list,size,a,tmpreg);
a_cmp_reg_reg_label(list,size,cmp_op,tmpreg,reg,l);
end;
procedure thlcgllvm.a_cmp_reg_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg1, reg2: tregister; l: tasmlabel);
var
resreg: tregister;
falselab: tasmlabel;
begin
if getregtype(reg1)<>getregtype(reg2) then
internalerror(2012111105);
resreg:=getintregister(list,llvmbool1type);
current_asmdata.getjumplabel(falselab);
{ invert order of registers. In FPC, cmp_reg_reg(reg1,reg2) means that
e.g. OC_GT is true if "subl %reg1,%reg2" in x86 AT&T is >0. In LLVM,
OC_GT is true if op1>op2 }
list.concat(taillvm.op_reg_cond_size_reg_reg(la_icmp,resreg,cmp_op,size,reg2,reg1));
list.concat(taillvm.op_size_reg_lab_lab(la_br,llvmbool1type,resreg,l,falselab));
a_label(list,falselab);
end;
procedure thlcgllvm.a_jmp_always(list: TAsmList; l: tasmlabel);
begin
{ implement in tcg because required by the overridden a_label; doesn't use
any high level stuff anyway }
cg.a_jmp_always(list,l);
end;
procedure thlcgllvm.g_unreachable(list: TAsmList);
begin
list.Concat(taillvm.op_none(la_unreachable));
end;
procedure thlcgllvm.g_concatcopy(list: TAsmList; size: tdef; const source, dest: treference);
var
pd: tprocdef;
sourcepara, destpara, sizepara, alignpara, volatilepara: tcgpara;
maxalign: longint;
indivalign: boolean;
begin
{ perform small copies directly; not larger ones, because then llvm
will try to load the entire large datastructure into registers and
starts spilling like crazy }
if (size.typ in [orddef,floatdef,enumdef]) or
(size.size in [1,2,4,8]) then
begin
a_load_ref_ref(list,size,size,source,dest);
exit;
end;
indivalign:=llvmflag_memcpy_indiv_align in llvmversion_properties[current_settings.llvmversion];
if indivalign then
pd:=search_system_proc('llvm_memcpy64_indivalign')
else
pd:=search_system_proc('llvm_memcpy64');
sourcepara.init;
destpara.init;
sizepara.init;
alignpara.init;
volatilepara.init;
paramanager.getcgtempparaloc(list,pd,1,destpara);
paramanager.getcgtempparaloc(list,pd,2,sourcepara);
paramanager.getcgtempparaloc(list,pd,3,sizepara);
if indivalign then
begin
paramanager.getcgtempparaloc(list,pd,4,volatilepara);
destpara.Alignment:=-dest.alignment;
sourcepara.Alignment:=-source.alignment;
end
else
begin
paramanager.getcgtempparaloc(list,pd,4,alignpara);
paramanager.getcgtempparaloc(list,pd,5,volatilepara);
maxalign:=newalignment(max(source.alignment,dest.alignment),min(source.alignment,dest.alignment));
a_load_const_cgpara(list,u32inttype,maxalign,alignpara);
end;
a_loadaddr_ref_cgpara(list,size,dest,destpara);
a_loadaddr_ref_cgpara(list,size,source,sourcepara);
a_load_const_cgpara(list,u64inttype,size.size,sizepara);
a_load_const_cgpara(list,llvmbool1type,ord((vol_read in source.volatility) or (vol_write in dest.volatility)),volatilepara);
if indivalign then
g_call_system_proc(list,pd,[@destpara,@sourcepara,@sizepara,@volatilepara],nil).resetiftemp
else
g_call_system_proc(list,pd,[@destpara,@sourcepara,@sizepara,@alignpara,@volatilepara],nil).resetiftemp;
sourcepara.done;
destpara.done;
sizepara.done;
alignpara.done;
volatilepara.done;
end;
procedure thlcgllvm.g_undefined_ok(list: TAsmList; size: tdef; reg: tregister);
begin
if not(llvmflag_no_freeze in llvmversion_properties[current_settings.llvmversion]) then
begin
list.concat(taillvm.op_reg_size_reg(la_freeze,reg,size,reg));
exit;
end;
internalerror(2023010110);
end;
procedure thlcgllvm.a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister);
var
tmpreg: tregister;
href: treference;
fromcompcurr,
tocompcurr: boolean;
begin
href:=make_simple_ref(list,ref,fromsize);
{ named register -> use generic code }
if ref.refaddr=addr_full then
begin
gen_load_refaddrfull_anyreg(list,fromsize,tosize,href,reg,mms_movescalar);
exit
end;
{ comp and currency are handled by the x87 in this case. They cannot
be represented directly in llvm, and llvmdef translates them into i64
(since that's their storage size and internally they also are int64).
Solve this by changing the type to s80real once they are loaded into
a register. }
fromcompcurr:=
(fromsize.typ=floatdef) and
(tfloatdef(fromsize).floattype in [s64comp,s64currency]);
tocompcurr:=
(tosize.typ=floatdef) and
(tfloatdef(tosize).floattype in [s64comp,s64currency]);
if tocompcurr then
tosize:=s80floattype;
{ don't generate different code for loading e.g. extended into cextended,
but to take care of loading e.g. comp (=int64) into double }
if (fromsize.size<>tosize.size) then
tmpreg:=getfpuregister(list,fromsize)
else
tmpreg:=reg;
{ handle aggregate loads (happens if a struct needs to be passed in a
floating point register) }
if (fromsize.typ in [arraydef,recorddef]) or
(tosize.typ in [arraydef,recorddef]) then
begin
if handle_agg_load_ref_anyreg(list,fromsize,tosize,href,reg,mms_movescalar) then
exit;
end;
{ %tmpreg = load size* %ref }
list.concat(taillvm.op_reg_size_ref(la_load,tmpreg,cpointerdef.getreusable(fromsize),href));
if tmpreg<>reg then
if fromcompcurr then
{ treat as extended as long as it's in a register }
list.concat(taillvm.op_reg_size_reg_size(la_sitofp,reg,fromsize,tmpreg,tosize))
else
a_loadfpu_reg_reg(list,fromsize,tosize,tmpreg,reg);
end;
procedure thlcgllvm.a_loadfpu_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference);
var
tmpreg: tregister;
href: treference;
fromcompcurr,
tocompcurr: boolean;
begin
{ see comment in a_loadfpu_ref_reg }
fromcompcurr:=
(fromsize.typ=floatdef) and
(tfloatdef(fromsize).floattype in [s64comp,s64currency]);
tocompcurr:=
(tosize.typ=floatdef) and
(tfloatdef(tosize).floattype in [s64comp,s64currency]);
if fromcompcurr then
fromsize:=s80floattype;
href:=make_simple_ref(list,ref,tosize);
{ don't generate different code for loading e.g. extended into cextended,
but to take care of storing e.g. comp (=int64) into double }
if (fromsize.size<>tosize.size) then
begin
tmpreg:=getfpuregister(list,tosize);
if tocompcurr then
{ store back an int64 rather than an extended }
list.concat(taillvm.op_reg_size_reg_size(la_fptosi,tmpreg,fromsize,reg,tosize))
else
a_loadfpu_reg_reg(list,fromsize,tosize,reg,tmpreg);
end
else
tmpreg:=reg;
{ store tosize tmpreg, tosize* href }
list.concat(taillvm.op_size_reg_size_ref(la_store,tosize,tmpreg,cpointerdef.getreusable(tosize),href));
end;
procedure thlcgllvm.a_loadfpu_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister);
var
op: tllvmop;
intrinsic: TIDString;
begin
op:=llvmconvop(fromsize,tosize,true);
if (cs_opt_fastmath in current_settings.optimizerswitches) or
not(llvmflag_constrained_fptrunc_fpext in llvmversion_properties[current_settings.llvmversion]) or
not(op in [la_fptrunc,la_fpext]) then
list.concat(taillvm.op_reg_size_reg_size(op,reg2,fromsize,reg1,tosize))
else
begin
if op=la_fptrunc then
intrinsic:='llvm_experimental_constrained_fptrunc'
else
intrinsic:='llvm_experimental_constrained_fpext';
gen_fpconstrained_intrinsic(list,
intrinsic+llvmfloatintrinsicsuffix(tfloatdef(tosize))+llvmfloatintrinsicsuffix(tfloatdef(fromsize)),
fromsize,tosize,reg1,reg2,op=la_fptrunc);
end;
end;
procedure thlcgllvm.gen_fpconstrained_intrinsic(list: TAsmList; const intrinsic: TIDString; fromsize, tosize: tdef; fromreg, toreg: tregister; roundingmode: boolean);
var
exceptmode: ansistring;
frompara, roundpara, exceptpara, respara: tcgpara;
tmploc: tlocation;
pd: tprocdef;
begin
frompara.init;
if roundingmode then
roundpara.init;
exceptpara.init;
pd:=search_system_proc(intrinsic);
paramanager.getcgtempparaloc(list,pd,1,frompara);
if roundingmode then
begin
paramanager.getcgtempparaloc(list,pd,2,roundpara);
paramanager.getcgtempparaloc(list,pd,3,exceptpara);
end
else
paramanager.getcgtempparaloc(list,pd,2,exceptpara);
location_reset(tmploc,frompara.location^.loc,def_cgsize(fromsize));
tmploc.register:=fromreg;
gen_load_loc_cgpara(list,fromsize,tmploc,frompara);
if roundingmode then
a_load_reg_cgpara(list,llvm_metadatatype,tllvmmetadata.getstringreg('round.dynamic'),roundpara);
exceptmode:=llvm_constrainedexceptmodestring;
a_load_reg_cgpara(list,llvm_metadatatype,tllvmmetadata.getstringreg(exceptmode),exceptpara);
if roundingmode then
respara:=g_call_system_proc(list,pd,[@frompara,@roundpara,@exceptpara],nil)
else
respara:=g_call_system_proc(list,pd,[@frompara,@exceptpara],nil);
location_reset(tmploc,respara.location^.loc,def_cgsize(tosize));
tmploc.register:=toreg;
gen_load_cgpara_loc(list,tosize,respara,tmploc,false);
frompara.done;
if roundingmode then
roundpara.done;
exceptpara.done;
respara.resetiftemp;
end;
procedure thlcgllvm.gen_proc_symbol(list: TAsmList);
var
item: TCmdStrListItem;
mangledname: TSymStr;
asmsym: tasmsymbol;
begin
if po_external in current_procinfo.procdef.procoptions then
exit;
item:=TCmdStrListItem(current_procinfo.procdef.aliasnames.first);
mangledname:=current_procinfo.procdef.mangledname;
{ predefine the real function name as local/global, so the aliases can
refer to the symbol and get the binding correct }
if (cs_profile in current_settings.moduleswitches) or
(po_global in current_procinfo.procdef.procoptions) then
asmsym:=current_asmdata.DefineAsmSymbol(mangledname,AB_GLOBAL,AT_FUNCTION,current_procinfo.procdef)
else
asmsym:=current_asmdata.DefineAsmSymbol(mangledname,AB_LOCAL,AT_FUNCTION,current_procinfo.procdef);
while assigned(item) do
begin
if mangledname<>item.Str then
list.concat(taillvmalias.create(asmsym,item.str,current_procinfo.procdef,asmsym.bind));
item:=TCmdStrListItem(item.next);
end;
list.concat(taillvmdecl.createdef(asmsym,current_procinfo.procdef.procsym,current_procinfo.procdef,nil,sec_code,current_procinfo.procdef.alignment));
current_procinfo.procdef.procstarttai:=tai(list.last);
end;
procedure thlcgllvm.handle_external_proc(list: TAsmList; pd: tprocdef; const importname: TSymStr);
begin
{ don't do anything, because at this point we can't know yet for certain
whether the aliased routine is internal to the current routine or not.
If it's internal, we would have to generate an llvm alias, while if it's
external, we would have to generate a declaration. Additionally, aliases
cannot refer to declarations, so always creating aliases doesn't work
either -> handle in llvmtype }
end;
procedure thlcgllvm.g_proc_entry(list: TAsmList; localsize: longint; nostackframe: boolean);
begin
list.concatlist(ttgllvm(tg).alloclist)
{ rest: todo }
end;
procedure thlcgllvm.g_proc_exit(list: TAsmList; parasize: longint; nostackframe: boolean);
var
retdef: tdef;
retreg,
hreg: tregister;
retpara: tcgpara;
begin
{ the function result type is the type of the first location, which can
differ from the real result type (e.g. int64 for a record consisting of
two longint fields on x86-64 -- we are responsible for lowering the
result types like that) }
retpara:=get_call_result_cgpara(current_procinfo.procdef,nil);
retpara.check_simple_location;
retdef:=retpara.location^.def;
if (is_void(retdef) or
{ don't check retdef here, it is e.g. a pshortstring in case it's
shortstring that's returned in a parameter }
paramanager.ret_in_param(current_procinfo.procdef.returndef,current_procinfo.procdef)) and
not current_procinfo.procdef.generate_safecall_wrapper then
list.concat(taillvm.op_size(la_ret,voidtype))
else
begin
case retpara.location^.loc of
LOC_REGISTER,
LOC_FPUREGISTER,
LOC_MMREGISTER:
begin
{ sign/zeroextension of function results is handled implicitly
via the signext/zeroext modifiers of the result, rather than
in the code generator -> remove any explicit extensions here }
retreg:=retpara.location^.register;
if (current_procinfo.procdef.returndef.typ in [orddef,enumdef]) and
(retdef.typ in [orddef,enumdef]) and
not current_procinfo.procdef.generate_safecall_wrapper then
begin
if (current_procinfo.procdef.returndef.size<retpara.location^.def.size) then
begin
hreg:=getintregister(list,current_procinfo.procdef.returndef);
a_load_reg_reg(list,retdef,current_procinfo.procdef.returndef,retreg,hreg);
retreg:=hreg;
retdef:=current_procinfo.procdef.returndef;
end;
end;
list.concat(taillvm.op_size_reg(la_ret,retdef,retreg))
end;
LOC_VOID:
begin
{ zero-sized records: return an undefined zero-sized record of
the correct type }
list.concat(taillvm.op_size_undef(la_ret,retdef));
end
else
{ todo: complex returns }
internalerror(2012111106);
end;
end;
retpara.resetiftemp;
end;
procedure thlcgllvm.gen_load_uninitialized_function_result(list: TAsmList; pd: tprocdef; resdef: tdef; const resloc: tcgpara);
begin
if not paramanager.ret_in_param(resdef,pd) then
begin
case resloc.location^.loc of
LOC_REGISTER,
LOC_FPUREGISTER,
LOC_MMREGISTER:
begin
if not llvmaggregatetype(resdef) then
list.concat(taillvm.op_reg_size_undef(la_bitcast,resloc.location^.register,llvmgetcgparadef(resloc,true,calleeside)))
else
{ bitcast doesn't work for aggregates -> just load from the
(uninitialised) function result memory location }
gen_load_loc_function_result(list,resdef,tabstractnormalvarsym(pd.funcretsym).localloc)
end;
{ for empty record returns }
LOC_VOID:
;
else
internalerror(2015042301);
end;
end;
end;
procedure thlcgllvm.g_overflowcheck(list: TAsmList; const Loc: tlocation; def: tdef);
begin
{ not possible, need ovloc }
internalerror(2012111107);
end;
procedure thlcgllvm.g_overflowCheck_loc(List: TAsmList; const Loc: TLocation; def: TDef; var ovloc: tlocation);
var
hl: tasmlabel;
begin
if not(cs_check_overflow in current_settings.localswitches) then
exit;
if ovloc.size<>OS_8 then
internalerror(2015122504);
current_asmdata.getjumplabel(hl);
a_cmp_const_loc_label(list,llvmbool1type,OC_EQ,0,ovloc,hl);
g_call_system_proc(list,'fpc_overflow',[],nil).resetiftemp;
a_label(list,hl);
end;
procedure thlcgllvm.g_ptrtypecast_reg(list: TAsmList; fromdef, todef: tdef; var reg: tregister);
var
hreg: tregister;
begin
{ will insert a bitcast if necessary }
if (fromdef<>todef) and
not(llvmflag_opaque_ptr in llvmversion_properties[current_settings.llvmversion]) then
begin
hreg:=getregisterfordef(list,todef);
a_load_reg_reg(list,fromdef,todef,reg,hreg);
reg:=hreg;
end;
end;
procedure thlcgllvm.g_ptrtypecast_ref(list: TAsmList; fromdef, todef: tdef; var ref: treference);
var
hreg: tregister;
begin
{ the reason for the array exception is that we sometimes generate
getelementptr array_element_ty, arrayref, 0, 0
to get a pointer to the first element of the array. That expression is
not valid if arrayref does not point to an array. Clang does the same.
}
if (llvmflag_opaque_ptr in llvmversion_properties[current_settings.llvmversion]) and
(((fromdef.typ=pointerdef) and (tpointerdef(fromdef).pointeddef.typ=arraydef)) <>
((todef.typ=pointerdef) and (tpointerdef(todef).pointeddef.typ=arraydef))
) then
exit;
hreg:=getaddressregister(list,todef);
a_loadaddr_ref_reg_intern(list,fromdef,todef,ref,hreg,false);
reference_reset_base(ref,todef,hreg,0,ref.temppos,ref.alignment,ref.volatility);
end;
procedure thlcgllvm.g_set_addr_nonbitpacked_field_ref(list: TAsmList; recdef: tabstractrecorddef; field: tfieldvarsym; var recref: treference);
var
parentdef,
subscriptdef,
currentstructdef,
llvmfielddef: tdef;
llvmfield: tllvmshadowsymtableentry;
newbase: tregister;
implicitpointer: boolean;
begin
implicitpointer:=is_implicit_pointer_object_type(recdef);
currentstructdef:=recdef;
{ in case the field is part of a parent of the current object,
index into the parents until we're at the parent containing the
field; if it's an implicit pointer type, these embedded parents
will be of the structure type of the class rather than of the
class time itself -> one indirection fewer }
while field.owner<>tabstractrecorddef(currentstructdef).symtable do
begin
{ only objectdefs have parents and hence the owner of the
fieldvarsym can be different from the current def's owner }
parentdef:=tobjectdef(currentstructdef).childof;
if implicitpointer then
newbase:=getaddressregister(list,parentdef)
else
newbase:=getaddressregister(list,cpointerdef.getreusable(parentdef));
recref:=make_simple_ref(list,recref,recdef);
if implicitpointer then
subscriptdef:=currentstructdef
else
subscriptdef:=cpointerdef.getreusable(currentstructdef);
{ recurse into the first field }
list.concat(taillvm.getelementptr_reg_size_ref_size_const(newbase,subscriptdef,recref,s32inttype,0,true));
reference_reset_base(recref,subscriptdef,newbase,field.offsetfromllvmfield,recref.temppos,newalignment(recref.alignment,field.fieldoffset),recref.volatility);
{ go to the parent }
currentstructdef:=parentdef;
end;
{ get the corresponding field in the llvm shadow symtable }
llvmfield:=tabstractrecordsymtable(tabstractrecorddef(currentstructdef).symtable).llvmst[field];
if implicitpointer then
subscriptdef:=currentstructdef
else
subscriptdef:=cpointerdef.getreusable(currentstructdef);
{ load the address of that shadow field }
newbase:=getaddressregister(list,cpointerdef.getreusable(llvmfield.def));
recref:=make_simple_ref(list,recref,recdef);
list.concat(taillvm.getelementptr_reg_size_ref_size_const(newbase,subscriptdef,recref,s32inttype,field.llvmfieldnr,true));
reference_reset_base(recref,subscriptdef,newbase,field.offsetfromllvmfield,recref.temppos,newalignment(recref.alignment,llvmfield.fieldoffset+field.offsetfromllvmfield),recref.volatility);
{ in case of an 80 bits extended type, typecast from an array of 10
bytes (used because otherwise llvm will allocate the ABI-defined
size for extended, which is usually larger) into an extended }
if (llvmfield.def.typ=floatdef) and
(tfloatdef(llvmfield.def).floattype=s80real) then
g_ptrtypecast_ref(list,cpointerdef.getreusable(carraydef.getreusable(u8inttype,10)),cpointerdef.getreusable(s80floattype),recref);
{ if it doesn't match the requested field exactly (variant record),
adjust the type of the pointer }
if (field.offsetfromllvmfield<>0) or
(llvmfield.def<>field.vardef) then
g_ptrtypecast_ref(list,cpointerdef.getreusable(llvmfield.def),cpointerdef.getreusable(field.vardef),recref);
end;
procedure thlcgllvm.a_loadmm_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister; shuffle: pmmshuffle);
var
href: treference;
begin
if shuffle=mms_movescalar then
a_loadfpu_ref_reg(list,fromsize,tosize,ref,reg)
else
begin
href:=make_simple_ref(list,ref,fromsize);
if ref.refaddr=addr_full then
gen_load_refaddrfull_anyreg(list,fromsize,tosize,href,reg,shuffle)
else
begin
{ handle aggregate loads (happens if a struct needs to be passed
in an mmregister) }
if (fromsize.typ in [arraydef,recorddef]) or
(tosize.typ in [arraydef,recorddef]) then
begin
if handle_agg_load_ref_anyreg(list,fromsize,tosize,href,reg,mms_movescalar) then
exit;
end;
if fromsize<>tosize then
g_ptrtypecast_ref(list,cpointerdef.getreusable(fromsize),cpointerdef.getreusable(tosize),href);
{ %reg = load size* %ref }
list.concat(taillvm.op_reg_size_ref(la_load,reg,cpointerdef.getreusable(tosize),href));
end;
end;
end;
procedure thlcgllvm.a_loadmm_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference; shuffle: pmmshuffle);
var
href: treference;
begin
if shuffle=mms_movescalar then
a_loadfpu_reg_ref(list,fromsize,tosize,reg,ref)
else
begin
{ todo }
if fromsize<>tosize then
internalerror(2013060220);
href:=make_simple_ref(list,ref,tosize);
{ store tosize reg, tosize* href }
list.concat(taillvm.op_size_reg_size_ref(la_store,tosize,reg,cpointerdef.getreusable(tosize),href))
end;
end;
procedure thlcgllvm.a_loadmm_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister; shuffle: pmmshuffle);
begin
if shuffle=mms_movescalar then
a_loadfpu_reg_reg(list,fromsize,tosize,reg1,reg2)
else
{ reg2 = bitcast fromllsize reg1 to tollsize }
list.concat(taillvm.op_reg_size_reg_size(la_bitcast,reg2,fromsize,reg1,tosize));
end;
procedure thlcgllvm.a_opmm_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; src, dst: tregister; shuffle: pmmshuffle);
begin
if (op=OP_XOR) and
(src=dst) then
a_load_const_reg(list,size,0,dst)
else
{ todo }
internalerror(2013060221);
end;
procedure thlcgllvm.a_loadmm_intreg_reg(list: TAsmList; fromsize, tosize: tdef; intreg, mmreg: tregister; shuffle: pmmshuffle);
begin
internalerror(2013060222);
end;
procedure thlcgllvm.a_loadmm_reg_intreg(list: TAsmList; fromsize, tosize: tdef; mmreg, intreg: tregister; shuffle: pmmshuffle);
begin
internalerror(2013060223);
end;
function thlcgllvm.get_call_result_cgpara(pd: tabstractprocdef; forceresdef: tdef): tcgpara;
var
paraloc: pcgparalocation;
begin
result:=inherited;
{ we'll change the paraloc, make sure we don't modify the original one }
if not result.temporary then
begin
result:=result.getcopy;
result.temporary:=true;
end;
{ get the LLVM representation of the function result (e.g. a
struct with two i64 fields for a record with 4 i32 fields) }
result.def:=llvmgetcgparadef(result,true,callerside);
if assigned(result.location^.next) then
begin
{ unify the result into a sinlge location; unlike for parameters,
we are not responsible for splitting up results into multiple
locations }
{ set the first location to the type of the function result }
result.location^.def:=result.def;
result.location^.size:=result.size;
{ free all extra paralocs }
while assigned(result.location^.next) do
begin
paraloc:=result.location^.next^.next;
freemem(result.location^.next);
result.location^.next:=paraloc;
end;
end;
paraloc:=result.location;
paraloc^.def:=result.def;
case paraloc^.loc of
LOC_VOID:
;
LOC_REGISTER,
LOC_FPUREGISTER,
LOC_MMREGISTER:
begin
paraloc^.llvmloc.loc:=paraloc^.loc;
paraloc^.llvmloc.reg:=paraloc^.register;
paraloc^.llvmvalueloc:=true;
end;
LOC_REFERENCE:
if not paramanager.ret_in_param(pd.returndef,pd) then
{ TODO, if this can happen at all }
internalerror(2014011901);
else
internalerror(2014011902);
end;
end;
procedure thlcgllvm.gen_load_loc_function_result(list: TAsmList; vardef: tdef; const l: tlocation);
var
retlocpara: tcgpara;
begin
retlocpara:=get_call_result_cgpara(current_procinfo.procdef,nil);
gen_load_loc_cgpara(list,vardef,l,retlocpara);
retlocpara.resetiftemp;
end;
procedure thlcgllvm.gen_load_loc_cgpara(list: TAsmList; vardef: tdef; const l: tlocation; const cgpara: tcgpara);
var
memloc: tlocation;
begin
if not(cgpara.location^.llvmvalueloc) then
begin
memloc:=l;
location_force_mem(list,memloc,vardef);
a_loadaddr_ref_cgpara(list,vardef,memloc.reference,cgpara);
end
else
inherited;
end;
procedure thlcgllvm.gen_load_cgpara_loc(list: TAsmList; vardef: tdef; const para: TCGPara; var destloc: tlocation; reusepara: boolean);
var
ploc : pcgparalocation;
hloc : tlocation;
href, href2 : treference;
hreg : tregister;
fielddef,
llvmparadef : tdef;
index : longint;
offset : pint;
userecord : boolean;
begin
{ ignore e.g. empty records }
if (para.location^.loc=LOC_VOID) then
exit;
{ If the parameter location is reused we don't need to copy
anything }
if (destloc.loc=LOC_REFERENCE) and
reusepara then
exit;
{ get the equivalent llvm def used to pass the parameter (e.g. a record
with two int64 fields for passing a record consisiting of 8 bytes on
x86-64) }
llvmparadef:=llvmgetcgparadef(para,true,calleeside);
userecord:=
(llvmparadef<>para.def) and
assigned(para.location^.next);
if userecord then
begin
{ llvmparadef is a record in this case, with every field corresponding
to a single paraloc }
if destloc.loc<>LOC_REFERENCE then
tg.gethltemp(list,llvmparadef,llvmparadef.size,tt_normal,href)
else
begin
hreg:=getaddressregister(list,cpointerdef.getreusable(llvmparadef));
a_loadaddr_ref_reg(list,vardef,cpointerdef.getreusable(llvmparadef),destloc.reference,hreg);
reference_reset_base(href,cpointerdef.getreusable(llvmparadef),hreg,0,destloc.reference.temppos,destloc.reference.alignment,destloc.reference.volatility);
end;
index:=0;
ploc:=para.location;
repeat
paraloctoloc(ploc,hloc);
g_setup_load_field_by_name(list,trecorddef(llvmparadef),'F'+tostr(index),href,href2,fielddef);
a_load_loc_ref(list,ploc^.def,fielddef,hloc,href2);
inc(index);
ploc:=ploc^.next;
until not assigned(ploc);
if destloc.loc<>LOC_REFERENCE then
tg.ungettemp(list,href);
end
else
begin
para.check_simple_location;
paraloctoloc(para.location,hloc);
case destloc.loc of
LOC_REFERENCE :
begin
case def2regtyp(llvmparadef) of
R_INTREGISTER,
R_ADDRESSREGISTER:
a_load_loc_ref(list,llvmparadef,vardef,hloc,destloc.reference);
R_FPUREGISTER:
a_loadfpu_loc_ref(list,llvmparadef,vardef,hloc,destloc.reference);
R_MMREGISTER:
a_loadmm_loc_ref(list,llvmparadef,vardef,hloc,destloc.reference,nil);
else
internalerror(2014080801);
end;
end;
LOC_REGISTER:
begin
a_load_loc_reg(list,llvmparadef,vardef,hloc,destloc.register);
end;
LOC_FPUREGISTER:
begin
a_loadfpu_loc_reg(list,llvmparadef,vardef,hloc,destloc.register);
end;
LOC_MMREGISTER:
begin
a_loadmm_loc_reg(list,llvmparadef,vardef,hloc,destloc.register,nil);
end;
{ TODO other possible locations }
else
internalerror(2013102304);
end;
end;
end;
procedure thlcgllvm.a_jmp_flags(list: TAsmList; const f: TResFlags; l: tasmlabel);
begin
internalerror(2013060224);
end;
procedure thlcgllvm.g_flags2reg(list: TAsmList; size: tdef; const f: tresflags; reg: TRegister);
begin
internalerror(2013060225);
end;
procedure thlcgllvm.g_flags2ref(list: TAsmList; size: tdef; const f: tresflags; const ref: TReference);
begin
internalerror(2013060226);
end;
procedure thlcgllvm.a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; srcsize, dstsize: tdef; src, dst: tregister);
begin
internalerror(2012090201);
end;
procedure thlcgllvm.g_stackpointer_alloc(list: TAsmList; size: longint);
begin
internalerror(2012090203);
end;
procedure thlcgllvm.g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint);
begin
internalerror(2012090204);
end;
procedure thlcgllvm.g_adjust_self_value(list: TAsmList; procdef: tprocdef; ioffset: aint);
begin
internalerror(2012090205);
end;
procedure thlcgllvm.g_local_unwind(list: TAsmList; l: TAsmLabel);
begin
internalerror(2012090206);
end;
procedure thlcgllvm.gen_stack_check_size_para(list: TAsmList);
begin
{ this is implemented in a very hackish way, whereby first the call
to fpc_stackcheck() is emitted, then the prolog is generated and
registers are allocated, and finally the code to load the parameter
is inserted before the call to fpc_stackcheck(). Since parameters are
explicitly passed to call instructions for llvm, that does not work
here. It could be solved by patching the call instruction later, but
that's a lot of engineering for functionality that's only marginally
useful at best. }
end;
procedure thlcgllvm.gen_stack_check_call(list: TAsmList);
begin
{ see explanation in thlcgllvm.gen_stack_check_size_para() }
end;
function thlcgllvm.make_simple_ref(list: TAsmList; const ref: treference; def: tdef): treference;
begin
result:=make_simple_ref_ptr(list,ref,cpointerdef.getreusable(def));
end;
function thlcgllvm.make_simple_ref_ptr(list: TAsmList; const ref: treference; ptrdef: tdef): treference;
var
ptrindex: tcgint;
hreg1,
hreg2: tregister;
tmpref: treference;
pointedsize: asizeint;
begin
if ref.alignment=0 then
internalerror(2016072203);
{ already simple? }
if (not assigned(ref.symbol) or
(ref.base=NR_NO)) and
(ref.index=NR_NO) and
(ref.offset=0) then
begin
result:=ref;
exit;
end;
case ptrdef.typ of
pointerdef:
begin
pointedsize:=tpointerdef(ptrdef).pointeddef.size;
{ void, formaldef }
if pointedsize=0 then
pointedsize:=1;
end;
else
begin
{ pointedsize is only used if the offset <> 0, to see whether we
can use getelementptr if it's an exact multiple -> set pointedsize
to a value that will never be a multiple as we can't "index" other
types }
pointedsize:=ref.offset+1;
end;
end;
hreg2:=getaddressregister(list,ptrdef);
{ symbol+offset or base+offset with offset a multiple of the size ->
use getelementptr }
if (ref.index=NR_NO) and
(ref.offset mod pointedsize=0) then
begin
ptrindex:=ref.offset div pointedsize;
if assigned(ref.symbol) then
reference_reset_symbol(tmpref,ref.symbol,0,ref.alignment,ref.volatility)
else
reference_reset_base(tmpref,ptrdef,ref.base,0,ref.temppos,ref.alignment,ref.volatility);
list.concat(taillvm.getelementptr_reg_size_ref_size_const(hreg2,ptrdef,tmpref,ptruinttype,ptrindex,assigned(ref.symbol)));
reference_reset_base(result,ptrdef,hreg2,0,ref.temppos,ref.alignment,ref.volatility);
exit;
end;
{ for now, perform all calculations using plain pointer arithmetic. Later
we can look into optimizations based on getelementptr for structured
accesses (if only to prevent running out of virtual registers).
Assumptions:
* symbol/base register: always type "ptrdef"
* index/offset: always type "ptruinttype" (llvm bitcode has no sign information, so sign doesn't matter) }
hreg1:=getintregister(list,ptruinttype);
if assigned(ref.symbol) then
begin
if ref.base<>NR_NO then
internalerror(2012111301);
reference_reset_symbol(tmpref,ref.symbol,0,ref.alignment,ref.volatility);
list.concat(taillvm.getelementptr_reg_size_ref_size_const(hreg1,ptrdef,tmpref,ptruinttype,0,true));
end
else if ref.base<>NR_NO then
begin
a_load_reg_reg(list,ptrdef,ptruinttype,ref.base,hreg1);
end
else
{ for absolute addresses }
a_load_const_reg(list,ptruinttype,0,hreg1);
if ref.index<>NR_NO then
begin
{ SSA... }
hreg2:=getintregister(list,ptruinttype);
a_op_reg_reg_reg(list,OP_ADD,ptruinttype,ref.index,hreg1,hreg2);
hreg1:=hreg2;
end;
if ref.offset<>0 then
begin
hreg2:=getintregister(list,ptruinttype);
a_op_const_reg_reg(list,OP_ADD,ptruinttype,ref.offset,hreg1,hreg2);
hreg1:=hreg2;
end;
hreg2:=getaddressregister(list,ptrdef);
a_load_reg_reg(list,ptruinttype,ptrdef,hreg1,hreg2);
reference_reset_base(result,ptrdef,hreg2,0,ref.temppos,ref.alignment,ref.volatility);
end;
procedure thlcgllvm.set_call_function_result(const list: TAsmList; const pd: tabstractprocdef; const llvmretdef, hlretdef: tdef; const resval: tregister; var retpara: tcgpara);
var
hreg: tregister;
rettemp: treference;
begin
if (not is_void(hlretdef) and
not paramanager.ret_in_param(hlretdef, pd)) or
pd.generate_safecall_wrapper then
begin
{ should already be a copy, because it currently describes the llvm
return location }
if not retpara.temporary then
internalerror(2014020101);
if llvmaggregatetype(hlretdef) then
begin
{ to ease the handling of aggregate types here, we just store
everything to memory rather than potentially dealing with aggregates
in "registers" }
tg.gethltemp(list, llvmretdef, llvmretdef.size, tt_normal, rettemp);
case def2regtyp(llvmretdef) of
R_INTREGISTER,
R_ADDRESSREGISTER:
a_load_reg_ref(list,llvmretdef,llvmretdef,resval,rettemp);
R_FPUREGISTER:
a_loadfpu_reg_ref(list,llvmretdef,llvmretdef,resval,rettemp);
R_MMREGISTER:
a_loadmm_reg_ref(list,llvmretdef,llvmretdef,resval,rettemp,mms_movescalar);
else
;
end;
{ the return parameter now contains a value whose type matches the one
that the high level code generator expects instead of the llvm shim
}
retpara.def:=llvmretdef;
retpara.location^.def:=llvmretdef;
{ for llvm-specific code: }
retpara.location^.llvmvalueloc:=false;
retpara.location^.llvmloc.loc:=LOC_REGISTER;
retpara.location^.llvmloc.reg:=rettemp.base;
{ for the rest (normally not used, but cleaner to set it correclty) }
retpara.location^.loc:=LOC_REFERENCE;
retpara.location^.reference.index:=rettemp.base;
retpara.location^.reference.offset:=0;
end
else
begin
retpara.def:=llvmretdef;
retpara.Location^.def:=llvmretdef;
retpara.location^.llvmloc.reg:=resval;
retpara.Location^.llvmloc.loc:=retpara.location^.loc;
retpara.Location^.llvmvalueloc:=true;
end;
end
else
retpara.location^.llvmloc.loc:=LOC_VOID;
end;
procedure thlcgllvm.paraloctoloc(const paraloc: pcgparalocation; out hloc: tlocation);
begin
case paraloc^.llvmloc.loc of
LOC_REFERENCE:
begin
location_reset_ref(hloc,LOC_REFERENCE,def_cgsize(paraloc^.def),paraloc^.def.alignment,[]);
hloc.reference.symbol:=paraloc^.llvmloc.sym;
if paraloc^.llvmvalueloc then
hloc.reference.refaddr:=addr_full;
end;
LOC_REGISTER:
begin
if paraloc^.llvmvalueloc then
begin
location_reset(hloc,LOC_REGISTER,def_cgsize(paraloc^.def));
hloc.register:=paraloc^.llvmloc.reg;
end
else
begin
if getregtype(paraloc^.llvmloc.reg)<>R_TEMPREGISTER then
internalerror(2014011903);
location_reset_ref(hloc,LOC_REFERENCE,def_cgsize(paraloc^.def),paraloc^.def.alignment,[]);
hloc.reference.base:=paraloc^.llvmloc.reg;
end;
end;
LOC_FPUREGISTER,
LOC_MMREGISTER:
begin
if paraloc^.llvmvalueloc then
begin
location_reset(hloc,paraloc^.llvmloc.loc,def_cgsize(paraloc^.def));
hloc.register:=paraloc^.llvmloc.reg;
end
else
internalerror(2014012401);
end
else
internalerror(2014010706);
end;
end;
procedure thlcgllvm.varsym_set_localloc(list: TAsmList; vs: tabstractnormalvarsym);
begin
if cs_asm_source in current_settings.globalswitches then
begin
case vs.initialloc.loc of
LOC_REFERENCE :
begin
if assigned(vs.initialloc.reference.symbol) then
list.concat(Tai_comment.Create(strpnew('Var '+vs.realname+' located at '+
vs.initialloc.reference.symbol.name)))
else
list.concat(Tai_comment.Create(strpnew('Var '+vs.realname+' located at %tmp.'+
tostr(getsupreg(vs.initialloc.reference.base)))));
end;
else
;
end;
end;
vs.localloc:=vs.initialloc;
end;
procedure thlcgllvm.paravarsym_set_initialloc_to_paraloc(vs: tparavarsym);
var
parasym : tasmsymbol;
begin
if vs.paraloc[calleeside].location^.llvmloc.loc<>LOC_REFERENCE then
internalerror(2014010708);
parasym:=vs.paraloc[calleeside].location^.llvmloc.sym;
reference_reset_symbol(vs.initialloc.reference,parasym,0,vs.paraloc[calleeside].alignment,[]);
if vs.paraloc[calleeside].location^.llvmvalueloc then
vs.initialloc.reference.refaddr:=addr_full;
end;
procedure thlcgllvm.g_external_wrapper(list: TAsmList; procdef: tprocdef; const wrappername, externalname: string; global: boolean);
var
asmsym: TAsmSymbol;
begin
if po_external in procdef.procoptions then
exit;
asmsym:=current_asmdata.RefAsmSymbol(externalname,AT_FUNCTION);
list.concat(taillvmalias.create(asmsym,wrappername,procdef,asmsym.bind));
end;
procedure create_hlcodegen_llvm;
begin
if not assigned(current_procinfo) or
not(po_assembler in current_procinfo.procdef.procoptions) then
begin
tgobjclass:=ttgllvm;
hlcg:=thlcgllvm.create;
cgllvm.create_codegen
end
else
begin
tgobjclass:=orgtgclass;
create_hlcodegen_cpu;
{ todo: handle/remove chlcgobj }
end;
end;
begin
chlcgobj:=thlcgllvm;
{ this unit must initialise after hlcgobj;
message system has not been initialised yet here }
if not assigned(create_hlcodegen) then
begin
writeln('Internalerror 2018052003');
halt(1);
end;
create_hlcodegen_cpu:=create_hlcodegen;
create_hlcodegen:=@create_hlcodegen_llvm;
end.