mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-26 04:57:09 +01:00
4b82d30953
+ 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.
1145 lines
35 KiB
ObjectPascal
1145 lines
35 KiB
ObjectPascal
{
|
|
$Id$
|
|
Copyright (c) 2000-2002 by Florian Klaempfl
|
|
|
|
Type checking and register allocation for memory related 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 nmem;
|
|
|
|
{$i fpcdefs.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
node,
|
|
symtype,symppu,symdef,symsym,symtable,
|
|
cpubase;
|
|
|
|
type
|
|
tloadvmtnode = class(tunarynode)
|
|
constructor create(l : tnode);virtual;
|
|
function pass_1 : tnode;override;
|
|
function det_resulttype:tnode;override;
|
|
end;
|
|
tloadvmtnodeclass = class of tloadvmtnode;
|
|
|
|
thnewnode = class(tnode)
|
|
objtype : ttype;
|
|
constructor create(t:ttype);virtual;
|
|
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
|
|
procedure ppuwrite(ppufile:tcompilerppufile);override;
|
|
procedure derefimpl;override;
|
|
function pass_1 : tnode;override;
|
|
function det_resulttype:tnode;override;
|
|
end;
|
|
thnewnodeclass = class of thnewnode;
|
|
|
|
thdisposenode = class(tunarynode)
|
|
constructor create(l : tnode);virtual;
|
|
function pass_1 : tnode;override;
|
|
function det_resulttype:tnode;override;
|
|
end;
|
|
thdisposenodeclass = class of thdisposenode;
|
|
|
|
taddrnode = class(tunarynode)
|
|
getprocvardef : tprocvardef;
|
|
constructor create(l : tnode);virtual;
|
|
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
|
|
procedure ppuwrite(ppufile:tcompilerppufile);override;
|
|
procedure derefimpl;override;
|
|
function getcopy : tnode;override;
|
|
function pass_1 : tnode;override;
|
|
function det_resulttype:tnode;override;
|
|
end;
|
|
taddrnodeclass = class of taddrnode;
|
|
|
|
tdoubleaddrnode = class(tunarynode)
|
|
constructor create(l : tnode);virtual;
|
|
function pass_1 : tnode;override;
|
|
function det_resulttype:tnode;override;
|
|
end;
|
|
tdoubleaddrnodeclass = class of tdoubleaddrnode;
|
|
|
|
tderefnode = class(tunarynode)
|
|
{$ifdef var_notification}
|
|
write_access:boolean;
|
|
{$endif}
|
|
constructor create(l : tnode);virtual;
|
|
function pass_1 : tnode;override;
|
|
function det_resulttype:tnode;override;
|
|
{$ifdef var_notification}
|
|
procedure mark_write;override;
|
|
{$endif}
|
|
end;
|
|
tderefnodeclass = class of tderefnode;
|
|
|
|
tsubscriptnode = class(tunarynode)
|
|
vs : tvarsym;
|
|
{$ifdef var_notification}
|
|
write_access:boolean;
|
|
{$endif}
|
|
constructor create(varsym : tsym;l : tnode);virtual;
|
|
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
|
|
procedure ppuwrite(ppufile:tcompilerppufile);override;
|
|
procedure derefimpl;override;
|
|
function getcopy : tnode;override;
|
|
function pass_1 : tnode;override;
|
|
function docompare(p: tnode): boolean; override;
|
|
function det_resulttype:tnode;override;
|
|
{$ifdef var_notification}
|
|
procedure mark_write;override;
|
|
{$endif}
|
|
end;
|
|
tsubscriptnodeclass = class of tsubscriptnode;
|
|
|
|
tvecnode = class(tbinarynode)
|
|
write_access:boolean;
|
|
constructor create(l,r : tnode);virtual;
|
|
function pass_1 : tnode;override;
|
|
function det_resulttype:tnode;override;
|
|
{$ifdef var_notification}
|
|
procedure mark_write;override;
|
|
{$endif}
|
|
end;
|
|
tvecnodeclass = class of tvecnode;
|
|
|
|
tselfnode = class(tnode)
|
|
classdef : tdef; { objectdef or classrefdef }
|
|
constructor create(_class : tdef);virtual;
|
|
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
|
|
procedure ppuwrite(ppufile:tcompilerppufile);override;
|
|
procedure derefimpl;override;
|
|
function pass_1 : tnode;override;
|
|
function det_resulttype:tnode;override;
|
|
end;
|
|
tselfnodeclass = class of tselfnode;
|
|
|
|
twithnode = class(tbinarynode)
|
|
withsymtable : twithsymtable;
|
|
tablecount : longint;
|
|
withreference : treference;
|
|
constructor create(symtable : twithsymtable;l,r : tnode;count : longint);virtual;
|
|
destructor destroy;override;
|
|
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
|
|
procedure ppuwrite(ppufile:tcompilerppufile);override;
|
|
function getcopy : tnode;override;
|
|
function pass_1 : tnode;override;
|
|
function docompare(p: tnode): boolean; override;
|
|
function det_resulttype:tnode;override;
|
|
end;
|
|
twithnodeclass = class of twithnode;
|
|
|
|
var
|
|
cloadvmtnode : tloadvmtnodeclass;
|
|
chnewnode : thnewnodeclass;
|
|
chdisposenode : thdisposenodeclass;
|
|
caddrnode : taddrnodeclass;
|
|
cdoubleaddrnode : tdoubleaddrnodeclass;
|
|
cderefnode : tderefnodeclass;
|
|
csubscriptnode : tsubscriptnodeclass;
|
|
cvecnode : tvecnodeclass;
|
|
cselfnode : tselfnodeclass;
|
|
cwithnode : twithnodeclass;
|
|
|
|
implementation
|
|
|
|
uses
|
|
globtype,systems,
|
|
cutils,verbose,globals,
|
|
symconst,symbase,defbase,
|
|
nbas,
|
|
htypechk,pass_1,ncal,nld,ncon,ncnv,cgbase
|
|
;
|
|
|
|
{*****************************************************************************
|
|
TLOADVMTNODE
|
|
*****************************************************************************}
|
|
|
|
constructor tloadvmtnode.create(l : tnode);
|
|
begin
|
|
inherited create(loadvmtn,l);
|
|
end;
|
|
|
|
function tloadvmtnode.det_resulttype:tnode;
|
|
begin
|
|
result:=nil;
|
|
resulttypepass(left);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
resulttype.setdef(tclassrefdef.create(left.resulttype));
|
|
end;
|
|
|
|
function tloadvmtnode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
registers32:=1;
|
|
location.loc:=LOC_REGISTER;
|
|
end;
|
|
|
|
{*****************************************************************************
|
|
THNEWNODE
|
|
*****************************************************************************}
|
|
|
|
constructor thnewnode.create(t:ttype);
|
|
begin
|
|
inherited create(hnewn);
|
|
objtype:=t;
|
|
end;
|
|
|
|
|
|
constructor thnewnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuload(t,ppufile);
|
|
ppufile.gettype(objtype);
|
|
end;
|
|
|
|
|
|
procedure thnewnode.ppuwrite(ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuwrite(ppufile);
|
|
ppufile.puttype(objtype);
|
|
end;
|
|
|
|
|
|
procedure thnewnode.derefimpl;
|
|
begin
|
|
inherited derefimpl;
|
|
objtype.resolve;
|
|
end;
|
|
|
|
|
|
function thnewnode.det_resulttype:tnode;
|
|
begin
|
|
result:=nil;
|
|
if objtype.def.deftype<>objectdef then
|
|
Message(parser_e_pointer_to_class_expected);
|
|
resulttype:=objtype;
|
|
end;
|
|
|
|
|
|
function thnewnode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
THDISPOSENODE
|
|
*****************************************************************************}
|
|
|
|
constructor thdisposenode.create(l : tnode);
|
|
begin
|
|
inherited create(hdisposen,l);
|
|
end;
|
|
|
|
|
|
function thdisposenode.det_resulttype:tnode;
|
|
begin
|
|
result:=nil;
|
|
resulttypepass(left);
|
|
if codegenerror then
|
|
exit;
|
|
if (left.resulttype.def.deftype<>pointerdef) then
|
|
CGMessage1(type_e_pointer_type_expected,left.resulttype.def.typename);
|
|
resulttype:=tpointerdef(left.resulttype.def).pointertype;
|
|
end;
|
|
|
|
|
|
function thdisposenode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
firstpass(left);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
registers32:=left.registers32;
|
|
registersfpu:=left.registersfpu;
|
|
{$ifdef SUPPORT_MMX}
|
|
registersmmx:=left.registersmmx;
|
|
{$endif SUPPORT_MMX}
|
|
if registers32<1 then
|
|
registers32:=1;
|
|
{
|
|
if left.location.loc<>LOC_REFERENCE then
|
|
CGMessage(cg_e_illegal_expression);
|
|
}
|
|
if left.location.loc=LOC_CREGISTER then
|
|
inc(registers32);
|
|
location.loc:=LOC_REFERENCE;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TADDRNODE
|
|
*****************************************************************************}
|
|
|
|
constructor taddrnode.create(l : tnode);
|
|
|
|
begin
|
|
inherited create(addrn,l);
|
|
getprocvardef:=nil;
|
|
end;
|
|
|
|
|
|
constructor taddrnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuload(t,ppufile);
|
|
getprocvardef:=tprocvardef(ppufile.getderef);
|
|
end;
|
|
|
|
|
|
procedure taddrnode.ppuwrite(ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuwrite(ppufile);
|
|
ppufile.putderef(getprocvardef);
|
|
end;
|
|
|
|
|
|
procedure taddrnode.derefimpl;
|
|
begin
|
|
inherited derefimpl;
|
|
resolvedef(pointer(getprocvardef));
|
|
end;
|
|
|
|
|
|
function taddrnode.getcopy : tnode;
|
|
|
|
var
|
|
p : taddrnode;
|
|
|
|
begin
|
|
p:=taddrnode(inherited getcopy);
|
|
p.getprocvardef:=getprocvardef;
|
|
getcopy:=p;
|
|
end;
|
|
|
|
|
|
function taddrnode.det_resulttype:tnode;
|
|
var
|
|
hp : tnode;
|
|
hp2 : TParaItem;
|
|
hp3 : tabstractprocdef;
|
|
begin
|
|
result:=nil;
|
|
resulttypepass(left);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
{ don't allow constants }
|
|
if is_constnode(left) then
|
|
begin
|
|
aktfilepos:=left.fileinfo;
|
|
CGMessage(type_e_no_addr_of_constant);
|
|
exit;
|
|
end;
|
|
|
|
{ tp @procvar support (type of @procvar is a void pointer)
|
|
Note: we need to leave the addrn in the tree,
|
|
else we can't see the difference between @procvar and procvar.
|
|
we set the procvarload flag so a secondpass does nothing for
|
|
this node (PFV) }
|
|
if (m_tp_procvar in aktmodeswitches) then
|
|
begin
|
|
case left.nodetype of
|
|
calln :
|
|
begin
|
|
{ a load of a procvar can't have parameters }
|
|
if assigned(tcallnode(left).left) then
|
|
CGMessage(cg_e_illegal_expression);
|
|
{ is it a procvar? }
|
|
hp:=tcallnode(left).right;
|
|
if assigned(hp) then
|
|
begin
|
|
{ remove calln node }
|
|
tcallnode(left).right:=nil;
|
|
left.free;
|
|
left:=hp;
|
|
include(flags,nf_procvarload);
|
|
end;
|
|
end;
|
|
loadn,
|
|
subscriptn,
|
|
typeconvn,
|
|
vecn,
|
|
derefn :
|
|
begin
|
|
if left.resulttype.def.deftype=procvardef then
|
|
include(flags,nf_procvarload);
|
|
end;
|
|
end;
|
|
if nf_procvarload in flags then
|
|
begin
|
|
resulttype:=voidpointertype;
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
{ proc 2 procvar ? }
|
|
if left.nodetype=calln then
|
|
{ if it were a valid construct, the addr node would already have }
|
|
{ been removed in the parser. This happens for (in FPC mode) }
|
|
{ procvar1 := @procvar2(parameters); }
|
|
CGMessage(cg_e_illegal_expression)
|
|
else
|
|
if (left.nodetype=loadn) and (tloadnode(left).symtableentry.typ=procsym) then
|
|
begin
|
|
{ the address is already available when loading a procedure of object }
|
|
if assigned(tloadnode(left).left) then
|
|
include(flags,nf_procvarload);
|
|
|
|
{ result is a procedure variable }
|
|
{ No, to be TP compatible, you must return a voidpointer to
|
|
the procedure that is stored in the procvar.}
|
|
if not(m_tp_procvar in aktmodeswitches) then
|
|
begin
|
|
if assigned(getprocvardef) then
|
|
hp3:=getprocvardef
|
|
else
|
|
hp3:=tabstractprocdef(tprocsym(tloadnode(left).symtableentry).first_procdef);
|
|
|
|
{ create procvardef }
|
|
resulttype.setdef(tprocvardef.create);
|
|
tprocvardef(resulttype.def).proctypeoption:=hp3.proctypeoption;
|
|
tprocvardef(resulttype.def).proccalloption:=hp3.proccalloption;
|
|
tprocvardef(resulttype.def).procoptions:=hp3.procoptions;
|
|
tprocvardef(resulttype.def).rettype:=hp3.rettype;
|
|
tprocvardef(resulttype.def).symtablelevel:=hp3.symtablelevel;
|
|
|
|
{ method ? then set the methodpointer flag }
|
|
if (hp3.owner.symtabletype=objectsymtable) then
|
|
include(tprocvardef(resulttype.def).procoptions,po_methodpointer);
|
|
|
|
{ we need to process the parameters reverse so they are inserted
|
|
in the correct right2left order (PFV) }
|
|
hp2:=TParaItem(hp3.Para.last);
|
|
while assigned(hp2) do
|
|
begin
|
|
tprocvardef(resulttype.def).concatpara(hp2.paratype,hp2.parasym,hp2.paratyp,hp2.defaultvalue);
|
|
hp2:=TParaItem(hp2.previous);
|
|
end;
|
|
end
|
|
else
|
|
resulttype:=voidpointertype;
|
|
end
|
|
else
|
|
begin
|
|
{ what are we getting the address from an absolute sym? }
|
|
hp:=left;
|
|
while assigned(hp) and (hp.nodetype in [vecn,derefn,subscriptn]) do
|
|
hp:=tunarynode(hp).left;
|
|
if assigned(hp) and (hp.nodetype=loadn) and
|
|
((tloadnode(hp).symtableentry.typ=absolutesym) and
|
|
tabsolutesym(tloadnode(hp).symtableentry).absseg) then
|
|
begin
|
|
if not(cs_typed_addresses in aktlocalswitches) then
|
|
resulttype:=voidfarpointertype
|
|
else
|
|
resulttype.setdef(tpointerdef.createfar(left.resulttype));
|
|
end
|
|
else
|
|
begin
|
|
if not(cs_typed_addresses in aktlocalswitches) then
|
|
resulttype:=voidpointertype
|
|
else
|
|
resulttype.setdef(tpointerdef.create(left.resulttype));
|
|
end;
|
|
end;
|
|
|
|
{ this is like the function addr }
|
|
inc(parsing_para_level);
|
|
set_varstate(left,false);
|
|
dec(parsing_para_level);
|
|
|
|
end;
|
|
|
|
|
|
function taddrnode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
firstpass(left);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
make_not_regable(left);
|
|
if nf_procvarload in flags then
|
|
begin
|
|
registers32:=left.registers32;
|
|
registersfpu:=left.registersfpu;
|
|
{$ifdef SUPPORT_MMX}
|
|
registersmmx:=left.registersmmx;
|
|
{$endif SUPPORT_MMX}
|
|
if registers32<1 then
|
|
registers32:=1;
|
|
location.loc:=left.location.loc;
|
|
exit;
|
|
end;
|
|
|
|
{ we should allow loc_mem for @string }
|
|
if not(left.location.loc in [LOC_CREFERENCE,LOC_REFERENCE]) then
|
|
begin
|
|
aktfilepos:=left.fileinfo;
|
|
CGMessage(cg_e_illegal_expression);
|
|
end;
|
|
|
|
registers32:=left.registers32;
|
|
registersfpu:=left.registersfpu;
|
|
{$ifdef SUPPORT_MMX}
|
|
registersmmx:=left.registersmmx;
|
|
{$endif SUPPORT_MMX}
|
|
if registers32<1 then
|
|
registers32:=1;
|
|
{ is this right for object of methods ?? }
|
|
location.loc:=LOC_REGISTER;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TDOUBLEADDRNODE
|
|
*****************************************************************************}
|
|
|
|
constructor tdoubleaddrnode.create(l : tnode);
|
|
begin
|
|
inherited create(doubleaddrn,l);
|
|
end;
|
|
|
|
|
|
function tdoubleaddrnode.det_resulttype:tnode;
|
|
begin
|
|
result:=nil;
|
|
resulttypepass(left);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
inc(parsing_para_level);
|
|
set_varstate(left,false);
|
|
dec(parsing_para_level);
|
|
|
|
if (left.resulttype.def.deftype)<>procvardef then
|
|
CGMessage(cg_e_illegal_expression);
|
|
|
|
resulttype:=voidpointertype;
|
|
end;
|
|
|
|
|
|
function tdoubleaddrnode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
make_not_regable(left);
|
|
firstpass(left);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
if (left.location.loc<>LOC_REFERENCE) then
|
|
CGMessage(cg_e_illegal_expression);
|
|
|
|
registers32:=left.registers32;
|
|
registersfpu:=left.registersfpu;
|
|
{$ifdef SUPPORT_MMX}
|
|
registersmmx:=left.registersmmx;
|
|
{$endif SUPPORT_MMX}
|
|
if registers32<1 then
|
|
registers32:=1;
|
|
location.loc:=LOC_REGISTER;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TDEREFNODE
|
|
*****************************************************************************}
|
|
|
|
constructor tderefnode.create(l : tnode);
|
|
|
|
begin
|
|
inherited create(derefn,l);
|
|
|
|
end;
|
|
|
|
function tderefnode.det_resulttype:tnode;
|
|
begin
|
|
result:=nil;
|
|
resulttypepass(left);
|
|
set_varstate(left,true);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
if left.resulttype.def.deftype=pointerdef then
|
|
resulttype:=tpointerdef(left.resulttype.def).pointertype
|
|
else
|
|
CGMessage(cg_e_invalid_qualifier);
|
|
end;
|
|
|
|
{$ifdef var_notification}
|
|
procedure Tderefnode.mark_write;
|
|
|
|
begin
|
|
write_access:=true;
|
|
end;
|
|
{$endif}
|
|
|
|
function tderefnode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
firstpass(left);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
registers32:=max(left.registers32,1);
|
|
registersfpu:=left.registersfpu;
|
|
{$ifdef SUPPORT_MMX}
|
|
registersmmx:=left.registersmmx;
|
|
{$endif SUPPORT_MMX}
|
|
|
|
location.loc:=LOC_REFERENCE;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TSUBSCRIPTNODE
|
|
*****************************************************************************}
|
|
|
|
constructor tsubscriptnode.create(varsym : tsym;l : tnode);
|
|
|
|
begin
|
|
inherited create(subscriptn,l);
|
|
{ vs should be changed to tsym! }
|
|
vs:=tvarsym(varsym);
|
|
end;
|
|
|
|
constructor tsubscriptnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuload(t,ppufile);
|
|
vs:=tvarsym(ppufile.getderef);
|
|
end;
|
|
|
|
|
|
procedure tsubscriptnode.ppuwrite(ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuwrite(ppufile);
|
|
ppufile.putderef(vs);
|
|
end;
|
|
|
|
|
|
procedure tsubscriptnode.derefimpl;
|
|
begin
|
|
inherited derefimpl;
|
|
resolvesym(pointer(vs));
|
|
end;
|
|
|
|
|
|
function tsubscriptnode.getcopy : tnode;
|
|
|
|
var
|
|
p : tsubscriptnode;
|
|
|
|
begin
|
|
p:=tsubscriptnode(inherited getcopy);
|
|
p.vs:=vs;
|
|
getcopy:=p;
|
|
end;
|
|
|
|
|
|
function tsubscriptnode.det_resulttype:tnode;
|
|
begin
|
|
result:=nil;
|
|
resulttypepass(left);
|
|
resulttype:=vs.vartype;
|
|
end;
|
|
|
|
{$ifdef var_notification}
|
|
procedure Tsubscriptnode.mark_write;
|
|
|
|
begin
|
|
write_access:=true;
|
|
end;
|
|
{$endif}
|
|
|
|
function tsubscriptnode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
firstpass(left);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
registers32:=left.registers32;
|
|
registersfpu:=left.registersfpu;
|
|
{$ifdef SUPPORT_MMX}
|
|
registersmmx:=left.registersmmx;
|
|
{$endif SUPPORT_MMX}
|
|
{ classes must be dereferenced implicit }
|
|
if is_class_or_interface(left.resulttype.def) then
|
|
begin
|
|
if registers32=0 then
|
|
registers32:=1;
|
|
location.loc:=LOC_REFERENCE;
|
|
end
|
|
else
|
|
begin
|
|
if (left.location.loc<>LOC_CREFERENCE) and
|
|
(left.location.loc<>LOC_REFERENCE) then
|
|
CGMessage(cg_e_illegal_expression);
|
|
location.loc:=left.location.loc;
|
|
end;
|
|
end;
|
|
|
|
function tsubscriptnode.docompare(p: tnode): boolean;
|
|
begin
|
|
docompare :=
|
|
inherited docompare(p) and
|
|
(vs = tsubscriptnode(p).vs);
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TVECNODE
|
|
*****************************************************************************}
|
|
|
|
constructor tvecnode.create(l,r : tnode);
|
|
|
|
begin
|
|
inherited create(vecn,l,r);
|
|
end;
|
|
|
|
|
|
function tvecnode.det_resulttype:tnode;
|
|
var
|
|
htype : ttype;
|
|
ct : tconverttype;
|
|
begin
|
|
result:=nil;
|
|
resulttypepass(left);
|
|
resulttypepass(right);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
{ range check only for arrays }
|
|
if (left.resulttype.def.deftype=arraydef) then
|
|
begin
|
|
if (isconvertable(right.resulttype.def,tarraydef(left.resulttype.def).rangetype.def,
|
|
ct,ordconstn,false)=0) and
|
|
not(is_equal(right.resulttype.def,tarraydef(left.resulttype.def).rangetype.def)) then
|
|
CGMessage(type_e_mismatch);
|
|
end;
|
|
{ Never convert a boolean or a char !}
|
|
{ maybe type conversion }
|
|
if (right.resulttype.def.deftype<>enumdef) and
|
|
not(is_char(right.resulttype.def)) and
|
|
not(is_boolean(right.resulttype.def)) then
|
|
begin
|
|
inserttypeconv(right,s32bittype);
|
|
end;
|
|
|
|
{ are we accessing a pointer[], then convert the pointer to
|
|
an array first, in FPC this is allowed for all pointers in
|
|
delphi/tp7 it's only allowed for pchars }
|
|
if (left.resulttype.def.deftype=pointerdef) and
|
|
((m_fpc in aktmodeswitches) or
|
|
is_pchar(left.resulttype.def) or
|
|
is_pwidechar(left.resulttype.def)) then
|
|
begin
|
|
{ convert pointer to array }
|
|
htype.setdef(tarraydef.create(0,$7fffffff,s32bittype));
|
|
tarraydef(htype.def).elementtype:=tpointerdef(left.resulttype.def).pointertype;
|
|
inserttypeconv(left,htype);
|
|
|
|
resulttype:=tarraydef(htype.def).elementtype;
|
|
end;
|
|
|
|
{ determine return type }
|
|
if not assigned(resulttype.def) then
|
|
if left.resulttype.def.deftype=arraydef then
|
|
resulttype:=tarraydef(left.resulttype.def).elementtype
|
|
else if left.resulttype.def.deftype=stringdef then
|
|
begin
|
|
{ indexed access to strings }
|
|
case tstringdef(left.resulttype.def).string_typ of
|
|
st_widestring :
|
|
resulttype:=cwidechartype;
|
|
st_ansistring :
|
|
resulttype:=cchartype;
|
|
st_longstring :
|
|
resulttype:=cchartype;
|
|
st_shortstring :
|
|
resulttype:=cchartype;
|
|
end;
|
|
end
|
|
else
|
|
CGMessage(type_e_array_required);
|
|
end;
|
|
|
|
{$ifdef var_notification}
|
|
procedure Tvecnode.mark_write;
|
|
|
|
begin
|
|
write_access:=true;
|
|
end;
|
|
{$endif}
|
|
|
|
function tvecnode.pass_1 : tnode;
|
|
{$ifdef consteval}
|
|
var
|
|
tcsym : ttypedconstsym;
|
|
{$endif}
|
|
begin
|
|
result:=nil;
|
|
firstpass(left);
|
|
firstpass(right);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
{ the register calculation is easy if a const index is used }
|
|
if right.nodetype=ordconstn then
|
|
begin
|
|
{$ifdef consteval}
|
|
{ constant evaluation }
|
|
if (left.nodetype=loadn) and
|
|
(left.symtableentry.typ=typedconstsym) then
|
|
begin
|
|
tcsym:=ttypedconstsym(left.symtableentry);
|
|
if tcsym.defintion^.typ=stringdef then
|
|
begin
|
|
|
|
end;
|
|
end;
|
|
{$endif}
|
|
registers32:=left.registers32;
|
|
|
|
{ for ansi/wide strings, we need at least one register }
|
|
if is_ansistring(left.resulttype.def) or
|
|
is_widestring(left.resulttype.def) or
|
|
{ ... as well as for dynamic arrays }
|
|
is_dynamic_array(left.resulttype.def) then
|
|
registers32:=max(registers32,1);
|
|
end
|
|
else
|
|
begin
|
|
{ this rules are suboptimal, but they should give }
|
|
{ good results }
|
|
registers32:=max(left.registers32,right.registers32);
|
|
|
|
{ for ansi/wide strings, we need at least one register }
|
|
if is_ansistring(left.resulttype.def) or
|
|
is_widestring(left.resulttype.def) or
|
|
{ ... as well as for dynamic arrays }
|
|
is_dynamic_array(left.resulttype.def) then
|
|
registers32:=max(registers32,1);
|
|
|
|
{ need we an extra register when doing the restore ? }
|
|
if (left.registers32<=right.registers32) and
|
|
{ only if the node needs less than 3 registers }
|
|
{ two for the right node and one for the }
|
|
{ left address }
|
|
(registers32<3) then
|
|
inc(registers32);
|
|
|
|
{ need we an extra register for the index ? }
|
|
if (right.location.loc<>LOC_REGISTER)
|
|
{ only if the right node doesn't need a register }
|
|
and (right.registers32<1) then
|
|
inc(registers32);
|
|
|
|
{ not correct, but what works better ?
|
|
if left.registers32>0 then
|
|
registers32:=max(registers32,2)
|
|
else
|
|
min. one register
|
|
registers32:=max(registers32,1);
|
|
}
|
|
end;
|
|
registersfpu:=max(left.registersfpu,right.registersfpu);
|
|
{$ifdef SUPPORT_MMX}
|
|
registersmmx:=max(left.registersmmx,right.registersmmx);
|
|
{$endif SUPPORT_MMX}
|
|
if left.location.loc in [LOC_CREGISTER,LOC_REFERENCE] then
|
|
location.loc:=LOC_REFERENCE
|
|
else
|
|
location.loc:=LOC_CREFERENCE;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TSELFNODE
|
|
*****************************************************************************}
|
|
|
|
constructor tselfnode.create(_class : tdef);
|
|
|
|
begin
|
|
inherited create(selfn);
|
|
classdef:=_class;
|
|
end;
|
|
|
|
constructor tselfnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuload(t,ppufile);
|
|
classdef:=tdef(ppufile.getderef);
|
|
end;
|
|
|
|
|
|
procedure tselfnode.ppuwrite(ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuwrite(ppufile);
|
|
ppufile.putderef(classdef);
|
|
end;
|
|
|
|
|
|
procedure tselfnode.derefimpl;
|
|
begin
|
|
inherited derefimpl;
|
|
resolvedef(pointer(classdef));
|
|
end;
|
|
|
|
|
|
function tselfnode.det_resulttype:tnode;
|
|
begin
|
|
result:=nil;
|
|
resulttype.setdef(classdef);
|
|
end;
|
|
|
|
function tselfnode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
if (resulttype.def.deftype=classrefdef) or
|
|
is_class(resulttype.def) then
|
|
location.loc:=LOC_CREGISTER
|
|
else
|
|
location.loc:=LOC_REFERENCE;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TWITHNODE
|
|
*****************************************************************************}
|
|
|
|
constructor twithnode.create(symtable : twithsymtable;l,r : tnode;count : longint);
|
|
|
|
begin
|
|
inherited create(withn,l,r);
|
|
withsymtable:=symtable;
|
|
tablecount:=count;
|
|
FillChar(withreference,sizeof(withreference),0);
|
|
set_file_line(l);
|
|
end;
|
|
|
|
|
|
destructor twithnode.destroy;
|
|
var
|
|
hsymt,
|
|
symt : tsymtable;
|
|
i : longint;
|
|
begin
|
|
symt:=withsymtable;
|
|
for i:=1 to tablecount do
|
|
begin
|
|
if assigned(symt) then
|
|
begin
|
|
hsymt:=symt.next;
|
|
symt.free;
|
|
symt:=hsymt;
|
|
end;
|
|
end;
|
|
inherited destroy;
|
|
end;
|
|
|
|
|
|
constructor twithnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuload(t,ppufile);
|
|
internalerror(200208192);
|
|
end;
|
|
|
|
|
|
procedure twithnode.ppuwrite(ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuwrite(ppufile);
|
|
internalerror(200208193);
|
|
end;
|
|
|
|
|
|
function twithnode.getcopy : tnode;
|
|
|
|
var
|
|
p : twithnode;
|
|
|
|
begin
|
|
p:=twithnode(inherited getcopy);
|
|
p.withsymtable:=withsymtable;
|
|
p.tablecount:=tablecount;
|
|
p.withreference:=withreference;
|
|
result:=p;
|
|
end;
|
|
|
|
function twithnode.det_resulttype:tnode;
|
|
var
|
|
symtable : tsymtable;
|
|
i : longint;
|
|
begin
|
|
result:=nil;
|
|
resulttype:=voidtype;
|
|
if assigned(left) and assigned(right) then
|
|
begin
|
|
resulttypepass(left);
|
|
unset_varstate(left);
|
|
set_varstate(left,true);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
symtable:=withsymtable;
|
|
for i:=1 to tablecount do
|
|
begin
|
|
if (left.nodetype=loadn) and
|
|
(tloadnode(left).symtable=aktprocdef.localst) then
|
|
twithsymtable(symtable).direct_with:=true;
|
|
twithsymtable(symtable).withnode:=self;
|
|
symtable:=symtable.next;
|
|
end;
|
|
|
|
resulttypepass(right);
|
|
if codegenerror then
|
|
exit;
|
|
end;
|
|
resulttype:=voidtype;
|
|
end;
|
|
|
|
|
|
function twithnode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
if assigned(left) and assigned(right) then
|
|
begin
|
|
firstpass(left);
|
|
firstpass(right);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
left_right_max;
|
|
end
|
|
else
|
|
begin
|
|
{ optimization }
|
|
result:=nil;
|
|
end;
|
|
end;
|
|
|
|
function twithnode.docompare(p: tnode): boolean;
|
|
begin
|
|
docompare :=
|
|
inherited docompare(p) and
|
|
(withsymtable = twithnode(p).withsymtable) and
|
|
(tablecount = twithnode(p).tablecount);
|
|
end;
|
|
|
|
begin
|
|
cloadvmtnode := tloadvmtnode;
|
|
chnewnode := thnewnode;
|
|
chdisposenode := thdisposenode;
|
|
caddrnode := taddrnode;
|
|
cdoubleaddrnode := tdoubleaddrnode;
|
|
cderefnode := tderefnode;
|
|
csubscriptnode := tsubscriptnode;
|
|
cvecnode := tvecnode;
|
|
cselfnode := tselfnode;
|
|
cwithnode := twithnode;
|
|
end.
|
|
{
|
|
$Log$
|
|
Revision 1.37 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.36 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.35 2002/07/23 09:51:23 daniel
|
|
* Tried to make Tprocsym.defs protected. I didn't succeed but the cleanups
|
|
are worth comitting.
|
|
|
|
Revision 1.34 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.33 2002/05/18 13:34:10 peter
|
|
* readded missing revisions
|
|
|
|
Revision 1.32 2002/05/16 19:46:39 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.30 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.29 2002/04/21 19:02:04 peter
|
|
* removed newn and disposen nodes, the code is now directly
|
|
inlined from pexpr
|
|
* -an option that will write the secondpass nodes to the .s file, this
|
|
requires EXTDEBUG define to actually write the info
|
|
* fixed various internal errors and crashes due recent code changes
|
|
|
|
Revision 1.28 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.27 2002/04/02 17:11:29 peter
|
|
* tlocation,treference update
|
|
* LOC_CONSTANT added for better constant handling
|
|
* secondadd splitted in multiple routines
|
|
* location_force_reg added for loading a location to a register
|
|
of a specified size
|
|
* secondassignment parses now first the right and then the left node
|
|
(this is compatible with Kylix). This saves a lot of push/pop especially
|
|
with string operations
|
|
* adapted some routines to use the new cg methods
|
|
|
|
Revision 1.26 2002/04/01 20:57:13 jonas
|
|
* fixed web bug 1907
|
|
* fixed some other procvar related bugs (all related to accepting procvar
|
|
constructs with either too many or too little parameters)
|
|
(both merged, includes second typo fix of pexpr.pas)
|
|
|
|
}
|