paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-04 12:39:38 +01:00
Code Issues Packages Projects Releases Wiki Activity
13a860eefc
fpc/compiler/ncgmem.pas

1274 lines
50 KiB
ObjectPascal
Raw Blame History

{
$Id$
Copyright (c) 1998-2002 by Florian Klaempfl
Generate assembler for memory related nodes which are
the same for all (most?) processors
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.
****************************************************************************
}
{ This unit generate assembler for memory related nodes.
}
unit ncgmem;
{$i fpcdefs.inc}
interface
uses
cgbase,cpuinfo,cpubase,
node,nmem;
type
tcgloadvmtaddrnode = class(tloadvmtaddrnode)
procedure pass_2;override;
end;
tcgloadparentfpnode = class(tloadparentfpnode)
procedure pass_2;override;
end;
tcgaddrnode = class(taddrnode)
procedure pass_2;override;
end;
tcgderefnode = class(tderefnode)
procedure pass_2;override;
end;
tcgsubscriptnode = class(tsubscriptnode)
procedure pass_2;override;
end;
tcgwithnode = class(twithnode)
procedure pass_2;override;
end;
tcgvecnode = class(tvecnode)
private
procedure rangecheck_array;
protected
function get_mul_size : longint;
{# This routine is used to calculate the address of the reference.
On entry reg contains the index in the array,
and l contains the size of each element in the array.
This routine should update location.reference correctly,
so it points to the correct address.
}
procedure update_reference_reg_mul(reg:tregister;l:aword);virtual;
procedure second_wideansistring;virtual;
procedure second_dynamicarray;virtual;
public
procedure pass_2;override;
end;
implementation
uses
{$ifdef delphi}
sysutils,
{$else}
strings,
{$endif}
{$ifdef GDB}
gdb,
{$endif GDB}
globtype,systems,
cutils,verbose,globals,
symconst,symdef,symsym,defutil,paramgr,
aasmbase,aasmtai,
procinfo,pass_2,
pass_1,nld,ncon,nadd,nutils,
cgutils,cgobj,
tgobj,ncgutil,symbase
;
{*****************************************************************************
TCGLOADVMTADDRNODE
*****************************************************************************}
procedure tcgloadvmtaddrnode.pass_2;
var
href : treference;
begin
location_reset(location,LOC_REGISTER,OS_ADDR);
if (left.nodetype<>typen) then
begin
{ left contains self, load vmt from self }
secondpass(left);
if is_object(left.resulttype.def) then
begin
case left.location.loc of
LOC_CREFERENCE,
LOC_REFERENCE:
begin
location_release(exprasmlist,left.location);
reference_reset_base(href,cg.getaddressregister(exprasmlist),tobjectdef(left.resulttype.def).vmt_offset);
cg.a_loadaddr_ref_reg(exprasmlist,left.location.reference,href.base);
end;
else
internalerror(200305056);
end;
end
else
begin
case left.location.loc of
LOC_REGISTER:
begin
{$ifdef cpu_uses_separate_address_registers}
if getregtype(left.location.register)<>R_ADDRESSREGISTER then
begin
location_release(exprasmlist,left.location);
reference_reset_base(href,cg.getaddressregister(exprasmlist),tobjectdef(left.resulttype.def).vmt_offset);
cg.a_load_reg_reg(exprasmlist,OS_ADDR,OS_ADDR,left.location.register,href.base);
end
else
{$endif}
reference_reset_base(href,left.location.register,tobjectdef(left.resulttype.def).vmt_offset);
end;
LOC_CREGISTER,
LOC_CREFERENCE,
LOC_REFERENCE:
begin
location_release(exprasmlist,left.location);
reference_reset_base(href,cg.getaddressregister(exprasmlist),tobjectdef(left.resulttype.def).vmt_offset);
cg.a_load_loc_reg(exprasmlist,OS_ADDR,left.location,href.base);
end;
else
internalerror(200305057);
end;
end;
reference_release(exprasmlist,href);
location.register:=cg.getaddressregister(exprasmlist);
cg.g_maybe_testself(exprasmlist,href.base);
cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,href,location.register);
end
else
begin
reference_reset_symbol(href,
objectlibrary.newasmsymbol(tobjectdef(tclassrefdef(resulttype.def).pointertype.def).vmt_mangledname,AB_EXTERNAL,AT_DATA),0);
location.register:=cg.getaddressregister(exprasmlist);
cg.a_loadaddr_ref_reg(exprasmlist,href,location.register);
end;
end;
{*****************************************************************************
TCGLOADPARENTFPNODE
*****************************************************************************}
procedure tcgloadparentfpnode.pass_2;
var
currpi : tprocinfo;
hsym : tvarsym;
href : treference;
begin
if (current_procinfo.procdef.parast.symtablelevel=parentpd.parast.symtablelevel) then
begin
location_reset(location,LOC_REGISTER,OS_ADDR);
location.register:=current_procinfo.framepointer;
end
else
begin
currpi:=current_procinfo;
location_reset(location,LOC_REGISTER,OS_ADDR);
location.register:=cg.getaddressregister(exprasmlist);
{ load framepointer of current proc }
hsym:=tvarsym(currpi.procdef.parast.search('parentfp'));
if not assigned(hsym) then
internalerror(200309281);
case hsym.localloc.loc of
LOC_REFERENCE :
begin
reference_reset_base(href,hsym.localloc.reference.index,hsym.localloc.reference.offset);
cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,href,location.register);
end;
LOC_REGISTER :
cg.a_load_reg_reg(exprasmlist,OS_ADDR,OS_ADDR,hsym.localloc.register,location.register);
end;
{ walk parents }
while (currpi.procdef.owner.symtablelevel>parentpd.parast.symtablelevel) do
begin
currpi:=currpi.parent;
if not assigned(currpi) then
internalerror(200311201);
hsym:=tvarsym(currpi.procdef.parast.search('parentfp'));
if not assigned(hsym) then
internalerror(200309282);
if hsym.localloc.loc<>LOC_REFERENCE then
internalerror(200309283);
reference_reset_base(href,location.register,hsym.localloc.reference.offset);
cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,href,location.register);
end;
end;
end;
{*****************************************************************************
TCGADDRNODE
*****************************************************************************}
procedure tcgaddrnode.pass_2;
begin
secondpass(left);
{ when loading procvar we do nothing with this node, so load the
location of left }
if nf_procvarload in flags then
begin
location_copy(location,left.location);
exit;
end;
location_release(exprasmlist,left.location);
location_reset(location,LOC_REGISTER,OS_ADDR);
location.register:=cg.getaddressregister(exprasmlist);
{ @ on a procvar means returning an address to the procedure that
is stored in it }
if (m_tp_procvar in aktmodeswitches) and
(left.nodetype=loadn) and
(tloadnode(left).resulttype.def.deftype=procvardef) and
assigned(tloadnode(left).symtableentry) and
(tloadnode(left).symtableentry.typ=varsym) then
cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,left.location.reference,location.register)
else
cg.a_loadaddr_ref_reg(exprasmlist,left.location.reference,location.register);
end;
{*****************************************************************************
TCGDEREFNODE
*****************************************************************************}
procedure tcgderefnode.pass_2;
var
paraloc1 : tparalocation;
begin
secondpass(left);
location_reset(location,LOC_REFERENCE,def_cgsize(resulttype.def));
case left.location.loc of
LOC_REGISTER:
begin
{$ifdef cpu_uses_separate_address_registers}
if getregtype(left.location.register)<>R_ADDRESSREGISTER then
begin
location_release(exprasmlist,left.location);
location.reference.base := cg.getaddressregister(exprasmlist);
cg.a_load_reg_reg(exprasmlist,OS_ADDR,OS_ADDR,left.location.register,
location.reference.base);
end
else
{$endif}
location.reference.base := left.location.register;
end;
LOC_CREGISTER,
LOC_CREFERENCE,
LOC_REFERENCE:
begin
location_release(exprasmlist,left.location);
location.reference.base:=cg.getaddressregister(exprasmlist);
cg.a_load_loc_reg(exprasmlist,OS_ADDR,left.location,location.reference.base);
end;
end;
if (cs_gdb_heaptrc in aktglobalswitches) and
(cs_checkpointer in aktglobalswitches) and
not(cs_compilesystem in aktmoduleswitches) and
(not tpointerdef(left.resulttype.def).is_far) then
begin
paraloc1:=paramanager.getintparaloc(pocall_default,1);
paramanager.allocparaloc(exprasmlist,paraloc1);
cg.a_param_reg(exprasmlist, OS_ADDR,location.reference.base,paraloc1);
paramanager.freeparaloc(exprasmlist,paraloc1);
{ FPC_CHECKPOINTER uses saveregisters }
cg.a_call_name(exprasmlist,'FPC_CHECKPOINTER');
end;
end;
{*****************************************************************************
TCGSUBSCRIPTNODE
*****************************************************************************}
procedure tcgsubscriptnode.pass_2;
var
paraloc1 : tparalocation;
begin
secondpass(left);
if codegenerror then
exit;
{ classes and interfaces must be dereferenced implicit }
if is_class_or_interface(left.resulttype.def) then
begin
location_reset(location,LOC_REFERENCE,def_cgsize(resulttype.def));
case left.location.loc of
LOC_CREGISTER,
LOC_REGISTER:
begin
{$ifdef cpu_uses_separate_address_registers}
if getregtype(left.location.register)<>R_ADDRESSREGISTER then
begin
location_release(exprasmlist,left.location);
location.reference.base:=rg.getaddressregister(exprasmlist);
cg.a_load_reg_reg(exprasmlist,OS_ADDR,OS_ADDR,
left.location.register,location.reference.base);
end
else
{$endif}
location.reference.base := left.location.register;
end;
LOC_CREFERENCE,
LOC_REFERENCE:
begin
location_release(exprasmlist,left.location);
location.reference.base:=cg.getaddressregister(exprasmlist);
cg.a_load_loc_reg(exprasmlist,OS_ADDR,left.location,location.reference.base);
end;
end;
{ implicit deferencing }
if (cs_gdb_heaptrc in aktglobalswitches) and
(cs_checkpointer in aktglobalswitches) and
not(cs_compilesystem in aktmoduleswitches) then
begin
paraloc1:=paramanager.getintparaloc(pocall_default,1);
paramanager.allocparaloc(exprasmlist,paraloc1);
cg.a_param_reg(exprasmlist, OS_ADDR,location.reference.base,paraloc1);
paramanager.freeparaloc(exprasmlist,paraloc1);
{ FPC_CHECKPOINTER uses saveregisters }
cg.a_call_name(exprasmlist,'FPC_CHECKPOINTER');
end;
end
else if is_interfacecom(left.resulttype.def) then
begin
tg.GetTempTyped(exprasmlist,left.resulttype.def,tt_normal,location.reference);
cg.a_load_loc_ref(exprasmlist,OS_ADDR,left.location,location.reference);
{ implicit deferencing also for interfaces }
if (cs_gdb_heaptrc in aktglobalswitches) and
(cs_checkpointer in aktglobalswitches) and
not(cs_compilesystem in aktmoduleswitches) then
begin
paraloc1:=paramanager.getintparaloc(pocall_default,1);
paramanager.allocparaloc(exprasmlist,paraloc1);
cg.a_param_reg(exprasmlist, OS_ADDR,location.reference.base,paraloc1);
paramanager.freeparaloc(exprasmlist,paraloc1);
{ FPC_CHECKPOINTER uses saveregisters }
cg.a_call_name(exprasmlist,'FPC_CHECKPOINTER');
end;
end
else
location_copy(location,left.location);
inc(location.reference.offset,vs.fieldoffset);
{ also update the size of the location }
location.size:=def_cgsize(resulttype.def);
end;
{*****************************************************************************
TCGWITHNODE
*****************************************************************************}
procedure tcgwithnode.pass_2;
{$ifdef WITHNODEDEBUG}
const
withlevel : longint = 0;
var
withstartlabel,withendlabel : tasmlabel;
pp : pchar;
mangled_length : longint;
refnode : tnode;
{$endif WITHNODEDEBUG}
begin
location_reset(location,LOC_VOID,OS_NO);
{$ifdef WITHNODEDEBUG}
if (cs_debuginfo in aktmoduleswitches) then
begin
{ load reference }
if (withrefnode.nodetype=derefn) and
(tderefnode(withrefnode).left.nodetype=temprefn) then
refnode:=tderefnode(withrefnode).left
else
refnode:=withrefnode;
secondpass(refnode);
location_release(exprasmlist,refnode.location);
location_freetemp(exprasmlist,refnode.location);
if not(refnode.location.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
internalerror(2003092810);
inc(withlevel);
objectlibrary.getaddrlabel(withstartlabel);
objectlibrary.getaddrlabel(withendlabel);
cg.a_label(exprasmlist,withstartlabel);
withdebugList.concat(Tai_stabs.Create(strpnew(
'"with'+tostr(withlevel)+':'+tostr(symtablestack.getnewtypecount)+
'=*'+tstoreddef(left.resulttype.def).numberstring+'",'+
tostr(N_LSYM)+',0,0,'+tostr(refnode.location.reference.offset))));
mangled_length:=length(current_procinfo.procdef.mangledname);
getmem(pp,mangled_length+50);
strpcopy(pp,'192,0,0,'+withstartlabel.name);
if (target_info.use_function_relative_addresses) then
begin
strpcopy(strend(pp),'-');
strpcopy(strend(pp),current_procinfo.procdef.mangledname);
end;
withdebugList.concat(Tai_stabn.Create(strnew(pp)));
end;
{$endif WITHNODEDEBUG}
if assigned(left) then
secondpass(left);
{$ifdef WITHNODEDEBUG}
if (cs_debuginfo in aktmoduleswitches) then
begin
cg.a_label(exprasmlist,withendlabel);
strpcopy(pp,'224,0,0,'+withendlabel.name);
if (target_info.use_function_relative_addresses) then
begin
strpcopy(strend(pp),'-');
strpcopy(strend(pp),current_procinfo.procdef.mangledname);
end;
withdebugList.concat(Tai_stabn.Create(strnew(pp)));
freemem(pp,mangled_length+50);
dec(withlevel);
end;
{$endif WITHNODEDEBUG}
end;
{*****************************************************************************
TCGVECNODE
*****************************************************************************}
function tcgvecnode.get_mul_size : longint;
begin
if nf_memindex in flags then
get_mul_size:=1
else
begin
if (left.resulttype.def.deftype=arraydef) then
get_mul_size:=tarraydef(left.resulttype.def).elesize
else
get_mul_size:=resulttype.def.size;
end
end;
procedure tcgvecnode.update_reference_reg_mul(reg:tregister;l:aword);
var
hreg: tregister;
begin
if location.reference.base=NR_NO then
begin
if l<>1 then
cg.a_op_const_reg(exprasmlist,OP_IMUL,OS_ADDR,l,reg);
location.reference.base:=reg;
end
else if location.reference.index=NR_NO then
begin
if l<>1 then
cg.a_op_const_reg(exprasmlist,OP_IMUL,OS_ADDR,l,reg);
location.reference.index:=reg;
end
else
begin
cg.ungetreference(exprasmlist,location.reference);
hreg := cg.getaddressregister(exprasmlist);
cg.a_loadaddr_ref_reg(exprasmlist,location.reference,hreg);
reference_reset_base(location.reference,hreg,0);
{ insert new index register }
if l<>1 then
cg.a_op_const_reg(exprasmlist,OP_IMUL,OS_ADDR,l,reg);
location.reference.index:=reg;
end;
end;
procedure tcgvecnode.second_wideansistring;
begin
end;
procedure tcgvecnode.second_dynamicarray;
begin
end;
procedure tcgvecnode.rangecheck_array;
var
freereg : boolean;
hightree : tnode;
poslabel,
neglabel : tasmlabel;
hreg : tregister;
paraloc1,paraloc2 : tparalocation;
begin
if is_open_array(left.resulttype.def) or
is_array_of_const(left.resulttype.def) then
begin
{ cdecl functions don't have high() so we can not check the range }
if not(current_procinfo.procdef.proccalloption in [pocall_cdecl,pocall_cppdecl]) then
begin
{ Get high value }
hightree:=load_high_value_node(tvarsym(tloadnode(left).symtableentry));
{ it must be available }
if not assigned(hightree) then
internalerror(200212201);
firstpass(hightree);
secondpass(hightree);
{ generate compares }
freereg:=false;
if (right.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
hreg:=right.location.register
else
begin
hreg:=cg.getintregister(exprasmlist,OS_INT);
freereg:=true;
cg.a_load_loc_reg(exprasmlist,OS_INT,right.location,hreg);
end;
objectlibrary.getlabel(neglabel);
objectlibrary.getlabel(poslabel);
cg.a_cmp_const_reg_label(exprasmlist,OS_INT,OC_LT,0,hreg,poslabel);
location_release(exprasmlist,hightree.location);
cg.a_cmp_loc_reg_label(exprasmlist,OS_INT,OC_BE,hightree.location,hreg,neglabel);
if freereg then
cg.ungetregister(exprasmlist,hreg);
cg.a_label(exprasmlist,poslabel);
cg.a_call_name(exprasmlist,'FPC_RANGEERROR');
cg.a_label(exprasmlist,neglabel);
{ release hightree }
hightree.free;
end;
end
else
if is_dynamic_array(left.resulttype.def) then
begin
paraloc1:=paramanager.getintparaloc(pocall_default,1);
paraloc2:=paramanager.getintparaloc(pocall_default,2);
paramanager.allocparaloc(exprasmlist,paraloc2);
cg.a_param_loc(exprasmlist,right.location,paraloc2);
paramanager.allocparaloc(exprasmlist,paraloc1);
cg.a_param_loc(exprasmlist,left.location,paraloc1);
paramanager.freeparaloc(exprasmlist,paraloc1);
paramanager.freeparaloc(exprasmlist,paraloc2);
cg.allocexplicitregisters(exprasmlist,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
cg.a_call_name(exprasmlist,'FPC_DYNARRAY_RANGECHECK');
cg.deallocexplicitregisters(exprasmlist,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
end
else
cg.g_rangecheck(exprasmlist,right.location,right.resulttype.def,left.resulttype.def);
end;
procedure tcgvecnode.pass_2;
var
extraoffset : longint;
t : tnode;
href : treference;
otl,ofl : tasmlabel;
newsize : tcgsize;
mulsize: longint;
isjump : boolean;
paraloc1,paraloc2 : tparalocation;
begin
mulsize := get_mul_size;
newsize:=def_cgsize(resulttype.def);
secondpass(left);
if left.location.loc=LOC_CREFERENCE then
location_reset(location,LOC_CREFERENCE,newsize)
else
location_reset(location,LOC_REFERENCE,newsize);
{ an ansistring needs to be dereferenced }
if is_ansistring(left.resulttype.def) or
is_widestring(left.resulttype.def) then
begin
if nf_callunique in flags then
internalerror(200304236);
{DM!!!!!}
case left.location.loc of
LOC_REGISTER,
LOC_CREGISTER :
location.reference.base:=left.location.register;
LOC_CREFERENCE,
LOC_REFERENCE :
begin
location_release(exprasmlist,left.location);
location.reference.base:=cg.getaddressregister(exprasmlist);
cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,left.location.reference,location.reference.base);
end;
else
internalerror(2002032218);
end;
{ check for a zero length string,
we can use the ansistring routine here }
if (cs_check_range in aktlocalswitches) then
begin
paraloc1:=paramanager.getintparaloc(pocall_default,1);
paramanager.allocparaloc(exprasmlist,paraloc1);
cg.a_param_reg(exprasmlist,OS_ADDR,location.reference.base,paraloc1);
paramanager.freeparaloc(exprasmlist,paraloc1);
cg.allocexplicitregisters(exprasmlist,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
cg.a_call_name(exprasmlist,'FPC_'+upper(tstringdef(left.resulttype.def).stringtypname)+'_CHECKZERO');
cg.deallocexplicitregisters(exprasmlist,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
end;
{ in ansistrings/widestrings S[1] is p<w>char(S)[0] !! }
if is_ansistring(left.resulttype.def) then
dec(location.reference.offset)
else
dec(location.reference.offset,2);
end
else if is_dynamic_array(left.resulttype.def) then
begin
case left.location.loc of
LOC_REGISTER,
LOC_CREGISTER :
location.reference.base:=left.location.register;
LOC_REFERENCE,
LOC_CREFERENCE :
begin
location_release(exprasmlist,left.location);
location.reference.base:=cg.getaddressregister(exprasmlist);
cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,
left.location.reference,location.reference.base);
end;
else
internalerror(2002032219);
end;
end
else
location_copy(location,left.location);
{ offset can only differ from 0 if arraydef }
if (left.resulttype.def.deftype=arraydef) and
not(is_dynamic_array(left.resulttype.def)) then
dec(location.reference.offset,mulsize*tarraydef(left.resulttype.def).lowrange);
if right.nodetype=ordconstn then
begin
{ offset can only differ from 0 if arraydef }
case left.resulttype.def.deftype of
arraydef :
begin
if not(is_open_array(left.resulttype.def)) and
not(is_array_of_const(left.resulttype.def)) and
not(is_dynamic_array(left.resulttype.def)) then
begin
if (tordconstnode(right).value>tarraydef(left.resulttype.def).highrange) or
(tordconstnode(right).value<tarraydef(left.resulttype.def).lowrange) then
begin
{ this should be caught in the resulttypepass! (JM) }
if (cs_check_range in aktlocalswitches) then
CGMessage(parser_e_range_check_error)
else
CGMessage(parser_w_range_check_error);
end;
end
else
begin
{ range checking for open and dynamic arrays needs
runtime code }
secondpass(right);
if (cs_check_range in aktlocalswitches) then
rangecheck_array;
end;
end;
stringdef :
begin
if (cs_check_range in aktlocalswitches) then
begin
case tstringdef(left.resulttype.def).string_typ of
{ it's the same for ansi- and wide strings }
st_widestring,
{$ifdef ansistring_bits}
st_ansistring16,st_ansistring32,st_ansistring64:
{$else}
st_ansistring:
{$endif}
begin
paraloc1:=paramanager.getintparaloc(pocall_default,1);
paraloc2:=paramanager.getintparaloc(pocall_default,2);
paramanager.allocparaloc(exprasmlist,paraloc2);
cg.a_param_const(exprasmlist,OS_INT,tordconstnode(right).value,paraloc2);
href:=location.reference;
dec(href.offset,7);
paramanager.allocparaloc(exprasmlist,paraloc1);
cg.a_param_ref(exprasmlist,OS_INT,href,paraloc1);
paramanager.freeparaloc(exprasmlist,paraloc1);
paramanager.freeparaloc(exprasmlist,paraloc2);
cg.allocexplicitregisters(exprasmlist,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
cg.a_call_name(exprasmlist,'FPC_'+upper(tstringdef(left.resulttype.def).stringtypname)+'_RANGECHECK');
cg.deallocexplicitregisters(exprasmlist,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
end;
st_shortstring:
begin
{!!!!!!!!!!!!!!!!!}
end;
st_longstring:
begin
{!!!!!!!!!!!!!!!!!}
end;
end;
end;
end;
end;
inc(location.reference.offset,
mulsize*tordconstnode(right).value);
end
else
{ not nodetype=ordconstn }
begin
if (cs_regvars in aktglobalswitches) and
{ if we do range checking, we don't }
{ need that fancy code (it would be }
{ buggy) }
not(cs_check_range in aktlocalswitches) and
(left.resulttype.def.deftype=arraydef) then
begin
extraoffset:=0;
if (right.nodetype=addn) then
begin
if taddnode(right).right.nodetype=ordconstn then
begin
extraoffset:=tordconstnode(taddnode(right).right).value;
t:=taddnode(right).left;
{ First pass processed this with the assumption }
{ that there was an add node which may require an }
{ extra register. Fake it or die with IE10 (JM) }
t.registersint := taddnode(right).registersint;
taddnode(right).left:=nil;
right.free;
right:=t;
end
else if taddnode(right).left.nodetype=ordconstn then
begin
extraoffset:=tordconstnode(taddnode(right).left).value;
t:=taddnode(right).right;
t.registersint := right.registersint;
taddnode(right).right:=nil;
right.free;
right:=t;
end;
end
else if (right.nodetype=subn) then
begin
if taddnode(right).right.nodetype=ordconstn then
begin
extraoffset:=-tordconstnode(taddnode(right).right).value;
t:=taddnode(right).left;
t.registersint := right.registersint;
taddnode(right).left:=nil;
right.free;
right:=t;
end
{ You also have to negate right.right in this case! I can't add an
unaryminusn without causing a crash, so I've disabled it (JM)
else if right.left.nodetype=ordconstn then
begin
extraoffset:=right.left.value;
t:=right.right;
t^.registersint := right.registersint;
putnode(right);
putnode(right.left);
right:=t;
end;}
end;
inc(location.reference.offset,
mulsize*extraoffset);
end;
{ calculate from left to right }
if not(location.loc in [LOC_CREFERENCE,LOC_REFERENCE]) then
internalerror(200304237);
isjump:=(right.location.loc=LOC_JUMP);
if isjump then
begin
otl:=truelabel;
objectlibrary.getlabel(truelabel);
ofl:=falselabel;
objectlibrary.getlabel(falselabel);
end;
secondpass(right);
if cs_check_range in aktlocalswitches then
begin
if left.resulttype.def.deftype=arraydef then
rangecheck_array;
end;
{ if mulsize = 1, we won't have to modify the index }
location_force_reg(exprasmlist,right.location,OS_ADDR,(mulsize = 1));
if isjump then
begin
truelabel:=otl;
falselabel:=ofl;
end;
{ produce possible range check code: }
if cs_check_range in aktlocalswitches then
begin
if left.resulttype.def.deftype=arraydef then
begin
{ done defore (PM) }
end
else if (left.resulttype.def.deftype=stringdef) then
begin
case tstringdef(left.resulttype.def).string_typ of
{ it's the same for ansi- and wide strings }
st_widestring,
{$ifdef ansistring_bits}
st_ansistring16,st_ansistring32,st_ansistring64:
{$else}
st_ansistring:
{$endif}
begin
paraloc1:=paramanager.getintparaloc(pocall_default,1);
paraloc2:=paramanager.getintparaloc(pocall_default,2);
paramanager.allocparaloc(exprasmlist,paraloc2);
cg.a_param_reg(exprasmlist,OS_INT,right.location.register,paraloc2);
href:=location.reference;
dec(href.offset,7);
paramanager.allocparaloc(exprasmlist,paraloc1);
cg.a_param_ref(exprasmlist,OS_INT,href,paraloc1);
paramanager.freeparaloc(exprasmlist,paraloc1);
paramanager.freeparaloc(exprasmlist,paraloc2);
cg.allocexplicitregisters(exprasmlist,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
cg.a_call_name(exprasmlist,'FPC_'+upper(tstringdef(left.resulttype.def).stringtypname)+'_RANGECHECK');
cg.deallocexplicitregisters(exprasmlist,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
end;
st_shortstring:
begin
{!!!!!!!!!!!!!!!!!}
end;
st_longstring:
begin
{!!!!!!!!!!!!!!!!!}
end;
end;
end;
end;
{ insert the register and the multiplication factor in the
reference }
update_reference_reg_mul(right.location.register,mulsize);
end;
location.size:=newsize;
end;
begin
cloadvmtaddrnode:=tcgloadvmtaddrnode;
cloadparentfpnode:=tcgloadparentfpnode;
caddrnode:=tcgaddrnode;
cderefnode:=tcgderefnode;
csubscriptnode:=tcgsubscriptnode;
cwithnode:=tcgwithnode;
cvecnode:=tcgvecnode;
end.
{
$Log$
Revision 1.91 2004-04-29 19:56:37 daniel
* Prepare compiler infrastructure for multiple ansistring types
Revision 1.90 2004/04/21 17:39:40 jonas
- disabled with-symtable debugging code since it was broken and
at the same time confused the register allocator and therefore also
the optimizer. May be fixed in the future using dwarf support
Revision 1.89 2004/03/02 00:36:33 olle
* big transformation of Tai_[const_]Symbol.Create[data]name*
Revision 1.88 2004/02/27 10:21:05 florian
* top_symbol killed
+ refaddr to treference added
+ refsymbol to treference added
* top_local stuff moved to an extra record to save memory
+ aint introduced
* tppufile.get/putint64/aint implemented
Revision 1.87 2004/02/20 21:55:59 peter
* procvar cleanup
Revision 1.86 2004/02/03 22:32:54 peter
* renamed xNNbittype to xNNinttype
* renamed registers32 to registersint
* replace some s32bit,u32bit with torddef([su]inttype).def.typ
Revision 1.85 2004/01/31 17:45:17 peter
* Change several $ifdef i386 to x86
* Change several OS_32 to OS_INT/OS_ADDR
Revision 1.84 2004/01/12 16:38:50 peter
* don't generate IMUL reg,1
Revision 1.83 2003/12/06 01:15:22 florian
* reverted Peter's alloctemp patch; hopefully properly
Revision 1.82 2003/12/03 23:13:20 peter
* delayed paraloc allocation, a_param_*() gets extra parameter
if it needs to allocate temp or real paralocation
* optimized/simplified int-real loading
Revision 1.81 2003/11/23 17:03:35 peter
* fixed parentfp loading, it was using the offset of the current
nested proc instead of the parent
Revision 1.80 2003/11/04 15:35:13 peter
* fix for referencecounted temps
Revision 1.79 2003/10/10 17:48:13 peter
* old trgobj moved to x86/rgcpu and renamed to trgx86fpu
* tregisteralloctor renamed to trgobj
* removed rgobj from a lot of units
* moved location_* and reference_* to cgobj
* first things for mmx register allocation
Revision 1.78 2003/10/09 21:31:37 daniel
* Register allocator splitted, ans abstract now
Revision 1.77 2003/10/01 20:34:48 peter
* procinfo unit contains tprocinfo
* cginfo renamed to cgbase
* moved cgmessage to verbose
* fixed ppc and sparc compiles
Revision 1.76 2003/09/29 20:58:56 peter
* optimized releasing of registers
Revision 1.75 2003/09/28 21:45:52 peter
* fix register leak in with debug
Revision 1.74 2003/09/28 17:55:03 peter
* parent framepointer changed to hidden parameter
* tloadparentfpnode added
Revision 1.73 2003/09/23 17:56:05 peter
* locals and paras are allocated in the code generation
* tvarsym.localloc contains the location of para/local when
generating code for the current procedure
Revision 1.72 2003/09/10 08:31:47 marco
* Patch from Peter for paraloc
Revision 1.71 2003/09/07 22:09:35 peter
* preparations for different default calling conventions
* various RA fixes
Revision 1.70 2003/09/03 15:55:00 peter
* NEWRA branch merged
Revision 1.69.2.1 2003/08/29 17:28:59 peter
* next batch of updates
Revision 1.69 2003/08/10 17:25:23 peter
* fixed some reported bugs
Revision 1.68 2003/08/09 18:56:54 daniel
* cs_regalloc renamed to cs_regvars to avoid confusion with register
allocator
* Some preventive changes to i386 spillinh code
Revision 1.67 2003/07/23 11:01:14 jonas
* several rg.allocexplicitregistersint/rg.deallocexplicitregistersint
pairs round calls to helpers
Revision 1.66 2003/07/06 21:50:33 jonas
* fixed ppc compilation problems and changed VOLATILE_REGISTERS for x86
so that it doesn't include ebp and esp anymore
Revision 1.65 2003/07/06 15:31:20 daniel
* Fixed register allocator. *Lots* of fixes.
Revision 1.64 2003/06/17 19:24:08 jonas
* fixed conversion of fpc_*str_unique to compilerproc
Revision 1.63 2003/06/17 16:34:44 jonas
* lots of newra fixes (need getfuncretparaloc implementation for i386)!
* renamed all_intregisters to paramanager.get_volatile_registers_int(pocall_default) and made it
processor dependent
Revision 1.62 2003/06/13 21:19:30 peter
* current_procdef removed, use current_procinfo.procdef instead
Revision 1.61 2003/06/09 16:45:41 jonas
* fixed update_reference_reg_mul() so that it won't modify CREGISTERs
in a reference
* cache value of get_mul_size()
* if get_mul_size = 1, the index can be a CREGISTER since it won't be
modified
Revision 1.60 2003/06/07 18:57:04 jonas
+ added freeintparaloc
* ppc get/freeintparaloc now check whether the parameter regs are
properly allocated/deallocated (and get an extra list para)
* ppc a_call_* now internalerrors if pi_do_call is not yet set
* fixed lot of missing pi_do_call's
Revision 1.59 2003/06/03 21:11:09 peter
* cg.a_load_* get a from and to size specifier
* makeregsize only accepts newregister
* i386 uses generic tcgnotnode,tcgunaryminus
Revision 1.58 2003/06/03 13:01:59 daniel
* Register allocator finished
Revision 1.57 2003/06/02 22:35:45 florian
* better handling of CREGISTER in subscript nodes
Revision 1.56 2003/06/01 21:38:06 peter
* getregisterfpu size parameter added
* op_const_reg size parameter added
* sparc updates
Revision 1.55 2003/05/30 23:49:18 jonas
* a_load_loc_reg now has an extra size parameter for the destination
register (properly fixes what I worked around in revision 1.106 of
ncgutil.pas)
Revision 1.54 2003/05/15 16:10:37 florian
* fixed getintparaloc call for ansi- and widestring range checking
Revision 1.53 2003/05/11 21:37:03 peter
* moved implicit exception frame from ncgutil to psub
* constructor/destructor helpers moved from cobj/ncgutil to psub
Revision 1.52 2003/05/11 14:45:12 peter
* tloadnode does not support objectsymtable,withsymtable anymore
* withnode cleanup
* direct with rewritten to use temprefnode
Revision 1.51 2003/05/09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.50 2003/05/07 09:16:23 mazen
- non used units removed from uses clause
Revision 1.49 2003/04/27 11:21:33 peter
* aktprocdef renamed to current_procinfo.procdef
* procinfo renamed to current_procinfo
* procinfo will now be stored in current_module so it can be
cleaned up properly
* gen_main_procsym changed to create_main_proc and release_main_proc
to also generate a tprocinfo structure
* fixed unit implicit initfinal
Revision 1.48 2003/04/22 23:50:22 peter
* firstpass uses expectloc
* checks if there are differences between the expectloc and
location.loc from secondpass in EXTDEBUG
Revision 1.47 2003/04/22 13:47:08 peter
* fixed C style array of const
* fixed C array passing
* fixed left to right with high parameters
Revision 1.46 2003/04/22 10:09:35 daniel
+ Implemented the actual register allocator
+ Scratch registers unavailable when new register allocator used
+ maybe_save/maybe_restore unavailable when new register allocator used
Revision 1.45 2003/04/06 21:11:23 olle
* changed newasmsymbol to newasmsymboldata for data symbols
Revision 1.44 2003/03/28 19:16:56 peter
* generic constructor working for i386
* remove fixed self register
* esi added as address register for i386
Revision 1.43 2003/03/12 22:43:38 jonas
* more powerpc and generic fixes related to the new register allocator
Revision 1.42 2003/02/19 22:00:14 daniel
* Code generator converted to new register notation
- Horribily outdated todo.txt removed
Revision 1.41 2003/01/30 21:46:57 peter
* self fixes for static methods (merged)
Revision 1.40 2003/01/08 18:43:56 daniel
* Tregister changed into a record
Revision 1.39 2002/12/20 18:13:19 peter
* no rangecheck for openarrays with cdecl
Revision 1.38 2002/12/17 22:19:33 peter
* fixed pushing of records>8 bytes with stdcall
* simplified hightree loading
Revision 1.37 2002/12/08 13:39:03 carl
+ some documentation added
Revision 1.36 2002/12/07 14:14:19 carl
* bugfix on invalid typecast
Revision 1.35 2002/11/25 17:43:18 peter
* splitted defbase in defutil,symutil,defcmp
* merged isconvertable and is_equal into compare_defs(_ext)
* made operator search faster by walking the list only once
Revision 1.34 2002/11/24 18:19:20 carl
+ checkpointer for interfaces also
Revision 1.33 2002/11/23 22:50:06 carl
* some small speed optimizations
+ added several new warnings/hints
Revision 1.32 2002/11/15 01:58:51 peter
* merged changes from 1.0.7 up to 04-11
- -V option for generating bug report tracing
- more tracing for option parsing
- errors for cdecl and high()
- win32 import stabs
- win32 records<=8 are returned in eax:edx (turned off by default)
- heaptrc update
- more info for temp management in .s file with EXTDEBUG
Revision 1.31 2002/10/09 20:24:47 florian
+ range checking for dyn. arrays
Revision 1.30 2002/10/07 21:30:45 peter
* rangecheck for open arrays added
Revision 1.29 2002/10/05 12:43:25 carl
* fixes for Delphi 6 compilation
(warning : Some features do not work under Delphi)
Revision 1.28 2002/09/17 18:54:02 jonas
* a_load_reg_reg() now has two size parameters: source and dest. This
allows some optimizations on architectures that don't encode the
register size in the register name.
Revision 1.27 2002/09/07 15:25:03 peter
* old logs removed and tabs fixed
Revision 1.26 2002/09/01 18:46:01 peter
* fixed generic tcgvecnode
* move code that updates a reference with index register and multiplier
to separate method so it can be overriden for scaled indexing
* i386 uses generic tcgvecnode
Revision 1.25 2002/08/23 16:14:48 peter
* tempgen cleanup
* tt_noreuse temp type added that will be used in genentrycode
Revision 1.24 2002/08/15 08:13:54 carl
- a_load_sym_ofs_reg removed
* loadvmt now calls loadaddr_ref_reg instead
Revision 1.23 2002/08/11 14:32:26 peter
* renamed current_library to objectlibrary
Revision 1.22 2002/08/11 13:24:12 peter
* saving of asmsymbols in ppu supported
* asmsymbollist global is removed and moved into a new class
tasmlibrarydata that will hold the info of a .a file which
corresponds with a single module. Added librarydata to tmodule
to keep the library info stored for the module. In the future the
objectfiles will also be stored to the tasmlibrarydata class
* all getlabel/newasmsymbol and friends are moved to the new class
Revision 1.21 2002/08/11 11:36:57 jonas
* always first try to use base and only then index
Revision 1.20 2002/08/11 06:14:40 florian
* fixed powerpc compilation problems
Revision 1.19 2002/08/10 14:46:29 carl
+ moved target_cpu_string to cpuinfo
* renamed asmmode enum.
* assembler reader has now less ifdef's
* move from nppcmem.pas -> ncgmem.pas vec. node.
Revision 1.18 2002/07/28 21:34:31 florian
* more powerpc fixes
+ dummy tcgvecnode
Revision 1.17 2002/07/11 14:41:28 florian
* start of the new generic parameter handling
Revision 1.16 2002/07/07 09:52:32 florian
* powerpc target fixed, very simple units can be compiled
* some basic stuff for better callparanode handling, far from being finished
Revision 1.15 2002/07/01 18:46:23 peter
* internal linker
* reorganized aasm layer
Revision 1.14 2002/07/01 16:23:53 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.13 2002/05/20 13:30:40 carl
* bugfix of hdisponen (base must be set, not index)
* more portability fixes
Revision 1.12 2002/05/18 13:34:09 peter
* readded missing revisions
Revision 1.11 2002/05/16 19:46:37 carl
+ defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
+ try to fix temp allocation (still in ifdef)
+ generic constructor calls
+ start of tassembler / tmodulebase class cleanup
Revision 1.9 2002/05/12 16:53:07 peter
* moved entry and exitcode to ncgutil and cgobj
* foreach gets extra argument for passing local data to the
iterator function
* -CR checks also class typecasts at runtime by changing them
into as
* fixed compiler to cycle with the -CR option
* fixed stabs with elf writer, finally the global variables can
be watched
* removed a lot of routines from cga unit and replaced them by
calls to cgobj
* u32bit-s32bit updates for and,or,xor nodes. When one element is
u32bit then the other is typecasted also to u32bit without giving
a rangecheck warning/error.
* fixed pascal calling method with reversing also the high tree in
the parast, detected by tcalcst3 test
Revision 1.8 2002/04/20 21:32:23 carl
+ generic FPC_CHECKPOINTER
+ first parameter offset in stack now portable
* rename some constants
+ move some cpu stuff to other units
- remove unused constents
* fix stacksize for some targets
* fix generic size problems which depend now on EXTEND_SIZE constant
Revision 1.7 2002/04/15 18:58:47 carl
+ target_info.size_of_pointer -> pointer_Size
Revision 1.6 2002/04/04 19:05:57 peter
* removed unused units
* use tlocation.size in cg.a_*loc*() routines
}
Reference in New Issue View Git Blame Copy Permalink