WPO: also consider NewInstance to detect class instancing

Resolves #40200

compiler/ncal.pas

@@ -57,7 +57,8 @@ interface
          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 }
-         cnf_check_fpu_exceptions { after the call fpu exceptions shall be checked }
+         cnf_check_fpu_exceptions, { after the call fpu exceptions shall be checked }
+         cnf_ignore_devirt_wpo   { ignore this call for devirtualisatio info tracking: calls to newinstance generated by the compiler do not result in extra class types being instanced }
        );
        tcallnodeflags = set of tcallnodeflag;
 
@@ -2560,10 +2561,22 @@ implementation
         { only makes sense for methods }
         if not assigned(methodpointer) then
           exit;
+        { inherited calls don't create an instance of the inherited type, but of
+          the current type }
+        if ([cnf_inherited,cnf_anon_inherited,cnf_ignore_devirt_wpo]*callnodeflags)<>[] then
+          exit;
         if (methodpointer.resultdef.typ=classrefdef) then
           begin
-            { constructor call via classreference => allocate memory }
-            if (procdefinition.proctypeoption=potype_constructor) then
+            { constructor call via classreference => instance can be created
+              same with calling newinstance without a instance-self (don't
+              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
               begin
                 { Only a typenode can be passed when it is called with <class of xx>.create }
                 if (methodpointer.nodetype=typen) then

compiler/psub.pas

@@ -512,6 +512,11 @@ implementation
                        (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(
@@ -522,9 +527,7 @@ implementation
                                 ctypeconvnode.create_internal(
                                     load_self_pointer_node,
                                     voidpointertype),
-                                ccallnode.create(nil,tprocsym(srsym),srsym.owner,
-                                  ctypeconvnode.create_internal(load_self_pointer_node,cclassrefdef.create(current_structdef)),
-                                  [],nil)),
+                                call),
                             nil));
                       end
                     else

tests/webtbs/tw40200.pp

@@ -0,0 +1,54 @@
+{ %wpoparas=devirtcalls }
+{ %wpopasses=1 }
+
+{$mode objfpc}
+
+type
+  tderived = class;
+ 
+  tbase = class
+    procedure test; virtual;
+  end;
+  tbaseclass = class of tbase;
+
+  tbasetop = class(tbase)
+    function alloc(c: tbaseclass): tbase;
+    function getderived: tderived;
+  end;
+
+  tderived = class(tbase)
+    procedure test; override;
+  end;
+
+procedure tbase.test;
+  begin
+    writeln('error');
+    halt(1);
+  end;
+
+function tbasetop.alloc(c: tbaseclass): tbase;
+  begin
+    result:=tbase(c.newinstance);
+  end;
+
+function tbasetop.getderived: tderived;
+  begin
+    result:=tderived(alloc(tderived));
+    result.create;
+  end;
+
+procedure tderived.test;
+  begin
+    writeln('ok');
+  end;
+
+var
+  t: tbasetop;
+  b: tbase;
+begin
+  t:=tbasetop.create;
+  b:=tbase(t.getderived);
+  b.test;
+  b.free;
+  t.free;
+end.