From cb7730a42319c28fd947564880ad4a600daa6a74 Mon Sep 17 00:00:00 2001 From: Jonas Maebe Date: Sun, 8 Apr 2018 15:41:00 +0000 Subject: [PATCH] * fixed execution order of implicit finalization and class destructors: first the latter, then the former git-svn-id: trunk@38716 - --- .gitattributes | 2 + compiler/ncal.pas | 6 +- compiler/ngenutil.pas | 120 +++++++++++++++++----------------------- compiler/symtable.pas | 47 +++++++++++++++- tests/webtbs/tw29245.pp | 36 ++++++++++++ tests/webtbs/uw29245.pp | 41 ++++++++++++++ 6 files changed, 180 insertions(+), 72 deletions(-) create mode 100644 tests/webtbs/tw29245.pp create mode 100644 tests/webtbs/uw29245.pp diff --git a/.gitattributes b/.gitattributes index 90faa72769..0335b7ddb7 100644 --- a/.gitattributes +++ b/.gitattributes @@ -15846,6 +15846,7 @@ tests/webtbs/tw2916.pp svneol=native#text/plain tests/webtbs/tw2920.pp svneol=native#text/plain tests/webtbs/tw2923.pp svneol=native#text/plain tests/webtbs/tw29244.pp svneol=native#text/pascal +tests/webtbs/tw29245.pp svneol=native#text/plain tests/webtbs/tw29250.pp svneol=native#text/pascal tests/webtbs/tw2926.pp svneol=native#text/plain tests/webtbs/tw2927.pp svneol=native#text/plain @@ -16702,6 +16703,7 @@ tests/webtbs/uw28442.pp svneol=native#text/pascal tests/webtbs/uw28766.pp svneol=native#text/pascal tests/webtbs/uw28964.pp svneol=native#text/plain tests/webtbs/uw2920.pp svneol=native#text/plain +tests/webtbs/uw29245.pp svneol=native#text/plain tests/webtbs/uw2956.pp svneol=native#text/plain tests/webtbs/uw2984.pp svneol=native#text/plain tests/webtbs/uw3103.pp svneol=native#text/plain diff --git a/compiler/ncal.pas b/compiler/ncal.pas index 7cec380756..0984293d8b 100644 --- a/compiler/ncal.pas +++ b/compiler/ncal.pas @@ -54,8 +54,9 @@ interface cnf_objc_id_call, { the procedure is a member call via id -> any ObjC method of any ObjC type in scope is fair game } cnf_unit_specified, { the unit in which the procedure has to be searched has been specified } cnf_call_never_returns, { information for the dfa that a subroutine never returns } - cnf_call_self_node_done { the call_self_node has been generated if necessary + cnf_call_self_node_done,{ the call_self_node has been generated if necessary (to prevent it from potentially happening again in a wrong context in case of constant propagation or so) } + cnf_ignore_visibility { internally generated call that should ignore visibility checks } ); tcallnodeflags = set of tcallnodeflag; @@ -3596,7 +3597,8 @@ implementation end; { ignore possible private for properties or in delphi mode for anon. inherited (FK) } ignorevisibility:=(nf_isproperty in flags) or - ((m_delphi in current_settings.modeswitches) and (cnf_anon_inherited in callnodeflags)); + ((m_delphi in current_settings.modeswitches) and (cnf_anon_inherited in callnodeflags)) or + (cnf_ignore_visibility in callnodeflags); candidates:=tcallcandidates.create(symtableprocentry,symtableproc,left,ignorevisibility, not(nf_isproperty in flags),cnf_objc_id_call in callnodeflags,cnf_unit_specified in callnodeflags, callnodeflags*[cnf_anon_inherited,cnf_inherited]=[],cnf_anon_inherited in callnodeflags,spezcontext); diff --git a/compiler/ngenutil.pas b/compiler/ngenutil.pas index 91ee2e8763..744b5c3811 100644 --- a/compiler/ngenutil.pas +++ b/compiler/ngenutil.pas @@ -48,6 +48,8 @@ interface class function initialize_data_node(p:tnode; force: boolean):tnode; virtual; class function finalize_data_node(p:tnode):tnode; virtual; strict protected + type + tstructinifinipotype = potype_class_constructor..potype_class_destructor; class procedure sym_maybe_initialize(p: TObject; arg: pointer); { generates the code for finalisation of local variables } class procedure local_varsyms_finalize(p:TObject;arg:pointer); @@ -55,6 +57,7 @@ interface all local (static) typed consts } class procedure static_syms_finalize(p: TObject; arg: pointer); class procedure sym_maybe_finalize(var stat: tstatementnode; sym: tsym); + class procedure append_struct_initfinis(u: tmodule; initfini: tstructinifinipotype; var stat: tstatementnode); public class procedure procdef_block_add_implicit_initialize_nodes(pd: tprocdef; var stat: tstatementnode); class procedure procdef_block_add_implicit_finalize_nodes(pd: tprocdef; var stat: tstatementnode); @@ -421,6 +424,47 @@ implementation end; + procedure AddToStructInits(p:TObject;arg:pointer); + var + StructList: TFPList absolute arg; + begin + if (tdef(p).typ in [objectdef,recorddef]) and + not (df_generic in tdef(p).defoptions) then + begin + { first add the class... } + if ([oo_has_class_constructor,oo_has_class_destructor] * tabstractrecorddef(p).objectoptions <> []) then + StructList.Add(p); + { ... and then also add all subclasses } + tabstractrecorddef(p).symtable.deflist.foreachcall(@AddToStructInits,arg); + end; + end; + + + class procedure tnodeutils.append_struct_initfinis(u: tmodule; initfini: tstructinifinipotype; var stat: tstatementnode); + var + structlist: tfplist; + i: integer; + pd: tprocdef; + begin + structlist:=tfplist.Create; + if assigned(u.globalsymtable) then + u.globalsymtable.DefList.ForEachCall(@AddToStructInits,structlist); + u.localsymtable.DefList.ForEachCall(@AddToStructInits,structlist); + { write structures } + for i:=0 to structlist.Count-1 do + begin + pd:=tabstractrecorddef(structlist[i]).find_procdef_bytype(initfini); + if assigned(pd) then + begin + { class constructors are private -> ignore visibility checks } + addstatement(stat, + ccallnode.create(nil,tprocsym(pd.procsym),pd.owner,nil,[cnf_ignore_visibility],nil)) + end; + end; + structlist.free; + end; + + class procedure tnodeutils.procdef_block_add_implicit_initialize_nodes(pd: tprocdef; var stat: tstatementnode); begin { initialize local data like ansistrings } @@ -432,6 +476,9 @@ implementation if assigned(current_module.globalsymtable) then TSymtable(current_module.globalsymtable).SymList.ForEachCall(@sym_maybe_initialize,@stat); TSymtable(current_module.localsymtable).SymList.ForEachCall(@sym_maybe_initialize,@stat); + { insert class constructors } + if (current_module.flags and uf_classinits) <> 0 then + append_struct_initfinis(current_module, potype_class_constructor, stat); end; { units have seperate code for initilization and finalization } potype_unitfinalize: ; @@ -453,6 +500,9 @@ implementation case current_procinfo.procdef.proctypeoption of potype_unitfinalize: begin + { insert class destructors } + if (current_module.flags and uf_classinits) <> 0 then + append_struct_initfinis(current_module, potype_class_destructor, stat); { this is also used for initialization of variables in a program which does not have a globalsymtable } if assigned(current_module.globalsymtable) then @@ -894,82 +944,16 @@ implementation end; - procedure AddToStructInits(p:TObject;arg:pointer); - var - StructList: TFPList absolute arg; - begin - if (tdef(p).typ in [objectdef,recorddef]) and - not (df_generic in tdef(p).defoptions) then - begin - { first add the class... } - if ([oo_has_class_constructor,oo_has_class_destructor] * tabstractrecorddef(p).objectoptions <> []) then - StructList.Add(p); - { ... and then also add all subclasses } - tabstractrecorddef(p).symtable.deflist.foreachcall(@AddToStructInits,arg); - end; - end; - - class function tnodeutils.get_init_final_list:tfplist; - - procedure append_struct_inits(u:tmodule); - var - i : integer; - structlist : tfplist; - pd : tprocdef; - entry : pinitfinalentry; - begin - structlist:=tfplist.Create; - if assigned(u.globalsymtable) then - u.globalsymtable.DefList.ForEachCall(@AddToStructInits,structlist); - u.localsymtable.DefList.ForEachCall(@AddToStructInits,structlist); - { write structures } - for i:=0 to structlist.Count-1 do - begin - new(entry); - entry^.module:=u; - pd:=tabstractrecorddef(structlist[i]).find_procdef_bytype(potype_class_constructor); - if assigned(pd) then - begin - entry^.initfunc:=pd.mangledname; - entry^.initpd:=pd; - end - else - begin - entry^.initfunc:=''; - entry^.initpd:=nil; - end; - pd := tabstractrecorddef(structlist[i]).find_procdef_bytype(potype_class_destructor); - if assigned(pd) then - begin - entry^.finifunc:=pd.mangledname; - entry^.finipd:=pd; - end - else - begin - entry^.finifunc:=''; - entry^.finipd:=nil; - end; - if assigned(entry^.finipd) or assigned(entry^.initpd) then - result.add(entry) - else - { AddToStructInits only adds structs that have either a class constructor or destructor or both } - internalerror(2017051902); - end; - structlist.free; - end; - var hp : tused_unit; entry : pinitfinalentry; begin result:=tfplist.create; + { Insert initialization/finalization of the used units } hp:=tused_unit(usedunits.first); while assigned(hp) do begin - { insert class constructors/destructors of the unit } - if (hp.u.flags and uf_classinits) <> 0 then - append_struct_inits(hp.u); if (hp.u.flags and (uf_init or uf_finalize))<>0 then begin new(entry); @@ -989,8 +973,6 @@ implementation hp:=tused_unit(hp.next); end; - if (current_module.flags and uf_classinits) <> 0 then - append_struct_inits(current_module); { Insert initialization/finalization of the program } if (current_module.flags and (uf_init or uf_finalize))<>0 then begin diff --git a/compiler/symtable.pas b/compiler/symtable.pas index 4a055889a4..7c81f97992 100644 --- a/compiler/symtable.pas +++ b/compiler/symtable.pas @@ -70,7 +70,7 @@ interface procedure allprivatesused; procedure check_forwards; procedure checklabels; - function needs_init_final : boolean; + function needs_init_final : boolean; virtual; procedure testfordefaultproperty(sym:TObject;arg:pointer); procedure register_children; end; @@ -226,7 +226,9 @@ interface function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override; function findnamespace(const n:string):TSymEntry;virtual; function iscurrentunit:boolean;override; + function needs_init_final: boolean; override; procedure insertunit(sym:TSymEntry); + function has_class_condestructors: boolean; end; tglobalsymtable = class(tabstractuniTSymtable) @@ -2420,6 +2422,23 @@ implementation ); end; + + function tabstractuniTSymtable.needs_init_final: boolean; + begin + if not init_final_check_done then + begin + result:=inherited needs_init_final; + if not result then + begin + result:=has_class_condestructors; + if result then + include(tableoptions,sto_needs_init_final); + end; + end; + result:=sto_needs_init_final in tableoptions; + end; + + procedure tabstractuniTSymtable.insertunit(sym:TSymEntry); var p:integer; @@ -2444,6 +2463,32 @@ implementation end; end; + + procedure CheckForClassConDestructors(p:TObject;arg:pointer); + var + result: pboolean absolute arg; + begin + if result^ then + exit; + if (tdef(p).typ in [objectdef,recorddef]) and + not (df_generic in tdef(p).defoptions) then + begin + { first check the class... } + if ([oo_has_class_constructor,oo_has_class_destructor] * tabstractrecorddef(p).objectoptions <> []) then + result^:=true;; + { ... and then also check all subclasses } + if not result^ then + tabstractrecorddef(p).symtable.deflist.foreachcall(@CheckForClassConDestructors,arg); + end; + end; + + + function tabstractuniTSymtable.has_class_condestructors: boolean; + begin + result:=false; + deflist.foreachcall(@CheckForClassConDestructors,@result); + end; + {**************************************************************************** TStaticSymtable ****************************************************************************} diff --git a/tests/webtbs/tw29245.pp b/tests/webtbs/tw29245.pp new file mode 100644 index 0000000000..235a6456da --- /dev/null +++ b/tests/webtbs/tw29245.pp @@ -0,0 +1,36 @@ +{ %opt=-gh } + +{$mode delphi} + +uses + uw29245; + + type + TBar = class + class var + F: array of TObject; + strict private + class constructor Create; + class destructor Destroy; + end; + +class constructor TBar.Create; +begin + writeln('tbar class constructor'); + SetLength(F, 10); +end; + +class destructor TBar.Destroy; +begin + writeln('tbar class destructor'); + if length(Tbar.F)<>10 then + halt(5); +end; + +begin + HaltOnNotReleased := true; + writeln('main program'); + if length(TBar.F)<>10 then + halt(4); +end. + diff --git a/tests/webtbs/uw29245.pp b/tests/webtbs/uw29245.pp new file mode 100644 index 0000000000..66980f7af9 --- /dev/null +++ b/tests/webtbs/uw29245.pp @@ -0,0 +1,41 @@ +unit uw29245; + +{$mode delphi} + +interface + + type + TFoo = class + class var + F: array of TObject; + private + class constructor Create; + class destructor Destroy; + end; + +implementation + +class constructor TFoo.Create; +begin + writeln('tfoo class constructor'); + SetLength(F, 10); +end; + +class destructor TFoo.Destroy; +begin + writeln('tfoo class destructor'); + if length(TFOO.F)<>10 then + halt(3); +end; + +initialization + writeln('unit initialization'); + if length(TFOO.F)<>10 then + halt(1); + +finalization + writeln('unit finalization'); + if length(TFOO.F)<>10 then + halt(2); + +end.