paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-14 20:49:22 +02:00
Code Issues Packages Projects Releases Wiki Activity

* initial revision

Browse Source
This commit is contained in:
florian 2000-09-25 14:55:05 +00:00
parent 991db24e93
commit f245ef187f
1 changed files with 696 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

696
compiler/nld.pas Normal file
View File

@ -0,0 +1,696 @@
{
$Id$
Copyright (c) 2000 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;
interface
uses
node,symtable;
type
tloadnode = class(tunarynode)
symtableentry : psym;
symtable : psymtable;
constructor create(v : pvarsym;st : psymtable);virtual;
function getcopy : tnode;override;
function pass_1 : tnode;override;
end;
{ different assignment types }
tassigntyp = (at_normal,at_plus,at_minus,at_star,at_slash);
tassignmentnode = class(tbinarynode)
assigntyp : tassigntyp;
constructor create(l,r : tnode);virtual;
function getcopy : tnode;override;
function pass_1 : tnode;override;
end;
tfuncretnode = class(tnode)
funcretprocinfo : pointer;
{$IFDEF NEWST}
retsym : Psym;
{$ELSE}
rettype : ttype;
{$ENDIF}
constructor create;virtual;
function getcopy : tnode;override;
function pass_1 : tnode;override;
end;
tarrayconstructorrangenode = class(tbinarynode)
constructor create(l,r : tnode);virtual;
function pass_1 : tnode;override;
end;
tarrayconstructnode = class(tbinarynode)
constructdef : pdef;
constructor create(l,r : tnode);virtual;
function getcopy : tnode;
function pass_1 : tnode;override;
end;
ttypenode = class(tnode)
typenodetype : pdef;
typenodesym:ptypesym
constructor create(t : pdef;sym:ptypesym);virtual;
function getcopy : tnode;override;
function pass_1 : tnode;override;
end;
var
cloadnode : class of tloadnode;
cassignmentnode : class of tassignmentnode;
cfuncretnode : class of tfuncretnode;
carrayconstructorrangenode : class of tarrayconstructorrangenode;
carrayconstructnode : class of tarrayconstructnode;
ctypenode : class of ttypenode;
function gentypenode(t : pdef;sym:ptypesym) : ttypenode;
implementation
uses
cutils,cobjects,verbose,globtype,globals,systems,
symconst,aasm,types,
htypechk,pass_1,
ncnv,cpubase
{$ifdef newcg}
,cgbase
,tgobj
,tgcpu
{$else newcg}
,hcodegen
{$ifdef i386}
,tgeni386
{$endif}
{$endif newcg}
;
function genloadnode(v : pvarsym;st : psymtable) : tloadnode;
begin
genloadnode:=cloadnode.create(v,st);
end;
function gentypenode(t : pdef;sym:ptypesym) : ttypenode;
begin
gentypenode:=ctypenode.create(t,sym);
end;
{*****************************************************************************
TLOADNODE
*****************************************************************************}
constructor tloadnode.create(v : pvarsym;st : psymtable);
begin
inherited create(loadn,nil);
symtableentry:=v;
symtable:=st;
end;
function tloadnode.getcopy : tnode;
var
n : tloadnode;
begin
n:=tloadnode(inherited getcopy);
n.symtable:=symtable;
n.symtableentry:=symtableentry;
end;
function tloadnode.pass_1 : tnode;
var
p1 : tnode;
begin
if (symtable^.symtabletype=withsymtable) and
(pwithsymtable(symtable)^.direct_with) and
(symtableentry^.typ=varsym) then
begin
p1:=getcopy(ptree(pwithsymtable(symtable)^.withrefnode));
p1:=gensubscriptnode(pvarsym(symtableentry),p1);
putnode(p);
p:=p1;
firstpass(p);
exit;
end;
location.loc:=LOC_REFERENCE;
registers32:=0;
registersfpu:=0;
{$ifdef SUPPORT_MMX}
registersmmx:=0;
{$endif SUPPORT_MMX}
{ handle first absolute as it will replace the symtableentry }
if symtableentry^.typ=absolutesym then
begin
resulttype:=pabsolutesym(symtableentry)^.vartype.def;
{ replace the symtableentry when it points to a var, else
we are finished }
if pabsolutesym(symtableentry)^.abstyp=tovar then
begin
symtableentry:=pabsolutesym(symtableentry)^.ref;
symtable:=symtableentry^.owner;
is_absolute:=true;
end
else
exit;
end;
case symtableentry^.typ of
funcretsym :
begin
p1:=genzeronode(funcretn);
p1.funcretprocinfo:=pprocinfo(pfuncretsym(symtableentry)^.funcretprocinfo);
p1.rettype:=pfuncretsym(symtableentry)^.rettype;
firstpass(p1);
{ if it's refered as absolute then we need to have the
type of the absolute instead of the function return,
the function return is then also assigned }
if is_absolute then
begin
pprocinfo(p1.funcretprocinfo)^.funcret_state:=vs_assigned;
p1.resulttype:=resulttype;
end;
putnode(p);
p:=p1;
end;
constsym:
begin
if pconstsym(symtableentry)^.consttyp=constresourcestring then
begin
resulttype:=cansistringdef;
{ we use ansistrings so no fast exit here }
if assigned(procinfo) then
procinfo^.no_fast_exit:=true;
location.loc:=LOC_MEM;
end
else
internalerror(22799);
end;
varsym :
begin
{ if it's refered by absolute then it's used }
if is_absolute then
pvarsym(symtableentry)^.varstate:=vs_used
else
if (resulttype=nil) then
resulttype:=pvarsym(symtableentry)^.vartype.def;
if (symtable^.symtabletype in [parasymtable,localsymtable]) and
(lexlevel>symtable^.symtablelevel) then
begin
{ if the variable is in an other stackframe then we need
a register to dereference }
if (symtable^.symtablelevel)>0 then
begin
registers32:=1;
{ further, the variable can't be put into a register }
pvarsym(symtableentry)^.varoptions:=
pvarsym(symtableentry)^.varoptions-[vo_fpuregable,vo_regable];
end;
end;
if (pvarsym(symtableentry)^.varspez=vs_const) then
location.loc:=LOC_MEM;
{ we need a register for call by reference parameters }
if (pvarsym(symtableentry)^.varspez in [vs_var,vs_out]) or
((pvarsym(symtableentry)^.varspez=vs_const) and
push_addr_param(pvarsym(symtableentry)^.vartype.def)) or
{ call by value open arrays are also indirect addressed }
is_open_array(pvarsym(symtableentry)^.vartype.def) then
registers32:=1;
if symtable^.symtabletype=withsymtable then
inc(registers32);
if ([vo_is_thread_var,vo_is_dll_var]*pvarsym(symtableentry)^.varoptions)<>[] then
registers32:=1;
{ a class variable is a pointer !!!
yes, but we have to resolve the reference in an
appropriate tree node (FK)
if (pvarsym(symtableentry)^.definition^.deftype=objectdef) and
((pobjectdef(pvarsym(symtableentry)^.definition)^.options and oo_is_class)<>0) then
registers32:=1;
}
{ count variable references }
{ this will create problem with local var set by
under_procedures
if (assigned(pvarsym(symtableentry)^.owner) and assigned(aktprocsym)
and ((pvarsym(symtableentry)^.owner = aktprocsym^.definition^.localst)
or (pvarsym(symtableentry)^.owner = aktprocsym^.definition^.localst))) then }
if t_times<1 then
inc(pvarsym(symtableentry)^.refs)
else
inc(pvarsym(symtableentry)^.refs,t_times);
end;
typedconstsym :
if not is_absolute then
resulttype:=ptypedconstsym(symtableentry)^.typedconsttype.def;
procsym :
begin
if assigned(pprocsym(symtableentry)^.definition^.nextoverloaded) then
CGMessage(parser_e_no_overloaded_procvars);
resulttype:=pprocsym(symtableentry)^.definition;
{ if the owner of the procsym is a object, }
{ left must be set, if left isn't set }
{ it can be only self }
{ this code is only used in TP procvar mode }
if (m_tp_procvar in aktmodeswitches) and
not(assigned(left)) and
(pprocsym(symtableentry)^.owner^.symtabletype=objectsymtable) then
left:=genselfnode(pobjectdef(symtableentry^.owner^.defowner));
{ method pointer ? }
if assigned(left) then
begin
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(3);
end;
end;
{*****************************************************************************
TASSIGNMENTNODE
*****************************************************************************}
constructor tassignmentnode.create(l,r : tnode);
begin
inherited create(assignn,l,r);
assigntype:=at_normal;
end;
function tassignmentnode.getcopy : tnode;
var
n : tassignmentnode;
begin
n:=tassignmentnode(inherited getcopy);
n.assigntype:=assigntype;
getcopy:=n;
end;
function tassignmentnode.pass_1 : tnode;
{$ifdef newoptimizations2}
var
hp : tnode;
{$endif newoptimizations2}
begin
{ must be made unique }
set_unique(left);
{ set we the function result? }
set_funcret_is_valid(left);
firstpass(left);
set_varstate(left,false);
if codegenerror then
exit;
{ assignements to open arrays aren't allowed }
if is_open_array(left.resulttype) then
CGMessage(type_e_mismatch);
{ test if we can avoid copying string to temp
as in s:=s+...; (PM) }
{$ifdef dummyi386}
if ((right.treetype=addn) or (right.treetype=subn)) and
equal_trees(left,right.left) and
(ret_in_acc(left.resulttype)) and
(not cs_rangechecking in aktmoduleswitches^) then
begin
disposetree(right.left);
hp:=right;
right:=right.right;
if hp.treetype=addn then
assigntyp:=at_plus
else
assigntyp:=at_minus;
putnode(hp);
end;
if assigntyp<>at_normal then
begin
{ for fpu type there is no faster way }
if is_fpu(left.resulttype) then
case assigntyp of
at_plus : right:=gennode(addn,getcopy(left),right);
at_minus : right:=gennode(subn,getcopy(left),right);
at_star : right:=gennode(muln,getcopy(left),right);
at_slash : right:=gennode(slashn,getcopy(left),right);
end;
end;
{$endif i386}
firstpass(right);
set_varstate(right,true);
if codegenerror then
exit;
{ some string functions don't need conversion, so treat them separatly }
if is_shortstring(left.resulttype) and (assigned(right.resulttype)) then
begin
if not (is_shortstring(right.resulttype) or
is_ansistring(right.resulttype) or
is_char(right.resulttype)) then
begin
right:=gentypeconvnode(right,left.resulttype);
firstpass(right);
if codegenerror then
exit;
end;
{ we call STRCOPY }
procinfo^.flags:=procinfo^.flags or pi_do_call;
{ test for s:=s+anything ... }
{ the problem is for
s:=s+s+s;
this is broken here !! }
{$ifdef newoptimizations2}
{ the above is fixed now, but still problem with s := s + f(); if }
{ f modifies s (bad programming, so only enable if uncertain }
{ optimizations are on) (JM) }
if (cs_UncertainOpts in aktglobalswitches) then
begin
hp := right;
while hp.treetype=addn do hp:=hp.left;
if equal_trees(left,hp) and
not multiple_uses(left,right) then
begin
concat_string:=true;
hp:=right;
while hp.treetype=addn do
begin
hp.use_strconcat:=true;
hp:=hp.left;
end;
end;
end;
{$endif newoptimizations2}
end
else
begin
right:=gentypeconvnode(right,left.resulttype);
firstpass(right);
if codegenerror then
exit;
end;
{ test if node can be assigned, properties are allowed }
valid_for_assign(left,true);
{ check if local proc/func is assigned to procvar }
if right.resulttype^.deftype=procvardef then
test_local_to_procvar(pprocvardef(right.resulttype),left.resulttype);
resulttype:=voiddef;
{
registers32:=max(left.registers32,right.registers32);
registersfpu:=max(left.registersfpu,right.registersfpu);
}
registers32:=left.registers32+right.registers32;
registersfpu:=max(left.registersfpu,right.registersfpu);
{$ifdef SUPPORT_MMX}
registersmmx:=max(left.registersmmx,right.registersmmx);
{$endif SUPPORT_MMX}
end;
{*****************************************************************************
TFUNCRETNODE
*****************************************************************************}
constructor tfuncretnode.create;
begin
inherited create(tfuncretn);
funcretprocinfo:=nil;
n.rettype:=nil;
end;
function tfuncretnode.getcopy : tnode;
var
n : tfuncretnode;
begin
n:=tfuncretnode(inherited getcopy);
n.funcretprocinfo:=funcretprocinfo;
{$ifdef NEWST}
n.retsym:=retsym;
{$else NEWST}
n.rettype:=rettype;
{$endif NEWST}
getcopy:=n;
end;
function tfuncretnode.pass_1 : tnode;
begin
resulttype:=rettype.def;
location.loc:=LOC_REFERENCE;
if ret_in_param(rettype.def) or
(procinfo<>pprocinfo(funcretprocinfo)) then
registers32:=1;
end;
{*****************************************************************************
TARRAYCONSTRUCTRANGENODE
*****************************************************************************}
constructor tarrayconstructrangenode.create(l,r : tnode);
begin
inherited create(arrayconstructn,l,r);
end;
function tarrayconstructrangenode.pass_1 : tnode;
begin
firstpass(left);
left.set_varstate(true);
firstpass(right);
right.set_varstate(true);
calcregisters(p,0,0,0);
resulttype:=left.resulttype;
end;
{****************************************************************************
TARRAYCONSTRUCTNODE
*****************************************************************************}
constructor tarrayconstrucnode.create(l,r : tnode);
begin
inherited create(arrayconstructnode,l,r);
constructdef:=nil;
end;
function tarrayconstrucnode.getcopy : tnode;
var
n : tarrayconstructnode;
begin
n:=tarrayconstructnode(inherited getcopy);
n.constructdef:=constructdef;
end;
function tarrayconstructnode.pass_1 : tnode;
var
pd : pdef;
thp,
chp,
hp : tnode;
len : longint;
varia : boolean;
begin
{ are we allowing array constructor? Then convert it to a set }
if not allow_array_constructor then
begin
arrayconstructor_to_set(p);
firstpass(p);
exit;
end;
{ only pass left tree, right tree contains next construct if any }
pd:=constructdef;
len:=0;
varia:=false;
if assigned(left) then
begin
hp:=p;
while assigned(hp) do
begin
firstpass(hp.left);
hp.left.set_varstate(true);
if (not get_para_resulttype) and (not novariaallowed) then
begin
case hp.left.resulttype^.deftype of
enumdef :
begin
hp.left:=gentypeconvnode(hp.left,s32bitdef);
firstpass(hp.left);
end;
orddef :
begin
if is_integer(hp.left.resulttype) and
not(is_64bitint(hp.left.resulttype)) then
begin
hp.left:=gentypeconvnode(hp.left,s32bitdef);
firstpass(hp.left);
end;
end;
floatdef :
begin
hp.left:=gentypeconvnode(hp.left,bestrealdef^);
firstpass(hp.left);
end;
stringdef :
begin
if cargs then
begin
hp.left:=gentypeconvnode(hp.left,charpointerdef);
firstpass(hp.left);
end;
end;
procvardef :
begin
hp.left:=gentypeconvnode(hp.left,voidpointerdef);
firstpass(hp.left);
end;
pointerdef,
classrefdef,
objectdef : ;
else
CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype^.typename);
end;
end;
if (pd=nil) then
pd:=hp.left.resulttype
else
begin
if ((novariaallowed) or (not varia)) and
(not is_equal(pd,hp.left.resulttype)) then
begin
{ if both should be equal try inserting a conversion }
if novariaallowed then
begin
hp.left:=gentypeconvnode(hp.left,pd);
firstpass(hp.left);
end;
varia:=true;
end;
end;
inc(len);
hp:=hp.right;
end;
{ swap the tree for cargs }
if cargs and (not cargswap) then
begin
chp:=nil;
hp:=p;
while assigned(hp) do
begin
thp:=hp.right;
hp.right:=chp;
chp:=hp;
hp:=thp;
end;
p:=chp;
cargs:=true;
cargswap:=true;
end;
end;
calcregisters(p,0,0,0);
{ looks a little bit dangerous to me }
{ len-1 gives problems with is_open_array if len=0, }
{ is_open_array checks now for isconstructor (FK) }
{ if no type is set then we set the type to voiddef to overcome a
0 addressing }
if not assigned(pd) then
pd:=voiddef;
{ skip if already done ! (PM) }
if not assigned(resulttype) or
(resulttype^.deftype<>arraydef) or
not parraydef(resulttype)^.IsConstructor or
(parraydef(resulttype)^.lowrange<>0) or
(parraydef(resulttype)^.highrange<>len-1) then
resulttype:=new(parraydef,init(0,len-1,s32bitdef));
parraydef(resulttype)^.elementtype.def:=pd;
parraydef(resulttype)^.IsConstructor:=true;
parraydef(resulttype)^.IsVariant:=varia;
location.loc:=LOC_MEM;
end;
{*****************************************************************************
TTYPENODE
*****************************************************************************}
constructor ttypenode.create(t : pdef;sym:ptypesym);
begin
inherited create(typen);
resulttype:=generrordef;
typenodetype:=t;
typenodesym:=sym;
end;
function ttypenode.getcopy : tnode;
var
n : ttypenode;
begin
n:=ttypenode(inherited getcopy);
n.typenodetype:=typenodetype;
n.typenodesym:=typenodesym;
end;
function ttypenode.pass_1 : tnode;
begin
pass_1:=nil;
{ do nothing, resulttype is already set }
end;
begin
cloadnode:=tloadnode;
cassignmentnode:=tassignmentnode;
cfuncretnode:=tfuncretnode;
carrayconstructorrangenode:=tarrayconstructorrangenode;
carrayconstructnode:=tarrayconstructnode;
ctypenode:=ttypenode;
end.
{
$Log$
Revision 1.1 2000-09-25 14:55:05 florian
* initial revision
}