From 243c967967070429195b93b0cb51d2b406badb4d Mon Sep 17 00:00:00 2001 From: pierre Date: Sat, 22 Jun 2019 14:08:47 +0000 Subject: [PATCH] Commit of new debug feature implemented by J. Gareth Moreton Allows compilation of compiler using -dDEBUG_NODE_XML which will generate a NAME-node-dump.xml file for each unit, program or library compiled, containing a XML description of the nodes handled during compilation of the unit, program or library. git-svn-id: trunk@42271 - --- compiler/finput.pas | 18 ++ compiler/i8086/n8086con.pas | 12 + compiler/nbas.pas | 253 +++++++++++++++++++++ compiler/ncal.pas | 53 +++++ compiler/ncnv.pas | 28 +++ compiler/ncon.pas | 87 +++++++ compiler/nflw.pas | 117 ++++++++++ compiler/ninl.pas | 10 + compiler/nld.pas | 28 +++ compiler/nmem.pas | 57 +++++ compiler/node.pas | 438 +++++++++++++++++++++++++++++++++++- compiler/nset.pas | 40 ++++ compiler/pmodules.pas | 46 ++++ compiler/psub.pas | 123 +++++++++- 14 files changed, 1306 insertions(+), 4 deletions(-) diff --git a/compiler/finput.pas b/compiler/finput.pas index 4106318b23..36eca6cf37 100644 --- a/compiler/finput.pas +++ b/compiler/finput.pas @@ -145,6 +145,9 @@ interface objfilename, { fullname of the objectfile } asmfilename, { fullname of the assemblerfile } ppufilename, { fullname of the ppufile } +{$ifdef DEBUG_NODE_XML} + ppxfilename, { fullname of the intermediate node XML file } +{$endif DEBUG_NODE_XML} importlibfilename, { fullname of the import libraryfile } staticlibfilename, { fullname of the static libraryfile } sharedlibfilename, { fullname of the shared libraryfile } @@ -154,6 +157,9 @@ interface dbgfilename, { fullname of the debug info file } path, { path where the module is find/created } outputpath : TPathStr; { path where the .s / .o / exe are created } +{$ifdef DEBUG_NODE_XML} + ppxfilefail: Boolean; { If the ppxfile could not be accessed, flag it } +{$endif DEBUG_NODE_XML} constructor create(const s:string); destructor destroy;override; procedure setfilename(const fn:TPathStr;allowoutput:boolean); @@ -625,6 +631,9 @@ uses asmfilename:=p+n+target_info.asmext; objfilename:=p+n+target_info.objext; ppufilename:=p+n+target_info.unitext; +{$ifdef DEBUG_NODE_XML} + ppxfilename:=p+n+'-node-dump.xml'; +{$endif DEBUG_NODE_XML} importlibfilename:=p+target_info.importlibprefix+n+target_info.importlibext; staticlibfilename:=p+target_info.staticlibprefix+n+target_info.staticlibext; exportfilename:=p+'exp'+n+target_info.objext; @@ -668,6 +677,9 @@ uses realmodulename:=stringdup(s); mainsource:=''; ppufilename:=''; +{$ifdef DEBUG_NODE_XML} + ppxfilename:=''; +{$endif DEBUG_NODE_XML} objfilename:=''; asmfilename:=''; importlibfilename:=''; @@ -679,6 +691,12 @@ uses outputpath:=''; paramfn:=''; path:=''; +{$ifdef DEBUG_NODE_XML} + { Setting ppxfilefail to true will stop it from being written to if it + was never initialised, which happens if a module doesn't need + recompiling. } + ppxfilefail := True; +{$endif DEBUG_NODE_XML} { status } state:=ms_registered; { unit index } diff --git a/compiler/i8086/n8086con.pas b/compiler/i8086/n8086con.pas index 99109edfce..878ee60200 100644 --- a/compiler/i8086/n8086con.pas +++ b/compiler/i8086/n8086con.pas @@ -35,6 +35,9 @@ interface ti8086pointerconstnode = class(tcgpointerconstnode) constructor create(v : TConstPtrUInt;def:tdef);override; procedure printnodedata(var t: text);override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} procedure pass_generate_code;override; end; @@ -70,6 +73,15 @@ implementation inherited printnodedata(t); end; +{$ifdef DEBUG_NODE_XML} + procedure Ti8086PointerConstNode.XMLPrintNodeData(var T: Text); + begin + if (typedef.typ=pointerdef) and (tcpupointerdef(typedef).x86pointertyp in [x86pt_far,x86pt_huge]) then + WriteLn(T, PrintNodeIndention, '$', hexstr(word(value shr 16),4),':',hexstr(word(value),4), '') + else + inherited XMLPrintNodeData(T); + end; +{$endif DEBUG_NODE_XML} procedure ti8086pointerconstnode.pass_generate_code; begin diff --git a/compiler/nbas.pas b/compiler/nbas.pas index f082162704..6ba8fe6536 100644 --- a/compiler/nbas.pas +++ b/compiler/nbas.pas @@ -37,6 +37,9 @@ interface constructor create;virtual; function pass_1 : tnode;override; function pass_typecheck:tnode;override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeTree(var T: Text); override; +{$endif DEBUG_NODE_XML} end; tnothingnodeclass = class of tnothingnode; @@ -83,6 +86,9 @@ interface function pass_1 : tnode;override; function pass_typecheck:tnode;override; function docompare(p: tnode): boolean; override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} end; tasmnodeclass = class of tasmnode; @@ -224,6 +230,10 @@ interface procedure includetempflag(flag: ttempinfoflag); inline; procedure excludetempflag(flag: ttempinfoflag); inline; property tempflags: ttempinfoflags read gettempinfoflags write settempinfoflags; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeInfo(var T: Text); override; + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} end; { a node which will create a (non)persistent temp of a given type with a given } @@ -251,6 +261,9 @@ interface function pass_typecheck: tnode; override; function docompare(p: tnode): boolean; override; procedure printnodedata(var t:text);override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} end; ttempcreatenodeclass = class of ttempcreatenode; @@ -286,6 +299,9 @@ interface function docompare(p: tnode): boolean; override; destructor destroy; override; procedure printnodedata(var t:text);override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} protected release_to_normal : boolean; private @@ -324,6 +340,14 @@ implementation pass_1, nutils,nld, procinfo +{$ifdef DEBUG_NODE_XML} +{$ifndef jvm} + , + cpubase, + cutils, + itcpugas +{$endif jvm} +{$endif DEBUG_NODE_XML} ; @@ -395,6 +419,15 @@ implementation expectloc:=LOC_VOID; end; +{$ifdef DEBUG_NODE_XML} + procedure TNothingNode.XMLPrintNodeTree(var T: Text); + begin + Write(T, PrintNodeIndention, '<', nodetype2str[nodetype]); + XMLPrintNodeInfo(T); + { "Nothing nodes" contain no data, so just use "/>" to terminate it early } + WriteLn(T, ' />'); + end; +{$endif DEBUG_NODE_XML} {***************************************************************************** TFIRSTERROR @@ -892,6 +925,159 @@ implementation docompare := false; end; +{$ifdef DEBUG_NODE_XML} + procedure TAsmNode.XMLPrintNodeData(var T: Text); + + procedure PadString(var S: string; Len: Integer); + var + X, C: Integer; + begin + C := Length(S); + if C < Len then + begin + SetLength(S, 7); + for X := C + 1 to Len do + S[X] := ' ' + end; + end; + +{$ifndef jvm} + function FormatOp(const Oper: POper): string; + begin + case Oper^.typ of + top_const: + begin + case Oper^.val of + -15..15: + Result := '$' + tostr(Oper^.val); + $10..$FF: + Result := '$0x' + hexstr(Oper^.val, 2); + $100..$FFFF: + Result := '$0x' + hexstr(Oper^.val, 4); + $10000..$FFFFFFFF: + Result := '$0x' + hexstr(Oper^.val, 8); + else + Result := '$0x' + hexstr(Oper^.val, 16); + end; + end; + top_reg: + Result := gas_regname(Oper^.reg); + top_ref: + with Oper^.ref^ do + begin +{$if defined(x86)} + if segment <> NR_NO then + Result := gas_regname(segment) + ':' + else + Result := ''; +{$endif defined(x86)} + + if Assigned(symbol) then + begin + Result := Result + symbol.Name; + if offset > 0 then + Result := Result + '+'; + end; + + if offset <> 0 then + Result := Result + tostr(offset) + else + Result := Result; + + if (base <> NR_NO) or (index <> NR_NO) then + begin + Result := Result + '('; + + if base <> NR_NO then + begin + Result := Result + gas_regname(base); + if index <> NR_NO then + Result := Result + ','; + end; + + if index <> NR_NO then + Result := Result + gas_regname(index); + + if scalefactor <> 0 then + Result := Result + ',' + tostr(scalefactor) + ')' + else + Result := Result + ')'; + end; + end; + top_bool: + begin + if Oper^.b then + Result := 'TRUE' + else + Result := 'FALSE'; + end + else + Result := ''; + end; + end; + +{$if defined(x86)} + procedure ProcessInstruction(p: tai); inline; + var + ThisOp, ThisOper: string; + X: Integer; + begin + case p.typ of + ait_label: + WriteLn(T, PrintNodeIndention, tai_label(p).labsym.name); + + ait_instruction: + begin + ThisOp := gas_op2str[taicpu(p).opcode]+cond2str[taicpu(p).condition]; + if gas_needsuffix[taicpu(p).opcode] <> AttSufNONE then + ThisOp := ThisOp + gas_opsize2str[taicpu(p).opsize]; + + { Pad the opcode with spaces so the succeeding operands are aligned } + PadString(ThisOp, 7); + + Write(T, PrintNodeIndention, ' ', ThisOp); { Extra indentation to account for label formatting } + for X := 0 to taicpu(p).ops - 1 do + begin + Write(T, ' '); + + ThisOper := FormatOp(taicpu(p).oper[X]); + if X < taicpu(p).ops - 1 then + begin + ThisOper := ThisOper + ','; + PadString(ThisOper, 7); + end; + + Write(T, ThisOper); + end; + WriteLn(T); + end; + else + { Do nothing }; + end; + end; + + var + hp: tai; + begin + if not Assigned(p_asm) then + Exit; + + hp := tai(p_asm.First); + while Assigned(hp) do + begin + ProcessInstruction(hp); + hp := tai(hp.Next); + end; +{$else defined(x86)} + begin + WriteLn(T, PrintNodeIndention, '(Assembler output not currently supported on this platform)'); +{$endif defined(x86)} +{$else jvm} + begin + WriteLn(T, PrintNodeIndention, '(Should assembly language even be possible under JVM?)'); +{$endif jvm} + end; +{$endif DEBUG_NODE_XML} {***************************************************************************** TEMPBASENODE @@ -939,6 +1125,47 @@ implementation settempinfoflags(gettempinfoflags-[flag]) end; +{$ifdef DEBUG_NODE_XML} + procedure TTempBaseNode.XMLPrintNodeInfo(var T: Text); + begin + inherited XMLPrintNodeInfo(T); + + { The raw pointer is the only way to uniquely identify the temp } + Write(T, ' id="', WritePointer(tempinfo), '"'); + end; + + + procedure TTempBaseNode.XMLPrintNodeData(var T: Text); + var + Flag: TTempInfoFlag; + NotFirst: Boolean; + begin + inherited XMLPrintNodeData(t); + + if not assigned(tempinfo) then + exit; + + WriteLn(T, PrintNodeIndention, '', SanitiseXMLString(tempinfo^.typedef.typesymbolprettyname), ''); + + NotFirst := False; + for Flag := Low(TTempInfoFlag) to High(TTempInfoFlag) do + if (Flag in tempinfo^.flags) then + if not NotFirst then + begin + Write(T, PrintNodeIndention, '', Flag); + NotFirst := True; + end + else + Write(T, ',', Flag); + + if NotFirst then + WriteLn(T, '') + else + WriteLn(T, PrintNodeIndention, ''); + + WriteLn(T, PrintNodeIndention, '', tempinfo^.temptype, ''); + end; +{$endif DEBUG_NODE_XML} {***************************************************************************** TEMPCREATENODE @@ -1136,6 +1363,24 @@ implementation printnode(t,tempinfo^.tempinitcode); end; +{$ifdef DEBUG_NODE_XML} + procedure TTempCreateNode.XMLPrintNodeData(var T: Text); + begin + inherited XMLPrintNodeData(T); + WriteLn(T, PrintNodeIndention, '', size, ''); + if Assigned(TempInfo^.TempInitCode) then + begin + WriteLn(T, PrintNodeIndention, ''); + PrintNodeIndent; + XMLPrintNode(T, TempInfo^.TempInitCode); + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + end + else + WriteLn(T, PrintNodeIndention, ''); + end; +{$endif DEBUG_NODE_XML} + {***************************************************************************** TEMPREFNODE *****************************************************************************} @@ -1393,4 +1638,12 @@ implementation tempinfo^.typedef.GetTypeName,'", temptype = ',tempinfo^.temptype,', tempinfo = $',hexstr(ptrint(tempinfo),sizeof(ptrint)*2)); end; +{$ifdef DEBUG_NODE_XML} + procedure TTempDeleteNode.XMLPrintNodeData(var T: Text); + begin + inherited XMLPrintNodeData(T); + WriteLn(T, PrintNodeIndention, '', release_to_normal, ''); + end; +{$endif DEBUG_NODE_XML} + end. diff --git a/compiler/ncal.pas b/compiler/ncal.pas index 546a1a0d99..295926019d 100644 --- a/compiler/ncal.pas +++ b/compiler/ncal.pas @@ -201,6 +201,9 @@ interface {$endif state_tracking} function docompare(p: tnode): boolean; override; procedure printnodedata(var t:text);override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} function para_count:longint; function required_para_count:longint; { checks if there are any parameters which end up at the stack, i.e. @@ -1836,6 +1839,56 @@ implementation (not(cnf_typedefset in callnodeflags) and not(cnf_typedefset in tcallnode(p).callnodeflags))); end; +{$ifdef DEBUG_NODE_XML} + procedure TCallNode.XMLPrintNodeData(var T: Text); + begin + if assigned(procdefinition) and (procdefinition.typ=procdef) then + WriteLn(T, PrintNodeIndention, '', SanitiseXMLString(TProcDef(procdefinition).FullProcName(True)), '') + else + begin + if assigned(symtableprocentry) then + WriteLn(T, PrintNodeIndention, '', symtableprocentry.name, '') + end; + + if assigned(methodpointer) then + begin + WriteLn(T, PrintNodeIndention, ''); + PrintNodeIndent; + XMLPrintNode(T, methodpointer); + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + end; + + if assigned(funcretnode) then + begin + WriteLn(T, PrintNodeIndention, ''); + PrintNodeIndent; + XMLPrintNode(T, funcretnode); + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + end; + + if assigned(callinitblock) then + begin + WriteLn(T, PrintNodeIndention, ''); + PrintNodeIndent; + XMLPrintNode(T, callinitblock); + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + end; + + if assigned(callcleanupblock) then + begin + WriteLn(T, PrintNodeIndention, ''); + PrintNodeIndent; + XMLPrintNode(T, callcleanupblock); + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + end; + + inherited XMLPrintNodeData(T); + end; +{$endif DEBUG_NODE_XML} procedure tcallnode.printnodedata(var t:text); begin diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas index 5f69d3a6e6..84a6c7aa66 100644 --- a/compiler/ncnv.pas +++ b/compiler/ncnv.pas @@ -64,6 +64,9 @@ interface procedure derefimpl;override; function dogetcopy : tnode;override; procedure printnodeinfo(var t : text);override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeInfo(var T: Text); override; +{$endif DEBUG_NODE_XML} function pass_1 : tnode;override; function pass_typecheck:tnode;override; function simplify(forinline : boolean):tnode; override; @@ -1047,6 +1050,31 @@ implementation write(t,']'); end; +{$ifdef DEBUG_NODE_XML} + procedure TTypeConvNode.XMLPrintNodeInfo(var T: Text); + var + First: Boolean; + i: TTypeConvNodeFlag; + begin + inherited XMLPrintNodeInfo(T); + Write(T,' convtype="', convtype); + First := True; + for i := Low(TTypeConvNodeFlag) to High(TTypeConvNodeFlag) do + if i in ConvNodeFlags then + begin + if First then + begin + Write(T, '" convnodeflags="', i); + First := False; + end + else + Write(T, ',', i); + end; + + { If no flags were printed, this is the closing " for convtype } + Write(T, '"'); + end; +{$endif DEBUG_NODE_XML} function ttypeconvnode.typecheck_cord_to_pointer : tnode; diff --git a/compiler/ncon.pas b/compiler/ncon.pas index 594d2f54a5..a2a62bcb40 100644 --- a/compiler/ncon.pas +++ b/compiler/ncon.pas @@ -48,6 +48,9 @@ interface function pass_typecheck:tnode;override; function docompare(p: tnode) : boolean; override; procedure printnodedata(var t:text);override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} end; trealconstnodeclass = class of trealconstnode; @@ -70,6 +73,10 @@ interface function pass_typecheck:tnode;override; function docompare(p: tnode) : boolean; override; procedure printnodedata(var t:text);override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeInfo(var T: Text); override; + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} end; tordconstnodeclass = class of tordconstnode; @@ -87,6 +94,9 @@ interface function pass_typecheck:tnode;override; function docompare(p: tnode) : boolean; override; procedure printnodedata(var t : text); override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} end; tpointerconstnodeclass = class of tpointerconstnode; @@ -124,6 +134,9 @@ interface { returns whether this platform uses the nil pointer to represent empty dynamic strings } class function emptydynstrnil: boolean; virtual; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} end; tstringconstnodeclass = class of tstringconstnode; @@ -494,6 +507,13 @@ implementation writeln(t,printnodeindention,'value = ',value_real); end; +{$ifdef DEBUG_NODE_XML} + procedure TRealConstNode.XMLPrintNodeData(var T: Text); + begin + inherited XMLPrintNodeData(T); + WriteLn(T, printnodeindention, '', value_real, ''); + end; +{$endif DEBUG_NODE_XML} {***************************************************************************** TORDCONSTNODE @@ -586,6 +606,20 @@ implementation writeln(t,printnodeindention,'value = ',tostr(value)); end; +{$ifdef DEBUG_NODE_XML} + procedure TOrdConstNode.XMLPrintNodeInfo(var T: Text); + begin + inherited XMLPrintNodeInfo(T); + Write(T, ' rangecheck="', rangecheck, '"'); + end; + + + procedure TOrdConstNode.XMLPrintNodeData(var T: Text); + begin + inherited XMLPrintNodeData(T); + WriteLn(T, printnodeindention, '', tostr(value), ''); + end; +{$endif DEBUG_NODE_XML} {***************************************************************************** TPOINTERCONSTNODE @@ -668,6 +702,13 @@ implementation writeln(t,printnodeindention,'value = $',hexstr(PUInt(value),sizeof(PUInt)*2)); end; +{$ifdef DEBUG_NODE_XML} + procedure TPointerConstNode.XMLPrintNodeData(var T: Text); + begin + inherited XMLPrintNodeData(T); + WriteLn(T, PrintNodeIndention, '$', hexstr(PUInt(value),sizeof(PUInt)*2), ''); + end; +{$endif DEBUG_NODE_XML} {***************************************************************************** TSTRINGCONSTNODE @@ -1031,6 +1072,52 @@ implementation result:=true; end; +{$ifdef DEBUG_NODE_XML} + procedure TStringConstNode.XMLPrintNodeData(var T: Text); + var + OutputStr: ansistring; + begin + inherited XMLPrintNodeData(T); + Write(T, printnodeindention, ''); + case cst_type of + cst_conststring: + Write(T, 'conststring'); + cst_shortstring: + Write(T, 'shortstring'); + cst_longstring: + Write(T, 'longstring'); + cst_ansistring: + Write(T, 'ansistring'); + cst_widestring: + Write(T, 'widestring'); + cst_unicodestring: + Write(T, 'unicodestring'); + end; + WriteLn(T, ''); + WriteLn(T, printnodeindention, '', len, ''); + + if len = 0 then + begin + WriteLn(T, printnodeindention, ''); + Exit; + end; + + case cst_type of + cst_widestring, cst_unicodestring: + begin + { value_str is of type PCompilerWideString } + SetLength(OutputStr, len); + UnicodeToUtf8(PChar(OutputStr), PUnicodeChar(PCompilerWideString(value_str)^.data), len + 1); { +1 for the null terminator } + end; + else + OutputStr := ansistring(value_str); + SetLength(OutputStr, len); + end; + + WriteLn(T, printnodeindention, '', SanitiseXMLString(OutputStr), ''); + end; +{$endif DEBUG_NODE_XML} + {***************************************************************************** TSETCONSTNODE *****************************************************************************} diff --git a/compiler/nflw.pas b/compiler/nflw.pas index 8221dac21e..e4f983bd0a 100644 --- a/compiler/nflw.pas +++ b/compiler/nflw.pas @@ -68,6 +68,10 @@ interface procedure derefimpl;override; procedure insertintolist(l : tnodelist);override; procedure printnodetree(var t:text);override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeInfo(var T: Text); override; + procedure XMLPrintNodeTree(var T: Text); override; +{$endif DEBUG_NODE_XML} function docompare(p: tnode): boolean; override; end; @@ -1052,6 +1056,119 @@ implementation writeln(t,printnodeindention,')'); end; +{$ifdef DEBUG_NODE_XML} + procedure TLoopNode.XMLPrintNodeInfo(var T: Text); + var + i: TLoopFlag; + First: Boolean; + begin + inherited XMLPrintNodeInfo(T); + + First := True; + for i := Low(TLoopFlag) to High(TLoopFlag) do + if i in loopflags then + begin + if First then + begin + Write(T, ' loopflags="', i); + First := False; + end + else + Write(T, ',', i) + end; + if not First then + Write(T, '"'); + end; + + procedure TLoopNode.XMLPrintNodeTree(var T: Text); + begin + Write(T, PrintNodeIndention, '<', nodetype2str[nodetype]); + XMLPrintNodeInfo(T); + WriteLn(T, '>'); + PrintNodeIndent; + if Assigned(Left) then + begin + if nodetype = forn then + WriteLn(T, PrintNodeIndention, '') + else + WriteLn(T, PrintNodeIndention, ''); + PrintNodeIndent; + XMLPrintNode(T, Left); + PrintNodeUnindent; + if nodetype = forn then + WriteLn(T, PrintNodeIndention, '') + else + WriteLn(T, PrintNodeIndention, ''); + end; + + if Assigned(Right) then + begin + case nodetype of + ifn: + WriteLn(T, PrintNodeIndention, ''); + forn: + WriteLn(T, PrintNodeIndention, ''); + else + WriteLn(T, PrintNodeIndention, ''); + end; + PrintNodeIndent; + XMLPrintNode(T, Right); + PrintNodeUnindent; + case nodetype of + ifn: + WriteLn(T, PrintNodeIndention, ''); + forn: + WriteLn(T, PrintNodeIndention, ''); + else + WriteLn(T, PrintNodeIndention, ''); + end; + end; + + if Assigned(t1) then + begin + case nodetype of + ifn: + WriteLn(T, PrintNodeIndention, ''); + forn: + WriteLn(T, PrintNodeIndention, ''); + else + WriteLn(T, PrintNodeIndention, ''); + end; + PrintNodeIndent; + XMLPrintNode(T, t1); + PrintNodeUnindent; + case nodetype of + ifn: + WriteLn(T, PrintNodeIndention, ''); + forn: + WriteLn(T, PrintNodeIndention, ''); + else + WriteLn(T, PrintNodeIndention, ''); + end; + end; + + if Assigned(t2) then + begin + + if nodetype <> forn then + begin + WriteLn(T, PrintNodeIndention, ''); + PrintNodeIndent; + end; + + XMLPrintNode(T, t2); + + if nodetype <> forn then + begin + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + end; + end; + + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + end; +{$endif DEBUG_NODE_XML} function tloopnode.docompare(p: tnode): boolean; begin diff --git a/compiler/ninl.pas b/compiler/ninl.pas index 3ba81a434e..fcb18430a2 100644 --- a/compiler/ninl.pas +++ b/compiler/ninl.pas @@ -36,6 +36,9 @@ interface procedure ppuwrite(ppufile:tcompilerppufile);override; function dogetcopy : tnode;override; procedure printnodeinfo(var t : text);override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeInfo(var t : text);override; +{$endif DEBUG_NODE_XML} function pass_1 : tnode;override; function pass_typecheck:tnode;override; function pass_typecheck_cpu:tnode;virtual; @@ -191,6 +194,13 @@ implementation write(t,', inlinenumber = ',inlinenumber); end; +{$ifdef DEBUG_NODE_XML} + procedure TInlineNode.XMLPrintNodeInfo(var T: Text); + begin + inherited; + Write(T, ' inlinenumber="', inlinenumber, '"'); + end; +{$endif DEBUG_NODE_XML} function get_str_int_func(def: tdef): string; var diff --git a/compiler/nld.pas b/compiler/nld.pas index 65a82a13f1..913d1a1533 100644 --- a/compiler/nld.pas +++ b/compiler/nld.pas @@ -71,6 +71,9 @@ interface procedure mark_write;override; function docompare(p: tnode): boolean; override; procedure printnodedata(var t:text);override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} procedure setprocdef(p : tprocdef); property procdef: tprocdef read fprocdef write setprocdef; end; @@ -97,6 +100,9 @@ interface function track_state_pass(exec_known:boolean):boolean;override; {$endif state_tracking} function docompare(p: tnode): boolean; override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} end; tassignmentnodeclass = class of tassignmentnode; @@ -471,6 +477,16 @@ implementation writeln(t,''); end; +{$ifdef DEBUG_NODE_XML} + procedure TLoadNode.XMLPrintNodeData(var T: Text); + begin + inherited XMLPrintNodeData(T); + WriteLn(T, printnodeindention, '', symtableentry.name, ''); + + if symtableentry.typ = procsym then + WriteLn(T, printnodeindention, '', fprocdef.mangledname, ''); + end; +{$endif DEBUG_NODE_XML} procedure tloadnode.setprocdef(p : tprocdef); begin @@ -956,6 +972,18 @@ implementation {$endif} +{$ifdef DEBUG_NODE_XML} + procedure TAssignmentNode.XMLPrintNodeData(var T: Text); + begin + { For assignments, put the left and right branches on the same level for clarity } + XMLPrintNode(T, Left); + XMLPrintNode(T, Right); + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + end; +{$endif DEBUG_NODE_XML} + + {***************************************************************************** TARRAYCONSTRUCTORRANGENODE *****************************************************************************} diff --git a/compiler/nmem.pas b/compiler/nmem.pas index 4eae7da363..79efbdaa66 100644 --- a/compiler/nmem.pas +++ b/compiler/nmem.pas @@ -88,6 +88,9 @@ interface procedure buildderefimpl;override; procedure derefimpl;override; procedure printnodeinfo(var t: text); override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeInfo(var T: Text); override; +{$endif DEBUG_NODE_XML} function docompare(p: tnode): boolean; override; function dogetcopy : tnode;override; function pass_1 : tnode;override; @@ -121,6 +124,9 @@ interface function docompare(p: tnode): boolean; override; function pass_typecheck:tnode;override; procedure mark_write;override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} end; tsubscriptnodeclass = class of tsubscriptnode; @@ -133,6 +139,9 @@ interface function pass_1 : tnode;override; function pass_typecheck:tnode;override; procedure mark_write;override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} end; tvecnodeclass = class of tvecnode; @@ -481,6 +490,29 @@ implementation write(t,']'); end; +{$ifdef DEBUG_NODE_XML} + procedure TAddrNode.XMLPrintNodeInfo(var T: Text); + var + First: Boolean; + i: TAddrNodeFlag; + begin + inherited XMLPrintNodeInfo(t); + First := True; + for i := Low(TAddrNodeFlag) to High(TAddrNodeFlag) do + if i in addrnodeflags then + begin + if First then + begin + Write(T, ' addrnodeflags="', i); + First := False; + end + else + Write(T, ',', i); + end; + if not First then + Write(T, '"'); + end; +{$endif DEBUG_NODE_XML} function taddrnode.docompare(p: tnode): boolean; begin @@ -897,6 +929,13 @@ implementation (vs = tsubscriptnode(p).vs); end; +{$ifdef DEBUG_NODE_XML} + procedure TSubscriptNode.XMLPrintNodeData(var T: Text); + begin + inherited XMLPrintNodeData(T); + WriteLn(T, PrintNodeIndention, '', vs.Name, ''); + end; +{$endif DEBUG_NODE_XML} {***************************************************************************** TVECNODE @@ -1299,6 +1338,24 @@ implementation end; +{$ifdef DEBUG_NODE_XML} + procedure TVecNode.XMLPrintNodeData(var T: Text); + begin + XMLPrintNode(T, Left); + + { The right node is the index } + WriteLn(T, PrintNodeIndention, ''); + PrintNodeIndent; + XMLPrintNode(T, Right); + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + end; +{$endif DEBUG_NODE_XML} + + function is_big_untyped_addrnode(p: tnode): boolean; begin is_big_untyped_addrnode:=(p.nodetype=addrn) and diff --git a/compiler/node.pas b/compiler/node.pas index a0aad228eb..c5d74d37f7 100644 --- a/compiler/node.pas +++ b/compiler/node.pas @@ -383,6 +383,15 @@ interface procedure printnodeinfo(var t:text);virtual; procedure printnodedata(var t:text);virtual; procedure printnodetree(var t:text);virtual; +{$ifdef DEBUG_NODE_XML} + { For writing nodes to XML files - do not call directly, but + instead call XMLPrintNode to write a complete tree } + procedure XMLPrintNodeInfo(var T: Text); dynamic; + procedure XMLPrintNodeData(var T: Text); virtual; + procedure XMLPrintNodeTree(var T: Text); virtual; + class function SanitiseXMLString(const S: ansistring): ansistring; + class function WritePointer(const P: Pointer): ansistring; +{$endif DEBUG_NODE_XML} procedure concattolist(l : tlinkedlist);virtual; function ischild(p : tnode) : boolean;virtual; @@ -413,6 +422,9 @@ interface function dogetcopy : tnode;override; procedure insertintolist(l : tnodelist);override; procedure printnodedata(var t:text);override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} end; //pbinarynode = ^tbinarynode; @@ -431,6 +443,10 @@ interface function dogetcopy : tnode;override; procedure insertintolist(l : tnodelist);override; procedure printnodedata(var t:text);override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeTree(var T: Text); override; + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} procedure printnodelist(var t:text); end; @@ -449,11 +465,17 @@ interface function dogetcopy : tnode;override; procedure insertintolist(l : tnodelist);override; procedure printnodedata(var t:text);override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} end; tbinopnode = class(tbinarynode) constructor create(t:tnodetype;l,r : tnode);virtual; function docompare(p : tnode) : boolean;override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeData(var T: Text); override; +{$endif DEBUG_NODE_XML} end; var @@ -476,7 +498,9 @@ interface procedure printnodeunindent; procedure printnode(var t:text;n:tnode); procedure printnode(n:tnode); - +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNode(var T: Text; N: TNode); +{$endif DEBUG_NODE_XML} function is_constnode(p : tnode) : boolean; function is_constintnode(p : tnode) : boolean; function is_constcharnode(p : tnode) : boolean; @@ -494,6 +518,9 @@ implementation uses verbose,entfile,comphook, +{$ifdef DEBUG_NODE_XML} + cutils, +{$endif DEBUG_NODE_XML} symconst, nutils,nflw, defutil; @@ -656,6 +683,13 @@ implementation printnode(output,n); end; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNode(var T: Text; N: TNode); + begin + if Assigned(N) then + N.XMLPrintNodeTree(T); + end; +{$endif DEBUG_NODE_XML} function is_constnode(p : tnode) : boolean; begin @@ -898,6 +932,354 @@ implementation writeln(t,printnodeindention,')'); end; +{$ifdef DEBUG_NODE_XML} + { For writing nodes to XML files - do not call directly, but + instead call XMLPrintNode to write a complete tree } + procedure tnode.XMLPrintNodeInfo(var T: Text); + var + i: TNodeFlag; + first: Boolean; + begin + if Assigned(resultdef) then + Write(T,' resultdef="', SanitiseXMLString(resultdef.typesymbolprettyname), '"'); + + Write(T,' pos="',fileinfo.line,',',fileinfo.column); + + First := True; + for i := Low(TNodeFlag) to High(TNodeFlag) do + if i in flags then + begin + if First then + begin + Write(T, '" flags="', i); + First := False; + end + else + Write(T, ',', i) + end; + + write(t,'" complexity="',node_complexity(self),'"'); + end; + + procedure tnode.XMLPrintNodeData(var T: Text); + begin + { Nothing by default } + end; + + procedure tnode.XMLPrintNodeTree(var T: Text); + begin + Write(T, PrintNodeIndention, '<', nodetype2str[nodetype]); + XMLPrintNodeInfo(T); + WriteLn(T, '>'); + PrintNodeIndent; + XMLPrintNodeData(T); + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + end; + + class function TNode.WritePointer(const P: Pointer): ansistring; + begin + case PtrUInt(P) of + 0: + WritePointer := 'nil'; + 1..$FFFF: + WritePointer := '$' + hexstr(PtrUInt(P), 4); + $10000..$FFFFFFFF: + WritePointer := '$' + hexstr(PtrUInt(P), 8); +{$ifdef CPU64} + else + WritePointer := '$' + hexstr(PtrUInt(P), 16); +{$endif CPU64} + end; + end; + + class function TNode.SanitiseXMLString(const S: ansistring): ansistring; + var + X, UTF8Len, UTF8Char, CurrentChar: Integer; + needs_quoting, in_quotes, add_end_quote: Boolean; + DoASCII: Boolean; + + { Write the given byte as #xxx } + procedure EncodeControlChar(Value: Byte); + begin + if X = Length(Result) then + add_end_quote := False; + + Delete(Result, X, 1); + if in_quotes then + begin + Insert('#' + tostr(Value) + '''', Result, X); + + { If the entire string consists of control characters, it + doesn't need quoting, so only set the flag here } + needs_quoting := True; + + in_quotes := False; + end + else + Insert('#' + tostr(Value), Result, X); + end; + + { Write the given byte as either a plain character or an XML keyword } + procedure EncodeStandardChar(Value: Byte); + begin + if not in_quotes then + begin + in_quotes := True; + if (X < Length(Result)) then + begin + needs_quoting := True; + Insert('''', Result, X + 1) + end; + end; + + { Check the character for anything that could be mistaken for an XML element } + case CurrentChar of + Ord('#'): + { Required to differentiate '#27' from the escape code #27, for example } + needs_quoting:=true; + + Ord('<'): + begin + Delete(Result, X, 1); + Insert('<', Result, X); + end; + Ord('>'): + begin + Delete(Result, X, 1); + Insert('>', Result, X); + end; + Ord('&'): + begin + Delete(Result, X, 1); + Insert('&', Result, X); + end; + Ord('"'): + begin + needs_quoting := True; + Delete(Result, X, 1); + Insert('"', Result, X); + end; + Ord(''''): + begin + needs_quoting:=true; + { Simply double it like in pascal strings } + Insert('''', Result, X); + end; + else + { Do nothing }; + end; + end; + + { Convert character between $80 and $FF to UTF-8 } + procedure EncodeExtendedChar(Value: Byte); + begin + if not in_quotes then + begin + in_quotes := True; + if (X < Length(Result)) then + begin + needs_quoting := True; + Insert('''', Result, X + 1) + end; + end; + + case Value of + $80..$BF: { Add $C2 before the value } + Insert(#$C2, Result, X); + $C0..$FF: { Zero the $40 bit and add $C3 before the value } + begin + Result[X] := Char(Byte(Result[X]) and $BF); + Insert(#$C3, Result, X); + end; + else + { Previous conditions should prevent this procedure from being + called if Value < $80 } + InternalError(2019061901); + end; + end; + + begin + needs_quoting := False; + Result := S; + + { Gets set to True if an invalid UTF-8 sequence is found } + DoASCII := False; + + { By setting in_quotes to false here, we can exclude the single + quotation marks surrounding the string if it doesn't contain any + control characters, or consists entirely of control characters. } + in_quotes := False; + + add_end_quote := True; + + X := Length(Result); + while X > 0 do + begin + CurrentChar := Ord(Result[X]); + + { Control characters and extended characters need special handling } + case CurrentChar of + $00..$1F, $7F: + EncodeControlChar(CurrentChar); + + $20..$7E: + EncodeStandardChar(CurrentChar); + + { UTF-8 continuation byte } + $80..$BF: + begin + if not in_quotes then + begin + in_quotes := True; + if (X < Length(Result)) then + begin + needs_quoting := True; + Insert('''', Result, X + 1) + end; + end; + + UTF8Char := CurrentChar and $3F; { The data bits of the continuation byte } + UTF8Len := 1; { This variable actually holds 1 less than the length } + + { By setting DoASCII to true, it marks the string as 'invalid UTF-8' + automatically if it reaches the beginning of the string unexpectedly } + DoASCII := True; + + Dec(X); + while X > 0 do + begin + CurrentChar := Ord(Result[X]); + + case CurrentChar of + { A standard character here is invalid UTF-8 } + $00..$7F: + Break; + + { Another continuation byte } + $80..$BF: + begin + UTF8Char := UTF8Char or ((CurrentChar and $3F) shl (6 * UTF8Len)); + + Inc(UTF8Len); + if UTF8Len >= 4 then + { Sequence too long } + Break; + end; + + { Lead byte for 2-byte sequences } + $C2..$DF: + begin + if UTF8Len <> 1 then Break; + + UTF8Char := UTF8Char or ((CurrentChar and $1F) shl 6); + + { Check to see if the code is in range and not part of an 'overlong' sequence } + case UTF8Char of + $0080..$07FF: + DoASCII := False; + else + { Do nothing - DoASCII is already true } + end; + Break; + end; + + { Lead byte for 3-byte sequences } + $E0..$EF: + begin + if UTF8Len <> 2 then Break; + + UTF8Char := UTF8Char or ((CurrentChar and $0F) shl 12); + + { Check to see if the code is in range and not part of an 'overlong' sequence } + case UTF8Char of + $0800..$D7FF, $E000..$FFFF: { $D800..$DFFF is reserved and hence invalid } + DoASCII := False; + else + { Do nothing - DoASCII is already true } + end; + Break; + end; + + { Lead byte for 4-byte sequences } + $F0..$F4: + begin + if UTF8Len <> 3 then Break; + + UTF8Char := UTF8Char or ((CurrentChar and $07) shl 18); + + { Check to see if the code is in range and not part of an 'overlong' sequence } + case UTF8Char of + $010000..$10FFFF: + DoASCII := False; + else + { Do nothing - DoASCII is already true } + end; + Break; + end; + + { Invalid character } + else + Break; + end; + end; + + if DoASCII then + Break; + + { If all is fine, we don't need to encode any more characters } + end; + + { Invalid UTF-8 bytes and lead bytes without continuation bytes } + $C0..$FF: + begin + DoASCII := True; + Break; + end; + end; + + Dec(X); + end; + + { UTF-8 failed, so encode the string as plain ASCII } + if DoASCII then + begin + { Reset the flags and Result } + needs_quoting := False; + Result := S; + in_quotes := False; + add_end_quote := True; + + for X := Length(Result) downto 1 do + begin + CurrentChar := Ord(Result[X]); + + { Control characters and extended characters need special handling } + case CurrentChar of + $00..$1F, $7F: + EncodeControlChar(CurrentChar); + + $20..$7E: + EncodeStandardChar(CurrentChar); + + { Extended characters } + else + EncodeExtendedChar(CurrentChar); + + end; + end; + end; + + if needs_quoting then + begin + if in_quotes then + Result := '''' + Result; + + if add_end_quote then + Result := Result + ''''; + end; + end; +{$endif DEBUG_NODE_XML} function tnode.isequal(p : tnode) : boolean; begin @@ -1058,6 +1440,13 @@ implementation printnode(t,left); end; +{$ifdef DEBUG_NODE_XML} + procedure TUnaryNode.XMLPrintNodeData(var T: Text); + begin + inherited XMLPrintNodeData(T); + XMLPrintNode(T, Left); + end; +{$endif DEBUG_NODE_XML} procedure tunarynode.concattolist(l : tlinkedlist); begin @@ -1185,6 +1574,26 @@ implementation printnode(t,right); end; +{$ifdef DEBUG_NODE_XML} + procedure TBinaryNode.XMLPrintNodeTree(var T: Text); + begin + Write(T, PrintNodeIndention, '<', nodetype2str[nodetype]); + XMLPrintNodeInfo(T); + WriteLn(T, '>'); + PrintNodeIndent; + XMLPrintNodeData(T); + end; + + + procedure TBinaryNode.XMLPrintNodeData(var T: Text); + begin + inherited XMLPrintNodeData(T); + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + { Right nodes are on the same indentation level } + XMLPrintNode(T, Right); + end; +{$endif DEBUG_NODE_XML} procedure tbinarynode.printnodelist(var t:text); var @@ -1286,6 +1695,21 @@ implementation printnode(t,third); end; +{$ifdef DEBUG_NODE_XML} + procedure TTertiaryNode.XMLPrintNodeData(var T: Text); + begin + if Assigned(Third) then + begin + WriteLn(T, PrintNodeIndention, ''); + PrintNodeIndent; + XMLPrintNode(T, Third); + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + end; + + inherited XMLPrintNodeData(T); + end; +{$endif DEBUG_NODE_XML} procedure ttertiarynode.concattolist(l : tlinkedlist); begin @@ -1320,6 +1744,18 @@ implementation right.isequal(tbinopnode(p).left)); end; +{$ifdef DEBUG_NODE_XML} + procedure TBinOpNode.XMLPrintNodeData(var T: Text); + begin + { For binary operations, put the left and right branches on the same level for clarity } + XMLPrintNode(T, Left); + XMLPrintNode(T, Right); + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + end; +{$endif DEBUG_NODE_XML} + + begin {$push}{$warnings off} { tvaroption must fit into a 4 byte set for speed reasons } diff --git a/compiler/nset.pas b/compiler/nset.pas index ae7f4bbb16..718bb54529 100644 --- a/compiler/nset.pas +++ b/compiler/nset.pas @@ -120,6 +120,9 @@ interface procedure derefimpl;override; function dogetcopy : tnode;override; procedure printnodetree(var t:text);override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintNodeTree(var t:text); override; +{$endif DEBUG_NODE_XML} procedure insertintolist(l : tnodelist);override; function pass_typecheck:tnode;override; function pass_1 : tnode;override; @@ -1014,6 +1017,43 @@ implementation writeln(t,printnodeindention,')'); end; +{$ifdef DEBUG_NODE_XML} + procedure TCaseNode.XMLPrintNodeTree(var T: Text); + var + i : longint; + begin + Write(T, PrintNodeIndention, '<', nodetype2str[nodetype]); + XMLPrintNodeInfo(T); + WriteLn(T, '>'); + PrintNodeIndent; + WriteLn(T, PrintNodeIndention, ''); + PrintNodeIndent; + XMLPrintNode(T, Left); + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + + i:=0; + for i:=0 to blocks.count-1 do + begin + WriteLn(T, PrintNodeIndention, ''); + PrintNodeIndent; + XMLPrintNode(T, PCaseBlock(blocks[i])^.statement); + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + end; + if assigned(elseblock) then + begin + WriteLn(T, PrintNodeIndention, '');; + PrintNodeIndent; + XMLPrintNode(T, ElseBlock); + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + end; + + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + end; +{$endif DEBUG_NODE_XML} procedure tcasenode.insertintolist(l : tnodelist); begin diff --git a/compiler/pmodules.pas b/compiler/pmodules.pas index 3a3159ff12..11f6deaa73 100644 --- a/compiler/pmodules.pas +++ b/compiler/pmodules.pas @@ -886,6 +886,10 @@ type current_module.SetFileName(main_file.path+main_file.name,true); current_module.SetModuleName(unitname); +{$ifdef DEBUG_NODE_XML} + XMLInitializeNodeFile('unit', unitname); +{$endif DEBUG_NODE_XML} + { check for system unit } new(s2); s2^:=upper(ChangeFileExt(ExtractFileName(main_file.name),'')); @@ -1023,6 +1027,10 @@ type Message1(unit_f_errors_in_unit,tostr(Errorcount)); status.skip_error:=true; symtablestack.pop(current_module.globalsymtable); + +{$ifdef DEBUG_NODE_XML} + XMLFinalizeNodeFile('unit'); +{$endif DEBUG_NODE_XML} exit; end; @@ -1316,6 +1324,10 @@ type module_is_done; if not immediate then restore_global_state(globalstate,true); + +{$ifdef DEBUG_NODE_XML} + XMLFinalizeNodeFile('unit'); +{$endif DEBUG_NODE_XML} exit; end; @@ -1405,6 +1417,10 @@ type module_is_done; if not immediate then restore_global_state(globalstate,true); + +{$ifdef DEBUG_NODE_XML} + XMLFinalizeNodeFile('unit'); +{$endif DEBUG_NODE_XML} exit; end; @@ -1464,6 +1480,9 @@ type waitingmodule.end_of_parsing; end; end; +{$ifdef DEBUG_NODE_XML} + XMLFinalizeNodeFile('unit'); +{$endif DEBUG_NODE_XML} end; @@ -1545,6 +1564,10 @@ type setupglobalswitches; +{$ifdef DEBUG_NODE_XML} + XMLInitializeNodeFile('package', module_name); +{$endif DEBUG_NODE_XML} + consume(_SEMICOLON); { global switches are read, so further changes aren't allowed } @@ -1727,6 +1750,10 @@ type main_procinfo.generate_code; end; +{$ifdef DEBUG_NODE_XML} + XMLFinalizeNodeFile('package'); +{$endif DEBUG_NODE_XML} + { leave when we got an error } if (Errorcount>0) and not status.skip_error then begin @@ -1991,6 +2018,10 @@ type setupglobalswitches; consume(_SEMICOLON); + +{$ifdef DEBUG_NODE_XML} + XMLInitializeNodeFile('library', program_name); +{$endif DEBUG_NODE_XML} end else { is there an program head ? } @@ -2037,6 +2068,10 @@ type setupglobalswitches; consume(_SEMICOLON); + +{$ifdef DEBUG_NODE_XML} + XMLInitializeNodeFile('program', program_name); +{$endif DEBUG_NODE_XML} end else begin @@ -2045,6 +2080,10 @@ type { setup things using the switches } setupglobalswitches; + +{$ifdef DEBUG_NODE_XML} + XMLInitializeNodeFile('program', current_module.realmodulename^); +{$endif DEBUG_NODE_XML} end; { load all packages, so we know whether a unit is contained inside a @@ -2267,6 +2306,13 @@ type { consume the last point } consume(_POINT); +{$ifdef DEBUG_NODE_XML} + if IsLibrary then + XMLFinalizeNodeFile('library') + else + XMLFinalizeNodeFile('program'); +{$endif DEBUG_NODE_XML} + { reset wpo flags for all defs } reset_all_defs; diff --git a/compiler/psub.pas b/compiler/psub.pas index 625451407e..43ca6fa9ae 100644 --- a/compiler/psub.pas +++ b/compiler/psub.pas @@ -68,11 +68,18 @@ interface function has_assembler_child : boolean; procedure set_eh_info; override; +{$ifdef DEBUG_NODE_XML} + procedure XMLPrintProc; +{$endif DEBUG_NODE_XML} end; procedure printnode_reset; +{$ifdef DEBUG_NODE_XML} + procedure XMLInitializeNodeFile(RootName, ModuleName: shortstring); + procedure XMLFinalizeNodeFile(RootName: shortstring); +{$endif DEBUG_NODE_XML} { reads the declaration blocks } procedure read_declarations(islibrary : boolean); @@ -1153,6 +1160,67 @@ implementation end; +{$ifdef DEBUG_NODE_XML} + procedure tcgprocinfo.XMLPrintProc; + var + T: Text; + W: Word; + syssym: tsyssym; + + procedure PrintOption(Flag: string); + begin + WriteLn(T, PrintNodeIndention, ''); + end; + + begin + if current_module.ppxfilefail then + Exit; + + Assign(T, current_module.ppxfilename); + {$push} {$I-} + Append(T); + if IOResult <> 0 then + begin + Message1(exec_e_cant_create_archivefile,current_module.ppxfilename); + current_module.ppxfilefail := True; + Exit; + end; + {$pop} + Write(T, PrintNodeIndention, ''); + + PrintNodeIndent; + + 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'); + + WriteLn(T, PrintNodeIndention, ''); + PrintNodeIndent; + XMLPrintNode(T, Code); + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + PrintNodeUnindent; + WriteLn(T, PrintNodeIndention, ''); + WriteLn(T); { Line for spacing } + Close(T); + end; +{$endif DEBUG_NODE_XML} + procedure tcgprocinfo.generate_code_tree; var hpi : tcgprocinfo; @@ -1450,7 +1518,7 @@ implementation {$endif i386 or i8086} { Print the node to tree.log } - if paraprintnodetree=1 then + if paraprintnodetree <> 0 then printproc( 'after the firstpass'); { do this before adding the entry code else the tail recursion recognition won't work, @@ -1577,7 +1645,7 @@ implementation CalcExecutionWeights(code); { Print the node to tree.log } - if paraprintnodetree=1 then + if paraprintnodetree <> 0 then printproc( 'right before code generation'); { generate code for the node tree } @@ -2073,9 +2141,14 @@ implementation CreateInlineInfo; { Print the node to tree.log } - if paraprintnodetree=1 then + if paraprintnodetree <> 0 then printproc( 'after parsing'); +{$ifdef DEBUG_NODE_XML} + printnodeindention := printnodespacing; + XMLPrintProc; +{$endif DEBUG_NODE_XML} + { ... remove symbol tables } remove_from_symtablestack; @@ -2491,6 +2564,50 @@ implementation MessagePos1(tsym(p).fileinfo,sym_e_forward_type_not_resolved,tsym(p).realname); end; +{$ifdef DEBUG_NODE_XML} + procedure XMLInitializeNodeFile(RootName, ModuleName: shortstring); + var + T: Text; + begin + Assign(T, current_module.ppxfilename); + {$push} {$I-} + Rewrite(T); + if IOResult<>0 then + begin + Message1(exec_e_cant_create_archivefile,current_module.ppxfilename); + current_module.ppxfilefail := True; + Exit; + end; + {$pop} + { Mark the node dump file as available for writing } + current_module.ppxfilefail := False; + WriteLn(T, ''); + WriteLn(T, '<', RootName, ' name="', ModuleName, '">'); + Close(T); + end; + + + procedure XMLFinalizeNodeFile(RootName: shortstring); + var + T: Text; + begin + if current_module.ppxfilefail then + Exit; + + current_module.ppxfilefail := True; { File is now considered closed no matter what happens } + Assign(T, current_module.ppxfilename); + {$push} {$I-} + Append(T); + if IOResult<>0 then + begin + Message1(exec_e_cant_create_archivefile,current_module.ppxfilename); + Exit; + end; + {$pop} + WriteLn(T, ''); + Close(T); + end; +{$endif DEBUG_NODE_XML} procedure read_declarations(islibrary : boolean); var