paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-21 19:05:16 +02:00
Code Issues Packages Projects Releases Wiki Activity
3c6fde4acc
fpc/compiler/nutils.pas
paul 56bf42de57 compiler: implement record methods and class methods: 
- rename tprocdef._class to tprocdef.struct and change the type from tobjectdef to tabstractrecorddef because methods can belong not to classes only now but to records too
  - replace in many places use of current_objectdef to current_structdef with typcast where is needed
  - add an argument to comp_expr, expr, factor, sub_expr to notify that we are searching type only symbol to solve the problem with records,objects,classes which contains fields with the same name as previosly declared type (like:
  HWND = type Handle;
  rec = record 
    hWnd: HWND;
  end;)
  - disable check in factor_read_id which was made for object that only static fields can be accessed as TObjectType.FieldName outside the object because it makes SizeOf(TObjectType.FieldName) imposible and since the same method was extended to handle records it also breaks a52 package compilation
  - rename tcallcandidates.collect_overloads_in_class to tcallcandidates.collect_overloads_in_struct and addapt the code to handle overloads in records too
  - fix searchsym_type to search also in object ancestors if we found an object symtable
  - add pd_record, pd_notrecord flags to mark procedure modifies which can or can't be used with records. Disallow the next modifiers for records: abstract, dynamic, export, external, far, far16, final, forward, internconst, internproc, interrupt, message, near, override, public, reintroduce, virtual, weakexternal,
Allow the next modifiers for records: static

git-svn-id: branches/paul/extended_records@16526 -
2010-12-09 02:24:46 +00:00

1217 lines
41 KiB
ObjectPascal
Raw Blame History

{
Copyright (c) 1998-2002 by Florian Klaempfl
Type checking and register allocation for inline 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 nutils;
{$i fpcdefs.inc}
interface
uses
globtype,constexp,
symtype,symsym,symbase,symtable,
node;
const
NODE_COMPLEXITY_INF = 255;
type
{ resultdef of functions that process on all nodes in a (sub)tree }
foreachnoderesult = (
{ false, continue recursion }
fen_false,
{ false, stop recursion }
fen_norecurse_false,
{ true, continue recursion }
fen_true,
{ true, stop recursion }
fen_norecurse_true
);
tforeachprocmethod = (pm_preprocess,pm_postprocess,
pm_postandagain);
foreachnodefunction = function(var n: tnode; arg: pointer): foreachnoderesult of object;
staticforeachnodefunction = function(var n: tnode; arg: pointer): foreachnoderesult;
function foreachnode(var n: tnode; f: foreachnodefunction; arg: pointer): boolean;
function foreachnode(procmethod : tforeachprocmethod; var n: tnode; f: foreachnodefunction; arg: pointer): boolean;
function foreachnodestatic(var n: tnode; f: staticforeachnodefunction; arg: pointer): boolean;
function foreachnodestatic(procmethod : tforeachprocmethod; var n: tnode; f: staticforeachnodefunction; arg: pointer): boolean;
{ checks if the given node tree contains only nodes of the given type,
if this isn't the case, an ie is thrown
}
procedure checktreenodetypes(n : tnode;typeset : tnodetypeset);
procedure load_procvar_from_calln(var p1:tnode);
function maybe_call_procvar(var p1:tnode;tponly:boolean):boolean;
function get_high_value_sym(vs: tparavarsym):tsym; { marking it as inline causes IE 200311075 during loading from ppu file }
function load_high_value_node(vs:tparavarsym):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;
function call_fail_node:tnode;
function initialize_data_node(p:tnode):tnode;
function finalize_data_node(p:tnode):tnode;
function node_complexity(p: tnode): cardinal;
function node_resources_fpu(p: tnode): cardinal;
procedure node_tree_set_filepos(var n:tnode;const filepos:tfileposinfo);
{ tries to simplify the given node after inlining }
procedure doinlinesimplify(var n : tnode);
{ creates an ordinal constant, optionally based on the result from a
simplify operation: normally the type is the smallest integer type
that can hold the value, but when inlining the "def" will be used instead,
which was determined during an earlier typecheck pass (because the value
may e.g. be a parameter to a call, which needs to be of the declared
parameter type) }
function create_simplified_ord_const(value: tconstexprint; def: tdef; forinline: boolean): tnode;
{ returns true if n is only a tree of administrative nodes
containing no code }
function has_no_code(n : tnode) : boolean;
function getpropaccesslist(propsym:tpropertysym; pap:tpropaccesslisttypes;out propaccesslist:tpropaccesslist):boolean;
procedure propaccesslist_to_node(var p1:tnode;st:TSymtable;pl:tpropaccesslist);
function node_to_propaccesslist(p1:tnode):tpropaccesslist;
{ returns true if n is an array element access of a bitpacked array with
elements of the which the vitsize mod 8 <> 0, or if is a field access
with bitsize mod 8 <> 0 or bitoffset mod 8 <> 0 of an element in a
bitpacked structure }
function is_bitpacked_access(n: tnode): boolean;
{ creates a load of field 'fieldname' in the record/class/...
represented by n }
function genloadfield(n: tnode; const fieldname: string): tnode;
implementation
uses
cutils,verbose,globals,
symconst,symdef,
defutil,defcmp,
nbas,ncon,ncnv,nld,nflw,nset,ncal,nadd,nmem,ninl,
cpubase,cgbase,procinfo,
pass_1;
function foreachnode(procmethod : tforeachprocmethod;var n: tnode; f: foreachnodefunction; arg: pointer): boolean;
function process_children(res : boolean) : boolean;
var
i: longint;
begin
result:=res;
case n.nodetype of
asn:
if assigned(tasnode(n).call) then
begin
result := foreachnode(procmethod,tasnode(n).call,f,arg);
exit
end;
calln:
begin
result := foreachnode(procmethod,tnode(tcallnode(n).callinitblock),f,arg) or result;
result := foreachnode(procmethod,tcallnode(n).methodpointer,f,arg) or result;
result := foreachnode(procmethod,tcallnode(n).funcretnode,f,arg) or result;
result := foreachnode(procmethod,tnode(tcallnode(n).callcleanupblock),f,arg) or result;
end;
ifn, whilerepeatn, forn, tryexceptn, tryfinallyn:
begin
{ not in one statement, won't work because of b- }
result := foreachnode(procmethod,tloopnode(n).t1,f,arg) or result;
result := foreachnode(procmethod,tloopnode(n).t2,f,arg) or result;
end;
raisen:
{ frame tree }
result := foreachnode(traisenode(n).third,f,arg) or result;
tempcreaten:
{ temp. initialization code }
if assigned(ttempcreatenode(n).tempinfo^.tempinitcode) then
result := foreachnode(ttempcreatenode(n).tempinfo^.tempinitcode,f,arg) or result;
casen:
begin
for i := 0 to tcasenode(n).blocks.count-1 do
if assigned(tcasenode(n).blocks[i]) then
result := foreachnode(procmethod,pcaseblock(tcasenode(n).blocks[i])^.statement,f,arg) or result;
result := foreachnode(procmethod,tcasenode(n).elseblock,f,arg) or result;
end;
end;
if n.inheritsfrom(tbinarynode) then
begin
{ first process the "payload" of statementnodes }
result := foreachnode(procmethod,tbinarynode(n).left,f,arg) or result;
result := foreachnode(procmethod,tbinarynode(n).right,f,arg) or result;
end
else if n.inheritsfrom(tunarynode) then
result := foreachnode(procmethod,tunarynode(n).left,f,arg) or result;
end;
begin
result := false;
if not assigned(n) then
exit;
if procmethod=pm_preprocess then
result:=process_children(result);
case f(n,arg) of
fen_norecurse_false:
exit;
fen_norecurse_true:
begin
result := true;
exit;
end;
fen_true:
result := true;
{ result is already false
fen_false:
result := false; }
end;
if (procmethod=pm_postprocess) or (procmethod=pm_postandagain) then
result:=process_children(result);
if procmethod=pm_postandagain then
begin
case f(n,arg) of
fen_norecurse_false:
exit;
fen_norecurse_true:
begin
result := true;
exit;
end;
fen_true:
result := true;
end;
end;
end;
function foreachnode(var n: tnode; f: foreachnodefunction; arg: pointer): boolean;
begin
result:=foreachnode(pm_postprocess,n,f,arg);
end;
function foreachnodestatic(procmethod : tforeachprocmethod;var n: tnode; f: staticforeachnodefunction; arg: pointer): boolean;
function process_children(res : boolean) : boolean;
var
i: longint;
begin
result:=res;
case n.nodetype of
asn:
if assigned(tasnode(n).call) then
begin
result := foreachnodestatic(procmethod,tasnode(n).call,f,arg);
exit
end;
calln:
begin
result := foreachnodestatic(procmethod,tnode(tcallnode(n).callinitblock),f,arg) or result;
result := foreachnodestatic(procmethod,tcallnode(n).methodpointer,f,arg) or result;
result := foreachnodestatic(procmethod,tcallnode(n).funcretnode,f,arg) or result;
result := foreachnodestatic(procmethod,tnode(tcallnode(n).callcleanupblock),f,arg) or result;
end;
ifn, whilerepeatn, forn, tryexceptn, tryfinallyn:
begin
{ not in one statement, won't work because of b- }
result := foreachnodestatic(procmethod,tloopnode(n).t1,f,arg) or result;
result := foreachnodestatic(procmethod,tloopnode(n).t2,f,arg) or result;
end;
raisen:
{ frame tree }
result := foreachnodestatic(traisenode(n).third,f,arg) or result;
tempcreaten:
{ temp. initialization code }
if assigned(ttempcreatenode(n).tempinfo^.tempinitcode) then
result := foreachnodestatic(ttempcreatenode(n).tempinfo^.tempinitcode,f,arg) or result;
casen:
begin
for i := 0 to tcasenode(n).blocks.count-1 do
if assigned(tcasenode(n).blocks[i]) then
result := foreachnodestatic(procmethod,pcaseblock(tcasenode(n).blocks[i])^.statement,f,arg) or result;
result := foreachnodestatic(procmethod,tcasenode(n).elseblock,f,arg) or result;
end;
end;
if n.inheritsfrom(tbinarynode) then
begin
{ first process the "payload" of statementnodes }
result := foreachnodestatic(procmethod,tbinarynode(n).left,f,arg) or result;
result := foreachnodestatic(procmethod,tbinarynode(n).right,f,arg) or result;
end
else if n.inheritsfrom(tunarynode) then
result := foreachnodestatic(procmethod,tunarynode(n).left,f,arg) or result;
end;
begin
result := false;
if not assigned(n) then
exit;
if procmethod=pm_preprocess then
result:=process_children(result);
case f(n,arg) of
fen_norecurse_false:
exit;
fen_norecurse_true:
begin
result := true;
exit;
end;
fen_true:
result := true;
{ result is already false
fen_false:
result := false; }
end;
if (procmethod=pm_postprocess) or (procmethod=pm_postandagain) then
result:=process_children(result);
if procmethod=pm_postandagain then
begin
case f(n,arg) of
fen_norecurse_false:
exit;
fen_norecurse_true:
begin
result := true;
exit;
end;
fen_true:
result := true;
end;
end;
end;
function foreachnodestatic(var n: tnode; f: staticforeachnodefunction; arg: pointer): boolean;
begin
result:=foreachnodestatic(pm_postprocess,n,f,arg);
end;
function do_check(var n: tnode; arg: pointer): foreachnoderesult;
begin
if not(n.nodetype in pnodetypeset(arg)^) then
internalerror(200610141);
result:=fen_true;
end;
procedure checktreenodetypes(n : tnode;typeset : tnodetypeset);
begin
foreachnodestatic(n,@do_check,@typeset);
end;
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
tloadnode(p2).set_mp(tcallnode(p1).methodpointer.getcopy);
end;
typecheckpass(p2);
p1.free;
p1:=p2;
end;
function maybe_call_procvar(var p1:tnode;tponly:boolean):boolean;
var
hp : tnode;
begin
result:=false;
if (p1.resultdef.typ<>procvardef) or
(tponly and
not(m_tp_procvar in current_settings.modeswitches)) then
exit;
{ ignore vecn,subscriptn }
hp:=p1;
repeat
case hp.nodetype of
vecn,
derefn,
typeconvn,
subscriptn :
hp:=tunarynode(hp).left;
else
break;
end;
until false;
{ a tempref is used when it is loaded from a withsymtable }
if (hp.nodetype in [calln,loadn,temprefn]) then
begin
hp:=ccallnode.create_procvar(nil,p1);
typecheckpass(hp);
p1:=hp;
result:=true;
end;
end;
function get_high_value_sym(vs: tparavarsym):tsym;
begin
result := tsym(vs.owner.Find('high'+vs.name));
end;
function get_local_or_para_sym(const aname:string):tsym;
var
pd : tprocdef;
begin
result:=nil;
{ is not assigned while parsing a property }
if not assigned(current_procinfo) then
exit;
{ we can't use searchsym here, because the
symtablestack is not fully setup when pass1
is run for nested procedures }
pd:=current_procinfo.procdef;
repeat
result := tsym(pd.localst.Find(aname));
if assigned(result) then
break;
result := tsym(pd.parast.Find(aname));
if assigned(result) then
break;
{ try the parent of a nested function }
if assigned(pd.owner.defowner) and
(pd.owner.defowner.typ=procdef) then
pd:=tprocdef(pd.owner.defowner)
else
break;
until false;
end;
function load_high_value_node(vs:tparavarsym):tnode;
var
srsym : tsym;
begin
result:=nil;
srsym:=get_high_value_sym(vs);
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,vs.owner);
typecheckpass(result);
end
else
CGMessage(parser_e_illegal_expression);
end;
function load_self_node:tnode;
var
srsym : tsym;
begin
result:=nil;
srsym:=get_local_or_para_sym('self');
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,srsym.owner);
include(result.flags,nf_is_self);
end
else
begin
result:=cerrornode.create;
CGMessage(parser_e_illegal_expression);
end;
typecheckpass(result);
end;
function load_result_node:tnode;
var
srsym : tsym;
begin
result:=nil;
srsym:=get_local_or_para_sym('result');
if assigned(srsym) then
result:=cloadnode.create(srsym,srsym.owner)
else
begin
result:=cerrornode.create;
CGMessage(parser_e_illegal_expression);
end;
typecheckpass(result);
end;
function load_self_pointer_node:tnode;
var
srsym : tsym;
begin
result:=nil;
srsym:=get_local_or_para_sym('self');
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,srsym.owner);
include(result.flags,nf_load_self_pointer);
end
else
begin
result:=cerrornode.create;
CGMessage(parser_e_illegal_expression);
end;
typecheckpass(result);
end;
function load_vmt_pointer_node:tnode;
var
srsym : tsym;
begin
result:=nil;
srsym:=get_local_or_para_sym('vmt');
if assigned(srsym) then
result:=cloadnode.create(srsym,srsym.owner)
else
begin
result:=cerrornode.create;
CGMessage(parser_e_illegal_expression);
end;
typecheckpass(result);
end;
function is_self_node(p:tnode):boolean;
begin
is_self_node:=(p.nodetype=loadn) and
(tloadnode(p).symtableentry.typ=paravarsym) and
(vo_is_self in tparavarsym(tloadnode(p).symtableentry).varoptions);
end;
function call_fail_node:tnode;
var
para : tcallparanode;
newstatement : tstatementnode;
srsym : tsym;
begin
result:=internalstatements(newstatement);
{ call fail helper and exit normal }
if is_class(current_structdef) then
begin
srsym:=search_struct_member(current_objectdef,'FREEINSTANCE');
if assigned(srsym) and
(srsym.typ=procsym) then
begin
{ if self<>0 and vmt<>0 then freeinstance }
addstatement(newstatement,cifnode.create(
caddnode.create(andn,
caddnode.create(unequaln,
load_self_pointer_node,
cnilnode.create),
caddnode.create(unequaln,
load_vmt_pointer_node,
cnilnode.create)),
ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
nil));
end
else
internalerror(200305108);
end
else
if is_object(current_structdef) then
begin
{ parameter 3 : vmt_offset }
{ parameter 2 : pointer to vmt }
{ parameter 1 : self pointer }
para:=ccallparanode.create(
cordconstnode.create(current_objectdef.vmt_offset,s32inttype,false),
ccallparanode.create(
ctypeconvnode.create_internal(
load_vmt_pointer_node,
voidpointertype),
ccallparanode.create(
ctypeconvnode.create_internal(
load_self_pointer_node,
voidpointertype),
nil)));
addstatement(newstatement,
ccallnode.createintern('fpc_help_fail',para));
end
else
internalerror(200305132);
{ self:=nil }
addstatement(newstatement,cassignmentnode.create(
load_self_pointer_node,
cnilnode.create));
{ exit }
addstatement(newstatement,cexitnode.create(nil));
end;
function initialize_data_node(p:tnode):tnode;
begin
if not assigned(p.resultdef) then
typecheckpass(p);
if is_ansistring(p.resultdef) or
is_wide_or_unicode_string(p.resultdef) or
is_interfacecom(p.resultdef) or
is_dynamic_array(p.resultdef) then
begin
result:=cassignmentnode.create(
ctypeconvnode.create_internal(p,voidpointertype),
cnilnode.create
);
end
else
begin
result:=ccallnode.createintern('fpc_initialize',
ccallparanode.create(
caddrnode.create_internal(
crttinode.create(
tstoreddef(p.resultdef),initrtti,rdt_normal)),
ccallparanode.create(
caddrnode.create_internal(p),
nil)));
end;
end;
function finalize_data_node(p:tnode):tnode;
var
newstatement : tstatementnode;
begin
if not assigned(p.resultdef) then
typecheckpass(p);
if is_ansistring(p.resultdef) then
begin
result:=internalstatements(newstatement);
addstatement(newstatement,ccallnode.createintern('fpc_ansistr_decr_ref',
ccallparanode.create(
ctypeconvnode.create_internal(p,voidpointertype),
nil)));
addstatement(newstatement,cassignmentnode.create(
ctypeconvnode.create_internal(p.getcopy,voidpointertype),
cnilnode.create
));
end
else if is_widestring(p.resultdef) then
begin
result:=internalstatements(newstatement);
addstatement(newstatement,ccallnode.createintern('fpc_widestr_decr_ref',
ccallparanode.create(
ctypeconvnode.create_internal(p,voidpointertype),
nil)));
addstatement(newstatement,cassignmentnode.create(
ctypeconvnode.create_internal(p.getcopy,voidpointertype),
cnilnode.create
));
end
else if is_unicodestring(p.resultdef) then
begin
result:=internalstatements(newstatement);
addstatement(newstatement,ccallnode.createintern('fpc_unicodestr_decr_ref',
ccallparanode.create(
ctypeconvnode.create_internal(p,voidpointertype),
nil)));
addstatement(newstatement,cassignmentnode.create(
ctypeconvnode.create_internal(p.getcopy,voidpointertype),
cnilnode.create
));
end
else if is_interfacecom(p.resultdef) then
begin
result:=internalstatements(newstatement);
addstatement(newstatement,ccallnode.createintern('fpc_intf_decr_ref',
ccallparanode.create(
ctypeconvnode.create_internal(p,voidpointertype),
nil)));
addstatement(newstatement,cassignmentnode.create(
ctypeconvnode.create_internal(p.getcopy,voidpointertype),
cnilnode.create
));
end
else
result:=ccallnode.createintern('fpc_finalize',
ccallparanode.create(
caddrnode.create_internal(
crttinode.create(
tstoreddef(p.resultdef),initrtti,rdt_normal)),
ccallparanode.create(
caddrnode.create_internal(p),
nil)));
end;
{ this function must return a very high value ("infinity") for }
{ trees containing a call, the rest can be balanced more or less }
{ at will, probably best mainly in terms of required memory }
{ accesses }
function node_complexity(p: tnode): cardinal;
var
correction: byte;
{$ifdef ARM}
dummy : byte;
{$endif ARM}
begin
result := 0;
while assigned(p) do
begin
case p.nodetype of
{ floating point constants usually need loading from memory }
realconstn,
temprefn,
loadvmtaddrn,
{ main reason for the next one: we can't take the address of }
{ loadparentfpnode, so replacing it by a temp which is the }
{ address of this node's location and then dereferencing }
{ doesn't work. If changed, check whether webtbs/tw0935 }
{ still works with nodeinlining (JM) }
loadparentfpn:
begin
result := 1;
exit;
end;
loadn:
begin
if assigned(tloadnode(p).left) then
inc(result,node_complexity(tloadnode(p).left));
{ threadvars need a helper call }
if (tloadnode(p).symtableentry.typ=staticvarsym) and
(vo_is_thread_var in tstaticvarsym(tloadnode(p).symtableentry).varoptions) then
inc(result,5)
else
inc(result);
if (result >= NODE_COMPLEXITY_INF) then
result := NODE_COMPLEXITY_INF;
exit;
end;
subscriptn:
begin
if is_class_or_interface_or_dispinterface_or_objc(tunarynode(p).left.resultdef) then
inc(result,2);
if (result = NODE_COMPLEXITY_INF) then
exit;
p := tunarynode(p).left;
end;
blockn,
callparan:
p := tunarynode(p).left;
notn,
derefn :
begin
inc(result);
if (result = NODE_COMPLEXITY_INF) then
exit;
p := tunarynode(p).left;
end;
typeconvn:
begin
{ may be more complex in some cases }
if not(ttypeconvnode(p).convtype in [tc_equal,tc_int_2_int,tc_bool_2_bool,tc_real_2_real,tc_cord_2_pointer]) then
inc(result);
if (result = NODE_COMPLEXITY_INF) then
exit;
p := tunarynode(p).left;
end;
vecn,
statementn:
begin
inc(result,node_complexity(tbinarynode(p).left));
if (result >= NODE_COMPLEXITY_INF) then
begin
result := NODE_COMPLEXITY_INF;
exit;
end;
p := tbinarynode(p).right;
end;
addn,subn,orn,andn,xorn,muln,divn,modn,symdifn,
shln,shrn,
equaln,unequaln,gtn,gten,ltn,lten,
assignn:
begin
{$ifdef CPU64BITALU}
correction:=1;
{$else CPU64BITALU}
correction:=2;
{$endif CPU64BITALU}
inc(result,node_complexity(tbinarynode(p).left)+1*correction);
if (p.nodetype in [muln,divn,modn]) then
inc(result,5*correction*correction);
if (result >= NODE_COMPLEXITY_INF) then
begin
result := NODE_COMPLEXITY_INF;
exit;
end;
p := tbinarynode(p).right;
end;
ordconstn:
begin
{$ifdef ARM}
if not(is_shifter_const(tordconstnode(p).value.svalue,dummy)) then
result:=2;
{$endif ARM}
exit;
end;
stringconstn,
tempcreaten,
tempdeleten,
pointerconstn,
nothingn,
niln:
exit;
inlinen:
begin
{ this code assumes that the inline node has }
{ already been firstpassed, and consequently }
{ that inline nodes which are transformed into }
{ calls already have been transformed }
case tinlinenode(p).inlinenumber of
in_lo_qword,
in_hi_qword,
in_lo_long,
in_hi_long,
in_lo_word,
in_hi_word,
in_length_x,
in_assigned_x,
in_pred_x,
in_succ_x,
in_round_real,
in_trunc_real,
in_int_real,
in_frac_real,
in_cos_real,
in_sin_real,
in_arctan_real,
in_pi_real,
in_abs_real,
in_sqr_real,
in_sqrt_real,
in_ln_real,
in_unaligned_x,
in_prefetch_var:
begin
inc(result);
p:=tunarynode(p).left;
end;
in_abs_long:
begin
inc(result,3);
if (result >= NODE_COMPLEXITY_INF) then
begin
result:=NODE_COMPLEXITY_INF;
exit;
end;
p:=tunarynode(p).left;
end;
in_sizeof_x,
in_typeof_x:
begin
inc(result);
if (tinlinenode(p).left.nodetype<>typen) then
{ get instance vmt }
p:=tunarynode(p).left
else
{ type vmt = global symbol, result is }
{ already increased above }
exit;
end;
{$ifdef SUPPORT_MMX}
in_mmx_pcmpeqb..in_mmx_pcmpgtw,
{$endif SUPPORT_MMX}
{ load from global symbol }
in_typeinfo_x,
{ load frame pointer }
in_get_frame,
in_get_caller_frame,
in_get_caller_addr:
begin
inc(result);
exit;
end;
in_inc_x,
in_dec_x,
in_include_x_y,
in_exclude_x_y,
in_assert_x_y :
begin
{ operation (add, sub, or, and }
inc(result);
{ left expression }
inc(result,node_complexity(tcallparanode(tunarynode(p).left).left));
if (result >= NODE_COMPLEXITY_INF) then
begin
result := NODE_COMPLEXITY_INF;
exit;
end;
p:=tcallparanode(tunarynode(p).left).right;
if assigned(p) then
p:=tcallparanode(p).left;
end;
else
begin
result := NODE_COMPLEXITY_INF;
exit;
end;
end;
end;
else
begin
result := NODE_COMPLEXITY_INF;
exit;
end;
end;
end;
end;
{ this function returns an indication how much fpu registers
will be required.
Note: The algorithms need to be pessimistic to prevent a
fpu stack overflow on i386 }
function node_resources_fpu(p: tnode): cardinal;
var
res1,res2,res3 : cardinal;
begin
result:=0;
res1:=0;
res2:=0;
res3:=0;
if p.inheritsfrom(tunarynode) then
begin
if assigned(tunarynode(p).left) then
res1:=node_resources_fpu(tunarynode(p).left);
if p.inheritsfrom(tbinarynode) then
begin
if assigned(tbinarynode(p).right) then
res2:=node_resources_fpu(tbinarynode(p).right);
if p.inheritsfrom(ttertiarynode) and assigned(ttertiarynode(p).third) then
res3:=node_resources_fpu(ttertiarynode(p).third)
end;
end;
result:=max(max(res1,res2),res3);
case p.nodetype of
calln:
{ it could be a recursive call, so we never really know the number of used fpu registers }
result:=maxfpuregs;
realconstn,
typeconvn,
loadn :
begin
if p.expectloc in [LOC_CFPUREGISTER,LOC_FPUREGISTER] then
result:=max(result,1);
end;
assignn,
addn,subn,muln,slashn,
equaln,unequaln,gtn,gten,ltn,lten :
begin
if (tbinarynode(p).left.expectloc in [LOC_CFPUREGISTER,LOC_FPUREGISTER]) or
(tbinarynode(p).right.expectloc in [LOC_CFPUREGISTER,LOC_FPUREGISTER])then
result:=max(result,2);
if(p.expectloc in [LOC_CFPUREGISTER,LOC_FPUREGISTER]) then
inc(result);
end;
end;
end;
function setnodefilepos(var n: tnode; arg: pointer): foreachnoderesult;
begin
result:=fen_true;
n.fileinfo:=pfileposinfo(arg)^;
end;
procedure node_tree_set_filepos(var n:tnode;const filepos:tfileposinfo);
begin
foreachnodestatic(n,@setnodefilepos,@filepos);
end;
function callsimplify(var n: tnode; arg: pointer): foreachnoderesult;
var
hn : tnode;
treechanged : ^boolean;
begin
result:=fen_false;
if n.inheritsfrom(tloopnode) and
not (lnf_simplify_processing in tloopnode(n).loopflags) then
begin
// Try to simplify condition
doinlinesimplify(tloopnode(n).left);
// call directly second part below,
// which might change the loopnode into
// something else if the conditino is a constant node
include(tloopnode(n).loopflags,lnf_simplify_processing);
callsimplify(n,arg);
// Be careful, n might have change node type
if n.inheritsfrom(tloopnode) then
exclude(tloopnode(n).loopflags,lnf_simplify_processing);
end
else
begin
hn:=n.simplify(true);
if assigned(hn) then
begin
treechanged := arg;
if assigned(treechanged) then
treechanged^:=true
else
internalerror (201008181);
n.free;
n:=hn;
typecheckpass(n);
end;
end;
end;
{ tries to simplify the given node calling the simplify method recursively }
procedure doinlinesimplify(var n : tnode);
var
treechanged : boolean;
begin
// Optimize if code first
repeat
treechanged:=false;
foreachnodestatic(pm_postandagain,n,@callsimplify,@treechanged);
until not(treechanged);
end;
function create_simplified_ord_const(value: tconstexprint; def: tdef; forinline: boolean): tnode;
begin
if not forinline then
result:=genintconstnode(value)
else
result:=cordconstnode.create(value,def,cs_check_range in current_settings.localswitches);
end;
function getpropaccesslist(propsym:tpropertysym; pap:tpropaccesslisttypes;out propaccesslist:tpropaccesslist):boolean;
var
hpropsym : tpropertysym;
begin
result:=false;
{ find property in the overridden list }
hpropsym:=propsym;
repeat
propaccesslist:=hpropsym.propaccesslist[pap];
if not propaccesslist.empty then
begin
result:=true;
exit;
end;
hpropsym:=hpropsym.overriddenpropsym;
until not assigned(hpropsym);
end;
procedure propaccesslist_to_node(var p1:tnode;st:TSymtable;pl:tpropaccesslist);
var
plist : ppropaccesslistitem;
begin
plist:=pl.firstsym;
while assigned(plist) do
begin
case plist^.sltype of
sl_load :
begin
addsymref(plist^.sym);
if not assigned(st) then
st:=plist^.sym.owner;
{ p1 can already contain the loadnode of
the class variable. When there is no tree yet we
may need to load it for with or objects }
if not assigned(p1) then
begin
case st.symtabletype of
withsymtable :
p1:=tnode(twithsymtable(st).withrefnode).getcopy;
ObjectSymtable :
p1:=load_self_node;
end;
end;
if assigned(p1) then
p1:=csubscriptnode.create(plist^.sym,p1)
else
p1:=cloadnode.create(plist^.sym,st);
end;
sl_subscript :
begin
addsymref(plist^.sym);
p1:=csubscriptnode.create(plist^.sym,p1);
end;
sl_typeconv :
p1:=ctypeconvnode.create_explicit(p1,plist^.def);
sl_absolutetype :
begin
p1:=ctypeconvnode.create(p1,plist^.def);
include(p1.flags,nf_absolute);
end;
sl_vec :
p1:=cvecnode.create(p1,cordconstnode.create(plist^.value,plist^.valuedef,true));
else
internalerror(200110205);
end;
plist:=plist^.next;
end;
end;
function node_to_propaccesslist(p1:tnode):tpropaccesslist;
var
sl : tpropaccesslist;
procedure addnode(p:tnode);
begin
case p.nodetype of
subscriptn :
begin
addnode(tsubscriptnode(p).left);
sl.addsym(sl_subscript,tsubscriptnode(p).vs);
end;
typeconvn :
begin
addnode(ttypeconvnode(p).left);
if nf_absolute in ttypeconvnode(p).flags then
sl.addtype(sl_absolutetype,ttypeconvnode(p).totypedef)
else
sl.addtype(sl_typeconv,ttypeconvnode(p).totypedef);
end;
vecn :
begin
addnode(tvecnode(p).left);
if tvecnode(p).right.nodetype=ordconstn then
sl.addconst(sl_vec,tordconstnode(tvecnode(p).right).value,tvecnode(p).right.resultdef)
else
begin
Message(parser_e_illegal_expression);
{ recovery }
sl.addconst(sl_vec,0,tvecnode(p).right.resultdef);
end;
end;
loadn :
sl.addsym(sl_load,tloadnode(p).symtableentry);
else
internalerror(200310282);
end;
end;
begin
sl:=tpropaccesslist.create;
addnode(p1);
result:=sl;
end;
function is_bitpacked_access(n: tnode): boolean;
begin
case n.nodetype of
vecn:
result:=
is_packed_array(tvecnode(n).left.resultdef) and
{ only orddefs and enumdefs are actually bitpacked. Don't consider
e.g. an access to a 3-byte record as "bitpacked", since it
isn't }
(tvecnode(n).left.resultdef.typ in [orddef,enumdef]) and
not(tarraydef(tvecnode(n).left.resultdef).elepackedbitsize in [8,16,32,64]);
subscriptn:
result:=
is_packed_record_or_object(tsubscriptnode(n).left.resultdef) and
{ see above }
(tsubscriptnode(n).vs.vardef.typ in [orddef,enumdef]) and
(not(tsubscriptnode(n).vs.vardef.packedbitsize in [8,16,32,64]) or
(tsubscriptnode(n).vs.fieldoffset mod 8 <> 0));
else
result:=false;
end;
end;
function genloadfield(n: tnode; const fieldname: string): tnode;
var
vs : tsym;
begin
if not assigned(n.resultdef) then
typecheckpass(n);
vs:=tsym(tabstractrecorddef(n.resultdef).symtable.find(fieldname));
if not assigned(vs) or
(vs.typ<>fieldvarsym) then
internalerror(2010061902);
result:=csubscriptnode.create(vs,n);
end;
function has_no_code(n : tnode) : boolean;
begin
if n=nil then
begin
result:=true;
exit;
end;
result:=false;
case n.nodetype of
nothingn:
begin
result:=true;
exit;
end;
blockn:
begin
result:=has_no_code(tblocknode(n).left);
exit;
end;
statementn:
begin
repeat
result:=has_no_code(tstatementnode(n).left);
n:=tstatementnode(n).right;
until not(result) or not assigned(n);
exit;
end;
end;
end;
end.
Reference in New Issue View Git Blame Copy Permalink