{ $Id$ Copyright (c) 2000 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 defines.inc} interface uses node, symtype,symdef,symsym,symtable, cpubase; type tloadvmtnode = class(tunarynode) constructor create(l : tnode);virtual; function pass_1 : tnode;override; end; thnewnode = class(tnode) constructor create;virtual; function pass_1 : tnode;override; end; tnewnode = class(tunarynode) constructor create(l : tnode);virtual; function pass_1 : tnode;override; end; thdisposenode = class(tunarynode) constructor create(l : tnode);virtual; function pass_1 : tnode;override; end; tsimplenewdisposenode = class(tunarynode) constructor create(n : tnodetype;l : tnode); function pass_1 : tnode;override; end; taddrnode = class(tunarynode) constructor create(l : tnode);virtual; function pass_1 : tnode;override; end; tdoubleaddrnode = class(tunarynode) constructor create(l : tnode);virtual; function pass_1 : tnode;override; end; tderefnode = class(tunarynode) constructor create(l : tnode);virtual; function pass_1 : tnode;override; end; tsubscriptnode = class(tunarynode) vs : pvarsym; constructor create(varsym : psym;l : tnode);virtual; function getcopy : tnode;override; function pass_1 : tnode;override; function docompare(p: tnode): boolean; override; end; tvecnode = class(tbinarynode) constructor create(l,r : tnode);virtual; function pass_1 : tnode;override; end; tselfnode = class(tnode) constructor create(_class : pdef);virtual; function pass_1 : tnode;override; end; twithnode = class(tbinarynode) withsymtable : pwithsymtable; tablecount : longint; withreference:preference; constructor create(symtable : pwithsymtable;l,r : tnode;count : longint);virtual; destructor destroy;override; function getcopy : tnode;override; function pass_1 : tnode;override; function docompare(p: tnode): boolean; override; end; function gensubscriptnode(varsym : pvarsym;l : tnode) : tsubscriptnode; function genselfnode(_class : pdef) : tselfnode; function genwithnode(symtable:pwithsymtable;l,r : tnode;count : longint) : twithnode; var cloadvmtnode : class of tloadvmtnode; chnewnode : class of thnewnode; cnewnode : class of tnewnode; chdisposenode : class of thdisposenode; csimplenewdisposenode : class of tsimplenewdisposenode; caddrnode : class of taddrnode; cdoubleaddrnode : class of tdoubleaddrnode; cderefnode : class of tderefnode; csubscriptnode : class of tsubscriptnode; cvecnode : class of tvecnode; cselfnode : class of tselfnode; cwithnode : class of twithnode; implementation uses globtype,systems, cutils,verbose,globals, symconst,symbase,types, htypechk,pass_1,ncal,nld,ncon,ncnv {$ifdef newcg} ,cgbase {$else newcg} ,hcodegen {$endif newcg} ; function genselfnode(_class : pdef) : tselfnode; begin genselfnode:=cselfnode.create(_class); end; function genwithnode(symtable : pwithsymtable;l,r : tnode;count : longint) : twithnode; begin genwithnode:=cwithnode.create(symtable,l,r,count); end; function gensubscriptnode(varsym : pvarsym;l : tnode) : tsubscriptnode; begin gensubscriptnode:=csubscriptnode.create(varsym,l); end; {***************************************************************************** TLOADVMTNODE *****************************************************************************} constructor tloadvmtnode.create(l : tnode); begin inherited create(loadvmtn,l); end; function tloadvmtnode.pass_1 : tnode; begin pass_1:=nil; registers32:=1; location.loc:=LOC_REGISTER; end; {***************************************************************************** THNEWNODE *****************************************************************************} constructor thnewnode.create; begin inherited create(hnewn); end; function thnewnode.pass_1 : tnode; begin pass_1:=nil; end; {***************************************************************************** TNEWNODE *****************************************************************************} constructor tnewnode.create(l : tnode); begin inherited create(newn,l); end; function tnewnode.pass_1 : tnode; begin pass_1:=nil; if assigned(left) then firstpass(left); if codegenerror then exit; if assigned(left) then begin registers32:=left.registers32; registersfpu:=left.registersfpu; {$ifdef SUPPORT_MMX} registersmmx:=left.registersmmx; {$endif SUPPORT_MMX} end; { result type is already set } procinfo^.flags:=procinfo^.flags or pi_do_call; if assigned(left) then location.loc:=LOC_REGISTER else location.loc:=LOC_REFERENCE; end; {***************************************************************************** THDISPOSENODE *****************************************************************************} constructor thdisposenode.create(l : tnode); begin inherited create(hdisposen,l); end; function thdisposenode.pass_1 : tnode; begin pass_1:=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; resulttype:=ppointerdef(left.resulttype)^.pointertype.def; end; {***************************************************************************** TSIMPLENEWDISPOSENODE *****************************************************************************} constructor tsimplenewdisposenode.create(n : tnodetype;l : tnode); begin inherited create(n,l); end; function tsimplenewdisposenode.pass_1 : tnode; begin pass_1:=nil; { this cannot be in a register !! } make_not_regable(left); firstpass(left); if codegenerror then exit; { check the type } if left.resulttype=nil then left.resulttype:=generrordef; if (left.resulttype^.deftype<>pointerdef) then CGMessage1(type_e_pointer_type_expected,left.resulttype^.typename); if (left.location.loc<>LOC_REFERENCE) {and (left.location.loc<>LOC_CREGISTER)} then CGMessage(cg_e_illegal_expression); registers32:=left.registers32; registersfpu:=left.registersfpu; {$ifdef SUPPORT_MMX} registersmmx:=left.registersmmx; {$endif SUPPORT_MMX} resulttype:=voiddef; procinfo^.flags:=procinfo^.flags or pi_do_call; end; {***************************************************************************** TADDRNODE *****************************************************************************} constructor taddrnode.create(l : tnode); begin inherited create(addrn,l); end; function taddrnode.pass_1 : tnode; var hp : tnode; hp2 : TParaItem; hp3 : pabstractprocdef; begin pass_1:=nil; make_not_regable(left); if not(assigned(resulttype)) then begin { 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 hp:=left; case hp.nodetype of calln : begin { is it a procvar? } hp:=tcallnode(hp).right; if assigned(hp) then begin { remove calln node } tcallnode(left).right:=nil; left.free; { first do firstpass, then assignment in case hp } { gets changed by firstpass (JM) } firstpass(hp); left:=hp; include(flags,nf_procvarload); end; end; loadn, subscriptn, typeconvn, vecn, derefn : begin firstpass(hp); { in case hp gets changed by firstpass (JM) } left := hp; if codegenerror then exit; if hp.resulttype^.deftype=procvardef then include(flags,nf_procvarload); end; end; end; 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; resulttype:=voidpointerdef; exit; end; { proc 2 procvar ? } if left.nodetype=calln then begin { generate a methodcallnode or proccallnode } { we shouldn't convert things like @tcollection.load } if (tcallnode(left).symtableprocentry^.owner^.symtabletype=objectsymtable) and not(assigned(tcallnode(left).methodpointer) and (tcallnode(left).methodpointer.nodetype=typen)) then begin hp:=genloadmethodcallnode(pprocsym(tcallnode(left).symtableprocentry),tcallnode(left).symtableproc, tcallnode(left).methodpointer.getcopy); firstpass(hp); pass_1:=hp; exit; end else hp:=genloadcallnode(pprocsym(tcallnode(left).symtableprocentry), tcallnode(left).symtableproc); { result is a procedure variable } { No, to be TP compatible, you must return a pointer to the procedure that is stored in the procvar.} if not(m_tp_procvar in aktmodeswitches) then begin resulttype:=new(pprocvardef,init); { it could also be a procvar, not only pprocsym ! } if tcallnode(left).symtableprocentry^.typ=varsym then hp3:=pabstractprocdef(pvarsym(tcallnode(left).symtableprocentry)^.vartype.def) else hp3:=pabstractprocdef(pprocsym(tcallnode(left).symtableprocentry)^.definition); pprocvardef(resulttype)^.proctypeoption:=hp3^.proctypeoption; pprocvardef(resulttype)^.proccalloptions:=hp3^.proccalloptions; pprocvardef(resulttype)^.procoptions:=hp3^.procoptions; pprocvardef(resulttype)^.rettype:=hp3^.rettype; pprocvardef(resulttype)^.symtablelevel:=hp3^.symtablelevel; { method ? then set the methodpointer flag } if (hp3^.owner^.symtabletype=objectsymtable) and is_class(pdef(hp3^.owner^.defowner)) then include(pprocvardef(resulttype)^.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 pprocvardef(resulttype)^.concatpara(hp2.paratype,hp2.paratyp,hp2.defaultvalue); hp2:=TParaItem(hp2.previous); end; end else resulttype:=voidpointerdef; left.free; left:=hp; end else begin firstpass(left); { 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 pabsolutesym(tloadnode(hp).symtableentry)^.absseg) then begin if not(cs_typed_addresses in aktlocalswitches) then resulttype:=voidfarpointerdef else resulttype:=new(ppointerdef,initfardef(left.resulttype)); end else begin if not(cs_typed_addresses in aktlocalswitches) then resulttype:=voidpointerdef else resulttype:=new(ppointerdef,initdef(left.resulttype)); end; end; end; firstpass(left); { this is like the function addr } inc(parsing_para_level); set_varstate(left,false); dec(parsing_para_level); if codegenerror then exit; { don't allow constants } if is_constnode(left) then begin aktfilepos:=left.fileinfo; CGMessage(type_e_no_addr_of_constant); end else begin { we should allow loc_mem for @string } if not(left.location.loc in [LOC_MEM,LOC_REFERENCE]) then begin aktfilepos:=left.fileinfo; CGMessage(cg_e_illegal_expression); end; 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.pass_1 : tnode; begin pass_1:=nil; make_not_regable(left); firstpass(left); inc(parsing_para_level); set_varstate(left,false); dec(parsing_para_level); if resulttype=nil then resulttype:=voidpointerdef; if codegenerror then exit; if (left.resulttype^.deftype)<>procvardef then CGMessage(cg_e_illegal_expression); 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.pass_1 : tnode; begin pass_1:=nil; firstpass(left); set_varstate(left,true); if codegenerror then begin resulttype:=generrordef; exit; end; registers32:=max(left.registers32,1); registersfpu:=left.registersfpu; {$ifdef SUPPORT_MMX} registersmmx:=left.registersmmx; {$endif SUPPORT_MMX} if left.resulttype^.deftype<>pointerdef then CGMessage(cg_e_invalid_qualifier); resulttype:=ppointerdef(left.resulttype)^.pointertype.def; location.loc:=LOC_REFERENCE; end; {***************************************************************************** TSUBSCRIPTNODE *****************************************************************************} constructor tsubscriptnode.create(varsym : psym;l : tnode); begin inherited create(subscriptn,l); { vs should be changed to psym! } vs:=pvarsym(varsym); end; function tsubscriptnode.getcopy : tnode; var p : tsubscriptnode; begin p:=tsubscriptnode(inherited getcopy); p.vs:=vs; getcopy:=p; end; function tsubscriptnode.pass_1 : tnode; begin pass_1:=nil; firstpass(left); if codegenerror then begin resulttype:=generrordef; exit; end; resulttype:=vs^.vartype.def; 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) then begin if registers32=0 then registers32:=1; location.loc:=LOC_REFERENCE; end else begin if (left.location.loc<>LOC_MEM) and (left.location.loc<>LOC_REFERENCE) then CGMessage(cg_e_illegal_expression); set_location(location,left.location); 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.pass_1 : tnode; var harr : pdef; ct : tconverttype; {$ifdef consteval} tcsym : ptypedconstsym; {$endif} begin pass_1:=nil; firstpass(left); firstpass(right); if codegenerror then exit; { range check only for arrays } if (left.resulttype^.deftype=arraydef) then begin if (isconvertable(right.resulttype,parraydef(left.resulttype)^.rangetype.def, ct,nil,ordconstn,false)=0) and not(is_equal(right.resulttype,parraydef(left.resulttype)^.rangetype.def)) then CGMessage(type_e_mismatch); end; { Never convert a boolean or a char !} { maybe type conversion } if (right.resulttype^.deftype<>enumdef) and not(is_char(right.resulttype)) and not(is_boolean(right.resulttype)) then begin right:=gentypeconvnode(right,s32bitdef); firstpass(right); if codegenerror then exit; 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^.deftype=pointerdef) and ((m_fpc in aktmodeswitches) or is_pchar(left.resulttype)) then begin { convert pointer to array } harr:=new(parraydef,init(0,$7fffffff,s32bitdef)); parraydef(harr)^.elementtype.def:=ppointerdef(left.resulttype)^.pointertype.def; left:=gentypeconvnode(left,harr); firstpass(left); if codegenerror then exit; resulttype:=parraydef(harr)^.elementtype.def end; { determine return type } if not assigned(resulttype) then if left.resulttype^.deftype=arraydef then resulttype:=parraydef(left.resulttype)^.elementtype.def else if left.resulttype^.deftype=stringdef then begin { indexed access to strings } case pstringdef(left.resulttype)^.string_typ of { st_widestring : resulttype:=cwchardef; } st_ansistring : resulttype:=cchardef; st_longstring : resulttype:=cchardef; st_shortstring : resulttype:=cchardef; end; end else CGMessage(type_e_array_required); { 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:=ptypedconstsym(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) or is_widestring(left.resulttype) or { ... as well as for dynamic arrays } is_dynamic_array(left.resulttype) 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) or is_widestring(left.resulttype) or { ... as well as for dynamic arrays } is_dynamic_array(left.resulttype) 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_MEM; end; {***************************************************************************** TSELFNODE *****************************************************************************} constructor tselfnode.create(_class : pdef); begin inherited create(selfn); resulttype:=_class; end; function tselfnode.pass_1 : tnode; begin pass_1:=nil; if (resulttype^.deftype=classrefdef) or is_class(resulttype) then location.loc:=LOC_CREGISTER else location.loc:=LOC_REFERENCE; end; {***************************************************************************** TWITHNODE *****************************************************************************} constructor twithnode.create(symtable : pwithsymtable;l,r : tnode;count : longint); begin inherited create(withn,l,r); withsymtable:=symtable; tablecount:=count; withreference:=nil; set_file_line(l); end; destructor twithnode.destroy; var symt : psymtable; i : longint; begin symt:=withsymtable; for i:=1 to tablecount do begin if assigned(symt) then begin withsymtable:=pwithsymtable(symt^.next); dispose(symt,done); end; symt:=withsymtable; end; inherited destroy; 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.pass_1 : tnode; var symtable : pwithsymtable; i : longint; begin pass_1:=nil; if assigned(left) and assigned(right) then begin firstpass(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=aktprocsym^.definition^.localst) then symtable^.direct_with:=true; symtable^.withnode:=self; symtable:=pwithsymtable(symtable^.next); end; firstpass(right); if codegenerror then exit; left_right_max; resulttype:=voiddef; end else begin { optimization } pass_1:=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; cnewnode := tnewnode; chdisposenode := thdisposenode; csimplenewdisposenode := tsimplenewdisposenode; caddrnode := taddrnode; cdoubleaddrnode := tdoubleaddrnode; cderefnode := tderefnode; csubscriptnode := tsubscriptnode; cvecnode := tvecnode; cselfnode := tselfnode; cwithnode := twithnode; end. { $Log$ Revision 1.14 2000-12-31 11:14:11 jonas + implemented/fixed docompare() mathods for all nodes (not tested) + nopt.pas, nadd.pas, i386/n386opt.pas: optimized nodes for adding strings and constant strings/chars together * n386add.pas: don't copy temp strings (of size 256) to another temp string when adding Revision 1.13 2000/12/25 00:07:26 peter + new tlinkedlist class (merge of old tstringqueue,tcontainer and tlinkedlist objects) Revision 1.12 2000/12/05 15:19:50 jonas * fixed webbug 1268 ("merged") Revision 1.11 2000/11/29 00:30:34 florian * unused units removed from uses clause * some changes for widestrings Revision 1.10 2000/11/04 14:25:20 florian + merged Attila's changes for interfaces, not tested yet Revision 1.9 2000/10/31 22:02:49 peter * symtable splitted, no real code changes Revision 1.8 2000/10/21 18:16:11 florian * a lot of changes: - basic dyn. array support - basic C++ support - some work for interfaces done .... Revision 1.7 2000/10/14 21:52:55 peter * fixed memory leaks Revision 1.6 2000/10/14 10:14:51 peter * moehrendorf oct 2000 rewrite Revision 1.5 2000/10/01 19:48:24 peter * lot of compile updates for cg11 Revision 1.4 2000/09/28 19:49:52 florian *** empty log message *** Revision 1.3 2000/09/25 15:37:14 florian * more fixes Revision 1.2 2000/09/25 15:05:25 florian * some updates Revision 1.1 2000/09/25 09:58:22 florian * first revision for testing purpose }