runtime/src/common/RTHeapInfo.m3


Copyright (C) 1994, Digital Equipment Corp.
                                                              

UNSAFE MODULE RTHeapInfo;

IMPORT RT0, RT0u, RTOS, RTParams, RTPerfTool, RTType;
IMPORT Text, Thread, Cstring, Word;

TYPE Closure = Thread.Closure OBJECT OVERRIDES apply := Producer END;

VAR
  drain  : RTPerfTool.Handle;
  self   : Thread.T := NIL;
  cnt    : INTEGER := 0;
  buf    : ARRAY [0..255] OF INTEGER;
  update : LONGREAL := 5.0d0;

PROCEDURE Producer (<*UNUSED*> self: Thread.Closure): REFANY =
  VAR n: INTEGER;  nTypes: RT0.Typecode := RT0u.nTypes;
  BEGIN
    LOOP
      RTOS.LockHeap ();
        (* count the non-zero stats *)
        n := 0;
        FOR i := 0 TO nTypes-1 DO
          IF RT0u.alloc_cnts[i] # 0 THEN INC (n) END;
        END;

        (* and send'm *)
        Send (n);
        FOR i := 0 TO nTypes-1 DO
          IF RT0u.alloc_cnts[i] # 0 THEN
            Send (i);
            Send (RT0u.alloc_cnts[i]);
            RT0u.alloc_cnts[i] := 0;
            IF (RT0u.alloc_bytes[i] # 0) THEN
              Send (RT0u.alloc_bytes[i]);
              RT0u.alloc_bytes[i] := 0;
            END;
          END;
        END;
        Flush ();
      RTOS.UnlockHeap ();

      Thread.Pause (update);
    END;
  END Producer;

PROCEDURE SendTypes () =
  VAR t: RT0.TypeDefn;  str: ADDRESS;  n: INTEGER;  buf: ARRAY [0..31] OF CHAR;
  BEGIN
    RTOS.LockHeap ();
      (* describe the types *)
      Send (RT0u.nTypes);
      FOR i := 0 TO RT0u.nTypes-1 DO
        t := RTType.Get (i);
        IF (t.nDimensions > 0)
          THEN Send (-1);          (* variable sized object *)
          ELSE Send (t.dataSize);  (* fixed size *)
        END;
        str := t.name;
        IF (str # NIL)
          THEN n := Cstring.strlen (str);
          ELSE n := BuildTypeName (t, buf);  str := ADR (buf[0]);
        END;
        Send (n);
        Flush ();
        EVAL RTPerfTool.Send (drain, str, n);
      END;
    RTOS.UnlockHeap ();
  END SendTypes;

PROCEDURE BuildTypeName (t: RT0.TypeDefn;  VAR buf: ARRAY OF CHAR): INTEGER =
  CONST Digits = ARRAY [0..15] OF CHAR {'0','1','2','3','4','5','6','7',
                                        '8','9','a','b','c','d','e','f'};
  VAR uid, n: INTEGER;
  BEGIN
    buf[0] := '<';
    buf[1] := '_';
    buf[2] := 't';
    uid := t.selfID;
    FOR i := 10 TO 3 BY -1 DO
      buf[i] := Digits[ Word.And (uid, 16_f) ];
      uid := Word.RightShift (uid, 4);
    END;
    buf[11] := ' ';
    buf[12] := 'T';
    buf[13] := 'C';
    buf[14] := '=';
    uid := t.typecode;
    n := 1;
    WHILE (uid > 10) DO INC (n);  uid := uid DIV 10 END;
    uid := t.typecode;
    FOR i := 14+n TO 15 BY -1 DO
      buf[i] := Digits[ uid MOD 10 ];
      uid := uid DIV 10;
    END;
    buf[15+n] := '>';
    buf[16+n] := '\000';
    RETURN 15+n;
  END BuildTypeName;

PROCEDURE Send (i: INTEGER) =
  BEGIN
    IF (cnt >= NUMBER (buf)) THEN Flush () END;
    buf[cnt] := i;
    INC (cnt);
  END Send;

PROCEDURE Flush () =
  BEGIN
    IF (cnt > 0) THEN
      EVAL RTPerfTool.Send (drain, ADR (buf), cnt * BYTESIZE (buf[0]));
      cnt := 0;
    END;
  END Flush;

PROCEDURE SetUpdate (txt: TEXT) =
  VAR n: INTEGER := 0;  ch: INTEGER;
  BEGIN
    IF (txt = NIL) OR Text.Length (txt) = 0 THEN RETURN END;
    FOR i := 0 TO Text.Length(txt)-1 DO
      ch := ORD (Text.GetChar (txt, i)) - ORD ('0');
      IF (ch < 0) OR (9 < ch) THEN RETURN END;
      n := 10 * n + ch;
    END;
    update := MAX (1.0d0, FLOAT (n, LONGREAL));
  END SetUpdate;

PROCEDURE Init () =
  BEGIN
    IF RTPerfTool.Start ("shownew", drain) THEN
      SendTypes ();
      SetUpdate (RTParams.Value ("update"));
      self := Thread.Fork (NEW (Closure));
    END;
  END Init;

BEGIN
END RTHeapInfo.

interface RT0u is in:


interface RTPerfTool is in:


interface Cstring is in: