LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031672. :SYSTEM-TYPE :LOGICAL :VERSION 10. :TYPE "LISP" :NAME "MEMORY-DEBUG" :DIRECTORY ("REL3-SOURCE" "MEMORY-MANAGEMENT") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758728027. :AUTHOR "REL3" :LENGTH-IN-BYTES 74976. :LENGTH-IN-BLOCKS 74. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             ;;; -*- Mode:COMMON-LISP; Package:si;  Base:8. -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;; Copyright (C) 1986,1987 Texas Instruments Incorporated. All rights reserved.;;; This file contains a bunch of memory hacking routines.;;; Edit History;;;    Data    Patcher    Patch #  Description;;; -------------------------------------------------------------------;;;  11-20-86    ab                - Original, from pieces by rjf, ptm, ab;;;                                Made everything "safe" on bad addresses.;;;  12-01-86  ab for lgo   -      - Added LaMott's pointer-arithmetic macros.;;;  12-14-86    ab                - More bells and whistles.  The SCAN-MEMORY;;;                                routines basically work now.  Also started;;;                                on %structure-header-safe and;;;                                %structure-total-size-safe.;;;  01-26-87    ab                - Debugged %structure-header-safe and;;;                                %structure-total-size-safe.  They work now!;;;  02-05-87    ab                - Fixed LaMott's pointer-arithmetic macros;;;                                so they work! (They were just returning the;;;                                same thing that >, <, etc would return.);;;                                Also changed them all to 2-arg functions;;;                                rather than macros, and made them INLINEs.;;;                                Moved them to STORAGE-MACROS for #+elroy.;;;;;;;;;;;;;;;;;;;;;;;;; Vars ;;;#-elroy(DEFVAR DTP-Unused-31 31.)#-elroy(DEFVAR DTP-GC-Young-Pointer DTP-Free);; *all-immediate-types* plus *all-pointer-types* plus *all-index-types* should be everything.(DEFVAR *all-immediate-types*'(  ;; Immediate Lisp Types  DTP-Fix  DTP-Character  #+elroy DTP-Short-Float  #-elroy DTP-Small-Flonum    ;; Immediate hdr types  DTP-Array-Header  DTP-Header  #+elroy DTP-Function  #-elroy DTP-Fef-Header    ;; Misc  DTP-Trap  DTP-Free  #+elroy DTP-Ones-Trap  #-elroy DTP-Unused-31)  "All data types whose pointer fields contain just an immediate value (or whose pointerfields are meaningless).")(DEFVAR *all-index-types*'(  ;; Implied addressing.  DTP-U-Entry  DTP-Self-Ref-Pointer)  "All data types whose pointer fields contain a number to be used as some sort of index.")(DEFVAR *all-pointer-types*'(  ;; lisp ptr types  DTP-List  #+elroy DTP-Array  #-elroy DTP-Array-Pointer  DTP-Symbol  DTP-Instance  DTP-Locative  DTP-Extended-Number  DTP-Single-Float  #+elroy DTP-Function  #-elroy DTP-Fef-Pointer  DTP-Stack-Group  DTP-Closure  #+elroy DTP-Lexical-Closure  #-elroy DTP-Stack-Closure  #+elroy DTP-Stack-List  #-elroy DTP-Entity  #-elroy DTP-Select-Method    ;; forwarding types  DTP-One-Q-Forward  DTP-Header-Forward  DTP-Body-Forward  DTP-GC-Forward  DTP-External-Value-Cell-Pointer          DTP-GC-Young-Pointer  ;; unbound marker  DTP-Null  ;; pointer-header types  DTP-Instance-Header  DTP-Symbol-Header)  "All data types whose pointer fields contain a valid virtual memory address.");; Header types.  Can be immediate or ptr field.(DEFVAR *all-header-types*'(DTP-Array-Header   DTP-Header   DTP-Fef-Header   DTP-Instance-Header   DTP-Symbol-Header   DTP-Header-Forward))(DEFVAR *immediate-header-types*'(DTP-Array-Header   DTP-Header   DTP-Fef-Header))(DEFVAR *pointer-header-types*'(DTP-Instance-Header   DTP-Symbol-Header));; Lisp objects.  Immediate or ptr(DEFVAR *lisp-immediate-types*'(DTP-Fix   #+elroy DTP-Short-Float   #-elroy DTP-Small-Flonum   DTP-Character   DTP-U-Entry))(DEFVAR *lisp-pointer-types*'(DTP-Symbol   #+elroy DTP-Array   #-elroy DTP-Array-Pointer   DTP-Instance   DTP-List   DTP-Locative   DTP-Extended-Number   DTP-Single-Float   #+elroy DTP-Function   #-elroy DTP-Fef-Pointer   DTP-Stack-Group   DTP-Closure   #+elroy DTP-Lexical-Closure   #-elroy DTP-Stack-Closure   #+elroy DTP-Stack-List   #-elroy DTP-Entity   #-elroy DTP-Select-Method   ));; Housekeeping types(DEFVAR *forwarding-types*'(DTP-One-Q-Forward   DTP-Header-Forward   DTP-Body-Forward   DTP-GC-Forward   DTP-GC-Young-Pointer   DTP-External-Value-Cell-Pointer)  )(DEFVAR *misc-types*'(DTP-Self-Ref-Pointer))(DEFVAR *trap-types*'(DTP-Trap   #+elroy DTP-Ones-Trap   #-elroy DTP-Unused-31   DTP-Null))(DEFVAR *unused-types*'(DTP-Free  #-elroy DTP-Unused-31   ));; Other vars(DEFVAR *dtp-list-for-printing* nil)(DEFVAR *cdr-code-list-for-printing* '("<CDR-NORMAL>" "<CDR-ERROR>" "<CDR-NIL>" "<CDR-NEXT>"));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Misc fns;;;(DEFUN short-type-name (type-number &aux ans)  (COND ((OR (NOT (INTEGERP type-number))     (< type-number 0)     (> type-number (BYTE-MASK (BYTE (BYTE-SIZE %%Q-DATA-TYPE)     (BYTE-POSITION 0))))) (FERROR nil "~a is an invalid type number" type-number)) ((<= type-number (1- (LENGTH q-data-types)))  (SETQ ans (Q-DATA-TYPES type-number))) (t (SETQ ans (STRING-APPEND 'dtp-unused-     (FORMAT nil "~d" type-number)))))  (COND ((EQ ans 'dtp-external-value-cell-pointer) (SETQ ans "DTP-EVCP"))(t (SETQ ans (SUBSEQ (THE string (STRING ans)) 0))))  (SETQ ans (FORMAT nil "<~a>" ans))  ans)(DEFUN make-short-type-names (&aux l)  (DOTIMES (type (1+ (BYTE-MASK (BYTE (BYTE-SIZE %%Q-DATA-TYPE)      (BYTE-POSITION 0)))))    (PUSH-END (short-type-name type) l))  (SETQ *dtp-list-for-printing* l))(DEFUN dump-typed-q (q &key (base 8.))  (DECLARE (UNSPECIAL base))  (LET* ((*print-base* base) (*read-base* base) (cc (LDB %%Q-Cdr-Code q)) (dtp (LDB %%Q-Data-Type q)) (ptr (LDB %%Q-Pointer q)))        (UNLESS *dtp-list-for-printing* (make-short-type-names))    (FORMAT nil "<~[~;CDR-ERROR ~;CDR-NIL ~;CDR-NEXT ~]~a ~a>"    cc    (OR (NTH dtp q-data-types) 'dtp-unused)    ptr)    ))(DEFUN dump-q-as-string (q)  (LET* ((splat (INT-CHAR 0)) (char0 (INT-CHAR (LDB (BYTE 8. 0) q))) (char1 (INT-CHAR (LDB (BYTE 8. 8.) q))) (char2 (INT-CHAR (LDB (BYTE 8. 16.) q))) (char3 (INT-CHAR (LDB (BYTE 8. 24.) q))))        (FORMAT nil "~c ~c ~c ~c"    (IF (GRAPHIC-CHAR-P char0) char0 splat) (IF (GRAPHIC-CHAR-P char1) char1 splat)    (IF (GRAPHIC-CHAR-P char2) char2 splat) (IF (GRAPHIC-CHAR-P char3) char3 splat))    ));;; The Memory Dumper(DEFUN dump-memory (address-or-object &key (length 16.)                                   (base 8.)   (addr-or-obj)           (stream *standard-output*)                                   (bignum-is-dump-object nil))  "Dumps virtual memory in raw (numeric) format starting at ADDRESS-OR-OBJECT.  ADDRESS-OR-OBJECT can be an integer or an arbitrary object.  If it is aninteger (a bignum or a fixnum) it is used as a virtual memory address.  If it is an object, the object's pointer field is used as the address.  A check is done prior to dumping to assure that the resulting addressis valid virtual memory.  The memory display will be in the base supplied as the BASE keyword.  Thismust be 8, 10 or 16.  The LENGTH keyword specifies how many words to dump.  If this amountwould run into unallocated virtual memory it will be truncated to a safeamount and a warning will be issued.  When ADDRESS-OR-OBJECT is nil, the value of the ADDR-OR-OBJ keyword isused instead.   This allows you to be free of positional parameters.  Usually if ADDRESS-OR-OBJECT is a bignum it will be used as an address.However, you may actually want the memory containing the bignum dumped instead.In that case supply a non-NIL value for the BIGNUM-IS-DUMP-OBJECT keyword."  (DECLARE (UNSPECIAL base length))  (CHECK-ARG base (AND (INTEGERP base)       (OR (= base 8.) (= base 10.) (= base 16.)))     "A integer base number 8. 10. or 16.")  (LET (addr ptr reg page-addr arealast-allocated-addr free-ptrlast-addr-on-allocated-pagelast-addr-to-dumpdump-type)    ;; Housekeeping    (WHEN (NULL *dtp-list-for-printing*) (make-short-type-names))    (WHEN (NULL address-or-object) (SETQ address-or-object addr-or-obj))    (TERPRI)        ;; Perform concordance.    (COND ((INTEGERP address-or-object)   (COND (bignum-is-dump-object   (SETQ ptr (%POINTER address-or-object))  (SETQ addr (convert-to-unsigned ptr))) (t  (COND ((> (INTEGER-LENGTH address-or-object)    (BYTE-SIZE %%Q-POINTER)) (FORMAT stream "~%#o~o does not make sense as ~d-bit address." address-or-object (BYTE-SIZE %%Q-POINTER)) (RETURN-FROM dump-memory nil))(t (SETQ ptr (convert-to-signed address-or-object)) (SETQ addr (convert-to-unsigned address-or-object)))))))  (t   (SETQ ptr (%POINTER address-or-object))   (SETQ addr (convert-to-unsigned ptr))))    ;; Error checking.    ;; If the first word on PTR's page is valid (in allocated portion of some region)    ;; we can safely look at Qs in the whole page.  Otherwise, the address is illegal.    (SETQ reg (%REGION-NUMBER ptr)  page-addr (LOGAND ptr (- page-size)))    (UNLESS (NULL reg)      (SETQ free-ptr (convert-to-unsigned       (%POINTER-PLUS (AREF #'region-origin reg) (AREF #'region-free-pointer reg)))    last-allocated-addr (1- free-ptr)))    (COND ((a-memory-address-p ptr)   (SETQ dump-type "A-Memory"))  ((io-space-address-p ptr)   (SETQ dump-type "IO-Space"))  ((NULL reg)   (FORMAT stream "~%Address #o~o is not currently assigned to any region." addr)   (RETURN-FROM dump-memory nil))  ;; Can dump any address in a fixed-wired area  ((perm-wired-address-p ptr)   t)  ((NOT (pointer-valid-p page-addr))   (FORMAT stream "~%Address #o~o is assigned to region ~d. in area ~d. (~a),~                           ~%but no part of the page which contains it is before the region free pointer~                           ~%at #o~o."   addr reg (SETQ area (%AREA-NUMBER ptr)) (AREF #'AREA-NAME area) free-ptr)   (RETURN-FROM dump-memory nil))  ((NOT (pointer-valid-p ptr))   (FORMAT stream "~%Warning:  Address #o~o is assigned to region ~d. in area ~d. (~a)~                           ~%          but is beyond the region free pointer at #o~o.  However it is~                           ~%          on an assigned page so still can be be dumped."   addr reg (SETQ area (%AREA-NUMBER ptr)) (AREF #'AREA-NAME area) free-ptr)))    (SETQ last-addr-to-dump (convert-to-unsigned (%POINTER-PLUS ptr (1- length)))  last-addr-on-allocated-page (convert-to-unsigned(%POINTER-PLUS  (LOGAND (convert-to-signed last-allocated-addr)  (- page-size))  (1- page-size))))    (WHEN (AND (> last-addr-to-dump last-addr-on-allocated-page)       (NOT (perm-wired-address-p last-addr-to-dump)))      (FORMAT stream "~2%Warning:  Dump length of ~d. would go past end of the last allocated page in~                       ~%          region ~d. (origin #o~o, free-pointer #o~o, last-page-addr #o~o).~                       ~%          Truncating length to ~d."      length reg (convert-to-unsigned (AREF #'region-origin reg)) free-ptr last-addr-on-allocated-page      (SETQ length (- length (- last-addr-to-dump last-addr-on-allocated-page)))))    ;; OK, can now do dumping.    (UNLESS dump-type      (SETQ dump-type    (FORMAT nil "REGION ~a in AREA ~a (~a)"    reg (SETQ area (%AREA-NUMBER ptr)) (AREF #'AREA-NAME area))))    (FORMAT stream "~&~2%  ~a dump of ~a."     (SELECT base      (8.         "OCTAL")      (10.        "DECIMAL")      (16.        "HEX"))    dump-type)   (FORMAT     stream     "~2%     ADDRESS          VALUE            CDR-CODE                DATA-TYPE               POINTER     REVERSED ASCII~      ~2%  -------------  ----------------  -----------------  ----------------------------  -------------  --------------")      (DO ((target ptr (%POINTER-PLUS target 1))(count 0 (1+ count)))       ((>= count length))     (LET* ((target-addr (convert-to-unsigned target))    (cdr-code (%P-LDB %%Q-CDR-CODE target))    (cc-name (NTH cdr-code *cdr-code-list-for-printing*))    (dtp (%P-LDB %%Q-DATA-TYPE target))    (dtp-name (NTH dtp *dtp-list-for-printing*))    (pointer (convert-to-unsigned (%P-LDB %%Q-POINTER target)))    (word (DPB cdr-code %%Q-CDR-CODE       (DPB dtp %%Q-DATA-TYPE pointer)))            (char0   (INT-CHAR (LDB #o0010 word)))            (char1   (INT-CHAR (LDB #o1010 word)))            (char2   (INT-CHAR (LDB #o2010 word)))            (char3   (INT-CHAR (LDB #o3010 word)))    (splat   (INT-CHAR 0)))       (SELECT base (8.  (FORMAT stream "~%   ~:11,,o    ~:14,,o    ~1o  ~12a    ~2o  ~22a    ~:11,,o   "      target-addr word cdr-code cc-name dtp dtp-name pointer)) (10. (FORMAT stream "~%   ~:11,,d    ~:14,,d    ~1d  ~12a    ~2d  ~22a    ~:11,,d   "      target-addr word cdr-code cc-name dtp dtp-name pointer)) (16. (FORMAT stream "~%     ~8x        ~8x       ~1x  ~12a    ~2x   ~22a     ~8x    "      target-addr word cdr-code cc-name dtp dtp-name pointer)))       (FORMAT stream "   ~c ~c ~c ~c"       (IF (GRAPHIC-CHAR-P char0) char0 splat) (IF (GRAPHIC-CHAR-P char1) char1 splat)       (IF (GRAPHIC-CHAR-P char2) char2 splat) (IF (GRAPHIC-CHAR-P char3) char3 splat))))   ));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Misc "safe" subprimitives;;;(PROCLAIM '(inline %p-ldb-safe))(DEFUN %p-ldb-safe (ppss pointer)  "Just like %P-LDB except signals an error if POINTER is not valid virtual memory."  (DECLARE (inline pointer-valid-p))  (IF (pointer-valid-p pointer)      (%P-LDB ppss pointer)      (FERROR nil "Invalid virtual address ~a" pointer))  )(DEFUN %p-dpb-safe (value ppss pointer)  "Just like %P-DPB except signals an error if POINTER is not valid virtual memory."  (DECLARE (inline pointer-valid-p))  (IF (pointer-valid-p pointer)      (%P-DPB value ppss pointer)      (FERROR nil "Invalid virtual address ~a" pointer))  )(DEFUN %p-ldb-word (ptr)  "Returns the contents of the word at address PTR as a 32-bit number.PTR's data type is not checked, so this must be used with care."    (DPB (%P-LDB %%Q-High-Half ptr)       %%Q-High-Half       (%P-LDB %%Q-Low-Half ptr)))(PROCLAIM '(inline %follow-gc-forwarding))(DEFUN %follow-gc-forwarding (ptr)  "If address PTR is in OLDSPACE and GC-Forwarded, returns address of copiedobject in COPYSPACE; else returns PTR.  PTR itself must be valid, but %FOLLOW-GC-FORWARDING will signal an error if the forwarding address is not valid virtual memory."  (DECLARE (inline %p-ldb-safe))  (DO ((pointer ptr (%P-LDB %%Q-POINTER pointer)))      ((/= (%p-ldb-safe %%Q-DATA-TYPE pointer) DTP-GC-Forward) pointer))  )(PROCLAIM '(inline %follow-header-forwarding))(DEFUN %follow-header-forwarding (ptr)  "PTR must be the address of a word of type DTP-HEADER-FORWARD.  Returns theaddress of the actual object, following as many header-forwards as necessary.  PTR itself must be valid, but %FOLLOW-HEADER-FORWARDING will signal an error if the forwarding address is not valid virtual memory."  (DECLARE (inline %p-ldb-safe))  (DO ((pointer ptr (%P-LDB %%Q-POINTER pointer)))      ((/= (%p-ldb-safe %%Q-DATA-TYPE pointer) DTP-Header-Forward) pointer))  )(PROCLAIM '(inline %follow-gc-young-pointer))(DEFUN %follow-gc-young-pointer (ptr)  "PTR must be the address of a word of type DTP-GC-YOUNG-POINTER.  Returns theaddress of the actual object (in the INDIRECTION-CELL-AREA).    PTR itself must be valid, but %FOLLOW-GC-YOUNG-POINTER will signal an error if the forwarding address is not valid virtual memory."  (DECLARE (inline %p-ldb-safe))  (DO ((pointer ptr (%P-LDB %%Q-Pointer pointer)))      ((/= (%p-ldb-safe %%Q-Data-Type pointer) DTP-GC-Young-Pointer) pointer))  );;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Find Structure Header Safe;;;(DEFUN %FIND-STRUCTURE-HEADER-SAFE (PTR)  "%FIND-STRUCTURE-HEADER-SAFE is a safe version of %FIND-STRUCTURE-HEADER.  It is safebecause it parses storage in the forward direction in the region containing address PTR.  Two values are returned.  The first value is either the object containing addressPTR, if it is possible to return the object; or a fixnum giving the address of theobject's first (header) word; or NIL.  (In the case of an array with a leader, the arrayobject itself is returned rather than a locative to the leader.)  The second value is a flag.  If the flag is NIL, the object is in DYNAMIC space.If the flag is :OLD or :COPY, PTR was in OLDSPACE.  An address in OLDSPACE gives rise totwo possibilities:   1) The object is still in OLDSPACE (and may be garbage).  In this case the first valuewould be a fixnum address of the object's header since it cannot return the object itself,and the second value is :OLD.  2) PTR was in OLDSPACE, but the object containing it has already been copied out toCOPYSPACE.  In this case %FIND-STRUCTURE-LEADER-SAFE will return the object as its first value and a second value of :COPY.  If PTR is an invalid virtual address, NILs are returned."   (fs-safe-internal ptr nil))(DEFF fsh-safe '%find-structure-header-safe)(DEFUN %find-structure-leader-safe (ptr)  "%FIND-STRUCTURE-LEADER-SAFE is a safe version of %FIND-STRUCTURE-LEADER.  It is safebecause it parses storage in the forward direction in the region containing address PTR.  Two values are returned.  The first value is either the object containing addressPTR, if it is possible to return the object; or a fixnum giving the address of theobject's first (header) word; or NIL.  (In the case of an array with a leader, alocative to the leader is returned rather than the array.)  The second value is a flag.  If the flag is NIL, the object is in DYNAMIC space.If the flag is :OLD or :COPY, PTR was in OLDSPACE.  An address in OLDSPACE gives rise totwo possibilities:   1) The object is still in OLDSPACE (and may be garbage).  In this case the first valuewould be a fixnum address of the object's header since it cannot return the object itself,and the second value is :OLD.  2) PTR was in OLDSPACE, but the object containing it has already been copied out toCOPYSPACE.  In this case %FIND-STRUCTURE-LEADER-SAFE will return the object as its first value and a second value of :COPY.  If PTR is an invalid virtual address, NILs are returned."  (fs-safe-internal ptr t))(DEFF fsl-safe '%find-structure-leader-safe)(DEFUN fs-safe-internal (ptr &optional (leader nil))  ;; Validate address  (UNLESS (pointer-valid-p ptr)    (RETURN-FROM fs-safe-internal (VALUES nil nil)))  (WITHOUT-INTERRUPTS     (DO* ((reg (%REGION-NUMBER ptr))  (reg-fp (AREF #'region-free-pointer reg))  (size-parsed 0)                         ; incremented in loop    (va (AREF #'region-origin reg) next-ptr)  (fwd-va (%follow-gc-forwarding va)  ; May have to follow GC-Forwarding to get object's size  (%follow-gc-forwarding va))  (size (%STRUCTURE-TOTAL-SIZE fwd-va)(%STRUCTURE-TOTAL-SIZE fwd-va))  (next-ptr (%POINTER-PLUS va size)    (%POINTER-PLUS va size))) (())      (WHEN (AND (%pointer<= va ptr) (%pointer< ptr next-ptr));; We have found the containing object.(COND  ;; Not oldspace.  Return the object.  ((NOT (region-really-oldspace-p reg))   (RETURN (VALUES (IF leader       (%FIND-STRUCTURE-LEADER va)       (%FIND-STRUCTURE-HEADER va))   nil)))  ;; Oldspace.  If GC-Forwarded return object in copyspace  ((/= va fwd-va)   (RETURN (VALUES (IF leader       (%FIND-STRUCTURE-LEADER fwd-va)       (%FIND-STRUCTURE-HEADER fwd-va))   :copy)))  ;; Oldspace and not yet copied out.  Just return hdr address as fixnum.  (t   (RETURN (VALUES va :old)))))      (INCF size-parsed size)            ;; Shouldn't need this exit if POINTER-VALID-P returned non-NIL,      ;; but just in case...      (WHEN (>= size-parsed reg-fp)(RETURN (VALUES nil nil))))    ));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; %STRUCTURE-HEADER-SAFE;;;(DEFUN %get-array-leader-addr (array-hdr-addr)  "If the array at address ARRAY-HDR-ADDR has a leader, returns the leader'saddress as a first value; otherwise just returns ARRAY-HDR-ADDR.  Returns theleader lenth as a second value (0 if no leader)."  (DECLARE (VALUES hdr-or-leader-addr leader-length))  (UNLESS (= DTP-Array-Header (%P-LDB %%Q-Data-Type array-hdr-addr))    (FERROR nil "Array header address ~a does not contain ARRAY-HEADER." array-hdr-addr))  (IF (= 1 (%P-LDB %%Array-Leader-Bit array-hdr-addr))      (LET* ((leader-length (%P-LDB-OFFSET %%Q-Pointer array-hdr-addr -1))     (leader-addr (%POINTER-DIFFERENCE array-hdr-addr (+ 2 leader-length)))     (leader-dt (%p-ldb-safe %%Q-Data-Type leader-addr)))(IF (= DTP-Header leader-dt)    (VALUES leader-addr (+ 2 leader-length))    (FERROR nil "Invalid ARRAY-HEADER at ~a:  Can't find leader at ~a"    array-hdr-addr leader-addr)))      (VALUES array-hdr-addr 0))  )(DEFUN %get-array-header-addr (array-leader-addr &aux dt)  "If the object at address ARRAY-LEADER-ADDR is the leader of an array with leader,returns the array header address for the array as a first value.  Returns the leaderlenth as a second value (0 if no leader)."  (DECLARE (VALUES hdr-or-leader-addr leader-length))  (SETQ dt (%P-LDB %%Q-Data-Type array-leader-addr))  (COND ((= DTP-Header dt) (LET* ((leader-length (%P-LDB %%Header-Rest-Field array-leader-addr))(header-addr (%POINTER-PLUS array-leader-addr leader-length))(header-dt (%p-ldb-safe %%Q-Data-Type header-addr)))   (IF (= DTP-Array-Header header-dt)       (VALUES header-addr leader-length)       (FERROR nil "Invalid ARRAY-LEADER at ~a:  Can't find header at ~a"       array-leader-addr header-addr))))((= DTP-Array-Pointer dt) (VALUES array-leader-addr 0))(t (FERROR nil "Word at array-leader-addr ~a is neither an array nor an array leader."   array-leader-addr)))  )(DEFUN %structure-header-structure-region (header-ptr &optional (header-not-leader t)   &aux hdr-ptr data-type ht)  "HEADER-PTR must be a valid address in a non-OLDSPACE structure region.  Decodes the data type of the word at address HEADER-PTR, and returns the object of that type.Also returns a second value of T if the structure is structure-forwarded.  When HEADER-NOT-LEADER is T (the default), returns the array when given an array-leader address.  When HEADER-NOT-LEADER is nil, returns a locative to the leader.  Will signal an error if the word at address HEADER-PTR is not a valid header type."  (DECLARE (VALUES object structure-forward-flag))  (SETQ hdr-ptr (%follow-gc-young-pointer header-ptr)data-type (%P-LDB %%Q-Data-Type hdr-ptr))  (SELECT data-type    (DTP-Symbol-Header      (%MAKE-POINTER DTP-Symbol header-ptr))    (DTP-Array-Header     (LET ((has-leader (= 1 (%P-LDB %%Array-Leader-Bit header-ptr))))       (IF (OR header-not-leader (NOT has-leader))   ;; Either we just want the array (not the leader) or   ;; the array doesn't have a leader.   (%MAKE-POINTER (IF (= ART-STACK-GROUP-HEAD (LSH (%P-LDB %%Array-Type-Field header-ptr)      (- Array-Type-Shift)))      DTP-Stack-Group      DTP-Array-Pointer)  header-ptr)   ;; Array has a leader and we want a locative to it.   (%MAKE-POINTER dtp-locative (%get-array-leader-addr header-ptr)))))    (DTP-Header     (SELECT (SETQ ht (%P-LDB %%Header-Type-Field header-ptr))       (%Header-Type-Array-Leader(IF header-not-leader    (LET ((hdr-addr (%get-array-header-addr header-ptr)))      (%MAKE-POINTER (IF (= ART-STACK-GROUP-HEAD    (LSH (%P-LDB %%Array-Type-Field hdr-addr) (- Array-Type-Shift))) DTP-Stack-Group DTP-Array-Pointer)   hdr-addr))    (%MAKE-POINTER DTP-Locative Header-ptr)))       ((%Header-Type-Bignum %Header-Type-Complex     %Header-Type-Rational %Header-Type-Double-Float)(%MAKE-POINTER DTP-Extended-Number header-ptr))       (%Header-Type-Flonum (%MAKE-POINTER DTP-Single-Float header-ptr))       (:otherwise          (FERROR nil "Unexpected header type ~a encountered."    (OR (ELT q-header-types ht) ht)))))    (DTP-Fef-Header         (%MAKE-POINTER DTP-Fef-Pointer header-ptr))    (DTP-Instance-Header    (%MAKE-POINTER DTP-Instance header-ptr))    (DTP-Header-Forward     (LET ((obj (%structure-header-structure-region (%follow-header-forwarding hdr-ptr))))       (VALUES (%MAKE-POINTER (%DATA-TYPE obj) header-ptr) t)))    (DTP-Body-Forward     ;; Must be the body-forward of a forwarded array with leader.     (IF header-not-leader ;; Get header address from pointer field of BODY-FORWARD word. (LET* ((hdr-addr (%p-ldb-safe %%Q-Pointer hdr-ptr))(hdr-data-type (%p-ldb-safe %%Q-Data-Type hdr-addr)))   (UNLESS (= hdr-data-type DTP-Header-Forward)     (FERROR nil "Invalid BODY-FORWARD at ~a (does not point to HEADER-FORWARD." header-ptr))   (VALUES (%MAKE-POINTER dtp-array-pointer  (%P-LDB %%Q-Pointer header-ptr)) t)) ;; Just return locative to leader (VALUES (%MAKE-POINTER dtp-locative header-ptr) t)))    (:otherwise (FERROR nil "Data-type ~a is not a valid header type."(OR (Q-DATA-TYPES data-type) data-type))))  )(DEFUN %structure-header-list-region (start-ptr)  "START-PTR must be a valid address in a non-OLDSPACE list region.  Returns the liststartomg at that address, or signals an error if a valid list does not begin there.  Returns a second value of T if the list ends in a RPLACD-FORWARDED cons."  (DECLARE (VALUES object rplacd-forward-flag))  (LET* ((ptr (%follow-gc-young-pointer start-ptr)) (dtp (%P-LDB %%Q-Data-Type ptr)) (cc  (%P-LDB %%Q-Cdr-Code ptr)))    (IF (= dtp DTP-Header-Forward);; Rplacd-forwarded list.(LET* ((cons-addr (%P-LDB %%Q-Pointer ptr))       (cc (%p-ldb-safe %%Q-Cdr-Code (%follow-gc-young-pointer cons-addr))))  (IF (= cc CDR-Normal)      (VALUES (%MAKE-POINTER DTP-List start-ptr) t)      (FERROR nil "HEADER-FORWARD ~a in list space does not point to word with CDR-NORMAL" start-ptr)));; Not header-forwarded(SELECT cc  ((Cdr-Normal Cdr-Next Cdr-Nil)   (VALUES (%MAKE-POINTER dtp-list start-ptr) nil))  (Cdr-Error   (FERROR nil "Start-pointer ~a in list space points to word with CDR-ERROR" start-ptr)))))  )(DEFUN %structure-header-safe-internal (header-ptr &optional (header-not-leader t))  (DECLARE (VALUES object space-type-flag object-forwarded-flag))  (UNLESS (pointer-valid-p header-ptr)    (FERROR nil "Invalid virtual address ~a" header-ptr))  (LET* ((reg (%REGION-NUMBER header-ptr)) (oldsp (region-really-oldspace-p reg)) (gc-fwd (= DTP-GC-Forward (%P-LDB %%Q-Data-Type header-ptr))))        (COND      ((NOT oldsp)       (MULTIPLE-VALUE-BIND (obj flag)   (SELECT (region-representation-type (%REGION-NUMBER header-ptr))     (:structure (%structure-header-structure-region (%POINTER header-ptr) header-not-leader))     (:list (%structure-header-list-region (%POINTER header-ptr)))     (:otherwise (FERROR nil "Illegal region representation type"))) (VALUES obj nil header-ptr flag)))      (gc-fwd       (MULTIPLE-VALUE-BIND (obj ignore flag)   (%structure-header-safe-internal     (%follow-gc-forwarding header-ptr) header-not-leader) (VALUES obj :COPY header-ptr flag)))      (t (VALUES header-ptr :OLD header-ptr nil))))  )(DEFUN %structure-header-safe (header-ptr)  "Decodes the data type of the structure header or list CAR at address HEADER-PTR and returns the object of the object of that type.  Signals an error if the wordat address HEADER-PTR is not a valid header type.  Returns four values:   1) The first value is the object, if it can be returned.  The object cannotbe returned if HEADER-PTR points to an object in oldspace which has not yet beentransported.  In this case the HEADER-PTR (a fixnum) is returned as the first value.   2) The second value is a space type flag.  A value of :OLD indicates that HEADER-PTRis an object in oldspace which has not yet be transported, and indicates that a fixnumrather than the object was returned as the first value.  A value of :COPY indicatesthat HEADER-PTR was in oldspace, but has been transported to copyspace, and it is thecopyspace object that is being returned.  A value of NIL just indicates that the objectreturned is really at address HEADER-PTR.   3) The object's original address (= HEADER-PTR)   4) A flag which, if non-nil, indicates the object is structure forwarded (if a structure)or rplacd forwarded (if a list).  If the structure at HEADER-PTR is a leader of an array, returns the array as the firstvalue instead of a locative to the array leader.  This is a semi-safe subprimitive since it is Lisp-coded and does lots of error checkingbefore poking around virtual memory.  If you want something fast, use %FIND-STRUCTURE-HEADER."  (DECLARE (VALUES object space-type-flag object-forwarded-flag))  (%structure-header-safe-internal header-ptr t)  )(DEFUN %structure-leader-safe (header-or-leader-ptr)  "Decodes the data type of the structure header or list CAR at address HEADER-PTR and returns the object of the object of that type.  Signals an error if the wordat address HEADER-PTR is not a valid header type.     Returns three values:   1) The first value is the object, if it can be returned.  The object cannotbe returned if HEADER-PTR points to an object in oldspace which has not yet beentransported.  In this case the HEADER-PTR (a fixnum) is returned as the first value.   2) The second value is a space type flag.  A value of :OLD indicates that HEADER-PTRis an object in oldspace which has not yet be transported, and indicates that a fixnumrather than the object was returned as the first value.  A value of :COPY indicatesthat HEADER-PTR was in oldspace, but has been transported to copyspace, and it is thecopyspace object that is being returned.  A value of NIL just indicates that the objectreturned is really at address HEADER-PTR.   3) The object's original address (= HEADER-PTR)   4) A flag which, if non-nil, indicates the object is structure forwarded (if a structure)or rplacd forwarded (if a list).  If the structure at HEADER-PTR is an array with a leader, returns a locative to thearray leader as the first value instead of the array.  This is a semi-safe subprimitive since it is Lisp-coded and does lots of error checkingbefore poking around virtual memory.  If you want something fast, use %FIND-STRUCTURE-HEADER."  (DECLARE (VALUES object space-type-flag object-forwarded-flag))  (%structure-header-safe-internal header-or-leader-ptr nil)  );;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; %STRUCTURE-SIZE-SAFE;;;(DEFUN %structure-size-in-oldspace (oldspace-ptr region)  "Returns the number of contiguous words with type DTP-GC-FORWARD startingat address OLDSPACE-PTR in oldspace region REGION."  (LOOP WITH orig = (AREF #'region-origin region)WITH limit = (AREF #'region-free-pointer region)FOR ptr = oldspace-ptr THEN (%POINTER-PLUS ptr 1)FOR dtp = (%P-LDB %%Q-Data-Type ptr)FOR adr-offset = (%POINTER-DIFFERENCE ptr orig)FOR count = 0 THEN (1+ count)UNTIL (OR (/= dtp DTP-GC-Forward)  (>= adr-offset limit))FINALLY (RETURN count))  )(DEFUN convert-array-index-length-to-words (index-len ary-type)  "Given an array index length INDEX-LEN, and array type ARY-TYPE,returns two values: the number of data WORDS in the array, and aflag.  The flag is :BOXED if all elements are boxed data, and :UNBOXEDif they are unboxed data words."  (SELECT ary-type    ((ART-STRING ART-8B); 4 elems/Q, unboxed     (VALUES (CEILING index-len 4) :UNBOXED))    ((ART-Q ART-Q-LIST; 1 elem/Q,  boxed      ART-SPECIAL-PDL ART-REG-PDL; special rules for PDLs      ART-STACK-GROUP-HEAD ART-FIX)     (VALUES index-len :BOXED))    ((ART-16B ART-FAT-STRING ART-HALF-FIX); 2 elems/Q, unboxed     (VALUES (CEILING index-len 2) :UNBOXED))    ((ART-32B; 1 elem/Q,  unboxed       #+elroy ART-SINGLE-FLOAT       #-elroy ART-FPS-FLOAT)     (VALUES index-len :UNBOXED))    (ART-1B;32 elems/Q, unboxed     (VALUES (CEILING index-len 32.) :UNBOXED))    (ART-2B;16 elems/Q, unboxed     (VALUES (CEILING index-len 16.) :UNBOXED))    (ART-4B; 8 elems/Q, unboxed     (VALUES (CEILING index-len 8.) :UNBOXED))    (ART-COMPLEX; 2 Qs/elem, unboxed     (VALUES (* index-len 2) :UNBOXED))    #+elroy    ((ART-DOUBLE-FLOAT; 2 Qs/elem, unboxed       ART-COMPLEX-SINGLE-FLOAT)     (VALUES (* index-len 2) :UNBOXED))    #-elroy    ((ART-FLOAT ART-COMPLEX-FPS-FLOAT); 2 Qs/elem, unboxed      (VALUES (* index-len 2) :UNBOXED))    #+elroy    (ART-COMPLEX-DOUBLE-FLOAT; 4 Qs/elem, unboxed     (VALUES (* index-len 4) :UNBOXED))    #-elroy    (ART-COMPLEX-FLOAT; 4 Qs/elem, unboxed     (VALUES (* index-len 4) :UNBOXED))    (:otherwise (FERROR nil "Invalid array type ~a" ary-type)))  );;(DEFUN tst-array-size (len);;  (DOLIST (ty (CDR array-types));;    (FORMAT t "~%Type ~a, index-len, ~a, Qs ~a, el/Q ~a";;    ty len;;    (convert-array-index-length-to-words len (SYMBOL-VALUE ty));;    (ASSOC ty array-elements-per-q :test #'EQ))))(DEFUN %structure-size-array (ptr)  (LET* ((array-header (%P-LDB %%Q-Pointer ptr)) (simple-p (LDB-TEST %%Array-Simple-Bit array-header)) (ary-type (DPB (LDB %%Array-Type-Field array-header) %%Array-Type-Field 0)) (boxed-overhead 1); always a header (unboxed-overhead 0) index-len long-len number-dims overhead-only)    (COND (simple-p (SETQ index-len (LDB %%Array-Index-Length-If-Simple array-header)))  (t   (SETQ long-len (LDB %%Array-Long-Length-Flag array-header) index-len (IF (= 1 long-len)       (%p-ldb-safe %%Q-Pointer (%POINTER-PLUS ptr 1))       (LDB %%Array-Index-Length-If-Short array-header)) number-dims (LDB %%Array-Number-Dimensions array-header))   ;; Non-simple arrays will always have > 0 number of dimensions.   (IF (ZEROP number-dims)       (FERROR nil "Non-simple array at ~a has 0 dimensions." ptr))   ;; There is one overhead word for each dimension after 1.   ;; Also extra word if long length.   (INCF boxed-overhead (+ long-len (1- number-dims)))      ;; Displaced or physical.  Header index-len field contains # overhead words.   ;; These words only are the "size" of the array (no data portion).   ;; ALL physical arrays are displaced.   (WHEN (LDB-TEST %%Array-Displaced-Bit array-header)     (SETQ index-len (LDB %%Array-Index-Length-If-Short array-header))     (SETQ overhead-only t)     (SETQ boxed-overhead   (+ index-len (1- number-dims) long-len 1))     (WHEN (LDB-TEST %%Array-Physical-Bit array-header)       ;; A strange artifact of physical arrays is that the index-length-if-long       ;; word will come AFTER the displaced-to-physical-address word (which is a       ;; 32-bit number).  Because the 32-bit number is unboxed, and because we       ;; can only count as boxed those CONTIGUOUS boxed words, we have to count       ;; both the long-length fixnum word and the displaced-to-address word as       ;; "unboxed", which is a minor fib.       (DECF boxed-overhead (+ 1 long-len))       (INCF unboxed-overhead (+ 1 long-len))))))      (IF overhead-only(VALUES (+ boxed-overhead unboxed-overhead) boxed-overhead)(MULTIPLE-VALUE-BIND (words box-flag)    (convert-array-index-length-to-words index-len ary-type)  (IF (EQ box-flag :boxed)      (INCF boxed-overhead words)      (INCF unboxed-overhead words))   (VALUES (+ boxed-overhead unboxed-overhead)  boxed-overhead))))  )(DEFUN %structure-size-header (ptr include-leader &aux ht)  (SELECT (SETQ ht (%P-LDB %%Header-Type-Field ptr))    (%Header-Type-Array-Leader     (MULTIPLE-VALUE-BIND (header-addr leader-length) (%get-array-header-addr ptr)       (MULTIPLE-VALUE-BIND (total boxed)   (%structure-size-array header-addr) (IF include-leader     (VALUES (+ total leader-length) (+ boxed leader-length))     (VALUES total boxed)))))    (%Header-Type-Bignum     (VALUES (1+ (%P-LDB (BYTE 18. 0) ptr)) 1)); length from header = unboxed; hdr Q is boxed    ((%Header-Type-Complex %Header-Type-Rational)     (VALUES 3 3)); header and 2 nbr pointers, all boxed    (%Header-Type-Flonum     (VALUES 2 1)); boxed hdr and 1 unboxed Q    (%Header-Type-Double-Float     (VALUES 3 1)); boxed hdr and 2 unboxed Q    (:otherwise     (FERROR nil "Unexpected header type ~a encountered."     (OR (ELT q-header-types ht) ht))))  )(DEFUN %structure-size-instance-header (ptr)  (LET* ((instance-descriptor-ptr   (%p-ldb-safe %%Q-Pointer(%follow-gc-forwarding ptr))) (size (%p-ldb-safe %%Q-Pointer    (%POINTER-PLUS instance-descriptor-ptr   %Instance-Descriptor-Size))))    (VALUES size size))  )(DEFUN %structure-size-fef-header (ptr)  (LET* ((total (%P-LDB (BYTE 24. 0)(%POINTER-PLUS ptr       #+elroy %Fef-Storage-Length-Word       #-elroy %Fefhi-Storage-Length))) (boxed (%P-LDB #+elroy %%FEF-HEADER-Location-Counter-Offset#-elroy %%Fefh-Pc-In-Wordsptr)))    (VALUES total boxed))  )(DEFUN %structure-size-body-forward (ptr &optional (include-leader t))  (LET* ((hdr-fwd-addr (%P-LDB %%Q-Pointer ptr)) (hdr-fwd-dt (%p-ldb-safe %%Q-Data-Type hdr-fwd-addr)) (leader-len (%POINTER-DIFFERENCE hdr-fwd-addr ptr)))    (COND ((/= DTP-Header-Forward hdr-fwd-dt)   (FERROR nil "Invalid BODY-FORWARD at ~a: HEADER-FORWARD not found at ~a."ptr hdr-fwd-addr))  ((NOT (PLUSP leader-len))   (FERROR nil "Invalid BODY-FORWARD at ~a : Not in forwarded leader." ptr))  (t   (LET ((body-size (%structure-size-header-forward hdr-fwd-addr)))     (IF include-leader (LOOP FOR adr = ptr THEN (%POINTER-PLUS adr 1)       FOR fwd-adr = (%follow-gc-young-pointer adr)       FOR dt = (%p-ldb-safe %%Q-Data-Type fwd-adr)       FOR leader-words = 0 THEN (1+ leader-words)       UNTIL (/= DTP-Body-Forward dt)       FINALLY (RETURN (VALUES (+ leader-words body-size) (+ leader-words body-size) t))) (VALUES body-size body-size t))))))  )(DEFUN %structure-size-header-forward (ptr)  (LOOP FOR adr = (%POINTER-PLUS ptr 1) THEN (%POINTER-PLUS adr 1)FOR fwd-adr = (%follow-gc-young-pointer adr)FOR dt = (%p-ldb-safe %%Q-Data-Type fwd-adr)FOR body-words = 1 THEN (1+ body-words);count header-forward itself.UNTIL (/= DTP-Body-Forward dt)FINALLY (RETURN (VALUES body-words body-words t)))  )  (DEFUN %structure-size-structure-region (header-ptr &optional (include-leader t))  "HEADER-PTR must be a pointer to the header of a structure.Returns three values: the total size, the boxed size, and T if the structure is forwarded."  (DECLARE (VALUES total-size boxed-size structure-forward-flag))  (LET* ((hdr-ptr (%follow-gc-young-pointer header-ptr)) (dtp (%P-LDB %%Q-Data-Type hdr-ptr)))    (SELECT dtp      (DTP-Array-Header (MULTIPLE-VALUE-BIND (ignore leader-length)     (%get-array-leader-addr header-ptr)   (MULTIPLE-VALUE-BIND (total boxed)       (%structure-size-array header-ptr)     (IF include-leader (VALUES (+ total leader-length) (+ boxed leader-length)) (VALUES total boxed)))))      (DTP-Symbol-Header (VALUES 5. 5.)); easy case! 5 boxed Qs      (DTP-GC-Forward       (%structure-size-structure-region (%follow-gc-forwarding hdr-ptr) include-leader))      (DTP-Header       (%structure-size-header hdr-ptr include-leader))      (DTP-Fef-Header       (%structure-size-fef-header hdr-ptr))      (DTP-Instance-Header       (%structure-size-instance-header hdr-ptr))      (DTP-Body-Forward       ;; Must be body forward of a structure-forwarded array with leader.       (%structure-size-body-forward hdr-ptr include-leader))      (DTP-Header-Forward       ;; If here, guaranteed not to have leader (would have been caught by above).       (%structure-size-header-forward hdr-ptr))      (:otherwise (FERROR nil "Data-type ~a is not a valid header type."  (OR (Q-DATA-TYPES dtp) dtp))))  ))(DEFUN %structure-size-list-in-oldspace (oldspace-ptr region)    (LOOP WITH orig = (AREF #'region-origin region)WITH limit = (AREF #'region-free-pointer region)WITH init-fwd-ptr = (%POINTER-DIFFERENCE (%P-LDB %%Q-Pointer oldspace-ptr) 1)FOR ptr = oldspace-ptr THEN (%POINTER-PLUS ptr 1)FOR offset = (%POINTER-DIFFERENCE ptr orig)FOR dtp = (%P-LDB %%Q-Data-Type ptr)FOR last-fwd-ptr = init-fwd-ptr THEN fwd-ptrFOR fwd-ptr = (%P-LDB %%Q-Pointer ptr)FOR count = 0 THEN (1+ count)UNTIL (OR (/= (%POINTER-PLUS last-fwd-ptr 1) fwd-ptr)  (/= dtp DTP-GC-Forward)  (>= offset limit));;DO (FORMAT t "~%fwd-ptr ~o, last ~o" fwd-ptr last-fwd-ptr)FINALLY (RETURN count))  )(DEFUN %structure-size-list-region (ptr &optional (reg (%REGION-NUMBER ptr))                  (gc-fwd (= (%P-LDB %%Q-Data-Type ptr) DTP-GC-Forward)))  "PTR is a pointer to a list in region REG.  Returns three values: the total size,the boxed size (will = total size for lists), and T if the list ends in a RPLACD-FORWARD."  (DECLARE (VALUES total-size boxed-size rplacd-fwd-flag))  (COND (gc-fwd (LET ((tem (%structure-size-list-in-oldspace ptr reg)))   (VALUES tem tem nil)));; All Qs are boxed, and the size is the length of the CDR-CODED list(t (LOOP WITH count = 0      WITH orig = (AREF #'region-origin reg)      WITH limit = (AREF #'region-free-pointer reg)      FOR adr = ptr THEN (%POINTER-PLUS adr 1)      FOR fwd-adr = (%follow-gc-young-pointer adr)      FOR cdr-code = (%P-LDB %%Q-Cdr-Code fwd-adr)      FOR data-type = (%P-LDB %%Q-Data-Type fwd-adr)      FOR adr-offset = (%POINTER-DIFFERENCE adr orig)      DO      (WHEN (>= adr-offset limit)(FERROR nil "Valid list tail of list starting ~a not found before end of region." ptr))      (WHEN (= data-type DTP-Header-Forward);; Rplacd fwd ends list portion.;; Could check that ptr field pts to NORMAL-ERROR pair...(RETURN (INCF count) count t))      (SELECT cdr-code;; Could check that CDR-ERROR follows CDR-NORMAL...(cdr-normal (RETURN (INCF count 2) count nil))(cdr-next (INCF count) count nil)(cdr-nil (RETURN (INCF count) count nil))(cdr-error (FERROR nil "Unexpected CDR-ERROR encountered")))))))(DEFUN %structure-size-safe (structure-ptr &optional (include-leader t))  (LET* ((reg (%REGION-NUMBER structure-ptr)) (structure-ptr-in-oldspace (region-really-oldspace-p reg)) (ptr (%follow-gc-forwarding structure-ptr)) (ptr-reg (%REGION-NUMBER ptr)) (gc-fwd (NEQ reg ptr-reg)) (list-or-structure (region-representation-type reg)) space-type)    (WHEN (AND gc-fwd (region-really-oldspace-p ptr-reg))      ;; Shouldn't be in oldspace after following GC Forwarding.      (FERROR nil "Structure-pointer ~a is in OLDSPACE and is GC-FORWARDED to ~a in OLDSPACE."   structure-ptr ptr))    (SETQ space-type  (COND ((NOT structure-ptr-in-oldspace) nil)(gc-fwd :COPY)(t :OLD)))    (MULTIPLE-VALUE-BIND (total boxed fwd)(SELECT list-or-structure  (:structure (%structure-size-structure-region (%POINTER ptr) include-leader))  (:list (%structure-size-list-region (%POINTER structure-ptr) reg gc-fwd))  (:otherwise (FERROR nil "Illegal region representation type.")))      (VALUES total boxed space-type fwd)))  );;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; %FIND-STRUCTURE-HEADER-PARSING-BACKWARDS;;;;;;;;;;;  The idea here is to back up until the cdr-code is cdr-nil, meaning the end of;;;;  the preceding list, or cdr-error, meaning a full node from a preceding list.;;;;  Also, if we reach the beginning of the region, we're finished, because cdr-coded;;;;  lists are not consed across regions.  Once we reach the end, we return a list;;;;  pointer to the apparent first word of our list.;(defun fsh-safe-list (ptr origin);   (loop until (= ptr origin); as previous-data-type = (sys:%p-data-type (1- ptr)); when (= previous-data-type dtp-header-forward)       ; Forwarding pointer from a rplacd.; do (loop-finish); as previous-cdr-code = (sys:%p-cdr-code (1- ptr)); doing (select previous-cdr-code; ((cdr-normal cdr-next);  (decf ptr)); ((cdr-error cdr-nil);  (loop-finish))); finally (return (sys:%make-pointer sys:dtp-list ptr))));(defun fsh-safe-structure (ptr origin);   (loop until (< ptr origin); finally (return nil "Invalid structure:  header not found in region"); as data-type = (sys:%p-data-type ptr); doing (select data-type; ((sys:dtp-gc-forward sys:dtp-free si:dtp-unused-28); +++ Should be sys, someday.;  (return nil;  (format nil "Unexpected data type in find-structure-header:  ~A" data-type))); ((sys:dtp-header-forward sys:dtp-body-forward);  (return nil "Can't handle header-forwards or body-forwards yet");;      (multiple-value-bind (header reason);;  (transport-header (if (= data-type sys:dtp-header-forward);;ptr;;(sys:%p-pointer ptr)));;(if (null reason);;    (setq data-type (sys:%p-data-type header);;  ptr       header);;    (return nil reason)));  ); (sys:dtp-symbol-header;  (return (sys:%make-pointer sys:dtp-symbol ptr))); (sys:dtp-header;  (let ((header-type (sys:%p-ldb sys:%%header-type-field ptr)));    (select header-type;      ((sys:%header-type-error si:%header-unused-1 si:%header-type-unused-3); +++ Sys, someday.;       (return nil (format nil "Illegal header type:  ~A" header-type)));      ((sys:%header-type-complex sys:%header-type-bignum;        sys:%header-type-rational sys:%header-type-double-float);       (return (sys:%make-pointer sys:dtp-extended-number ptr)));      (sys:%header-type-array-leader;       (let ((offset (sys:%p-ldb sys:%%array-leader-length ptr))); (return (sys:%make-pointer-offset sys:dtp-array-pointer ptr offset))));      (si:%header-type-single-float; +++ Sys, someday.;       (return (sys:%make-pointer sys:dtp-single-float ptr)))))); (sys:dtp-array-header;  (let ((array-type (sys:%p-ldb sys:%%array-type-field ptr)));    (if (= array-type (lsh art-stack-group-head sys:array-type-shift));(return (sys:%make-pointer sys:dtp-stack-group ptr));(return (sys:%make-pointer si:dtp-array ptr))))); +++ Sys, someday.; (sys:dtp-instance-header;  (return (sys:%make-pointer sys:dtp-instance ptr))); (sys:dtp-fef-header;  (return (sys:%make-pointer si:dtp-function ptr))); +++ Sys, someday.; (otherwise;  nil)); doing (decf ptr))); Will only reach here if needs to loop around.;;;;;;;;  Simulate the microcode's transport-header.  This really should do something about;;;;  oldspace pointers, but I don't know how to do that without possibly chasing pointers;;;;  into illegal data types or invalid places.;(defun transport-header (ptr);   (loop as next-ptr = (sys:%p-pointer ptr); as next-type = (sys:%p-data-type ptr); doing (select next-type; ((sys:dtp-trap sys:dtp-gc-forward sys:dtp-external-value-cell-pointer sys:dtp-one-q-forward;   sys:dtp-self-ref-pointer sys:dtp-free sys:dtp-null); sys:dtp-ones-trap sys:dtp-unused-28;  (return nil (format nil "Illegal data type:  ~A" next-type))); (sys:dtp-body-forward;  (return nil "Don't know how to handle body-forwards yet in transport-header")); (sys:dtp-header-forward;  nil); Keep looping.; (otherwise;  (return next-ptr)))));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAP-OBJECTS & Friends;;;(DEFUN map-objects (start-addr &key (num-objects :all)    (analysis-function nil)    (analysis-function-args nil)    (start-function nil)    (stream *Standard-Output*)    (safe-for-oldspace-objects nil))  "Apply funcion ANALYSIS-FUNCTION to objects starting at address START-ADDR.  START-ADDR should be a fixnum.  If it is an invalid virtual memory address, an error is signalled.If START-ADDR is in the middle of an object (even an unboxed structure), the analysis will begin with the object containing START-ADDR.  The :NUM-OBJECTS keyword specifies the maximum number of objects to analyze.  It defaults to all the objects in the region containing START-ADDR.  :ANALYSIS-FUNCTION is a function that can be applied to each object.:ANALYSIS-FUNCTION-ARGS is a list of arguments to be supplied to theanalysis function.  The first 6 of these arguments will be bound to thefollowing information about the object:  OBJECT      The object itself, if the object is in dynamic space.  The object's              copyspace image if it has been transported to copyspace.  A fixnum              if it is an untransported oldspace object.  TOTAL-SIZE  The total size of the object (as if from %STRUCTURE-TOTAL-SIZE).  BOXED-SIZE  The boxed size of the object (as if from %STRUCTURE-BOXED-SIZE).  SPACE-FLAG  Indicates the space type where the object resides.  NIL means              in normal dynamic (safe) memory.  A non-NIL value means the              object was in oldspace (:OLD means it is still there, :COPY means              it is the transported copy in copyspace).  ORIG-ADDR   The object's original address, which will be the same as              (%POINTER obj) unless the SPACE-FLAG is :COPY.  FWD-FLAG    If non-NIL, indicates the object is structure-forwarded (if a              structure) or rplacd-forwarded (if a list).  Before beginning any object-mapping, the function specified as :START-FUNCTIONwill be called with the region number and the value of the :STREAM keyword as its arguments.  The :SAFE-FOR-OLDSPACE-OBJECTS keyword, if non-NIL, indicates that ANALYSIS-FUNCTION can safely be applied to objects in oldspace.  An exampleof a function that is unsafe for oldspace objects is PRINT.  The defaultis NIL."  (LET ((first-obj (%find-structure-leader-safe start-addr))reg)    (UNLESS (OR first-obj (< start-addr 5));don't neglect NIL!      (FERROR nil "~a is an invalid virtual address" start-addr))    (UNLESS (FUNCTIONP analysis-function)      (FERROR nil "~s is not a valid function spec"))    (SETQ reg (%REGION-NUMBER start-addr))    (WHEN (FUNCTIONP start-function)      (FUNCALL start-function reg stream))    (DO* ((orig (AREF #'region-origin reg))  (reg-fp (AREF #'region-free-pointer reg))  (parsed-size (%POINTER-DIFFERENCE first-obj orig))    (addr (%POINTER first-obj) next-addr)  (cnt 0 (1+ cnt))  next-addr tot-size boxed-size  obj space-type-flag orig-addr fwd-flag) (())      (WHEN (NUMBERP num-objects)  (IF (>= cnt num-objects) (RETURN cnt)))(MULTIPLE-VALUE-SETQ (tot-size boxed-size)    (%structure-size-safe addr t))(MULTIPLE-VALUE-SETQ (obj space-type-flag orig-addr fwd-flag)    (%structure-header-safe addr))(WHEN (OR (NULL space-type-flag)  safe-for-oldspace-objects)   (APPLY analysis-function obj tot-size boxed-size space-type-flag  orig-addr fwd-flag analysis-function-args))(SETQ next-addr (%POINTER-PLUS addr tot-size)      parsed-size (+ parsed-size tot-size))(WHEN (>= parsed-size reg-fp) (RETURN cnt))))  )(DEFUN map-objects-in-region (region &key (start-offset 0)                  (num-objects :all)  (analysis-function nil)  (analysis-function-args nil)  (stream *Standard-Output*)  (region-start-function nil)  (safe-for-oldspace-objects nil))  "Apply funcion ANALYSIS-FUNCTION to the objects in region REGION, starting atthe object nearest offset START-OFFSET into the region.  The value of the :START-OFFSET keyword does not have to be an object boundary.  If REGION is a it is an invalid region, an error is signalled.  The :NUM-OBJECTS keyword specifies the maximum number of objects to analyze.  It defaults to all the objects in the region.  :ANALYSIS-FUNCTION is a function that can be applied to each object.:ANALYSIS-FUNCTION-ARGS is a list of arguments to be supplied to theanalysis function.  The first 5 of these arguments will be bound to thefollowing information about the object:  OBJECT      The object itself, if the object is in dynamic space.  The object's              copyspace image if it has been transported to copyspace.  A fixnum              if it is an untransported oldspace object.  TOTAL-SIZE  The total size of the object (as if from %STRUCTURE-TOTAL-SIZE).  BOXED-SIZE  The boxed size of the object (as if from %STRUCTURE-BOXED-SIZE).  SPACE-FLAG  Indicates the space type where the object resides.  NIL means              in normal dynamic (safe) memory.  A non-NIL value means the              object was in oldspace (:OLD means it is still there, :COPY means              it is the transported copy in copyspace).  FWD-FLAG    If non-NIL, indicates the object is structure-forwarded (if a              structure) or rplacd-forwarded (if a list).  Whenever the analysis of a new region begins, the function specified as:REGION-START-FUNCTION will be called with REGION and the value of the :STREAM keyword as its arguments.  The :SAFE-FOR-OLDSPACE-OBJECTS keyword, if non-NIL, indicates that ANALYSIS-FUNCTION can safely be applied to objects in oldspace.  An exampleof a function that is unsafe for oldspace objects is PRINT.  The defaultis NIL."  (WHEN (region-free-p region)    (FERROR nil "Region ~a is a free region." region))  (LET ((addr (%POINTER-PLUS (AREF #'region-origin region) start-offset)))    (UNLESS (pointer-valid-p addr)      (FERROR nil "Offset ~a is not in the allocation portion of region ~a"      addr region))    (WHEN (FUNCTIONP region-start-function)      (FUNCALL region-start-function region stream))    (map-objects addr :num-objects num-objects :analysis-function analysis-function :analysis-function-args analysis-function-args :stream nil :safe-for-oldspace-objects safe-for-oldspace-objects))  )(DEFUN map-objects-in-area (&key (area-list :all)         (num-objects :all) (analysis-function nil) (analysis-function-args nil) (region-start-function nil) (stream *Standard-Output*) (safe-for-oldspace-objects nil))  "Apply funcion ANALYSIS-FUNCTION to the objects in all areas in AREA-LIST.The value of the :AREA-LIST keyword should be the keyword :ALL (indicatingall areas), a list of area numbers, or a list of area name symbols.  The :NUM-OBJECTS keyword specifies the maximum number of objects to analyze.  It defaults to all the objects in the areas.  :ANALYSIS-FUNCTION is a function that can be applied to each object.:ANALYSIS-FUNCTION-ARGS is a list of arguments to be supplied to theanalysis function.  The first 5 of these arguments will be bound to thefollowing information about the object:  OBJECT      The object itself, if the object is in dynamic space.  The object's              copyspace image if it has been transported to copyspace.  A fixnum              if it is an untransported oldspace object.  TOTAL-SIZE  The total size of the object (as if from %STRUCTURE-TOTAL-SIZE).  BOXED-SIZE  The boxed size of the object (as if from %STRUCTURE-BOXED-SIZE).  SPACE-FLAG  Indicates the space type where the object resides.  NIL means              in normal dynamic (safe) memory.  A non-NIL value means the              object was in oldspace (:OLD means it is still there, :COPY means              it is the transported copy in copyspace).  FWD-FLAG    If non-NIL, indicates the object is structure-forwarded (if a              structure) or rplacd-forwarded (if a list).  Whenever the analysis of a new region begins, the function specified as:REGION-START-FUNCTION will be called with the value of the :STREAM keywordas its only argument.  In addition, a brief header is displayed on STREAMat the start of a new area.  The :SAFE-FOR-OLDSPACE-OBJECTS keyword, if non-NIL, indicates that ANALYSIS-FUNCTION can safely be applied to objects in oldspace.  An exampleof a function that is unsafe for oldspace objects is PRINT.  The defaultis NIL."  (DECLARE (UNSPECIAL area-list))  (LET ((area-lst area-list))    (WHEN (EQ area-lst :ALL)      (LET ()(DECLARE (SPECIAL area-list))(SETQ area-lst (MEMBER first-non-fixed-area-name Area-List :test #'EQ))))    (LOOP FOR area IN area-lst  FOR area-number = (IF (NUMBERP area) area (SYMBOL-VALUE area))  FOR area-symbol = (IF (SYMBOLP area) area (AREF #'AREA-NAME area))  DO  (FORMAT stream "~2%AREA ~a (~a.)" area-symbol area-number)  (LOOP FOR region = (AREF #'area-region-list area-number) THEN (AREF #'region-list-thread region)UNTIL (MINUSP region)COUNTING(map-objects-in-region region       :num-objects num-objects       :analysis-function analysis-function       :analysis-function-args analysis-function-args       :region-start-function region-start-function       :safe-for-oldspace-objects safe-for-oldspace-objects       :stream stream)    INTO cntFINALLY (RETURN cnt))))  );;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; DUMP-OBJECTS and friends;;;(DEFUN dump-objects-hdr-function (region strm)  (FORMAT strm "~2%  REGION ~@4a (~a)" region (region-space-type region))  (FORMAT strm "~2%    Address      Size    Object ~                 ~%  -----------  --------  --------")  )(DEFUN dump-objects-obj-function (obj tot-size ignore space-flag orig-addr ignore  strm max-string-len)  (FORMAT strm "~%   ~@9,,a   ~@7,,a   "  (convert-to-unsigned orig-addr) tot-size)  (IF (EQ space-flag :OLD)      (FORMAT strm "~a" "*An untransported OLDSPACE object")      (FORMAT strm "~a~s"      (IF (EQ space-flag :COPY)  (FORMAT nil "~a~a~a"  "[ At " (convert-to-unsigned (%POINTER obj)) " in COPYSPACE ]: ")  "")      (IF (AND (STRINGP obj)       (NUMBERP max-string-len)       (> (LENGTH (THE string obj)) max-string-len))  (STRING-APPEND (SUBSEQ (THE string obj) 0 max-string-len) "...")  obj)))  )(DEFUN dump-objects (start-addr &key num-objects                     (max-print-length 3.)     (max-print-level 3.)      (max-string-length 50.)     (base 8.)     (stream *standard-output*))  "Start dumping objects at address START-ADDR.  START-ADDR should bea fixnum.  If it is an invalid virtual memory address, nothing will be dumped.  If START-ADDR is in the middle of a structure (even an unboxed structure), the dump will begin with the object containing START-ADDR.  The :NUM-OBJECTS keyword specifies the maximum number of objects to dump.  It defaults to all the objects in the region containing START-ADDR.  The :MAX-PRINT-LENGTH and :MAX-PRINT-LEVEL keywords can be used tocontrol the settings of the *PRINT-LENGTH* and *PRINT-LEVEL* variablesrespectively.  :MAX-STRING-LENGTH says how much of strings to print.  The address and size of each object is printed.   The :BASE keywordsays what base to do this in.  :STREAM specifies the stream for the output."  (DECLARE (UNSPECIAL base ignore))  (LET* ((*print-level* max-print-level) (*print-length* max-print-length) (*print-base* base) (*read-base* base) (strm (OR stream 'null-stream)) (start-fn #'dump-objects-hdr-function) (obj-fn #'dump-objects-obj-function))        (map-objects start-addr :num-objects num-objects :analysis-function obj-fn :analysis-function-args `(,strm ,max-string-length) :start-function start-fn :safe-for-oldspace-objects t))  )(DEFUN dump-objects-in-region (region &key (start-offset 0)                   (num-objects :all)                   (max-print-length 3.)   (max-print-level 3.)    (max-string-length 50.)   (base 8.)   (stream *standard-output*))  "Start dumping objects at offset START-OFFSET in region REGION.If region is an invalid (free) region, nothing will be dumped.  If START-OFFSET is in the middle of a structure (even an unboxed structure), the dump will begin with the object containing START-OFFSET.  The :NUM-OBJECTS keyword specifies the maximum number of objects to dump.  It defaults to all the objects in the region containing START-OFFSET.  The :MAX-PRINT-LENGTH and :MAX-PRINT-LEVEL keywords can be used tocontrol the settings of the *PRINT-LENGTH* and *PRINT-LEVEL* variablesrespectively.  :MAX-STRING-LENGTH says how much of strings to print.  The address and size of each object is printed.   The :BASE keywordsays what base to do this in.  :STREAM specifies the stream for the output."  (DECLARE (UNSPECIAL base))  (LET* ((*print-level* max-print-level) (*print-length* max-print-length) (*print-base* base) (*read-base* base) (strm (OR stream 'null-stream)) (reg-start-fn #'dump-objects-hdr-function) (obj-fn #'dump-objects-obj-function))        (map-objects-in-region region :start-offset start-offset   :num-objects num-objects   :analysis-function obj-fn   :analysis-function-args `(,strm ,max-string-length)   :region-start-function reg-start-fn   :safe-for-oldspace-objects t))  );;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WHO-POINTS-TO & other Memory Scanners;;;(DEFUN %scan-obj (scan-start scan-size target-start target-size  &optional follow-gcyp gc-forwarded)  (LOOP WITH pointer-field = nilFOR count = 0 THEN (1+ count)FOR obj-word = (%POINTER scan-start)    THEN (%POINTER-PLUS scan-start count)FOR scan-word = (IF follow-gcyp    (%follow-gc-young-pointer obj-word)    obj-word)FOR gcyp-forwarded = (/= obj-word scan-word)UNTIL (>= count scan-size)DO(SETQ pointer-field (%p-ldb-safe %%Q-Pointer scan-word))(LOOP FOR target-count = 0 THEN (1+ target-count)      FOR target-adr = (%POINTER target-start)          THEN (%POINTER-PLUS target-adr 1)      UNTIL (>= target-count target-size)      DO       (WHEN (AND (= pointer-field target-adr) (OR gc-forwarded     (MEMBER (Q-DATA-TYPES (%p-ldb-safe %%Q-Data-Type scan-word))     *all-pointer-types* :test #'EQ)))(RETURN-FROM %scan-obj (VALUES target-start gcyp-forwarded)))      FINALLY (RETURN nil))FINALLY (RETURN nil))  )(DEFUN who-points-to-obj-function (obj tot-size box-size sp-flag orig-addr fwd-flag   target-object target-scan-size stream follow-gcyp)  (MULTIPLE-VALUE-BIND (pointer-found ignore)      (%scan-obj obj (IF (EQ sp-flag :COPY)     tot-size     box-size) target-object target-scan-size follow-gcyp (IF (EQ sp-flag :COPY)     t nil))    (WHEN pointer-found      (LET ((*print-level* 3)    (*print-length* 5)    (max-string-len 30.))(FUNCALL #'dump-objects-obj-function obj tot-size box-size sp-flag orig-addr fwd-flag stream max-string-len))))  )(DEFUN who-points-to-in-region (object &key region            (stream *standard-output*)            (header-only t)            (oldspace-also nil)            (follow-gcyp nil))  (MULTIPLE-VALUE-BIND (ignore box)      (%structure-size-safe object)    (map-objects-in-region region :start-offset 0   :num-objects :all   :analysis-function #'who-points-to-obj-function   :analysis-function-args   `(,object ,(IF header-only 1 box) ,stream ,follow-gcyp)   :region-start-function #'dump-objects-hdr-function   :stream stream   :safe-for-oldspace-objects oldspace-also))  )   (DEFUN who-points-to (object &key (area-list :all)                  (stream *standard-output*)  (header-only t)  (oldspace-also nil)  (follow-gcyp nil))  (DECLARE (UNSPECIAL area-list))  (MULTIPLE-VALUE-BIND (ignore box)      (%structure-size-safe object)    (map-objects-in-area :area-list area-list :num-objects :all :analysis-function #'who-points-to-obj-function :analysis-function-args `(,object ,(IF header-only 1 box) ,stream ,follow-gcyp) :region-start-function #'dump-objects-hdr-function :stream stream :safe-for-oldspace-objects oldspace-also))  )(DEFVAR *words-searched* 0)(DEFUN scan-memory-for-value (value &key (area-list :all)         (byte-spec %%Q-DATA-TYPE) (stream *standard-output*))  (DECLARE (UNSPECIAL area-list))  (LET ((area-lst area-list))    (WHEN (EQ area-lst :ALL)      (LET ()(DECLARE (SPECIAL area-list))(SETQ area-lst (MEMBER first-non-fixed-area-name Area-List :test #'EQ))))    (LOOP FOR area IN area-lst  FOR area-number = (IF (NUMBERP area) area (SYMBOL-VALUE area))  FOR area-symbol = (IF (SYMBOLP area) area (AREF #'AREA-NAME area))  DO  (FORMAT stream "~2%AREA ~a (~a.)" area-symbol area-number)  (LOOP FOR region = (AREF #'area-region-list area-number) THEN (AREF #'region-list-thread region)UNTIL (MINUSP region)DO(LOOP FOR found-addr = (search-words-for-value (%POINTER-PLUS (AREF #'region-origin region) (AREF #'region-free-pointer region)) value byte-spec)          THEN (%POINTER-PLUS found-addr 1)      UNTIL (OR (NOT found-addr)(NOT (pointer-valid-p found-addr)))      DO (FORMAT stream "~%Address ~@9a" found-addr)))))  )(DEFUN search-words-for-value (start-address value       &optional (byte-spec %%Q-Pointer))    (LET* ((reg (%REGION-NUMBER start-address)) (reg-orig (AREF #'region-origin reg)) (reg-fp (AREF #'region-free-pointer reg)))        (UNLESS (AND reg (< (%POINTER-DIFFERENCE start-address reg-orig)reg-fp))    (RETURN-FROM search-words-for-value nil))        (DO* ((ptr start-address (%POINTER-PLUS ptr 1))  (len-so-far (%POINTER-DIFFERENCE ptr reg-orig)      (%POINTER-DIFFERENCE ptr reg-orig))) ((>= len-so-far reg-fp) nil)            (SETQ *words-searched* (1+ *words-searched*))      (COND ((= byte-spec %%Q-Pointer)     (WHEN (= (%P-LDB byte-spec (%follow-gc-young-pointer ptr)) value)       (RETURN ptr)))    ((AND (= byte-spec %%Q-Data-Type)  (/= value DTP-GC-Young-Pointer))     (WHEN (= (%P-LDB byte-spec (%follow-gc-young-pointer ptr)) value)       (RETURN ptr)))    (t (WHEN (= (%P-LDB byte-spec ptr) value) (RETURN ptr)))))    ));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; A-Memory Hacking;;;(DEFUN %write-a-memory-hi-low (offset hi low)  "Write to A-Memory at offet OFFSET.  The value written in the highpart of the word is HI, and that in the low part of the word is LOW."  (LET ((addr (%POINTER-PLUS a-memory-virtual-address offset)))    (%P-DPB hi %%Q-High-Half addr)    (%P-DPB low %%Q-Low-Half addr))  )(DEFUN %read-a-memory-hi-low (offset)  "Read the contents of A-Memory at OFFSET.  The contents arereturned in two values, the high and low halves of the 32-bit word,so no consing is done."  (LET ((addr (%POINTER-PLUS a-memory-virtual-address offset)))    (VALUES      (%P-LDB %%Q-High-Half addr)      (%P-LDB %%Q-Low-Half addr)))  )(DEFUN %read-a-memory (offset)  "Read the contents of the word at OFFSET into A-Memory and returnit as a 32-bit value."  (LET ((addr (%POINTER-PLUS a-memory-virtual-address offset)))    (DPB (%P-LDB %%Q-High-Half addr) %%Q-High-Half (%P-LDB %%Q-Low-Half addr))  ))(DEFUN %write-a-memory (offset value)  "Write the 32-bit value VALUE at the word OFFSET into A-Memory."  (LET ((addr (%POINTER-PLUS a-memory-virtual-address offset)))    (%P-DPB (LDB %%Q-High-Half value) %%Q-High-Half addr)    (%P-DPB (LDB %%Q-Low-Half value) %%Q-Low-Half addr))  )(DEFSETF %read-a-memory %write-a-memory)(DEFUN dump-a-memory (&key (start-offset 0)           (length 32.)   (all nil)   (base 8.))  "Dump the contents of A-Memory starting at :START-OFFSET for :LENGTH words.If the :ALL keyword is non-nil, the :LENGTH keyword is ignored and all of A-Memoryis dumped."  (DECLARE (UNSPECIAL base))  (WHEN all (SETQ length (%POINTER-DIFFERENCE -1 a-memory-virtual-address)))  (FORMAT t "~2%     Address          Value        Q-Representation~              ~%  -------------  ----------------  -------------------------------")  (DO* ((offset start-offset (1+ offset))(addr (convert-to-unsigned (%POINTER-PLUS a-memory-virtual-address offset))      (1+ addr))(val)(end-addr (convert-to-unsigned    (%POINTER-PLUS (MOD length (1+ (%POINTER-DIFFERENCE -1 a-memory-virtual-address)))   a-memory-virtual-address))))       ((>= addr end-addr))    (TERPRI)    (SELECT base      (8.  (FORMAT t "   ~:11,,o    ~14,,o   ~a"    addr (SETQ val (%read-a-memory offset)) (dump-typed-q val :base base)))      (10. (FORMAT t "   ~:11,,d    ~:14,,d   ~a"   addr (SETQ val (%read-a-memory offset)) (dump-typed-q val :base base)))      (16. (FORMAT t "     ~7,,x         ~8,,x      ~a"   addr (SETQ val (%read-a-memory offset)) (dump-typed-q val :base base)))      (t (FORMAT t "   ~@11,,a    ~@14,,a   ~a"  addr (SETQ val (%read-a-memory offset)) (dump-typed-q val :base base))))    ))(DEFUN search-a-memory (value &key (byte-spec (BYTE 32. 0))      (start-offset 0)      (length :all))  "Search A-Memory for a location containing VALUE in the bits specified bythe :BYTE-SPEC keyword.  The default for :BYTE-SPEC will compare the whole word.    The :START-OFFSET and :LENGTH keywords can be used to limit the search.  The OFFSET of the FIRST matching A-memory location (after :START-OFFSET) is returned.  To find additional locations, call this function again providing 1+ its previouslyreturned value for the :START-OFFSET, until it returne NIL."  (WHEN (EQ length :all)    (SETQ length (%POINTER-DIFFERENCE -1 a-memory-virtual-address)))   (DO* ((offset start-offset (1+ offset))(cnt 0 (1+ cnt)))       ((>= cnt length) nil)    (WHEN (= (LDB byte-spec (%read-a-memory offset))     value)      (RETURN offset))    ))(DEFUN dump-m-memory-q-storage (&key (base 8.))  "Prints out names and values for all M-Memory-Location-Names"  (DECLARE (UNSPECIAL base))  (LET ((*print-base* base)(*read-base* base)(MAX 0) tem)    (DOLIST (m-q m-memory-location-names max)      (WHEN (> (SETQ tem (LENGTH (THE string (SYMBOL-NAME m-q))))       max)(SETQ max tem)))    (DOLIST (m-q m-memory-location-names)      (FORMAT t "~%  ~vs  ~s" max m-q (SYMBOL-VALUE m-q)))    (VALUES)    ))(DEFF m-memory 'dump-m-memory-q-storage)(DEFUN dump-a-memory-q-storage (&key (base 8.))  "Prints out names and values for all A-Memory-Location-Names"  (DECLARE (UNSPECIAL base))  (LET ((*print-base* base)(*read-base* base)(max 0) tem)    (DOLIST (a-q a-memory-location-names max)      (WHEN (> (SETQ tem (LENGTH (THE string (SYMBOL-NAME a-q))))       max)(SETQ max tem)))    (DOLIST (a-q a-memory-location-names)      (FORMAT t "~%  ~vs  ~s" max a-q (SYMBOL-VALUE a-q)))    (VALUES)    ))(DEFF a-memory 'dump-a-memory-q-storage)(DEFUN dump-a-memory-counters (&key (base 8.))  "Prints out names and values for all A-Memory-Counter-Block-Names"  (DECLARE (UNSPECIAL base))  (LET ((*print-base* base)(*read-base* base)(max 0) tem)    (DOLIST (a-counter a-memory-counter-block-names max)      (WHEN (> (SETQ tem (LENGTH (THE string (SYMBOL-NAME a-counter))))       max)(SETQ max tem)))    (DOLIST (a-counter a-memory-counter-block-names)      (FORMAT t "~%  ~vs  ~@9a" max a-counter      (%read-a-memory (+ (SYMBOL-VALUE a-counter) %counter-block-a-mem-address))))    (VALUES)    ))(DEFF a-counters 'dump-a-memory-counters)(DEFUN dump-phys-mem-map ()  (LET ((map-addr (AREF #'system-communication-area %Sys-Com-Physical-Memory-Map))addr quanta phys-pg)    (FORMAT t "~2%A-Memory Physical Memory Map contents~%")    (DOTIMES (i A-Memory-Physical-Memory-Map-Words)      (SETQ addr (+ map-addr i))      (SETQ quanta (%P-LDB %%Phys-Mem-Map-2MB-Quantum addr))      (SETQ phys-pg (%P-LDB %%Physical-Page-Number addr))      (FORMAT t "~%A-Mem-Addr: ~7,,x,  Phys Pg #: ~6,,x  (Nubus Addr ~8,,x),  ~                 # Quanta: ~3,,x"      (convert-to-unsigned addr)      phys-pg (ASH phys-pg (BYTE-SIZE %%Physical-Page-Offset)) quanta))    ))(DEFUN dump-sca-words (&key (base 8.))  "Prints out names and values for all System-Communication-Area words"  (DECLARE (UNSPECIAL base))  (LET ((*print-base* base)(*read-base* base)(max 0) tem)    (DOLIST (sca-symbol System-Communication-Area-Qs)      (WHEN (> (SETQ tem (LENGTH (THE string (SYMBOL-NAME sca-symbol))))       max)(SETQ max tem)))    (DOLIST (sca-symbol System-Communication-Area-Qs)      (FORMAT t "~%  ~vs  (~2a):  ~a" max sca-symbol (SYMBOL-VALUE sca-symbol)      (LET* ((base-adr (AREF #'region-origin system-communication-area))     (ptr (%POINTER-PLUS base-adr (SYMBOL-VALUE sca-symbol)))     (dtp (%P-LDB %%Q-Data-Type ptr))     (dtp-symb #-elroy (OR (Q-DATA-TYPES dtp) 'DTP-Unused-31) #+elroy (Q-DATA-TYPES dtp)))(IF (OR (MEMBER dtp-symb *lisp-pointer-types* :test #'EQ)(MEMBER dtp-symb *lisp-immediate-types* :test #'EQ))    (AREF #'system-communication-area (SYMBOL-VALUE sca-symbol))    (dump-typed-q (%p-ldb-word ptr))))))    (VALUES)    ))(DEFF sca 'dump-sca-words);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Physical memory tests;;; (DEFUN physical-memory-test (&optional (times-to-read-each-word 1))  "Reads each physical memory word in the current memory configurationand reports memory errors.  The number of times each memory word is readcan be specified with the optional TIMES-TO-READ-EACH-WORD argument."  (DOTIMES (pfn (pages-of-physical-memory))    (LET* ((pg-adr (convert-pfn-to-physical-address pfn))   (slot (LDB %%Nubus-f-and-slot-bits pg-adr))   (offset (LDB %%nubus-all-but-f-and-slot-bits pg-adr)))      (DO ((wds 0 (1+ wds))   (nubus-offset offset (+ nubus-offset 4)))  ((>= wds page-size))(DOTIMES (i times-to-read-each-word)  (%NUBUS-READ slot nubus-offset)))))  );;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  Miscellaneous useful stuff;;;#+elroy(DEFVAR *ET-Pathname-Default* "SYS:UBIN;ELROY.TBL#>")#+elroy(DEFUN force-load-error-table (error-table-pathname)  "Force-loads and processes error table ERROR-TABLE-PATHNAME. ERROR-TABLE-PATHNAME defaults against *ET-Pathname-Default*.   Should only be used right before a disk save, since it alters the in-use error table."  (LET ((fs:*always-merge-type-and-version* nil)pathname)    (IF (NUMBERP error-table-pathname)(SETQ pathname (fs:merge-pathnames *ET-Pathname-Default*   nil error-table-pathname))(SETQ pathname (fs:merge-pathnames error-table-pathname   *ET-Pathname-Default*)))    (LOAD pathname :package 'EH)    (SETQ eh:*error-table-number* 0)    (eh:assure-table-processed))    ) (DEFUN hex (n)  (VALUES n (FORMAT nil "#x~x" n)))(DEFUN oct (n)  (VALUES n (FORMAT nil "#o~o" n)))(DEFUN dec (n)  (VALUES n (FORMAT nil "~d." n)))(DEFUN bin (n)  (VALUES n (FORMAT nil "~&#b~:b" n))) **2.See the documentation for COMPILE-FILE for the remaining arguments"*  (DECLARE (ARGLIST PATHNAME &KEY FORCE-DATE OUTPUT-FILE LOAD VERBOSE SET-DEFAULT-PATHNAME PACKAGE    DECLARE SUPPRESS-DEBUG-INFO))  (LET* ((USE-DATES-P (OR FORCE-DATE (IF (EQ COMPILER:*OUTPUT-VERSION-BEHAVIOR* :SAME) NIL T))) (COMPILE-PATHNAME (FS:MERGE-PATHNAME-DEFAULTS PATHNAME FS:LOAD-PATHNAME-DEFAULTS :LISP)) (LOAD-PATHNAME (FS:MERGE-PATHNAME-DEFAULTS (OR OUTPUT-FILE(SEND COMPILE-PATHNAME :NEW-PATHNAME      :TYPE (SI:LOCAL-BINARY-FILE-TYPE)))    COMPILE-PATHNAME    (SI:LOCAL-BINARY-FILE-TYPE))) (COMPILE-P (SIMPLE-FILE-NEWER-THAN-FILE-P COMPILE-PATHNAME LOAD-PATHNAME USE-DATES-P)))    (WHEN COMPILE-P       (COMPILE-FILE COMPILE-PATHNAME     :OUTPUT-FILE OUTPUT-FIL