;; -*- Mode:COMMON-LISP; Package:si; Base:8.; Cold-load: t; -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(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- 1989 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-14-86 ab - More bells and whistles. Started work ;;; 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! ;;; 05-11-87 ab - - Fixed DUMP-MEMORY for io-space and a-memory. ;;; Fixed FSH-SAFE for a-memory & m-memory ;;; q-storage addresses. Also fixed it for stack groups. ;;; Made FORCE-LOAD-ERROR-TABLE do better pathname ;;; defaulting. ;;; 07-09-87 ab Sys 44 - Above changes put in patch plus fixed structure- ;;; hacking routines for body-forward/header-forward in ;;; light of GCYPs. ;;; 07-24-87 ab Sys 52 - Add new routines %ADD-TO-SUPPORT-VECTOR and ;;; %FORWARD-NEW-REGISTER-SYMBOL for Prolog installation ;;; support (& for general hacking). ;;; 07-28-87 ab Sys 56 - Fixed %STRUCTURE-SIZE-ARRAY for PDLs. ;;; - Fixed %GET-ARRAY-LEADER-ADDR for funcallable hash tables. ;;; 01-12-88 JO - Fixed %structure-size-header-forward ;;; 01-12-88 ab - Added DUMP-PHYSICAL routine. ;;; 01-19-88 ab - - Change %ADD-TO-SUPPORT-VECTOR to make more flexible. ;;; Eliminate use of FILL-POINTER in support-entry-vector area ;;; to keep track of active entries. ;;; - Add COLD-LOAD attribute. ;;; 01-25-88 RJF - - Added a follow-gc-safe to %structure-size-instance-header ;;; in case the instance header was pointing to oldspace ;;; or train space. ;;; 01-25-88 RJF _ Fixed map-atoms, %structure-header-safe-internal, fs-safe-internal ;;; to work with train space. ;;; 05-26-88 RJF - Changed fs-safe-internal to call %structure-size-safe with ;;; original object even if gc-forwarded. %Structure-size-safe ;;; does the right thing for rplacd'ed lists. ;;; 09-15-88 RJF - Fixed a problem with train space pointers getting in the ;;; machine. [spr 8720] ;;; 04/19/89 RJF - Removed elroy conditionals. ;;; 04/20/89 RJF - Fixed %structure-header-safe-internal, fs-safe-internal, ;;; %structure-size-safe, and map-objects functions to work with ;;; train-a, entry, and oldspace-a region types ;;;;;;;;;;;;;;;;;;; ;;; ;;; Vars ;;; ;; *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 DTP-Short-Float ;; Immediate hdr types DTP-Array-Header DTP-Header DTP-Fef-Header ;; Misc DTP-Trap DTP-Free DTP-Ones-Trap) "All data types whose pointer fields contain just an immediate value (or whose pointer fields 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 DTP-Array DTP-Symbol DTP-Instance DTP-Locative DTP-Extended-Number DTP-Single-Float DTP-Function DTP-Stack-Group DTP-Closure DTP-Lexical-Closure DTP-Stack-List ;; 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 DTP-Short-Float DTP-Character DTP-U-Entry)) (DEFVAR *lisp-pointer-types* '(DTP-Symbol DTP-Array DTP-Instance DTP-List DTP-Locative DTP-Extended-Number DTP-Single-Float DTP-Function DTP-Stack-Group DTP-Closure DTP-Lexical-Closure DTP-Stack-List )) ;; 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 DTP-Ones-Trap DTP-Null)) (DEFVAR *unused-types* '(DTP-Free )) ;; Other vars (DEFVAR *dtp-list-for-printing* nil) (DEFVAR *cdr-code-list-for-printing* '("" "" "" "")) ;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; 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 Dumpers ;;; (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 an integer (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 address is valid virtual memory. The memory display will be in the base supplied as the BASE keyword. This must be 8, 10 or 16. The LENGTH keyword specifies how many words to dump. If this amount would run into unallocated virtual memory it will be truncated to a safe amount and a warning will be issued. When ADDRESS-OR-OBJECT is nil, the value of the ADDR-OR-OBJ keyword is used 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 area last-allocated-addr free-ptr last-addr-on-allocated-page last-addr-to-dump dump-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))) (IF (NULL reg) (SETQ free-ptr (1+ (convert-to-unsigned -1)) last-allocated-addr (convert-to-unsigned -1)) (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." (CASE 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))) (CASE 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)))) )) (DEFUN dump-physical (adr &key (length 16.) (base 16.) (stream *standard-output*)) "Dumps physical memory starting at NuBus address ADR for LENGTH words in base BASE." (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.") (UNLESS *dtp-list-for-printing* (make-short-type-names)) (FORMAT stream "~2% ADDRESS VALUE CDR-CODE DATA-TYPE POINTER ASCII~ ~2% ------------- ---------------- ----------------- ---------------------------- ------------- --------------") (DO ((target adr (+ target 4.)) (count 0 (1+ count))) ((>= count length)) (LET* ((target-addr target) (target-slot (LDB %%Nubus-F-and-Slot-Bits target)) (target-offset (LDB %%Nubus-All-But-F-And-Slot-Bits target)) (byte0 (%Nubus-Read-8b-Careful target-slot target-offset)) (byte1 (%Nubus-Read-8b-Careful target-slot (1+ target-offset))) (byte2 (%Nubus-Read-8b-Careful target-slot (+ 2 target-offset))) (byte3 (%Nubus-Read-8b-Careful target-slot (+ 3 target-offset))) char0 char1 char2 char3 splat cc-name cdr-code dtp dtp-name pointer word) (COND ((NOT (AND (NUMBERP byte0) (NUMBERP byte1) (NUMBERP byte2) (NUMBERP byte3))) (CASE base (8. (FORMAT stream "~% ~:11,,o NuBus Error or Timeout" target-addr)) (10. (FORMAT stream "~% ~:11,,d NuBus Error or Timeout" target-addr)) (16. (FORMAT stream "~% ~8x NuBus Error or Timeout" target-addr)))) (t (SETQ word (DPB byte3 (BYTE 8. 24.) (DPB byte2 (BYTE 8. 16.) (DPB byte1 (BYTE 8. 8.) byte0)))) (SETQ cdr-code (LDB %%Q-CDR-CODE word)) (SETQ cc-name (NTH cdr-code *cdr-code-list-for-printing*)) (SETQ dtp (LDB %%Q-DATA-TYPE word)) (SETQ dtp-name (NTH dtp *dtp-list-for-printing*)) (SETQ pointer (convert-to-unsigned (LDB %%Q-POINTER word))) (SETQ char0 (INT-CHAR (LDB #o0010 word))) (SETQ char1 (INT-CHAR (LDB #o1010 word))) (SETQ char2 (INT-CHAR (LDB #o2010 word))) (SETQ char3 (INT-CHAR (LDB #o3010 word))) (SETQ splat (INT-CHAR 0)) (CASE 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 "~% ~8,'0,x ~2,'0,x ~2,'0,x ~2,'0,x ~2,'0,x ~1x ~12a ~ ~2x ~22a ~8x " target-addr byte3 byte2 byte1 byte0 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 copied object 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 the address 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 the address 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 safe because it parses storage in the forward direction in the region containing address PTR. Three values are returned. The first value is either the object containing address PTR, if it is possible to return the object; or a fixnum giving the address of the object's first (header) word; or NIL. (In the case of an array with a leader, the array object itself is returned rather than a locative to the leader.) The second value is the address of the object. If the object is in oldspace, then this is the address in oldspace even if the object has been copied. If the object is in train-space, then this is the address in train-space even if the object has now been copied out. The third value is a flag. If the flag is NIL, the object is in DYNAMIC space. If the flag is :TRAIN, then the object is in train space. If the flag is :ENTRY, :OLD-A or :TRAIN-A, then it is in one of the special Extended-Address-Space regions. If the flag is :OLD or :COPY, PTR was in OLDSPACE. An address in OLDSPACE gives rise to two possibilities: 1) The object is still in OLDSPACE (and may be garbage). In this case the first value would be a fixnum address of the object's header since it cannot return the object itself, and the third value is :OLD. 2) PTR was in OLDSPACE, but the object containing it has already been copied out to COPYSPACE. In this case %FIND-STRUCTURE-LEADER-SAFE will return the object as its first value and a third 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 safe because it parses storage in the forward direction in the region containing address PTR. Three values are returned. The first value is either the object containing address PTR, if it is possible to return the object; or a fixnum giving the address of the object's first (header) word; or NIL. (In the case of an array with a leader, a locative to the leader is returned rather than the array.) The second value is the address of the object. If the object is in oldspace, then this is the address in oldspace even if the object has been copied. If the object is in train-space, then this is the address in train-space even if the object has now been copied out. The third value is a flag. If the flag is NIL, the object is in DYNAMIC space. If the flag is :TRAIN, then the object is in train space. If the flag is :ENTRY, :OLD-A or :TRAIN-A, then it is in one of the special Extended-Address-Space regions. If the flag is :OLD or :COPY, PTR was in OLDSPACE. An address in OLDSPACE gives rise to two possibilities: 1) The object is still in OLDSPACE (and may be garbage). In this case the first value would be a fixnum address of the object's header since it cannot return the object itself, and the third value is :OLD. 2) PTR was in OLDSPACE, but the object containing it has already been copied out to COPYSPACE. In this case %FIND-STRUCTURE-LEADER-SAFE will return the object as its first value and a third 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) &aux reg) ;; Validate address (UNLESS (pointer-valid-p ptr) (RETURN-FROM fs-safe-internal (VALUES nil nil nil))) (SETQ reg (%region-number ptr)) (WHEN (NULL reg) (RETURN-FROM fs-safe-internal (VALUES (q-storage-symbol ptr) ptr :a-memory))) (Cond ((region-train-a-p reg) (RETURN-FROM fs-safe-internal (VALUES nil nil :train-a))) ((region-oldspace-a-p reg) (RETURN-FROM fs-safe-internal (VALUES nil nil :old-a))) ((region-entry-p reg) (RETURN-FROM fs-safe-internal (VALUES nil nil :entry)))) (WITHOUT-INTERRUPTS (DO* ((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-size-safe va) (%structure-size-safe 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 ;; Train space ((region-train-p reg) (RETURN (VALUES (IF leader (%structure-leader-safe va) (%structure-header-safe va)) Va :train))) ;; Not oldspace. Return the object. ((NOT (region-really-oldspace-p reg)) (RETURN (VALUES (IF leader (%structure-leader-safe va) (%structure-header-safe va)) Va Nil))) ;; Oldspace. If GC-Forwarded return object in copyspace ((/= va fwd-va) (RETURN (VALUES (IF leader (%structure-leader-safe fwd-va) (%structure-header-safe fwd-va)) va :copy))) ;; Oldspace and not yet copied out. Just return hdr address as fixnum. (t (RETURN (VALUES va 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 nil)))) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; %STRUCTURE-HEADER-SAFE ;;; ;;AB 7-28-87. Fix to load only 18 bits as # leader elements in word at (1- hdr address). ;; Otherwise funcallable hash tables look like they have huge leaders. (DEFUN %get-array-leader-addr (array-hdr-addr) "If the array at address ARRAY-HDR-ADDR has a leader, returns the leader's address as a first value; otherwise just returns ARRAY-HDR-ADDR. Returns the leader 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 (LDB %%ARRAY-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 leader lenth 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))) ) (defvar Obj nil) ;;; By storing it and then retrieving it, we get a non-train space pointer. (Defun %MAKE-POINTER-NOT-TRAIN-SPACE (datatype header-ptr) (progn (setq Obj (%make-pointer datatype header-ptr)) obj)) (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-NOT-TRAIN-SPACE 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-NOT-TRAIN-SPACE (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-NOT-TRAIN-SPACE 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-NOT-TRAIN-SPACE (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-NOT-TRAIN-SPACE DTP-Locative Header-ptr))) ((%Header-Type-Bignum %Header-Type-Complex %Header-Type-Rational %Header-Type-Double-Float) (%MAKE-POINTER-NOT-TRAIN-SPACE DTP-Extended-Number header-ptr)) (%Header-Type-Flonum (%MAKE-POINTER-NOT-TRAIN-SPACE 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-NOT-TRAIN-SPACE DTP-Fef-Pointer header-ptr)) (DTP-Instance-Header (%MAKE-POINTER-NOT-TRAIN-SPACE DTP-Instance header-ptr)) (DTP-Header-Forward (LET ((obj (%structure-header-structure-region (%follow-header-forwarding hdr-ptr)))) (VALUES (%MAKE-POINTER-NOT-TRAIN-SPACE (%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 (%follow-gc-young-pointer 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-NOT-TRAIN-SPACE dtp-array-pointer (%P-LDB %%Q-Pointer header-ptr)) t)) ;; Just return locative to leader (VALUES (%MAKE-POINTER-NOT-TRAIN-SPACE 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 list startomg 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-NOT-TRAIN-SPACE 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-NOT-TRAIN-SPACE 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))) (COND ((region-train-a-p reg) (VALUES header-ptr :train-a header-ptr nil)) ((region-oldspace-a-p reg) (VALUES header-ptr :old-a header-ptr nil)) ((region-entry-p reg) (VALUES header-ptr :entry header-ptr nil)) (T (LET ((oldsp (region-really-oldspace-p reg)) (gc-fwd (= DTP-GC-Forward (%P-LDB %%Q-Data-Type header-ptr)))) (DECLARE (UNSPECIAL oldsp)) (COND ((and (region-train-p reg) (not gc-fwd)) (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 :train header-ptr flag))) ((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 word at 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 cannot be returned if HEADER-PTR points to an object in oldspace which has not yet been transported. 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-PTR is an object in oldspace which has not yet be transported, and indicates that a fixnum rather than the object was returned as the first value. A value of :COPY indicates that HEADER-PTR was in oldspace or train-space, but has been transported to copyspace or newspace, and it is the copyspace or newspace object that is being returned. A value of :TRAIN indicates that HEADER-PTR is an object in train-space, which has not been copied out. If the flag is :ENTRY, :OLD-A or :TRAIN-A, then it is in one of the special Extended-Address-Space regions. A value of NIL just indicates that the object returned 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 first value instead of a locative to the array leader. This is a semi-safe subprimitive since it is Lisp-coded and does lots of error checking before 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 word at 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 cannot be returned if HEADER-PTR points to an object in oldspace which has not yet been transported. 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-PTR is an object in oldspace which has not yet be transported, and indicates that a fixnum rather than the object was returned as the first value. A value of :COPY indicates that HEADER-PTR was in oldspace or train-space, but has been transported to copyspace or newspace, and it is the copyspace or newspace object that is being returned. A value of :TRAIN indicates that HEADER-PTR is an object in train-space, which has not been copied out. If the flag is :ENTRY, :OLD-A or :TRAIN-A, then it is in one of the special Extended-Address-Space regions. A value of NIL just indicates that the object returned 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 the array 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 checking before 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 starting at 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 a flag. The flag is :BOXED if all elements are boxed data, and :UNBOXED if 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 ART-SINGLE-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)) ((ART-DOUBLE-FLOAT ; 2 Qs/elem, unboxed ART-COMPLEX-SINGLE-FLOAT) (VALUES (* index-len 2) :UNBOXED)) (ART-COMPLEX-DOUBLE-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)))) ;;AB 7-28-87. Fixed size for PDLs. (DEFUN %structure-size-array (ptr) (LET* ((array-header (%P-LDB %%Q-Pointer ptr)) (simple-p (LDB-TEST %%Array-Simple-Bit array-header)) (ary-type (%logdpb (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) (IF (OR (= ary-type ART-SPECIAL-PDL) (= ary-type ART-REG-PDL)) (MULTIPLE-VALUE-BIND (ignore leader-length) (%get-array-header-addr (%find-structure-leader ptr)) (VALUES (- (%structure-total-size ptr) leader-length) (- (%structure-boxed-size ptr) leader-length))) (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-instance-header (ptr) (LET* ((instance-descriptor-ptr (%follow-gc-forwarding (%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 %Fef-Storage-Length-Word))) (boxed (%P-LDB %%FEF-HEADER-Location-Counter-Offset ptr))) (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 (%follow-gc-young-pointer 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-header-forward (ptr) (LOOP FOR adr = (%POINTER-PLUS ptr 1) THEN (%POINTER-PLUS adr 1) FOR reg = (%region-number adr) FOR last-addr = (1- (+ (region-origin reg) (region-free-pointer reg))) 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 (OR (/= DTP-Body-Forward dt) (IF (= last-addr adr) (SETF body-words (+ body-words 1)))) 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 header-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 header-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-ptr FOR 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)) "This is a safe version of the %STRUCTURE-TOTAL-SIZE and %STRUCTURE-BOXED-SIZE subprimitives. STRUCTURE-PTR should be a pointer. If it is a pointer into list space, it can point anywhere and the sublist beginning there will be returned. If it is a pointer into structure space, it should point to a structure header or leader. This does not work for objects in the special Extended-Address-space regions such as Train-a, Oldspace-a, and Entry regions. Returns 3 values: 1) The structure's total size in words (for lists, the length of the cdr-coded list starting at STRUCTURE-PTR). 2) The boxed size. This is the number of words out of the total that have a valid data type field. For lists this will be the same as total size. 3) A flag. For lists, non-NIL means the cdr-coded list segment ends in a RPLACD forwarded cons. For structures, non-NIL means the structure has been structure-forwarded." (LET ((reg (%REGION-NUMBER structure-ptr))) (If (or (region-train-a-p reg) (region-entry-p reg) (region-oldspace-a-p reg)) (ferror nil "Structure-pointer ~a points to an :entry, :train-a, or :oldspace-a region, ~ ~% it is illegal to call %structure-size-safe on a object is these types of regions." structure-ptr)) (LET* ((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. An error will be signalled if the address is in a train-a, entry, or oldspace-a region, since these are extended-address-space regions. 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 the analysis function. The first 6 of these arguments will be bound to the following 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 or a special extended-address-space region (: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-FUNCTION will 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 example of a function that is unsafe for oldspace objects is PRINT. The default is NIL." (let (First-obj-address reg flag) (multiple-value-setq (nil first-obj-address flag) (%find-structure-leader-safe start-addr)) (If (or (eq flag :train-a) (eq flag :ENTRY) (eq flag :OLD-A)) (ferror nil "~a is in an :entry, :train-a, or :oldspace-a region, ~ ~% it is illegal to call map-objects on these type of regions" start-addr)) (UNLESS (OR first-obj-address (< 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-address orig)) (addr first-obj-address 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) (eq space-type-flag :train) 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 at the 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. An error will be signalled if the region is a train-a, entry, or oldspace-a region, since these are extended-address-space regions. 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 the analysis function. The first 5 of these arguments will be bound to the following 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). 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 example of a function that is unsafe for oldspace objects is PRINT. The default is 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)) (If (or (region-train-a-p region) (region-entry-p region) (region-oldspace-a-p region)) (ferror nil "Region ~a is an :entry, :train-a, or :oldspace-a region, ~ ~% it is illegal to call map-objects on this type of region." region)) (WHEN (OR safe-for-oldspace-objects (NOT (region-oldspace-p region (AREF #'region-bits 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) (skip-special-EAS-regions 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 (indicating all 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 the analysis function. The first 5 of these arguments will be bound to the following 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). Whenever the analysis of a new region begins, the function specified as :REGION-START-FUNCTION will be called with the value of the :STREAM keyword as its only argument. In addition, a brief header is displayed on STREAM at 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 example of a function that is unsafe for oldspace objects is PRINT. The default is NIL. The :SKIP-SPECIAL-EAS-REGIONS keyword, if non-nil, will cause the skipping of the special Extended Address Space regions type: Train-a, Oldspace-a, and Entry. Otherwise an error will be signalled if one is seen." (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 WITH cnt = 0 FOR region = (AREF #'area-region-list area-number) THEN (AREF #'region-list-thread region) UNTIL (MINUSP region) DO (If (or (region-train-a-p region) (region-entry-p region) (region-oldspace-a-p region)) ;; if special EAS region, see if we should skip or signal error (if (not skip-special-EAS-regions ) (ferror nil "Region ~a in area ~a is an :entry, :train-a, or :oldspace-a region, ~ ~% it is illegal to call map-objects-in-region on this type of region. ~ ~% You can set keyword :skip-special-EAS-regions to T to skip these." region area-number)) ;; if not special EAS region, check for oldspace case (WHEN (OR safe-for-oldspace-objects (NOT (region-oldspace-p region (AREF #'region-bits region)))) (INCF cnt (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)))) FINALLY (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 be a 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 to control the settings of the *PRINT-LENGTH* and *PRINT-LEVEL* variables respectively. :MAX-STRING-LENGTH says how much of strings to print. The address and size of each object is printed. The :BASE keyword says 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 to control the settings of the *PRINT-LENGTH* and *PRINT-LEVEL* variables respectively. :MAX-STRING-LENGTH says how much of strings to print. The address and size of each object is printed. The :BASE keyword says 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)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Misc Analysis Functions ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; 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 = nil FOR 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 high part 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 are returned 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 return it 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-Memory is 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) (CASE 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 by the :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 previously returned 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 q-storage-symbol (ptr) (LET* ((first-q-storage-location (%p-pointer (VALUE-CELL-LOCATION (FIRST a-memory-location-names)))) (last-q-storage-location (%pointer-plus first-q-storage-location (LENGTH (THE list a-memory-location-names))))) (IF (AND (%pointer<= first-q-storage-location ptr) (%pointer<= ptr last-q-storage-location)) ;; In A-MEMORY q storage. Return corresponding symbol. (LOOP with q-storage-offset = (%pointer-difference ptr first-q-storage-location) for sym in a-memory-location-names for ct = 0 then (1+ ct) do (WHEN (= q-storage-offset ct) (RETURN sym)) finally (RETURN nil)) ;; Not in A-MEMORY q storage. Check for M-MEMORY q storage. (LET* ((first-q-storage-location (%p-pointer (VALUE-CELL-LOCATION (FIRST m-memory-location-names)))) (last-q-storage-location (%pointer-plus first-q-storage-location (LENGTH (THE list m-memory-location-names))))) (IF (AND (%pointer<= first-q-storage-location ptr) (%pointer<= ptr last-q-storage-location)) ;; In M-MEMORY q storage. Return corresponding symbol. (LOOP with q-storage-offset = (%pointer-difference ptr first-q-storage-location) for sym in m-memory-location-names for ct = 0 then (1+ ct) do (WHEN (= q-storage-offset ct) (RETURN sym)) finally (RETURN nil)))))) ) (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 ~@12a" 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 (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 configuration and reports memory errors. The number of times each memory word is read can 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 ;;; (DEFVAR *ET-Pathname-Default* "SYS:UBIN;.TBL#>") (DEFUN force-load-error-table (&optional 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." ;; 4/19/88 CLM - Rewritten for new mcr naming convention ;; (e.g. exp1-ucode-540.tbl#1). (LET* ((fs:*always-merge-type-and-version* nil) (filename (get-microcode-name)) (old-default-for-parsing (SEND (fs:parse-pathname *et-pathname-default*) :new-name filename)) (new-default-for-parsing (send (fs:parse-pathname *et-pathname-default*) :new-name (concatenate 'string filename (format nil "-~s" (if (NUMBERP error-table-pathname) error-table-pathname %microcode-version-number))))) (new-default (probe-file new-default-for-parsing)) pathname) (SETQ pathname (COND ((NUMBERP error-table-pathname) (if new-default new-default-for-parsing (SEND old-default-for-parsing :new-version error-table-pathname))) ((NULL error-table-pathname) (if new-default new-default-for-parsing (SEND old-default-for-parsing :new-version %microcode-version-number) ) ) (t (fs:merge-pathnames error-table-pathname (if new-default new-default-for-parsing old-default-for-parsing)) ) ) ) (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))) (DEFUN add-items-to-support-vector (new-items-list first-new-svc-number) (LOOP FOR item-num = first-new-svc-number THEN (1+ item-num) FOR item IN new-items-list DO (%add-to-support-vector item item-num))) (DEFUN fix-up-wired-area (area-number) (LET* ((area-array (OR (AND (NUMBERP area-number) (AREA-NAME area-number) (FBOUNDP (AREA-NAME area-number)) (TYPEP (SYMBOL-FUNCTION (AREA-NAME area-number)) 'ARRAY) (EQ t (ARRAY-ELEMENT-TYPE (SYMBOL-FUNCTION (AREA-NAME area-number)))) (SYMBOL-FUNCTION (AREA-NAME area-number))) (FERROR nil "~s is not a fixable area-number." area-number))) (free-ptr (AREF #'region-free-pointer area-number)) (length (ARRAY-LENGTH area-array)) (origin (AREF #'region-origin area-number))) ;; Assure FREE-POINTER of area set up right. (UNLESS (= free-ptr length) (WITHOUT-INTERRUPTS (LET ((%inhibit-read-only t)) (LOOP for el from free-ptr below length do (%p-store-pointer (%pointer-plus origin el) 0) (%p-store-data-type (%pointer-plus origin el) dtp-symbol) (%p-store-cdr-code (%pointer-plus origin el) cdr-next)) (%p-store-cdr-code (%pointer-plus origin (1- free-ptr)) cdr-next) (%p-store-cdr-code (%pointer-plus origin (1- length)) cdr-nil) (SETF (AREF #'region-free-pointer area-number) length) (WHEN (ARRAY-HAS-FILL-POINTER-P area-array) (SETF (FILL-POINTER area-array) length)))))) ) (DEFUN %add-to-support-vector (thing-to-add svc-number &optional force-p) "Stores THING-TO-ADD in the microcode SUPPORT-VECTOR. SVC-NUMBER is the slot to store into. An error will be signalled if there is already something stored in that slot." ;; Error checking (CHECK-ARG svc-number (AND (NUMBERP svc-number) (< svc-number (AREF #'region-length support-entry-vector))) "a valid support entry vector slot number") (UNLESS (= (AREF #'region-free-pointer support-entry-vector) (AREF #'region-length support-entry-vector)) (fix-up-wired-area support-entry-vector)) (COND ((EQ (AREF #'support-entry-vector svc-number) thing-to-add) (RETURN-FROM %add-to-support-vector (VALUES svc-number nil))) (force-p t) ((NOT (NULL (AREF #'support-entry-vector svc-number))) (CERROR "Replace ~s with ~s in support vector." "Another entry (~s) already exists for SVC number ~*~d." (AREF #'support-entry-vector svc-number) thing-to-add svc-number))) ;; Now do the real work. (WITHOUT-INTERRUPTS (LET ((%inhibit-read-only t)) (SETF (AREF #'si:support-entry-vector svc-number) thing-to-add))) (VALUES svc-number t) ) (DEFUN %forward-new-register-symbol (sym) "Given SYM, a symbol in either SYS:A-MEMORY-LOCATION-NAMES or SYS:M-MEMORY-LOCATION-NAMES, forwards SYM's value cell to the appropriate processor register. Error if SYM is not on either list. NOTE: Don't do this unless the running microcode knows about the register corresponding to SYM becuase the register must contain only typed data." (LET (base-adr pos) (COND ((MEMBER sym A-Memory-Location-Names :test #'EQ) (SETQ base-adr (%p-pointer (VALUE-CELL-LOCATION (FIRST A-Memory-Location-Names))) pos (POSITION sym (THE list A-Memory-Location-Names)))) ((MEMBER sym M-Memory-Location-Names :test #'EQ) (SETQ base-adr (%p-pointer (VALUE-CELL-LOCATION (FIRST M-Memory-Location-Names))) pos (POSITION sym (THE list M-Memory-Location-Names)))) (t (ERROR "~s is not an A-Memory or M-Memory location name." sym))) (%p-store-data-type-and-pointer (VALUE-CELL-LOCATION sym) dtp-one-q-forward (%pointer-plus base-adr pos))) )