From a7232669fff29a5a4054bb64ea000f402d31bc45 Mon Sep 17 00:00:00 2001
From: pierre <pierre@freepascal.org>
Date: Mon, 7 Dec 2020 07:28:04 +0000
Subject: [PATCH] * 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 | 251 ++++++++++++++++++++++++++++------------------
1 file changed, 152 insertions(+), 99 deletions(-)
diff --git a/compiler/psub.pas b/compiler/psub.pas
index b070099fc4..49836771a5 100644
--- a/compiler/psub.pas
+++ b/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 }
- if Assigned(procdef.struct) then
+ separate := (df_generic in procdef.defoptions);
+
+ { 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, ' struct="', SanitiseXMLString(procdef.struct.objrealname^), '"')
- else
- Write(T, ' struct="<NULL>"');
+ Write(T, PrintNodeIndention, '<subroutine');
+ { Check to see if the procedure is a class or object method }
+ if Assigned(procdef.struct) then
+ begin
+ if Assigned(procdef.struct.objrealname) then
+ Write(T, ' struct="', SanitiseXMLString(procdef.struct.objrealname^), '"')
+ else
+ Write(T, ' struct="<NULL>"');
+ 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
- potype_none: { Do nothing };
+ if Assigned(Code) then
+ begin
+ if FirstHalf then
+ WriteLn(T, PrintNodeIndention, '<code>')
+ else
+ begin
+ WriteLn(T); { Line for spacing }
+ WriteLn(T, PrintNodeIndention, '<firstpass>');
+ end;
- 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;
- { Do nothing otherwise }
+ PrintNodeIndent;
+ XMLPrintNode(T, Code);
+ PrintNodeUnindent;
- 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;
+ if FirstHalf then
+ WriteLn(T, PrintNodeIndention, '</code>')
+ else
+ WriteLn(T, PrintNodeIndention, '</firstpass>');
+ end
+ else { Code=Nil }
+ begin
+ { Don't print anything for second half - if there's no code, there's no firstpass }
+ if FirstHalf then
+ WriteLn(T, PrintNodeIndention, '<code />');
+ 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');
-
- if Assigned(Code) then
+ { Print footer only for second half }
+ if (not FirstHalf) or separate then
begin
- WriteLn(T, PrintNodeIndention, '<code>');
- PrintNodeIndent;
- XMLPrintNode(T, Code);
PrintNodeUnindent;
- WriteLn(T, PrintNodeIndention, '</code>');
- end
- else
- WriteLn(T, PrintNodeIndention, '<code />');
+ WriteLn(T, PrintNodeIndention, '</subroutine>');
+ WriteLn(T); { Line for spacing }
+ end;
- 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 }