<<>>
    <<ExamineStorage.mesa>>
        <<Copyright Ó 1990, 1991 by Xerox Corporation.  All rights reserved.>>
        <<Spreitze, December 10, 1990 11:49 am PST>>
        <<Michael Plass, July 16, 1992 4:27 pm PDT>>

    DIRECTORY Basics, Commander, CommanderOps, Convert, ConvertUnsafe, IO, List, MesaLoadState, PrintTypeString, Process, Rope, 
    StructuredStreams, UnparserBuffer;

    ExamineStorage: CEDAR PROGRAM
        IMPORTS Commander, CommanderOps, Convert, ConvertUnsafe, IO, List, MesaLoadState, PrintTypeString, Process, Rope, 
        StructuredStreams, UnparserBuffer
    = BEGIN OPEN SS:StructuredStreams, UB:UnparserBuffer;

    LORA: TYPE ~ LIST OF REF ANY;
    ROPE: TYPE ~ Rope.ROPE;
    XrBool: TYPE ~ CARD --0 is FALSE, 1 is TRUE--;

    CedarProc: TYPE ~ LONG POINTER TO RECORD [startPC, flag: CARD];

    TypeCount: TYPE = RECORD [objects, bytes: INT];
    TypeIndex: TYPE = CARD;

    TypeCounts: TYPE = REF TypeCountsRep;
    TypeCountsRep: TYPE = RECORD [
        types: INT ¬ 0,
        bytes, objects: RECORD [counted, rejected: INT ¬ 0] ¬ [],
        counts: SEQUENCE size: TypeIndex OF TypeCount
        ];

    HeapObject: TYPE ~ RECORD [
        dull: CARD,
        typeCode: TypeIndex];

    True: PROC [b: XrBool] RETURNS [BOOL]
        ~ INLINE {RETURN [b#0]};

    CreateTypeCounts: PROC RETURNS [tcs: TypeCounts] ~ {
        size: TypeIndex ¬ 3000;
        tcs ¬ NEW [TypeCountsRep[size]];
        tcs.types ¬ 0;
        tcs.bytes ¬ tcs.objects ¬ [0, 0];
        FOR i: NAT IN [0..tcs.size) DO tcs[i] ¬ [0, 0] ENDLOOP;
        RETURN};

    XrEnumObjs: UNSAFE PROC [fn: CARD, clientData: REF ANY]
        ~ UNCHECKED MACHINE CODE {"XR_EnumObjs"};

    Sample: PROC [tcs: TypeCounts] ~ TRUSTED {
        noteCP: CedarProc ~ LOOPHOLE[NoteObj];
        XrEnumObjs[noteCP.startPC, tcs];
        RETURN};

    NoteObj: UNSAFE PROC [tcs: TypeCounts, obj: LONG POINTER TO HeapObject, sz: INT, isAtomic: XrBool] ~ UNCHECKED {
        typeCode: TypeIndex ¬ obj.typeCode;
        IF typeCode IN [0..tcs.size) THEN {
            tcs.objects.counted ¬ tcs.objects.counted.SUCC;
            tcs.bytes.counted ¬ tcs.bytes.counted + sz;
            IF tcs[typeCode].objects=0 THEN tcs.types ¬ tcs.types.SUCC;
            tcs[typeCode].objects ¬ tcs[typeCode].objects.SUCC;
            tcs[typeCode].bytes ¬ tcs[typeCode].bytes + sz;
            }
        ELSE {
            tcs.objects.rejected ¬ tcs.objects.rejected.SUCC;
            tcs.bytes.rejected ¬ tcs.bytes.rejected + sz;
            };
        RETURN};

    PrintTypeCounts: PROC [to: IO.STREAM, tcs: TypeCounts, nLargest: INT] ~ {
        CompareListElt: PROC [ref1, ref2: REF ANY] RETURNS [Basics.Comparison] ~ {
            ri1: REF INT ~ NARROW[ref1]; i1: INT ~ tcs[ri1­].bytes;
            ri2: REF INT ~ NARROW[ref2]; i2: INT ~ tcs[ri2­].bytes;
            SELECT TRUE FROM
                i1 < i2 => RETURN [greater];
                i1 > i2 => RETURN [less];
                ENDCASE => RETURN [equal]};
        ts: LONG STRING;
        tr: ROPE;
        theList: LORA ¬ NIL;
        to.PutFL["%g types, %g objects, %g bytes counted; %g objects, %g bytes rejected.\n", LIST[ [integer[tcs.types]], 
        [integer[tcs.objects.counted]], [integer[tcs.bytes.counted]], [integer[tcs.objects.rejected]], 
        [integer[tcs.bytes.rejected]]]];
        FOR i: TypeIndex IN [0..tcs.size) DO
            IF tcs[i].objects # 0 THEN theList ¬ CONS[NEW[INT ¬ i], theList];
            ENDLOOP;
        theList ¬ List.Sort[theList, CompareListElt];
        FOR j: INT IN [0..nLargest) WHILE theList # NIL DO
            ri: REF INT ~ NARROW[theList.first];
            i: INT ~ ri­;
            PrintTypesCounts: PROC ~ {
                to.PutF["tc: %04g, o: %06g, b: %09g,", [cardinal[i]], [integer[tcs[i].objects]], [integer[tcs[i].bytes]] ];
                SS.Bp[to, width, 3, " "];
                to.PutRope["type: "];
                ts ¬ MesaLoadState.TypeStringFromType[VAL[i]];
                tr ¬ ConvertUnsafe.ToRope[ts];
                IF tr.Length[]=0 THEN to.PutRope["(appears invalid)"] ELSE {
                    PrintTypeString.ToStream[to, tr !PrintTypeString.Malformed => {
                        to.PutF[" !Malformed[%g, %g]", [integer[i]], [rope[why]] ];
                        CONTINUE}];
                    };
                };
            theList ¬ theList.rest;
            Process.CheckForAbort[];
            IF tcs[i].objects#0 THEN {PrintObj[to, PrintTypesCounts]; to.PutRope["\n"]};
            ENDLOOP;
        RETURN};

    PrintObj: PROC [to: IO.STREAM, Inner: PROC] ~ {
        SS.Begin[to];
        Inner[!UNWIND => SS.End[to]];
        SS.End[to];
        RETURN};

    ExamineCmd: Commander.CommandProc ~ {
        tcs: TypeCounts ~ CreateTypeCounts[];
        argv: CommanderOps.ArgumentVector ~ CommanderOps.Parse[cmd];
        nLargest: INT ¬ 20;
        margin: INT ¬ 60;
        {ENABLE Convert.Error => CommanderOps.Failed["numeric conversion error"];
        IF argv.argc>1 THEN nLargest ¬ Convert.IntFromRope[argv[1]];
        IF argv.argc>2 THEN margin ¬ Convert.IntFromRope[argv[2]];
        };
        {sso: IO.STREAM ¬ SS.Create[UB.NewInittedHandle[[margin: margin, output: [stream[cmd.out]]]]];
        Sample[tcs];
        PrintTypeCounts[sso, tcs, nLargest];
        RETURN}};

    Commander.Register["ExamineStorage", ExamineCmd, "Scan heap for memory-consuming TYPEs\nargs: [ nLargest [ margin ] ]"];

    END.