* Adapted from patch node-dump-pass-1.patch submitted by J. Gareth Moreton from bug report 38156.

This patch extends the DEBUG_NODE_XML debug feature by also outputting, 
     to the *-node-dump.xml files, the node tree as it appears after the first pass, 
     since it often contains many more internal nodes like temporary allocations that may need
     to be evaluated for debugging and development purposes, or node-level optimisation opportunities.

git-svn-id: trunk@47709 -

compiler/psub.pas

@@ -86,7 +86,7 @@ interface
         function has_assembler_child : boolean;
         procedure set_eh_info; override;
 {$ifdef DEBUG_NODE_XML}
-        procedure XMLPrintProc;
+        procedure XMLPrintProc(FirstHalf: Boolean);
 {$endif DEBUG_NODE_XML}
       end;
 
@@ -1437,15 +1437,19 @@ implementation
 
 
 {$ifdef DEBUG_NODE_XML}
-    procedure tcgprocinfo.XMLPrintProc;
+    procedure tcgprocinfo.XMLPrintProc(FirstHalf: Boolean);
       var
         T: Text;
         W: Word;
         syssym: tsyssym;
+        separate : boolean;
 
       procedure PrintType(Flag: string);
         begin
-          Write(T, ' type="', Flag, '"');
+          if df_generic in procdef.defoptions then
+            Write(T, ' type="generic ', Flag, '"')
+          else
+            Write(T, ' type="', Flag, '"');
         end;
 
       procedure PrintOption(Flag: string);
@@ -1467,109 +1471,132 @@ implementation
             Exit;
           end;
         {$pop}
-        Write(T, PrintNodeIndention, '<subroutine');
 
-        { Check to see if the procedure is a class or object method }
+        separate := (df_generic in procdef.defoptions);
-        if Assigned(procdef.struct) then
+
+        { First half prints the header and the nodes as a "code" tag }
+        if FirstHalf or separate then
           begin
-            if Assigned(procdef.struct.objrealname) then
+            Write(T, PrintNodeIndention, '<subroutine');
-              Write(T, ' struct="', SanitiseXMLString(procdef.struct.objrealname^), '"')
+            { Check to see if the procedure is a class or object method }
-            else
+            if Assigned(procdef.struct) then
-              Write(T, ' struct="&lt;NULL&gt;"');
+              begin
+                if Assigned(procdef.struct.objrealname) then
+                  Write(T, ' struct="', SanitiseXMLString(procdef.struct.objrealname^), '"')
+                else
+                  Write(T, ' struct="&lt;NULL&gt;"');
+              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 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;
 
-        case procdef.proctypeoption of
+          if Assigned(Code) then
-          potype_none: { Do nothing };
+            begin
+              if FirstHalf then
+                WriteLn(T, PrintNodeIndention, '<code>')
+              else
+                begin
+                  WriteLn(T); { Line for spacing }
+                  WriteLn(T, PrintNodeIndention, '<firstpass>');
+                end;
 
-          potype_procedure,
+              PrintNodeIndent;
-          potype_function:
+              XMLPrintNode(T, Code);
-            if po_classmethod in procdef.procoptions then
+              PrintNodeUnindent;
-              begin
-                if po_staticmethod in procdef.procoptions then
-                  PrintType('static class method')
-                else
-                  PrintType('class method');
-              end;
-            { Do nothing otherwise }
 
-          potype_proginit,
+              if FirstHalf then
-          potype_unitinit:
+                WriteLn(T, PrintNodeIndention, '</code>')
-            PrintType('initialization');
+              else
-          potype_unitfinalize:
+                WriteLn(T, PrintNodeIndention, '</firstpass>');
-            PrintType('finalization');
+            end
-          potype_constructor:
+          else { Code=Nil }
-            PrintType('constructor');
+            begin
-          potype_destructor:
+              { Don't print anything for second half - if there's no code, there's no firstpass }
-            PrintType('destructor');
+              if FirstHalf then
-          potype_operator:
+                WriteLn(T, PrintNodeIndention, '<code />');
-            PrintType('operator');
+            end;
-          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])), '"');
+        { Print footer only for second half }
-
+        if (not FirstHalf) or separate then
-        if po_hascallingconvention in procdef.procoptions 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');
-
-        if Assigned(Code) then
           begin
-            WriteLn(T, PrintNodeIndention, '<code>');
-            PrintNodeIndent;
-            XMLPrintNode(T, Code);
             PrintNodeUnindent;
-            WriteLn(T, PrintNodeIndention, '</code>');
+            WriteLn(T, PrintNodeIndention, '</subroutine>');
-          end
+            WriteLn(T); { Line for spacing }
-        else
+          end;
-          WriteLn(T, PrintNodeIndention, '<code />');
 
-        PrintNodeUnindent;
-        WriteLn(T, PrintNodeIndention, '</subroutine>');
-        WriteLn(T); { Line for spacing }
         Close(T);
       end;
 {$endif DEBUG_NODE_XML}
@@ -1789,7 +1816,14 @@ implementation
           don't need to generate anything. When it was an empty
           procedure there would be at least a blocknode }
         if not assigned(code) then
-          exit;
+          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
@@ -1883,6 +1917,10 @@ implementation
            (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);
@@ -1912,7 +1950,14 @@ implementation
           do_optloadmodifystore(code);
 
         { only do secondpass if there are no errors }
-        if (ErrorCount=0) then
+        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;
 
@@ -1962,6 +2007,11 @@ implementation
             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);
@@ -2470,7 +2520,10 @@ implementation
            printproc( 'after parsing');
 
 {$ifdef DEBUG_NODE_XML}
-         XMLPrintProc;
+         { 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 }