<> <> <> <<>> DIRECTORY BcdDefs: TYPE USING [Base, BcdBase, MTIndex, MTHandle], Basics: TYPE USING [BYTE], ConvertUnsafe: TYPE USING [EqualSubStrings, SubString, SubStringToRope, ToRope], FileIO: TYPE USING [Open, OpenFailed], FileSegment: TYPE USING [Pages, nullPages], IO: TYPE USING [card, Close, EndOf, GetChar, int, PutChar, PutF, PutRope, SetIndex, STREAM], ListerOps: TYPE USING [CodeOptions], ListerUtil: TYPE USING [ CreateStream, LoadBcd, LoadModule, MapPages, Message, SetExtension, SetRoutineSymbols, PutFileID, UnknownModule], OpTableDefs: TYPE USING [InstLength, InstName], PrincOps: TYPE USING [ CSegPrefix, EntryVectorItem, FrameHandle, FrameVec, InstWord, zJ2, zJ9, zJEQ2, zJEQ9, zJIB, zJIW, zJNE2, zJNE9, zLI0, zLI6, zLIB, zLIW, zRF, zRFC, zRFL, zRIGP, zRIGPL, zRILP, zRILPL, zRXGPL, zRXLP, zRXLPL, zWF, zWFL, zWIGPL, zWILP, zWILPL, zWSF, zWXGPL, zWXLP, zWXLPL], PrincOpsUtils: TYPE USING [BITOR], Rope: TYPE USING [Flatten, Length, ROPE], Symbols: TYPE USING [ Name, ISEIndex, BodyInfo, BodyRecord, BTIndex, CBTIndex, nullName, ISENull, BTNull], SymbolSegment: TYPE USING [FGTEntry], SymbolTable: TYPE USING [Base, Acquire, Release, SetCacheSize], UnsafeStorage: TYPE USING [GetSystemUZone], VM: TYPE USING [AddressForPageNumber, Interval, PageCount, Free]; CLList: PROGRAM IMPORTS ConvertUnsafe, FileIO, IO, ListerUtil, OpTableDefs, PrincOpsUtils, Rope, SymbolTable, UnsafeStorage, VM EXPORTS ListerOps = { CodeOptions: TYPE = ListerOps.CodeOptions; MTIndex: TYPE = BcdDefs.MTIndex; FrameHandle: TYPE = PrincOps.FrameHandle; PageCount: TYPE = VM.PageCount; BYTE: TYPE = Basics.BYTE; OpCode: TYPE = BYTE; JumpOp: TYPE = [PrincOps.zJ2..PrincOps.zJIW]; FineGrainInfo: TYPE = RECORD [ firstSource, lastSource: CARDINAL _ nullSource, pc: CARDINAL, procEnd: BOOL, bti: Symbols.CBTIndex]; FGT: TYPE = RECORD [ length: NAT, info: SEQUENCE maxLength: NAT OF FineGrainInfo]; FGHandle: TYPE = LONG POINTER TO FGT; nullSource: CARDINAL = CARDINAL.LAST; -- if lastSource, causes to EOF myFGT: FGHandle; DigestFGT: PROC = { OPEN s: symbols; bti, prev: Symbols.BTIndex; cspp: LONG POINTER TO PrincOps.CSegPrefix = codebase; AddMyEntry: PROC [ source: CARDINAL_nullSource, object: CARDINAL, procEnd: BOOL_FALSE] = { IF n = myFGTSize THEN { oldFGT: FGHandle _ myFGT; myFGTSize _ myFGTSize + 10; SetupMyFGT[]; FOR i: NAT IN [0..oldFGT.maxLength) DO myFGT[i] _ oldFGT[i] ENDLOOP; (UnsafeStorage.GetSystemUZone[]).FREE[@oldFGT]}; myFGT[n] _ [firstSource: source, pc: object, procEnd: procEnd, bti: LOOPHOLE[bti]]; myFGT.length _ n _ n + 1}; AddBodyFGT: PROC [bti: Symbols.CBTIndex] = { OPEN s: symbols; procstart: CARDINAL = cspp.entry[s.bb[bti].entryIndex].initialpc*2; info: Symbols.BodyInfo[External] = NARROW[s.bb[bti].info, Symbols.BodyInfo[External]]; fgLast: CARDINAL = info.startIndex + info.indexLength - 1; lastSource: CARDINAL _ s.bb[bti].sourceIndex; lastObject: CARDINAL _ procstart; FOR i: CARDINAL IN [info.startIndex..fgLast] DO f: SymbolSegment.FGTEntry = s.fgTable[i]; WITH f SELECT FROM normal => { lastSource _ lastSource + deltaSource; lastObject _ lastObject + deltaObject; AddMyEntry[source: lastSource, object: lastObject]}; step => IF which = $source THEN lastSource _ lastSource + delta ELSE lastObject _ lastObject + delta; ENDCASE; ENDLOOP; AddMyEntry[object: procstart + info.bytes, procEnd: TRUE]}; SetupMyFGT: PROC = INLINE { myFGT _ (UnsafeStorage.GetSystemUZone[]).NEW[FGT[myFGTSize] _ [length: 0, info: TRASH]]}; BySource: PROC [r1, r2: LONG POINTER TO FineGrainInfo] RETURNS [BOOL] = { IF r1.firstSource > r2.firstSource THEN RETURN [TRUE]; IF r1.firstSource = r2.firstSource THEN RETURN [r1.pc > r2.pc]; RETURN [FALSE]}; ByPC: PROC [r1, r2: LONG POINTER TO FineGrainInfo] RETURNS [BOOL] = { IF r1.pc > r2.pc THEN RETURN [TRUE]; IF r1.pc < r2.pc THEN RETURN [FALSE]; IF r1.procEnd THEN RETURN [FALSE]; IF r2.procEnd THEN RETURN [TRUE]; RETURN [r1.firstSource > r2.firstSource]}; Sort: PROC [ n: CARDINAL, greater: PROC [r1, r2: LONG POINTER TO FineGrainInfo] RETURNS [BOOL]] = { i: CARDINAL; temp: FineGrainInfo; SiftUp: PROC [l, u: CARDINAL] = { s: CARDINAL; key: FineGrainInfo _ myFGT[l-1]; DO s _ l*2; IF s > u THEN EXIT; IF s < u AND greater[@myFGT[s+1-1], @myFGT[s-1]] THEN s _ s+1; IF greater[@key, @myFGT[s-1]] THEN EXIT; myFGT[l-1] _ myFGT[s-1]; l _ s; ENDLOOP; myFGT[l-1] _ key}; FOR i DECREASING IN [2..n/2] DO SiftUp[i, n]; ENDLOOP; FOR i DECREASING IN [2..n] DO SiftUp[1, i]; temp _ myFGT[1-1]; myFGT[1-1] _ myFGT[i-1]; myFGT[i-1] _ temp; ENDLOOP}; n: CARDINAL _ 0; myFGTSize: CARDINAL _ (3*s.fgTable.LENGTH)/2; SetupMyFGT[]; bti _ Symbols.BTIndex.FIRST; IF s.bb[bti].sourceIndex # 0 THEN AddMyEntry[source: 0, object: cspp.entry[0].initialpc*2]; DO WITH s.bb[bti] SELECT FROM Callable => IF ~inline THEN AddBodyFGT[LOOPHOLE[bti]]; ENDCASE; IF s.bb[bti].firstSon # Symbols.BTNull THEN bti _ s.bb[bti].firstSon ELSE DO prev _ bti; bti _ s.bb[bti].link.index; IF bti = Symbols.BTNull THEN GO TO Done; IF s.bb[prev].link.which # $parent THEN EXIT; ENDLOOP; REPEAT Done => NULL; ENDLOOP; Sort[n, BySource]; FOR i: CARDINAL DECREASING IN [0..n - 1) DO IF myFGT[i].firstSource = nullSource THEN LOOP; IF myFGT[i].firstSource = myFGT[i+1].firstSource THEN { myFGT[i].lastSource _ myFGT[i+1].lastSource; myFGT[i+1].firstSource _ myFGT[i+1].lastSource} ELSE myFGT[i].lastSource _ myFGT[i + 1].firstSource; ENDLOOP; Sort[n, ByPC]}; offset: CARDINAL; codebase: LONG POINTER; codepages: PageCount; symbols: SymbolTable.Base; Tinst, Tbytes, Pinst, Pbytes: CARDINAL _ 0; <> decimal: Rope.ROPE = "%1d"; decimal3: Rope.ROPE = "%3d"; hoctal3: Rope.ROPE; hoctal5: Rope.ROPE; hoctal6: Rope.ROPE; hoctal1: Rope.ROPE; <> Hexify: PROC = {hoctal3 _ "%3x"; hoctal5 _ "%5x"; hoctal6 _ "%5x"; hoctal1 _ "%5x"}; Octify: PROC = {hoctal3 _ "%3b"; hoctal5 _ "%3b"; hoctal6 _ "%3b"; hoctal1 _ "%3b"}; <> source: IO.STREAM; sourceAvailable: BOOL; out: IO.STREAM _ NIL; OpenOutput: PROC [output: Rope.ROPE] = { output _ ListerUtil.SetExtension[output, "cl"]; out _ ListerUtil.CreateStream[output]}; CloseOutput: PROC = { IO.Close[out]; out _ NIL}; OutCheck: PROC [xfirst: CARDINAL, xlast: CARDINAL] = { nextchar: CHAR; lastcr: CARDINAL; IF ~sourceAvailable THEN RETURN; FOR lastcr _ xfirst, lastcr - 1 UNTIL lastcr = 0 DO IO.SetIndex[source, lastcr]; IF source.GetChar[] = '\n THEN EXIT; ENDLOOP; THROUGH (lastcr..xfirst) DO IO.PutChar[out, ' ] ENDLOOP; IO.SetIndex[source, xfirst]; WHILE xfirst # xlast DO IF IO.EndOf[source] THEN GOTO eof; nextchar _ source.GetChar[]; xfirst _ xfirst + 1; IF nextchar = '\032 THEN -- Bravo trailer WHILE nextchar # '\n DO IF IO.EndOf[source] THEN GOTO eof; nextchar _ source.GetChar[]; xfirst _ xfirst + 1; ENDLOOP; IO.PutChar[out, nextchar]; REPEAT eof => NULL; ENDLOOP; IF nextchar # '\n THEN IO.PutChar[out, '\n]}; SetUpSource: PROC = { sourceAvailable _ TRUE; source _ FileIO.Open[ConvertUnsafe.ToRope[symbols.sourceFile] ! FileIO.OpenFailed => {sourceAvailable _ FALSE; CONTINUE}]}; CloseSource: PROC = {IF sourceAvailable THEN IO.Close[source]}; FilterBody: PROC [bti: Symbols.CBTIndex, key: Rope.ROPE] RETURNS [BOOL_TRUE] = { IF key # NIL THEN { sei: Symbols.ISEIndex = symbols.bb[bti].id; hti: Symbols.Name; d1, d2: ConvertUnsafe.SubString; IF sei = Symbols.ISENull OR (hti _ symbols.seb[sei].hash) = Symbols.nullName THEN RETURN [FALSE]; d1 _ symbols.SubStringForName[hti]; d2.offset _ 0; d2.length _ key.Length[]; d2.base _ LOOPHOLE[Rope.Flatten[key]]; RETURN [ConvertUnsafe.EqualSubStrings[d1, d2]]}}; PrintBodyName: PROC [bti: Symbols.CBTIndex] = { IF ~sourceAvailable THEN { sei: Symbols.ISEIndex = symbols.bb[bti].id; hti: Symbols.Name; IF sei # Symbols.ISENull AND (hti _ symbols.seb[sei].hash) # Symbols.nullName THEN { ss: ConvertUnsafe.SubString; ss _ symbols.SubStringForName[hti]; IO.PutRope[out, ConvertUnsafe.SubStringToRope[ss]]; IO.PutRope[out, ":\n"]}}}; EvenUp: PROC [n: CARDINAL] RETURNS [CARDINAL] = INLINE { <> RETURN [n + n MOD 2]}; GetByte: PROC [pc: CARDINAL] RETURNS [BYTE] = { <> w: LONG POINTER TO PrincOps.InstWord = codebase + pc/2; RETURN [IF pc MOD 2 = 0 THEN w.evenbyte ELSE w.oddbyte]}; GetWord: PROC [pc: CARDINAL] RETURNS [WORD] = INLINE { <> RETURN [(codebase + pc)^]}; JumpAddress: PROC [jop: OpCode, arg: INTEGER] RETURNS [CARDINAL] = { <> OPEN PrincOps; SELECT OpTableDefs.InstLength[ jop] FROM 1 => SELECT jop FROM IN [zJ2..zJ9] => arg _ jop - zJ2 + 2; IN [zJEQ2..zJEQ9] => arg _ jop - zJEQ2 + 2; IN [zJNE2..zJNE9] => arg _ jop - zJNE2 + 2; ENDCASE => ERROR; 2 => { IF arg > 177B THEN arg _ PrincOpsUtils.BITOR[arg, 177400B]; arg _ arg - 1}; ENDCASE => arg _ arg - 2; RETURN [INTEGER[offset] + arg]}; OutWJTab: PROC [tabstart, tablength: CARDINAL, options: CodeOptions] = { Pbytes _ Pbytes + tablength*2; FOR pc: CARDINAL IN [tabstart..tabstart + tablength) DO w: INTEGER = GetWord[pc]; IO.PutRope[out, "\n\t\t"]; IF options.stripped THEN {IO.PutF[out, hoctal5, IO.int[w]]; LOOP}; IF options.full THEN IO.PutRope[out, "\t\t"]; IO.PutRope[out, " ("]; IO.PutF[out, hoctal5, IO.card[JumpAddress[PrincOps.zJIW, w]]]; IO.PutChar[out, ')]; ENDLOOP}; OutBJTab: PROC [tabstart, tablength: CARDINAL, options: CodeOptions] = { Pbytes _ Pbytes + EvenUp[tablength]; FOR pc: CARDINAL IN [tabstart*2..tabstart*2 + tablength) DO b: BYTE = GetByte[pc]; IO.PutRope[out, "\n\t\t"]; IF options.stripped THEN {IO.PutF[out, hoctal5, IO.card[b]]; LOOP}; IF options.full THEN IO.PutRope[out, "\t\t"]; IO.PutRope[out, " ("]; IO.PutF[out, hoctal5, IO.card[JumpAddress[PrincOps.zJIB, b]]]; IO.PutChar[out, ')]; ENDLOOP}; PutPair: PROC [byte: CARDINAL] = { a: CARDINAL = byte/16; b: CARDINAL = byte MOD 16; IF a < 8 AND b < 8 THEN IO.PutChar[out, ' ]; IO.PutChar[out, '[]; IO.PutF[out, hoctal1, IO.card[a]]; IO.PutChar[out, ',]; IO.PutF[out, hoctal1, IO.card[b]]; IO.PutChar[out, ']]}; PrintCode: PROC [ startcode, endcode: CARDINAL, options: CodeOptions] = { <> OPEN PrincOps; lastconstant: INTEGER; FOR offset IN [startcode..endcode) DO inst: BYTE = GetByte[offset]; il: [0..3] = OpTableDefs.InstLength[inst]; <> Pinst _ Pinst + 1; IO.PutChar[out, '\t]; IF ~options.stripped THEN { IF options.full THEN { IO.PutF[out, hoctal5, IO.card[offset/2]]; IO.PutRope[out, (IF offset MOD 2 = 0 THEN ",E " ELSE ",O ")]}; IO.PutF[out, hoctal5, IO.card[offset]]; IO.PutChar[out, ':]}; IF options.full THEN { IO.PutRope[out, "\t["]; IO.PutF[out, hoctal3, IO.card[inst]]; IO.PutChar[out, ']]}; IO.PutChar[out, '\t]; IO.PutRope[out, OpTableDefs.InstName[inst]]; SELECT il FROM 0, 1 => { Pbytes _ Pbytes + 1; IF inst IN [zLI0..zLI6] THEN lastconstant _ inst - zLI0 ELSE IF inst IN JumpOp AND ~options.stripped THEN { IO.PutRope[out, "\t ("]; IO.PutF[out, hoctal1, IO.card[JumpAddress[inst, 0]]]; IO.PutChar[out, ')]}}; 2 => { byte: BYTE = GetByte[(offset _ offset + 1)]; Pbytes _ Pbytes + 2; IO.PutChar[out, '\t]; SELECT inst FROM zRILP, zWILP, zRXLP, zWXLP, zRIGP, zRXLPL, zWXLPL, zRXGPL, zWXGPL, zRILPL, zWILPL, zRIGPL, zWIGPL => PutPair[byte]; ENDCASE => IO.PutF[out, hoctal6, IO.card[byte]]; IF inst = zLIB THEN lastconstant _ byte ELSE IF inst IN JumpOp AND ~options.stripped THEN { IO.PutRope[out, " ("]; IO.PutF[out, hoctal1, IO.card[JumpAddress[inst, byte]]]; IO.PutChar[out, ')]}}; 3 => { ab: RECORD [first, second: BYTE]; Pbytes _ Pbytes + 3; ab.first _ GetByte[(offset _ offset + 1)]; ab.second _ GetByte[(offset _ offset + 1)]; IO.PutChar[out, '\t]; SELECT inst FROM zRF, zWF, zWSF, zRFC, zRFL, zWFL => { IO.PutF[out, hoctal6, IO.card[ab.first]]; IO.PutRope[out, ", "]; PutPair[ab.second]}; ENDCASE => { v: INTEGER = ab.first*256 + ab.second; IO.PutF[out, hoctal6, IO.card[v]]; SELECT inst FROM zJIB => OutBJTab[v, lastconstant, options]; zJIW => OutWJTab[v, lastconstant, options]; zLIW => lastconstant _ v; IN JumpOp => IF ~options.stripped THEN { IO.PutRope[out, " ("]; IO.PutF[out, hoctal1, IO.card[JumpAddress[inst, v]]]; IO.PutChar[out, ')]}; ENDCASE}}; ENDCASE; IO.PutChar[out, '\n]; ENDLOOP}; ListModule: PROC [ file, module, proc: Rope.ROPE, output: Rope.ROPE, options: CodeOptions] = { bcdFile: Rope.ROPE; bcdSeg, cSeg, sSeg: FileSegment.Pages; mti: BcdDefs.MTIndex; bcdFile _ ListerUtil.SetExtension[file, "bcd"]; bcdSeg _ ListerUtil.LoadBcd[bcdFile]; IF bcdSeg = FileSegment.nullPages THEN GO TO NoFile; [mti, cSeg, sSeg] _ ListerUtil.LoadModule[bcdSeg, module ! ListerUtil.UnknownModule => {GO TO NoModule}]; DoCodeListing[cSeg, sSeg, bcdSeg, mti, proc, output, options] EXITS NoFile => ListerUtil.Message["File cannot be opened"]; NoModule => { ListerUtil.Message["File does not contain module "]; ListerUtil.Message[module]}}; ShowTotals: PROC = { IO.PutRope[out, "Instructions: "]; IO.PutF[out, decimal, IO.card[Pinst]]; IO.PutRope[out, ", Bytes: "]; IO.PutF[out, decimal, IO.card[Pbytes _ EvenUp[Pbytes]]]; IO.PutRope[out, "\n\n"]; Tinst _ Tinst + Pinst; Pinst _ 0; Tbytes _ Tbytes + Pbytes; Pbytes _ 0}; DoCodeListing: PROC [ cseg, sseg, bcdseg: FileSegment.Pages, mti: MTIndex, proc: Rope.ROPE, output: Rope.ROPE, options: CodeOptions] = { OPEN BcdDefs, Symbols; codeInterval: VM.Interval; crossJumped: BOOL; codeOffset, framesize: CARDINAL; prevBti: BTIndex _ BTNull; BEGIN bcdInterval: VM.Interval _ ListerUtil.MapPages[bcdseg]; bcd: BcdDefs.BcdBase _ VM.AddressForPageNumber[bcdInterval.page]; mth: BcdDefs.MTHandle _ @LOOPHOLE[bcd + bcd.mtOffset, Base][mti]; codeOffset _ mth.code.offset; framesize _ mth.framesize; crossJumped _ mth.crossJumped; VM.Free[bcdInterval]; END; IF cseg = FileSegment.nullPages THEN ListerUtil.Message["Code not available"] ELSE IF sseg = FileSegment.nullPages THEN ListerUtil.Message["Symbols not available"] ELSE { print: BOOL _ FALSE; cspp: LONG POINTER TO PrincOps.CSegPrefix; codeInterval _ ListerUtil.MapPages[cseg]; codebase _ VM.AddressForPageNumber[codeInterval.page] + codeOffset; codepages _ cseg.span.pages; cspp _ codebase; SymbolTable.SetCacheSize[0]; -- clear cache symbols _ SymbolTable.Acquire[sseg]; IF cspp.header.info.altoCode THEN { ListerUtil.Message["Cannot list Alto code"]; GO TO Fail}; IF symbols.fgTable = NIL THEN { ListerUtil.Message["Bad bcd format"]; GO TO Fail}; ListerUtil.SetRoutineSymbols[symbols]; SetUpSource[]; OpenOutput[output]; ListerUtil.PutFileID[out]; IF crossJumped THEN IO.PutRope[out, "Cross jumped\n"]; IO.PutRope[out, "Global frame size: "]; IO.PutF[out, decimal, IO.card[framesize]]; IO.PutRope[out, "\n\n"]; IF options.radix = $hex THEN Hexify[] ELSE Octify[]; Tbytes _ Tinst _ 0; DigestFGT[]; FOR i: CARDINAL IN [0..myFGT.length) DO ff: FineGrainInfo = myFGT[i]; IF ff.bti # prevBti THEN { IF prevBti # BTNull AND print THEN ShowTotals[]; print _ FilterBody[ff.bti, proc]}; IF ff.firstSource # nullSource AND print THEN IF ff.lastSource = ff.firstSource THEN IO.PutChar[out, '\n] ELSE OutCheck[ff.firstSource, ff.lastSource]; IF ff.bti # prevBti THEN { ep: CARDINAL = symbols.bb[ff.bti].entryIndex; evi: LONG POINTER TO PrincOps.EntryVectorItem = @cspp.entry[ep]; fsize: CARDINAL = PrincOps.FrameVec[evi.info.framesize]; IF print THEN { PrintBodyName[ff.bti]; IF options.full THEN IO.PutChar[out, '\t]; IO.PutRope[out, " Entry point: "]; IO.PutF[out, decimal, IO.card[ep]]; IO.PutRope[out, ", Frame size: "]; IO.PutF[out, decimal, IO.card[fsize]]; IO.PutChar[out, '\n]}}; IF print THEN { IF ~ff.procEnd THEN PrintCode[ff.pc, myFGT[i + 1].pc, options]; IO.PutChar[out, '\n]}; prevBti _ ff.bti; ENDLOOP; IF prevBti # Symbols.BTNull AND print THEN ShowTotals[]; (UnsafeStorage.GetSystemUZone[]).FREE[@myFGT]; SymbolTable.Release[symbols]; VM.Free[codeInterval]; CloseSource[]; IO.PutChar[out, '\n]; IF proc = NIL THEN { IF options.full THEN IO.PutChar[out, '\t]; IO.PutRope[out, "Total instructions: "]; IO.PutF[out, decimal, IO.card[Tinst]]; IO.PutRope[out, ", Bytes: "]; IO.PutF[out, decimal, IO.card[Tbytes]]; IO.PutChar[out, '\n]}; CloseOutput[] EXITS Fail => {SymbolTable.Release[symbols]; VM.Free[codeInterval]}}}; ListProc: PUBLIC PROC [ input, proc: Rope.ROPE, output: Rope.ROPE, options: CodeOptions] = { ListModule[input, input, proc, output, options]}; ListCode: PUBLIC PROC [root: Rope.ROPE, options: CodeOptions] = { ListModule[root, root, NIL, root, options]}; ListCodeInConfig: PUBLIC PROC [config, name: Rope.ROPE, options: CodeOptions] = { ListModule[config, name, NIL, name, options]}; <> Octify[]; }.