(FILECREATED "19-Feb-84 16:29:16" {PHYLUM}<LISPCORE>LIBRARY>GCHAX.;14 30542
changes to: (FNS \FINDPOINTER \REFCNT)
(VARS GCHAXCOMS)
previous date: "18-Feb-84 13:55:28" {PHYLUM}<LISPCORE>LIBRARY>GCHAX.;13)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT GCHAXCOMS)
(RPAQQ GCHAXCOMS [(FNS \MAPGC \SHOWGC \GCENTRIES.BY.TYPE \#COLLISIONS \#OVERFLOWS \REFCNT
\GCSTATS.AUX)
(FNS \PRINTFREELIST \SHOWFREELISTS \SCANFREELIST \ISONFREELIST)
(FNS \COLLECTINUSE \SORTFREELIST \SFLHASHLOOKUP)
(FNS \SHOWCIRCULARITY \SHOWCIRCULARITY1 \SHOWCIRCULARLIST \SHOWCIRCULARPATH)
(FNS PFL SFL)
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS \COERCETOTYPENUMBER)
(RECORDS FREELISTENTRY HASHENTRY)
(FILES (LOADCOMP)
LLGC)
(LOCALVARS . T))
(P (PUTDQ? \GC.LOOKUP.BIGREFCNT [LAMBDA (PTR)
63]))
(FNS \FINDPOINTER \FINDPOINTER.FOUND \FINDPOINTER.NEWITEM \FINDPOINTER.LISTP
\FINDPOINTER.LISTP.FREE \FINDPOINTER.TYPE)
(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))
(* bvm: "14-Feb-84 12:06")
(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 (ZEROP (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))))
(\REFCNT
[LAMBDA (PTR) (* bvm: "19-Feb-84 16:01")
(PROG (ENTRY LINK CNT)
(COND
((OR (BITTEST (\GETBASE \MDSTypeTable (LRSH (fetch (POINTER PAGE#) of PTR)
1))
\TT.NOREF)
(\GCDISABLED)) (* PTR is not reference counted)
(RETURN 1)))
[CHECK (ZEROP (LOGAND 1 (\LOLOC PTR]
(SETQ ENTRY (\ADDBASE \HTMAIN (LRSH (\LOLOC PTR)
1)))
[COND
((fetch (GC EMPTY) of ENTRY)
(RETURN 1))
((fetch (GC LINKP) of ENTRY) (* chase down the link)
(GO FINDLINK))
((NEQ (\HILOC PTR)
(fetch (GC HIBITS) of ENTRY)) (* Doesn't match ptr in table, so no entry)
(RETURN 1))
((ILESSP (SETQ CNT (fetch (GC CNT) of ENTRY))
\MAXHTCNT)
(RETURN CNT))
(T (* Look in overflow table)
(RETURN (\GC.LOOKUP.BIGREFCNT PTR]
FINDLINK
(SETQ LINK (\ADDBASE \HTCOLL (fetch (GC LINKPTR) of ENTRY)))
LINKLOOP
[COND
((EQ (fetch (GC HIBITS) of LINK)
(\HILOC PTR)) (* found the link entry)
(RETURN (COND
((ILESSP (SETQ CNT (fetch (GC CNT) of LINK))
\MAXHTCNT)
CNT)
(T (\GC.LOOKUP.BIGREFCNT PTR]
(COND
((EQ (SETQ LINK (fetch NXTPTR of LINK))
0) (* Didn't find an entry on this chain)
(RETURN 1))
(T (SETQ LINK (\ADDBASE \HTCOLL LINK))
(GO LINKLOOP])
(\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: "20-Jan-84 16:01")
(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)
(OR HASHTABLE (RETURN))
(for MDSPAGE# from 0 to \MAXVMPAGE by 2
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]
(for DISP from 0 by SIZE as (BASE ←(create POINTER
PAGE# ← MDSPAGE#))
by (\ADDBASE BASE SIZE) while (ILEQ (IPLUS DISP SIZE)
\MDSIncrement)
when (OR (NOT FIRSTFREE)
(for (X ← FIRSTFREE) by (fetch FREELINK of X)
never (EQ X BASE) repeatuntil (EQ X LASTFREE)))
do (push RESULT BASE)))
(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) (* bvm: " 5-Dec-83 16:39")
(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))
((ZEROP (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
(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))))
)
[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)
)
)
(PUTDQ? \GC.LOOKUP.BIGREFCNT [LAMBDA (PTR)
63])
(DEFINEQ
(\FINDPOINTER
[LAMBDA (PTR COLLECT/INSPECT? ALLFLG MARGIN) (* bvm: "19-Feb-84 15:51")
(DECLARE (SPECVARS MARGIN REFSFOUND COLLECT/INSPECT?))
(OR MARGIN (SETQ MARGIN 0))
(PROG ((REFCNT (\REFCNT PTR))
[SAFESEGMENTS (AND (NOT ALLFLG)
(NCONC (for I from (\HILOC \PNCHARSSPACE) to (\HILOC \PNAMESPACEEND)
collect I)
(LIST (\HILOC \PNPSPACE)
(\HILOC \STACKSPACE)
(\HILOC \SMALLPOSPSPACE)
(\HILOC \SMALLNEGSPACE)
(\HILOC \AtomHashTable)
(\HILOC \PAGEMAP)
(\HILOC \PageMapTBL]
(REFSFOUND 0)
RESULT SEGBASE POINTERSOURCE)
(printout T .TAB0 MARGIN "Reference count = " .P2 REFCNT T)
(COND
((AND (ZEROP REFCNT)
(NOT ALLFLG))
(GO DONE)))
[for SEGMENT from 1 to \MAXVMSEGMENT unless (FMEMB SEGMENT SAFESEGMENTS)
do (SETQ SEGBASE (\VAG2 SEGMENT 0))
(for PAGEINSEG from 0 to (SUB1 PAGESPERSEGMENT) bind BASE TYPE DTD STR
unless (ZEROP (\LOOKUPPAGEMAP (IPLUS (UNFOLD SEGMENT PAGESPERSEGMENT)
PAGEINSEG)))
do (* Page exists)
(SETQ BASE (\VAG2 SEGMENT (UNFOLD PAGEINSEG WORDSPERPAGE)))
(SETQ TYPE (NTYPX BASE))
(COND
([OR (ZEROP TYPE)
(fetch DTDPTRS of (SETQ DTD (\GETDTD TYPE]
(to CELLSPERPAGE
do [COND
((EQ (\GETBASEPTR BASE 0)
PTR)
(COND
((SETQ POINTERSOURCE
(SELECTC TYPE
(0 (COND
((SETQ STR (COND
((EQ SEGBASE \VALSPACE)
"value")
((EQ SEGBASE \DEFSPACE)
"function definition")
((EQ SEGBASE \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))
(\FINDPOINTER.TYPE BASE DTD)))
(* Accounted for a valid reference)
(COND
(COLLECT/INSPECT? (push RESULT POINTERSOURCE)))
(COND
((AND (NOT ALLFLG)
(EQ REFCNT REFSFOUND))
(GO DONE]
(SETQ BASE (\ADDBASE BASE WORDSPERCELL]
DONE(COND
((AND COLLECT/INSPECT? (NEQ COLLECT/INSPECT? (QUOTE COLLECT)))
(INSPECT RESULT)
(SETQ RESULT NIL)))
(RETURN (OR RESULT REFSFOUND])
(\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) (* JonL "18-Feb-84 13:55")
(PROG ((PAGEBASE (fetch (POINTER PAGEBASE) of BASE))
(WORDOFFSET (fetch (POINTER WORDINPAGE) of BASE))
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)))
127)
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))
(\FINDPOINTER.NEWITEM T)
(printout T "as " (OR TYPE (QUOTE CAR))
" of list ")
(LVLPRIN2 BASE T 1 3)
(COND
((EQ (\REFCNT BASE)
63)
(printout T "," " whose reference count is 63" T))
(T (TERPRI T)))
(TAB MARGIN 0 T)
(RETURN (COND
((EQ (ASKUSER DWIMWAIT (QUOTE N)
"Shall I search for pointers to this list? ")
(QUOTE Y))
(COND
((NOT (SETQ TYPE (\FINDPOINTER BASE (QUOTE COLLECT)
NIL
(IPLUS MARGIN 3))))
BASE)
((CDR TYPE)
TYPE)
(T (CAR TYPE))))
(T BASE))))))
(\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: "20-Jan-84 16:26")
(PROG ((WORDINDOUBLEPAGE (MOD (\LOLOC BASE)
(ITIMES 2 WORDSPERPAGE)))
(SIZE (fetch DTDSIZE of DTD))
VALIDPOINTERP FREEP ORIGIN OFFSET OBJECT)
(SETQ ORIGIN (ITIMES (IQUOTIENT WORDINDOUBLEPAGE SIZE)
SIZE))
(SETQ OBJECT (\VAG2 (\HILOC BASE)
(IPLUS (FLOOR (\LOLOC BASE)
(ITIMES 2 WORDSPERPAGE))
ORIGIN)))
(SETQ VALIDPOINTERP (MEMB (SETQ OFFSET (IDIFFERENCE WORDINDOUBLEPAGE ORIGIN))
(fetch DTDPTRS of DTD)))
(SETQ FREEP (\ISONFREELIST OBJECT))
(\FINDPOINTER.NEWITEM (AND VALIDPOINTERP (NOT FREEP)))
(printout T "at offset " .P2 OFFSET)
(COND
((NOT VALIDPOINTERP)
(printout T " (not a pointer field)")))
(printout T " in" (COND
(FREEP " freed ")
(T " "))
"object " OBJECT T)
(RETURN (AND VALIDPOINTERP (NOT FREEP)
OBJECT])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA SFL PFL)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS GCHAX COPYRIGHT ("Xerox Corporation" 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1154 9397 (\MAPGC 1164 . 2495) (\SHOWGC 2497 . 4329) (\GCENTRIES.BY.TYPE 4331 . 6735) (
\#COLLISIONS 6737 . 6892) (\#OVERFLOWS 6894 . 7047) (\REFCNT 7049 . 8726) (\GCSTATS.AUX 8728 . 9395))
(9398 12840 (\PRINTFREELIST 9408 . 11166) (\SHOWFREELISTS 11168 . 11396) (\SCANFREELIST 11398 . 12388)
(\ISONFREELIST 12390 . 12838)) (12841 19678 (\COLLECTINUSE 12851 . 14419) (\SORTFREELIST 14421 .
19085) (\SFLHASHLOOKUP 19087 . 19676)) (19679 22506 (\SHOWCIRCULARITY 19689 . 20035) (
\SHOWCIRCULARITY1 20037 . 21722) (\SHOWCIRCULARLIST 21724 . 22143) (\SHOWCIRCULARPATH 22145 . 22504))
(22507 22807 (PFL 22517 . 22647) (SFL 22649 . 22805)) (23614 30317 (\FINDPOINTER 23624 . 26246) (
\FINDPOINTER.FOUND 26248 . 26559) (\FINDPOINTER.NEWITEM 26561 . 26864) (\FINDPOINTER.LISTP 26866 .
28725) (\FINDPOINTER.LISTP.FREE 28727 . 29249) (\FINDPOINTER.TYPE 29251 . 30315)))))
STOP