<> <> <> <> DIRECTORY Allocator USING [BlockSizeIndex, bsiEscape, EHeaderP, ExtendedHeader, HeaderP, LastAddress, logPagesPerQuantum, NHeaderP, NormalHeader, QuantumIndex, RefCount], AllocatorOps USING [AddressToQuantumIndex, bsiToSize, EnterAndCallBack, quantumMap], Atom, Basics, BackStop USING [Call], BasicTime USING [Now], Commander USING [CommandProc, Register], CommandTool USING [ArgumentVector, Failed, Parse], DebuggerSwap USING [CallDebugger], HashTable, IO, PrintTV USING [PrintType], RCMap, RefTab, Rope USING [Fetch, Length, Match, ROPE, RopeRep], RTTypesBasicPrivate, RuntimeError USING [UNCAUGHT], SafeStorage USING [GetCanonicalType, GetReferentType, nullType, ReclaimCollectibleObjects, Type, TypeIndex], SymTab, VM, ZCT USING [EnterAndCallBack, EnterRCOvAndCallBack]; ExamineStorage: CEDAR PROGRAM IMPORTS AllocatorOps, Atom, Basics, BackStop, BasicTime, Commander, CommandTool, DebuggerSwap, IO, PrintTV, Rope, RTTypesBasicPrivate, RuntimeError, SafeStorage, VM, ZCT SHARES HashTable, Rope = BEGIN LORA: TYPE = LIST OF REF ANY; ROPE: TYPE = Rope.ROPE; LOR: TYPE = LIST OF ROPE; STREAM: TYPE = IO.STREAM; Type: TYPE = SafeStorage.Type; nullType: Type = SafeStorage.nullType; <> minType: SafeStorage.Type _ SafeStorage.nullType; maxType: SafeStorage.Type _ [LAST[SafeStorage.TypeIndex]]; allowF: BOOL _ TRUE; allowNotF: BOOL _ TRUE; allowOver: BOOL _ TRUE; allowNotOver: BOOL _ TRUE; minBsi: Allocator.BlockSizeIndex _ FIRST[Allocator.BlockSizeIndex]; maxBsi: Allocator.BlockSizeIndex _ LAST[Allocator.BlockSizeIndex]; minRC: NAT _ FIRST[Allocator.RefCount]; maxRC: NAT _ LAST[Allocator.RefCount]; <> typeDepth: NAT _ 3; typeWidth: NAT _ 4; typeVerbose: BOOL _ FALSE; typeRank: TypeIndex _ 10; lastSample: TypeCounts _ NIL; <> <> FindBadGuysProc: Commander.CommandProc = TRUSTED { <<[cmd: Handle] RETURNS [result: REF _ NIL, msg: ROPE _ NIL]>> <> out: STREAM = cmd.out; switches: Switches _ ALL[FALSE]; argsProcessed: NAT _ 0; <<# of arguments processed>> argv: CommandTool.ArgumentVector _ CommandTool.Parse[cmd: cmd, starExpand: FALSE ! CommandTool.Failed => {msg _ errorMsg; GO TO failed}]; <> eachObject: InfoProc = TRUSTED { <<[type: SafeStorage.Type, size: INT, object: Allocator.HeaderP, objectHP: Allocator.NHeaderP] RETURNS [continue: BOOLEAN]>> header: Allocator.NormalHeader _ objectHP^; SELECT TRUE FROM type < minType => {}; type > maxType => {}; type > RTTypesBasicPrivate.MapTiTd.length => {}; header.blockSizeIndex < minBsi => {}; header.blockSizeIndex > maxBsi => {}; header.f AND NOT allowF => {}; NOT header.f AND NOT allowNotF => {}; header.rcOverflowed AND NOT allowOver => {}; NOT header.rcOverflowed AND NOT allowNotOver => {}; header.refCount < minRC => {}; header.refCount > maxRC => {}; ENDCASE => { td: RTTypesBasicPrivate.PTypeDesc _ RTTypesBasicPrivate.MapTiTd[type]; IF badGuys = maxBadGuyIndex THEN badGuysMissed _ badGuysMissed + 1 ELSE { badGuysArray[badGuys] _ [objectHP, header]; badGuys _ badGuys + 1}; }; RETURN [TRUE]; }; badGuysArray: ARRAY [0..maxBadGuyIndex) OF BadGuy; BadGuy: TYPE = RECORD [ addr: Allocator.NHeaderP, header: Allocator.NormalHeader ]; badGuys: [0..maxBadGuyIndex] _ 0; badGuysMissed: INT _ 0; maxBadGuyIndex: NAT = 64; EnumerateCollectableStorage[eachObject]; IF badGuys = 0 THEN {msg _ "No bad guys found.\n"; RETURN}; FOR i: [0..maxBadGuyIndex) IN [0..badGuys) DO badGuy: BadGuy _ badGuysArray[i]; IO.PutF1[out, "At %bB: ", [cardinal[LOOPHOLE[badGuy.addr]]] ]; PrintHeader[out, @badGuy.header ]; IO.PutRope[out, "\n" ]; ENDLOOP; IF badGuysMissed # 0 THEN IO.PutF1[out, "Bad guys missed: %g\n", [integer[badGuysMissed]] ]; EXITS failed => {result _ $Failure}; }; TakeHeapStatsProc: Commander.CommandProc = TRUSTED { <<[cmd: Handle] RETURNS [result: REF _ NIL, msg: ROPE _ NIL]>> <> out: STREAM = cmd.out; switches: Switches _ ALL[FALSE]; argsProcessed: NAT _ 0; <<# of arguments processed>> argv: CommandTool.ArgumentVector _ CommandTool.Parse[cmd: cmd, starExpand: FALSE ! CommandTool.Failed => {msg _ errorMsg; GO TO failed}]; <> new: TypeCounts _ lastSample; old: TypeCounts _ lastSample; tc: TypeCounts _ lastSample; switches['g] _ TRUE; switches['w] _ TRUE; FOR i: NAT IN [1..argv.argc) DO arg: ROPE _ argv[i]; IF Rope.Match["-*", arg] THEN { switches _ ProcessSwitches[switches, arg]; LOOP; }; <> ENDLOOP; IF NOT switches['r] THEN { <> new _ InitTypeCounts[]; IF switches['g] THEN <> SafeStorage.ReclaimCollectibleObjects[suspendMe: TRUE, traceAndSweep: FALSE]; SampleTypeCounts[tc: new, includeFree: switches['f]]; IF switches['d] AND old # NIL THEN tc _ DeltaTypeCounts[old, new] ELSE tc _ new; }; IF tc # NIL AND NOT switches['s] THEN { <> PrintTypeCounts[tc, out]; IF switches['o] THEN PrintRank[tc: tc, out: out, highestN: typeRank, countObjects: TRUE]; IF switches['w] THEN PrintRank[tc: tc, out: out, highestN: typeRank, countObjects: FALSE]; }; lastSample _ IF switches['n] THEN NIL ELSE new; EXITS failed => {result _ $Failure}; }; HeapValidProc: Commander.CommandProc = TRUSTED { <<[cmd: Handle] RETURNS [result: REF _ NIL, msg: ROPE _ NIL]>> <> out: STREAM = cmd.out; switches: Switches _ ALL[FALSE]; argsProcessed: NAT _ 0; <<# of arguments processed>> argv: CommandTool.ArgumentVector _ CommandTool.Parse[cmd: cmd, starExpand: FALSE ! CommandTool.Failed => {msg _ errorMsg; GO TO failed}]; <> FOR i: NAT IN [1..argv.argc) DO arg: ROPE _ argv[i]; IF Rope.Match["-*", arg] THEN { switches _ ProcessSwitches[switches, arg]; LOOP; }; <> ENDLOOP; worldSwap _ switches['w]; EnumerateCollectableStorage[NIL]; EXITS failed => {result _ $Failure}; }; FindCyclicTypesProc: Commander.CommandProc = TRUSTED { <<[cmd: Handle] RETURNS [result: REF _ NIL, msg: ROPE _ NIL]>> <> out: STREAM = cmd.out; switches: Switches _ ALL[FALSE]; argsProcessed: NAT _ 0; <<# of arguments processed>> argv: CommandTool.ArgumentVector _ CommandTool.Parse[cmd: cmd, starExpand: FALSE ! CommandTool.Failed => {msg _ errorMsg; GO TO failed}]; <> new: TypeCounts _ lastSample; old: TypeCounts _ lastSample; tc: TypeCounts _ lastSample; switches['g] _ TRUE; switches['w] _ TRUE; FOR i: NAT IN [1..argv.argc) DO arg: ROPE _ argv[i]; IF Rope.Match["-*", arg] THEN { switches _ ProcessSwitches[switches, arg]; LOOP; }; <> ENDLOOP; IF NOT switches['r] THEN { <> base: BasePtr = SetupBase[]; {ENABLE UNWIND => CleanupBase[base]; sawATrue, sawAFalse: BOOL _ FALSE; Cyclic: UNSAFE PROC [nhp: Allocator.NHeaderP] RETURNS [cyclic: BOOL] --VertexTest-- = { cyclic _ ReadFlags[base, nhp].cyclic; IF cyclic THEN sawATrue _ TRUE ELSE sawAFalse _ TRUE; }; IF switches['g] THEN <> SafeStorage.ReclaimCollectibleObjects[]; EnumerateEdges[base: base, Startworthy: True, Transparent: True, IsGoal: False, ConsumeGoal: NIL, cumulative: TRUE]; new _ InitTypeCounts[]; SampleTypeCounts[tc: new, includeFree: FALSE, Filter: Cyclic]; IF switches['d] AND old # NIL THEN tc _ DeltaTypeCounts[old, new] ELSE tc _ new; }--end base--; CleanupBase[base]; }; IF NOT switches['s] THEN { PrintTypeCounts[tc, out, "\n-- Only cyclic objects are counted --"]; IF switches['o] THEN PrintRank[tc: tc, out: out, highestN: typeRank, countObjects: TRUE]; IF switches['w] THEN PrintRank[tc: tc, out: out, highestN: typeRank, countObjects: FALSE]; }; lastSample _ IF switches['n] THEN NIL ELSE new; EXITS failed => {result _ $Failure}; }; True: PROC [nhp: Allocator.NHeaderP] RETURNS [BOOL] --VertexTest-- = { RETURN [TRUE]}; False: PROC [nhp: Allocator.NHeaderP] RETURNS [BOOL] --VertexTest-- = { RETURN [FALSE]}; <> TypeSet: TYPE = REF TypeSetPrivate; TypeSetPrivate: TYPE = RECORD [members: PACKED SEQUENCE length: TypeIndex OF BOOL]; TypeList: TYPE = LIST OF Type; FromList: PROC [list: TypeList] RETURNS [ts: TypeSet] = TRUSTED { ts _ NEW [TypeSetPrivate[RTTypesBasicPrivate.MapTiTd.length+64]]; FOR ti: INT IN [0 .. ts.length) DO ts[ti] _ FALSE ENDLOOP; FOR list _ list, list.rest WHILE list # NIL DO type: Type = SafeStorage.GetCanonicalType[list.first]; ts[type] _ TRUE; ENDLOOP; }; HeaderSet: TYPE = REF HeaderSetPrivate; HeaderSetPrivate: TYPE = RECORD [ length: INT _ 0, headers: SEQUENCE size: NAT OF Allocator.NHeaderP ]; FindSome: PROC [goalType: Type, upTo: INT _ 5] RETURNS [headers: HeaderSet] = { eachObject: UNSAFE PROC [type: Type, size: INT, object: Allocator.HeaderP, objectHP: Allocator.NHeaderP] RETURNS [continue: BOOLEAN _ TRUE] --InfoProc-- = TRUSTED { IF goalType = type THEN { headers[headers.length] _ objectHP; headers.length _ headers.length + 1; continue _ headers.length # headers.size; }; }; headers _ NEW [HeaderSetPrivate[upTo]]; headers.length _ 0; EnumerateCollectableStorage[eachObject]; }; aList: LORA = LIST[$Foo]; aRopeList: LOR = LIST["a rope"]; aPropList: Atom.PropList = Atom.PutPropOnList[NIL, $Foo, $bar]; basicBores: TypeList = LIST[ CODE[Rope.RopeRep], SafeStorage.GetReferentType[aRopeList], CODE[Atom.DottedPairNode], SafeStorage.GetReferentType[aPropList], SafeStorage.GetReferentType[aList] ]; moreBores: TypeList = CONS[CODE[HashTable.TableRec], CONS[CODE[HashTable.Seq], CONS[CODE[HashTable.NodeRep], CONS[CODE[SymTab.SymTabRep], CONS[CODE[SymTab.Seq], CONS[CODE[SymTab.NodeRep], CONS[CODE[RefTab.RefTabRep], CONS[CODE[RefTab.Seq], CONS[CODE[RefTab.NodeRep], basicBores]]]]]]]]]; ExamineRefs: PROC [goalList, transparentList: TypeList, log: STREAM, gcFirst, wordRank: BOOL _ TRUE, objectRank: BOOL _ FALSE] = TRUSTED { goals: TypeSet = FromList[goalList]; transparents: TypeSet = FromList[transparentList]; tc: TypeCounts = InitTypeCounts[]; base: BasePtr = SetupBase[]; {ENABLE UNWIND => CleanupBase[base]; Startworthy: UNSAFE PROC [nhp: Allocator.NHeaderP] RETURNS [start: BOOL] --VertexTest-- = { start _ NOT Transparent[nhp]; }; Transparent: UNSAFE PROC [nhp: Allocator.NHeaderP] RETURNS [is: BOOL] --VertexTest-- = { is _ transparents[SafeStorage.GetCanonicalType[nhp.type]]; }; IsGoal: UNSAFE PROC [nhp: Allocator.NHeaderP] RETURNS [is: BOOL] --VertexTest-- = { is _ goals[SafeStorage.GetCanonicalType[nhp.type]]; }; ConsumeGoal: UNSAFE PROC [startNHP, goalNHP: Allocator.NHeaderP] --GoalConsumer-- = { size: LONG CARDINAL; type: Type = startNHP.type; IF goalNHP.blockSizeIndex = Allocator.bsiEscape THEN { ehp: Allocator.EHeaderP _ LOOPHOLE[goalNHP + SIZE[Allocator.NormalHeader] - SIZE[Allocator.ExtendedHeader]]; SELECT ehp.sizeTag FROM words => size _ ehp.extendedSize; pages => size _ VM.WordsForPages[ehp.extendedSize]; ENDCASE => {Crash[goalNHP]; RETURN}; } ELSE { size _ AllocatorOps.bsiToSize[goalNHP.blockSizeIndex]; }; tc.objects _ tc.objects + 1; tc.words _ tc.words + size; IF type < tc.max THEN TRUSTED { tcp: LONG POINTER TO TypeCount _ @tc[type]; IF tcp.objects = 0 THEN { <> tcp.objects _ 1; tcp.words _ size; tc.types _ tc.types + 1; } ELSE { <> tcp.objects _ tcp.objects + 1; tcp.words _ tcp.words + size; }; }; }; IF gcFirst THEN SafeStorage.ReclaimCollectibleObjects[]; EnumerateEdges[base: base, Startworthy: Startworthy, Transparent: Transparent, IsGoal: IsGoal, ConsumeGoal: ConsumeGoal, cumulative: FALSE]; }--end base--; CleanupBase[base]; PrintTypeCounts[tc, log]; IF objectRank THEN PrintRank[tc: tc, out: log, highestN: typeRank, countObjects: TRUE]; IF wordRank THEN PrintRank[tc: tc, out: log, highestN: typeRank, countObjects: FALSE]; }; <> Flags: TYPE = RECORD [ marked: BOOL _ FALSE, <> stacked: BOOL _ FALSE, <> <> cyclic: BOOL _ FALSE, legal: BOOL _ FALSE <> ]; nullFlags: Flags = []; FlagsArrayPtr: TYPE = LONG POINTER TO FlagsArray; FlagsArray: TYPE = PACKED ARRAY FlagIndex OF Flags; BasePtr: TYPE = LONG POINTER TO BaseArray; BaseArray: TYPE = ARRAY BaseIndex OF FlagsArrayPtr; FlagMod: NAT = 4096; FlagIndex: TYPE = [0..FlagMod); logFlagMod: NAT = 12; BaseMod: NAT = 4096; BaseIndex: TYPE = [0..BaseMod); CyclicRef: UNSAFE PROC [base: BasePtr, ref: REF] RETURNS [BOOL] = UNCHECKED { nhp: Allocator.NHeaderP = LOOPHOLE[ref, Allocator.NHeaderP] - SIZE[Allocator.NormalHeader]; RETURN [ReadFlags[base, nhp].cyclic]; }; ReadFlags: UNSAFE PROC [base: BasePtr, nhp: Allocator.NHeaderP] RETURNS [Flags] = UNCHECKED { ln: Basics.LongNumber = LOOPHOLE[nhp]; ptr: FlagsArrayPtr = base[Basics.DoubleShiftRight[ln, logFlagMod+1].lo]; IF ln.lc >= Allocator.LastAddress THEN Crash[nhp]; IF ln.lo MOD 2 = 1 THEN Crash[nhp]; IF ptr = NIL THEN RETURN [nullFlags]; RETURN [ptr[(ln.lo / 2) MOD FlagMod]]; }; WriteFlags: UNSAFE PROC [base: BasePtr, nhp: Allocator.NHeaderP, flags: Flags] = UNCHECKED { ln: Basics.LongNumber = LOOPHOLE[nhp]; xHi: NAT = Basics.DoubleShiftRight[ln, logFlagMod+1].lo; ptr: FlagsArrayPtr _ base[xHi]; IF ln.lc >= Allocator.LastAddress THEN Crash[nhp]; IF ln.lo MOD 2 = 1 THEN Crash[nhp]; IF ptr = NIL THEN { <> interval: VM.Interval _ VM.SimpleAllocate[VM.PagesForWords[ SIZE[FlagsArray] ]]; base[xHi] _ ptr _ VM.AddressForPageNumber[interval.page]; ptr^ _ ALL[nullFlags]; }; ptr[(ln.lo / 2) MOD FlagMod] _ flags; }; SetupBase: UNSAFE PROC RETURNS [base: BasePtr] = UNCHECKED { interval: VM.Interval _ VM.SimpleAllocate[VM.PagesForWords[ SIZE[BaseArray] ]]; base _ VM.AddressForPageNumber[interval.page]; base^ _ ALL[NIL]; }; CleanupBase: UNSAFE PROC [base: BasePtr] = UNCHECKED { pages: NAT = VM.PagesForWords[ SIZE[FlagsArray] ]; FOR i: NAT IN BaseIndex DO IF base[i] # NIL THEN { page: VM.PageNumber = VM.PageNumberForAddress[base[i]]; base[i] _ NIL; VM.Free[ [page, pages] ]; }; ENDLOOP; VM.Free[ [VM.PageNumberForAddress[base], VM.PagesForWords[SIZE[BaseArray]] ]]; }; <> Switches: TYPE = PACKED ARRAY CHAR['a..'z] OF BOOL; TypeIndex: TYPE = [0..LAST[SafeStorage.TypeIndex]-256]; LowRC: NAT = LAST[Allocator.RefCount]/4; MidRC: NAT = LAST[Allocator.RefCount]/2; HighRC: NAT = LAST[Allocator.RefCount]; TypeCounts: TYPE = REF TypeCountsRep; TypeCountsRep: TYPE = RECORD [ types: INT _ 0, objects: INT _ 0, words: INT _ 0, lowRC: ARRAY [0..LowRC] OF INT _ ALL[0], midRC: INT _ 0, highRC: INT _ 0, overRC: INT _ 0, inZCT: INT _ 0, inZCT0: INT _ 0, counts: SEQUENCE max: TypeIndex OF TypeCount ]; TypeCount: TYPE = RECORD [ objects: INT, words: INT ]; TypeAccum: TYPE = REF TypeAccumRep; TypeAccumRep: TYPE = RECORD [ SEQUENCE max: TypeIndex OF TypeAccumEntry ]; TypeAccumEntry: TYPE = RECORD [ type: TypeIndex _ 0, count: INT _ 0 ]; InitTypeCounts: PROC RETURNS [tc: TypeCounts] = TRUSTED { index: TypeIndex _ RTTypesBasicPrivate.MapTiTd.length; WHILE index > 0 DO IF RTTypesBasicPrivate.MapTiTd[index-1] # NIL THEN EXIT; index _ index-1; ENDLOOP; tc _ NEW[TypeCountsRep[index+64]]; FOR i: TypeIndex IN [0..index+64) DO tc[i] _ [0, 0]; ENDLOOP; }; SampleTypeCounts: PROC [tc: TypeCounts, includeFree: BOOL, Filter: VertexTest _ True] = TRUSTED { eachObject: InfoProc = TRUSTED { <<[type: SafeStorage.Type, size: INT, object: Allocator.HeaderP, objectHP: Allocator.NHeaderP] RETURNS [continue: BOOLEAN]>> trueZero: BOOL _ FALSE; IF NOT includeFree AND type = SafeStorage.nullType THEN RETURN [TRUE]; IF NOT Filter[objectHP] THEN RETURN [TRUE]; tc.objects _ tc.objects + 1; tc.words _ tc.words + size; IF type < tc.max THEN TRUSTED { tcp: LONG POINTER TO TypeCount _ @tc[type]; IF tcp.objects = 0 THEN { <> tcp.objects _ 1; tcp.words _ size; tc.types _ tc.types + 1; } ELSE { <> tcp.objects _ tcp.objects + 1; tcp.words _ tcp.words + size; }; IF type = SafeStorage.nullType THEN RETURN [TRUE]; }; <> SELECT TRUE FROM objectHP.rcOverflowed => tc.overRC _ tc.overRC + 1; ENDCASE => SELECT objectHP.refCount FROM 0 => { tc.lowRC[0] _ tc.lowRC[0] + 1; trueZero _ TRUE; }; <= LowRC => tc.lowRC[objectHP.refCount] _ tc.lowRC[objectHP.refCount] + 1; <= MidRC => tc.midRC _ tc.midRC + 1; ENDCASE => tc.highRC _ tc.highRC + 1; IF objectHP.inZCT THEN { tc.inZCT _ tc.inZCT + 1; IF trueZero THEN tc.inZCT0 _ tc.inZCT0 + 1; }; continue _ TRUE; }; EnumerateCollectableStorage[eachObject]; }; DeltaTypeCounts: PROC [old, new: TypeCounts] RETURNS [delta: TypeCounts] = { <> delta _ NEW[TypeCountsRep[new.max]]; delta.types _ new.types - old.types; delta.objects _ new.objects - old.objects; delta.words _ new.words - old.words; FOR i: [0..LowRC] IN [0..LowRC] DO delta.lowRC[i] _ new.lowRC[i] - old.lowRC[i]; ENDLOOP; delta.midRC _ new.midRC - old.midRC; delta.highRC _ new.highRC - old.highRC; delta.overRC _ new.overRC - old.overRC; delta.inZCT _ new.inZCT - old.inZCT; delta.inZCT0 _ new.inZCT0 - old.inZCT0; FOR i: TypeIndex IN [0..new.max) DO oldTypeCount: TypeCount _ IF i < old.max THEN old[i] ELSE [0, 0]; newTypeCount: TypeCount _ new[i]; delta[i] _ [ objects: newTypeCount.objects - oldTypeCount.objects, words: newTypeCount.words - oldTypeCount.words]; ENDLOOP; }; PrintTypeCounts: PROC [tc: TypeCounts, out: STREAM, msg: ROPE _ NIL] = { <> IF msg # NIL THEN IO.PutRope[out, msg]; IO.PutF1[out, "\n-- Heap storage statistics (%g) --\n", [time[BasicTime.Now[]]] ]; IO.PutF[out, " types: %g, objects: %g, words: %g", [integer[tc.types]], [integer[tc.objects]], [integer[tc.words]] ]; IF tc.objects > 0 AND tc.words > 0 THEN { <> avg: INT _ (tc.words+tc.objects/2) / tc.objects; IO.PutF1[out, " (words/obj: %g)", [integer[avg]] ]; }; FOR i: NAT IN [0..LowRC] DO IF i MOD 4 = 0 THEN IO.PutF[out, "\n RC - %g: %g", [integer[i]], [integer[tc.lowRC[i]]] ] ELSE IO.PutF[out, ", %g: %g", [integer[i]], [integer[tc.lowRC[i]]] ]; ENDLOOP; IO.PutF[out, "\n RC IN [%g..%g]: %g", [integer[LowRC+1]], [integer[MidRC]], [integer[tc.midRC]] ]; IO.PutF[out, ", IN [%g..%g]: %g", [integer[MidRC+1]], [integer[HighRC]], [integer[tc.highRC]] ]; IO.PutF1[out, ", overflow: %g\n", [integer[tc.overRC]] ]; IO.PutF[out, " inZCT: %g, inZCT0; %g\n", [integer[tc.inZCT]], [integer[tc.inZCT0]] ]; }; PrintRank: PROC [tc: TypeCounts, out: STREAM, highestN: NAT _ 16, countObjects: BOOL] = { IF highestN # 0 THEN { highestAccum: TypeAccum _ NEW[TypeAccumRep[highestN]]; worstRank: TypeIndex _ highestN-1; worstCount: INT _ 0; IO.PutRope[out, IF countObjects THEN "\n-- Rank by objects --\n" ELSE "\n-- Rank by words --\n"]; FOR i: NAT IN [0..highestN) DO highestAccum[i] _ [0, 0]; ENDLOOP; FOR type: TypeIndex IN [0..tc.max) DO tCount: TypeCount _ tc[type]; count: INT _ ABS[IF countObjects THEN tCount.objects ELSE tCount.words]; IF count > worstCount THEN { WHILE worstRank > 0 DO IF count <= highestAccum[worstRank-1].count THEN EXIT; highestAccum[worstRank] _ highestAccum[worstRank-1]; worstRank _ worstRank - 1; ENDLOOP; highestAccum[worstRank] _ [type, count]; worstRank _ highestN-1; worstCount _ highestAccum[worstRank].count; }; ENDLOOP; FOR rank: NAT IN [0..highestN) DO type: TypeIndex _ highestAccum[rank].type; words: INT _ tc[type].words; objects: INT _ tc[type].objects; IF words = 0 AND objects = 0 THEN EXIT; IO.PutF[out, " rank %g, words: %g, objects: %g", [integer[rank]], [integer[words]], [integer[objects]] ]; IO.PutF1[out, ", type: %bB\n ", [cardinal[type]] ]; PrintType[out, type]; IO.PutRope[out, "\n"]; ENDLOOP; }; }; PrintType: PROC [out: STREAM, type: TypeIndex] = { <> innerPrint: PROC = { PrintTV.PrintType[type: [type], put: out, depth: typeDepth, width: typeWidth, verbose: typeVerbose]; }; msg: ROPE _ NIL; IF type = 0 THEN msg _ "(free)" ELSE msg _ BackStop.Call[innerPrint]; IF msg # NIL THEN IO.PutRope[out, msg]; }; ProcessSwitches: PROC [swIn: Switches, arg: ROPE] RETURNS [switches: Switches] = { sense: BOOL _ TRUE; switches _ swIn; FOR index: INT IN [0..Rope.Length[arg]) DO char: CHAR _ Rope.Fetch[arg, index]; SELECT char FROM '- => LOOP; '~ => {sense _ NOT sense; LOOP}; IN ['a..'z] => switches[char] _ sense; IN ['A..'Z] => switches[char + ('a-'A)] _ sense; ENDCASE; sense _ TRUE; ENDLOOP; }; PrintHeader: PROC [out: STREAM, nhp: Allocator.NHeaderP] = TRUSTED { IO.PutF1[out, "[inZCT: %g", [rope[IF nhp.inZCT THEN "TRUE" ELSE "FALSE"]] ]; IO.PutF1[out, ", maybeOnStack: %g", [rope[IF nhp.maybeOnStack THEN "TRUE" ELSE "FALSE"]] ]; IO.PutF1[out, "\n bsi: %g", IF nhp.blockSizeIndex = Allocator.bsiEscape THEN [rope["bsiEscape"]] ELSE [cardinal[nhp.blockSizeIndex]] ]; IO.PutF1[out, ", f: %g", [rope[IF nhp.f THEN "TRUE" ELSE "FALSE"]] ]; IF nhp.f THEN { td: RTTypesBasicPrivate.PTypeDesc _ RTTypesBasicPrivate.MapTiTd[nhp.type]; IF td.numberPackageRefs > nhp.refCount THEN { <> IO.PutF1[out, " (prc: %g)", [integer[td.numberPackageRefs]] ]; }; }; IO.PutF1[out, ", refCount: %g", [cardinal[nhp.refCount]] ]; IF nhp.rcOverflowed THEN IO.PutRope[out, " (overflowed)" ]; IO.PutF1[out, "\n typePad: %g", [cardinal[nhp.typePad]] ]; IO.PutF1[out, ", type: %g (", [cardinal[nhp.type]] ]; PrintType[out, nhp.type]; IO.PutRope[out, ")]" ]; }; InfoProc: TYPE = UNSAFE PROC [type: SafeStorage.Type, size: INT, object: Allocator.HeaderP, objectHP: Allocator.NHeaderP] RETURNS [continue: BOOLEAN _ TRUE]; EnumerateCollectableStorage: PROC [callBack: InfoProc _ NIL] = TRUSTED { <> haveAllocatorLocked: PROC = TRUSTED { haveRCOvLocked: PROC = TRUSTED { haveZCTLocked: PROC = TRUSTED { qx: Allocator.QuantumIndex _ FIRST[Allocator.QuantumIndex]; lag1: Allocator.NHeaderP _ NIL; lag2: Allocator.NHeaderP _ NIL; lag3: Allocator.NHeaderP _ NIL; lag4: Allocator.NHeaderP _ NIL; DO hp: Allocator.HeaderP _ NIL; blockSize: LONG CARDINAL _ 0; <> WHILE NOT AllocatorOps.quantumMap[qx] DO IF qx = LAST[Allocator.QuantumIndex] THEN RETURN; qx _ qx + 1; ENDLOOP; hp _ Basics.DoubleShiftLeft[[lc[qx]], Allocator.logPagesPerQuantum+VM.logWordsPerPage].lp; DO start: Allocator.QuantumIndex _ qx; nhp: Allocator.NHeaderP _ LOOPHOLE[hp]; IF LOOPHOLE[hp, LONG CARDINAL] >= Allocator.LastAddress THEN RETURN; IF nhp.blockSizeIndex = Allocator.bsiEscape THEN { ehp: Allocator.EHeaderP _ LOOPHOLE[hp]; nhp _ nhp + (SIZE[Allocator.ExtendedHeader] - SIZE[Allocator.NormalHeader]); SELECT ehp.sizeTag FROM words => blockSize _ ehp.extendedSize; pages => blockSize _ VM.WordsForPages[ehp.extendedSize]; ENDCASE => {Crash[nhp]; RETURN}; } ELSE { blockSize _ AllocatorOps.bsiToSize[nhp.blockSizeIndex]; }; IF blockSize = 0 THEN {Crash[nhp]; RETURN}; IF blockSize >= Allocator.LastAddress THEN {Crash[nhp]; RETURN}; IF Basics.LowHalf[blockSize] MOD 2 = 1 THEN {Crash[nhp]; RETURN}; IF Basics.LowHalf[blockSize] MOD VM.wordsPerPage = 0 THEN { <> ln: Basics.LongNumber _ [lp[hp]]; IF ln.lo MOD VM.wordsPerPage # 0 THEN {Crash[nhp]; RETURN}; }; IF callBack # NIL THEN { <> IF NOT callBack[nhp.type, blockSize, hp, nhp ! RuntimeError.UNCAUGHT => Crash[nhp] ] THEN RETURN; IF foundNhp # NIL THEN {Crash[nhp]; RETURN}; }; hp _ hp + blockSize; qx _ AllocatorOps.AddressToQuantumIndex[LOOPHOLE[hp]]; FOR qq: Allocator.QuantumIndex IN (start..qx) DO IF NOT AllocatorOps.quantumMap[qq] THEN {Crash[nhp]; RETURN}; ENDLOOP; IF qx = LAST[Allocator.QuantumIndex] THEN RETURN; IF NOT AllocatorOps.quantumMap[qx] THEN EXIT; lag4 _ lag3; lag3 _ lag2; lag2 _ lag1; lag1 _ nhp; ENDLOOP; ENDLOOP; }; ZCT.EnterAndCallBack[haveZCTLocked]; }; ZCT.EnterRCOvAndCallBack[haveRCOvLocked]; }; AllocatorOps.EnterAndCallBack[haveAllocatorLocked]; IF foundNhp # NIL THEN ERROR CrashError[foundNhp]; }; foundNhp: Allocator.NHeaderP _ NIL; worldSwap: BOOL _ TRUE; Crash: PROC [nhp: Allocator.NHeaderP] = TRUSTED { foundNhp _ nhp; IF worldSwap THEN DebuggerSwap.CallDebugger["Kosher it's not!"L] ELSE ERROR CrashError[nhp]; }; CrashError: ERROR [nhp: Allocator.NHeaderP] = CODE; VertexTest: TYPE = UNSAFE PROC [nhp: Allocator.NHeaderP] RETURNS [BOOL]; GoalConsumer: TYPE = UNSAFE PROC [startNHP, goalNHP: Allocator.NHeaderP]; EnumerateEdges: UNSAFE PROC [base: BasePtr, Startworthy, Transparent, IsGoal: VertexTest, ConsumeGoal: GoalConsumer, cumulative: BOOL] = TRUSTED { objects: INT _ 0; countObject: InfoProc = { <<[type: SafeStorage.Type, size: INT, object: Allocator.HeaderP, objectHP: Allocator.NHeaderP] RETURNS [continue: BOOLEAN]>> pr: LONG POINTER _ objectHP+SIZE[Allocator.NormalHeader]; SELECT TRUE FROM type = nullType => {}; < {};>> type > RTTypesBasicPrivate.MapTiTd.length => {}; objectHP.refCount = 0 => {}; ENDCASE => { <> rcmx: RCMap.Index = RTTypesBasicPrivate.MapTiRcmx[type]; SELECT rcmx FROM FIRST[RCMap.Index], LAST[RCMap.Index] => {}; ENDCASE => { <> eachRef: UNSAFE PROC [p: REF] = { IF p # NIL THEN { IF none THEN { none _ FALSE; WriteFlags[base, objectHP, [legal: TRUE]]; }; }; }; none: BOOL _ TRUE; RTTypesBasicPrivate.MapRefs[pr, rcmx, eachRef]; }; objects _ objects + 1; }; RETURN [TRUE]; }; stackSpace: VM.Interval; EnumerateCollectableStorage[countObject]; stackSpace _ VM.SimpleAllocate[ VM.PagesForWords[ SIZE[Allocator.NHeaderP]*(objects+100) ]]; {ENABLE UNWIND => VM.Free[stackSpace]; stackStart: LONG POINTER TO Allocator.NHeaderP = VM.AddressForPageNumber[stackSpace.page]; stackEnd: LONG POINTER TO Allocator.NHeaderP = stackStart + SIZE[Allocator.NHeaderP]*(objects+99); trace: InfoProc = { <<[type: SafeStorage.Type, size: INT, object: Allocator.HeaderP, objectHP: Allocator.NHeaderP] RETURNS [continue: BOOLEAN]>> ff: Flags _ ReadFlags[base, objectHP]; IF ff.legal AND NOT ff.marked AND Startworthy[objectHP] THEN { ExploreFrom[objectHP, TRUE]; IF NOT cumulative THEN ExploreFrom[objectHP, FALSE]; }; RETURN [TRUE]; }; ExploreFrom: UNSAFE PROC [start: Allocator.NHeaderP, firstPass: BOOL] = { Marked: PROC [flags: Flags] RETURNS [marked: BOOL] = CHECKED INLINE {marked _ flags.marked = firstPass}; Mark: PROC [ofl: Flags] RETURNS [nfl: Flags] = CHECKED INLINE {nfl _ ofl; nfl.marked _ firstPass}; stackP: LONG POINTER TO Allocator.NHeaderP _ stackStart; stackP^ _ start; DO p: Allocator.NHeaderP _ stackP^; type: Type = p.type; rcmx: RCMap.Index = RTTypesBasicPrivate.MapTiRcmx[type]; eachRef: UNSAFE PROC [p: REF] = { IF p # NIL THEN { nhp: Allocator.NHeaderP _ LOOPHOLE[p, Allocator.NHeaderP] - SIZE[Allocator.NormalHeader]; ff: Flags _ ReadFlags[base, nhp]; IF Marked[ff] THEN {--we've seen it before IF NOT firstPass THEN NULL--on second pass, don't worry about detecting cycles. ELSE IF ff.stacked THEN {--It's in the current path, and thus is part of a cycle. stackQ: LONG POINTER TO Allocator.NHeaderP _ stackP; IF NOT ff.cyclic THEN { ff.cyclic _ TRUE; WriteFlags[base, nhp, ff]; }; <> DO pp: Allocator.NHeaderP = stackQ^; pf: Flags = ReadFlags[base, pp]; IF pp = nhp THEN EXIT; IF stackQ = stackStart THEN EXIT; IF pf.stacked AND NOT pf.cyclic THEN WriteFlags[base, pp, ff]; stackQ _ stackQ - SIZE[Allocator.NHeaderP]; ENDLOOP; } ELSE NULL--it's already queued to be traced, or has already been traced; in either case, nothing needs to be done about it here. } ELSE {--Never seen before IF IsGoal[nhp] THEN ConsumeGoal[start, nhp]; IF ff.legal AND Transparent[nhp] THEN { <> ff _ Mark[ff]; stackP _ stackP + SIZE[Allocator.NHeaderP]; IF stackP = stackEnd THEN Crash[nhp]; stackP^ _ nhp; WriteFlags[base, nhp, ff]; }; }; }; }; pf: Flags _ ReadFlags[base, p]; IF NOT pf.legal THEN Crash[p]; pf.stacked _ TRUE; pf _ Mark[pf]; WriteFlags[base, p, pf]; RTTypesBasicPrivate.MapRefs[p+SIZE[Allocator.NormalHeader], rcmx, eachRef]; <> DO pp: Allocator.NHeaderP _ stackP^; ff: Flags _ ReadFlags[base, pp]; IF NOT ff.stacked THEN EXIT; ff.stacked _ FALSE; WriteFlags[base, pp, ff]; IF stackP = stackStart THEN RETURN; stackP _ stackP - SIZE[Allocator.NHeaderP]; ENDLOOP; <> ENDLOOP; }--end ExploreFrom--; EnumerateCollectableStorage[trace]; }--end stackSpace--; VM.Free[stackSpace]; }--end EnumerateEdges--; <> <<>> Commander.Register[ key: "FindBadGuys", <> proc: FindBadGuysProc, doc: "{switch | item}* Finds bad objects according to variables in ExamineStorage", clientData: NIL, interpreted: TRUE ]; Commander.Register[ key: "TakeHeapStats", <> proc: TakeHeapStatsProc, doc: "takes heap statistics Switches (with True/False defaults) -d: (F) take delta of stats from last time -f: (F) include free objects in counts -g: (T) GC once before taking stats -n: (F) no save of stats for next time -o: (F) show objects rank -r: (F) reprint only, don't take stats -s: (F) silent, don't print stats -w: (T) show words rank ", clientData: NIL, interpreted: TRUE ]; Commander.Register[ key: "FindCyclicTypes", proc: FindCyclicTypesProc, doc: "finds types with cyclic objects Switches (with True/False defaults) -d: (F) take delta of stats from last time -g: (T) GC once before taking stats -n: (F) no save of stats for next time -o: (F) show objects rank -r: (F) reprint only, don't take stats -s: (F) silent, don't print stats -w: (T) show words rank ", clientData: NIL, interpreted: TRUE ]; Commander.Register[ key: "ValidateHeap", proc: HeapValidProc, doc: "validates the heap Switches (with True/False defaults) -w: (F) world-swap debug on error " ]; END. <<>>