WPO: fix dead code detection, and handle procvars

Extend dead code detection to not only look for the main mangled name, but also
for any aliases before deciding that a routine has been dead-stripped.

Assume objects/classes can also be constructed if the address of one of their
constructors or of the TObject.NewInstance class method has been taken.

Resolves #40204

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 <class of xx>.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;

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

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

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

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

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;

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.
+