{
$Id: nld.pas,v 1.119 2003/12/01 18:44:15 peter Exp $
Copyright (c) 2000-2002 by Florian Klaempfl
Type checking and register allocation for load/assignment nodes
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 nld;
{$i fpcdefs.inc}
interface
uses
node,
{$ifdef state_tracking}
nstate,
{$endif}
symconst,symppu,symbase,symtype,symsym,symdef;
type
tloadnode = class(tunarynode)
symtableentry : tsym;
symtableentryderef : tderef;
symtable : tsymtable;
procdef : tprocdef;
procdefderef : tderef;
constructor create(v : tsym;st : tsymtable);virtual;
constructor create_procvar(v : tsym;d:tprocdef;st : tsymtable);virtual;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure buildderefimpl;override;
procedure derefimpl;override;
procedure set_mp(p:tnode);
function getcopy : tnode;override;
function pass_1 : tnode;override;
function det_resulttype:tnode;override;
procedure mark_write;override;
function docompare(p: tnode): boolean; override;
procedure printnodedata(var t:text);override;
end;
tloadnodeclass = class of tloadnode;
{ different assignment types }
tassigntype = (at_normal,at_plus,at_minus,at_star,at_slash);
tassignmentnode = class(tbinarynode)
assigntype : tassigntype;
constructor create(l,r : tnode);virtual;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
function getcopy : tnode;override;
function pass_1 : tnode;override;
function det_resulttype:tnode;override;
{$ifdef state_tracking}
function track_state_pass(exec_known:boolean):boolean;override;
{$endif state_tracking}
function docompare(p: tnode): boolean; override;
end;
tassignmentnodeclass = class of tassignmentnode;
tarrayconstructorrangenode = class(tbinarynode)
constructor create(l,r : tnode);virtual;
function pass_1 : tnode;override;
function det_resulttype:tnode;override;
end;
tarrayconstructorrangenodeclass = class of tarrayconstructorrangenode;
tarrayconstructornode = class(tbinarynode)
constructor create(l,r : tnode);virtual;
function getcopy : tnode;override;
function pass_1 : tnode;override;
function det_resulttype:tnode;override;
function docompare(p: tnode): boolean; override;
procedure force_type(tt:ttype);
procedure insert_typeconvs;
end;
tarrayconstructornodeclass = class of tarrayconstructornode;
ttypenode = class(tnode)
allowed : boolean;
restype : ttype;
constructor create(t : ttype);virtual;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure buildderefimpl;override;
procedure derefimpl;override;
function pass_1 : tnode;override;
function det_resulttype:tnode;override;
function docompare(p: tnode): boolean; override;
end;
ttypenodeclass = class of ttypenode;
trttinode = class(tnode)
l1,l2 : longint;
rttitype : trttitype;
rttidef : tstoreddef;
rttidefderef : tderef;
constructor create(def:tstoreddef;rt:trttitype);virtual;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure buildderefimpl;override;
procedure derefimpl;override;
function getcopy : tnode;override;
function pass_1 : tnode;override;
procedure pass_2;override;
function det_resulttype:tnode;override;
function docompare(p: tnode): boolean; override;
end;
trttinodeclass = class of trttinode;
var
cloadnode : tloadnodeclass;
cassignmentnode : tassignmentnodeclass;
carrayconstructorrangenode : tarrayconstructorrangenodeclass;
carrayconstructornode : tarrayconstructornodeclass;
ctypenode : ttypenodeclass;
crttinode : trttinodeclass;
procedure load_procvar_from_calln(var p1:tnode);
function load_high_value_node(vs:tvarsym):tnode;
function load_self_node:tnode;
function load_result_node:tnode;
function load_self_pointer_node:tnode;
function load_vmt_pointer_node:tnode;
function is_self_node(p:tnode):boolean;
implementation
uses
cutils,verbose,globtype,globals,systems,
symtable,symnot,
defutil,defcmp,
htypechk,pass_1,procinfo,paramgr,
ncon,ninl,ncnv,nmem,ncal,cpubase,cgobj,cgbase
;
{*****************************************************************************
Helpers
*****************************************************************************}
procedure load_procvar_from_calln(var p1:tnode);
var
p2 : tnode;
begin
if p1.nodetype<>calln then
internalerror(200212251);
{ was it a procvar, then we simply remove the calln and
reuse the right }
if assigned(tcallnode(p1).right) then
begin
p2:=tcallnode(p1).right;
tcallnode(p1).right:=nil;
end
else
begin
p2:=cloadnode.create_procvar(tcallnode(p1).symtableprocentry,
tprocdef(tcallnode(p1).procdefinition),tcallnode(p1).symtableproc);
{ when the methodpointer is typen we've something like:
tobject.create. Then only the address is needed of the
method without a self pointer }
if assigned(tcallnode(p1).methodpointer) and
(tcallnode(p1).methodpointer.nodetype<>typen) then
begin
tloadnode(p2).set_mp(tcallnode(p1).methodpointer);
tcallnode(p1).methodpointer:=nil;
end;
end;
resulttypepass(p2);
p1.free;
p1:=p2;
end;
function load_high_value_node(vs:tvarsym):tnode;
var
srsym : tsym;
srsymtable : tsymtable;
begin
result:=nil;
srsymtable:=vs.owner;
srsym:=searchsymonlyin(srsymtable,'high'+vs.name);
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,srsymtable);
resulttypepass(result);
end
else
CGMessage(cg_e_illegal_expression);
end;
function load_self_node:tnode;
var
srsym : tsym;
srsymtable : tsymtable;
begin
result:=nil;
searchsym('self',srsym,srsymtable);
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,srsymtable);
resulttypepass(result);
end
else
CGMessage(cg_e_illegal_expression);
end;
function load_result_node:tnode;
var
srsym : tsym;
srsymtable : tsymtable;
begin
result:=nil;
searchsym('result',srsym,srsymtable);
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,srsymtable);
resulttypepass(result);
end
else
CGMessage(cg_e_illegal_expression);
end;
function load_self_pointer_node:tnode;
var
srsym : tsym;
srsymtable : tsymtable;
begin
result:=nil;
searchsym('self',srsym,srsymtable);
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,srsymtable);
include(result.flags,nf_load_self_pointer);
resulttypepass(result);
end
else
CGMessage(cg_e_illegal_expression);
end;
function load_vmt_pointer_node:tnode;
var
srsym : tsym;
srsymtable : tsymtable;
begin
result:=nil;
searchsym('vmt',srsym,srsymtable);
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,srsymtable);
resulttypepass(result);
end
else
CGMessage(cg_e_illegal_expression);
end;
function is_self_node(p:tnode):boolean;
begin
is_self_node:=(p.nodetype=loadn) and
(tloadnode(p).symtableentry.typ=varsym) and
(vo_is_self in tvarsym(tloadnode(p).symtableentry).varoptions);
end;
{*****************************************************************************
TLOADNODE
*****************************************************************************}
constructor tloadnode.create(v : tsym;st : tsymtable);
begin
inherited create(loadn,nil);
if not assigned(v) then
internalerror(200108121);
symtableentry:=v;
symtable:=st;
procdef:=nil;
end;
constructor tloadnode.create_procvar(v : tsym;d:tprocdef;st : tsymtable);
begin
inherited create(loadn,nil);
if not assigned(v) then
internalerror(200108121);
symtableentry:=v;
symtable:=st;
procdef:=d;
end;
constructor tloadnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
ppufile.getderef(symtableentryderef);
symtable:=nil;
ppufile.getderef(procdefderef);
end;
procedure tloadnode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.putderef(symtableentryderef);
ppufile.putderef(procdefderef);
end;
procedure tloadnode.buildderefimpl;
begin
inherited buildderefimpl;
symtableentryderef.build(symtableentry);
procdefderef.build(procdef);
end;
procedure tloadnode.derefimpl;
begin
inherited derefimpl;
symtableentry:=tsym(symtableentryderef.resolve);
symtable:=symtableentry.owner;
procdef:=tprocdef(procdefderef.resolve);
end;
procedure tloadnode.set_mp(p:tnode);
begin
{ typen nodes should not be set }
if p.nodetype=typen then
internalerror(200301042);
left:=p;
end;
function tloadnode.getcopy : tnode;
var
n : tloadnode;
begin
n:=tloadnode(inherited getcopy);
n.symtable:=symtable;
n.symtableentry:=symtableentry;
n.procdef:=procdef;
result:=n;
end;
function tloadnode.det_resulttype:tnode;
begin
result:=nil;
case symtableentry.typ of
absolutesym :
resulttype:=tabsolutesym(symtableentry).vartype;
constsym:
begin
if tconstsym(symtableentry).consttyp=constresourcestring then
resulttype:=cansistringtype
else
internalerror(22799);
end;
varsym :
begin
inc(tvarsym(symtableentry).refs);
{ Nested variable? The we need to load the framepointer of
the parent procedure }
if (symtable.symtabletype in [localsymtable,parasymtable]) and
(symtable.symtablelevel<>current_procinfo.procdef.parast.symtablelevel) then
begin
if assigned(left) then
internalerror(200309289);
left:=cloadparentfpnode.create(tprocdef(symtable.defowner));
end;
{ fix self type which is declared as voidpointer in the
definition }
if vo_is_self in tvarsym(symtableentry).varoptions then
begin
resulttype.setdef(tprocdef(symtableentry.owner.defowner)._class);
if (po_classmethod in tprocdef(symtableentry.owner.defowner).procoptions) or
(po_staticmethod in tprocdef(symtableentry.owner.defowner).procoptions) then
resulttype.setdef(tclassrefdef.create(resulttype))
else if is_object(resulttype.def) and
(nf_load_self_pointer in flags) then
resulttype.setdef(tpointerdef.create(resulttype));
end
else if vo_is_vmt in tvarsym(symtableentry).varoptions then
begin
resulttype.setdef(tprocdef(symtableentry.owner.defowner)._class);
resulttype.setdef(tclassrefdef.create(resulttype));
end
else
resulttype:=tvarsym(symtableentry).vartype;
end;
typedconstsym :
resulttype:=ttypedconstsym(symtableentry).typedconsttype;
procsym :
begin
if not assigned(procdef) then
begin
if Tprocsym(symtableentry).procdef_count>1 then
CGMessage(parser_e_no_overloaded_procvars);
procdef:=tprocsym(symtableentry).first_procdef;
end;
{ the result is a procdef, addrn and proc_to_procvar
typeconvn need this as resulttype so they know
that the address needs to be returned }
resulttype.setdef(procdef);
{ process methodpointer }
if assigned(left) then
resulttypepass(left);
end;
else
internalerror(200104141);
end;
end;
procedure Tloadnode.mark_write;
begin
include(flags,nf_write);
end;
function tloadnode.pass_1 : tnode;
begin
result:=nil;
expectloc:=LOC_REFERENCE;
registers32:=0;
registersfpu:=0;
{$ifdef SUPPORT_MMX}
registersmmx:=0;
{$endif SUPPORT_MMX}
case symtableentry.typ of
absolutesym :
;
constsym:
begin
if tconstsym(symtableentry).consttyp=constresourcestring then
begin
include(current_procinfo.flags,pi_needs_implicit_finally);
expectloc:=LOC_CREFERENCE;
end;
end;
varsym :
begin
if assigned(left) then
firstpass(left);
if (tvarsym(symtableentry).varspez=vs_const) then
expectloc:=LOC_CREFERENCE;
{ we need a register for call by reference parameters }
if paramanager.push_addr_param(tvarsym(symtableentry).varspez,tvarsym(symtableentry).vartype.def,pocall_default) then
registers32:=1;
if ([vo_is_thread_var,vo_is_dll_var]*tvarsym(symtableentry).varoptions)<>[] then
registers32:=1;
{ call to get address of threadvar }
if (vo_is_thread_var in tvarsym(symtableentry).varoptions) then
include(current_procinfo.flags,pi_do_call);
if nf_write in flags then
Tvarsym(symtableentry).trigger_notifications(vn_onwrite)
else
Tvarsym(symtableentry).trigger_notifications(vn_onread);
{ count variable references }
if cg.t_times>1 then
inc(tvarsym(symtableentry).refs,cg.t_times-1);
end;
typedconstsym :
;
procsym :
begin
{ method pointer ? }
if assigned(left) then
begin
expectloc:=LOC_CREFERENCE;
firstpass(left);
registers32:=max(registers32,left.registers32);
registersfpu:=max(registersfpu,left.registersfpu);
{$ifdef SUPPORT_MMX}
registersmmx:=max(registersmmx,left.registersmmx);
{$endif SUPPORT_MMX}
end;
end;
else
internalerror(200104143);
end;
end;
function tloadnode.docompare(p: tnode): boolean;
begin
docompare :=
inherited docompare(p) and
(symtableentry = tloadnode(p).symtableentry) and
(procdef = tloadnode(p).procdef) and
(symtable = tloadnode(p).symtable);
end;
procedure Tloadnode.printnodedata(var t:text);
begin
inherited printnodedata(t);
write(t,printnodeindention,'symbol = ',symtableentry.name);
if symtableentry.typ=procsym then
write(t,printnodeindention,'procdef = ',procdef.mangledname);
writeln(t,'');
end;
{*****************************************************************************
TASSIGNMENTNODE
*****************************************************************************}
constructor tassignmentnode.create(l,r : tnode);
begin
inherited create(assignn,l,r);
l.mark_write;
assigntype:=at_normal;
end;
constructor tassignmentnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
assigntype:=tassigntype(ppufile.getbyte);
end;
procedure tassignmentnode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.putbyte(byte(assigntype));
end;
function tassignmentnode.getcopy : tnode;
var
n : tassignmentnode;
begin
n:=tassignmentnode(inherited getcopy);
n.assigntype:=assigntype;
getcopy:=n;
end;
function tassignmentnode.det_resulttype:tnode;
var
hp : tnode;
useshelper : boolean;
original_size : longint;
begin
result:=nil;
resulttype:=voidtype;
original_size := 0;
{ must be made unique }
set_unique(left);
resulttypepass(left);
if is_ansistring(left.resulttype.def) then
begin
{ fold <ansistring>:=<ansistring>+<char|shortstring|ansistring> }
if (right.nodetype=addn) and
left.isequal(tbinarynode(right).left) and
{ don't fold multiple concatenations else we could get trouble
with multiple uses of s
}
(tbinarynode(right).left.nodetype<>addn) and
(tbinarynode(right).right.nodetype<>addn) then
begin
{ don't do a resulttypepass(right), since then the addnode }
{ may insert typeconversions that make this optimization }
{ opportunity quite difficult to detect (JM) }
resulttypepass(tbinarynode(right).left);
resulttypepass(tbinarynode(right).right);
if (is_char(tbinarynode(right).right.resulttype.def) or
is_shortstring(tbinarynode(right).right.resulttype.def) or
is_ansistring(tbinarynode(right).right.resulttype.def)) then
begin
{ remove property flag so it'll not trigger an error }
exclude(left.flags,nf_isproperty);
{ generate call to helper }
hp:=ccallparanode.create(tbinarynode(right).right,
ccallparanode.create(left,nil));
if is_char(tbinarynode(right).right.resulttype.def) then
result:=ccallnode.createintern('fpc_ansistr_append_char',hp)
else if is_shortstring(tbinarynode(right).right.resulttype.def) then
result:=ccallnode.createintern('fpc_ansistr_append_shortstring',hp)
else
result:=ccallnode.createintern('fpc_ansistr_append_ansistring',hp);
tbinarynode(right).right:=nil;
left:=nil;
exit;
end;
end;
end
else
if is_shortstring(left.resulttype.def) then
begin
{ fold <shortstring>:=<shortstring>+<shortstring>,
<shortstring>+<char> is handled by an optimized node }
if (right.nodetype=addn) and
left.isequal(tbinarynode(right).left) and
{ don't fold multiple concatenations else we could get trouble
with multiple uses of s }
(tbinarynode(right).left.nodetype<>addn) and
(tbinarynode(right).right.nodetype<>addn) then
begin
{ don't do a resulttypepass(right), since then the addnode }
{ may insert typeconversions that make this optimization }
{ opportunity quite difficult to detect (JM) }
resulttypepass(tbinarynode(right).left);
resulttypepass(tbinarynode(right).right);
if is_shortstring(tbinarynode(right).right.resulttype.def) then
begin
{ remove property flag so it'll not trigger an error }
exclude(left.flags,nf_isproperty);
{ generate call to helper }
hp:=ccallparanode.create(tbinarynode(right).right,
ccallparanode.create(left,nil));
if is_shortstring(tbinarynode(right).right.resulttype.def) then
result:=ccallnode.createintern('fpc_shortstr_append_shortstr',hp);
tbinarynode(right).right:=nil;
left:=nil;
exit;
end;
end;
end;
resulttypepass(right);
set_varstate(left,vs_assigned,false);
set_varstate(right,vs_used,true);
if codegenerror then
exit;
{ assignments to formaldefs and open arrays aren't allowed }
if (left.resulttype.def.deftype=formaldef) or
is_open_array(left.resulttype.def) then
CGMessage(type_e_operator_not_allowed);
{ test if node can be assigned, properties are allowed }
valid_for_assignment(left);
{ assigning nil to a dynamic array clears the array }
if is_dynamic_array(left.resulttype.def) and
(right.nodetype=niln) then
begin
hp:=ccallparanode.create(caddrnode.create
(crttinode.create(tstoreddef(left.resulttype.def),initrtti)),
ccallparanode.create(ctypeconvnode.create_explicit(left,voidpointertype),nil));
result := ccallnode.createintern('fpc_dynarray_clear',hp);
left:=nil;
exit;
end;
{ shortstring helpers can do the conversion directly,
so treat them separatly }
if (is_shortstring(left.resulttype.def)) then
begin
{ insert typeconv, except for chars that are handled in
secondpass and except for ansi/wide string that can
be converted immediatly }
if not(is_char(right.resulttype.def) or
(right.resulttype.def.deftype=stringdef)) then
inserttypeconv(right,left.resulttype);
if right.resulttype.def.deftype=stringdef then
begin
useshelper:=true;
{ convert constant strings to shortstrings. But
skip empty constant strings, that will be handled
in secondpass }
if (right.nodetype=stringconstn) then
begin
{ verify if range fits within shortstring }
{ just emit a warning, delphi gives an }
{ error, only if the type definition of }
{ of the string is less < 255 characters }
if not is_open_string(left.resulttype.def) and
(tstringconstnode(right).len > tstringdef(left.resulttype.def).len) then
cgmessage(type_w_string_too_long);
inserttypeconv(right,left.resulttype);
if (tstringconstnode(right).len=0) then
useshelper:=false;
end;
{ rest is done in pass 1 (JM) }
if useshelper then
exit;
end
end
else
begin
{ get the size before the type conversion - check for all nodes }
if assigned(right.resulttype.def) and
(right.resulttype.def.deftype in [enumdef,orddef,floatdef]) and
(right.nodetype in [loadn,vecn,calln]) then
original_size := right.resulttype.def.size;
inserttypeconv(right,left.resulttype);
end;
{ check if the assignment may cause a range check error }
{ if its not explicit, and only if the values are }
{ ordinals, enumdef and floatdef }
if (right.nodetype = typeconvn) and
not (nf_explicit in ttypeconvnode(right).flags) then
begin
if assigned(left.resulttype.def) and
(left.resulttype.def.deftype in [enumdef,orddef,floatdef]) then
begin
if (original_size <> 0) and (left.resulttype.def.size < original_size) then
begin
if (cs_check_range in aktlocalswitches) then
Message(type_w_smaller_possible_range_check)
else
Message(type_h_smaller_possible_range_check);
end;
end;
end;
{ call helpers for interface }
if is_interfacecom(left.resulttype.def) then
begin
hp:=ccallparanode.create(ctypeconvnode.create_explicit
(right,voidpointertype),
ccallparanode.create(ctypeconvnode.create_explicit
(left,voidpointertype),nil));
result:=ccallnode.createintern('fpc_intf_assign',hp);
left:=nil;
right:=nil;
exit;
end;
{ check if local proc/func is assigned to procvar }
if right.resulttype.def.deftype=procvardef then
test_local_to_procvar(tprocvardef(right.resulttype.def),left.resulttype.def);
end;
function tassignmentnode.pass_1 : tnode;
var
hp: tnode;
begin
result:=nil;
expectloc:=LOC_VOID;
firstpass(left);
firstpass(right);
{ assignment to refcounted variable -> inc/decref }
if (not is_class(left.resulttype.def) and
left.resulttype.def.needs_inittable) then
include(current_procinfo.flags,pi_do_call);
if codegenerror then
exit;
if (is_shortstring(left.resulttype.def)) then
begin
if right.resulttype.def.deftype=stringdef then
begin
if (right.nodetype<>stringconstn) or
(tstringconstnode(right).len<>0) then
begin
if (cs_optimize in aktglobalswitches) and
(right.nodetype in [calln,blockn]) and
(left.nodetype = temprefn) and
is_shortstring(right.resulttype.def) and
not is_open_string(left.resulttype.def) and
(tstringdef(left.resulttype.def).len = 255) then
begin
{ the blocknode case is handled in pass_2 at the temp }
{ reference level (mainly for callparatemp) (JM) }
if (right.nodetype = calln) then
begin
tcallnode(right).funcretnode := left;
result := right;
end
else
exit;
end
else
begin
hp:=ccallparanode.create
(right,
ccallparanode.create(cinlinenode.create
(in_high_x,false,left.getcopy),nil));
result:=ccallnode.createinternreturn('fpc_'+tstringdef(right.resulttype.def).stringtypname+'_to_shortstr',hp,left);
firstpass(result);
end;
left:=nil;
right:=nil;
exit;
end;
end;
end;
if (cs_optimize in aktglobalswitches) and
(right.nodetype = calln) and
{ left must be a temp, since otherwise as soon as you modify the }
{ result, the current left node is modified and that one may }
{ still be an argument to the function or even accessed in the }
{ function }
(((left.nodetype = temprefn) and
paramanager.ret_in_param(right.resulttype.def,
tcallnode(right).procdefinition.proccalloption)) or
{ there's special support for ansi/widestrings in the callnode }
is_ansistring(right.resulttype.def) or
is_widestring(right.resulttype.def)) then
begin
tcallnode(right).funcretnode := left;
result := right;
left := nil;
right := nil;
exit;
end;
registers32:=left.registers32+right.registers32;
registersfpu:=max(left.registersfpu,right.registersfpu);
{$ifdef SUPPORT_MMX}
registersmmx:=max(left.registersmmx,right.registersmmx);
{$endif SUPPORT_MMX}
end;
function tassignmentnode.docompare(p: tnode): boolean;
begin
docompare :=
inherited docompare(p) and
(assigntype = tassignmentnode(p).assigntype);
end;
{$ifdef state_tracking}
function Tassignmentnode.track_state_pass(exec_known:boolean):boolean;
var se:Tstate_entry;
begin
track_state_pass:=false;
if exec_known then
begin
track_state_pass:=right.track_state_pass(exec_known);
{Force a new resulttype pass.}
right.resulttype.def:=nil;
do_resulttypepass(right);
resulttypepass(right);
aktstate.store_fact(left.getcopy,right.getcopy);
end
else
aktstate.delete_fact(left);
end;
{$endif}
{*****************************************************************************
TARRAYCONSTRUCTORRANGENODE
*****************************************************************************}
constructor tarrayconstructorrangenode.create(l,r : tnode);
begin
inherited create(arrayconstructorrangen,l,r);
end;
function tarrayconstructorrangenode.det_resulttype:tnode;
begin
result:=nil;
resulttypepass(left);
resulttypepass(right);
set_varstate(left,vs_used,true);
set_varstate(right,vs_used,true);
if codegenerror then
exit;
resulttype:=left.resulttype;
end;
function tarrayconstructorrangenode.pass_1 : tnode;
begin
firstpass(left);
firstpass(right);
expectloc:=LOC_CREFERENCE;
calcregisters(self,0,0,0);
result:=nil;
end;
{****************************************************************************
TARRAYCONSTRUCTORNODE
*****************************************************************************}
constructor tarrayconstructornode.create(l,r : tnode);
begin
inherited create(arrayconstructorn,l,r);
end;
function tarrayconstructornode.getcopy : tnode;
var
n : tarrayconstructornode;
begin
n:=tarrayconstructornode(inherited getcopy);
result:=n;
end;
function tarrayconstructornode.det_resulttype:tnode;
var
htype : ttype;
hp : tarrayconstructornode;
len : longint;
varia : boolean;
begin
result:=nil;
{ are we allowing array constructor? Then convert it to a set }
if not allow_array_constructor then
begin
hp:=tarrayconstructornode(getcopy);
arrayconstructor_to_set(tnode(hp));
result:=hp;
exit;
end;
{ only pass left tree, right tree contains next construct if any }
htype.reset;
len:=0;
varia:=false;
if assigned(left) then
begin
hp:=self;
while assigned(hp) do
begin
resulttypepass(hp.left);
set_varstate(hp.left,vs_used,true);
if (htype.def=nil) then
htype:=hp.left.resulttype
else
begin
if ((nf_novariaallowed in flags) or (not varia)) and
(not equal_defs(htype.def,hp.left.resulttype.def)) then
begin
varia:=true;
end;
end;
inc(len);
hp:=tarrayconstructornode(hp.right);
end;
end;
if not assigned(htype.def) then
htype:=voidtype;
resulttype.setdef(tarraydef.create(0,len-1,s32bittype));
tarraydef(resulttype.def).setelementtype(htype);
tarraydef(resulttype.def).IsConstructor:=true;
tarraydef(resulttype.def).IsVariant:=varia;
end;
procedure tarrayconstructornode.force_type(tt:ttype);
var
hp : tarrayconstructornode;
begin
tarraydef(resulttype.def).setelementtype(tt);
tarraydef(resulttype.def).IsConstructor:=true;
tarraydef(resulttype.def).IsVariant:=false;
if assigned(left) then
begin
hp:=self;
while assigned(hp) do
begin
inserttypeconv(hp.left,tt);
hp:=tarrayconstructornode(hp.right);
end;
end;
end;
procedure tarrayconstructornode.insert_typeconvs;
var
thp,
chp,
hp : tarrayconstructornode;
dovariant : boolean;
htype : ttype;
orgflags : tnodeflags;
begin
dovariant:=(nf_forcevaria in flags) or tarraydef(resulttype.def).isvariant;
{ only pass left tree, right tree contains next construct if any }
if assigned(left) then
begin
hp:=self;
while assigned(hp) do
begin
resulttypepass(hp.left);
{ Insert typeconvs for array of const }
if dovariant then
begin
case hp.left.resulttype.def.deftype of
enumdef :
hp.left:=ctypeconvnode.create_explicit(hp.left,s32bittype);
arraydef :
hp.left:=ctypeconvnode.create(hp.left,charpointertype);
orddef :
begin
if is_integer(hp.left.resulttype.def) and
not(is_64bitint(hp.left.resulttype.def)) then
hp.left:=ctypeconvnode.create(hp.left,s32bittype);
end;
floatdef :
hp.left:=ctypeconvnode.create(hp.left,pbestrealtype^);
procvardef :
hp.left:=ctypeconvnode.create(hp.left,voidpointertype);
stringdef,
variantdef,
pointerdef,
classrefdef,
objectdef : ;
else
CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype.def.typename);
end;
end;
resulttypepass(hp.left);
hp:=tarrayconstructornode(hp.right);
end;
end;
end;
function tarrayconstructornode.pass_1 : tnode;
var
hp : tarrayconstructornode;
begin
result:=nil;
{ Insert required type convs, this must be
done in pass 1, because the call must be
resulttypepassed already }
if assigned(left) then
begin
insert_typeconvs;
{ call firstpass for all nodes }
hp:=self;
while assigned(hp) do
begin
firstpass(hp.left);
hp:=tarrayconstructornode(hp.right);
end;
end;
expectloc:=LOC_CREFERENCE;
calcregisters(self,0,0,0);
end;
function tarrayconstructornode.docompare(p: tnode): boolean;
begin
docompare :=
inherited docompare(p);
end;
{*****************************************************************************
TTYPENODE
*****************************************************************************}
constructor ttypenode.create(t : ttype);
begin
inherited create(typen);
restype:=t;
allowed:=false;
end;
constructor ttypenode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
ppufile.gettype(restype);
allowed:=boolean(ppufile.getbyte);
end;
procedure ttypenode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.puttype(restype);
ppufile.putbyte(byte(allowed));
end;
procedure ttypenode.buildderefimpl;
begin
inherited buildderefimpl;
restype.buildderef;
end;
procedure ttypenode.derefimpl;
begin
inherited derefimpl;
restype.resolve;
end;
function ttypenode.det_resulttype:tnode;
begin
result:=nil;
resulttype:=restype;
{ check if it's valid }
if restype.def.deftype = errordef then
CGMessage(cg_e_illegal_expression);
end;
function ttypenode.pass_1 : tnode;
begin
result:=nil;
expectloc:=LOC_VOID;
{ a typenode can't generate code, so we give here
an error. Else it'll be an abstract error in pass_2.
Only when the allowed flag is set we don't generate
an error }
if not allowed then
Message(parser_e_no_type_not_allowed_here);
end;
function ttypenode.docompare(p: tnode): boolean;
begin
docompare :=
inherited docompare(p);
end;
{*****************************************************************************
TRTTINODE
*****************************************************************************}
constructor trttinode.create(def:tstoreddef;rt:trttitype);
begin
inherited create(rttin);
rttidef:=def;
rttitype:=rt;
end;
constructor trttinode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
ppufile.getderef(rttidefderef);
rttitype:=trttitype(ppufile.getbyte);
end;
procedure trttinode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.putderef(rttidefderef);
ppufile.putbyte(byte(rttitype));
end;
procedure trttinode.buildderefimpl;
begin
inherited buildderefimpl;
rttidefderef.build(rttidef);
end;
procedure trttinode.derefimpl;
begin
inherited derefimpl;
rttidef:=tstoreddef(rttidefderef.resolve);
end;
function trttinode.getcopy : tnode;
var
n : trttinode;
begin
n:=trttinode(inherited getcopy);
n.rttidef:=rttidef;
n.rttitype:=rttitype;
result:=n;
end;
function trttinode.det_resulttype:tnode;
begin
{ rtti information will be returned as a void pointer }
result:=nil;
resulttype:=voidpointertype;
end;
function trttinode.pass_1 : tnode;
begin
result:=nil;
expectloc:=LOC_CREFERENCE;
end;
function trttinode.docompare(p: tnode): boolean;
begin
docompare :=
inherited docompare(p) and
(rttidef = trttinode(p).rttidef) and
(rttitype = trttinode(p).rttitype);
end;
procedure trttinode.pass_2;
begin
location_reset(location,LOC_CREFERENCE,OS_NO);
location.reference.symbol:=rttidef.get_rtti_label(rttitype);
end;
begin
cloadnode:=tloadnode;
cassignmentnode:=tassignmentnode;
carrayconstructorrangenode:=tarrayconstructorrangenode;
carrayconstructornode:=tarrayconstructornode;
ctypenode:=ttypenode;
crttinode:=trttinode;
end.
{
$Log: nld.pas,v $
Revision 1.119 2003/12/01 18:44:15 peter
* fixed some crashes
* fixed varargs and register calling probs
Revision 1.118 2003/11/26 14:25:26 michael
+ Applied patch from peter to support ansistrings in array constructors
Revision 1.117 2003/11/23 17:39:33 peter
* removed obsolete nf_cargs flag
Revision 1.116 2003/10/28 15:36:01 peter
* absolute to object field supported, fixes tb0458
Revision 1.115 2003/10/23 14:44:07 peter
* splitted buildderef and buildderefimpl to fix interface crc
calculation
Revision 1.114 2003/10/22 20:40:00 peter
* write derefdata in a separate ppu entry
Revision 1.113 2003/10/17 14:38:32 peter
* 64k registers supported
* fixed some memory leaks
Revision 1.112 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.111 2003/10/09 21:31:37 daniel
* Register allocator splitted, ans abstract now
Revision 1.110 2003/10/08 19:19:45 peter
* set_varstate cleanup
Revision 1.109 2003/10/05 21:21:52 peter
* c style array of const generates callparanodes
* varargs paraloc fixes
Revision 1.108 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.107 2003/09/28 17:55:03 peter
* parent framepointer changed to hidden parameter
* tloadparentfpnode added
Revision 1.106 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.105 2003/09/16 16:17:01 peter
* varspez in calls to push_addr_param
Revision 1.104 2003/09/07 22:09:35 peter
* preparations for different default calling conventions
* various RA fixes
Revision 1.103 2003/07/08 15:20:56 peter
* don't allow add/assignments for formaldef
* formaldef size changed to 0
Revision 1.102 2003/06/13 21:19:30 peter
* current_procdef removed, use current_procinfo.procdef instead
Revision 1.101 2003/06/08 20:01:53 jonas
* optimized assignments with on the right side a function that returns
an ansi- or widestring
Revision 1.100 2003/06/08 18:27:15 jonas
+ ability to change the location of a ttempref node with changelocation()
method. Useful to use instead of copying the contents from one temp to
another
+ some shortstring optimizations in tassignmentnode that avoid some
copying (required some shortstring optimizations to be moved from
resulttype to firstpass, because they work on callnodes and string
addnodes are only changed to callnodes in the firstpass)
* allow setting/changing the funcretnode of callnodes after the
resulttypepass has been done, funcretnode is now a property
(all of the above should have a quite big effect on callparatemp)
Revision 1.99 2003/06/07 20:26:32 peter
* re-resolving added instead of reloading from ppu
* tderef object added to store deref info for resolving
Revision 1.98 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.97 2003/06/07 14:39:18 jonas
* set pi_do_call for accesses to threadvars
Revision 1.96 2003/05/26 19:38:28 peter
* generic fpc_shorstr_concat
+ fpc_shortstr_append_shortstr optimization
Revision 1.95 2003/05/23 17:05:13 peter
* loadn procsym need to return procdef
Revision 1.94 2003/05/23 14:27:35 peter
* remove some unit dependencies
* current_procinfo changes to store more info
Revision 1.93 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.92 2003/05/11 14:45:12 peter
* tloadnode does not support objectsymtable,withsymtable anymore
* withnode cleanup
* direct with rewritten to use temprefnode
Revision 1.91 2003/05/09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.90 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.89 2003/04/27 07:29:50 peter
* current_procinfo.procdef cleanup, current_procdef is now always nil when parsing
a new procdef declaration
* aktprocsym removed
* lexlevel removed, use symtable.symtablelevel instead
* implicit init/final code uses the normal genentry/genexit
* funcret state checking updated for new funcret handling
Revision 1.88 2003/04/26 00:28:42 peter
* removed load_funcret
Revision 1.87 2003/04/25 20:59:33 peter
* removed funcretn,funcretsym, function result is now in varsym
and aliases for result and function name are added using absolutesym
* vs_hidden parameter for funcret passed in parameter
* vs_hidden fixes
* writenode changed to printnode and released from extdebug
* -vp option added to generate a tree.log with the nodetree
* nicer printnode for statements, callnode
Revision 1.86 2003/04/23 20:16:04 peter
+ added currency support based on int64
+ is_64bit for use in cg units instead of is_64bitint
* removed cgmessage from n386add, replace with internalerrors
Revision 1.85 2003/04/23 10:10:54 peter
* procvar is not compared in addrn
Revision 1.84 2003/04/22 23:50:23 peter
* firstpass uses expectloc
* checks if there are differences between the expectloc and
location.loc from secondpass in EXTDEBUG
Revision 1.83 2003/04/11 15:01:23 peter
* fix bug 2438
Revision 1.82 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.81 2003/03/11 21:46:24 jonas
* lots of new regallocator fixes, both in generic and ppc-specific code
(ppc compiler still can't compile the linux system unit though)
Revision 1.80 2003/01/07 16:52:58 jonas
* fixed ansistring+char and ansistring+shortstring optimizations (those
cases were always handled as ansistring+ansistring due to
typeconversions inserted by the add-node)
Revision 1.79 2003/01/05 22:44:14 peter
* remove a lot of code to support typen in loadn-procsym
Revision 1.78 2003/01/03 12:15:56 daniel
* Removed ifdefs around notifications
ifdefs around for loop optimizations remain
Revision 1.77 2002/12/31 09:55:58 daniel
+ Notification implementation complete
+ Add for loop code optimization using notifications
results in 1.5-1.9% speed improvement in nestloop benchmark
Optimization incomplete, compiler does not cycle yet with
notifications enabled.
Revision 1.76 2002/12/30 22:44:53 daniel
* Some work on notifications
Revision 1.75 2002/12/27 15:27:25 peter
* remove property indicator when calling internal helpers
Revision 1.74 2002/12/24 16:53:19 peter
* fix for tb0438
Revision 1.73 2002/12/20 18:14:53 peter
* fix result of high_tree when high was not available
Revision 1.72 2002/12/17 22:19:33 peter
* fixed pushing of records>8 bytes with stdcall
* simplified hightree loading
Revision 1.71 2002/12/07 14:27:07 carl
* 3% memory optimization
* changed some types
+ added type checking with different size for call node and for
parameters
Revision 1.70 2002/12/02 19:38:06 carl
* fix some errors
Revision 1.69 2002/11/29 20:02:44 carl
* warning / hint for possible loss of data in assignment
Revision 1.68 2002/11/27 20:04:39 peter
* cdecl array of const fixes
Revision 1.67 2002/11/27 15:33:47 peter
* the never ending story of tp procvar hacks
Revision 1.66 2002/11/25 17:43:20 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.65 2002/11/18 17:31:57 peter
* pass proccalloption to ret_in_xxx and push_xxx functions
Revision 1.64 2002/11/15 01:58:52 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.63 2002/10/17 12:44:09 florian
+ s:=s+<string type> where s is an ansistring is done via calls to append_ansistring_*
Revision 1.62 2002/10/05 12:43:25 carl
* fixes for Delphi 6 compilation
(warning : Some features do not work under Delphi)
Revision 1.61 2002/10/03 21:26:08 carl
+ compile-time range checking for strings
Revision 1.60 2002/09/27 21:13:28 carl
* low-highval always checked if limit ober 2GB is reached (to avoid overflow)
Revision 1.59 2002/09/26 15:02:05 florian
+ support of passing variants to "array of const"
Revision 1.58 2002/09/07 15:25:03 peter
* old logs removed and tabs fixed
Revision 1.57 2002/09/03 16:26:26 daniel
* Make Tprocdef.defs protected
Revision 1.56 2002/09/01 13:28:37 daniel
- write_access fields removed in favor of a flag
Revision 1.55 2002/09/01 08:01:16 daniel
* Removed sets from Tcallnode.det_resulttype
+ Added read/write notifications of variables. These will be usefull
for providing information for several optimizations. For example
the value of the loop variable of a for loop does matter is the
variable is read after the for loop, but if it's no longer used
or written, it doesn't matter and this can be used to optimize
the loop code generation.
Revision 1.54 2002/08/25 19:25:19 peter
* sym.insert_in_data removed
* symtable.insertvardata/insertconstdata added
* removed insert_in_data call from symtable.insert, it needs to be
called separatly. This allows to deref the address calculation
* procedures now calculate the parast addresses after the procedure
directives are parsed. This fixes the cdecl parast problem
* push_addr_param has an extra argument that specifies if cdecl is used
or not
Revision 1.53 2002/08/19 19:36:43 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.52 2002/08/18 20:06:23 peter
* inlining is now also allowed in interface
* renamed write/load to ppuwrite/ppuload
* tnode storing in ppu
* nld,ncon,nbas are already updated for storing in ppu
Revision 1.51 2002/08/17 22:09:46 florian
* result type handling in tcgcal.pass_2 overhauled
* better tnode.dowrite
* some ppc stuff fixed
Revision 1.50 2002/08/17 09:23:37 florian
* first part of procinfo rewrite
Revision 1.49 2002/07/20 11:57:54 florian
* types.pas renamed to defbase.pas because D6 contains a types
unit so this would conflicts if D6 programms are compiled
+ Willamette/SSE2 instructions to assembler added
Revision 1.48 2002/07/20 07:44:37 daniel
* Forgot to add a $ifdef extdebug
Revision 1.47 2002/07/19 12:55:27 daniel
* Further developed state tracking in whilerepeatn
Revision 1.46 2002/07/19 11:41:36 daniel
* State tracker work
* The whilen and repeatn are now completely unified into whilerepeatn. This
allows the state tracker to change while nodes automatically into
repeat nodes.
* Resulttypepass improvements to the notn. 'not not a' is optimized away and
'not(a>b)' is optimized into 'a<=b'.
* Resulttypepass improvements to the whilerepeatn. 'while not a' is optimized
by removing the notn and later switchting the true and falselabels. The
same is done with 'repeat until not a'.
Revision 1.45 2002/07/15 18:03:15 florian
* readded removed changes
Revision 1.43 2002/07/11 14:41:28 florian
* start of the new generic parameter handling
Revision 1.44 2002/07/14 18:00:44 daniel
+ Added the beginning of a state tracker. This will track the values of
variables through procedures and optimize things away.
Revision 1.42 2002/05/18 13:34:10 peter
* readded missing revisions
Revision 1.41 2002/05/16 19:46:38 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.39 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.38 2002/04/25 20:16:39 peter
* moved more routines from cga/n386util
Revision 1.37 2002/04/23 19:16:34 peter
* add pinline unit that inserts compiler supported functions using
one or more statements
* moved finalize and setlength from ninl to pinline
}
syntax highlighted by Code2HTML, v. 0.9.1