diff --git a/compiler/ncal.pas b/compiler/ncal.pas index ddebdbd343..4ed6cbea2e 100644 --- a/compiler/ncal.pas +++ b/compiler/ncal.pas @@ -2539,21 +2539,6 @@ implementation procedure tcallnode.register_created_object_types; - function checklive(def: tdef): boolean; - begin - if assigned(current_procinfo) and - not(po_inline in current_procinfo.procdef.procoptions) and - not wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname) then - begin -{$ifdef debug_deadcode} - writeln(' NOT adding creadion of ',def.typename,' because performed in dead stripped proc: ',current_procinfo.procdef.typename); -{$endif debug_deadcode} - result:=false; - end - else - result:=true; - end; - var crefdef, systobjectdef : tdef; @@ -2572,16 +2557,12 @@ implementation consider self-based newinstance calls, because then everything will be assumed to be just a TObject since TObject.Create calls NewInstance) } - if (procdefinition.proctypeoption=potype_constructor) or - ((procdefinition.typ=procdef) and - ((methodpointer.resultdef.typ=classrefdef) or - (methodpointer.nodetype=typen)) and - (tprocdef(procdefinition).procsym.Name='NEWINSTANCE')) then + if procdefinition.wpo_may_create_instance(methodpointer) then begin { Only a typenode can be passed when it is called with .create } if (methodpointer.nodetype=typen) then begin - if checklive(methodpointer.resultdef) then + if wpoinfomanager.symbol_live_in_currentproc(methodpointer.resultdef) then { we know the exact class type being created } tclassrefdef(methodpointer.resultdef).pointeddef.register_created_object_type end @@ -2591,12 +2572,12 @@ implementation if (methodpointer.nodetype=loadvmtaddrn) and (tloadvmtaddrnode(methodpointer).left.nodetype=typen) then begin - if checklive(methodpointer.resultdef) then + if wpoinfomanager.symbol_live_in_currentproc(methodpointer.resultdef) then tclassrefdef(methodpointer.resultdef).pointeddef.register_created_object_type end else begin - if checklive(methodpointer.resultdef) then + if wpoinfomanager.symbol_live_in_currentproc(methodpointer.resultdef) then begin { special case: if the classref comes from x.classtype (with classtype, being tobject.classtype) then the created instance is x or a descendant @@ -2638,7 +2619,7 @@ implementation { constructor with extended syntax called from new } if (cnf_new_call in callnodeflags) then begin - if checklive(methodpointer.resultdef) then + if wpoinfomanager.symbol_live_in_currentproc(methodpointer.resultdef) then methodpointer.resultdef.register_created_object_type; end else @@ -2650,7 +2631,7 @@ implementation if (procdefinition.proctypeoption=potype_constructor) then begin if (methodpointer.nodetype<>typen) and - checklive(methodpointer.resultdef) then + wpoinfomanager.symbol_live_in_currentproc(methodpointer.resultdef) then methodpointer.resultdef.register_created_object_type; end end; diff --git a/compiler/ngtcon.pas b/compiler/ngtcon.pas index 54a840a53d..bb9b53e9fe 100644 --- a/compiler/ngtcon.pas +++ b/compiler/ngtcon.pas @@ -208,9 +208,7 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis loadvmtaddrn: begin { update wpo info } - if not assigned(current_procinfo) or - (po_inline in current_procinfo.procdef.procoptions) or - wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname) then + if wpoinfomanager.symbol_live_in_currentproc(n.resultdef) then tobjectdef(tclassrefdef(n.resultdef).pointeddef).register_maybe_created_object_type; end; else diff --git a/compiler/nld.pas b/compiler/nld.pas index 1d2de58edc..2dec082c20 100644 --- a/compiler/nld.pas +++ b/compiler/nld.pas @@ -198,7 +198,7 @@ implementation htypechk,pass_1,procinfo,paramgr, nbas,ncon,nflw,ninl,ncnv,nmem,ncal,nutils, cgbase, - optloadmodifystore + optloadmodifystore,wpobase ; @@ -440,6 +440,20 @@ implementation typecheckpass(left); end end; + + { we can't know what will happen with this function pointer, so + we have to assume it will be used to create an instance of this + type } + if fprocdef.wpo_may_create_instance(left) then + begin + if wpoinfomanager.symbol_live_in_currentproc(tdef(symtable.defowner)) then + begin + if assigned(left) then + tobjectdef(left.resultdef).register_created_object_type + else + tobjectdef(fprocdef.owner.defowner).register_created_object_type; + end; + end; end; labelsym: begin diff --git a/compiler/nmem.pas b/compiler/nmem.pas index 4159e275f3..bfa0a937b0 100644 --- a/compiler/nmem.pas +++ b/compiler/nmem.pas @@ -276,9 +276,7 @@ implementation not is_objcclassref(left.resultdef) then begin if not(nf_ignore_for_wpo in flags) and - (not assigned(current_procinfo) or - (po_inline in current_procinfo.procdef.procoptions) or - wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname)) then + wpoinfomanager.symbol_live_in_currentproc(left.resultdef) then begin { keep track of which classes might be instantiated via a classrefdef } if (left.resultdef.typ=classrefdef) then diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 855b355218..911beb64d5 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -728,6 +728,8 @@ interface function generate_safecall_wrapper: boolean; virtual; { returns true if the def is a generic param of the procdef } function is_generic_param(def:tdef): boolean; + + function wpo_may_create_instance(optionalmethodpointer: tnode): boolean; private procedure count_para(p:TObject;arg:pointer); procedure insert_para(p:TObject;arg:pointer); @@ -6148,6 +6150,19 @@ implementation result:=false; end; + function tabstractprocdef.wpo_may_create_instance(optionalmethodpointer: tnode): boolean; + begin + result:= + (proctypeoption=potype_constructor) or + ((typ=procdef) and + ((not assigned(optionalmethodpointer) and + is_class(tdef(owner.defowner))) or + (assigned(optionalmethodpointer) and + ((optionalmethodpointer.resultdef.typ=classrefdef) or + (optionalmethodpointer.nodetype=typen)))) and + (tprocdef(self).procsym.Name='NEWINSTANCE')) + end; + {*************************************************************************** TPROCDEF diff --git a/compiler/wpobase.pas b/compiler/wpobase.pas index 9f659854f3..28fc053a9a 100644 --- a/compiler/wpobase.pas +++ b/compiler/wpobase.pas @@ -333,6 +333,8 @@ type } function symbol_live(const name: shortstring): boolean; virtual; abstract; + function symbol_live_in_currentproc(fordef: tdef): boolean; + constructor create; reintroduce; destructor destroy; override; end; @@ -347,7 +349,8 @@ implementation globals, cutils, sysutils, - symdef, + symconst,symdef, + procinfo, verbose; @@ -724,6 +727,38 @@ implementation twpocomponentbaseclass(fwpocomponents[i]).checkoptions end; + function twpoinfomanagerbase.symbol_live_in_currentproc(fordef: tdef): boolean; + + function alias_symbol_live: boolean; + var + item: TCmdStrListItem; + begin + result:=true; + item:=TCmdStrListItem(current_procinfo.procdef.aliasnames.first); + while assigned(item) do + begin + if symbol_live(item.Str) then + exit; + item:=TCmdStrListItem(item.Next); + end; + result:=false; + end; + + begin + if assigned(current_procinfo) and + not(po_inline in current_procinfo.procdef.procoptions) and + not symbol_live(current_procinfo.procdef.mangledname) and + not alias_symbol_live then + begin +{$ifdef debug_deadcode} + writeln(' NOT adding creation of ',fordef.typename,' because performed in dead stripped proc: ',current_procinfo.procdef.typename); +{$endif debug_deadcode} + result:=false; + end + else + result:=true; + end; + procedure twpoinfomanagerbase.extractwpoinfofromprogram; var i: longint; diff --git a/tests/webtbs/tw40204.pp b/tests/webtbs/tw40204.pp new file mode 100644 index 0000000000..4588464fb2 --- /dev/null +++ b/tests/webtbs/tw40204.pp @@ -0,0 +1,54 @@ +{ %wpoparas=devirtcalls,optvmts } +{ %wpopasses=1 } + +{$mode objfpc} {$longstrings on} +uses + Objects; + +type + MyObjBase = object + constructor Create; + function GetVirt: string; virtual; abstract; + end; + + MyObjA = object(MyObjBase) + constructor Create; + function GetVirt: string; virtual; + end; + + MyObjB = object(MyObjBase) + constructor Create; + function GetVirt: string; virtual; + end; + + constructor MyObjBase.Create; begin end; + constructor MyObjA.Create; begin end; + function MyObjA.GetVirt: string; begin result := 'MyObjA.GetVirt'; end; + constructor MyObjB.Create; begin end; + function MyObjB.GetVirt: string; begin result := 'MyObjB.GetVirt'; end; + +type + MyObjFactory = record + ctr: CodePointer; + vmt: pointer; + end; + +const + MyObjFactories: array[0 .. 1] of MyObjFactory = + ( + (ctr: @MyObjA.Create; vmt: TypeOf(MyObjA)), + (ctr: @MyObjB.Create; vmt: TypeOf(MyObjB)) + ); + +var + o: MyObjBase; + fact: MyObjFactory; + +begin + for fact in MyObjFactories do + begin + CallVoidConstructor(fact.ctr, @o, fact.vmt); + writeln(o.GetVirt); + end; +end. +