mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-06 22:28:01 +02:00
3330 lines
130 KiB
ObjectPascal
3330 lines
130 KiB
ObjectPascal
{
|
|
Copyright (c) 1998-2002 by Florian Klaempfl, Daniel Mantione
|
|
|
|
Does the parsing and codegeneration at subroutine level
|
|
|
|
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 psub;
|
|
|
|
{$i fpcdefs.inc}
|
|
|
|
{ $define debug_eh}
|
|
|
|
interface
|
|
|
|
uses
|
|
globals,cclasses,
|
|
node,nbas,nutils,aasmdata,
|
|
symdef,procinfo,optdfa;
|
|
|
|
type
|
|
tcgprocinfo = class(tprocinfo)
|
|
private type
|
|
ttempinfo_flags_entry = record
|
|
tempinfo : ptempinfo;
|
|
flags : ttempinfoflags;
|
|
end;
|
|
ptempinfo_flags_entry = ^ttempinfo_flags_entry;
|
|
private
|
|
tempinfo_flags_map : TFPList;
|
|
tempflags_swapped : boolean;
|
|
procedure swap_tempflags;
|
|
function store_node_tempflags(var n: tnode; arg: pointer): foreachnoderesult;
|
|
procedure CreateInlineInfo;
|
|
{ returns the node which is the start of the user code, this is needed by the dfa }
|
|
function GetUserCode: tnode;
|
|
procedure maybe_add_constructor_wrapper(var tocode: tnode; withexceptblock: boolean);
|
|
procedure add_entry_exit_code;
|
|
procedure setup_tempgen;
|
|
procedure OptimizeNodeTree;
|
|
procedure convert_captured_syms;
|
|
protected
|
|
procedure generate_code_exceptfilters;
|
|
public
|
|
{ code for the subroutine as tree }
|
|
code : tnode;
|
|
{ positions in the tree for init/final }
|
|
entry_asmnode,
|
|
loadpara_asmnode,
|
|
exitlabel_asmnode,
|
|
stackcheck_asmnode,
|
|
init_asmnode : tasmnode;
|
|
temps_finalized : boolean;
|
|
dfabuilder : TDFABuilder;
|
|
|
|
destructor destroy;override;
|
|
|
|
function calc_stackframe_size : longint;override;
|
|
|
|
procedure printproc(pass:string);
|
|
procedure generate_code;
|
|
procedure generate_code_tree;
|
|
procedure generate_exceptfilter(nestedpi: tcgprocinfo);
|
|
procedure generate_exit_label(list: tasmlist); virtual;
|
|
procedure resetprocdef;
|
|
procedure add_to_symtablestack;
|
|
procedure remove_from_symtablestack;
|
|
procedure parse_body;
|
|
|
|
procedure store_tempflags;
|
|
procedure apply_tempflags;
|
|
procedure reset_tempflags;
|
|
|
|
function has_assembler_child : boolean;
|
|
procedure set_eh_info; override;
|
|
{$ifdef DEBUG_NODE_XML}
|
|
procedure XMLPrintProc(FirstHalf: Boolean);
|
|
{$endif DEBUG_NODE_XML}
|
|
end;
|
|
|
|
tread_proc_flag = (
|
|
rpf_classmethod,
|
|
rpf_generic,
|
|
rpf_anonymous
|
|
);
|
|
tread_proc_flags = set of tread_proc_flag;
|
|
|
|
|
|
procedure printnode_reset;
|
|
|
|
{$ifdef DEBUG_NODE_XML}
|
|
procedure XMLInitializeNodeFile(RootName, ModuleName: shortstring);
|
|
procedure XMLFinalizeNodeFile(RootName: shortstring);
|
|
{$endif DEBUG_NODE_XML}
|
|
{ reads the declaration blocks }
|
|
procedure read_declarations(islibrary : boolean);
|
|
|
|
{ reads declarations in the interface part of a unit }
|
|
procedure read_interface_declarations;
|
|
|
|
{ reads any routine in the implementation, or a non-method routine
|
|
declaration in the interface (depending on whether or not parse_only is
|
|
true) }
|
|
function read_proc(flags:tread_proc_flags; usefwpd: tprocdef):tprocdef;
|
|
|
|
{ parses only the body of a non nested routine; needs a correctly setup pd }
|
|
procedure read_proc_body(pd:tprocdef);
|
|
|
|
procedure import_external_proc(pd:tprocdef);
|
|
|
|
|
|
implementation
|
|
|
|
uses
|
|
sysutils,
|
|
{ common }
|
|
cutils, cmsgs,
|
|
{ global }
|
|
globtype,tokens,verbose,comphook,constexp,
|
|
systems,cpubase,aasmbase,aasmtai,
|
|
{ symtable }
|
|
symconst,symbase,symsym,symtype,symtable,defutil,defcmp,procdefutil,symcreat,
|
|
paramgr,
|
|
fmodule,
|
|
{ pass 1 }
|
|
ngenutil,nld,ncal,ncon,nflw,nadd,ncnv,nmem,
|
|
pass_1,
|
|
{$ifdef state_tracking}
|
|
nstate,
|
|
{$endif state_tracking}
|
|
{ pass 2 }
|
|
{$ifndef NOPASS2}
|
|
pass_2,
|
|
{$endif}
|
|
{ parser }
|
|
scanner,gendef,
|
|
pbase,pstatmnt,pdecl,pdecsub,pexports,pgenutil,pparautl,
|
|
{ codegen }
|
|
tgobj,cgbase,cgobj,hlcgobj,hlcgcpu,dbgbase,
|
|
|
|
ncgflw,
|
|
ncgutil,
|
|
|
|
optbase,
|
|
opttail,
|
|
optcse,
|
|
optloop,
|
|
optconstprop,
|
|
optdeadstore,
|
|
optloadmodifystore,
|
|
optutils
|
|
{$if defined(arm) or defined(m68k)}
|
|
,cpuinfo
|
|
{$endif defined(arm) or defined(m68k)}
|
|
{$ifndef NOOPT}
|
|
,aopt
|
|
{$endif}
|
|
;
|
|
|
|
function checknodeinlining(procdef: tprocdef): boolean;
|
|
|
|
procedure _no_inline(const reason: TMsgStr);
|
|
begin
|
|
include(procdef.implprocoptions,pio_inline_not_possible);
|
|
Message1(parser_n_not_supported_for_inline,reason);
|
|
Message(parser_h_inlining_disabled);
|
|
end;
|
|
|
|
var
|
|
i : integer;
|
|
currpara : tparavarsym;
|
|
begin
|
|
result := false;
|
|
{ this code will never be used (only specialisations can be inlined),
|
|
and moreover contains references to defs that are not stored in the
|
|
ppu file }
|
|
if df_generic in current_procinfo.procdef.defoptions then
|
|
exit;
|
|
if pi_has_assembler_block in current_procinfo.flags then
|
|
begin
|
|
_no_inline('assembler');
|
|
exit;
|
|
end;
|
|
if (pi_has_global_goto in current_procinfo.flags) or
|
|
(pi_has_interproclabel in current_procinfo.flags) then
|
|
begin
|
|
_no_inline('global goto');
|
|
exit;
|
|
end;
|
|
if pi_has_nested_exit in current_procinfo.flags then
|
|
begin
|
|
_no_inline('nested exit');
|
|
exit;
|
|
end;
|
|
if pi_calls_c_varargs in current_procinfo.flags then
|
|
begin
|
|
_no_inline('called C-style varargs functions');
|
|
exit;
|
|
end;
|
|
{ the compiler cannot handle inherited in inlined subroutines because
|
|
it tries to search for self in the symtable, however, the symtable
|
|
is not available }
|
|
if pi_has_inherited in current_procinfo.flags then
|
|
begin
|
|
_no_inline('inherited');
|
|
exit;
|
|
end;
|
|
if pio_nested_access in procdef.implprocoptions then
|
|
begin
|
|
_no_inline('access to local from nested scope');
|
|
exit;
|
|
end;
|
|
{ We can't support inlining for procedures that have nested
|
|
procedures because the nested procedures use a fixed offset
|
|
for accessing locals in the parent procedure (PFV) }
|
|
if current_procinfo.has_nestedprocs then
|
|
begin
|
|
_no_inline('nested procedures');
|
|
exit;
|
|
end;
|
|
|
|
if pi_uses_get_frame in current_procinfo.flags then
|
|
begin
|
|
_no_inline('get_frame');
|
|
{ for LLVM: it can inline things that FPC can't, but it mustn't
|
|
inline this one }
|
|
include(current_procinfo.procdef.implprocoptions,pio_inline_forbidden);
|
|
exit;
|
|
end;
|
|
|
|
for i:=0 to procdef.paras.count-1 do
|
|
begin
|
|
currpara:=tparavarsym(procdef.paras[i]);
|
|
case currpara.vardef.typ of
|
|
arraydef :
|
|
begin
|
|
if is_array_of_const(currpara.vardef) or
|
|
is_variant_array(currpara.vardef) then
|
|
begin
|
|
_no_inline('array of const');
|
|
exit;
|
|
end;
|
|
{ open arrays might need re-basing of the index, i.e. if you pass
|
|
an array[1..10] as open array, you have to add 1 to all index operations
|
|
if you directly inline it }
|
|
if is_open_array(currpara.vardef) then
|
|
begin
|
|
_no_inline('open array');
|
|
exit;
|
|
end;
|
|
end;
|
|
else
|
|
;
|
|
end;
|
|
end;
|
|
result:=true;
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
PROCEDURE/FUNCTION BODY PARSING
|
|
****************************************************************************}
|
|
|
|
procedure initializevars(p:TObject;arg:pointer);
|
|
var
|
|
b : tblocknode;
|
|
begin
|
|
if not (tsym(p).typ in [localvarsym,staticvarsym]) then
|
|
exit;
|
|
with tabstractnormalvarsym(p) do
|
|
begin
|
|
if assigned(defaultconstsym) then
|
|
begin
|
|
b:=tblocknode(arg);
|
|
b.left:=cstatementnode.create(
|
|
cassignmentnode.create(
|
|
cloadnode.create(tsym(p),tsym(p).owner),
|
|
cloadnode.create(defaultconstsym,defaultconstsym.owner)),
|
|
b.left);
|
|
end
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure check_finalize_paras(p:TObject;arg:pointer);
|
|
begin
|
|
if (tsym(p).typ=paravarsym) then
|
|
begin
|
|
if tparavarsym(p).needs_finalization then
|
|
begin
|
|
include(current_procinfo.flags,pi_needs_implicit_finally);
|
|
include(current_procinfo.flags,pi_do_call);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure check_finalize_locals(p:TObject;arg:pointer);
|
|
begin
|
|
{ include the result: it needs to be finalized in case an exception }
|
|
{ occurs }
|
|
if (tsym(p).typ=localvarsym) and
|
|
(tlocalvarsym(p).refs>0) and
|
|
is_managed_type(tlocalvarsym(p).vardef) then
|
|
begin
|
|
include(current_procinfo.flags,pi_needs_implicit_finally);
|
|
include(current_procinfo.flags,pi_do_call);
|
|
end;
|
|
end;
|
|
|
|
procedure init_main_block_syms(block: tnode);
|
|
var
|
|
oldfilepos: tfileposinfo;
|
|
begin
|
|
{ initialized variables }
|
|
if current_procinfo.procdef.localst.symtabletype=localsymtable then
|
|
begin
|
|
{ initialization of local variables with their initial
|
|
values: part of function entry }
|
|
oldfilepos:=current_filepos;
|
|
current_filepos:=current_procinfo.entrypos;
|
|
current_procinfo.procdef.localst.SymList.ForEachCall(@initializevars,block);
|
|
current_filepos:=oldfilepos;
|
|
end;
|
|
|
|
if assigned(current_procinfo.procdef.parentfpstruct) then
|
|
begin
|
|
{ finish the parentfpstruct (add padding, ...) }
|
|
finish_parentfpstruct(current_procinfo.procdef);
|
|
end;
|
|
end;
|
|
|
|
function block(islibrary : boolean) : tnode;
|
|
begin
|
|
{ parse const,types and vars }
|
|
read_declarations(islibrary);
|
|
|
|
{ do we have an assembler block without the po_assembler?
|
|
we should allow this for Delphi compatibility (PFV) }
|
|
if (token=_ASM) and (m_delphi in current_settings.modeswitches) then
|
|
include(current_procinfo.procdef.procoptions,po_assembler);
|
|
|
|
{ Handle assembler block different }
|
|
if (po_assembler in current_procinfo.procdef.procoptions) then
|
|
begin
|
|
block:=assembler_block;
|
|
exit;
|
|
end;
|
|
|
|
{Unit initialization?.}
|
|
if (
|
|
assigned(current_procinfo.procdef.localst) and
|
|
(current_procinfo.procdef.localst.symtablelevel=main_program_level) and
|
|
(current_module.is_unit or islibrary)
|
|
) then
|
|
begin
|
|
if (token=_END) then
|
|
begin
|
|
consume(_END);
|
|
{ We need at least a node, else the entry/exit code is not
|
|
generated and thus no PASCALMAIN symbol which we need (PFV) }
|
|
if islibrary then
|
|
block:=cnothingnode.create
|
|
else
|
|
block:=nil;
|
|
end
|
|
else
|
|
begin
|
|
if token=_INITIALIZATION then
|
|
begin
|
|
{ The library init code is already called and does not
|
|
need to be in the initfinal table (PFV) }
|
|
block:=statement_block(_INITIALIZATION);
|
|
init_main_block_syms(block);
|
|
end
|
|
else if token=_FINALIZATION then
|
|
begin
|
|
{ when a unit has only a finalization section, we can come to this
|
|
point when we try to read the nonh existing initalization section
|
|
so we've to check if we are really try to parse the finalization }
|
|
if current_procinfo.procdef.proctypeoption=potype_unitfinalize then
|
|
block:=statement_block(_FINALIZATION)
|
|
else
|
|
block:=nil;
|
|
end
|
|
else
|
|
block:=statement_block(_BEGIN);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
{ parse routine body }
|
|
block:=statement_block(_BEGIN);
|
|
init_main_block_syms(block);
|
|
end;
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
PROCEDURE/FUNCTION COMPILING
|
|
****************************************************************************}
|
|
|
|
procedure printnode_reset;
|
|
begin
|
|
assign(printnodefile,treelogfilename);
|
|
{$push}{$I-}
|
|
rewrite(printnodefile);
|
|
{$pop}
|
|
if ioresult<>0 then
|
|
begin
|
|
Comment(V_Error,'Error creating '+treelogfilename);
|
|
exit;
|
|
end;
|
|
close(printnodefile);
|
|
end;
|
|
|
|
|
|
procedure add_label_init(p:TObject;arg:pointer);
|
|
begin
|
|
if tstoredsym(p).typ=labelsym then
|
|
begin
|
|
addstatement(tstatementnode(arg^),
|
|
cifnode.create(caddnode.create(equaln,
|
|
ccallnode.createintern('fpc_setjmp',
|
|
ccallparanode.create(cloadnode.create(tlabelsym(p).jumpbuf,tlabelsym(p).jumpbuf.owner),nil)),
|
|
cordconstnode.create(1,search_system_proc('fpc_setjmp').returndef,true))
|
|
,cgotonode.create(tlabelsym(p)),nil)
|
|
);
|
|
end;
|
|
end;
|
|
|
|
|
|
function generate_bodyentry_block:tnode;
|
|
var
|
|
srsym : tsym;
|
|
para : tcallparanode;
|
|
call : tcallnode;
|
|
newstatement : tstatementnode;
|
|
def : tabstractrecorddef;
|
|
begin
|
|
result:=internalstatements(newstatement);
|
|
|
|
if assigned(current_structdef) then
|
|
begin
|
|
{ a constructor needs a help procedure }
|
|
if (current_procinfo.procdef.proctypeoption=potype_constructor) then
|
|
begin
|
|
if is_class(current_structdef) or
|
|
(
|
|
is_objectpascal_helper(current_structdef) and
|
|
is_class(tobjectdef(current_structdef).extendeddef)
|
|
) then
|
|
begin
|
|
if is_objectpascal_helper(current_structdef) then
|
|
def:=tabstractrecorddef(tobjectdef(current_structdef).extendeddef)
|
|
else
|
|
def:=current_structdef;
|
|
srsym:=search_struct_member(def,'NEWINSTANCE');
|
|
if assigned(srsym) and
|
|
(srsym.typ=procsym) then
|
|
begin
|
|
{ if vmt=1 then newinstance }
|
|
call:=
|
|
ccallnode.create(nil,tprocsym(srsym),srsym.owner,
|
|
ctypeconvnode.create_internal(load_self_pointer_node,cclassrefdef.create(current_structdef)),
|
|
[],nil);
|
|
include(call.callnodeflags,cnf_ignore_devirt_wpo);
|
|
addstatement(newstatement,cifnode.create(
|
|
caddnode.create_internal(equaln,
|
|
ctypeconvnode.create_internal(
|
|
load_vmt_pointer_node,
|
|
voidpointertype),
|
|
cpointerconstnode.create(1,voidpointertype)),
|
|
cassignmentnode.create(
|
|
ctypeconvnode.create_internal(
|
|
load_self_pointer_node,
|
|
voidpointertype),
|
|
call),
|
|
nil));
|
|
end
|
|
else
|
|
internalerror(200305108);
|
|
end
|
|
else
|
|
if is_object(current_structdef) then
|
|
begin
|
|
{ parameter 3 : vmt_offset }
|
|
{ parameter 2 : address of pointer to vmt,
|
|
this is required to allow setting the vmt to -1 to indicate
|
|
that memory was allocated }
|
|
{ parameter 1 : self pointer }
|
|
para:=ccallparanode.create(
|
|
cordconstnode.create(tobjectdef(current_structdef).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,cassignmentnode.create(
|
|
ctypeconvnode.create_internal(
|
|
load_self_pointer_node,
|
|
voidpointertype),
|
|
ccallnode.createintern('fpc_help_constructor',para)));
|
|
end
|
|
else
|
|
if is_javaclass(current_structdef) or
|
|
((target_info.system in systems_jvm) and
|
|
is_record(current_structdef)) then
|
|
begin
|
|
if (current_procinfo.procdef.proctypeoption=potype_constructor) and
|
|
not current_procinfo.ConstructorCallingConstructor then
|
|
begin
|
|
{ call inherited constructor }
|
|
if is_javaclass(current_structdef) then
|
|
srsym:=search_struct_member_no_helper(tobjectdef(current_structdef).childof,'CREATE')
|
|
else
|
|
srsym:=search_struct_member_no_helper(java_fpcbaserecordtype,'CREATE');
|
|
if assigned(srsym) and
|
|
(srsym.typ=procsym) then
|
|
begin
|
|
call:=ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[cnf_inherited],nil);
|
|
exclude(tcallnode(call).callnodeflags,cnf_return_value_used);
|
|
addstatement(newstatement,call);
|
|
end
|
|
else
|
|
internalerror(2011010312);
|
|
end;
|
|
end
|
|
else
|
|
if not is_record(current_structdef) and
|
|
not (
|
|
is_objectpascal_helper(current_structdef) and
|
|
(tobjectdef(current_structdef).extendeddef.typ<>objectdef)
|
|
) then
|
|
internalerror(200305103);
|
|
{ if self=nil then exit
|
|
calling fail instead of exit is useless because
|
|
there is nothing to dispose (PFV) }
|
|
if is_class_or_object(current_structdef) then
|
|
addstatement(newstatement,cifnode.create(
|
|
caddnode.create(equaln,
|
|
load_self_pointer_node,
|
|
cnilnode.create),
|
|
cexitnode.create(nil),
|
|
nil));
|
|
end;
|
|
|
|
{ maybe call BeforeDestruction for classes }
|
|
if (current_procinfo.procdef.proctypeoption=potype_destructor) and
|
|
is_class(current_structdef) then
|
|
begin
|
|
srsym:=search_struct_member(current_structdef,'BEFOREDESTRUCTION');
|
|
if assigned(srsym) and
|
|
(srsym.typ=procsym) then
|
|
begin
|
|
{ if vmt>0 then beforedestruction }
|
|
addstatement(newstatement,cifnode.create(
|
|
caddnode.create(gtn,
|
|
ctypeconvnode.create_internal(
|
|
load_vmt_pointer_node,ptrsinttype),
|
|
ctypeconvnode.create_internal(
|
|
cnilnode.create,ptrsinttype)),
|
|
ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[],nil),
|
|
nil));
|
|
end
|
|
else
|
|
internalerror(200305104);
|
|
end;
|
|
end;
|
|
if m_non_local_goto in current_settings.modeswitches then
|
|
tsymtable(current_procinfo.procdef.localst).SymList.ForEachCall(@add_label_init,@newstatement);
|
|
|
|
initialize_capturer(current_procinfo,newstatement);
|
|
end;
|
|
|
|
|
|
function generate_bodyexit_block:tnode;
|
|
var
|
|
srsym : tsym;
|
|
para : tcallparanode;
|
|
newstatement : tstatementnode;
|
|
oldlocalswitches: tlocalswitches;
|
|
begin
|
|
result:=internalstatements(newstatement);
|
|
|
|
if assigned(current_structdef) then
|
|
begin
|
|
{ Don't test self and the vmt here. The reason is that }
|
|
{ a constructor already checks whether these are valid }
|
|
{ before. Further, in case of TThread the thread may }
|
|
{ free the class instance right after AfterConstruction }
|
|
{ has been called, so it may no longer be valid (JM) }
|
|
oldlocalswitches:=current_settings.localswitches;
|
|
current_settings.localswitches:=oldlocalswitches-[cs_check_object,cs_check_range];
|
|
|
|
{ a destructor needs a help procedure }
|
|
if (current_procinfo.procdef.proctypeoption=potype_destructor) then
|
|
begin
|
|
if is_class(current_structdef) then
|
|
begin
|
|
srsym:=search_struct_member(current_structdef,'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,
|
|
ctypeconvnode.create(
|
|
load_vmt_pointer_node,
|
|
voidpointertype),
|
|
cpointerconstnode.create(0,voidpointertype))),
|
|
ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[],nil),
|
|
nil));
|
|
end
|
|
else
|
|
internalerror(2003051001);
|
|
end
|
|
else
|
|
if is_object(current_structdef) then
|
|
begin
|
|
{ finalize object data, but only if not in inherited call }
|
|
if is_managed_type(current_structdef) then
|
|
begin
|
|
addstatement(newstatement,cifnode.create(
|
|
caddnode.create(unequaln,
|
|
ctypeconvnode.create_internal(load_vmt_pointer_node,voidpointertype),
|
|
cnilnode.create),
|
|
cnodeutils.finalize_data_node(load_self_node),
|
|
nil));
|
|
end;
|
|
{ parameter 3 : vmt_offset }
|
|
{ parameter 2 : pointer to vmt }
|
|
{ parameter 1 : self pointer }
|
|
para:=ccallparanode.create(
|
|
cordconstnode.create(tobjectdef(current_structdef).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_destructor',para));
|
|
end
|
|
else if is_javaclass(current_structdef) then
|
|
begin
|
|
{ nothing to do }
|
|
end
|
|
else
|
|
internalerror(200305105);
|
|
end;
|
|
current_settings.localswitches:=oldlocalswitches;
|
|
end;
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
TCGProcInfo
|
|
****************************************************************************}
|
|
|
|
destructor tcgprocinfo.destroy;
|
|
begin
|
|
TFPList.FreeAndNilDisposing(tempinfo_flags_map,TypeInfo(ttempinfo_flags_entry));
|
|
code.free;
|
|
inherited destroy;
|
|
end;
|
|
|
|
|
|
function tcgprocinfo.calc_stackframe_size:longint;
|
|
begin
|
|
result:=Align(tg.direction*tg.lasttemp,current_settings.alignment.localalignmin);
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.printproc(pass:string);
|
|
begin
|
|
assign(printnodefile,treelogfilename);
|
|
{$push}{$I-}
|
|
append(printnodefile);
|
|
if ioresult<>0 then
|
|
rewrite(printnodefile);
|
|
{$pop}
|
|
if ioresult<>0 then
|
|
begin
|
|
Comment(V_Error,'Error creating '+treelogfilename);
|
|
exit;
|
|
end;
|
|
writeln(printnodefile);
|
|
writeln(printnodefile,'*******************************************************************************');
|
|
writeln(printnodefile, pass);
|
|
writeln(printnodefile,procdef.fullprocname(false));
|
|
writeln(printnodefile,'*******************************************************************************');
|
|
printnode(printnodefile,code);
|
|
close(printnodefile);
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.maybe_add_constructor_wrapper(var tocode: tnode; withexceptblock: boolean);
|
|
var
|
|
oldlocalswitches: tlocalswitches;
|
|
srsym: tsym;
|
|
constructionblock,
|
|
exceptblock,
|
|
newblock: tblocknode;
|
|
newstatement: tstatementnode;
|
|
pd: tprocdef;
|
|
constructionsuccessful: tlocalvarsym;
|
|
begin
|
|
if assigned(procdef.struct) and
|
|
(procdef.proctypeoption=potype_constructor) then
|
|
begin
|
|
withexceptblock:=
|
|
withexceptblock and
|
|
not(target_info.system in systems_garbage_collected_managed_types);
|
|
{ Don't test self and the vmt here. See generate_bodyexit_block }
|
|
{ why (JM) }
|
|
oldlocalswitches:=current_settings.localswitches;
|
|
current_settings.localswitches:=oldlocalswitches-[cs_check_object,cs_check_range];
|
|
|
|
{ call AfterConstruction for classes }
|
|
constructionsuccessful:=nil;
|
|
if is_class(procdef.struct) then
|
|
begin
|
|
constructionsuccessful:=clocalvarsym.create(internaltypeprefixName[itp_vmt_afterconstruction_local],vs_value,ptrsinttype,[]);
|
|
procdef.localst.insertsym(constructionsuccessful,false);
|
|
srsym:=search_struct_member(procdef.struct,'AFTERCONSTRUCTION');
|
|
if not assigned(srsym) or
|
|
(srsym.typ<>procsym) then
|
|
internalerror(200305106);
|
|
|
|
current_filepos:=entrypos;
|
|
constructionblock:=internalstatements(newstatement);
|
|
{ initialise constructionsuccessful with -1, indicating that
|
|
the construction was not successful and hence
|
|
beforedestruction should not be called if a destructor is
|
|
called from the constructor }
|
|
addstatement(newstatement,cassignmentnode.create(
|
|
cloadnode.create(constructionsuccessful,procdef.localst),
|
|
genintconstnode(-1))
|
|
);
|
|
{ first execute all constructor code. If no exception
|
|
occurred then we will execute afterconstruction,
|
|
otherwise we won't (the exception will jump over us) }
|
|
addstatement(newstatement,tocode);
|
|
current_filepos:=exitpos;
|
|
{ if implicit finally node wasn't created, then exit label and
|
|
finalization code must be handled here and placed before
|
|
afterconstruction }
|
|
if not ((pi_needs_implicit_finally in flags) and
|
|
(cs_implicit_exceptions in current_settings.moduleswitches)) then
|
|
begin
|
|
include(tocode.flags,nf_block_with_exit);
|
|
if procdef.proctypeoption<>potype_exceptfilter then
|
|
addstatement(newstatement,cfinalizetempsnode.create);
|
|
cnodeutils.procdef_block_add_implicit_finalize_nodes(procdef,newstatement);
|
|
temps_finalized:=true;
|
|
end;
|
|
|
|
{ construction successful -> beforedestruction should be called
|
|
if an exception happens now }
|
|
addstatement(newstatement,cassignmentnode.create(
|
|
cloadnode.create(constructionsuccessful,procdef.localst),
|
|
genintconstnode(1))
|
|
);
|
|
{ Self can be nil when fail is called }
|
|
{ if self<>nil and vmt<>nil then afterconstruction }
|
|
addstatement(newstatement,cifnode.create(
|
|
caddnode.create(andn,
|
|
caddnode.create(unequaln,
|
|
load_self_node,
|
|
cnilnode.create),
|
|
caddnode.create(unequaln,
|
|
load_vmt_pointer_node,
|
|
cnilnode.create)),
|
|
ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[],nil),
|
|
nil));
|
|
tocode:=constructionblock;
|
|
end;
|
|
|
|
if withexceptblock and (procdef.struct.typ=objectdef) then
|
|
begin
|
|
{ Generate the implicit "fail" code for a constructor (destroy
|
|
in case an exception happened) }
|
|
pd:=tobjectdef(procdef.struct).find_destructor;
|
|
{ this will always be the case for classes, since tobject has
|
|
a destructor }
|
|
if assigned(pd) or is_object(procdef.struct) then
|
|
begin
|
|
current_filepos:=exitpos;
|
|
exceptblock:=internalstatements(newstatement);
|
|
{ first free the instance if non-nil }
|
|
if assigned(pd) then
|
|
{ if vmt<>0 then call destructor }
|
|
addstatement(newstatement,
|
|
cifnode.create(
|
|
caddnode.create(unequaln,
|
|
load_vmt_pointer_node,
|
|
cnilnode.create),
|
|
{ cnf_create_failed -> don't call BeforeDestruction }
|
|
ccallnode.create(nil,tprocsym(pd.procsym),pd.procsym.owner,load_self_node,[cnf_create_failed],nil),
|
|
nil))
|
|
else
|
|
{ object without destructor, call 'fail' helper }
|
|
addstatement(newstatement,
|
|
ccallnode.createintern('fpc_help_fail',
|
|
ccallparanode.create(
|
|
cordconstnode.create(tobjectdef(procdef.struct).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))))
|
|
);
|
|
{ then re-raise the exception }
|
|
addstatement(newstatement,craisenode.create(nil,nil,nil));
|
|
current_filepos:=entrypos;
|
|
newblock:=internalstatements(newstatement);
|
|
{ try
|
|
tocode
|
|
except
|
|
exceptblock
|
|
end
|
|
}
|
|
addstatement(newstatement,ctryexceptnode.create(
|
|
tocode,
|
|
nil,
|
|
exceptblock));
|
|
tocode:=newblock;
|
|
end;
|
|
end;
|
|
current_settings.localswitches:=oldlocalswitches;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.add_entry_exit_code;
|
|
var
|
|
finalcode,
|
|
bodyentrycode,
|
|
bodyexitcode,
|
|
wrappedbody,
|
|
newblock : tnode;
|
|
codestatement,
|
|
newstatement : tstatementnode;
|
|
oldfilepos : tfileposinfo;
|
|
is_constructor: boolean;
|
|
begin
|
|
is_constructor:=assigned(procdef.struct) and
|
|
(procdef.proctypeoption=potype_constructor);
|
|
|
|
oldfilepos:=current_filepos;
|
|
{ Generate code/locations used at start of proc }
|
|
current_filepos:=entrypos;
|
|
entry_asmnode:=casmnode.create_get_position;
|
|
loadpara_asmnode:=casmnode.create_get_position;
|
|
stackcheck_asmnode:=casmnode.create_get_position;
|
|
init_asmnode:=casmnode.create_get_position;
|
|
bodyentrycode:=generate_bodyentry_block;
|
|
{ Generate code/locations used at end of proc }
|
|
current_filepos:=exitpos;
|
|
exitlabel_asmnode:=casmnode.create_get_position;
|
|
temps_finalized:=false;
|
|
bodyexitcode:=generate_bodyexit_block;
|
|
{ Check if bodyexitcode is not empty }
|
|
with tstatementnode(tblocknode(bodyexitcode).statements) do
|
|
if (statement.nodetype<>nothingn) or assigned(next) then
|
|
{ Indicate that the extra code is executed after the exit statement }
|
|
include(flowcontrol,fc_no_direct_exit);
|
|
|
|
{ Generate procedure by combining init+body+final,
|
|
depending on the implicit finally we need to add
|
|
an try...finally...end wrapper }
|
|
current_filepos:=entrypos;
|
|
newblock:=internalstatements(newstatement);
|
|
{ Note - this is not strippable since it wraps the entire procedure }
|
|
Exclude(TBlockNode(newblock).blocknodeflags, bnf_strippable);
|
|
{ initialization is common for all cases }
|
|
addstatement(newstatement,loadpara_asmnode);
|
|
addstatement(newstatement,stackcheck_asmnode);
|
|
addstatement(newstatement,entry_asmnode);
|
|
cnodeutils.procdef_block_add_implicit_initialize_nodes(procdef,newstatement);
|
|
addstatement(newstatement,init_asmnode);
|
|
if assigned(procdef.parentfpinitblock) then
|
|
begin
|
|
if assigned(tblocknode(procdef.parentfpinitblock).left) then
|
|
begin
|
|
if cnodeutils.check_insert_trashing(procdef) then
|
|
cnodeutils.maybe_trash_variable(newstatement,tabstractnormalvarsym(procdef.parentfpstruct),cloadnode.create(procdef.parentfpstruct,procdef.parentfpstruct.owner));
|
|
{ could be an asmn in case of a pure assembler procedure,
|
|
but those shouldn't access nested variables }
|
|
addstatement(newstatement,procdef.parentfpinitblock);
|
|
end
|
|
else
|
|
procdef.parentfpinitblock.free;
|
|
procdef.parentfpinitblock:=nil;
|
|
end;
|
|
addstatement(newstatement,bodyentrycode);
|
|
|
|
if (cs_implicit_exceptions in current_settings.moduleswitches) and
|
|
(pi_needs_implicit_finally in flags) and
|
|
{ but it's useless in init/final code of units }
|
|
not(procdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) and
|
|
not(target_info.system in systems_garbage_collected_managed_types) and
|
|
(f_exceptions in features) then
|
|
begin
|
|
{ Any result of managed type must be returned in parameter }
|
|
if is_managed_type(procdef.returndef) and
|
|
(not paramanager.ret_in_param(procdef.returndef,procdef)) and
|
|
(not is_class(procdef.returndef)) then
|
|
InternalError(2013121301);
|
|
|
|
{ Generate special exception block only needed when
|
|
implicit finally is used }
|
|
current_filepos:=exitpos;
|
|
{ Generate code that will be in the try...finally }
|
|
finalcode:=internalstatements(codestatement);
|
|
if procdef.proctypeoption<>potype_exceptfilter then
|
|
addstatement(codestatement,cfinalizetempsnode.create);
|
|
cnodeutils.procdef_block_add_implicit_finalize_nodes(procdef,codestatement);
|
|
temps_finalized:=true;
|
|
|
|
current_filepos:=entrypos;
|
|
wrappedbody:=ctryfinallynode.create_implicit(code,finalcode);
|
|
{ afterconstruction must be called after finalizetemps, because it
|
|
has to execute after the temps have been finalised in case of a
|
|
refcounted class (afterconstruction decreases the refcount
|
|
without freeing the instance if the count becomes nil, while
|
|
the finalising of the temps can free the instance) }
|
|
maybe_add_constructor_wrapper(wrappedbody,true);
|
|
addstatement(newstatement,wrappedbody);
|
|
addstatement(newstatement,exitlabel_asmnode);
|
|
addstatement(newstatement,bodyexitcode);
|
|
{ set flag the implicit finally has been generated }
|
|
include(flags,pi_has_implicit_finally);
|
|
end
|
|
else
|
|
begin
|
|
{ constructors need destroy-on-exception code even if they don't
|
|
have managed variables/temps }
|
|
maybe_add_constructor_wrapper(code,
|
|
(cs_implicit_exceptions in current_settings.moduleswitches) and (f_exceptions in features));
|
|
current_filepos:=entrypos;
|
|
addstatement(newstatement,code);
|
|
current_filepos:=exitpos;
|
|
if assigned(nestedexitlabel) then
|
|
addstatement(newstatement,clabelnode.create(cnothingnode.create,nestedexitlabel));
|
|
addstatement(newstatement,exitlabel_asmnode);
|
|
addstatement(newstatement,bodyexitcode);
|
|
if not is_constructor then
|
|
begin
|
|
if procdef.proctypeoption<>potype_exceptfilter then
|
|
addstatement(newstatement,cfinalizetempsnode.create);
|
|
cnodeutils.procdef_block_add_implicit_finalize_nodes(procdef,newstatement);
|
|
temps_finalized:=true;
|
|
end;
|
|
end;
|
|
if not temps_finalized then
|
|
begin
|
|
current_filepos:=exitpos;
|
|
cnodeutils.procdef_block_add_implicit_finalize_nodes(procdef,newstatement);
|
|
end;
|
|
do_firstpass(newblock);
|
|
code:=newblock;
|
|
current_filepos:=oldfilepos;
|
|
end;
|
|
|
|
|
|
procedure clearrefs(p:TObject;arg:pointer);
|
|
begin
|
|
if (tsym(p).typ in [localvarsym,paravarsym,staticvarsym]) then
|
|
if tabstractvarsym(p).refs>1 then
|
|
tabstractvarsym(p).refs:=1;
|
|
end;
|
|
|
|
|
|
procedure translate_registers(p:TObject;list:pointer);
|
|
begin
|
|
if (tsym(p).typ in [localvarsym,paravarsym,staticvarsym]) and
|
|
(tabstractnormalvarsym(p).localloc.loc in [LOC_REGISTER,LOC_CREGISTER,LOC_MMREGISTER,
|
|
LOC_CMMREGISTER,LOC_FPUREGISTER,LOC_CFPUREGISTER]) then
|
|
begin
|
|
if not(cs_no_regalloc in current_settings.globalswitches) then
|
|
begin
|
|
cg.translate_register(tabstractnormalvarsym(p).localloc.register);
|
|
if (tabstractnormalvarsym(p).localloc.registerhi<>NR_NO) then
|
|
cg.translate_register(tabstractnormalvarsym(p).localloc.registerhi);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
{$if defined(i386) or defined(x86_64) or defined(arm) or defined(aarch64) or defined(riscv32) or defined(riscv64) or defined(m68k)}
|
|
const
|
|
exception_flags: array[boolean] of tprocinfoflags = (
|
|
[],
|
|
[pi_uses_exceptions,pi_needs_implicit_finally,pi_has_implicit_finally]
|
|
);
|
|
{$endif}
|
|
|
|
procedure tcgprocinfo.setup_tempgen;
|
|
begin
|
|
tg:=tgobjclass.create;
|
|
|
|
{$if defined(i386) or defined(x86_64) or defined(arm) or defined(aarch64) or defined(m68k)}
|
|
{$if defined(arm)}
|
|
{ frame and stack pointer must be always the same on arm thumb so it makes no
|
|
sense to fiddle with a frame pointer }
|
|
if GenerateThumbCode then
|
|
begin
|
|
framepointer:=NR_STACK_POINTER_REG;
|
|
tg.direction:=1;
|
|
end
|
|
else
|
|
{$endif defined(arm)}
|
|
begin
|
|
{ try to strip the stack frame }
|
|
{ set the framepointer to esp if:
|
|
- no assembler directive, those are handled in assembler_block
|
|
in pstatment.pas (for cases not caught by the Delphi
|
|
exception below)
|
|
- no exceptions are used
|
|
- no pushes are used/esp modifications, could be:
|
|
* outgoing parameters on the stack on non-fixed stack target
|
|
* incoming parameters on the stack
|
|
* open arrays
|
|
- no inline assembler
|
|
or
|
|
- Delphi mode
|
|
- assembler directive
|
|
- no pushes are used/esp modifications, could be:
|
|
* outgoing parameters on the stack
|
|
* incoming parameters on the stack
|
|
* open arrays
|
|
- no local variables
|
|
|
|
- stack frame cannot be optimized if using Win64 SEH
|
|
(at least with the current state of our codegenerator).
|
|
}
|
|
if ((po_assembler in procdef.procoptions) and
|
|
(m_delphi in current_settings.modeswitches) and
|
|
{ localst at main_program_level is a staticsymtable }
|
|
(procdef.localst.symtablelevel<>main_program_level) and
|
|
(tabstractlocalsymtable(procdef.localst).count_locals = 0)) or
|
|
((cs_opt_stackframe in current_settings.optimizerswitches) and
|
|
not(cs_generate_stackframes in current_settings.localswitches) and
|
|
not(cs_profile in current_settings.moduleswitches) and
|
|
not(po_assembler in procdef.procoptions) and
|
|
{$if defined(m68k)}
|
|
{ do not optimize away the frame pointer, if the CPU has no long
|
|
displacement support, this fixes optimizations on the plain 68000
|
|
until some shortcomings of the CG itself can be addressed. (KB) }
|
|
(CPUM68K_HAS_BASEDISP in cpu_capabilities[current_settings.cputype]) and
|
|
{$endif defined(m68k)}
|
|
{$if defined(aarch64)}
|
|
{ on aarch64, it must be a leaf subroutine }
|
|
not(pi_do_call in flags) and
|
|
{$endif defined(aarch64)}
|
|
not ((pi_has_stackparameter in flags)
|
|
{$if defined(i386) or defined(x86_64)}
|
|
{ Outgoing parameter(s) on stack do not need stackframe on x86 targets
|
|
with fixed stack. On ARM it fails, see bug #25050 }
|
|
and (not paramanager.use_fixed_stack)
|
|
{$endif defined(i386) or defined(x86_64)}
|
|
) and
|
|
((flags*([pi_has_assembler_block,pi_is_assembler,
|
|
pi_needs_stackframe]+
|
|
exception_flags[((target_info.cpu=cpu_i386) and (not paramanager.use_fixed_stack))
|
|
{$ifndef DISABLE_WIN64_SEH}
|
|
or (target_info.system=system_x86_64_win64)
|
|
{$endif DISABLE_WIN64_SEH}
|
|
]))=[])
|
|
)
|
|
then
|
|
begin
|
|
{ we need the parameter info here to determine if the procedure gets
|
|
parameters on the stack
|
|
|
|
calling generate_parameter_info doesn't hurt but it costs time
|
|
(necessary to init para_stack_size)
|
|
}
|
|
generate_parameter_info;
|
|
|
|
if not(procdef.stack_tainting_parameter(calleeside)) and
|
|
not(has_assembler_child)
|
|
{ parasize must be really zero, this means also that no result may be returned
|
|
in a parameter }
|
|
and not((current_procinfo.procdef.proccalloption in clearstack_pocalls) and
|
|
not(current_procinfo.procdef.generate_safecall_wrapper) and
|
|
paramanager.ret_in_param(current_procinfo.procdef.returndef,current_procinfo.procdef)) then
|
|
begin
|
|
{ Only need to set the framepointer }
|
|
framepointer:=NR_STACK_POINTER_REG;
|
|
tg.direction:=1;
|
|
Include(flags,pi_no_framepointer_needed)
|
|
end
|
|
{$if defined(arm)}
|
|
{ On arm, the stack frame size can be estimated to avoid using an extra frame pointer,
|
|
in case parameters are passed on the stack.
|
|
|
|
However, the draw back is, if the estimation fails, compilation will break later on
|
|
with an internal error, so this switch is not enabled by default yet. To overcome this,
|
|
multipass compilation of subroutines must be supported
|
|
}
|
|
else if (cs_opt_forcenostackframe in current_settings.optimizerswitches) and
|
|
not(has_assembler_child) then
|
|
begin
|
|
{ Only need to set the framepointer }
|
|
framepointer:=NR_STACK_POINTER_REG;
|
|
tg.direction:=1;
|
|
include(flags,pi_estimatestacksize);
|
|
set_first_temp_offset;
|
|
procdef.has_paraloc_info:=callnoside;
|
|
generate_parameter_info;
|
|
exit;
|
|
end;
|
|
{$endif defined(arm)}
|
|
end;
|
|
end;
|
|
{$endif defined(x86) or defined(arm) or defined(m68k)}
|
|
{$if defined(xtensa)}
|
|
{ On xtensa, the stack frame size can be estimated to avoid using an extra frame pointer,
|
|
in case parameters are passed on the stack.
|
|
|
|
However, the draw back is, if the estimation fails, compilation will break later on
|
|
with an internal error, so this switch is not enabled by default yet. To overcome this,
|
|
multipass compilation of subroutines must be supported
|
|
}
|
|
if procdef.stack_tainting_parameter(calleeside) then
|
|
begin
|
|
include(flags,pi_estimatestacksize);
|
|
set_first_temp_offset;
|
|
procdef.has_paraloc_info:=callnoside;
|
|
generate_parameter_info;
|
|
exit;
|
|
end;
|
|
{$endif defined(xtensa)}
|
|
{ set the start offset to the start of the temp area in the stack }
|
|
set_first_temp_offset;
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.OptimizeNodeTree;
|
|
var
|
|
i : integer;
|
|
UserCode : TNode;
|
|
RedoDFA : boolean;
|
|
begin
|
|
{ do this before adding the entry code else the tail recursion recognition won't work,
|
|
if this causes troubles, it must be if'ed
|
|
}
|
|
if (cs_opt_tailrecursion in current_settings.optimizerswitches) and
|
|
(pi_is_recursive in flags) then
|
|
do_opttail(code,procdef);
|
|
|
|
if cs_opt_constant_propagate in current_settings.optimizerswitches then
|
|
begin
|
|
do_optconstpropagate(code,RedoDFA);
|
|
{ RedoDFA value not used here }
|
|
RedoDFA:=false;
|
|
end;
|
|
|
|
if (cs_opt_nodedfa in current_settings.optimizerswitches) and
|
|
{ creating dfa is not always possible }
|
|
((flags*[pi_has_assembler_block,pi_uses_exceptions,pi_is_assembler])=[]) then
|
|
begin
|
|
dfabuilder:=TDFABuilder.Create;
|
|
dfabuilder.createdfainfo(code);
|
|
include(flags,pi_dfaavailable);
|
|
RedoDFA:=false;
|
|
|
|
if cs_opt_constant_propagate in current_settings.optimizerswitches then
|
|
begin
|
|
do_optconstpropagate(code,RedoDFA);
|
|
if RedoDFA then
|
|
begin
|
|
dfabuilder.redodfainfo(code);
|
|
RedoDFA:=false; { Don't redo it again unless necessary }
|
|
end;
|
|
{ Don't re-run constant propagation as redoing DFA info didn't
|
|
actually change any nodes }
|
|
end;
|
|
|
|
if (cs_opt_loopstrength in current_settings.optimizerswitches)
|
|
{ our induction variable strength reduction doesn't like
|
|
for loops with more than one entry }
|
|
and not(pi_has_label in flags) then
|
|
begin
|
|
RedoDFA:=OptimizeInductionVariables(code);
|
|
end;
|
|
|
|
if RedoDFA then
|
|
begin
|
|
dfabuilder.redodfainfo(code);
|
|
RedoDFA:=false; { Don't redo it again unless necessary }
|
|
end;
|
|
|
|
if cs_opt_forloop in current_settings.optimizerswitches then
|
|
RedoDFA:=OptimizeForLoop(code);
|
|
|
|
RedoDFA:=ConvertForLoops(code) or RedoDFA;
|
|
|
|
if RedoDFA then
|
|
dfabuilder.redodfainfo(code);
|
|
|
|
{ when life info is available, we can give more sophisticated warning about uninitialized
|
|
variables ...
|
|
... but not for the finalization section of a unit, we would need global dfa to handle
|
|
it properly }
|
|
if potype_unitfinalize<>procdef.proctypeoption then
|
|
{ iterate through life info of the first node }
|
|
for i:=0 to dfabuilder.nodemap.count-1 do
|
|
begin
|
|
UserCode:=GetUserCode();
|
|
if DFASetIn(UserCode.optinfo^.life,i) then
|
|
begin
|
|
{ do not warn for certain parameters: }
|
|
if not((tnode(dfabuilder.nodemap[i]).nodetype=loadn) and (tloadnode(dfabuilder.nodemap[i]).symtableentry.typ=paravarsym) and
|
|
{ do not warn about parameters passed by var }
|
|
(((tparavarsym(tloadnode(dfabuilder.nodemap[i]).symtableentry).varspez=vs_var) and
|
|
{ function result is passed by var but it must be initialized }
|
|
not(vo_is_funcret in tparavarsym(tloadnode(dfabuilder.nodemap[i]).symtableentry).varoptions)) or
|
|
{ do not warn about initialized hidden parameters }
|
|
((tparavarsym(tloadnode(dfabuilder.nodemap[i]).symtableentry).varoptions*[vo_is_high_para,vo_is_parentfp,vo_is_result,vo_is_self])<>[]))) then
|
|
CheckAndWarn(UserCode,tnode(dfabuilder.nodemap[i]));
|
|
end
|
|
else
|
|
begin
|
|
if (tnode(dfabuilder.nodemap[i]).nodetype=loadn) and
|
|
(tloadnode(dfabuilder.nodemap[i]).symtableentry.typ in [staticvarsym,localvarsym]) then
|
|
tabstractnormalvarsym(tloadnode(dfabuilder.nodemap[i]).symtableentry).noregvarinitneeded:=true
|
|
end;
|
|
end;
|
|
|
|
if cs_opt_dead_store_eliminate in current_settings.optimizerswitches then
|
|
begin
|
|
do_optdeadstoreelim(code,RedoDFA);
|
|
if RedoDFA then
|
|
dfabuilder.redodfainfo(code);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
ConvertForLoops(code);
|
|
end;
|
|
|
|
if (cs_opt_remove_empty_proc in current_settings.optimizerswitches) and
|
|
(procdef.proctypeoption in [potype_operator,potype_procedure,potype_function]) and
|
|
(code.nodetype=blockn) and (tblocknode(code).statements=nil) then
|
|
procdef.isempty:=true;
|
|
|
|
if cs_opt_nodecse in current_settings.optimizerswitches then
|
|
do_optcse(code);
|
|
|
|
if cs_opt_use_load_modify_store in current_settings.optimizerswitches then
|
|
do_optloadmodifystore(code);
|
|
|
|
if (cs_opt_consts in current_settings.optimizerswitches) and
|
|
{ non-local gotos can cause an fpc_setjmp call to be generated before
|
|
this block, which means the loaded value won't be loaded when the
|
|
longjmp is performed }
|
|
not(m_non_local_goto in current_settings.modeswitches) then
|
|
do_consttovar(code);
|
|
end;
|
|
|
|
|
|
function tcgprocinfo.has_assembler_child : boolean;
|
|
var
|
|
hp : tprocinfo;
|
|
begin
|
|
result:=false;
|
|
hp:=get_first_nestedproc;
|
|
while assigned(hp) do
|
|
begin
|
|
if (hp.flags*[pi_has_assembler_block,pi_is_assembler])<>[] then
|
|
begin
|
|
result:=true;
|
|
exit;
|
|
end;
|
|
hp:=tprocinfo(hp.next);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.set_eh_info;
|
|
begin
|
|
inherited;
|
|
if (tf_use_psabieh in target_info.flags) and
|
|
((pi_uses_exceptions in flags) or
|
|
((cs_implicit_exceptions in current_settings.moduleswitches) and
|
|
(pi_needs_implicit_finally in flags))) or
|
|
(pi_has_except_table_data in flags) then
|
|
procdef.personality:=search_system_proc('_FPC_PSABIEH_PERSONALITY_V0');
|
|
end;
|
|
|
|
|
|
function tcgprocinfo.store_node_tempflags(var n: tnode; arg: pointer): foreachnoderesult;
|
|
var
|
|
nodeset : THashSet absolute arg;
|
|
entry : ptempinfo_flags_entry;
|
|
i : longint;
|
|
{hashsetitem: PHashSetItem;}
|
|
begin
|
|
result:=fen_true;
|
|
case n.nodetype of
|
|
tempcreaten:
|
|
begin
|
|
{$ifdef EXTDEBUG}
|
|
comment(V_Debug,'keeping track of new temp node: '+hexstr(ttempbasenode(n).tempinfo));
|
|
{$endif EXTDEBUG}
|
|
nodeset.FindOrAdd(ttempbasenode(n).tempinfo,sizeof(pointer));
|
|
end;
|
|
tempdeleten:
|
|
begin
|
|
{$ifdef EXTDEBUG}
|
|
comment(V_Debug,'got temp delete node: '+hexstr(ttempbasenode(n).tempinfo));
|
|
{$endif EXTDEBUG}
|
|
{ don't remove temp nodes so that outside code can know if some temp
|
|
was only created in here }
|
|
(*hashsetitem:=nodeset.find(ttempbasenode(n).tempinfo,sizeof(pointer));
|
|
if assigned(hashsetitem) then
|
|
begin
|
|
{$ifdef EXTDEBUG}
|
|
comment(V_Debug,'no longer keeping track of temp node');
|
|
{$endif EXTDEBUG}
|
|
writeln('no longer keeping track of temp node');
|
|
nodeset.Remove(hashsetitem);
|
|
end;*)
|
|
end;
|
|
temprefn:
|
|
begin
|
|
{$ifdef EXTDEBUG}
|
|
comment(V_Debug,'found temp ref node: '+hexstr(ttempbasenode(n).tempinfo));
|
|
{$endif EXTDEBUG}
|
|
if not assigned(nodeset.find(ttempbasenode(n).tempinfo,sizeof(pointer))) then
|
|
begin
|
|
for i:=0 to tempinfo_flags_map.count-1 do
|
|
begin
|
|
entry:=ptempinfo_flags_entry(tempinfo_flags_map[i]);
|
|
{$ifdef EXTDEBUG}
|
|
comment(V_Debug,'comparing with tempinfo: '+hexstr(entry^.tempinfo));
|
|
{$endif EXTDEBUG}
|
|
if entry^.tempinfo=ttempbasenode(n).tempinfo then
|
|
begin
|
|
{$ifdef EXTDEBUG}
|
|
comment(V_Debug,'temp node exists');
|
|
{$endif EXTDEBUG}
|
|
exit;
|
|
end;
|
|
end;
|
|
{$ifdef EXTDEBUG}
|
|
comment(V_Debug,'storing node');
|
|
{$endif EXTDEBUG}
|
|
new(entry);
|
|
entry^.tempinfo:=ttempbasenode(n).tempinfo;
|
|
entry^.flags:=ttempinfoaccessor.gettempinfoflags(entry^.tempinfo);
|
|
tempinfo_flags_map.add(entry);
|
|
end
|
|
else
|
|
begin
|
|
{$ifdef EXTDEBUG}
|
|
comment(V_Debug,'ignoring node');
|
|
{$endif EXTDEBUG}
|
|
end;
|
|
end;
|
|
else
|
|
;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.store_tempflags;
|
|
var
|
|
nodeset : THashSet;
|
|
begin
|
|
if assigned(tempinfo_flags_map) then
|
|
internalerror(2020040601);
|
|
{$ifdef EXTDEBUG}
|
|
comment(V_Debug,'storing temp nodes of '+procdef.mangledname);
|
|
{$endif EXTDEBUG}
|
|
tempinfo_flags_map:=tfplist.create;
|
|
nodeset:=THashSet.Create(32,false,false);
|
|
foreachnode(code,@store_node_tempflags,nodeset);
|
|
nodeset.free;
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.swap_tempflags;
|
|
var
|
|
entry : ptempinfo_flags_entry;
|
|
i : longint;
|
|
tempflags : ttempinfoflags;
|
|
begin
|
|
if not assigned(tempinfo_flags_map) then
|
|
exit;
|
|
for i:=0 to tempinfo_flags_map.count-1 do
|
|
begin
|
|
entry:=ptempinfo_flags_entry(tempinfo_flags_map[i]);
|
|
tempflags:=ttempinfoaccessor.gettempinfoflags(entry^.tempinfo);
|
|
ttempinfoaccessor.settempinfoflags(entry^.tempinfo,entry^.flags);
|
|
entry^.flags:=tempflags;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.apply_tempflags;
|
|
begin
|
|
if tempflags_swapped then
|
|
internalerror(2020040602);
|
|
swap_tempflags;
|
|
tempflags_swapped:=true;
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.reset_tempflags;
|
|
begin
|
|
if not tempflags_swapped then
|
|
internalerror(2020040603);
|
|
swap_tempflags;
|
|
tempflags_swapped:=false;
|
|
end;
|
|
|
|
|
|
{$ifdef DEBUG_NODE_XML}
|
|
procedure tcgprocinfo.XMLPrintProc(FirstHalf: Boolean);
|
|
var
|
|
T: Text;
|
|
W: Word;
|
|
syssym: tsyssym;
|
|
separate : boolean;
|
|
|
|
procedure PrintType(Flag: string);
|
|
begin
|
|
if df_generic in procdef.defoptions then
|
|
Write(T, ' type="generic ', Flag, '"')
|
|
else
|
|
Write(T, ' type="', Flag, '"');
|
|
end;
|
|
|
|
procedure PrintOption(Flag: string);
|
|
begin
|
|
WriteLn(T, PrintNodeIndention, '<option>', Flag, '</option>');
|
|
end;
|
|
|
|
begin
|
|
if current_module.ppxfilefail then
|
|
Exit;
|
|
|
|
Assign(T, current_module.ppxfilename);
|
|
{$push} {$I-}
|
|
Append(T);
|
|
if IOResult <> 0 then
|
|
begin
|
|
Message1(exec_e_cant_create_archivefile,current_module.ppxfilename);
|
|
current_module.ppxfilefail := True;
|
|
Exit;
|
|
end;
|
|
{$pop}
|
|
|
|
separate := (df_generic in procdef.defoptions);
|
|
|
|
{ First half prints the header and the nodes as a "code" tag }
|
|
if FirstHalf or separate then
|
|
begin
|
|
Write(T, PrintNodeIndention, '<subroutine');
|
|
{ Check to see if the procedure is a class or object method }
|
|
if Assigned(procdef.struct) then
|
|
begin
|
|
if Assigned(procdef.struct.objrealname) then
|
|
Write(T, ' struct="', SanitiseXMLString(procdef.struct.objrealname^), '"')
|
|
else
|
|
Write(T, ' struct="<NULL>"');
|
|
end;
|
|
case procdef.proctypeoption of
|
|
potype_none:
|
|
{ Do nothing - should this be an internal error though? };
|
|
potype_procedure,
|
|
potype_function:
|
|
if po_classmethod in procdef.procoptions then
|
|
begin
|
|
if po_staticmethod in procdef.procoptions then
|
|
PrintType('static class method')
|
|
else
|
|
PrintType('class method');
|
|
end
|
|
else if df_generic in procdef.defoptions then
|
|
Write(T, ' type="generic"');
|
|
potype_proginit,
|
|
potype_unitinit:
|
|
PrintType('initialization');
|
|
potype_unitfinalize:
|
|
PrintType('finalization');
|
|
potype_constructor:
|
|
PrintType('constructor');
|
|
potype_destructor:
|
|
PrintType('destructor');
|
|
potype_operator:
|
|
PrintType('operator');
|
|
potype_class_constructor:
|
|
PrintType('class constructor');
|
|
potype_class_destructor:
|
|
PrintType('class destructor');
|
|
potype_propgetter:
|
|
PrintType('dispinterface getter');
|
|
potype_propsetter:
|
|
PrintType('dispinterface setter');
|
|
potype_exceptfilter:
|
|
PrintType('except filter');
|
|
potype_mainstub:
|
|
PrintType('main stub');
|
|
potype_libmainstub:
|
|
PrintType('library main stub');
|
|
potype_pkgstub:
|
|
PrintType('package stub');
|
|
end;
|
|
|
|
Write(T, ' name="', SanitiseXMLString(procdef.customprocname([pno_showhidden, pno_noclassmarker])), '"');
|
|
if (po_hascallingconvention in procdef.procoptions) or (procdef.proccalloption <> pocall_default) then
|
|
Write(T, ' convention="', proccalloptionStr[procdef.proccalloption], '"');
|
|
WriteLn(T, '>');
|
|
|
|
PrintNodeIndent;
|
|
|
|
if Assigned(procdef.returndef) and not is_void(procdef.returndef) then
|
|
WriteLn(T, PrintNodeIndention, '<returndef>', SanitiseXMLString(procdef.returndef.typesymbolprettyname), '</returndef>');
|
|
|
|
if po_reintroduce in procdef.procoptions then
|
|
PrintOption('reintroduce');
|
|
if po_virtualmethod in procdef.procoptions then
|
|
PrintOption('virtual');
|
|
if po_finalmethod in procdef.procoptions then
|
|
PrintOption('final');
|
|
if po_overridingmethod in procdef.procoptions then
|
|
PrintOption('override');
|
|
if po_overload in procdef.procoptions then
|
|
PrintOption('overload');
|
|
if po_compilerproc in procdef.procoptions then
|
|
PrintOption('compilerproc');
|
|
if po_assembler in procdef.procoptions then
|
|
PrintOption('assembler');
|
|
if po_nostackframe in procdef.procoptions then
|
|
PrintOption('nostackframe');
|
|
if po_inline in procdef.procoptions then
|
|
PrintOption('inline');
|
|
if po_noreturn in procdef.procoptions then
|
|
PrintOption('noreturn');
|
|
if po_noinline in procdef.procoptions then
|
|
PrintOption('noinline');
|
|
end;
|
|
|
|
if Assigned(Code) then
|
|
begin
|
|
if FirstHalf then
|
|
WriteLn(T, PrintNodeIndention, '<code>')
|
|
else
|
|
begin
|
|
WriteLn(T); { Line for spacing }
|
|
WriteLn(T, PrintNodeIndention, '<firstpass>');
|
|
end;
|
|
|
|
PrintNodeIndent;
|
|
XMLPrintNode(T, Code);
|
|
PrintNodeUnindent;
|
|
|
|
if FirstHalf then
|
|
WriteLn(T, PrintNodeIndention, '</code>')
|
|
else
|
|
WriteLn(T, PrintNodeIndention, '</firstpass>');
|
|
end
|
|
else { Code=Nil }
|
|
begin
|
|
{ Don't print anything for second half - if there's no code, there's no firstpass }
|
|
if FirstHalf then
|
|
WriteLn(T, PrintNodeIndention, '<code />');
|
|
end;
|
|
|
|
{ Print footer only for second half }
|
|
if (not FirstHalf) or separate then
|
|
begin
|
|
PrintNodeUnindent;
|
|
WriteLn(T, PrintNodeIndention, '</subroutine>');
|
|
WriteLn(T); { Line for spacing }
|
|
end;
|
|
|
|
Close(T);
|
|
end;
|
|
{$endif DEBUG_NODE_XML}
|
|
|
|
procedure tcgprocinfo.generate_code_tree;
|
|
var
|
|
hpi : tcgprocinfo;
|
|
begin
|
|
{ generate code for this procedure }
|
|
generate_code;
|
|
{ process nested procedures }
|
|
hpi:=tcgprocinfo(get_first_nestedproc);
|
|
while assigned(hpi) do
|
|
begin
|
|
if not (df_generic in hpi.procdef.defoptions) then
|
|
hpi.generate_code_tree;
|
|
hpi:=tcgprocinfo(hpi.next);
|
|
end;
|
|
resetprocdef;
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.generate_code_exceptfilters;
|
|
var
|
|
hpi : tcgprocinfo;
|
|
begin
|
|
hpi:=tcgprocinfo(get_first_nestedproc);
|
|
while assigned(hpi) do
|
|
begin
|
|
if hpi.procdef.proctypeoption=potype_exceptfilter then
|
|
begin
|
|
hpi.apply_tempflags;
|
|
generate_exceptfilter(hpi);
|
|
hpi.reset_tempflags;
|
|
end;
|
|
hpi:=tcgprocinfo(hpi.next);
|
|
end;
|
|
end;
|
|
|
|
{ For SEH, the code from 'finally' blocks must be put into a separate procedures,
|
|
which can be called by OS during stack unwind. This resembles nested procedures,
|
|
but finalizer procedures do not have their own local variables and work directly
|
|
with the stack frame of parent. In particular, the tempgen must be shared, so
|
|
1) finalizer procedure is able to finalize temps of the parent,
|
|
2) if the finalizer procedure is complex enough to need its own temps, they are
|
|
allocated in stack frame of parent, so second-level finalizer procedures are
|
|
not needed.
|
|
|
|
Due to requirement of shared tempgen we cannot process finalizer as a regular nested
|
|
procedure (after the parent) and have to do it inline.
|
|
This is called by platform-specific tryfinallynodes during pass2.
|
|
Here we put away the codegen (which carries the register allocator state), process
|
|
the 'nested' procedure, then restore previous cg and continue processing the parent
|
|
procedure. generate_code() will create another cg, but not another tempgen because
|
|
setup_tempgen() is not called for potype_exceptfilter procedures. }
|
|
|
|
procedure tcgprocinfo.generate_exceptfilter(nestedpi: tcgprocinfo);
|
|
var
|
|
saved_cg: tcg;
|
|
saved_hlcg: thlcgobj;
|
|
{$ifdef cpu64bitalu}
|
|
saved_cg128 : tcg128;
|
|
{$else cpu64bitalu}
|
|
saved_cg64 : tcg64;
|
|
{$endif cpu64bitalu}
|
|
begin
|
|
if nestedpi.procdef.proctypeoption<>potype_exceptfilter then
|
|
InternalError(201201141);
|
|
{ flush code generated this far }
|
|
aktproccode.concatlist(current_asmdata.CurrAsmList);
|
|
{ save the codegen }
|
|
saved_cg:=cg;
|
|
saved_hlcg:=hlcg;
|
|
cg:=nil;
|
|
hlcg:=nil;
|
|
{$ifdef cpu64bitalu}
|
|
saved_cg128:=cg128;
|
|
cg128:=nil;
|
|
{$else cpu64bitalu}
|
|
saved_cg64:=cg64;
|
|
cg64:=nil;
|
|
{$endif cpu64bitalu}
|
|
nestedpi.generate_code;
|
|
{ prevents generating code the second time when processing nested procedures }
|
|
nestedpi.resetprocdef;
|
|
cg:=saved_cg;
|
|
hlcg:=saved_hlcg;
|
|
{$ifdef cpu64bitalu}
|
|
cg128:=saved_cg128;
|
|
{$else cpu64bitalu}
|
|
cg64:=saved_cg64;
|
|
{$endif cpu64bitalu}
|
|
add_reg_instruction_hook:=@cg.add_reg_instruction;
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.generate_exit_label(list: tasmlist);
|
|
begin
|
|
hlcg.a_label(list,CurrExitLabel);
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.convert_captured_syms;
|
|
var
|
|
hpi : tcgprocinfo;
|
|
old_current_procinfo : tprocinfo;
|
|
begin
|
|
{ do the conversion only if there haven't been any errors so far }
|
|
if ErrorCount<>0 then
|
|
exit;
|
|
old_current_procinfo:=current_procinfo;
|
|
current_procinfo:=self;
|
|
{ process nested procedures }
|
|
hpi:=tcgprocinfo(get_first_nestedproc);
|
|
while assigned(hpi) do
|
|
begin
|
|
hpi.convert_captured_syms;
|
|
hpi:=tcgprocinfo(hpi.next);
|
|
end;
|
|
{ convert the captured symbols for this routine }
|
|
if assigned(code) then
|
|
procdefutil.convert_captured_syms(procdef,code);
|
|
current_procinfo:=old_current_procinfo;
|
|
end;
|
|
|
|
|
|
procedure TCGProcinfo.CreateInlineInfo;
|
|
begin
|
|
new(procdef.inlininginfo);
|
|
procdef.inlininginfo^.code:=code.getcopy;
|
|
procdef.inlininginfo^.flags:=flags;
|
|
{ The blocknode needs to set an exit label }
|
|
if procdef.inlininginfo^.code.nodetype=blockn then
|
|
include(procdef.inlininginfo^.code.flags,nf_block_with_exit);
|
|
procdef.has_inlininginfo:=true;
|
|
export_local_ref_syms;
|
|
export_local_ref_defs;
|
|
end;
|
|
|
|
procedure searchthreadvar(p: TObject; arg: pointer);
|
|
var
|
|
i : longint;
|
|
pd : tprocdef;
|
|
begin
|
|
case tsym(p).typ of
|
|
staticvarsym :
|
|
begin
|
|
{ local (procedure or unit) variables only need finalization
|
|
if they are used
|
|
}
|
|
if (vo_is_thread_var in tstaticvarsym(p).varoptions) and
|
|
((tstaticvarsym(p).refs>0) or
|
|
{ global (unit) variables always need finalization, since
|
|
they may also be used in another unit
|
|
}
|
|
(tstaticvarsym(p).owner.symtabletype=globalsymtable)) and
|
|
(
|
|
(tstaticvarsym(p).varspez<>vs_const) or
|
|
(vo_force_finalize in tstaticvarsym(p).varoptions)
|
|
) and
|
|
not(vo_is_funcret in tstaticvarsym(p).varoptions) and
|
|
not(vo_is_external in tstaticvarsym(p).varoptions) and
|
|
is_managed_type(tstaticvarsym(p).vardef) then
|
|
include(current_procinfo.flags,pi_uses_threadvar);
|
|
end;
|
|
procsym :
|
|
begin
|
|
for i:=0 to tprocsym(p).ProcdefList.Count-1 do
|
|
begin
|
|
pd:=tprocdef(tprocsym(p).ProcdefList[i]);
|
|
if assigned(pd.localst) and
|
|
(pd.procsym=tprocsym(p)) and
|
|
(pd.localst.symtabletype<>staticsymtable) then
|
|
pd.localst.SymList.ForEachCall(@searchthreadvar,arg);
|
|
end;
|
|
end;
|
|
else
|
|
;
|
|
end;
|
|
end;
|
|
|
|
|
|
function searchusercode(var n: tnode; arg: pointer): foreachnoderesult;
|
|
begin
|
|
if nf_usercode_entry in n.flags then
|
|
begin
|
|
pnode(arg)^:=n;
|
|
result:=fen_norecurse_true
|
|
end
|
|
else
|
|
result:=fen_false;
|
|
end;
|
|
|
|
|
|
function TCGProcinfo.GetUserCode : tnode;
|
|
var
|
|
n : tnode;
|
|
begin
|
|
n:=nil;
|
|
foreachnodestatic(code,@searchusercode,@n);
|
|
if not(assigned(n)) then
|
|
internalerror(2013111004);
|
|
result:=n;
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.generate_code;
|
|
|
|
procedure check_for_threadvars_in_initfinal;
|
|
begin
|
|
if current_procinfo.procdef.proctypeoption=potype_unitfinalize then
|
|
begin
|
|
{ this is also used for initialization of variables in a
|
|
program which does not have a globalsymtable }
|
|
if assigned(current_module.globalsymtable) then
|
|
TSymtable(current_module.globalsymtable).SymList.ForEachCall(@searchthreadvar,nil);
|
|
TSymtable(current_module.localsymtable).SymList.ForEachCall(@searchthreadvar,nil);
|
|
end;
|
|
end;
|
|
|
|
function heuristics_favors_autoinlining(code: tnode): boolean;
|
|
var
|
|
complexityAvail : integer;
|
|
begin
|
|
{ rough approximation if we should auto inline:
|
|
- if the tree is simple enough
|
|
- if the tree is not too big
|
|
A bigger tree which is simpler might be autoinlined otoh
|
|
a smaller and complexer tree as well: so we use the sum of
|
|
both measures here }
|
|
|
|
{ This is a shortcutted version of
|
|
"result:=node_count(code)+node_complexity(code)<=25". }
|
|
complexityAvail:=25-node_complexity(code);
|
|
result:=(complexityAvail>0) and (node_count(code,complexityAvail+1)<=dword(complexityAvail));
|
|
end;
|
|
|
|
var
|
|
old_current_procinfo : tprocinfo;
|
|
oldmaxfpuregisters : longint;
|
|
oldfilepos : tfileposinfo;
|
|
old_current_structdef : tabstractrecorddef;
|
|
oldswitches : tlocalswitches;
|
|
templist : TAsmList;
|
|
headertai : tai;
|
|
|
|
procedure delete_marker(anode: tasmnode);
|
|
var
|
|
ai: tai;
|
|
begin
|
|
if assigned(anode) then
|
|
begin
|
|
ai:=anode.currenttai;
|
|
if assigned(ai) then
|
|
begin
|
|
aktproccode.remove(ai);
|
|
ai.free;
|
|
anode.currenttai:=nil;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
{ the initialization procedure can be empty, then we
|
|
don't need to generate anything. When it was an empty
|
|
procedure there would be at least a blocknode }
|
|
if not assigned(code) then
|
|
begin
|
|
{$ifdef DEBUG_NODE_XML}
|
|
{ Print out nodes as they appear after the first pass }
|
|
XMLPrintProc(True);
|
|
XMLPrintProc(False);
|
|
{$endif DEBUG_NODE_XML}
|
|
exit;
|
|
end;
|
|
|
|
{ We need valid code }
|
|
if Errorcount<>0 then
|
|
exit;
|
|
|
|
{ No code can be generated for generic template }
|
|
if (df_generic in procdef.defoptions) then
|
|
internalerror(200511152);
|
|
|
|
{ For regular procedures the RA and Tempgen shall not be available yet,
|
|
but exception filters reuse Tempgen of parent }
|
|
if assigned(tg)<>(procdef.proctypeoption=potype_exceptfilter) then
|
|
internalerror(200309201);
|
|
|
|
old_current_procinfo:=current_procinfo;
|
|
oldfilepos:=current_filepos;
|
|
old_current_structdef:=current_structdef;
|
|
oldmaxfpuregisters:=current_settings.maxfpuregisters;
|
|
|
|
current_procinfo:=self;
|
|
current_filepos:=entrypos;
|
|
current_structdef:=procdef.struct;
|
|
|
|
{ store start of user code, it must be a block node, it will be used later one to
|
|
check variable lifeness }
|
|
include(code.flags,nf_usercode_entry);
|
|
|
|
{ add wrapping code if necessary (initialization of typed constants on
|
|
some platforms, initing of local variables and out parameters with
|
|
trashing values, ...) }
|
|
{ init/final code must be wrapped later (after code for main proc body
|
|
has been generated) }
|
|
if not(current_procinfo.procdef.proctypeoption in [potype_unitinit,potype_unitfinalize]) then
|
|
code:=cnodeutils.wrap_proc_body(procdef,code);
|
|
|
|
{ automatic inlining? }
|
|
if (cs_opt_autoinline in current_settings.optimizerswitches) and
|
|
not(po_noinline in procdef.procoptions) and
|
|
{ no inlining yet? }
|
|
not(procdef.has_inlininginfo) and not(has_nestedprocs) and
|
|
not(procdef.proctypeoption in [potype_proginit,potype_unitinit,potype_unitfinalize,potype_constructor,
|
|
potype_destructor,potype_class_constructor,potype_class_destructor]) and
|
|
((procdef.procoptions*[po_exports,po_external,po_interrupt,po_virtualmethod,po_iocheck])=[]) and
|
|
(not(procdef.proccalloption in [pocall_safecall])) and
|
|
heuristics_favors_autoinlining(code) then
|
|
begin
|
|
{ Can we inline this procedure? }
|
|
if checknodeinlining(procdef) then
|
|
begin
|
|
Message1(cg_d_autoinlining,procdef.GetTypeName);
|
|
include(procdef.procoptions,po_inline);
|
|
CreateInlineInfo;
|
|
end;
|
|
end;
|
|
|
|
templist:=TAsmList.create;
|
|
|
|
{ add parast/localst to symtablestack }
|
|
add_to_symtablestack;
|
|
|
|
{ clear register count }
|
|
procdef.localst.SymList.ForEachCall(@clearrefs,nil);
|
|
procdef.parast.SymList.ForEachCall(@clearrefs,nil);
|
|
|
|
{ there's always a call to FPC_INITIALIZEUNITS/FPC_DO_EXIT in the main program }
|
|
if (procdef.localst.symtablelevel=main_program_level) and
|
|
(not current_module.is_unit) then
|
|
begin
|
|
include(flags,pi_do_call);
|
|
{ the main program never returns due to the do_exit call }
|
|
if not(current_module.islibrary) and (procdef.proctypeoption=potype_proginit) then
|
|
include(procdef.procoptions,po_noreturn);
|
|
end;
|
|
|
|
{ set implicit_finally flag when there are locals/paras to be finalized }
|
|
if not(po_assembler in current_procinfo.procdef.procoptions) then
|
|
begin
|
|
procdef.parast.SymList.ForEachCall(@check_finalize_paras,nil);
|
|
procdef.localst.SymList.ForEachCall(@check_finalize_locals,nil);
|
|
end;
|
|
|
|
{$ifdef SUPPORT_SAFECALL}
|
|
{ set implicit_finally flag for if procedure is safecall }
|
|
if (tf_safecall_exceptions in target_info.flags) and
|
|
(procdef.proccalloption=pocall_safecall) then
|
|
include(flags, pi_needs_implicit_finally);
|
|
{$endif}
|
|
{$ifdef DEBUG_NODE_XML}
|
|
{ Print out nodes as they appear after the first pass }
|
|
XMLPrintProc(True);
|
|
{$endif DEBUG_NODE_XML}
|
|
{ firstpass everything }
|
|
flowcontrol:=[];
|
|
do_firstpass(code);
|
|
|
|
{$if defined(i386) or defined(i8086)}
|
|
if node_resources_fpu(code)>0 then
|
|
include(flags,pi_uses_fpu);
|
|
{$endif i386 or i8086}
|
|
|
|
{ Print the node to tree.log }
|
|
if paraprintnodetree <> 0 then
|
|
printproc( 'after the firstpass');
|
|
|
|
OptimizeNodeTree;
|
|
|
|
{ unit static/global symtables might contain threadvars which are not explicitly used but which might
|
|
require a tls register, so check for such variables }
|
|
check_for_threadvars_in_initfinal;
|
|
|
|
{ add implicit entry and exit code }
|
|
add_entry_exit_code;
|
|
|
|
{ only do secondpass if there are no errors }
|
|
if (ErrorCount<>0) then
|
|
begin
|
|
{$ifdef DEBUG_NODE_XML}
|
|
{ Print out nodes as they appear after the first pass }
|
|
XMLPrintProc(False);
|
|
{$endif DEBUG_NODE_XML}
|
|
end
|
|
else
|
|
begin
|
|
create_hlcodegen;
|
|
|
|
setup_eh;
|
|
|
|
if (procdef.proctypeoption<>potype_exceptfilter) then
|
|
setup_tempgen;
|
|
|
|
{ Create register allocator, must come after framepointer is known }
|
|
hlcg.init_register_allocators;
|
|
|
|
generate_parameter_info;
|
|
|
|
{ allocate got register if needed }
|
|
allocate_got_register(aktproccode);
|
|
|
|
{ allocate got register if needed }
|
|
allocate_tls_register(aktproccode);
|
|
|
|
{ Allocate space in temp/registers for parast and localst }
|
|
current_filepos:=entrypos;
|
|
gen_alloc_symtable(aktproccode,procdef,procdef.parast);
|
|
gen_alloc_symtable(aktproccode,procdef,procdef.localst);
|
|
|
|
{ Store temp offset for information about 'real' temps }
|
|
tempstart:=tg.lasttemp;
|
|
|
|
{ Generate code to load register parameters in temps and insert local
|
|
copies for values parameters. This must be done before the code for the
|
|
body is generated because the localloc is updated.
|
|
Note: The generated code will be inserted after the code generation of
|
|
the body is finished, because only then the position is known }
|
|
current_filepos:=entrypos;
|
|
|
|
hlcg.gen_load_para_value(templist);
|
|
|
|
{ caller paraloc info is also necessary in the stackframe_entry
|
|
code of the ppc (and possibly other processors) }
|
|
procdef.init_paraloc_info(callerside);
|
|
|
|
CalcExecutionWeights(code);
|
|
|
|
{ Print the node to tree.log }
|
|
if paraprintnodetree <> 0 then
|
|
printproc( 'right before code generation');
|
|
|
|
{$ifdef DEBUG_NODE_XML}
|
|
{ Print out nodes as they appear after the first pass }
|
|
XMLPrintProc(False);
|
|
{$endif DEBUG_NODE_XML}
|
|
|
|
{ generate code for the node tree }
|
|
do_secondpass(code);
|
|
aktproccode.concatlist(current_asmdata.CurrAsmList);
|
|
|
|
{ The position of the loadpara_asmnode is now known }
|
|
aktproccode.insertlistafter(loadpara_asmnode.currenttai,templist);
|
|
|
|
oldswitches:=current_settings.localswitches;
|
|
|
|
{ first generate entry and initialize code with the correct
|
|
position and switches }
|
|
current_filepos:=entrypos;
|
|
current_settings.localswitches:=entryswitches;
|
|
|
|
cg.set_regalloc_live_range_direction(rad_backwards);
|
|
|
|
hlcg.gen_entry_code(templist);
|
|
aktproccode.insertlistafter(entry_asmnode.currenttai,templist);
|
|
hlcg.gen_initialize_code(templist);
|
|
aktproccode.insertlistafter(init_asmnode.currenttai,templist);
|
|
|
|
{ now generate finalize and exit code with the correct position
|
|
and switches }
|
|
current_filepos:=exitpos;
|
|
current_settings.localswitches:=exitswitches;
|
|
|
|
cg.set_regalloc_live_range_direction(rad_forward);
|
|
|
|
if assigned(finalize_procinfo) then
|
|
begin
|
|
if target_info.system in [system_aarch64_win64] then
|
|
tcgprocinfo(finalize_procinfo).store_tempflags
|
|
else
|
|
generate_exceptfilter(tcgprocinfo(finalize_procinfo));
|
|
end
|
|
else if not temps_finalized then
|
|
begin
|
|
hlcg.gen_finalize_code(templist);
|
|
{ the finalcode must be concated if there was no position available,
|
|
using insertlistafter will result in an insert at the start
|
|
when currentai=nil }
|
|
aktproccode.concatlist(templist);
|
|
end;
|
|
{ insert exit label at the correct position }
|
|
generate_exit_label(templist);
|
|
if assigned(exitlabel_asmnode.currenttai) then
|
|
aktproccode.insertlistafter(exitlabel_asmnode.currenttai,templist)
|
|
else
|
|
aktproccode.concatlist(templist);
|
|
{ exit code }
|
|
hlcg.gen_exit_code(templist);
|
|
aktproccode.concatlist(templist);
|
|
|
|
{ reset switches }
|
|
current_settings.localswitches:=oldswitches;
|
|
|
|
{ generate symbol and save end of header position }
|
|
current_filepos:=entrypos;
|
|
hlcg.gen_proc_symbol(templist);
|
|
headertai:=tai(templist.last);
|
|
{ insert symbol }
|
|
aktproccode.insertlist(templist);
|
|
|
|
{ Free space in temp/registers for parast and localst, must be
|
|
done after gen_entry_code }
|
|
current_filepos:=exitpos;
|
|
|
|
{ make sure the got/pic register doesn't get freed in the }
|
|
{ middle of a loop }
|
|
if (tf_pic_uses_got in target_info.flags) and
|
|
(pi_needs_got in flags) and
|
|
(got<>NR_NO) then
|
|
cg.a_reg_sync(aktproccode,got);
|
|
|
|
if (pi_needs_tls in flags) and
|
|
(tlsoffset<>NR_NO) then
|
|
cg.a_reg_sync(aktproccode,tlsoffset);
|
|
|
|
gen_free_symtable(aktproccode,procdef.localst);
|
|
gen_free_symtable(aktproccode,procdef.parast);
|
|
|
|
{ add code that will load the return value, this is not done
|
|
for assembler routines when they didn't reference the result
|
|
variable }
|
|
hlcg.gen_load_return_value(templist);
|
|
aktproccode.concatlist(templist);
|
|
|
|
{ Already reserve all registers for stack checking code and
|
|
generate the call to the helper function }
|
|
if not(tf_no_generic_stackcheck in target_info.flags) and
|
|
(cs_check_stack in entryswitches) and
|
|
not(po_assembler in procdef.procoptions) and
|
|
(procdef.proctypeoption<>potype_proginit) then
|
|
begin
|
|
current_filepos:=entrypos;
|
|
hlcg.gen_stack_check_call(templist);
|
|
aktproccode.insertlistafter(stackcheck_asmnode.currenttai,templist);
|
|
end;
|
|
|
|
{ this code (got loading) comes before everything which has }
|
|
{ already been generated, so reset the info about already }
|
|
{ backwards extended registers (so their live range can be }
|
|
{ extended backwards even further if needed) }
|
|
{ This code must be }
|
|
{ a) generated after do_secondpass has been called }
|
|
{ (because pi_needs_got may be set there) }
|
|
{ b) generated before register allocation, because the }
|
|
{ got/pic register can be a virtual one }
|
|
{ c) inserted before the entry code, because the entry }
|
|
{ code may need global symbols such as init rtti }
|
|
{ d) inserted after the stackframe allocation, because }
|
|
{ this register may have to be spilled }
|
|
cg.set_regalloc_live_range_direction(rad_backwards_reinit);
|
|
current_filepos:=entrypos;
|
|
{ load got if necessary }
|
|
cg.g_maybe_got_init(templist);
|
|
aktproccode.insertlistafter(headertai,templist);
|
|
|
|
{ init tls if needed }
|
|
cg.g_maybe_tls_init(templist);
|
|
aktproccode.insertlistafter(stackcheck_asmnode.currenttai,templist);
|
|
|
|
{ re-enable if more code at the end is ever generated here
|
|
cg.set_regalloc_live_range_direction(rad_forward);
|
|
}
|
|
|
|
|
|
{$ifndef NoOpt}
|
|
{$ifndef i386}
|
|
if (cs_opt_scheduler in current_settings.optimizerswitches) and
|
|
{ do not optimize pure assembler procedures }
|
|
not(pi_is_assembler in flags) then
|
|
preregallocschedule(aktproccode);
|
|
{$endif i386}
|
|
{$endif NoOpt}
|
|
|
|
{ The procedure body is finished, we can now
|
|
allocate the registers }
|
|
cg.do_register_allocation(aktproccode,headertai);
|
|
|
|
{ translate imag. register to their real counter parts
|
|
this is necessary for debuginfo and verbose assembler output
|
|
when SSA will be implemented, this will be more complicated because we've to
|
|
maintain location lists }
|
|
procdef.parast.SymList.ForEachCall(@translate_registers,templist);
|
|
procdef.localst.SymList.ForEachCall(@translate_registers,templist);
|
|
if (tf_pic_uses_got in target_info.flags) and (pi_needs_got in flags) and
|
|
not(cs_no_regalloc in current_settings.globalswitches) and
|
|
(got<>NR_NO) then
|
|
cg.translate_register(got);
|
|
|
|
{ Add save and restore of used registers }
|
|
current_filepos:=entrypos;
|
|
gen_save_used_regs(templist);
|
|
{ Remember the last instruction of register saving block
|
|
(may be =nil for e.g. assembler procedures) }
|
|
endprologue_ai:=templist.last;
|
|
aktproccode.insertlistafter(headertai,templist);
|
|
current_filepos:=exitpos;
|
|
gen_restore_used_regs(aktproccode);
|
|
{ We know the size of the stack, now we can generate the
|
|
parameter that is passed to the stack checking code }
|
|
if not(tf_no_generic_stackcheck in target_info.flags) and
|
|
(cs_check_stack in entryswitches) and
|
|
not(po_assembler in procdef.procoptions) and
|
|
(procdef.proctypeoption<>potype_proginit) then
|
|
begin
|
|
current_filepos:=entrypos;
|
|
hlcg.gen_stack_check_size_para(templist);
|
|
aktproccode.insertlistafter(stackcheck_asmnode.currenttai,templist)
|
|
end;
|
|
|
|
current_procinfo.set_eh_info;
|
|
|
|
{ Add entry code (stack allocation) after header }
|
|
current_filepos:=entrypos;
|
|
gen_proc_entry_code(templist);
|
|
aktproccode.insertlistafter(headertai,templist);
|
|
{$ifdef SUPPORT_SAFECALL}
|
|
{ Set return value of safecall procedure if implicit try/finally blocks are disabled }
|
|
if not (cs_implicit_exceptions in current_settings.moduleswitches) and
|
|
(tf_safecall_exceptions in target_info.flags) and
|
|
(procdef.proccalloption=pocall_safecall) then
|
|
cg.a_load_const_reg(aktproccode,OS_ADDR,0,NR_FUNCTION_RETURN_REG);
|
|
{$endif}
|
|
{ Add exit code at the end }
|
|
current_filepos:=exitpos;
|
|
gen_proc_exit_code(templist);
|
|
aktproccode.concatlist(templist);
|
|
|
|
{ check if the implicit finally has been generated. The flag
|
|
should already be set in pass1 }
|
|
if (cs_implicit_exceptions in current_settings.moduleswitches) and
|
|
not(procdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) and
|
|
(pi_needs_implicit_finally in flags) and
|
|
not(pi_has_implicit_finally in flags) and
|
|
not(target_info.system in systems_garbage_collected_managed_types) then
|
|
internalerror(200405231);
|
|
|
|
{ sanity check }
|
|
if not(assigned(current_procinfo.procdef.personality)) and
|
|
(tf_use_psabieh in target_info.flags) and
|
|
((pi_uses_exceptions in flags) or
|
|
((cs_implicit_exceptions in current_settings.moduleswitches) and
|
|
(pi_needs_implicit_finally in flags))) then
|
|
Internalerror(2019021005);
|
|
|
|
{ Position markers are only used to insert additional code after the secondpass
|
|
and before this point. They are of no use in optimizer. Instead of checking and
|
|
ignoring all over the optimizer, just remove them here. }
|
|
delete_marker(entry_asmnode);
|
|
delete_marker(loadpara_asmnode);
|
|
delete_marker(exitlabel_asmnode);
|
|
delete_marker(stackcheck_asmnode);
|
|
delete_marker(init_asmnode);
|
|
|
|
{$ifndef NoOpt}
|
|
if not(cs_no_regalloc in current_settings.globalswitches) then
|
|
begin
|
|
if (cs_opt_level1 in current_settings.optimizerswitches) and
|
|
{ do not optimize pure assembler procedures }
|
|
not(pi_is_assembler in flags) then
|
|
optimize(aktproccode);
|
|
{$ifndef i386}
|
|
{ schedule after assembler optimization, it could have brought up
|
|
new schedule possibilities }
|
|
if (cs_opt_scheduler in current_settings.optimizerswitches) and
|
|
{ do not optimize pure assembler procedures }
|
|
not(pi_is_assembler in flags) then
|
|
preregallocschedule(aktproccode);
|
|
{$endif i386}
|
|
end;
|
|
{$endif NoOpt}
|
|
|
|
{ Perform target-specific processing if necessary }
|
|
postprocess_code;
|
|
|
|
{ Add end symbol and debug info }
|
|
{ this must be done after the pcrelativedata is appended else the distance calculation of
|
|
insertpcrelativedata will be wrong, further the pc indirect data is part of the procedure
|
|
so it should be inserted before the end symbol (FK)
|
|
}
|
|
current_filepos:=exitpos;
|
|
hlcg.gen_proc_symbol_end(templist);
|
|
aktproccode.concatlist(templist);
|
|
|
|
{ insert line debuginfo }
|
|
if (cs_debuginfo in current_settings.moduleswitches) or
|
|
(cs_use_lineinfo in current_settings.globalswitches) then
|
|
begin
|
|
{ We only do this after the code generated because
|
|
otherwise for-loop counters moved to the struct cause
|
|
errors. And doing it before optimisation passes have run
|
|
causes problems when they manually look up symbols
|
|
like result and self (nutils.load_self_node etc). Still
|
|
do it nevertheless to to assist debug info generation
|
|
(hide original symbols, add absolutevarsyms that redirect
|
|
to their new locations in the parentfpstruct) }
|
|
if assigned(current_procinfo.procdef.parentfpstruct) then
|
|
redirect_parentfpstruct_local_syms(current_procinfo.procdef);
|
|
current_debuginfo.insertlineinfo(aktproccode);
|
|
end;
|
|
|
|
finish_eh;
|
|
|
|
hlcg.record_generated_code_for_procdef(current_procinfo.procdef,aktproccode,aktlocaldata);
|
|
|
|
{ now generate code for any exception filters (they need the tempgen) }
|
|
generate_code_exceptfilters;
|
|
|
|
{ only now we can remove the temps }
|
|
if (procdef.proctypeoption<>potype_exceptfilter) then
|
|
begin
|
|
tg.resettempgen;
|
|
tg.free;
|
|
tg:=nil;
|
|
end;
|
|
{ stop tempgen and ra }
|
|
hlcg.done_register_allocators;
|
|
destroy_hlcodegen;
|
|
end;
|
|
|
|
dfabuilder.free;
|
|
|
|
{ restore symtablestack }
|
|
remove_from_symtablestack;
|
|
|
|
{ restore }
|
|
templist.free;
|
|
current_settings.maxfpuregisters:=oldmaxfpuregisters;
|
|
current_filepos:=oldfilepos;
|
|
current_structdef:=old_current_structdef;
|
|
current_procinfo:=old_current_procinfo;
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.add_to_symtablestack;
|
|
begin
|
|
{ insert symtables for the class, but only if it is no nested function }
|
|
if assigned(procdef.struct) and
|
|
not(assigned(parent) and
|
|
assigned(parent.procdef) and
|
|
assigned(parent.procdef.struct)) then
|
|
push_nested_hierarchy(procdef.struct);
|
|
|
|
{ insert parasymtable in symtablestack when parsing
|
|
a function }
|
|
if procdef.parast.symtablelevel>=normal_function_level then
|
|
symtablestack.push(procdef.parast);
|
|
|
|
{ insert localsymtable, except for the main procedure
|
|
(in that case the localst is the unit's static symtable,
|
|
which is already on the stack) }
|
|
if procdef.localst.symtablelevel>=normal_function_level then
|
|
symtablestack.push(procdef.localst);
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.remove_from_symtablestack;
|
|
begin
|
|
{ remove localsymtable }
|
|
if procdef.localst.symtablelevel>=normal_function_level then
|
|
symtablestack.pop(procdef.localst);
|
|
|
|
{ remove parasymtable }
|
|
if procdef.parast.symtablelevel>=normal_function_level then
|
|
symtablestack.pop(procdef.parast);
|
|
|
|
{ remove symtables for the class, but only if it is no nested function }
|
|
if assigned(procdef.struct) and
|
|
not(assigned(parent) and
|
|
assigned(parent.procdef) and
|
|
assigned(parent.procdef.struct)) then
|
|
pop_nested_hierarchy(procdef.struct);
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.resetprocdef;
|
|
begin
|
|
{ remove code tree, if not inline procedure }
|
|
if assigned(code) then
|
|
begin
|
|
{ the inline procedure has already got a copy of the tree
|
|
stored in procdef.inlininginfo }
|
|
code.free;
|
|
code:=nil;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.parse_body;
|
|
var
|
|
old_current_procinfo : tprocinfo;
|
|
old_block_type : tblock_type;
|
|
st : TSymtable;
|
|
old_current_structdef: tabstractrecorddef;
|
|
old_current_genericdef,
|
|
old_current_specializedef: tstoreddef;
|
|
parentfpinitblock: tnode;
|
|
old_parse_generic: boolean;
|
|
recordtokens : boolean;
|
|
begin
|
|
old_current_procinfo:=current_procinfo;
|
|
old_block_type:=block_type;
|
|
old_current_structdef:=current_structdef;
|
|
old_current_genericdef:=current_genericdef;
|
|
old_current_specializedef:=current_specializedef;
|
|
old_parse_generic:=parse_generic;
|
|
|
|
current_procinfo:=self;
|
|
current_structdef:=procdef.struct;
|
|
|
|
|
|
{ check if the definitions of certain types are available which might not be available in older rtls and
|
|
which are assigned "on the fly" in types_dec }
|
|
{$if not defined(jvm) and not defined(wasm)}
|
|
if not assigned(rec_exceptaddr) then
|
|
Message1(cg_f_internal_type_not_found,'TEXCEPTADDR');
|
|
if not assigned(rec_tguid) then
|
|
Message1(cg_f_internal_type_not_found,'TGUID');
|
|
if not assigned(rec_jmp_buf) then
|
|
Message1(cg_f_internal_type_not_found,'JMP_BUF');
|
|
{$endif}
|
|
|
|
{ if the procdef is truly a generic (thus takes parameters itself) then
|
|
/that/ is our genericdef, not the - potentially - generic struct }
|
|
if procdef.is_generic then
|
|
begin
|
|
current_genericdef:=procdef;
|
|
parse_generic:=true;
|
|
end
|
|
else if assigned(current_structdef) and (df_generic in current_structdef.defoptions) then
|
|
begin
|
|
current_genericdef:=current_structdef;
|
|
parse_generic:=true;
|
|
end;
|
|
if assigned(current_structdef) and (df_specialization in current_structdef.defoptions) then
|
|
current_specializedef:=current_structdef;
|
|
|
|
{ calculate the lexical level }
|
|
if procdef.parast.symtablelevel>maxnesting then
|
|
Message(parser_e_too_much_lexlevel);
|
|
block_type:=bt_body;
|
|
|
|
{$ifdef state_tracking}
|
|
{ aktstate:=Tstate_storage.create;}
|
|
{$endif state_tracking}
|
|
|
|
{ allocate the symbol for this procedure }
|
|
alloc_proc_symbol(procdef);
|
|
|
|
{ add parast/localst to symtablestack }
|
|
add_to_symtablestack;
|
|
|
|
{ save entry info }
|
|
entrypos:=current_filepos;
|
|
entryswitches:=current_settings.localswitches;
|
|
|
|
recordtokens:=procdef.is_generic or
|
|
(
|
|
assigned(procdef.struct) and
|
|
(df_generic in procdef.struct.defoptions) and
|
|
assigned(procdef.owner) and
|
|
(procdef.owner.defowner=procdef.struct)
|
|
);
|
|
|
|
if recordtokens then
|
|
begin
|
|
{ start token recorder for generic template }
|
|
procdef.initgeneric;
|
|
current_scanner.startrecordtokens(procdef.generictokenbuf);
|
|
end;
|
|
|
|
{ parse the code ... }
|
|
code:=block(current_module.islibrary);
|
|
|
|
postprocess_capturer(self);
|
|
|
|
if recordtokens then
|
|
begin
|
|
{ stop token recorder for generic template }
|
|
current_scanner.stoprecordtokens;
|
|
|
|
{ Give an error for accesses in the static symtable that aren't visible
|
|
outside the current unit }
|
|
st:=procdef.owner;
|
|
while (st.symtabletype in [ObjectSymtable,recordsymtable]) do
|
|
st:=st.defowner.owner;
|
|
if (pi_uses_static_symtable in flags) and
|
|
(st.symtabletype<>staticsymtable) then
|
|
Message(parser_e_global_generic_references_static);
|
|
end;
|
|
|
|
{ save exit info }
|
|
exitswitches:=current_settings.localswitches;
|
|
exitpos:=last_endtoken_filepos;
|
|
|
|
{ the procedure is now defined }
|
|
procdef.forwarddef:=false;
|
|
procdef.is_implemented:=true;
|
|
|
|
if assigned(code) then
|
|
begin
|
|
{ get a better entry point }
|
|
entrypos:=code.fileinfo;
|
|
|
|
{ Finish type checking pass }
|
|
do_typecheckpass(code);
|
|
|
|
if assigned(procdef.parentfpinitblock) then
|
|
begin
|
|
if assigned(tblocknode(procdef.parentfpinitblock).left) then
|
|
begin
|
|
parentfpinitblock:=procdef.parentfpinitblock;
|
|
do_typecheckpass(parentfpinitblock);
|
|
procdef.parentfpinitblock:=parentfpinitblock;
|
|
end
|
|
end;
|
|
|
|
end;
|
|
|
|
{ Check for unused labels, forwards, symbols for procedures. Static
|
|
symtable is checked in pmodules.
|
|
The check must be done after the typecheckpass }
|
|
if (Errorcount=0) and
|
|
(tstoredsymtable(procdef.localst).symtabletype<>staticsymtable) then
|
|
begin
|
|
{ check if forwards are resolved }
|
|
tstoredsymtable(procdef.localst).check_forwards;
|
|
{ check if all labels are used }
|
|
tstoredsymtable(procdef.localst).checklabels;
|
|
{ check for unused symbols, but only if there is no asm block }
|
|
if not(pi_has_assembler_block in flags) then
|
|
begin
|
|
tstoredsymtable(procdef.localst).allsymbolsused;
|
|
tstoredsymtable(procdef.parast).allsymbolsused;
|
|
end;
|
|
end;
|
|
|
|
if (po_inline in procdef.procoptions) and
|
|
{ Can we inline this procedure? }
|
|
checknodeinlining(procdef) then
|
|
CreateInlineInfo;
|
|
|
|
{ Print the node to tree.log }
|
|
if paraprintnodetree <> 0 then
|
|
printproc( 'after parsing');
|
|
|
|
{$ifdef DEBUG_NODE_XML}
|
|
{ Methods of generic classes don't get any code generated, so output
|
|
the node tree here }
|
|
if (df_generic in procdef.defoptions) then
|
|
XMLPrintProc(True);
|
|
{$endif DEBUG_NODE_XML}
|
|
|
|
{ ... remove symbol tables }
|
|
remove_from_symtablestack;
|
|
|
|
{$ifdef state_tracking}
|
|
{ aktstate.destroy;}
|
|
{$endif state_tracking}
|
|
|
|
current_structdef:=old_current_structdef;
|
|
current_genericdef:=old_current_genericdef;
|
|
current_specializedef:=old_current_specializedef;
|
|
current_procinfo:=old_current_procinfo;
|
|
parse_generic:=old_parse_generic;
|
|
|
|
{ Restore old state }
|
|
block_type:=old_block_type;
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
PROCEDURE/FUNCTION PARSING
|
|
****************************************************************************}
|
|
|
|
|
|
procedure check_init_paras(p:TObject;arg:pointer);
|
|
begin
|
|
if tsym(p).typ<>paravarsym then
|
|
exit;
|
|
with tparavarsym(p) do
|
|
if (is_managed_type(vardef) and
|
|
(varspez in [vs_value,vs_out])) or
|
|
(is_shortstring(vardef) and
|
|
(varspez=vs_value)) then
|
|
include(current_procinfo.flags,pi_do_call);
|
|
end;
|
|
|
|
|
|
procedure read_proc_body(old_current_procinfo:tprocinfo;pd:tprocdef);
|
|
{
|
|
Parses the procedure directives, then parses the procedure body, then
|
|
generates the code for it
|
|
}
|
|
|
|
var
|
|
oldfailtokenmode : tmodeswitches;
|
|
isnestedproc : boolean;
|
|
begin
|
|
Message1(parser_d_procedure_start,pd.fullprocname(false));
|
|
oldfailtokenmode:=[];
|
|
|
|
{ create a new procedure }
|
|
current_procinfo:=cprocinfo.create(old_current_procinfo);
|
|
current_module.procinfo:=current_procinfo;
|
|
current_procinfo.procdef:=pd;
|
|
isnestedproc:=(current_procinfo.procdef.parast.symtablelevel>normal_function_level);
|
|
{ an anonymous function is always considered as nested }
|
|
if po_anonymous in pd.procoptions then
|
|
begin
|
|
current_procinfo.force_nested;
|
|
isnestedproc:=true;
|
|
end;
|
|
|
|
{ Insert mangledname }
|
|
pd.aliasnames.insert(pd.mangledname);
|
|
|
|
{ Handle Export of this procedure }
|
|
if (po_exports in pd.procoptions) and
|
|
(target_info.system in [system_i386_os2,system_i386_emx]) then
|
|
begin
|
|
pd.aliasnames.insert(pd.procsym.realname);
|
|
if cs_link_deffile in current_settings.globalswitches then
|
|
deffile.AddExport(pd.mangledname);
|
|
end;
|
|
|
|
{ Insert result variables in the localst }
|
|
insert_funcret_local(pd);
|
|
|
|
{ check if there are para's which require initing -> set }
|
|
{ pi_do_call (if not yet set) }
|
|
if not(pi_do_call in current_procinfo.flags) then
|
|
pd.parast.SymList.ForEachCall(@check_init_paras,nil);
|
|
|
|
{ set _FAIL as keyword if constructor }
|
|
if (pd.proctypeoption=potype_constructor) then
|
|
begin
|
|
oldfailtokenmode:=tokeninfo^[_FAIL].keyword;
|
|
tokeninfo^[_FAIL].keyword:=alllanguagemodes;
|
|
end;
|
|
|
|
tcgprocinfo(current_procinfo).parse_body;
|
|
|
|
{ reset _FAIL as _SELF normal }
|
|
if (pd.proctypeoption=potype_constructor) then
|
|
tokeninfo^[_FAIL].keyword:=oldfailtokenmode;
|
|
|
|
{ When it's a nested procedure then defer the code generation,
|
|
when back at normal function level then generate the code
|
|
for all defered nested procedures and the current procedure }
|
|
if not isnestedproc then
|
|
begin
|
|
if not(df_generic in current_procinfo.procdef.defoptions) then
|
|
begin
|
|
{ also generate the bodies for all previously done
|
|
specializations so that we might inline them }
|
|
generate_specialization_procs;
|
|
{ convert all load nodes that might have been captured by a
|
|
capture object }
|
|
tcgprocinfo(current_procinfo).convert_captured_syms;
|
|
tcgprocinfo(current_procinfo).generate_code_tree;
|
|
end;
|
|
end;
|
|
|
|
{ release procinfo }
|
|
if tprocinfo(current_module.procinfo)<>current_procinfo then
|
|
internalerror(200304274);
|
|
current_module.procinfo:=current_procinfo.parent;
|
|
|
|
{ For specialization we didn't record the last semicolon. Moving this parsing
|
|
into the parse_body routine is not done because of having better file position
|
|
information available }
|
|
if not current_procinfo.procdef.is_specialization and
|
|
not (po_anonymous in current_procinfo.procdef.procoptions) and
|
|
(
|
|
not assigned(current_procinfo.procdef.struct) or
|
|
not (df_specialization in current_procinfo.procdef.struct.defoptions)
|
|
or not (
|
|
assigned(current_procinfo.procdef.owner) and
|
|
(current_procinfo.procdef.owner.defowner=current_procinfo.procdef.struct)
|
|
)
|
|
) then
|
|
consume(_SEMICOLON);
|
|
|
|
if not isnestedproc then
|
|
{ current_procinfo is checked for nil later on }
|
|
freeandnil(current_procinfo);
|
|
end;
|
|
|
|
|
|
procedure read_proc_body(pd:tprocdef);
|
|
var
|
|
old_module_procinfo : tobject;
|
|
old_current_procinfo : tprocinfo;
|
|
begin
|
|
old_current_procinfo:=current_procinfo;
|
|
old_module_procinfo:=current_module.procinfo;
|
|
current_procinfo:=nil;
|
|
current_module.procinfo:=nil;
|
|
read_proc_body(nil,pd);
|
|
current_procinfo:=old_current_procinfo;
|
|
current_module.procinfo:=old_module_procinfo;
|
|
end;
|
|
|
|
|
|
function read_proc(flags:tread_proc_flags; usefwpd: tprocdef):tprocdef;
|
|
{
|
|
Parses the procedure directives, then parses the procedure body, then
|
|
generates the code for it
|
|
}
|
|
|
|
function convert_flags_to_ppf:tparse_proc_flags;inline;
|
|
begin
|
|
result:=[];
|
|
if rpf_classmethod in flags then
|
|
include(result,ppf_classmethod);
|
|
if rpf_generic in flags then
|
|
include(result,ppf_generic);
|
|
if rpf_anonymous in flags then
|
|
include(result,ppf_anonymous);
|
|
end;
|
|
|
|
var
|
|
old_current_procinfo : tprocinfo;
|
|
old_current_structdef: tabstractrecorddef;
|
|
old_current_genericdef,
|
|
old_current_specializedef: tstoreddef;
|
|
pdflags : tpdflags;
|
|
firstpd : tprocdef;
|
|
{$ifdef genericdef_for_nested}
|
|
def : tprocdef;
|
|
srsym : tsym;
|
|
i : longint;
|
|
{$endif genericdef_for_nested}
|
|
begin
|
|
{ save old state }
|
|
old_current_procinfo:=current_procinfo;
|
|
old_current_structdef:=current_structdef;
|
|
old_current_genericdef:=current_genericdef;
|
|
old_current_specializedef:=current_specializedef;
|
|
|
|
{ reset current_procinfo.procdef to nil to be sure that nothing is writing
|
|
to another procdef }
|
|
current_procinfo:=nil;
|
|
current_structdef:=nil;
|
|
current_genericdef:=nil;
|
|
current_specializedef:=nil;
|
|
|
|
if not assigned(usefwpd) then
|
|
{ parse procedure declaration }
|
|
result:=parse_proc_dec(convert_flags_to_ppf,old_current_structdef)
|
|
else
|
|
result:=usefwpd;
|
|
|
|
{ set the default function options }
|
|
if parse_only then
|
|
begin
|
|
result.forwarddef:=true;
|
|
{ set also the interface flag, for better error message when the
|
|
implementation doesn't match this header }
|
|
result.interfacedef:=true;
|
|
include(result.procoptions,po_global);
|
|
pdflags:=[pd_interface];
|
|
end
|
|
else
|
|
begin
|
|
pdflags:=[pd_body];
|
|
if (not current_module.in_interface) then
|
|
include(pdflags,pd_implemen);
|
|
if (not current_module.is_unit) or
|
|
create_smartlink_library then
|
|
include(result.procoptions,po_global);
|
|
result.forwarddef:=false;
|
|
end;
|
|
|
|
if not assigned(usefwpd) then
|
|
begin
|
|
{ parse the directives that may follow }
|
|
parse_proc_directives(result,pdflags);
|
|
|
|
if not (rpf_anonymous in flags) then
|
|
{ hint directives, these can be separated by semicolons here,
|
|
that needs to be handled here with a loop (PFV) }
|
|
while try_consume_hintdirective(result.symoptions,result.deprecatedmsg) do
|
|
Consume(_SEMICOLON);
|
|
|
|
{ Set calling convention }
|
|
if parse_only then
|
|
handle_calling_convention(result,hcc_default_actions_intf)
|
|
else
|
|
handle_calling_convention(result,hcc_default_actions_impl)
|
|
end;
|
|
|
|
{ search for forward declarations }
|
|
if not proc_add_definition(result) then
|
|
begin
|
|
{ One may not implement a method of a type declared in a different unit }
|
|
if assigned(result.struct) and
|
|
(result.struct.symtable.moduleid<>current_module.moduleid) and
|
|
not result.is_specialization then
|
|
begin
|
|
MessagePos1(result.fileinfo,parser_e_method_for_type_in_other_unit,result.struct.typesymbolprettyname);
|
|
end
|
|
{ A method must be forward defined (in the object declaration) }
|
|
else if assigned(result.struct) and
|
|
(not assigned(old_current_structdef)) then
|
|
begin
|
|
MessagePos1(result.fileinfo,parser_e_header_dont_match_any_member,result.fullprocname(false));
|
|
tprocsym(result.procsym).write_parameter_lists(result);
|
|
end
|
|
else
|
|
begin
|
|
{ Give a better error if there is a forward def in the interface and only
|
|
a single implementation }
|
|
firstpd:=tprocdef(tprocsym(result.procsym).ProcdefList[0]);
|
|
if (not result.forwarddef) and
|
|
(not result.interfacedef) and
|
|
(tprocsym(result.procsym).ProcdefList.Count>1) and
|
|
firstpd.forwarddef and
|
|
firstpd.interfacedef and
|
|
not(tprocsym(result.procsym).ProcdefList.Count>2) and
|
|
{ don't give an error if it may be an overload }
|
|
not(m_fpc in current_settings.modeswitches) and
|
|
(not(po_overload in result.procoptions) or
|
|
not(po_overload in firstpd.procoptions)) then
|
|
begin
|
|
MessagePos1(result.fileinfo,parser_e_header_dont_match_forward,result.fullprocname(false));
|
|
tprocsym(result.procsym).write_parameter_lists(result);
|
|
end
|
|
else
|
|
begin
|
|
if result.is_generic and not assigned(result.struct) then
|
|
tprocsym(result.procsym).owner.includeoption(sto_has_generic);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ Set mangled name }
|
|
proc_set_mangledname(result);
|
|
|
|
{ inherit generic flags from parent routine }
|
|
if assigned(old_current_procinfo) and
|
|
(old_current_procinfo.procdef.defoptions*[df_specialization,df_generic]<>[]) then
|
|
begin
|
|
if df_generic in old_current_procinfo.procdef.defoptions then
|
|
include(result.defoptions,df_generic);
|
|
if df_specialization in old_current_procinfo.procdef.defoptions then
|
|
begin
|
|
include(result.defoptions,df_specialization);
|
|
{ the procdefs encountered here are nested procdefs of which
|
|
their complete definition also resides inside the current token
|
|
stream, thus access to their genericdef is not required }
|
|
{$ifdef genericdef_for_nested}
|
|
{ find the corresponding routine in the generic routine }
|
|
if not assigned(old_current_procinfo.procdef.genericdef) then
|
|
internalerror(2016121701);
|
|
srsym:=tsym(tprocdef(old_current_procinfo.procdef.genericdef).getsymtable(gs_local).find(result.procsym.name));
|
|
if not assigned(srsym) or (srsym.typ<>procsym) then
|
|
internalerror(2016121702);
|
|
{ in practice the generic procdef should be at the same index
|
|
as the index of the current procdef, but as there *might* be
|
|
differences between the amount of defs generated for the
|
|
specialization and the generic search for the def using
|
|
parameter comparison }
|
|
for i:=0 to tprocsym(srsym).procdeflist.count-1 do
|
|
begin
|
|
def:=tprocdef(tprocsym(srsym).procdeflist[i]);
|
|
if (compare_paras(def.paras,result.paras,cp_none,[cpo_ignorehidden,cpo_openequalisexact,cpo_ignoreuniv])=te_exact) and
|
|
(compare_defs(def.returndef,result.returndef,nothingn)=te_exact) then
|
|
begin
|
|
result.genericdef:=def;
|
|
break;
|
|
end;
|
|
end;
|
|
if not assigned(result.genericdef) then
|
|
internalerror(2016121703);
|
|
{$endif}
|
|
end;
|
|
end;
|
|
|
|
{ compile procedure when a body is needed }
|
|
if (pd_body in pdflags) then
|
|
begin
|
|
read_proc_body(old_current_procinfo,result);
|
|
end
|
|
else
|
|
begin
|
|
{ Handle imports }
|
|
if (po_external in result.procoptions) then
|
|
begin
|
|
import_external_proc(result);
|
|
{$ifdef cpuhighleveltarget}
|
|
{ it's hard to factor this out in a virtual method, because the
|
|
generic version (the one inside this ifdef) doesn't fit in
|
|
hlcgobj but in symcreat or here, while the other version
|
|
doesn't fit in symcreat (since it uses the code generator).
|
|
Maybe we need another class for this kind of code that could
|
|
either be symcreat- or hlcgobj-based
|
|
}
|
|
if (not result.forwarddef) and
|
|
(result.hasforward) and
|
|
(proc_get_importname(result)<>'') then
|
|
begin
|
|
{ we cannot handle the callee-side of variadic functions (and
|
|
even if we could, e.g. LLVM cannot call through to something
|
|
else in that case) }
|
|
if is_c_variadic(result) then
|
|
Message1(parser_e_callthrough_varargs,result.fullprocname(false));
|
|
call_through_new_name(result,proc_get_importname(result));
|
|
include(result.implprocoptions,pio_thunk);
|
|
end
|
|
else
|
|
{$endif cpuhighleveltarget}
|
|
begin
|
|
create_hlcodegen;
|
|
hlcg.handle_external_proc(
|
|
current_asmdata.asmlists[al_procedures],
|
|
result,
|
|
proc_get_importname(result));
|
|
destroy_hlcodegen;
|
|
end
|
|
end;
|
|
end;
|
|
|
|
{ always register public functions that are only declared in the
|
|
implementation section as they might be called using an external
|
|
declaration from another unit }
|
|
if (po_global in result.procoptions) and
|
|
not result.interfacedef and
|
|
([df_generic,df_specialization]*result.defoptions=[]) then
|
|
begin
|
|
result.register_def;
|
|
result.procsym.register_sym;
|
|
end;
|
|
|
|
{ make sure that references to forward-declared functions are not }
|
|
{ treated as references to external symbols, needed for darwin. }
|
|
|
|
{ make sure we don't change the binding of real external symbols }
|
|
if (([po_external,po_weakexternal]*result.procoptions)=[]) and (pocall_internproc<>result.proccalloption) then
|
|
current_asmdata.DefineProcAsmSymbol(result,result.mangledname,result.needsglobalasmsym);
|
|
|
|
current_structdef:=old_current_structdef;
|
|
current_genericdef:=old_current_genericdef;
|
|
current_specializedef:=old_current_specializedef;
|
|
current_procinfo:=old_current_procinfo;
|
|
end;
|
|
|
|
|
|
procedure import_external_proc(pd:tprocdef);
|
|
var
|
|
name : string;
|
|
begin
|
|
if not (po_external in pd.procoptions) then
|
|
internalerror(2015121101);
|
|
|
|
{ Import DLL specified? }
|
|
if assigned(pd.import_dll) then
|
|
begin
|
|
if assigned (pd.import_name) then
|
|
current_module.AddExternalImport(pd.import_dll^,
|
|
pd.import_name^,proc_get_importname(pd),
|
|
pd.import_nr,false,false)
|
|
else
|
|
current_module.AddExternalImport(pd.import_dll^,
|
|
proc_get_importname(pd),proc_get_importname(pd),
|
|
pd.import_nr,false,true);
|
|
end
|
|
else
|
|
begin
|
|
name:=proc_get_importname(pd);
|
|
{ add import name to external list for DLL scanning }
|
|
if tf_has_dllscanner in target_info.flags then
|
|
current_module.dllscannerinputlist.Add(name,pd);
|
|
{ needed for units that use functions in packages this way }
|
|
current_module.add_extern_asmsym(name,AB_EXTERNAL,AT_FUNCTION);
|
|
end;
|
|
end;
|
|
|
|
{****************************************************************************
|
|
DECLARATION PARSING
|
|
****************************************************************************}
|
|
|
|
{ search in symtablestack for not complete classes }
|
|
procedure check_forward_class(p:TObject;arg:pointer);
|
|
begin
|
|
if (tsym(p).typ=typesym) and
|
|
(ttypesym(p).typedef.typ=objectdef) and
|
|
(oo_is_forward in tobjectdef(ttypesym(p).typedef).objectoptions) then
|
|
MessagePos1(tsym(p).fileinfo,sym_e_forward_type_not_resolved,tsym(p).realname);
|
|
end;
|
|
|
|
{$ifdef DEBUG_NODE_XML}
|
|
procedure XMLInitializeNodeFile(RootName, ModuleName: shortstring);
|
|
var
|
|
T: Text;
|
|
begin
|
|
Assign(T, current_module.ppxfilename);
|
|
{$push} {$I-}
|
|
Rewrite(T);
|
|
if IOResult<>0 then
|
|
begin
|
|
Message1(exec_e_cant_create_archivefile,current_module.ppxfilename);
|
|
current_module.ppxfilefail := True;
|
|
Exit;
|
|
end;
|
|
{$pop}
|
|
{ Mark the node dump file as available for writing }
|
|
current_module.ppxfilefail := False;
|
|
WriteLn(T, '<?xml version="1.0" encoding="utf-8"?>');
|
|
WriteLn(T, '<', RootName, ' name="', ModuleName, '">');
|
|
Close(T);
|
|
|
|
printnodeindention := printnodespacing;
|
|
end;
|
|
|
|
|
|
procedure XMLFinalizeNodeFile(RootName: shortstring);
|
|
var
|
|
T: Text;
|
|
begin
|
|
if current_module.ppxfilefail then
|
|
Exit;
|
|
|
|
current_module.ppxfilefail := True; { File is now considered closed no matter what happens }
|
|
Assign(T, current_module.ppxfilename);
|
|
{$push} {$I-}
|
|
Append(T);
|
|
if IOResult<>0 then
|
|
begin
|
|
Message1(exec_e_cant_create_archivefile,current_module.ppxfilename);
|
|
Exit;
|
|
end;
|
|
{$pop}
|
|
WriteLn(T, '</', RootName, '>');
|
|
Close(T);
|
|
end;
|
|
{$endif DEBUG_NODE_XML}
|
|
|
|
procedure read_declarations(islibrary : boolean);
|
|
var
|
|
hadgeneric : boolean;
|
|
|
|
procedure handle_unexpected_had_generic;
|
|
begin
|
|
if hadgeneric then
|
|
begin
|
|
Message(parser_e_procedure_or_function_expected);
|
|
hadgeneric:=false;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
is_classdef:boolean;
|
|
flags : tread_proc_flags;
|
|
begin
|
|
is_classdef:=false;
|
|
hadgeneric:=false;
|
|
repeat
|
|
if not assigned(current_procinfo) then
|
|
internalerror(200304251);
|
|
case token of
|
|
_LABEL:
|
|
begin
|
|
handle_unexpected_had_generic;
|
|
label_dec;
|
|
end;
|
|
_CONST:
|
|
begin
|
|
handle_unexpected_had_generic;
|
|
const_dec(hadgeneric);
|
|
end;
|
|
_TYPE:
|
|
begin
|
|
handle_unexpected_had_generic;
|
|
type_dec(hadgeneric);
|
|
end;
|
|
_VAR:
|
|
begin
|
|
handle_unexpected_had_generic;
|
|
var_dec(hadgeneric);
|
|
end;
|
|
_THREADVAR:
|
|
begin
|
|
handle_unexpected_had_generic;
|
|
threadvar_dec(hadgeneric);
|
|
end;
|
|
_CLASS:
|
|
begin
|
|
is_classdef:=false;
|
|
if try_to_consume(_CLASS) then
|
|
begin
|
|
{ class modifier is only allowed for procedures, functions, }
|
|
{ constructors, destructors }
|
|
if not((token in [_FUNCTION,_PROCEDURE,_DESTRUCTOR,_OPERATOR]) or (token=_CONSTRUCTOR)) and
|
|
not((token=_ID) and (idtoken=_OPERATOR)) then
|
|
Message(parser_e_procedure_or_function_expected);
|
|
|
|
if is_interface(current_structdef) then
|
|
Message(parser_e_no_static_method_in_interfaces)
|
|
else
|
|
{ class methods are also allowed for Objective-C protocols }
|
|
is_classdef:=true;
|
|
end;
|
|
end;
|
|
_CONSTRUCTOR,
|
|
_DESTRUCTOR,
|
|
_FUNCTION,
|
|
_PROCEDURE,
|
|
_OPERATOR:
|
|
begin
|
|
if hadgeneric and not (token in [_PROCEDURE,_FUNCTION]) then
|
|
begin
|
|
Message(parser_e_procedure_or_function_expected);
|
|
hadgeneric:=false;
|
|
end;
|
|
flags:=[];
|
|
if is_classdef then
|
|
include(flags,rpf_classmethod);
|
|
if hadgeneric then
|
|
include(flags,rpf_generic);
|
|
read_proc(flags,nil);
|
|
is_classdef:=false;
|
|
hadgeneric:=false;
|
|
end;
|
|
_EXPORTS:
|
|
begin
|
|
handle_unexpected_had_generic;
|
|
if (current_procinfo.procdef.localst.symtablelevel>main_program_level) then
|
|
begin
|
|
Message(parser_e_syntax_error);
|
|
consume_all_until(_SEMICOLON);
|
|
end
|
|
else if islibrary or
|
|
(target_info.system in systems_unit_program_exports) then
|
|
read_exports
|
|
else
|
|
begin
|
|
Message(parser_w_unsupported_feature);
|
|
consume(_BEGIN);
|
|
end;
|
|
end;
|
|
_PROPERTY:
|
|
begin
|
|
handle_unexpected_had_generic;
|
|
if (m_fpc in current_settings.modeswitches) then
|
|
property_dec
|
|
else
|
|
break;
|
|
end;
|
|
else
|
|
begin
|
|
case idtoken of
|
|
_RESOURCESTRING:
|
|
begin
|
|
handle_unexpected_had_generic;
|
|
{ m_class is needed, because the resourcestring
|
|
loading is in the ObjPas unit }
|
|
{ if (m_class in current_settings.modeswitches) then}
|
|
resourcestring_dec(hadgeneric)
|
|
{ else
|
|
break;}
|
|
end;
|
|
_OPERATOR:
|
|
begin
|
|
handle_unexpected_had_generic;
|
|
if is_classdef then
|
|
begin
|
|
read_proc([rpf_classmethod],nil);
|
|
is_classdef:=false;
|
|
end
|
|
else
|
|
break;
|
|
end;
|
|
_GENERIC:
|
|
begin
|
|
handle_unexpected_had_generic;
|
|
if not (m_delphi in current_settings.modeswitches) then
|
|
begin
|
|
consume(_ID);
|
|
hadgeneric:=true;
|
|
end
|
|
else
|
|
break;
|
|
end
|
|
else
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
until false;
|
|
|
|
{ add implementations for synthetic method declarations added by
|
|
the compiler (not for unit/program init functions, their localst
|
|
is the staticst -> would duplicate the work done in pmodules) }
|
|
if (current_procinfo.procdef.localst.symtabletype=localsymtable) and
|
|
{ we cannot call add_synthetic_method_implementations as it throws an internalerror if
|
|
the token is a string/char. As this is a syntax error and compilation will abort anyways,
|
|
skipping the call does not matter
|
|
}
|
|
(token<>_CSTRING) and
|
|
(token<>_CWCHAR) and
|
|
(token<>_CWSTRING) then
|
|
add_synthetic_method_implementations(current_procinfo.procdef.localst);
|
|
|
|
{ check for incomplete class definitions, this is only required
|
|
for fpc modes }
|
|
if (m_fpc in current_settings.modeswitches) then
|
|
current_procinfo.procdef.localst.SymList.ForEachCall(@check_forward_class,nil);
|
|
end;
|
|
|
|
|
|
procedure read_interface_declarations;
|
|
var
|
|
hadgeneric : boolean;
|
|
|
|
procedure handle_unexpected_had_generic;
|
|
begin
|
|
if hadgeneric then
|
|
begin
|
|
Message(parser_e_procedure_or_function_expected);
|
|
hadgeneric:=false;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
flags : tread_proc_flags;
|
|
begin
|
|
hadgeneric:=false;
|
|
repeat
|
|
case token of
|
|
_CONST :
|
|
begin
|
|
handle_unexpected_had_generic;
|
|
const_dec(hadgeneric);
|
|
end;
|
|
_TYPE :
|
|
begin
|
|
handle_unexpected_had_generic;
|
|
type_dec(hadgeneric);
|
|
end;
|
|
_VAR :
|
|
begin
|
|
handle_unexpected_had_generic;
|
|
var_dec(hadgeneric);
|
|
end;
|
|
_THREADVAR :
|
|
begin
|
|
handle_unexpected_had_generic;
|
|
threadvar_dec(hadgeneric);
|
|
end;
|
|
_FUNCTION,
|
|
_PROCEDURE,
|
|
_OPERATOR :
|
|
begin
|
|
if hadgeneric and not (token in [_FUNCTION, _PROCEDURE]) then
|
|
begin
|
|
message(parser_e_procedure_or_function_expected);
|
|
hadgeneric:=false;
|
|
end;
|
|
flags:=[];
|
|
if hadgeneric then
|
|
include(flags,rpf_generic);
|
|
read_proc(flags,nil);
|
|
hadgeneric:=false;
|
|
end;
|
|
else
|
|
begin
|
|
case idtoken of
|
|
_RESOURCESTRING :
|
|
begin
|
|
handle_unexpected_had_generic;
|
|
resourcestring_dec(hadgeneric);
|
|
end;
|
|
_PROPERTY:
|
|
begin
|
|
handle_unexpected_had_generic;
|
|
if (m_fpc in current_settings.modeswitches) then
|
|
property_dec
|
|
else
|
|
break;
|
|
end;
|
|
_GENERIC:
|
|
begin
|
|
handle_unexpected_had_generic;
|
|
if not (m_delphi in current_settings.modeswitches) then
|
|
begin
|
|
hadgeneric:=true;
|
|
consume(_ID);
|
|
end
|
|
else
|
|
break;
|
|
end
|
|
else
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
until false;
|
|
{ check for incomplete class definitions, this is only required
|
|
for fpc modes }
|
|
if (m_fpc in current_settings.modeswitches) then
|
|
symtablestack.top.SymList.ForEachCall(@check_forward_class,nil);
|
|
end;
|
|
|
|
|
|
end.
|