(FILECREATED " 3-Sep-85 15:47:16" {ERIS}<LISPCORE>LIBRARY>GCHAX.;15 107557Q
changes to: (FNS \FINDPOINTER \FINDPOINTER.LISTP)
previous date: " 6-Jan-85 22:31:08" {ERIS}<LISPCORE>LIBRARY>GCHAX.;12)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT GCHAXCOMS)
(RPAQQ GCHAXCOMS [(FNS \MAPGC \SHOWGC \GCENTRIES.BY.TYPE \#COLLISIONS \#OVERFLOWS \GCSTATS.AUX)
(FNS \PRINTFREELIST \SHOWFREELISTS \SCANFREELIST \ISONFREELIST)
(FNS \COLLECTINUSE \SORTFREELIST \SFLHASHLOOKUP)
(FNS \SHOWCIRCULARITY \SHOWCIRCULARITY1 \SHOWCIRCULARLIST \SHOWCIRCULARPATH)
(FNS \SHOW.CLOSED.WINDOWS \WINDOW.ACCOUNTED.FOR? PFL SFL)
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS \COERCETOTYPENUMBER .ALLOCATED.PER.PAGE.)
(RECORDS FREELISTENTRY HASHENTRY)
(FILES (LOADCOMP)
LLGC)
(LOCALVARS . T)
(GLOBALVARS SYSTEMRECLST))
(P (PUTDQ? \GC.LOOKUP.BIGREFCNT [LAMBDA (PTR)
77Q]))
(FNS \FINDPOINTER \FINDPOINTERS.OF.TYPE \FINDPOINTER.FOUND \FINDPOINTER.NEWITEM
\FINDPOINTER.LISTP \FINDPOINTER.LISTP.FREE \FINDPOINTER.TYPE
\FINDPOINTER.INTERPRET.RECORD)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA SFL PFL)
(NLAML)
(LAMA])
(DEFINEQ
(\MAPGC
[LAMBDA (MAPFN INCLUDEZEROCNT) (* bvm: "14-Feb-84 10:55")
(PROG ((I 0)
ENTRY LINK CNT)
LP (SETQ ENTRY (\ADDBASE \HTMAIN I))
[COND
((fetch (GC EMPTY) of ENTRY))
[(NOT (fetch (GC LINKP) of ENTRY))
(COND
((OR INCLUDEZEROCNT (NEQ (fetch (GC CNT) of ENTRY)
0))
(APPLY* MAPFN (\VAG2 (fetch (GC HIBITS) of ENTRY)
(LLSH I 1))
[COND
((ILESSP (SETQ CNT (fetch (GC CNT) of ENTRY))
\MAXHTCNT)
CNT)
(T (\GC.LOOKUP.BIGREFCNT (\VAG2 (fetch (GC HIBITS) of ENTRY)
(LLSH I 1]
NIL]
(T (SETQ LINK (fetch (GC LINKPTR) of ENTRY))
(do (SETQ LINK (\ADDBASE \HTCOLL LINK))
(COND
((OR INCLUDEZEROCNT (NEQ (fetch (GC CNT) of LINK)
0))
(APPLY* MAPFN (\VAG2 (fetch (GC HIBITS) of LINK)
(LLSH I 1))
[COND
((ILESSP (SETQ CNT (fetch (GC CNT) of LINK))
\MAXHTCNT)
CNT)
(T (\GC.LOOKUP.BIGREFCNT (\VAG2 (fetch (GC HIBITS) of LINK)
(LLSH I 1]
T)))
repeatuntil (EQ (SETQ LINK (fetch (GC NXTPTR) of LINK))
0]
(COND
((ILESSP (add I 1)
100000Q)
(GO LP])
(\SHOWGC
[LAMBDA (ONLYTYPES COLLECT FILE CARLVL CDRLVL MINCNT) (* bvm: "14-Feb-84 12:09")
(OR CARLVL (SETQ CARLVL 2))
(OR CDRLVL (SETQ CDRLVL 6))
(OR MINCNT (SETQ MINCNT 2))
[COND
(ONLYTYPES (SETQ ONLYTYPES (for TYPE inside ONLYTYPES collect (\COERCETOTYPENUMBER TYPE]
(RESETLST [RESETSAVE (OUTPUT (COND
((NULL FILE)
T)
((OPENP FILE (QUOTE OUTPUT)))
(T [RESETSAVE NIL (LIST (QUOTE CLOSEF)
(SETQ FILE (OPENFILE FILE (QUOTE OUTPUT]
FILE]
(printout NIL " cnt datum" T)
(PROG [(TOTALCNT 0)
(COLLCNT 0)
(MAXCNT 0)
(SELECTEDITEMS (AND COLLECT (CONS]
(SETQ RESULT SELECTEDITEMS)
(\MAPGC [FUNCTION (LAMBDA (PTR CNT COLL?)
(COND
((AND (OR (NOT ONLYTYPES)
(FMEMB (NTYPX PTR)
ONLYTYPES))
(IGEQ CNT MINCNT))
(printout NIL (COND
(COLL? (QUOTE *))
(T (QUOTE % )))
CNT ,,)
(LVLPRINT PTR NIL CARLVL CDRLVL)
(COND
((AND ONLYTYPES COLLECT)
[SETQ SELECTEDITEMS (CDR (FRPLACD SELECTEDITEMS
(CONS PTR NIL]
(* Use RPLCONS to minimize refcnt operations)
))
(add TOTALCNT 1)
(COND
(COLL? (add COLLCNT 1)))
(COND
((IGEQ CNT \MAXHTCNT)
(add MAXCNT 1]
(ILESSP MINCNT 1))
(printout NIL TOTALCNT " items with reference cnt greater than or equal to "
MINCNT T)
(COND
((AND (ILESSP MINCNT \MAXHTCNT)
(NEQ MAXCNT 0))
(printout NIL MAXCNT " items with overflowed reference cnt" T)))
(printout NIL COLLCNT " collision entries" T)
(RETURN (COND
(COLLECT (CDR RESULT))
(T FILE])
(\GCENTRIES.BY.TYPE
(LAMBDA (MINREFCNT MINFRACTION)
(DECLARE (SPECVARS MINREFCNT \#COLLISIONS \#OFENTRIES TYPETABLE))
(* JonL "28-Dec-84 19:33")
(OR MINREFCNT (SETQ MINREFCNT 0))
(OR MINFRACTION (SETQ MINFRACTION .002))
(PROG ((TYPECOUNTS (ARRAY (ADD1 \MaxTypeNumber)
(QUOTE WORD)
0 0))
(TYPECOLLISIONS (ARRAY (ADD1 \MaxTypeNumber)
(QUOTE WORD)
0 0))
(\#OFENTRIES 0)
(\#COLLISIONS 0)
(PRINTEDENTRIES 0)
(PRINTEDCOLLISIONS 0)
(MAXWIDTH 0)
CNT FRAC)
(\MAPGC (FUNCTION (LAMBDA (PTR REFCNT COLL?)
(PROG (TYPE)
(COND
((IGEQ REFCNT MINREFCNT)
(add \#OFENTRIES 1)
(add (ELT TYPECOUNTS (NTYPX PTR))
1)
(COND
(COLL? (add \#COLLISIONS 1)
(add (ELT TYPECOLLISIONS (NTYPX PTR))
1)))))))))
(for I from 0 to \MaxTypeNumber bind N do (COND
((IGREATERP (SETQ N (NCHARS (\TYPENAMEFROMNUMBER
I)))
MAXWIDTH)
(SETQ MAXWIDTH N))))
(COND
((IGREATERP MINREFCNT 0)
(printout T " with reference count at least " .P2 MINREFCNT)))
(printout T T .FR MAXWIDTH "Type" " all entries collisions" T T)
(for TYPE# from 0 to \MaxTypeNumber when (AND (NEQ (SETQ CNT (ELT TYPECOUNTS TYPE#))
0)
(FGREATERP (SETQ FRAC (FQUOTIENT CNT
\#OFENTRIES))
MINFRACTION))
do (printout T .FR MAXWIDTH (OR (\TYPENAMEFROMNUMBER TYPE#)
(CONCAT "Type " TYPE#))
.I7 CNT .F6.1 (FTIMES 100.0 FRAC)
"%%")
(add PRINTEDENTRIES CNT)
(COND
((NOT (EQ 0 (SETQ CNT (ELT TYPECOLLISIONS TYPE#))))
(add PRINTEDCOLLISIONS CNT)
(printout T .I10 CNT .F6.1 (FTIMES 100.0 (FQUOTIENT CNT \#COLLISIONS))
"%%")))
(TERPRI T))
(printout T .FR MAXWIDTH "All other types" .I7 (SETQ CNT (IDIFFERENCE \#OFENTRIES
PRINTEDENTRIES))
.F6.1
(FTIMES 100.0 (FQUOTIENT CNT \#OFENTRIES))
"%%")
(printout T .I10 (SETQ CNT (IDIFFERENCE \#COLLISIONS PRINTEDCOLLISIONS))
.F6.1
(FTIMES 100.0 (FQUOTIENT CNT \#COLLISIONS))
"%%" T)
(printout T T .FR MAXWIDTH "Total" .I7 \#OFENTRIES .I17 \#COLLISIONS T T))))
(\#COLLISIONS
(LAMBDA NIL (* JonL "28-Jan-84 04:20")
(\GCSTATS.AUX (QUOTE \#COLLISIONS))))
(\#OVERFLOWS
(LAMBDA NIL (* JonL "28-Jan-84 04:20")
(\GCSTATS.AUX (QUOTE \#OVERFLOWS))))
(\GCSTATS.AUX
[LAMBDA (\GCTYPE.AUX)
(DECLARE (SPECVARS \#GCENTRIES \#GCLOSERS \GCTYPE.AUX))
(* bvm: "14-Feb-84 11:06")
(PROG ((\#GCENTRIES 0)
(\#GCLOSERS 0))
[\MAPGC (FUNCTION (LAMBDA (PTR REFCNT COLLISIONP)
(add \#GCENTRIES 1)
(SELECTQ \GCTYPE.AUX
[\#OVERFLOWS (COND
((IGEQ REFCNT \MAXHTCNT)
(add \#GCLOSERS 1]
[\#COLLISIONS (COND
(COLLISIONP (add \#GCLOSERS 1]
(SHOULDNT]
(RETURN (LIST \#GCENTRIES \#GCLOSERS (QUOTIENT (FLOAT \#GCLOSERS)
\#GCENTRIES])
)
(DEFINEQ
(\PRINTFREELIST
[LAMBDA (TYPE DETAILS FILE) (* bvm: " 6-Dec-83 15:00")
(SETQ TYPE (\COERCETOTYPENUMBER TYPE))
(PROG ((INFO (\SCANFREELIST TYPE))
TOTALPAGES MAXFREE TOTALLYFREE)
(printout FILE "Type " (\TYPENAMEFROMNUMBER TYPE)
": ")
(COND
([AND INFO (NOT (FIXP (CDAR INFO]
(printout FILE T (pop INFO)
T)))
(printout FILE .P2 (for X in INFO sum (CDR X))
" cells free" T "Free list covers " .P2 [SETQ TOTALPAGES
(LENGTH (for X in INFO do (pushnew $$VAL (CAR X]
" Pages with " .P2 (IDIFFERENCE (LENGTH INFO)
TOTALPAGES)
" extra hops" T)
[SETQ MAXFREE (IQUOTIENT \MDSIncrement (fetch DTDSIZE of (\GETDTD TYPE]
(COND
((IGREATERP [SETQ TOTALLYFREE (for TAIL on INFO count (AND (CDR TAIL)
(EQ (CAAR TAIL)
(LOGXOR (CAADR TAIL)
1))
(EQ (IPLUS (CDAR TAIL)
(CDADR TAIL))
MAXFREE]
0)
(printout FILE "Of the " .P2 TOTALPAGES " pages, " .P2 (ITIMES TOTALLYFREE 2)
" are completely free" T)))
(COND
(DETAILS (printout FILE "Details (page/#free):" T)
[for TAIL on (REVERSE INFO)
bind (I ← 0)
(N ←(SUB1 (IQUOTIENT (LINELENGTH NIL FILE)
12)))
do (printout FILE .TAB (ITIMES I 12)
.I6.8
(CAR (CAR TAIL))
"/" .I3 (CDR (CAR TAIL)))
[COND
((ASSOC (CAAR TAIL)
(CDR TAIL))
(printout FILE (QUOTE +]
(COND
((IGREATERP (add I 1)
N)
(SETQ I 0]
(TERPRI FILE)))
(TERPRI FILE])
(\SHOWFREELISTS
[LAMBDA (DETAILS FILE) (* bvm: "13-Dec-83 11:53")
(for I from 2 to \MaxTypeNumber do (\PRINTFREELIST I DETAILS FILE) unless (EQ I \LISTP])
(\SCANFREELIST
[LAMBDA (TYPE) (* bvm: " 5-Dec-83 15:59")
(PROG (RESULT FREE LASTPAGE LASTPAGECOUNT THISPAGE)
(SETQ TYPE (\COERCETOTYPENUMBER TYPE))
[COND
((EQ TYPE \LISTP)
(RETURN (CONS (LIST "LISTP scan not implemented"]
(SETQ FREE (fetch DTDFREE of (\GETDTD TYPE)))
(while FREE
do (SETQ THISPAGE (fetch (POINTER PAGE#) of FREE))
(COND
((EQ THISPAGE LASTPAGE)
(add LASTPAGECOUNT 1))
(T [COND
(LASTPAGE (push RESULT (CONS LASTPAGE LASTPAGECOUNT]
(COND
((NEQ (NTYPX FREE)
TYPE)
(push RESULT (LIST "Bad free list at" (\HILOC FREE)
(\LOLOC FREE)))
(RETURN)))
(SETQ LASTPAGE THISPAGE)
(SETQ LASTPAGECOUNT 1)))
(SETQ FREE (fetch FREELINK of FREE)))
[COND
(LASTPAGE (push RESULT (CONS LASTPAGE LASTPAGECOUNT]
(RETURN RESULT])
(\ISONFREELIST
[LAMBDA (OBJECT) (* bvm: " 6-Dec-83 17:44")
(PROG ((TYPE (NTYPX OBJECT))
FREE)
(COND
((EQ TYPE \LISTP)
(RETURN "LISTP scan not implemented")))
(SETQ FREE (fetch DTDFREE of (\GETDTD TYPE)))
(RETURN (while FREE
do (COND
((EQ OBJECT FREE)
(RETURN T)))
(SETQ FREE (fetch FREELINK of FREE])
)
(DEFINEQ
(\COLLECTINUSE
[LAMBDA (TYPE) (* bvm: " 6-Jan-85 22:26")
(SETQ TYPE (\COERCETOTYPENUMBER TYPE))
(RPTQ 20 (RECLAIM))
(RESETFORM (RECLAIMMIN MAX.SMALLP)
(UNINTERRUPTABLY
(PROG ((HASHTABLE (\SORTFREELIST TYPE T))
(SIZE (fetch DTDSIZE of (\GETDTD TYPE)))
RESULT FIRSTFREE LASTFREE HASHENT LASTPAGE LIMIT)
(OR HASHTABLE (RETURN))
(OR (EVENP SIZE)
(SHOULDNT "Odd size?"))
(COND
((.ALLOCATED.PER.PAGE. SIZE)
(SETQ LASTPAGE (SUB1 (IQUOTIENT \MDSIncrement WORDSPERPAGE)))
(SETQ LIMIT WORDSPERPAGE))
(T (SETQ LASTPAGE 0)
(SETQ LIMIT \MDSIncrement)))
[for MDSPAGE# from 0 by (IQUOTIENT \MDSIncrement WORDSPERPAGE)
while (ILEQ MDSPAGE# \MAXVMPAGE)
when (EQ (LOGAND (\GETBASE \MDSTypeTable (LRSH MDSPAGE# 1))
\TT.TYPEMASK)
TYPE)
do [COND
([SETQ FIRSTFREE (COND
((SETQ HASHENT (OR (\SFLHASHLOOKUP MDSPAGE# HASHTABLE)
(\SFLHASHLOOKUP (LOGOR MDSPAGE# 1)
HASHTABLE)))
(\VAG2 (FOLDLO MDSPAGE# PAGESPERSEGMENT)
(fetch HASHFIRSTOFFSET of HASHENT]
(SETQ LASTFREE (fetch HASHLASTFREE
of (OR (AND (EVENP (fetch HASHPAGE#
of HASHENT))
(\SFLHASHLOOKUP (LOGOR MDSPAGE# 1)
HASHTABLE))
HASHENT]
(* * Now collect all pointers not on free list. This code parallels \INITMDSPAGE)
(for N from 0 to LASTPAGE
do (for (DISP ← 0) while (ILEQ (add DISP SIZE)
LIMIT)
as (DATUMBASE ←(create POINTER
PAGE# ←(IPLUS N MDSPAGE#)))
by (\ADDBASE DATUMBASE SIZE)
when (OR (NOT FIRSTFREE)
(for (X ← FIRSTFREE) by (fetch FREELINK
of X)
never (EQ X DATUMBASE) repeatuntil (EQ X LASTFREE)
))
do (push RESULT DATUMBASE]
(RETURN RESULT)))])
(\SORTFREELIST
[LAMBDA (TYPE FLG READONLY) (* bvm: "20-Jan-84 16:01")
(SETQ TYPE (\COERCETOTYPENUMBER TYPE))
(PROG ((DTD (\GETDTD TYPE))
NPAGES HASHTABLE HASHENT HSIZE NEXTFREE NEXTPAGE LASTPAGE FIRSTFREE LASTFREE OTHERLASTFREE
PREVPAGELASTFREE PROBE MASK)
(COND
((EQ TYPE \LISTP)
(RETURN)))
(SETQ NPAGES (ITIMES (for I from 0 to \MAXVMPAGE by 2
count (EQ (LOGAND (\GETBASE \MDSTypeTable (LRSH I 1))
\TT.TYPEMASK)
TYPE))
2))
(SETQ HSIZE (FIX (TIMES NPAGES 1.4))) (* Good size of hashtable for hashing pages of this type
into)
(SETQ HSIZE (find I from 8 by I suchthat (IGREATERP I HSIZE)))
(* Get a power of 2)
(SETQ HASHTABLE (\ALLOCBLOCK (ITIMES HSIZE 2)))
(replace HASHMASK of HASHTABLE with (SUB1 (ITIMES HSIZE 4)))
(SETQ NEXTFREE (fetch DTDFREE of DTD))
[do (COND
((NEQ (SETQ NEXTPAGE (fetch (POINTER PAGE#) of NEXTFREE))
LASTPAGE) (* Cell on a new page)
[COND
((AND NEXTFREE (NEQ (NTYPX NEXTFREE)
TYPE))
(RETURN (RAID "Bad free list" NEXTFREE]
(COND
(LASTPAGE (* Hash LASTPAGE and see if we have already seen cells
free on this page)
(SETQ HASHENT (\SFLHASHLOOKUP LASTPAGE HASHTABLE T))
(COND
[(SETQ OTHERLASTFREE (fetch HASHLASTFREE of HASHENT))
(* Yes, we have seen others. Link this section of the
free list into it)
(COND
((EQ (fetch FREELINK of OTHERLASTFREE)
FIRSTFREE)
(* Aha, already in order. This happens when we have a sequence LASTPAGE -> x ... -> LASTPAGE where everything in
between the two LASTPAGE's got moved to earlier in the freelist)
(SETQ PREVPAGELASTFREE LASTFREE))
((NOT READONLY)
(UNINTERRUPTABLY
[replace FREELINK of OTHERLASTFREE
with (PROG1 FIRSTFREE (replace FREELINK
of (OR PREVPAGELASTFREE
(RETURN (RAID
"No PREVPAGELASTFREE")))
with NEXTFREE)
(replace FREELINK of LASTFREE
with (fetch FREELINK of OTHERLASTFREE])]
(T (replace HASHFIRSTOFFSET of HASHENT with (\LOLOC FIRSTFREE))
(SETQ PREVPAGELASTFREE LASTFREE)))
(replace HASHLASTFREE of HASHENT with LASTFREE)))
(OR (SETQ FIRSTFREE NEXTFREE)
(RETURN))
(SETQ LASTPAGE NEXTPAGE)))
(SETQ NEXTFREE (fetch FREELINK of (SETQ LASTFREE NEXTFREE]
(SETQ LASTPAGE (SETQ PREVPAGELASTFREE))
(SETQ NEXTFREE (fetch DTDFREE of DTD))
(* * Now take a quick second pass to link all odd pages immediately after the corresponding even pages.
Might possibly have done this in the previous loop, but the logic gets pretty messy)
[do (COND
((NEQ (SETQ NEXTPAGE (fetch (POINTER PAGE#) of NEXTFREE))
LASTPAGE) (* Cell on a new page)
[COND
(LASTPAGE (COND
[(AND (ODDP LASTPAGE)
(SETQ HASHENT (\SFLHASHLOOKUP (LOGXOR LASTPAGE 1)
HASHTABLE))
(NEQ (fetch FREELINK of (SETQ OTHERLASTFREE
(fetch HASHLASTFREE of HASHENT)))
FIRSTFREE)) (* There is an entry for our partner even page, and it
is not immediately followed by its odd partner)
(OR READONLY
(UNINTERRUPTABLY
[replace FREELINK of OTHERLASTFREE
with (PROG1 FIRSTFREE
(COND
(PREVPAGELASTFREE (replace FREELINK
of PREVPAGELASTFREE
with NEXTFREE))
(T (OR (EQ FIRSTFREE
(fetch DTDFREE of DTD))
(RAID "No PREVPAGELASTFREE"))
(replace DTDFREE of DTD with NEXTFREE)))
(replace FREELINK of LASTFREE
with (fetch FREELINK of OTHERLASTFREE])]
(T (SETQ PREVPAGELASTFREE LASTFREE]
(OR (SETQ FIRSTFREE NEXTFREE)
(RETURN))
(SETQ LASTPAGE NEXTPAGE)))
(SETQ NEXTFREE (fetch FREELINK of (SETQ LASTFREE NEXTFREE]
(RETURN (AND FLG HASHTABLE])
(\SFLHASHLOOKUP
(LAMBDA (PAGE# HASHTABLE INSERT) (* JonL "28-Dec-84 19:33")
(bind (MASK ←(fetch HASHMASK of HASHTABLE))
PROBE HASHENT first (SETQ PROBE (LOGAND (LLSH PAGE# 2)
MASK))
do (COND
((EQ (fetch HASHPAGE# of (SETQ HASHENT (\ADDBASE HASHTABLE PROBE)))
PAGE#)
(RETURN HASHENT))
((EQ 0 (fetch HASHPAGE# of HASHENT))
(RETURN (COND
(INSERT (replace HASHPAGE# of HASHENT with PAGE#)
HASHENT)))))
(SETQ PROBE (LOGAND (IPLUS PROBE 4)
MASK)))))
)
(DEFINEQ
(\SHOWCIRCULARITY
[LAMBDA (OBJECT MAXLEVEL) (* bvm: "13-Dec-83 12:57")
(DECLARE (SPECVARS CIRCLEHASH OBJECT MAXLEVEL))
(PROG [(CIRCLEHASH (LIST (HARRAY 100]
(OR (AND (FIXP MAXLEVEL)
(IGREATERP MAXLEVEL 0))
(SETQ MAXLEVEL 1000))
(\SHOWCIRCULARITY1 OBJECT])
(\SHOWCIRCULARITY1
[LAMBDA (OBJ PATH) (* bvm: "13-Dec-83 12:09")
(DECLARE (USEDFREE OBJECT CIRCLEHASH MAXLEVEL))
(COND
((AND (EQ OBJ OBJECT)
PATH)
(\SHOWCIRCULARPATH PATH))
(T (PROG ((TYPE (NTYPX OBJ))
PTRS B)
(SELECTC TYPE
(\LISTP (push PATH OBJ)
(\SHOWCIRCULARLIST (CAR OBJ)
PATH MAXLEVEL)
(\SHOWCIRCULARLIST (CDR OBJ)
PATH MAXLEVEL))
(\STRINGP (* No circularity possible, although it does have one
pointer field))
[0 (COND
((AND (type? ARRAYBLOCK OBJ)
[IEQ \ArrayBlockPassword (fetch PASSWORD
of (SETQ B (\ADDBASE OBJ (IMINUS
\ArrayBlockHeaderWords]
(fetch (ARRAYBLOCK INUSE) of B)
(EQ (fetch (ARRAYBLOCK GCTYPE) of B)
PTRBLOCK.GCT)
(NOT (GETHASH OBJ CIRCLEHASH)))
(* B points to arrayblock header, OBJ to first and
subsequent data words)
(PUTHASH OBJ T CIRCLEHASH)
(push PATH OBJ)
(for old OBJ (TRAILER ←(fetch (ARRAYBLOCK TRAILER) of B))
by (\ADDBASE OBJ WORDSPERCELL) until (EQ OBJ TRAILER)
do (\SHOWCIRCULARITY1 (\GETBASEPTR OBJ 0)
PATH]
(COND
((AND (SETQ PTRS (fetch DTDPTRS of (\GETDTD TYPE)))
(NOT (GETHASH OBJ CIRCLEHASH)))
(PUTHASH OBJ T CIRCLEHASH)
(push PATH OBJ)
(for I in PTRS do (\SHOWCIRCULARITY1 (\GETBASEPTR OBJ I)
PATH])
(\SHOWCIRCULARLIST
[LAMBDA (LST PATH DEPTH) (* bvm: " 6-Dec-83 16:53")
(DECLARE (USEDFREE OBJECT))
(COND
((NLISTP LST)
(\SHOWCIRCULARITY1 LST PATH))
((EQ LST OBJECT)
(\SHOWCIRCULARITY PATH))
((NEQ DEPTH 0)
(\SHOWCIRCULARLIST (CAR LST)
PATH
(SUB1 DEPTH))
(\SHOWCIRCULARLIST (CDR LST)
PATH
(SUB1 DEPTH])
(\SHOWCIRCULARPATH
[LAMBDA (PATH) (* bvm: " 6-Dec-83 16:39")
(TERPRI T)
[for X in (REVERSE (CONS OBJECT PATH)) bind PREFIX
do (COND
(PREFIX (PRIN1 " -> " T))
(T (SETQ PREFIX T)))
(COND
((LISTP X)
(LVLPRIN2 X T 1 3))
(T (PRIN2 X]
(TERPRI T])
)
(DEFINEQ
(\SHOW.CLOSED.WINDOWS
[LAMBDA NIL (* bvm: "11-Oct-84 21:42")
(for (TAIL ←(\COLLECTINUSE (QUOTE WINDOW))) while TAIL bind (OPEN ←(OPENWINDOWS))
W MAIN
unless (\WINDOW.ACCOUNTED.FOR? (SETQ W (pop TAIL)))
sum (OPENW W)
(CURSORPOSITION (QUOTE (0 . 0))
W)
(if (MOUSECONFIRM "Click LEFT to close window, RIGHT to save" T)
then (CLOSEW W)
elseif (MOUSECONFIRM
"Find pointers? Click LEFT to search, RIGHT to leave window open and go on"
T)
then (CLOSEW W)
(RPTQ 10 (RECLAIM))
(\FINDPOINTER W))
1])
(\WINDOW.ACCOUNTED.FOR?
[LAMBDA (WINDOW) (* bvm: "30-Jul-84 14:57")
(OR (OPENWP WINDOW)
(OPENWP (WINDOWPROP WINDOW (QUOTE ICONWINDOW)))
(OPENWP (WINDOWPROP WINDOW (QUOTE ICONFOR)))
(PROG [(MAIN (WINDOWPROP WINDOW (QUOTE MAINWINDOW]
(RETURN (AND MAIN (\WINDOW.ACCOUNTED.FOR? MAIN])
(PFL
[NLAMBDA X (* bvm: " 5-Dec-83 18:46")
(\PRINTFREELIST X T])
(SFL
[NLAMBDA X (* bvm: " 5-Dec-83 18:47")
(\SORTFREELIST X)
(\PRINTFREELIST X T])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS \COERCETOTYPENUMBER MACRO (OPENLAMBDA (TYPE)
(OR (FIXP TYPE)
(\TYPENUMBERFROMNAME TYPE)
(ERROR "Not a valid type" TYPE]
[PUTPROPS .ALLOCATED.PER.PAGE. MACRO (OPENLAMBDA (SIZE)
(* Maybe change this some day to a fetch of a flag
from the DTD)
(AND (IGEQ (LISPVERSION)
111010Q)
(ILESSP (IREMAINDER WORDSPERPAGE SIZE)
(LRSH SIZE 1))
(ILESSP SIZE WORDSPERPAGE]
)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD FREELISTENTRY ((FREELINK FULLXPOINTER)))
(BLOCKRECORD HASHENTRY ((HASHPAGE# WORD)
(HASHFIRSTOFFSET WORD)
(HASHLASTFREE FULLXPOINTER))
[ACCESSFNS HASHENTRY (HASHMASK (fetch HASHFIRSTOFFSET of DATUM)
(PROGN (replace HASHPAGE# of DATUM
with MAX.SMALLP)
(replace HASHFIRSTOFFSET of DATUM
with NEWVALUE])
]
(FILESLOAD (LOADCOMP)
LLGC)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS SYSTEMRECLST)
)
)
(PUTDQ? \GC.LOOKUP.BIGREFCNT [LAMBDA (PTR)
77Q])
(DEFINEQ
(\FINDPOINTER
[LAMBDA (PTR COLLECT/INSPECT? ALLFLG MARGIN ALLBACKFLG) (* bvm: " 3-Sep-85 15:38")
(DECLARE (SPECVARS MARGIN REFSFOUND COLLECT/INSPECT?))
(OR MARGIN (SETQ MARGIN 0))
(PROG ((REFCNT (\REFCNT PTR))
[SAFESEGMENTS (AND (NOT ALLFLG)
(LIST (\HILOC \STACKSPACE)
(\HILOC \FPTOVP)
(\HILOC \PAGEMAP)
(\HILOC \PageMapTBL)
(\HILOC \AtomHashTable)
(\HILOC \PNPSPACE)
(ADD1 (\HILOC \PNPSPACE))
(\HILOC \SMALLPOSPSPACE)
(\HILOC \SMALLNEGSPACE)
(\HILOC \HTMAIN)
(\HILOC \HTCOLL)
(\HILOC (fetch BITMAPBASE of (SCREENBITMAP]
(STACKSEG (\HILOC \STACKSPACE))
(REFSFOUND 0)
RESULT ATOMSEGMENTS SEGBASE POINTERSOURCE)
(COND
((OR (NEQ REFCNT 1)
(NOT ALLBACKFLG))
(printout T .TAB0 MARGIN "Reference count = " .P2 REFCNT T)))
(COND
((AND (EQ REFCNT 0)
(NOT ALLFLG))
(GO DONE)))
[for DTDPAGESONLY in (QUOTE (T NIL))
do (* More likely to find on typed pages first)
(for SEGMENT from 1 to \MAXVMSEGMENT unless (FMEMB SEGMENT SAFESEGMENTS)
do
(SETQ SEGBASE (\VAG2 SEGMENT 0))
(for PAGEINSEG from 0 to (SUB1 PAGESPERSEGMENT) as PAGE# from (UNFOLD SEGMENT
PAGESPERSEGMENT)
as (PAGEBASE ← SEGBASE) by (\ADDBASE PAGEBASE WORDSPERPAGE)
bind TYPE DTD STR
when [COND
[DTDPAGESONLY (AND (NEQ (SETQ TYPE (NTYPX PAGEBASE))
0)
(fetch DTDPTRS of (SETQ DTD (\GETDTD TYPE]
(T (AND (EQ (SETQ TYPE (NTYPX PAGEBASE))
0)
(NEQ (\LOOKUPPAGEMAP PAGE#)
0)
(OR (NEQ SEGMENT STACKSEG)
(PROGN (* Don't look at released stack pages, even though they
exist in the vmem -- could get stack fault)
(ILESSP (\LOLOC PAGEBASE)
(fetch (IFPAGE EndOfStack) of \InterfacePage]
do (* Page exists and might contain pointers)
(to CELLSPERPAGE as (BASE ← PAGEBASE) by (\ADDBASE BASE WORDSPERCELL)
when (EQ (\GETBASEPTR BASE 0)
PTR)
do
(COND
((SETQ POINTERSOURCE
(SELECTC
TYPE
(0 (COND
([SETQ STR (CADR (ASSOC (FLOOR SEGMENT 2)
(OR ATOMSEGMENTS
(SETQ ATOMSEGMENTS
(LIST (LIST (\HILOC \VALSPACE)
"value")
(LIST (\HILOC \DEFSPACE)
"function definition")
(LIST (\HILOC \PLISTSPACE)
"property list"]
(\FINDPOINTER.NEWITEM T)
(printout T "as " STR " of atom "
(SETQ STR (\VAG2 0 (LRSH (\LOLOC BASE)
1)))
T)
STR)
(T (\FINDPOINTER.FOUND BASE)
NIL)))
(\LISTP (\FINDPOINTER.LISTP BASE ALLBACKFLG))
(\FINDPOINTER.TYPE BASE DTD)))
(* Accounted for a valid reference)
(COND
(COLLECT/INSPECT? (push RESULT POINTERSOURCE)))
(COND
((AND (NOT ALLFLG)
(EQ REFCNT REFSFOUND))
(GO DONE]
DONE(COND
((AND COLLECT/INSPECT? (NEQ COLLECT/INSPECT? (QUOTE COLLECT)))
(INSPECT RESULT)
(SETQ RESULT NIL)))
(RETURN (OR RESULT REFSFOUND])
(\FINDPOINTERS.OF.TYPE
[LAMBDA (TYPE FILTER) (* bvm: "28-Jun-84 11:51")
(for (TAIL ←(\COLLECTINUSE TYPE)) while TAIL bind PTR (FILTERFNP ←(FNTYP FILTER))
declare (SPECVARS PTR) when [PROGN (SETQ PTR (pop TAIL))
(OR (NULL FILTER)
(COND
(FILTERFNP (APPLY* FILTER PTR))
(T (EVAL FILTER]
do (* This odd control structure so that we get rid of the
extra pointer from the list returned by \COLLECTINUSE)
(RECLAIM)
(RECLAIM)
(\FINDPOINTER (PRINT PTR T))
(TERPRI T])
(\FINDPOINTER.FOUND
[LAMBDA (BASE MSG) (* bvm: "20-Jan-84 16:22")
(\FINDPOINTER.NEWITEM NIL)
(COND
(MSG (printout T MSG)))
(printout T "at location " .I2.8 (\HILOC BASE)
(QUOTE ,)
.I6.8
(\LOLOC BASE)
T])
(\FINDPOINTER.NEWITEM
[LAMBDA (COUNTIT)
(DECLARE (USEDFREE MARGIN REFSFOUND)) (* bvm: "20-Jan-84 16:13")
(printout T .TAB0 MARGIN)
(IF COUNTIT
THEN (printout T (add REFSFOUND 1)
". "))
(printout T "Found ")
COUNTIT])
(\FINDPOINTER.LISTP
[LAMBDA (BASE ALLBACKFLG) (* bvm: " 3-Sep-85 14:48")
(DECLARE (USEDFREE REFSFOUND MARGIN))
(PROG ((PAGEBASE (fetch (POINTER PAGEBASE) of BASE))
(WORDOFFSET (fetch (POINTER WORDINPAGE) of BASE))
(NEWMARGIN MARGIN)
CDRCODE TYPE DESIREDCDRCODE)
(COND
((\FINDPOINTER.LISTP.FREE PAGEBASE WORDOFFSET)
(\FINDPOINTER.FOUND BASE "in freed list cell ")
(RETURN NIL)))
(SETQ DESIREDCDRCODE (LRSH WORDOFFSET 1))
LP (* Track this listp back on page)
(for I from 2 to (IDIFFERENCE WORDSPERPAGE WORDSPERCELL) by WORDSPERCELL
when (AND (EQ (LOGAND (SETQ CDRCODE (fetch (LISTP CDRCODE) of (\ADDBASE PAGEBASE I)))
177Q)
DESIREDCDRCODE)
(NOT (\FINDPOINTER.LISTP.FREE PAGEBASE I)))
do [OR TYPE (SETQ TYPE (COND
((IGREATERP CDRCODE \CDR.MAXINDIRECT)
(* CDR on page)
"an element")
(T (* CDR indirect on page)
"a tail"]
(SETQ BASE (\ADDBASE PAGEBASE I))
(SETQ DESIREDCDRCODE (LRSH I 1))
(GO LP))
(COND
((AND (NULL TYPE)
(EQ 0 (\GETBASEBYTE BASE 0)))
(* What we found was a full indirect cell pointing at a LISTP cell that (probably) someone told us to chase.
So just chase it explicitly now.)
(add REFSFOUND 1)
(GO SEARCHMORE))
[ALLBACKFLG (COND
((EQ (\REFCNT BASE)
1)
(add ALLBACKFLG 1)
(add REFSFOUND 1)
(printout T (QUOTE %.))
(GO SEARCHMORE))
(T (\FINDPOINTER.NEWITEM T)
(printout T "somewhere inside list "]
(T (\FINDPOINTER.NEWITEM T)
(printout T "as " (OR TYPE (QUOTE CAR))
" of list ")))
(LVLPRINT BASE T 1 3)
(TAB NEWMARGIN 0 T)
(SELECTQ (PROG1 [ASKUSER DWIMWAIT (QUOTE N)
"Shall I search for pointers to this list? "
(QUOTE ((Y "es")
(N "o")
(A "ll the way back"]
(TERPRI T))
(N (RETURN BASE))
(A (SETQ ALLBACKFLG 1))
NIL)
(add NEWMARGIN 3)
SEARCHMORE
(RETURN (COND
((NOT (SETQ TYPE (\FINDPOINTER BASE (QUOTE COLLECT)
NIL NEWMARGIN ALLBACKFLG)))
BASE)
((CDR TYPE)
TYPE)
(T (CAR TYPE])
(\FINDPOINTER.LISTP.FREE
[LAMBDA (PAGEBASE WORDOFFSET) (* bvm: "20-Jan-84 11:39")
(* True if the cell at WORDOFFSET after PAGEBASE is a
free list cell)
(for (FREE ←(fetch (CONSPAGE NEXTCELL) of PAGEBASE)) by (fetch (LISTP CDRCODE)
of (\ADDBASE PAGEBASE FREE))
as I to (fetch (CONSPAGE CNT) of PAGEBASE) thereis (EQ FREE WORDOFFSET])
(\FINDPOINTER.TYPE
[LAMBDA (BASE DTD) (* bvm: " 3-Jan-85 21:21")
(DECLARE (USEDFREE MARGIN COLLECT/INSPECT?))
(PROG ((SIZE (fetch DTDSIZE of DTD))
WORDINPAGEGROUP SEGMENTBASE VALIDPOINTERP FREEP ORIGIN OFFSET OBJECT TYPENAME DEC)
[COND
((.ALLOCATED.PER.PAGE. SIZE)
(SETQ WORDINPAGEGROUP (IMOD (\LOLOC BASE)
WORDSPERPAGE))
(SETQ SEGMENTBASE (FLOOR (\LOLOC BASE)
WORDSPERPAGE)))
(T (SETQ WORDINPAGEGROUP (IMOD (\LOLOC BASE)
\MDSIncrement))
(SETQ SEGMENTBASE (FLOOR (\LOLOC BASE)
\MDSIncrement]
(SETQ ORIGIN (ITIMES (IQUOTIENT WORDINPAGEGROUP SIZE)
SIZE))
(SETQ OBJECT (\VAG2 (\HILOC BASE)
(IPLUS SEGMENTBASE ORIGIN)))
(SETQ VALIDPOINTERP (MEMB (SETQ OFFSET (IDIFFERENCE WORDINPAGEGROUP ORIGIN))
(fetch DTDPTRS of DTD)))
(SETQ FREEP (\ISONFREELIST OBJECT))
(\FINDPOINTER.NEWITEM (AND VALIDPOINTERP (NOT FREEP)))
(printout T "at offset " .P2 OFFSET)
(COND
([SETQ DEC (OR [RECLOOK (SETQ TYPENAME (\VAG2 0 (fetch DTDNAME of DTD]
(find X in SYSTEMRECLST suchthat (EQ (CADR X)
TYPENAME]
(\FINDPOINTER.INTERPRET.RECORD DEC OFFSET)))
(COND
((NOT VALIDPOINTERP)
(printout T " (not a pointer field)")))
(printout T " in" (COND
(FREEP " freed ")
(T " "))
"object " OBJECT T)
(RETURN (COND
((AND VALIDPOINTERP (NOT FREEP))
(OR (SELECTQ (PROG1 [ASKUSER DWIMWAIT (QUOTE N)
"Shall I search for pointers to this object? "
(QUOTE ((Y "es")
(N "o")
(I "nspect it"]
(TERPRI T))
(Y (\FINDPOINTER OBJECT COLLECT/INSPECT? NIL (IPLUS MARGIN 3)))
(N NIL)
(PROGN (INSPECT OBJECT)
NIL))
OBJECT])
(\FINDPOINTER.INTERPRET.RECORD
[LAMBDA (DEC OFFSET) (* bvm: "28-Jun-84 12:05")
(* * Figures out the field name associated with word offset OFFSET in record declaration DEC.
Is simpleminded, gives up easily)
(for FIELD in (CADDR DEC) bind (N ← 0)
BITCOUNT
unless (EQ (CAR (LISTP FIELD))
(QUOTE *))
do (SELECTQ (COND
((LISTP FIELD)
(CADR FIELD))
(T (QUOTE POINTER)))
((XPOINTER POINTER FULLXPOINTER)
(COND
(BITCOUNT (COND
((OR (EQ (CADR FIELD)
(QUOTE FULLXPOINTER))
(IGREATERP BITCOUNT BITSPERBYTE))
(RETURN)))
(SETQ BITCOUNT NIL)))
(COND
((EQ N OFFSET)
(printout T " (" (OR (CAR (LISTP FIELD))
FIELD)
")")
(RETURN)))
(add N WORDSPERCELL))
(WORD [COND
(BITCOUNT (COND
((EQ BITCOUNT BITSPERWORD)
(SETQ BITCOUNT NIL)
(add N 1))
(T (RETURN]
(add N 1))
[BYTE (COND
((NOT BITCOUNT)
(SETQ BITCOUNT BITSPERBYTE))
((IGREATERP BITCOUNT BITSPERBYTE)
(RETURN))
(T (add N 1)
(SETQ BITCOUNT NIL]
[(FLAG BITS)
(SETQ BITCOUNT (IPLUS (OR BITCOUNT 0)
(OR (CADDR FIELD)
1]
(RETURN])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA SFL PFL)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS GCHAX COPYRIGHT ("Xerox Corporation" 3676Q 3677Q 3700Q 3701Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2440Q 17663Q (\MAPGC 2452Q . 5135Q) (\SHOWGC 5137Q . 10607Q) (\GCENTRIES.BY.TYPE 10611Q
. 15734Q) (\#COLLISIONS 15736Q . 16171Q) (\#OVERFLOWS 16173Q . 16424Q) (\GCSTATS.AUX 16426Q . 17661Q)
) (17664Q 26446Q (\PRINTFREELIST 17676Q . 23234Q) (\SHOWFREELISTS 23236Q . 23602Q) (\SCANFREELIST
23604Q . 25542Q) (\ISONFREELIST 25544Q . 26444Q)) (26447Q 45344Q (\COLLECTINUSE 26461Q . 33033Q) (
\SORTFREELIST 33035Q . 44125Q) (\SFLHASHLOOKUP 44127Q . 45342Q)) (45345Q 52760Q (\SHOWCIRCULARITY
45357Q . 46111Q) (\SHOWCIRCULARITY1 46113Q . 51340Q) (\SHOWCIRCULARLIST 51342Q . 52205Q) (
\SHOWCIRCULARPATH 52207Q . 52756Q)) (52761Q 55542Q (\SHOW.CLOSED.WINDOWS 52773Q . 54336Q) (
\WINDOW.ACCOUNTED.FOR? 54340Q . 55076Q) (PFL 55100Q . 55302Q) (SFL 55304Q . 55540Q)) (57777Q 107205Q (
\FINDPOINTER 60011Q . 67401Q) (\FINDPOINTERS.OF.TYPE 67403Q . 70644Q) (\FINDPOINTER.FOUND 70646Q .
71335Q) (\FINDPOINTER.NEWITEM 71337Q . 72016Q) (\FINDPOINTER.LISTP 72020Q . 77257Q) (
\FINDPOINTER.LISTP.FREE 77261Q . 100273Q) (\FINDPOINTER.TYPE 100275Q . 104454Q) (
\FINDPOINTER.INTERPRET.RECORD 104456Q . 107203Q)))))
STOP