QSyntax10.Scn.FntSyntax10i.Scn.FntMarkElemsAlloc!StampElemsAlloc20 Feb 97InfoElemsAllocVSyntax10.Scn.FntpdIStampElemsAlloc20 Feb 97"Title": HeapInspTracer "Author": Martin Rammerstorfer (MR) "Abstract": . "Keywords": Heap, inspecting data at run time, typed memory, NEW "Version": 1 "From": 15.02.97 "Until":  "Changes": no changes "Hints":Syntax14b.Scn.Fnt`[PopupElemsAllocStart HeapInspTracer#Syntax10.Scn.FntHeapInspTracer.Trace ^~Syntax10b.Scn.Fnt@ Compile#Syntax10.Scn.Fnt33Folds.Compile Platform.Mod/s HeapInspTracer.Mod/s ~ Free Modules#Syntax10.Scn.Fnt%%System.Free HeapInspTracer Platform ~P AsciiCoder.CodeFiles#Syntax10.Scn.Fnt88AsciiCoder.CodeFiles % HeapInspTracer.Mod Platform.Mod ~ ;8FoldElemsNew#Syntax10.Scn.FntS := SYSTEM, X := Platform, Ref, RefElems, Oberon, TextFrames, Texts, PopupElems, MenuViewers, Strings, In, Out, Modules, Kernel, Types, Fonts, System, FoldElems;88#Syntax10.Scn.Fnt'' Simple = 0; Error = -1; TAB = 09X; 8}8]Syntax10.Scn.Fnt 8FoldElemsNew#Syntax10.Scn.FntOO ModListDesc = RECORD mod: X.Module; spec: BOOLEAN; next: ModList; END;88#Syntax10.Scn.FntII close, newViewer, trace, print, collect, store: PopupElems.Elem; END;8' ADDRESS = LONGINT; Name = ARRAY 32 OF CHAR; NRecProc = PROCEDURE (tag: X.Tag; VAR p: ADDRESS); NSysProc = PROCEDURE (size: LONGINT; VAR p: ADDRESS); NArrProc = PROCEDURE (nofdim, nofelem: LONGINT; eltag: X.Tag; VAR p: ADDRESS); ModList = POINTER TO ModListDesc;  PopupCmds = RECORD  8K8#Syntax10.Scn.Fnt isPrinting, noTrace, unloadHITracer, lockedHITracer, showCaller, showCallerVars: BOOLEAN; KernelRoutines: ARRAY 3 OF ADDRESS; newRec: NRecProc; newSys: NSysProc; newArr: NArrProc; t: Texts.Text; w: Texts.Writer; menuViewer: MenuViewers.Viewer; viewerCount: INTEGER; cmd: PopupCmds; parc, noParcs: TextFrames.Parc; objCount: LONGINT; tracedMods, tracedModsLast: ModList; thisMod: X.Module; 8%L8 Syntax10.Scn.FntSyntax10i.Scn.Fnt MarkElemsAlloc 8FoldElemsNew#Syntax10.Scn.Fnt66 BEGIN Texts.SetFont (w, Fonts.Default) END TDefault; 8 t8#Syntax10.Scn.FntFF BEGIN Texts.SetFont (w, Fonts.This ("Syntax10b.Scn.Fnt")) END TBold; 8 {kK8#Syntax10.Scn.Fnt,, BEGIN Texts.WriteString (w, s) END String; 8 ~kK8#Syntax10.Scn.Fnt!! BEGIN Texts.WriteLn (w) END Ln; 8 }kK8#Syntax10.Scn.Fnt)) BEGIN Texts.WriteInt (w, l, 0) END Int; 8 }kK8#Syntax10.Scn.Fnt%% BEGIN Texts.Write (w, TAB) END Tab; 8 kK8#Syntax10.Scn.Fnt-- BEGIN Texts.Append (txt, w.buf) END Append; 8  !A8#Syntax10.Scn.Fnt VAR fold: FoldElems.Elem; BEGIN NEW (fold); fold.visible := TRUE; NEW (fold.hidden); Texts.OpenBuf (fold.hidden); fold.W := FoldElems.elemW; fold.H := FoldElems.elemH; fold.handle := FoldElems.FoldHandler; IF collapsed THEN IF left THEN fold.mode := FoldElems.colLeft ELSE fold.mode := FoldElems.colRight END ELSIF left THEN fold.mode := FoldElems.expLeft ELSE fold.mode := FoldElems.expRight END; Texts.WriteElem (w, fold); Append (txt); IF switch THEN FoldElems.Switch (fold) END END InsertFolds; 8 +?48#Syntax10.Scn.Fnt!! VAR cmds: PopupElems.Elem; BEGIN NEW (cmds); COPY (name, cmds.name); cmds.small := TRUE; cmds.menu := TextFrames.Text (""); cmds.handle := PopupElems.Handle; Texts.Delete (cmds.menu, 0, cmds.menu.len); Append (cmds.menu); PopupElems.MeasureMenu (cmds); RETURN cmds END CreatePopup; 8  P=8#Syntax10.Scn.Fnt VAR c: PopupElems.Elem; copy: Texts.CopyMsg; BEGIN cmds.handle (cmds, copy); c := copy.e (PopupElems.Elem); Texts.WriteElem (w, c); Texts.Insert (menu.text, menu.text.len, w.buf) END InsertPopup; 8 kKG8BSyntax10.Scn.FntPSyntax8i.Scn.FntV VAR menuF, mainF: TextFrames.Frame; x, y, i, n: INTEGER; nstr: ARRAY 10 OF CHAR; str: ARRAY 40 OF CHAR; BEGIN txt := TextFrames.Text(""); nstr [0] := ')'; i := 1; n := viewerCount; WHILE n > 0 DO nstr [i] := CHR ((n MOD 10) + ORD ('0')); n := n DIV 10; INC (i) END; nstr [i] := '('; n := i; FOR i := 0 TO n DO str [i] := nstr [n - i] END; str [i] := 0X; Strings.Insert (title, 0, str); CASE menu OF Simple: menuF := TextFrames.NewMenu (title, ""); InsertPopup (cmd.close, menuF); InsertPopup (cmd.newViewer, menuF); InsertPopup (cmd.trace, menuF); InsertPopup (cmd.print, menuF); InsertPopup (cmd.collect, menuF); InsertPopup (cmd.store, menuF) ELSE menuF := TextFrames.NewMenu (title, "System.Close System.Copy System.Grow"); END; mainF := TextFrames.NewText (txt, 0); Oberon.AllocateUserViewer (Oberon.Mouse.X, x, y); menuViewer := MenuViewers.New (menuF, mainF, TextFrames.menuH, x, y) END OpenViewer; 8  (* Text operations *) PROCEDURE TDefault;  PROCEDURE TBold;  PROCEDURE String (s: ARRAY OF CHAR);  PROCEDURE Ln;  PROCEDURE Int (l: LONGINT);  PROCEDURE Tab;  PROCEDURE Append (txt: Texts.Text);  PROCEDURE InsertFolds (txt: Texts.Text; left, collapsed, switch: BOOLEAN);  PROCEDURE CreatePopup (name: ARRAY OF CHAR): PopupElems.Elem;  PROCEDURE InsertPopup (cmds: PopupElems.Elem; menu: TextFrames.Frame);  PROCEDURE OpenViewer (title: ARRAY OF CHAR; VAR txt: Texts.Text; menu: INTEGER);  8 i>(8CSyntax10.Scn.Fnt,Syntax10b.Scn.Fnt q VAR m: X.Module; BEGIN IF mod = NIL THEN RETURN FALSE END; m := X.GetModules (); WHILE (m # NIL) & (m # mod) DO m := m.next END; RETURN m = mod END IsValidModule; 8 i>EE8I Syntax10.Scn.Fntb8FoldElemsNewCSyntax10.Scn.FntSyntax10i.Scn.Fnt VAR r, r1: Ref.Rider; p: TextFrames.Parc; copy: Texts.CopyMsg; BEGIN InsertFolds (t, TRUE, FALSE, FALSE); noParcs.handle (noParcs, copy); p := copy.e (TextFrames.Parc); Texts.WriteElem (w, p); Ref.OpenStack (NIL, r); r.Next (); r.Next (); r.Next (); (* Internal procedures *) WHILE r.mode # Ref.End DO String (r.mod); String ("."); String (r.name); IF showCallerVars THEN Tab; InsertFolds (t, TRUE, FALSE, FALSE); r.Zoom (r1); RefElems.WriteRider (w, r1, 1); InsertFolds (t, FALSE, FALSE, TRUE) END; r.Next (); Ln END; parc.handle (parc, copy); p := copy.e (TextFrames.Parc); Texts.WriteElem (w, p); InsertFolds (t, FALSE, FALSE, TRUE) END ShowCallerInFolds; 8`Syntax10b.Scn.Fnt8CSyntax10.Scn.Fnt{Syntax10i.Scn.Fnt'< String ("N "); IF ~lockedHITracer THEN lockedHITracer := TRUE; X.SetRefcnt (thisMod, X.GetRefcnt (thisMod) + 1) (* No unload of this module possible *) END; Kernel.RegisterObject (S.VAL (S.PTR, p), Finalize)Syntax10i.Scn.Fnt 8y:8#Syntax10.Scn.Fnt IF kind = X.TArrP THEN String ("Array of"); type := S.VAL (X.TypeS, X.TypeOf (S.VAL (S.PTR, p))) ELSE S.GET (S.VAL (LONGINT, p) - 4, p); String ("Array") END 88#Syntax10.Scn.FntXX CASE kind OF X.TObj: type := S.VAL (X.TypeS, X.TypeOf (S.VAL (S.PTR, p))); IF IsValidModule (type.mdesc) THEN String ("Record") ELSE S.GET (S.VAL (LONGINT, p) - 4, p); String ("Sysblock") END | X.TTypDesc: String ("Typedesc"); type := S.VAL (X.TypeS, tdesc) | X.TSysBl: String ("Error: Illegal sysblock detected"); Append (t); HALT (99) | X.TArrP: String ("Array of"); type := S.VAL (X.TypeS, X.TypeOf (S.VAL (S.PTR, p))) | X.TFree: String ("Error: Free block (???) detected"); Append (t); HALT (99) ELSE String ("Error: Invalid CASE"); Append (t); HALT (99) END8!^8#Syntax10.Scn.Fnt IF (type.mdesc # NIL) & IsValidModule (type.mdesc) THEN String (type.mdesc.name) END; String ("."); String (type.name)88ys VAR kind: INTEGER; tdesc: X.Tag; size: LONGINT; type: X.TypeS; PROCEDURE ShowCallerInFolds ();  BEGIN isPrinting := TRUE; IF t = NIL THEN String ("NEW failed (NIL returned)."); Append (t); RETURN END; IF new THEN  New object  ELSE String ("D ") END; Int (objCount); Tab; kind := X.GetObjType (S.VAL (S.PTR, p), tdesc, size); IF isArray THEN  Array with or without pointers  ELSE  Other objects  END; Tab; IF type # NIL THEN  Print type (when module is valid => print module name)  ELSIF isArray THEN String ("without pointer") ELSE String ("-------"); END; Tab; Int (size); Tab; Int (p); String (" ("); Int (X.AddressAbsToRel (p)); String (")");; IF ((kind = X.TArrP) OR isArray) & new THEN Tab; Int (dim); Tab; Int (nOfElem) ELSE Tab; Tab END; IF showCaller THEN Tab; ShowCallerInFolds () END; Ln; Append (t); isPrinting := FALSE END PrintObj; 8 i>% N8#Syntax10.Scn.Fnt VAR type: Types.Type; BEGIN newRec (tag, p); INC (objCount); IF ~isPrinting & ~noTrace THEN PrintObj (p, TRUE, FALSE, 0, 0) END END NewRec; 8 j>((d8#Syntax10.Scn.Fntzz BEGIN newSys (size, p); INC (objCount); IF ~isPrinting & ~noTrace THEN PrintObj (p, TRUE, FALSE, 0, 0) END END NewSys; 8 k>AH8#Syntax10.Scn.Fnt BEGIN newArr (nofdim, nofelem, eltag, p); INC (objCount); IF ~isPrinting & ~noTrace THEN PrintObj (p, TRUE, TRUE, nofdim, nofelem) END END NewArr; 8 k>08#Syntax10.Scn.Fnt VAR regMod, last: ModList; BEGIN regMod := tracedMods; last := regMod; WHILE regMod # NIL DO IF ~IsValidModule (regMod.mod) THEN IF regMod = tracedMods THEN tracedMods := tracedMods.next; ELSE last.next := regMod.next; IF last.next = NIL THEN tracedModsLast := last END END END; last := regMod; regMod := regMod.next END; IF tracedMods = NIL THEN tracedModsLast := NIL END END CheckRegisteredModules; 8 i>'8QSyntax10.Scn.FntSyntax10b.Scn.Fnt  VAR mod: X.Module; n: INTEGER; BEGIN n := 0; mod := X.GetModules (); WHILE (mod # NIL) & (mod.name # modName) DO mod := mod.next; INC (n) END; IF mod # NIL THEN RETURN Error ELSE RETURN n END END CountModules; 8 i><8Syntax10.Scn.Fntl8FoldElemsNew#Syntax10.Scn.FntrrnewNrOfMods, loadedMods, nrOfImports, i: LONGINT; mod, thisMod: X.Module; impList: X.AddressList; tMod: ModList;8 VAR  BEGIN CheckRegisteredModules (); newNrOfMods := CountModules (""); ASSERT (newNrOfMods # Error); loadedMods := newNrOfMods - oldNrOfMods; thisMod := S.VAL (X.Module, Modules.ThisMod ("HeapInspTracer")); X.SetRefcnt (thisMod, X.GetRefcnt (thisMod) + loadedMods); mod := X.GetModules (); WHILE (mod # NIL) & (loadedMods > 0) DO nrOfImports := X.GetNoOfImportsInMod (mod); NEW (impList, nrOfImports + 1); FOR i := 0 TO nrOfImports - 1 DO impList [i] := X.GetImportInMod (mod, SHORT (i)) END; impList [nrOfImports] := S.VAL (ADDRESS, thisMod); ASSERT (impList [nrOfImports] # S.VAL (ADDRESS, NIL)); X.SetPtrToImportList (mod, impList); NEW (tMod); tMod.mod := mod; tMod.spec := mod.name = specMod; IF tracedMods # NIL THEN tracedModsLast.next := tMod ELSE tracedMods := tMod END; tracedModsLast := tMod; mod := mod.next; DEC (loadedMods) END END UpdateAllImportLists; 8 i>8#Syntax10.Scn.Fnt VAR tMod: ModList; cnt: INTEGER; p: TextFrames.Parc; copy: Texts.CopyMsg; BEGIN ASSERT (t # NIL); parc.handle (parc, copy); p := copy.e (TextFrames.Parc); Texts.WriteElem (w, p); String ("Tracing modules:"); tMod := tracedMods; cnt := 0; WHILE tMod # NIL DO IF (cnt MOD 8) = 0 THEN Ln; Tab END; IF tMod.spec THEN TBold END; String (tMod.mod.name); IF tMod.spec THEN TDefault END; tMod := tMod.next; INC (cnt); IF tMod # NIL THEN String (", ") END END; Ln; Ln; TBold; String ("Action"); Tab; String ("Block"); Tab; String ("Record type"); Tab; String ("Size"); Tab; String ("Address (rel.)"); Tab; String ("Dim"); Tab; String ("Elems"); TDefault; Ln; Ln; Append (t) END PrintViewerText; 8 i> v8#Syntax10.Scn.Fnthh BEGIN OpenViewer ("HeapInspTracer", t, Simple); PrintViewerText (); noTrace := FALSE END NewViewer; 8 i>8Syntax10.Scn.Fnt8FoldElemsNew#Syntax10.Scn.Fntr: Ref.Rider; i, nOfMods: INTEGER; name: Name; mod: Modules.Module; nRec: PROCEDURE(tag: X.Tag; VAR p: ADDRESS); nSys: PROCEDURE(size: LONGINT; VAR p: ADDRESS); nArr: PROCEDURE(nofdim, nofelem: LONGINT; eltag: X.Tag; VAR p: ADDRESS);8.Syntax10b.Scn.FntHSyntax10i.Scn.Fnt VAR  BEGIN unloadHITracer := FALSE; noTrace := FALSE; In.Open; In.Name (name); nOfMods := CountModules (name); OpenViewer ("HeapInspTracer", t, Simple); PrintViewerText (); IF nOfMods = Error THEN String ("Error: Module "); String (name); String (" is already loaded."); Ln; Append (Oberon.Log); RETURN END; Ref.OpenVars ("Modules", r); WHILE (r.mode # Ref.End) & (r.name # "KernelRoutines") DO r.Next END; r.Zoom (r); nRec := NewRec; nSys := NewSys; nArr := NewArr; r.ReadLInt (KernelRoutines [0]); r.WriteLInt (S.VAL (LONGINT, nRec)); r.Next (); r.ReadLInt (KernelRoutines [1]); r.WriteLInt (S.VAL (LONGINT, nSys)); r.Next (); r.ReadLInt (KernelRoutines [2]); r.WriteLInt (S.VAL (LONGINT, nArr)); newRec := S.VAL (NRecProc, KernelRoutines [0]); newSys := S.VAL (NSysProc, KernelRoutines [1]); newArr := S.VAL (NArrProc, KernelRoutines [2]); mod := Modules.ThisMod (name); (* Load module(s) *) UpdateAllImportLists (nOfMods, name); Ref.OpenVars ("Modules", r); WHILE (r.mode # Ref.End) & (r.name # "KernelRoutines") DO r.Next END; r.Zoom (r); r.WriteLInt (S.VAL (LONGINT, KernelRoutines [0])); r.Next (); r.WriteLInt (S.VAL (LONGINT, KernelRoutines [1])); r.Next (); r.WriteLInt (S.VAL (LONGINT, KernelRoutines [2])); IF mod = NIL THEN Ln; String ("Can't find module "); String (name); String ("."); Ln; Ln; Append (t) ELSE Ln; String ("Specified modules loaded."); Ln; Ln; PrintViewerText () END END Trace; 8 i> 8#Syntax10.Scn.Fnt)) BEGIN noTrace := TRUE END TurnTraceOff; 8 i> 8#Syntax10.Scn.Fnt== BEGIN IF t # NIL THEN noTrace := FALSE END END TurnTraceOn; 8 i>8#Syntax10.Scn.Fnt11 BEGIN PrintViewerText () END ShowTracedModules; 8 i>w8#Syntax10.Scn.Fntgg BEGIN IF Oberon.Par.vwr = menuViewer THEN noTrace := TRUE; t := NIL END; System.Close END Close; 8 i> 8#Syntax10.Scn.Fnt VAR regMod: ModList; BEGIN CheckRegisteredModules (); regMod := tracedMods; WHILE regMod # NIL DO IF IsValidModule (regMod.mod) THEN Out.String ("Unloading traced module "); Out.String (regMod.mod.name); Modules.Free (regMod.mod.name, FALSE); IF Modules.res # Modules.done THEN Out.String (" failed.") ELSE Out.String (" done.") END; Modules.res := Modules.done; Out.Ln END; regMod := regMod.next END; CheckRegisteredModules () END UnloadTraced; 8 i> 8#Syntax10.Scn.Fnt22 BEGIN UnloadTraced; IF objCount = 0 THEN Modules.Free ("HeapInspTracer", FALSE); Out.String ("Unloading HeapInspTracer "); IF Modules.res # Modules.done THEN Out.String ("failed.") ELSE Out.String ("done.") END; Modules.res := Modules.done; Out.Ln END; unloadHITracer := TRUE END UnloadAll; 8 i>f8#Syntax10.Scn.Fntxx BEGIN Out.String ("HeapInspTracer: Current existing objects: "); Out.Int (objCount, 0); Out.Ln; END PrintCountedObjs; 8 i> 8#Syntax10.Scn.Fnt VAR switch: ARRAY 10 OF CHAR; BEGIN In.Open; In.Name (switch); IF switch = "On" THEN showCaller := TRUE; showCallerVars := FALSE ELSIF switch = "Off" THEN showCaller := FALSE; showCallerVars := FALSE ELSIF switch = "WithVars" THEN showCaller := TRUE; showCallerVars := TRUE ELSE Out.String ("HeapInspTracer: ShowCaller: "); IF showCaller THEN IF showCallerVars THEN Out.String ("With variables.") ELSE Out.String ("On.") END ELSE Out.String ("Off.") END; Out.Ln END END ShowCaller; 8 k>v8CSyntax10.Scn.FntSyntax10i.Scn.Fnt$;H BEGIN DEC (objCount); IF ~isPrinting & ~noTrace THEN PrintObj (S.VAL (ADDRESS, obj), FALSE, FALSE, 0, 0) END; IF (objCount = 0) & lockedHITracer THEN lockedHITracer := FALSE; X.SetRefcnt (thisMod, X.GetRefcnt (thisMod) - 1); (* Unload of this module possible *) IF unloadHITracer THEN UnloadAll END END END Finalize; 88Syntax10.Scn.Fnt8FoldElemsNew#Syntax10.Scn.Fnt VAR copy: Texts.CopyMsg; BEGIN TextFrames.defParc.handle (TextFrames.defParc, copy); parc := copy.e (TextFrames.Parc); parc.nofTabs := 7; parc.tab [0] := 450000; parc.tab [1] := 1000000; parc.tab [2] := 3100000; parc.tab [3] := 3700000; parc.tab [4] := 5000000; parc.tab [5] := 5300000; parc.tab [6] := 5750000; TextFrames.defParc.handle (TextFrames.defParc, copy); noParcs := copy.e (TextFrames.Parc); noParcs.nofTabs := 0; END SetParcs; 88#Syntax10.Scn.Fnt BEGIN String ("HeapInspTracer.Close"); Ln; String ("HeapInspTracer.UnloadAll"); Ln; String ("HeapInspTracer.UnloadTraced"); cmd.close := CreatePopup ("Close"); String ("HeapInspTracer.NewViewer"); cmd.newViewer := CreatePopup ("New viewer"); String ("HeapInspTracer.TurnTraceOff"); Ln; String ("HeapInspTracer.TurnTraceOn"); cmd.trace := CreatePopup ("Trace"); String ("HeapInspTracer.PrintCountedObjs"); Ln; String ("HeapInspTracer.ShowTracedModules"); Ln; String ("HeapInspTracer.ShowCaller On"); Ln; String ("HeapInspTracer.ShowCaller WithVars"); Ln; String ("HeapInspTracer.ShowCaller Off"); cmd.print := CreatePopup ("Show"); String ("System.Collect"); cmd.collect := CreatePopup ("Collect"); String ("Edit.Store"); cmd.store := CreatePopup ("Store") END SetPopups; 8g PROCEDURE SetParcs ();  PROCEDURE SetPopups ();  BEGIN isPrinting := FALSE; noTrace := FALSE; unloadHITracer := FALSE; lockedHITracer := FALSE; showCaller := FALSE; showCallerVars := FALSE; objCount := 0; viewerCount := 1; Texts.OpenWriter (w); thisMod := X.GetModules (); WHILE (thisMod # NIL) & (thisMod.name # "HeapInspTracer") DO thisMod := thisMod.next END; SetParcs (); SetPopups () END Init; 8!jMODULE HeapInspTracer; (* HeapInspTracer by MR, 15.02.97 -   *)     IMPORT  CONST  TYPE  VAR  PROCEDURE ^Finalize (obj: S.PTR);  Text operations  PROCEDURE IsValidModule (mod: X.Module): BOOLEAN;  PROCEDURE PrintObj (p: ADDRESS; new, isArray: BOOLEAN; dim, nOfElem: LONGINT);  PROCEDURE NewRec (tag: X.Tag; VAR p: ADDRESS); (* implementation of NEW(ptr) *)  PROCEDURE NewSys (size: LONGINT; VAR p: ADDRESS); (* implementation of S.NEW(ptr, size) *)  PROCEDURE NewArr (nofdim, nofelem: LONGINT; eltag: X.Tag; VAR p: ADDRESS);  PROCEDURE CheckRegisteredModules ();  PROCEDURE CountModules (modName: Name): INTEGER;  PROCEDURE UpdateAllImportLists (oldNrOfMods: INTEGER; specMod: Name);  PROCEDURE PrintViewerText ();  PROCEDURE NewViewer*;  PROCEDURE Trace*;  PROCEDURE TurnTraceOff*;  PROCEDURE TurnTraceOn*;  PROCEDURE ShowTracedModules*;  PROCEDURE Close*;  PROCEDURE UnloadTraced*;  PROCEDURE UnloadAll*;  PROCEDURE PrintCountedObjs*;  PROCEDURE ShowCaller*;  PROCEDURE Finalize (obj: S.PTR);  PROCEDURE Init;  BEGIN Init; END HeapInspTracer.