;;; -*- Mode:Lisp; Package:lambda; Base:8; readtable: zl -*- ;;; PHONEY LISP MACHINE MICROCODE -- Lambda VERSION ;;; ** (c) Copyright 1980 Massachusetts Institute of Technology ** ;; ** Enhancements (c) Copyright 1984,1985,1986 Lisp Machine Inc ** ;2/4/79 MODIFIED FOR CHANGES TO MAP-STATUS-CODE IN PAGE MAP ;LISP MACHINE Q'S ARE REPRESENTED AS FIXNUMS, CONTAINING ;THE SAME FIELDS. EXCEPT, -1 MEANS PAGE INACCESSIBLE, AND AT SOME ;LEVELS -2 MEANS IN PDL BUFFER. (DEFCONST *STRAIGHT-MAP-MODE* NIL) (defvar *major-version-warning-printed* nil) (DEFVAR QF-AREA-ORIGIN-CACHE NIL "Alist of area name vs starting address of that area. For fixed areas only.") (DEFVAR QF-PAGE-PARTITION-CACHE NIL "Disk address of start of PAGE partition on debugged machine, or NIL.") (DEFVAR QF-PAGE-PARTITION-CACHE-MAXIMUM NIL "Disk address of end of PAGE partition") (DEFCONST QF-FINDCORE-TRACE-SWITCH NIL "T => trace times we must swap out a page on the debugged machine.") (DEFVAR QF-PHT-CACHE :UNBOUND "List of ucode version, PHT limit, PHT mask; or NIL if not determined yet.") (DEFCONST QF-PAGE-HASH-TABLE-EXTRA-CHECKING-FLAG NIL "T turns on extra error checking for manipulation of debugged machines PHT.") (DEFVAR QF-CACHE-VERSION 0 "Cached symbols are recorded with this number. Incrementing this number therefore invalidates the cached data.") (DEFVAR PHT-ADDR NIL "Address of page hash table in debugged machine; NIL if not yet known.") (defvar pht-has-data-types t "T in old systems, NIL for lambdas that can address whole NUBUS.") (defvar lam-%address-space-map-byte-size nil) ;separate this from %address-space-map.. ;variable to avoid screwwing value used by micro-assembler. (defconst pdl-buffer-size-mask 3777) ;1777 for explorer (defvar qf-a-memory-virtual-address 176776000) ;these have bit 25. for system 99. (defvar qf-io-space-virtual-address 177000000) (defvar qf-multibus-virtual-address 177400000) (DEFVAR LAST-MAPPED-VIRTUAL-PAGE NIL) (DEFVAR LAST-MAPPED-PHYSICAL-PAGE NIL) (defvar micro-fault-page 1) (defvar *old-hash-table-setup* nil) (defun setup-for-old-page-hash-table () ;leave this around as long as system 102 is. (setq *old-hash-table-setup* t ; DEFINITIONS OF FIELDS IN PAGE HASH TABLE ;WORD 1 %%PHT1-VIRTUAL-PAGE-NUMBER 1020 ;ALIGNED SAME AS VMA %PHT-DUMMY-VIRTUAL-ADDRESS 177777 ;ALL ONES MEANS THIS IS DUMMY ENTRY ;WHICH JUST REMEMBERS A FREE CORE PAGE %%PHT1-SWAP-STATUS-CODE 0003 %PHT-SWAP-STATUS-NORMAL 1 ;ORDINARY PAGE %PHT-SWAP-STATUS-FLUSHABLE 2 ;SAFELY REUSABLE TO SWAP PAGES INTO ;MAY NEED TO BE WRITTEN TO DISK FIRST %PHT-SWAP-STATUS-PREPAGE 3 ;SAME AS FLUSHABLE, BUT CAME IN VIA PREPAGE %PHT-SWAP-STATUS-AGE-TRAP 4 ;LIKE NORMAL BUT TRYING TO MAKE FLUSHABLE %PHT-SWAP-STATUS-WIRED 5 ;NOT SWAPPABLE %%PHT1-AGE 0302 ;NUMBER OF TIMES AGED %%PHT1-MODIFIED-BIT 0501 ;1 IF PAGE MODIFIED, BUT THE FACT NOT RECORDED ; IN THE MAP-STATUS, BECAUSE IT IS NOMINALLY READ-ONLY ; OR NOMINALLY READ-WRITE-FIRST. %%PHT1-VALID-BIT 0601 ;1 IF THIS HASH TABLE SLOT IS OCCUPIED. %%PHT1-SCAVENGER-WS-FLAG 0701 ;IF SET, PAGE IN SCAVENGER WORKING SET. ;PHT WORD 2. THIS IS IDENTICAL TO THE LEVEL-2 MAP %%PHT2-META-BITS 1606 ;SEE %%REGION-MAP-BITS %%PHT2-MAP-STATUS-CODE 2403 %PHT-MAP-STATUS-MAP-NOT-VALID 0 ;LEVEL 1 OR 2 MAP NOT SET UP %PHT-MAP-STATUS-META-BITS-ONLY 1 ;HAS META BITS BUT NO PHYSICAL ADDRESS %PHT-MAP-STATUS-READ-ONLY 2 ;GARBAGE COLLECTOR CAN STILL WRITE IN IT %PHT-MAP-STATUS-READ-WRITE-FIRST 3 ;READ/WRITE BUT NOT MODIFIED %PHT-MAP-STATUS-READ-WRITE 4 ;READ/WRITE AND MODIFIED %PHT-MAP-STATUS-PDL-BUFFER 5 ;MAY RESIDE IN PDL BUFFER %PHT-MAP-STATUS-MAR 6 ;MAR SET SOMEWHERE ON THIS PAGE %%PHT2-MAP-ACCESS-CODE 2602 %%PHT2-ACCESS-STATUS-AND-META-BITS 1612 %%PHT2-ACCESS-AND-STATUS-BITS 2404 %%PHT2-PHYSICAL-PAGE-NUMBER 0016 )) (defun setup-for-new-page-hash-table () (setq *old-hash-table-setup* nil ;; WORD 1 %%PHT1-VIRTUAL-PAGE-NUMBER 1021 ;ALIGNED SAME AS VMA %PHT-DUMMY-VIRTUAL-ADDRESS 377777 ;ALL ONES MEANS THIS IS DUMMY ENTRY ;WHICH JUST REMEMBERS A FREE CORE PAGE %%PHT1-SWAP-STATUS-CODE 0003 %PHT-SWAP-STATUS-NORMAL 1 ;ORDINARY PAGE %PHT-SWAP-STATUS-FLUSHABLE 2 ;SAFELY REUSABLE TO SWAP PAGES INTO ;MAY NEED TO BE WRITTEN TO DISK FIRST %PHT-SWAP-STATUS-PREPAGE 3 ;SAME AS FLUSHABLE, BUT CAME IN VIA PREPAGE %PHT-SWAP-STATUS-AGE-TRAP 4 ;LIKE NORMAL BUT TRYING TO MAKE FLUSHABLE %PHT-SWAP-STATUS-WIRED 5 ;NOT SWAPPABLE %%PHT1-AGE 0302 ;NUMBER OF TIMES AGED %%PHT1-MODIFIED-BIT 0501 ;1 IF PAGE MODIFIED, BUT THE FACT NOT RECORDED ; IN THE MAP-STATUS, BECAUSE IT IS NOMINALLY ; READ-ONLY OR NOMINALLY READ-WRITE-FIRST. %%PHT1-VALID-BIT 0601 ;1 IF THIS HASH TABLE SLOT IS OCCUPIED. %%PHT1-SCAVENGER-WS-FLAG 0701 ;IF SET, PAGE IN SCAVENGER WORKING SET. ;; Pht word 2. This is identical to the level-2 map %%PHT2-META-BITS #.(byte 6 26) ;SEE %%REGION-MAP-BITS %%PHT2-MAP-STATUS-CODE #.(byte 3 34) %PHT-MAP-STATUS-MAP-NOT-VALID 0 ;LEVEL 1 OR 2 MAP NOT SET UP %PHT-MAP-STATUS-META-BITS-ONLY 1 ;HAS META BITS BUT NO PHYSICAL ADDRESS %PHT-MAP-STATUS-READ-ONLY 2 ;GARBAGE COLLECTOR CAN STILL WRITE IN IT %PHT-MAP-STATUS-READ-WRITE-FIRST 3 ;READ/WRITE BUT NOT MODIFIED %PHT-MAP-STATUS-READ-WRITE 4 ;READ/WRITE AND MODIFIED %PHT-MAP-STATUS-PDL-BUFFER 5 ;MAY RESIDE IN PDL BUFFER %PHT-MAP-STATUS-MAR 6 ;MAR SET SOMEWHERE ON THIS PAGE %%PHT2-MAP-ACCESS-CODE #.(byte 2 36) %%PHT2-ACCESS-STATUS-AND-META-BITS #.(byte 12 26) %%PHT2-ACCESS-AND-STATUS-BITS #.(byte 4 34) %%PHT2-PHYSICAL-PAGE-NUMBER 0026 )) (setup-for-new-page-hash-table) (setq cdr-next-is-0 t) (DEFUN QF-CLEAR-CACHE (&optional IGNORE) "Called each time debugged machine has been run, to forget all cached data about it." (setq *major-version-warning-printed* nil) (SETQ QF-AREA-ORIGIN-CACHE NIL) (INCF QF-CACHE-VERSION) (SETQ QF-PHT-CACHE NIL) (SETQ QF-PAGE-PARTITION-CACHE NIL) (SETQ PHT-ADDR NIL) (SETQ LAST-MAPPED-VIRTUAL-PAGE NIL LAST-MAPPED-PHYSICAL-PAGE NIL) ) (defvar cdr-next-is-0 nil) (DEFUN QF-SETUP-Q-FIELDS (&optional ignore) ;; 25-bit pointers. (SETQ %%QF-POINTER 0031 %QF-POINTER-MASK 177777777 %%QF-BOXED-SIGN-BIT 3001 %QF-PAGE-NUMBER-MASK 177777400 %%QF-PHT1-VIRTUAL-PAGE-NUMBER 1021 %QF-PHT-DUMMY-VIRTUAL-ADDRESS 377777 %QF-POINTER-SANS-BOXED-SIGN-BIT-MASK 77777777 %%QF-DATA-TYPE 3105 %%QF-CDR-CODE 3602 %%QF-TYPED-POINTER 0036 %QF-TYPED-POINTER-MASK 7777777777 LAM-SEXP-DESC LAM-SEXP-DESC-25 LAM-REG-ADDR-DESC LAM-REG-ADDR-DESC-25 %QF-TYPED-POINTER-MASK 7777777777 lam-inst-desc lam-inst-desc-25 lam-i-dest-desc lam-i-dest-desc-25 qf-a-memory-virtual-address 176776000 qf-io-space-virtual-address 177000000 qf-multibus-virtual-address 177400000) (if cdr-next-is-0 (setq cdr-next 0 cdr-error 1 cdr-normal 2 cdr-nil 3 lam-q-desc lam-q-desc-25-0 pht-has-data-types nil ) (setq cdr-normal 0 cdr-error 1 cdr-nil 2 cdr-next 3 lam-q-desc lam-q-desc-25 pht-has-data-types t )) (setq micro-fault-page 1) (SETQ QF-NIL (DPB DTP-SYMBOL %%QF-DATA-TYPE 0)) ) (DEFUN QF-INITIALIZE-FOR-LISP-REFERENCE NIL (IF (NULL PHT-ADDR) (QF-SETUP-PHT-ADDR))) (DEFUN QF-SETUP-PHT-ADDR (&optional no-error) (qf-clear-cache t) (LET ((%QF-POINTER-MASK 177777777)) (SETQ PHT-ADDR (QF-POINTER (PHYS-MEM-READ (+ 400 %SYS-COM-PAGE-TABLE-PNTR)))) ) (COND ((memq PHT-ADDR `(;,(* 11. 400) ;system 98 ,(* 12. 400) ;system 99 ,(* 14. 400) ;system 104 ,(* 162. 400) ;system 114 )) (setq lam-%address-space-map-byte-size (cond ((= pht-addr (* 162. 400)) 20) (t 8))) (QF-SETUP-Q-FIELDS) t) (no-error nil) (T (FERROR NIL "unable to figure out page table area")))) ;;; MEMORY INTERFACE AND PAGING STUFF ; PHYS-MEM-READ PHYSICAL MEMORY READ ; PHYS-MEM-WRITE PHYSICAL MEMORY WRITE ; QF-VIRTUAL-MEM-READ ; QF-VIRTUAL-MEM-WRITE ; QF-VIRTUAL-MEM-MAP GIVEN VMA RETURNS PMA ; OR -1 FOR INACCESSIBLE ; OR -2 FOR IN PDL BUFFER. ; SECOND ARG IS T IF WRITE CYCLE IS INTENDED ; QF-PAGE-HASH-TABLE-LOOKUP GIVEN VMA, RETURNS PHYS ADR OF PHT1 ; ENTRY OR -1 FOR NOT FOUND. ; QF-VIRT-ADR-OF-PHYS-ADR linearly searches PHT for phys adr. ; QF-PAGE-HASH-TABLE-DELETE GIVEN VMA, DELETE IT FROM HASH ; TABLE, READJUSTING THINGS AS NECC. ; RETURN T IF DELETED, NIL IF NOT FOUND ; QF-COMPUTE-PAGE-HASH GIVEN VMA, RETURN INITIAL HASH ADR RELATIVE ; TO HASH TABLE ORIGIN. ; QF-FINDCORE CALL TO OBTAIN A FREE CORE PAGE IN CONS. ; SWAPS ONE OUT IF NECC, ADJUSTING HASH ; TBL, REAL MACHINE'S MAP, ETC. RETURNS ; PHYSICAL PAGE NUMBER. ; QF-GET-DISK-ADR ; QF-SWAP-IN DO EVERYTHING NEEDED TO BE SWAPPED IN ; QF-VIRTUAL-MEM-PDL-BUF-ADR ; QF-MEM-READ BARF IF INACCESSIBLE ; QF-MEM-READ-DISK-COPY Read Virt Adr from disk even if swapped in. ; QF-MEM-WRITE (DEFUN QF-VIRTUAL-MEM-READ (VADR) (let ((padr (QF-VIRTUAL-MEM-MAP VADR NIL))) (COND ((= PADR -1) PADR) ;INACCESSIBLE ((= PADR -2) ;IN PDL BUFFER (LAM-REGISTER-EXAMINE (QF-VIRTUAL-MEM-PDL-BUF-ADR VADR))) ((= padr -3) ;A-MEMORY (lam-register-examine (+ raamo (- (qf-pointer vadr) qf-a-memory-virtual-address)))) ((< padr 0) (ferror nil "%Attempted virtual-mem-read of IO or Multibus adr")) (t (PHYS-MEM-READ PADR)))) ) (DEFUN QF-VIRTUAL-MEM-WRITE (VADR DATA) ;NOTE DOESN'T RESPECT READ ONLY, RWF (let ((padr (QF-VIRTUAL-MEM-MAP VADR T))) (COND ((= PADR -1) PADR) ;INACCESSIBLE ((= PADR -2) ;IN PDL BUFFER (LAM-REGISTER-DEPOSIT (QF-VIRTUAL-MEM-PDL-BUF-ADR VADR) DATA)) ((= padr -3) ;A-MEMORY (lam-register-deposit (+ raamo (- (qf-pointer vadr) qf-a-memory-virtual-address)) data)) ((< padr 0) (ferror nil "%Attempted virtual-mem-write of IO or Multibus adr")) (T (PHYS-MEM-WRITE PADR DATA) DATA))) ) (DEFUN QF-VIRTUAL-MEM-PDL-BUF-ADR (ADR) (+ RAPBO (LOGAND PDL-BUFFER-SIZE-MASK (+ (- ADR (LAM-SYMBOLIC-EXAMINE-REGISTER 'A-PDL-BUFFER-VIRTUAL-ADDRESS)) (LAM-SYMBOLIC-EXAMINE-REGISTER 'A-PDL-BUFFER-HEAD))))) (DEFUN QF-PAGE-HASH-TABLE-LOOKUP (ADR) ;RETURNS -1 OR PHYSICAL MEM ADR OF PHT1 WD (IF (NULL PHT-ADDR) (QF-SETUP-PHT-ADDR)) (SETQ ADR (QF-POINTER ADR)) ; OF HASH-TBL ENTRY FOR ADR (OR QF-PHT-CACHE (QF-REFILL-PHT-CACHE)) (LET ((PHT-SIZE (CADR QF-PHT-CACHE))) (DECLARE (FIXNUM PHT-SIZE)) (DO ((HASH (QF-COMPUTE-PAGE-HASH ADR) (+ HASH 2)) (PHT1) (COUNT (LSH PHT-SIZE -1) (1- COUNT))) ((= COUNT 0) -1) ;INACESSIBLE (SHOULD NEVER HAPPEN, BUT AT LEAST DONT GET ; INTO INFINITE LOOP IF HASH TABLE GETS OVER-FULL) (DECLARE (FIXNUM HASH PHT1 PHT2 COUNT)) (AND (>= HASH PHT-SIZE) (SETQ HASH (- HASH PHT-SIZE))) (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH))) (COND ((= 0 (LOGAND 100 PHT1)) ;NO VALID BIT (RETURN -1)) ;NOT FOUND ((= 0 (QF-MASK-PAGE-NUMBER (LOGXOR ADR PHT1))) ;ADDRESS MATCH (RETURN (+ PHT-ADDR HASH))))))) ;FOUND IT (DEFUN QF-PAGE-HASH-TABLE-LOOKUP-WITH-PROBES (ADR) ;RETURNS -1 OR PHYSICAL MEM ADR OF PHT1 WD (IF (NULL PHT-ADDR) (QF-SETUP-PHT-ADDR)) (SETQ ADR (QF-POINTER ADR)) ; OF HASH-TBL ENTRY FOR ADR (OR QF-PHT-CACHE (QF-REFILL-PHT-CACHE)) (LET ((PHT-SIZE (CADR QF-PHT-CACHE))) (DECLARE (FIXNUM PHT-SIZE)) (DO ((HASH (QF-COMPUTE-PAGE-HASH ADR) (+ HASH 2)) (PHT1) (COUNT (LSH PHT-SIZE -1) (1- COUNT)) (probes 1 (1+ probes))) ((= COUNT 0) (values -1 probes)) ;INACESSIBLE (SHOULD NEVER HAPPEN, BUT AT ;LEAST DONT GET INTO INFINITE LOOP IF HASH TABLE GETS OVER-FULL) (DECLARE (FIXNUM HASH PHT1 PHT2 COUNT)) (AND (>= HASH PHT-SIZE) (SETQ HASH (- HASH PHT-SIZE))) (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH))) (COND ((= 0 (LOGAND 100 PHT1)) ;NO VALID BIT (RETURN (values -1 probes))) ;NOT FOUND ((= 0 (QF-MASK-PAGE-NUMBER (LOGXOR ADR PHT1))) ;ADDRESS MATCH (RETURN (values (+ PHT-ADDR HASH) probes))))))) ;FOUND IT ;Linearly scan page hash table looking for info on given phys-adr. (DEFUN QF-VIRT-ADR-OF-PHYS-ADR (PHYS-ADR) (IF (NULL PHT-ADDR) (QF-SETUP-PHT-ADDR)) (DO ((PHYS-PAGE (ASH PHYS-ADR -10)) (HASH-LOCN 0 (+ HASH-LOCN 2)) (PHT1) (PHT2) (COUNT (LSH (QF-POINTER (PHYS-MEM-READ (+ 400 %SYS-COM-PAGE-TABLE-SIZE))) -1) (1- COUNT))) ((= COUNT 0) NIL) (COND ((AND (BIT-TEST 100 (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH-LOCN)))) (= PHYS-PAGE (LDB %%PHT2-PHYSICAL-PAGE-NUMBER (SETQ PHT2 (PHYS-MEM-READ (1+ (+ PHT-ADDR HASH-LOCN))))))) (RETURN (+ (ASH (LDB %%QF-PHT1-VIRTUAL-PAGE-NUMBER PHT1) 8) (LOGAND 377 PHYS-ADR))))))) (DEFUN QF-PAGE-HASH-TABLE-DELETE (ADR HOLE-POINTER) (IF (NULL PHT-ADDR) (QF-SETUP-PHT-ADDR)) (PROG (LEAD-POINTER LEAD-POINTER-HASH-ADR LEAD-POINTER-VIRT-ADR LIM PHT1 PHT2 PPDP MOVED-POINTER) (DECLARE (FIXNUM LEAD-POINTER LEAD-POINTER-HASH-ADR LEAD-POINTER-VIRT-ADR LIM PHT1 PHT2 MOVED-POINTER PPDP)) (SETQ LIM (+ PHT-ADDR (QF-POINTER (PHYS-MEM-READ (+ 400 %SYS-COM-PAGE-TABLE-SIZE))) -2)) ;POINTS TO LAST VALID ENTRY L1 (PHYS-MEM-WRITE HOLE-POINTER (if pht-has-data-types (QF-MAKE-Q 0 DTP-FIX) 0)) ;FLUSH GUY FROM TABLE (SETQ LEAD-POINTER HOLE-POINTER) L2 (SETQ LEAD-POINTER (COND ((< LEAD-POINTER LIM) (+ LEAD-POINTER 2)) (T PHT-ADDR))) (SETQ PHT1 (PHYS-MEM-READ LEAD-POINTER)) (COND ((= 0 (LOGAND 100 PHT1)) (OR QF-PAGE-HASH-TABLE-EXTRA-CHECKING-FLAG (RETURN T)) (AND (= 0 (LAM-CHECK-PAGE-HASH-TABLE-ACCESSIBILITY)) (RETURN T)) (PRINT (LIST 'QF-PAGE-HASH-TABLE-DELETE-SCREW ADR LEAD-POINTER HOLE-POINTER MOVED-POINTER)) (BREAK 'QF-PAGE-HASH-TABLE-DELETE-SCREW T) (RETURN T))) ;BLANK ENTRY, THROUGH (SETQ LEAD-POINTER-VIRT-ADR (QF-MASK-PAGE-NUMBER PHT1)) (SETQ LEAD-POINTER-HASH-ADR (COND ((NOT (= LEAD-POINTER-VIRT-ADR (QF-MASK-PAGE-NUMBER -1))) (+ PHT-ADDR (QF-COMPUTE-PAGE-HASH LEAD-POINTER-VIRT-ADR))) (T HOLE-POINTER))) ;DUMMY ALWAYS HASHES TO HOLE ADDR (COND ((< LEAD-POINTER LEAD-POINTER-HASH-ADR) (GO L4))) ;WRAPAROUND CASE (COND ((OR (> LEAD-POINTER-HASH-ADR HOLE-POINTER) (< LEAD-POINTER HOLE-POINTER)) (GO L2))) ;JUMP IF SHOULDN'T BE WHERE HOLE IS L6 (PHYS-MEM-WRITE HOLE-POINTER PHT1) ;SHOULD BE WHERE HOLE IS, MOVE IT (PHYS-MEM-WRITE (1+ HOLE-POINTER) (SETQ PHT2 (PHYS-MEM-READ (1+ LEAD-POINTER)))) (SETQ PPDP (+ (LDB %%PHT2-PHYSICAL-PAGE-NUMBER PHT2) (QF-INITIAL-AREA-ORIGIN 'PHYSICAL-PAGE-DATA))) (PHYS-MEM-WRITE PPDP (DPB (- HOLE-POINTER PHT-ADDR) 0020 (PHYS-MEM-READ PPDP))) (SETQ MOVED-POINTER HOLE-POINTER) ;FOR DEBUGGING, WHERE THING MOVED TO (SETQ HOLE-POINTER LEAD-POINTER) (GO L1) L4 (COND ((OR (<= LEAD-POINTER-HASH-ADR HOLE-POINTER) (>= LEAD-POINTER HOLE-POINTER)) (GO L6))) ;JUMP IF SHOULD BE WHERE HOLE IS (GO L2) )) (DEFUN QF-REFILL-PHT-CACHE () (LET ((PHT-SIZE (QF-POINTER (PHYS-MEM-READ (+ 400 %SYS-COM-PAGE-TABLE-SIZE))))) (DECLARE (FIXNUM PHT-SIZE)) (LET ((PHT-MASK (- (LSH 1 (HAULONG PHT-SIZE)) 2))) (DECLARE (FIXNUM PHT-MASK)) (SETQ LAST-MAPPED-VIRTUAL-PAGE NIL LAST-MAPPED-PHYSICAL-PAGE NIL) (SETQ QF-PHT-CACHE (LIST (QF-POINTER (LAM-SYMBOLIC-EXAMINE-REGISTER 'A-VERSION)) PHT-SIZE PHT-MASK))))) ;(DEFUN QF-COMPUTE-PAGE-HASH (ADR) ; (IF (NULL PHT-ADDR) (QF-SETUP-PHT-ADDR)) ; (OR QF-PHT-CACHE (QF-REFILL-PHT-CACHE)) ; (LET ((PHT-SIZE (CADR QF-PHT-CACHE)) (PHT-MASK (CADDR QF-PHT-CACHE))) ; (DECLARE (FIXNUM PHT-SIZE PHT-MASK)) ; (LET ((HASH (LOGAND (cond ((= %%qf-pointer 31) ; (LOGXOR ; (LDB (BYTE 10. 14.) (QF-POINTER ADR)) ; (LOGAND 1777760 (LOGLDB 0425 ADR)))) ; (t ; (LOGXOR ; (LDB (BYTE 10. 14.) (QF-POINTER ADR)) ; (LOGAND 777760 (LOGLDB 0424 ADR))))) ; PHT-MASK))) ; (DECLARE (FIXNUM HASH)) ; (AND (>= HASH PHT-SIZE) (SETQ HASH (- HASH PHT-SIZE))) ; HASH))) ;this one decommitted 4-Jul-86 ;(defvar *new-pht-hash* ()) ;(defun qf-compute-page-hash (vma) ; (when (null pht-addr) (qf-setup-pht-addr)) ; (when (null qf-pht-cache) (qf-refill-pht-cache)) ; (let ((pht-size (cadr qf-pht-cache)) ; (pht-mask (caddr qf-pht-cache))) ; (let ((hash (logand (if *new-pht-hash* ; (logxor ; (logldb (byte 17 12) vma) ; vma) ; (logxor ; (logldb (byte 10. 14.) vma) ; (logand 1777760 (logldb 0425 vma)))) ; pht-mask))) ; (if ( hash pht-size) ; (- hash pht-size) ; hash)))) (defun qf-compute-page-hash (vma) (when (null pht-addr) (qf-setup-pht-addr)) (when (null qf-pht-cache) (qf-refill-pht-cache)) (let ((ucode-version (car qf-pht-cache)) (pht-size (cadr qf-pht-cache)) (pht-mask (caddr qf-pht-cache)) hash) (cond ((< ucode-version 1660.) (setq hash (logand (logxor (logldb (byte 10. 14.) vma) (logand 1777760 (logldb 0425 vma))) pht-mask)) (if ( hash pht-size) (setq hash (- hash pht-size))) (if (>= hash pht-size) (ferror nil "bad hash")) ) (t (setq hash 0) (do ((vma-bit 22. (1- vma-bit)) (hash-bit 1 (1+ hash-bit))) ((= vma-bit 7)) (setq hash (dpb (ldb (byte 1 vma-bit) vma) (byte 1 hash-bit) hash))))) hash)) (DEFUN QF-VIRTUAL-MEM-MAP (ADR WRITE-CYCLE) (IF (NULL PHT-ADDR) (QF-SETUP-PHT-ADDR)) (SETQ ADR (QF-POINTER ADR)) ;FLUSH DATA TYPE ETC. (COND (*straight-map-mode* adr) ((< ADR (QF-POINTER (PHYS-MEM-READ (+ 400 %SYS-COM-WIRED-SIZE)))) ADR) ((>= adr qf-io-space-virtual-address) -5) ;multibus ((>= adr qf-multibus-virtual-address) -4) ;io space ((>= adr qf-a-memory-virtual-address) -3) ;a-memory ((EQ (ASH ADR -8) LAST-MAPPED-VIRTUAL-PAGE) (+ (LOGAND 377 ADR) (ASH LAST-MAPPED-PHYSICAL-PAGE 8))) (T (OR QF-PHT-CACHE (QF-REFILL-PHT-CACHE)) (LET ((PHT-SIZE (CADR QF-PHT-CACHE))) (DECLARE (FIXNUM PHT-SIZE)) (DO ((HASH (QF-COMPUTE-PAGE-HASH ADR) (+ HASH 2)) (PHT1) (PHT2) (TEM)(STS) (set-cache t) (COUNT (LSH PHT-SIZE -1) (1- COUNT))) ((= COUNT 0) -1) ;INACCESSIBLE (DECLARE (FIXNUM HASH PHT1 PHT2 COUNT TEM STS)) (AND (>= HASH PHT-SIZE) (SETQ HASH (- HASH PHT-SIZE))) (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH))) (COND ((= 0 (LOGAND 100 PHT1)) ;NO VALID BIT (RETURN -1)) ;INACCESSIBLE ((= 0 (QF-MASK-PAGE-NUMBER (LOGXOR ADR PHT1))) ;ADDRESS MATCH (SETQ STS (LOGAND 7 PHT1)) ;ISOLATE SWAP STATUS CODE (COND ((OR (= STS 0) ;UNUSED ENTRY (= STS 6) ;UNUSED CODES (= STS 7)) (ERROR 'BAD-PAGE-HASH-ENTRY-AT-ADR HASH 'FAIL-ACT))) (SETQ PHT2 (PHYS-MEM-READ (+ PHT-ADDR HASH 1))) ;IN CORE, GET ADDRESS (COND ((= 5 (LDB %%PHT2-MAP-STATUS-CODE PHT2)) ;MAY BE IN PDL-BUFFER (setq set-cache nil) ;dont cache pdl buffer pages.. (cond ((and (NOT (< ADR (SETQ TEM (QF-POINTER (LAM-SYMBOLIC-EXAMINE-REGISTER 'A-PDL-BUFFER-VIRTUAL-ADDRESS))))) (<= ADR (+ TEM (LOGAND PDL-BUFFER-SIZE-MASK (- (LAM-SYMBOLIC-EXAMINE-REGISTER 'PP) (LAM-SYMBOLIC-EXAMINE-REGISTER 'a-pdl-buffer-head)))))) (RETURN -2)))) ;IN PDL-BUFFER ) ;IF DOING A WRITE-CYCLE INTO A PAGE, SET PHT1-MODIFIED BIT ;THIS HOPEFULLY ASSURES PAGE WILL GET WRITTEN ON DISK IF IT ;GETS SWAPPED OUT, EVEN IF THE ACCESS IS NOT READ/WRITE. (COND (WRITE-CYCLE (PHYS-MEM-WRITE (+ PHT-ADDR HASH) (DPB 1 %%PHT1-MODIFIED-BIT PHT1)))) (IF SET-CACHE (SETQ LAST-MAPPED-PHYSICAL-PAGE (LDB %%PHT2-PHYSICAL-PAGE-NUMBER PHT2) LAST-MAPPED-VIRTUAL-PAGE (ASH ADR -8))) (RETURN (+ (ASH (LDB %%PHT2-PHYSICAL-PAGE-NUMBER PHT2) 8) (LOGAND 377 ADR)))))))))) (defun check-correct-symbols () (LET* ((A-VERSION (QF-POINTER (LAM-SYMBOLIC-EXAMINE-REGISTER 'A-VERSION))) (SYMBOL-VERSION ;(LAM-LOOKUP-NAME 'VERSION-NUMBER) (and lam-file-symbols-loaded-from (send lam-file-symbols-loaded-from :version)))) (WHEN (AND (NEQ A-VERSION SYMBOL-VERSION) ;symbol version can be NIL, (FQUERY NIL "~&Microcode ~D is running but you have the symbols for ~D; Type Y to load correct symbols, N to proceed anyway. " A-VERSION SYMBOL-VERSION)) (LAM-LOAD-UCODE-SYMBOLS-FOR-VERSION A-VERSION) (QF-SETUP-Q-FIELDS)))) (DEFUN QF-FINDCORE () ;CALL TO OBTAIN FREE PAGE OF CONS MEMORY. SWAP ONE OUT IF NECC, ETC. ;DOESN'T WORK SAME WAY AS MICROCODE ANY MORE (DECLARE (FIXNUM PTR LIM PHT1 PHT2 TEM PHTSIZE N)) (IF (NULL PHT-ADDR) (QF-SETUP-PHT-ADDR)) (PROG (PTR LIM PHT1 PHT2 TEM PHTSIZE N fast-boot-p) (check-correct-symbols) (setq fast-boot-p (ldb-test %%processor-switch-fast-boot-enable ;did it fast-boot? (lam-symbolic-examine-register 'a-processor-switches))) (SETQ PHTSIZE (QF-POINTER (PHYS-MEM-READ (+ 400 %SYS-COM-PAGE-TABLE-SIZE)))) (SETQ LIM (+ PHT-ADDR PHTSIZE -2)) ;POINTS AT HIGHEST ENTRY (SETQ N 100.) ;Number of probes before giving up ;; Poking around at the other machine's page table is very slow, especially ;; if you do it wrong. So just pick a random page and swap it out ;; if it isn't wired. PROBE (SETQ PTR (+ PHT-ADDR (* (RANDOM (TRUNCATE PHTSIZE 2)) 2))) (SETQ PHT1 (PHYS-MEM-READ PTR)) (SETQ TEM (LDB %%PHT1-SWAP-STATUS-CODE PHT1)) (when fast-boot-p (let* ((page-number (ldb %%PHT1-VIRTUAL-PAGE-NUMBER pht1)) (quantum-map-index (+ (lam-symbolic-examine-register 'a-v-quantum-map) (* page-size %quantum-map-offset-in-tables) (* 2 (ldb %%virtual-page-quantum-number page-number)))) ;2 words per entry (pq1 (qf-mem-read quantum-map-index))) (unless (and (ldb-test %%pq1-quantum-is-valid pq1) ;additional constraints if quantum map in use (not (ldb-test %%pq1-quantum-is-device pq1)) (not (ldb-test %%pq1m-page-out-copy-first pq1))) (go bad)) ;there is quantum space for this page so go ahead )) (COND ((OR (= TEM %PHT-SWAP-STATUS-NORMAL) (= TEM %PHT-SWAP-STATUS-FLUSHABLE) (= TEM %PHT-SWAP-STATUS-AGE-TRAP)) (GO CF))) ;otherwise find a different page to evict bad (OR (ZEROP (SETQ N (1- N))) (GO PROBE)) (ERROR 'QF-FINDCORE 'NOTHING-TO-SWAP-OUT 'FAIL-ACT) CF (SETQ PHT2 (PHYS-MEM-READ (1+ PTR))) (AND QF-FINDCORE-TRACE-SWITCH (PRINT (LIST 'QF-FINDCORE 'PTR PTR 'PHT1 PHT1 'PHT2 PHT2))) (SETQ TEM (LDB %%PHT2-MAP-STATUS-CODE PHT2)) (COND ((OR (= TEM %PHT-MAP-STATUS-READ-WRITE) (NOT (ZEROP (LOGLDB %%PHT1-MODIFIED-BIT PHT1)))) (LET ((DISK-ADR (QF-GET-DISK-ADR (LDB %%QF-PHT1-VIRTUAL-PAGE-NUMBER PHT1)))) (LAM-DISK-WRITE-VIA-NUBUS DISK-ADR (LDB %%PHT2-PHYSICAL-PAGE-NUMBER PHT2) 1)))) ;NUMBER PAGES (COND ((NULL (QF-PAGE-HASH-TABLE-DELETE (QF-MASK-PAGE-NUMBER PHT1) PTR)) (ERROR 'QF-FINDCORE 'HASH-SCREWUP 'FAIL-ACT))) ;DELETE FROM REAL MACHINE'S MAP ;**CHANGE FOR 25 BIT MODE. WHEN HARDWARE IS REALLY IN 25 BIT MODE. (COND ((= (SETQ TEM (LOGAND 177 (LAM-REGISTER-EXAMINE (+ RAM1O (LDB (if (= %%qf-pointer 0030) 1513 1514) PHT1))))) 177) (GO X))) ;LVL 1 MAP NOT SET, OK (SETQ TEM (+ (ASH TEM 5) (LDB 0805 PHT1) RAM2O-CONTROL)) (LAM-REGISTER-DEPOSIT TEM 0) ; CHANGE TO MAP NOT SET UP (ZERO) X (RETURN (LDB %%PHT2-PHYSICAL-PAGE-NUMBER PHT2)) )) (DEFVAR QF-SWAP-IN-LOOP-CHECK NIL "Detects recursive calls to QF-SWAP-IN, for errors.") ;SWAP IN PAGE AT ADR (DEFUN QF-SWAP-IN (ADR) (SETQ LAST-MAPPED-PHYSICAL-PAGE NIL LAST-MAPPED-VIRTUAL-PAGE NIL) (SETQ ADR (QF-POINTER ADR)) ;FLUSH DATA TYPE ETC. (IF (NULL PHT-ADDR) (QF-SETUP-PHT-ADDR)) (AND QF-SWAP-IN-LOOP-CHECK (ferror nil "QF-SWAP-IN INVOKED RECURSIVELY")) (OR (< (QF-PAGE-HASH-TABLE-LOOKUP ADR) 0) (ferror nil "ALREADY SWAPPED IN - QF-SWAP-IN")) (PROG (PHYS-PAGE REGION-NUMBER ACCESS-STATUS-AND-META-BITS QF-SWAP-IN-LOOP-CHECK) (DECLARE (FIXNUM PHYS-PAGE REGION-NUMBER ACCESS-STATUS-AND-META-BITS)) (SETQ QF-SWAP-IN-LOOP-CHECK T) (SETQ REGION-NUMBER (QF-REGION-NUMBER-OF-POINTER ADR)) (SETQ ACCESS-STATUS-AND-META-BITS (LDB %%REGION-MAP-BITS (PHYS-MEM-READ (+ REGION-NUMBER (QF-INITIAL-AREA-ORIGIN 'REGION-BITS))))) (SETQ PHYS-PAGE (QF-FINDCORE)) (LAM-DISK-READ-VIA-NUBUS (QF-GET-DISK-ADR (LDB %%QF-PHT1-VIRTUAL-PAGE-NUMBER ADR)) PHYS-PAGE 1) (OR QF-PHT-CACHE (QF-REFILL-PHT-CACHE)) (LET ((PHT-SIZE (CADR QF-PHT-CACHE))) (DECLARE (FIXNUM PHT-SIZE)) (DO ((HASH (QF-COMPUTE-PAGE-HASH ADR) (+ HASH 2)) (PHT1) (COUNT (LSH PHT-SIZE -1) (1- COUNT))) ((= COUNT 0) ;UGH FINDCORE SHOULD HAVE DELETED (ERROR 'QF-SWAP-IN 'PAGE-HASH-TABLE-FULL 'FAIL-ACT)) (DECLARE (FIXNUM HASH PHT1 PHT2 COUNT)) (AND (>= HASH PHT-SIZE) (SETQ HASH (- HASH PHT-SIZE))) (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH))) (COND ((= 0 (LOGAND 100 PHT1)) ;FOUND HOLE TO PUT NEW PHTE IN (PHYS-MEM-WRITE (+ PHT-ADDR HASH) (if pht-has-data-types (QF-MAKE-Q (+ 101 (QF-MASK-PAGE-NUMBER ADR)) DTP-FIX) (+ 101 (qf-mask-page-number adr)))) (PHYS-MEM-WRITE (+ PHT-ADDR HASH 1) (if pht-has-data-types (QF-MAKE-Q (DPB ACCESS-STATUS-AND-META-BITS %%PHT2-ACCESS-STATUS-AND-META-BITS (DPB PHYS-PAGE %%PHT2-PHYSICAL-PAGE-NUMBER 0)) DTP-FIX) (dpb access-status-and-meta-bits %%pht2-access-status-and-meta-bits (dpb phys-page %%pht2-physical-page-number 0)))) (PHYS-MEM-WRITE (+ PHYS-PAGE (QF-INITIAL-AREA-ORIGIN 'PHYSICAL-PAGE-DATA)) HASH) (OR QF-PAGE-HASH-TABLE-EXTRA-CHECKING-FLAG (RETURN T)) (AND (= 0 (LAM-CHECK-PAGE-HASH-TABLE-ACCESSIBILITY)) (RETURN T)) (PRINT (LIST 'QF-SWAP-IN-SCREW ADR HASH COUNT)) (BREAK 'QF-SWAP-IN-SCREW T) (RETURN T)))))) ) ;(DEFUN QF-GET-DISK-ADR (VIRTUAL-PAGE-NUMBER) ; (LET ((A-VERSION (QF-POINTER (LAM-SYMBOLIC-EXAMINE-REGISTER 'A-VERSION)))) ; (OR QF-PAGE-PARTITION-CACHE ; (LET ((SYMBOL-VERSION ;(LAM-LOOKUP-NAME 'VERSION-NUMBER) ; (and lam-file-symbols-loaded-from ; (send lam-file-symbols-loaded-from :version)))) ; (WHEN (AND (NEQ A-VERSION SYMBOL-VERSION) ;symbol version can be NIL, ; (FQUERY NIL "~&Microcode ~D is running but you have the symbols for ~D; ;Type Y to load correct symbols, N to proceed anyway. " ; A-VERSION SYMBOL-VERSION)) ; (LAM-LOAD-UCODE-SYMBOLS-FOR-VERSION A-VERSION) ; (QF-SETUP-Q-FIELDS)) ; (SETQ QF-PAGE-PARTITION-CACHE (LAM-SYMBOLIC-EXAMINE-REGISTER 'A-DISK-OFFSET)) ; (SETQ QF-PAGE-PARTITION-CACHE-MAXIMUM ;maximum is relative. i.e. actual value ; ;is size of paging partition ; (LAM-SYMBOLIC-EXAMINE-REGISTER 'A-DISK-MAXIMUM))))) ; (COND ((> QF-PAGE-PARTITION-CACHE-MAXIMUM 1_17.) ; (FERROR NIL "DISK PARTITION TOO BIG CHECK FAILS!!!"))) ; (IF (NOT (< VIRTUAL-PAGE-NUMBER QF-PAGE-PARTITION-CACHE-MAXIMUM)) ; (FERROR NIL "VIRTUAL PAGE FALLS OUTSIDE PAGING BAND!!")) ; (+ VIRTUAL-PAGE-NUMBER ; QF-PAGE-PARTITION-CACHE)) (DEFUN QF-GET-DISK-ADR (VIRTUAL-PAGE-NUMBER) (OR QF-PAGE-PARTITION-CACHE (LET* ((A-VERSION (QF-POINTER (LAM-SYMBOLIC-EXAMINE-REGISTER 'A-VERSION))) (SYMBOL-VERSION ;(LAM-LOOKUP-NAME 'VERSION-NUMBER) (and lam-file-symbols-loaded-from (send lam-file-symbols-loaded-from :version)))) (WHEN (AND (NEQ A-VERSION SYMBOL-VERSION) ;symbol version can be NIL, (FQUERY NIL "~&Microcode ~D is running but you have the symbols for ~D; Type Y to load correct symbols, N to proceed anyway. " A-VERSION SYMBOL-VERSION)) (LAM-LOAD-UCODE-SYMBOLS-FOR-VERSION A-VERSION) (QF-SETUP-Q-FIELDS)) ;;; look at the processor switches of the lambda being debugged. ;;; if quantum map booting in enabled then use the virtual page number ;;; to look up in the quantum map and find out what partition to look in. ;;; look in that entry of the partition table and eventually compute the disk address. )) (cond ((ldb-test %%processor-switch-fast-boot-enable ;did it fast-boot? (lam-symbolic-examine-register 'a-processor-switches)) (setq qf-page-partition-cache t) ;so above doesn't think about loading symbols again (let* ((quantum-map-base (lam-symbolic-examine-register 'a-v-quantum-map)) (tem (+ quantum-map-base (* page-size %quantum-map-offset-in-tables) (* 2 (ldb %%virtual-page-quantum-number virtual-page-number)))) ;2 words per entry pq1 pq2 pt1 pt2) (setq pq1 (qf-mem-read tem) pq2 (qf-mem-read (1+ tem))) ;;; first check quantum validity (unless (and (ldb-test %%pq1-quantum-is-valid pq1) (not (ldb-test %%pq1-quantum-is-device pq1))) (ferror nil "virtual page ~o is not in a memory quantum" virtual-page-number)) (setq tem (+ quantum-map-base (* page-size %partition-table-offset-in-tables) (* 2 (ldb %%pq2m-partition-number pq2)))) ;2 words per entry (setq pt1 (qf-mem-read tem) pt2 (qf-mem-read (1+ tem))) (unless (ldb-test %%pt1-valid pt1) (ferror nil "quantum map points to invalid partition")) ;;; maybe should also do some bounds checking (+ pt2 ;(ldb %%pt2-offset pt2) ;where the partition is on the disk (ldb %%pq1m-page-offset pq1) ;where the quantum is in the partition (ldb #o0006 virtual-page-number)) ;where the page is in the quantum )) (t (SETQ QF-PAGE-PARTITION-CACHE (LAM-SYMBOLIC-EXAMINE-REGISTER 'A-DISK-OFFSET)) (SETQ QF-PAGE-PARTITION-CACHE-MAXIMUM ;maximum is relative. i.e. actual value ;is size of paging partition (LAM-SYMBOLIC-EXAMINE-REGISTER 'A-DISK-MAXIMUM)) (COND ((> QF-PAGE-PARTITION-CACHE-MAXIMUM 1_17.) (FERROR NIL "DISK PARTITION TOO BIG CHECK FAILS!!!"))) (IF (NOT (< VIRTUAL-PAGE-NUMBER QF-PAGE-PARTITION-CACHE-MAXIMUM)) (FERROR NIL "VIRTUAL PAGE FALLS OUTSIDE PAGING BAND!!")) (+ VIRTUAL-PAGE-NUMBER QF-PAGE-PARTITION-CACHE)))) ;THIS READS ANY KIND OF MEMORY WHETHER OR NOT IT IS SWAPPED OUT (DEFUN QF-MEM-READ (ADR) "Return contents of virtual memory address ADR as a bignum, swapping if necessary." (PROG (DATA) (DECLARE (FIXNUM DATA)) (SETQ DATA (QF-VIRTUAL-MEM-READ ADR)) (COND ((< DATA 0) (QF-SWAP-IN ADR) (SETQ DATA (QF-VIRTUAL-MEM-READ ADR)))) (AND (< DATA 0) (ERROR 'QF-MEM-READ-INACCESSIBLE ADR 'FAIL-ACT)) (RETURN DATA))) (DEFUN QF-MEM-READ-TRANSPORT (ADR &optional inhibit-forwarding-messages) "Return contents of memory address ADR as a bignum, swapping or forwarding if nec." (LET (DATA) (DECLARE (FIXNUM DATA)) (SETQ DATA (QF-VIRTUAL-MEM-READ ADR)) (COND ((< DATA 0) (QF-SWAP-IN ADR) (SETQ DATA (QF-VIRTUAL-MEM-READ ADR)))) (AND (< DATA 0) (ERROR 'QF-MEM-READ-INACCESSIBLE ADR 'FAIL-ACT)) (SELECT (QF-DATA-TYPE DATA) ((DTP-GC-FORWARD DTP-ONE-Q-FORWARD DTP-HEADER-FORWARD DTP-EXTERNAL-VALUE-CELL-POINTER dtp-rplacd-forward) (unless inhibit-forwarding-messages (format t " ~s " (nth (qf-data-type data) q-data-types))) (QF-MEM-READ-TRANSPORT DATA inhibit-forwarding-messages)) (DTP-BODY-FORWARD (unless inhibit-forwarding-messages (format t " BODY-FORWARD ")) (QF-MEM-READ-TRANSPORT (+ (QF-POINTER (- ADR DATA)) (QF-MEM-READ DATA)) inhibit-forwarding-messages)) (T DATA)))) ;compare all words on given page, core versus disk. (DEFUN LAM-COMPARE-VIRTUAL-PAGE (ADR) (SETQ ADR (DPB 0 0010 ADR)) (LET ((PADR (QF-VIRTUAL-MEM-MAP ADR NIL))) (COND ((< PADR 0) (FERROR NIL "adr not accessible")) (T (cond ((not (eq (send *proc* :proc-type) :explorer)) (LAM-DISK-INIT))) (LAM-DISK-WRITE-VIA-NUBUS 1 LAM-DISK-LOWCORE 1) ;Save on block 1 (LAM-DISK-READ-VIA-NUBUS (QF-GET-DISK-ADR (LDB %%QF-PHT1-VIRTUAL-PAGE-NUMBER ADR)) LAM-DISK-LOWCORE 1) (DOTIMES (ADR-WITHIN-PAGE 400) (LET ((VIRTUAL-CONTENTS (PHYS-MEM-READ (+ PADR ADR-WITHIN-PAGE))) (DISK-CONTENTS (PHYS-MEM-READ (DPB LAM-DISK-LOWCORE %%QF-PHT1-VIRTUAL-PAGE-NUMBER ADR-WITHIN-PAGE)))) (COND ((NOT (= VIRTUAL-CONTENTS DISK-CONTENTS)) (FORMAT T "~%ADR ~s: virtual ~s disk ~s" (+ ADR ADR-WITHIN-PAGE) VIRTUAL-CONTENTS DISK-CONTENTS))))) (LAM-DISK-READ-VIA-NUBUS 1 LAM-DISK-LOWCORE 1) ;Restore saved core ))) ) ;SMASH CORE PAGE FROM DISK COPY. (DEFUN LAM-SMASH-VIRTUAL-PAGE-FROM-DISK (ADR) (SETQ ADR (DPB 0 0010 ADR)) (LET ((PADR (QF-VIRTUAL-MEM-MAP ADR NIL))) (COND ((< PADR 0) (FERROR NIL "adr not accessible")) (T (LAM-DISK-INIT) (LAM-DISK-WRITE-VIA-NUBUS 1 LAM-DISK-LOWCORE 1) ;Save on block 1 (LAM-DISK-READ-VIA-NUBUS (QF-GET-DISK-ADR (LDB %%QF-PHT1-VIRTUAL-PAGE-NUMBER ADR)) LAM-DISK-LOWCORE 1) (DOTIMES (ADR-WITHIN-PAGE 400) (LET ((DISK-CONTENTS (PHYS-MEM-READ (DPB LAM-DISK-LOWCORE %%QF-PHT1-VIRTUAL-PAGE-NUMBER ADR-WITHIN-PAGE)))) (PHYS-MEM-WRITE (+ PADR ADR-WITHIN-PAGE) DISK-CONTENTS))) (LAM-DISK-READ-VIA-NUBUS 1 LAM-DISK-LOWCORE 1) ;Restore saved core ))) ) ;return disk contents whether swapped in or not. (DEFUN QF-MEM-READ-DISK-COPY (ADR) (PROG (DATA) (DECLARE (FIXNUM DATA)) (LAM-DISK-INIT) (LAM-DISK-WRITE-VIA-NUBUS 1 LAM-DISK-LOWCORE 1) ;Save on block 1 (LAM-DISK-READ-VIA-NUBUS (QF-GET-DISK-ADR (LDB %%QF-PHT1-VIRTUAL-PAGE-NUMBER ADR)) LAM-DISK-LOWCORE 1) (SETQ DATA (PHYS-MEM-READ (DPB LAM-DISK-LOWCORE %%QF-PHT1-VIRTUAL-PAGE-NUMBER ADR))) (LAM-DISK-READ-VIA-NUBUS 1 LAM-DISK-LOWCORE 1) ;Restore saved core (RETURN DATA) )) (DEFUN QF-MEM-WRITE (ADR DATA) "Stores DATA, a positive bignum, into virt address ADR of debugged machine. Swaps in ADR if necessary." (COND ((< (QF-VIRTUAL-MEM-WRITE ADR DATA) 0) (QF-SWAP-IN ADR) (AND (< (QF-VIRTUAL-MEM-WRITE ADR DATA) 0) (ERROR 'QF-MEM-WRITE-INACCESSIBLE ADR 'FAIL-ACT))))) (DEFUN QF-AREA-NUMBER-OF-POINTER (PNTR) (setq pntr (qf-pointer pntr)) (cond ((>= pntr qf-io-space-virtual-address) 'multibus) ((>= pntr qf-multibus-virtual-address) 'io-space) ((>= pntr qf-a-memory-virtual-address) 'a-mem) (t (qf-pointer (qf-mem-read (+ (qf-initial-area-origin 'region-area-map) (qf-region-number-of-pointer pntr)))) ; (DO ((REGION (QF-REGION-NUMBER-OF-POINTER PNTR) ; (QF-POINTER (QF-MEM-READ (+ REGION-THREAD REGION)))) ; (REGION-THREAD (QF-INITIAL-AREA-ORIGIN 'REGION-LIST-THREAD)) ; (C 256. (1- C))) ; ((NOT (ZEROP (LOGAND (ASH 1 (1- %%QF-POINTER)) REGION))) ; (LOGAND (1- (ASH 1 (1- %%QF-POINTER))) REGION)) ; ; (format t "~%region ~s, region-thread ~s" region region-thread) ; (COND ((ZEROP C) (FERROR NIL "REGION THREAD FOR REGION ~S FAILS TO TERMINATE" ; REGION))) ; ) ))) (defun qf-area-not-dumped-in-band-p (name) (memq name '(micro-code-symbol-area wired-disk-buffer page-table-area physical-page-data micro-code-entry-max-pdl-usage micro-code-paging-area scavenger-queue))) (defun qf-area-valid-length (area-number) (cond ((or (>= area-number (qf-area-number 'working-storage-area)) (not (qf-area-not-dumped-in-band-p (nth area-number (qf-initial-area-list))))) (qf-pointer (qf-virtual-mem-read (+ (qf-initial-area-origin 'region-free-pointer) area-number)))) (t (qf-pointer (qf-virtual-mem-read (+ (qf-initial-area-origin 'region-length) area-number)))))) ;GIVEN A POINTER RETURN THE NUMBER OF THE REGION IT IS IN ;LIKE %REGION-NUMBER ON THE REAL MACHINE (DEFUN QF-REGION-NUMBER-OF-POINTER (PNTR &optional null-ok) (SETQ PNTR (QF-POINTER PNTR)) (cond ((>= pntr qf-io-space-virtual-address) 'multibus) ((>= pntr qf-multibus-virtual-address) 'io-space) ((>= pntr qf-a-memory-virtual-address) 'a-mem) (t (LET ((QUANTUM (TRUNCATE PNTR %ADDRESS-SPACE-QUANTUM-SIZE)) (BYTES-PER-WORD (TRUNCATE 32. lam-%ADDRESS-SPACE-MAP-BYTE-SIZE))) (DECLARE (FIXNUM QUANTUM BYTES-PER-WORD)) (LET ((WORD (PHYS-MEM-READ (+ (QF-INITIAL-AREA-ORIGIN 'ADDRESS-SPACE-MAP) (TRUNCATE QUANTUM BYTES-PER-WORD))))) (DECLARE (FIXNUM WORD)) (SETQ WORD (LOGAND (1- (LSH 1 lam-%ADDRESS-SPACE-MAP-BYTE-SIZE)) (ASH WORD (- (* (\ QUANTUM BYTES-PER-WORD) lam-%ADDRESS-SPACE-MAP-BYTE-SIZE))))) (COND ((NOT (ZEROP WORD)) WORD) (t ;;if we get here, if it is anywhere, it is in an initial area ;;where region-numbers are the same as area numbers (let ((ro (qf-initial-area-origin 'region-origin)) region-base) (DO ((L (QF-INITIAL-AREA-LIST) (CDR L)) (area-number 0 (1+ area-number)) ) ((OR (NULL L) (EQ (CAR L) 'WORKING-STORAGE-AREA)) (if null-ok nil (ferror nil "~%pntr ~s not in any region" pntr))) (setq region-base (qf-pointer (qf-mem-read (+ ro area-number)))) (cond ((and (>= pntr region-base) (< PNTR (+ region-base (qf-area-valid-length area-number)))) (RETURN area-number)))))))))))) ;use this one for extra checking. Can not be called if within QF-SWAP-IN tho. (DEFUN QF-REGION-NUMBER-OF-POINTER-and-check (PNTR &optional null-ok) (SETQ PNTR (QF-POINTER PNTR)) (cond ((>= pntr qf-io-space-virtual-address) 'multibus) ((>= pntr qf-multibus-virtual-address) 'io-space) ((>= pntr qf-a-memory-virtual-address) 'a-mem) (t (LET ((QUANTUM (TRUNCATE PNTR %ADDRESS-SPACE-QUANTUM-SIZE)) (BYTES-PER-WORD (TRUNCATE 32. lam-%ADDRESS-SPACE-MAP-BYTE-SIZE))) (DECLARE (FIXNUM QUANTUM BYTES-PER-WORD)) (LET ((WORD (PHYS-MEM-READ (+ (QF-INITIAL-AREA-ORIGIN 'ADDRESS-SPACE-MAP) (TRUNCATE QUANTUM BYTES-PER-WORD))))) (DECLARE (FIXNUM WORD)) (SETQ WORD (LOGAND (1- (LSH 1 lam-%ADDRESS-SPACE-MAP-BYTE-SIZE)) (ASH WORD (- (* (\ QUANTUM BYTES-PER-WORD) lam-%ADDRESS-SPACE-MAP-BYTE-SIZE))))) (COND ((NOT (ZEROP WORD)) (if (qf-region-on-free-list-p word) (format t "~%Warning, pointer ~s was in region ~s according to ~ address-space-map, but that region is on free list -- qf-region-number-of-pointer" pntr word)) (let ((ro (qf-initial-area-origin 'region-origin)) (fp (qf-initial-area-origin 'region-free-pointer)) (tem nil)) (cond ((not (and (>= pntr (setq tem (qf-pointer (qf-mem-read (+ ro word))))) (< pntr (+ tem (qf-pointer (qf-mem-read (+ fp word))))))) (format t "~%Region is ~s according to address-space-map, but that is not within active area according to origin and free-pointer" word)))) WORD) (T (let ((ro (qf-initial-area-origin 'region-origin)) (fp (qf-initial-area-origin 'region-free-pointer)) (tem nil)) (DO ((L (QF-INITIAL-AREA-LIST) (CDR L)) (I 0 (1+ I))) ((OR (NULL L) (EQ (CAR L) 'WORKING-STORAGE-AREA)) (if null-ok nil (ferror nil "~%pntr ~s not in any region -- qf-region-number-of-pointer" pntr))) (cond ((and (>= pntr (setq tem (qf-pointer (qf-mem-read (+ ro i))))) (< PNTR (+ tem (qf-pointer (qf-mem-read (+ fp i)))))) (format t "~%Region is not in address space map but seems to be ~s according to region origins" i) (RETURN I)))))))))))) (defvar *ignore-region-free-list-warnings* t) (defun qf-region-on-free-list-p (region) (let ((fl (qf-pointer (phys-mem-read (+ 400 %SYS-COM-FREE-REGION/#-LIST)))) (n-r (qf-pointer (phys-mem-read (+ 400 %sys-com-number-regions)))) (REGION-THREAD (QF-INITIAL-AREA-ORIGIN 'REGION-LIST-THREAD))) (do ((count 0 (1+ count))) ((zerop fl) nil) (when (> count n-r) (cond (*ignore-region-free-list-warnings* (format t "~%region free list circular") (return nil)) (t (ferror nil "region free list circular")))) (if (= region fl) (return t)) (when (> fl n-r) (cond (*ignore-region-free-list-warnings* (format t "~%region free list has ~s, which is too big" fl) (return nil)) (t (ferror nil "region free list has ~s, which is too big" fl)))) (setq fl (qf-pointer (qf-mem-read (+ fl region-thread))))))) (defun qf-print-region-free-list () (let ((fl (qf-pointer (phys-mem-read (+ 400 %SYS-COM-FREE-REGION/#-LIST)))) (n-r (qf-pointer (phys-mem-read (+ 400 %sys-com-number-regions)))) (REGION-THREAD (QF-INITIAL-AREA-ORIGIN 'REGION-LIST-THREAD))) (do ((count 0 (1+ count))) ((zerop fl) nil) (if (> count n-r) (ferror nil "region free list screwwed up")) (format t "~%region ~s" fl) (when (> fl n-r) (ferror nil "region free list has ~s, which is too big" fl)) (setq fl (qf-pointer (qf-mem-read (+ fl region-thread))))))) (defun qf-print-area-free-list () (let ((start (qf-pointer (phys-mem-read (+ 400 %sys-com-free-area#-list)))) (area-thread (qf-initial-area-origin 'area-region-list)) (number-areas (qf-pointer (phys-mem-read (+ 400 %sys-com-number-areas))))) (do ((thread start (qf-pointer (qf-mem-read (+ area-thread thread)))) (count number-areas (1- count))) ((zerop count) (ferror nil "area free list screwed up")) (when (zerop thread) (return-from qf-print-area-free-list '())) (when (> thread number-areas) (ferror nil "area free list has ~s, which is too big" thread)) (format t "~%area ~s" thread)))) ;;; OBARRAY STUFF ;Symbol in this machine in; returns a symbol in debugged machine, as fixnum, ;or -1 if symbol does not exist. (DEFUN QF-SYMBOL (THIS-MACHINE-SYMBOL) (COND ((AND (EQ (GET THIS-MACHINE-SYMBOL 'REAL-MACHINE-ATOM-HEADER-POINTER-VERSION) QF-CACHE-VERSION) (LET ((PACK (PHYS-MEM-READ (+ 400 %SYS-COM-OBARRAY-PNTR)))) (EQ PACK (GET THIS-MACHINE-SYMBOL 'REAL-MACHINE-ATOM-HEADER-PACKAGE))) (GET THIS-MACHINE-SYMBOL 'REAL-MACHINE-ATOM-HEADER-POINTER))) (T (QF-SYMBOL-INTERNAL THIS-MACHINE-SYMBOL (QF-FIND-PACKAGE (INTERN (DONT-OPTIMIZE (si:PKG-NAME (SYMBOL-PACKAGE THIS-MACHINE-SYMBOL))))) THIS-MACHINE-SYMBOL)))) (DEFUN QF-CURRENT-PACKAGE () "Returns the debugged machine's current package (as a number)." (LET ((PKG (PHYS-MEM-READ (+ 400 %SYS-COM-OBARRAY-PNTR)))) (DO () ((OR (NOT (= (QF-DATA-TYPE PKG) DTP-SYMBOL)) (= PKG QF-NIL))) (SETQ PKG (QF-VALUE-CELL-CONTENTS PKG))) PKG)) (DEFUN QF-SYMBOL1 (THIS-MACHINE-SYMBOL PACK) (COND ((AND (EQ (GET THIS-MACHINE-SYMBOL 'REAL-MACHINE-ATOM-HEADER-POINTER-VERSION) QF-CACHE-VERSION) (EQ PACK (GET THIS-MACHINE-SYMBOL 'REAL-MACHINE-ATOM-HEADER-PACKAGE)) (GET THIS-MACHINE-SYMBOL 'REAL-MACHINE-ATOM-HEADER-POINTER))) (T (QF-SYMBOL-INTERNAL THIS-MACHINE-SYMBOL PACK THIS-MACHINE-SYMBOL)))) (DEFUN QF-SYMBOL-INTERNAL (PNAME PACK THIS-MACHINE-SYMBOL) (PROG NIL (COND ((MINUSP PACK) (RETURN (COND ((Y-OR-N-P "PACKAGE NOT FOUND, SEARCH ALL PACKAGES?") (QF-SEARCH-ALL-PACKAGES-FOR-SYMBOL PNAME THIS-MACHINE-SYMBOL)) (T (FERROR NIL ""))))) ((= (QF-DATA-TYPE PACK) DTP-SYMBOL) (SETQ PACK (QF-VALUE-CELL-CONTENTS PACK)))) (COND ((= (QF-DATA-TYPE PACK) DTP-NULL) (FERROR NIL "OBARRAY NOT SET UP YET, YOU LOSE"))) (RETURN (QF-SYMBOL-SEARCH PNAME PACK THIS-MACHINE-SYMBOL)))) (DEFUN QF-SEARCH-ALL-PACKAGES-FOR-SYMBOL (PNAME &OPTIONAL THIS-MACHINE-SYMBOL) (COND ((SYMBOLP PNAME) (SETQ THIS-MACHINE-SYMBOL PNAME PNAME (GET-PNAME PNAME)))) (COND ((NULL THIS-MACHINE-SYMBOL) (SETQ THIS-MACHINE-SYMBOL (INTERN PNAME)))) (LET* ((CPACK (QF-CURRENT-PACKAGE)) (ALL-PACK-SYM (QF-PKG-ALL-PACKAGES-POINTER CPACK)) (ALL-PACK-LIST (qf-typed-pointer (QF-MEM-READ-TRANSPORT (1+ ALL-PACK-SYM))))) (DO ((LIST ALL-PACK-LIST (QF-CDR LIST))) ((QF-NULL LIST) -1) (LET ((TEM (QF-SYMBOL-SEARCH PNAME (QF-CAR LIST) THIS-MACHINE-SYMBOL))) (COND ((NOT (MINUSP TEM)) (FORMAT T "~%USE SYMBOL FROM PACKAGE ") (LAM-Q-PRINT-TOPLEV (QF-CAR LIST)) (COND ((Y-OR-N-P "?") (RETURN TEM))))))))) (DEFUN QF-OBARRAY-NEW-P (PACK) pack T) ;; In a new-style package, this is its NAME. (DEFUN QF-PKG-NAME (PACK) (IF (EQ (QF-DATA-TYPE PACK) DTP-SYMBOL) (QF-MAKE-Q (QF-MEM-READ-TRANSPORT PACK) DTP-ARRAY-POINTER) (QF-ARRAY-LEADER PACK 2))) ;; In a new-style package, this is a list (possibly NIL) of nicknames (strings). ;; In an old-style package, it happens to be a string. (DEFUN QF-PKG-NICKNAMES (PACK) (QF-ARRAY-LEADER PACK 3)) ;; In an old style package, this is the superpackage. ;; In a new-style common lisp package, this is a list ;; of packages to inherit from, nonrecursively. (DEFUN QF-PKG-SUPER-PACKAGE (PACK) (QF-ARRAY-LEADER PACK 4)) ;; In a new style package, this slot points to the symbol *ALL-PACKAGES*. (DEFUN QF-PKG-ALL-PACKAGES-POINTER (PACK) (QF-ARRAY-LEADER PACK 5)) ;; Used in old-style packages only. (DEFUN QF-PKG-REFNAME-ALIST (PACK) (QF-ARRAY-LEADER PACK 0)) (DEFUN QF-PKG-NUMBER-OF-SLOTS (PACK) (ASH (QF-ARRAY-LENGTH PACK) -1)) ;SEARCH A SPECIFIED PACKAGE AND ITS SUPERIORS FOR A SYMBOL. (DEFUN QF-SYMBOL-SEARCH (SYM PACK THIS-MACHINE-SYMBOL) (IF (= (QF-DATA-TYPE (QF-PKG-SUPER-PACKAGE PACK)) DTP-ARRAY-POINTER) (DO ((PKG PACK (QF-PKG-SUPER-PACKAGE PKG)) (TEM)) ((QF-NULL PKG) -1) (SETQ TEM (QF-SYMBOL-PKG SYM PKG THIS-MACHINE-SYMBOL)) (OR (= TEM -1) (RETURN TEM))) ;; New style package with list of other packages to inherit from. (LET ((TEM (QF-SYMBOL-PKG SYM PACK THIS-MACHINE-SYMBOL))) (IF ( TEM -1) TEM (DO ((PKGS (QF-PKG-SUPER-PACKAGE PACK) (QF-CDR PKGS))) ((QF-NULL PKGS) -1) (LET* ((PKG (QF-CAR PKGS)) (TEM (QF-SYMBOL-PKG SYM PKG THIS-MACHINE-SYMBOL T))) (OR (= TEM -1) (RETURN TEM)))))))) ;LOOK A SYMBOL UP IN A NEW-STYLE OBARRAY. (DEFUN QF-SYMBOL-PKG (SYM PACK THIS-MACHINE-SYMBOL &OPTIONAL EXTERNAL-ONLY) (DECLARE (FIXNUM PACK)) (DO () ((NOT (= DTP-HEADER-FORWARD (QF-DATA-TYPE (QF-MEM-READ PACK))))) (SETQ PACK (QF-MAKE-Q (QF-POINTER (QF-MEM-READ PACK)) DTP-ARRAY-POINTER))) (LET ((HASH (QF-PKG-HASH-STRING SYM)) (LEN (QF-PKG-NUMBER-OF-SLOTS PACK)) (HASH1 0)) (DO ((I (\ HASH LEN) (\ (1+ I) LEN))) (NIL) (SETQ HASH1 (QF-PKG-AR-2 PACK 0 I)) (AND (QF-NULL HASH1) (RETURN -1)) (AND (= HASH (QF-POINTER-SANS-BOXED-SIGN-BIT HASH1)) (OR (NOT EXTERNAL-ONLY) (NOT (ZEROP (ASH (QF-POINTER HASH1) (- 1 %%QF-POINTER))))) (QF-SAMEPNAMEP SYM (QF-PKG-AR-2 PACK 1 I)) (PROGN (PUTPROP THIS-MACHINE-SYMBOL QF-CACHE-VERSION 'REAL-MACHINE-ATOM-HEADER-POINTER-VERSION) (PUTPROP THIS-MACHINE-SYMBOL PACK 'REAL-MACHINE-ATOM-HEADER-PACKAGE) (RETURN (PUTPROP THIS-MACHINE-SYMBOL (QF-PKG-AR-2 PACK 1 I) 'REAL-MACHINE-ATOM-HEADER-POINTER))))))) (DEFUN QF-SYMBOL-SEARCH-ALL (THIS-MACHINE-SYMBOL) (COND ((AND (EQ (GET THIS-MACHINE-SYMBOL 'REAL-MACHINE-ATOM-HEADER-POINTER-VERSION) QF-CACHE-VERSION) (LET ((PACK (PHYS-MEM-READ (+ 400 %SYS-COM-OBARRAY-PNTR)))) (EQ PACK (GET THIS-MACHINE-SYMBOL 'REAL-MACHINE-ATOM-HEADER-PACKAGE))) (GET THIS-MACHINE-SYMBOL 'REAL-MACHINE-ATOM-HEADER-POINTER))) (T (QF-SYMBOL-INTERNAL-SEARCH-ALL THIS-MACHINE-SYMBOL (QF-FIND-PACKAGE (INTERN (DONT-OPTIMIZE (si:PKG-NAME (SYMBOL-PACKAGE THIS-MACHINE-SYMBOL))))) THIS-MACHINE-SYMBOL)))) (DEFUN QF-SYMBOL-INTERNAL-SEARCH-all (PNAME PACK THIS-MACHINE-SYMBOL) (PROG NIL (COND ((MINUSP PACK) (RETURN (COND ((Y-OR-N-P "PACKAGE NOT FOUND, SEARCH ALL PACKAGES?") (QF-SEARCH-ALL-PACKAGES-FOR-SYMBOL PNAME THIS-MACHINE-SYMBOL)) (T (FERROR NIL ""))))) ((= (QF-DATA-TYPE PACK) DTP-SYMBOL) (SETQ PACK (QF-VALUE-CELL-CONTENTS PACK)))) (COND ((= (QF-DATA-TYPE PACK) DTP-NULL) (FERROR NIL "OBARRAY NOT SET UP YET, YOU LOSE"))) (RETURN (QF-SYMBOL-SEARCH-search-all PNAME PACK THIS-MACHINE-SYMBOL)))) (DEFUN QF-SYMBOL-SEARCH-SEARCH-ALL (SYM PACK THIS-MACHINE-SYMBOL) ;; New style package with list of other packages to inherit from. (LET ((TEM (QF-SYMBOL-PKG-SEARCH-ALL SYM PACK THIS-MACHINE-SYMBOL))) (IF ( TEM -1) TEM (DO ((PKGS (QF-PKG-SUPER-PACKAGE PACK) (QF-CDR PKGS))) ((QF-NULL PKGS) -1) (LET* ((PKG (QF-CAR PKGS)) (TEM (QF-SYMBOL-PKG-SEARCH-ALL SYM PKG THIS-MACHINE-SYMBOL))) (OR (= TEM -1) (RETURN TEM))))))) (DEFUN QF-SYMBOL-PKG-SEARCH-ALL (SYM PACK THIS-MACHINE-SYMBOL) (DECLARE (FIXNUM PACK)) (DO () ((NOT (= DTP-HEADER-FORWARD (QF-DATA-TYPE (QF-MEM-READ PACK))))) (SETQ PACK (QF-MAKE-Q (QF-POINTER (QF-MEM-READ PACK)) DTP-ARRAY-POINTER))) (LET ((LEN (QF-PKG-NUMBER-OF-SLOTS PACK)) (HASH1 0)) (DO ((I 0 (1+ I))) ((= i len) (return -1)) (SETQ HASH1 (QF-PKG-AR-2 PACK 0 I)) (cond ((QF-NULL HASH1)) ((QF-SAMEPNAMEP SYM (QF-PKG-AR-2 PACK 1 I)) (PUTPROP THIS-MACHINE-SYMBOL QF-CACHE-VERSION 'REAL-MACHINE-ATOM-HEADER-POINTER-VERSION) (PUTPROP THIS-MACHINE-SYMBOL PACK 'REAL-MACHINE-ATOM-HEADER-PACKAGE) (RETURN (PUTPROP THIS-MACHINE-SYMBOL (QF-PKG-AR-2 PACK 1 I) 'REAL-MACHINE-ATOM-HEADER-POINTER))))))) (DEFUN QF-PRINT-SYMBOLS-IN-PACKAGE (PACKAGE) (LET ((PACK (QF-FIND-PACKAGE 'SI:GLOBAL))) (DO () ((NOT (= DTP-HEADER-FORWARD (QF-DATA-TYPE (QF-MEM-READ PACK))))) (FORMAT T " PACKAGE FORWARDED ") (SETQ PACK (QF-MAKE-Q (QF-POINTER (QF-MEM-READ PACK)) DTP-ARRAY-POINTER))) (FORMAT T "~%LOOKING IN PACKAGE ") (LAM-Q-PRINT-TOPLEV PACK) (LAM-Q-PRINT-TOPLEV (QF-PKG-NAME PACK)) (LET ((LEN (QF-PKG-NUMBER-OF-SLOTS PACK)) (HASH1 0)) (DO ((I 0 (1+ I))) ((= i len) (return -1)) (SETQ HASH1 (QF-PKG-AR-2 PACK 0 I)) (cond ((QF-NULL HASH1)) (T (LET ((SYM (QF-PKG-AR-2 PACK 1 I))) (LAM-Q-PRINT-TOPLEV SYM) (FORMAT T " WITH HASH ~S~%" HASH1)))))) PACK)) (DEFUN QF-PKG-AR-2 (Q I J) (QF-ARRAY-SETUP Q) (QF-TYPED-POINTER (QF-ARRAY-READ (QF-ARRAY-DISPLACE (+ (* J 2) I))))) (DEFUN QF-FIND-PACKAGE (MSYMBOL) (COND ((AND (EQ (GET MSYMBOL 'REAL-MACHINE-PACKAGE-POINTER-VERSION) QF-CACHE-VERSION) (GET MSYMBOL 'REAL-MACHINE-PACKAGE-POINTER))) (T (LET ((PACK (PHYS-MEM-READ (+ 400 %SYS-COM-OBARRAY-PNTR)))) (COND ((= (QF-DATA-TYPE PACK) DTP-SYMBOL) (SETQ PACK (QF-VALUE-CELL-CONTENTS PACK)))) (IF (= (QF-DATA-TYPE PACK) DTP-NULL) -1 (IF (= (QF-DATA-TYPE (QF-PKG-SUPER-PACKAGE PACK)) DTP-ARRAY-POINTER) ;; Old style packages. (PROGN (DO ((P (QF-PKG-SUPER-PACKAGE PACK) (QF-PKG-SUPER-PACKAGE P))) ((NOT (= (QF-DATA-TYPE P) DTP-ARRAY-POINTER))) (SETQ PACK P)) (DO ((R-ALIST (QF-PKG-REFNAME-ALIST PACK) (QF-CDR R-ALIST)) (THIS-CONS)) ((QF-NULL R-ALIST) -1) (SETQ THIS-CONS (QF-CAR R-ALIST)) (COND ((QF-LMSTRING-MSYMBOL-EQUAL (QF-CAR THIS-CONS) MSYMBOL) (LET ((ANSWER (QF-CAR (QF-CDR THIS-CONS)))) (PUTPROP MSYMBOL ANSWER 'REAL-MACHINE-PACKAGE-POINTER) (PUTPROP MSYMBOL QF-CACHE-VERSION 'REAL-MACHINE-PACKAGE-POINTER-VERSION) (RETURN ANSWER)))))) ;; New style. Just look on *ALL-PACKAGES*. ;; We do not allow local nicknames. (LET* ((ALL-PACK-SYM (QF-PKG-ALL-PACKAGES-POINTER PACK)) (ALL-PACK-LIST (QF-MEM-READ-TRANSPORT (1+ ALL-PACK-SYM)))) (DO ((LIST ALL-PACK-LIST (QF-CDR LIST))) ((QF-NULL LIST) -1) (LET ((P (QF-CAR LIST))) (WHEN (OR (QF-LMSTRING-MSYMBOL-EQUAL (QF-PKG-NAME P) MSYMBOL) (DO ((NICKS (QF-PKG-NICKNAMES P) (QF-CDR NICKS))) ((QF-NULL NICKS)) (WHEN (QF-LMSTRING-MSYMBOL-EQUAL (QF-CAR NICKS) MSYMBOL) (RETURN T)))) (PUTPROP MSYMBOL P 'REAL-MACHINE-PACKAGE-POINTER) (PUTPROP MSYMBOL QF-CACHE-VERSION 'REAL-MACHINE-PACKAGE-POINTER-VERSION) (RETURN P))))))))))) ;TAKE A THIS-MACHINE SYMBOL AND FIGURE OUT WHAT PKG-HASH-STRING WOULD DO ;WITH A SYMBOL OF THAT NAME. ;We do not call %SXHASH-STRING so we can win if it is changed! (DEFUN QF-PKG-HASH-STRING (SYM &AUX PNAME) (SETQ PNAME (COND ((SYMBOLP SYM) (GET-PNAME SYM)) (T SYM))) (DO ((I 0 (1+ I)) (N (ARRAY-ACTIVE-LENGTH PNAME)) (HASH 0)) (( I N) (IF (BIT-TEST (ASH 1 23.) HASH) (LOGXOR 1 (LDB 23. (QF-POINTER-SANS-BOXED-SIGN-BIT HASH))) ;-37777777 = 40000001 HASH)) (SETQ HASH (ASH (LOGXOR (AREF PNAME I) HASH) 7)) (SETQ HASH (LOGIOR (LOAD-BYTE HASH 24. 7) (LOGAND (1- 1_24.) HASH))))) ;DOESN'T TRY TO WIN FOR HAIRY FONT CHANGES ETC. (DEFUN QF-LM-STRING-EQUAL (STRING1 STRING2 LEN2) (DECLARE (FIXNUM STRING1 LEN1 STRING2 LEN2 WD1 WD2 IDX CHNUM)) (QF-TRANSPORT-HEADER STRING1) (QF-TRANSPORT-HEADER STRING2) ((LAMBDA (LEN1) (COND ((NOT (= LEN1 LEN2)) NIL) ((DO ((IDX 0 (1+ IDX)) (CHNUM) (WD1) (WD2)) ((NOT (< IDX LEN1)) T) (COND ((= 0 (SETQ CHNUM (LOGAND 3 IDX))) (SETQ WD1 (QF-MEM-READ (SETQ STRING1 (1+ STRING1)))) (SETQ WD2 (QF-MEM-READ (SETQ STRING2 (1+ STRING2)))))) (OR (= (LOGAND 377 (LSH WD1 (SETQ CHNUM (* -8 CHNUM)))) (LOGAND 377 (LSH WD2 CHNUM))) (RETURN NIL)) )))) (QF-ARRAY-ACTIVE-LENGTH STRING1))) (DEFUN QF-SAMEPNAMEP (LISPSYMB QSYMBPTR) (DECLARE (FIXNUM QSYMBPTR)) (QF-LMSTRING-MSYMBOL-EQUAL (QF-MEM-READ-TRANSPORT QSYMBPTR) LISPSYMB)) (DEFUN QF-LMSTRING-MSYMBOL-EQUAL (CONS-PNAME-PNTR LISPSYMB &AUX PNAME) (SETQ PNAME (COND ((SYMBOLP LISPSYMB) (GET-PNAME LISPSYMB)) (T LISPSYMB))) (LET (LEN ARRAY-HEAD) (QF-TRANSPORT-HEADER CONS-PNAME-PNTR) (SETQ ARRAY-HEAD (QF-MEM-READ CONS-PNAME-PNTR)) (COND ((NOT (= 0 (LDB %%ARRAY-LEADER-BIT ARRAY-HEAD))) (SETQ LEN (QF-POINTER (QF-MEM-READ (- CONS-PNAME-PNTR 2))))) ((= 0 (LDB %%ARRAY-LONG-LENGTH-FLAG ARRAY-HEAD)) (SETQ LEN (LDB %%ARRAY-INDEX-LENGTH-IF-SHORT ARRAY-HEAD))) ((SETQ LEN (QF-POINTER (QF-MEM-READ (SETQ CONS-PNAME-PNTR (1+ CONS-PNAME-PNTR))))))) (AND (= (LENGTH PNAME) LEN) (DO ((COUNT 0 (1+ COUNT)) (WD-NUM 0) (WD) (CH) (LCH) (PORTION 0 (1+ PORTION))) ((>= COUNT LEN) T) (AND (= 0 PORTION) (SETQ WD (QF-MEM-READ (+ (SETQ WD-NUM (1+ WD-NUM)) CONS-PNAME-PNTR)))) (SETQ CH (LOGAND 377 WD)) (SETQ WD (ASH WD -8)) (AND (= 0 (SETQ LCH (AREF PNAME COUNT))) (RETURN NIL)) (COND ((NOT (= LCH CH)) (RETURN NIL)) ((= 3 PORTION) (SETQ PORTION -1))) ) )) ) (DEFUN QF-APROPOS (STRING) (PROG (ADR HEADER) (SETQ ADR (QF-INITIAL-AREA-ORIGIN 'NR-SYM)) L (SETQ HEADER (QF-MEM-READ ADR)) (COND ((NOT (= (QF-DATA-TYPE HEADER) DTP-SYMBOL-HEADER)) (RETURN NIL)) ((STRING-SEARCH STRING (QF-FETCH-STRING HEADER)) (FORMAT T "~%Virt adr ~S " ADR) (LAM-Q-PRINT-TOPLEV (QF-MAKE-Q ADR DTP-SYMBOL)))) (SETQ ADR (+ LENGTH-OF-ATOM-HEAD ADR)) (GO L))) (DEFUN QF-FETCH-STRING (HEAD-ADR) (QF-ARRAY-SETUP (QF-MAKE-Q (QF-POINTER HEAD-ADR) DTP-ARRAY-POINTER)) (LET* ((LEN (COND (QF-ARRAY-HAS-LEADER-P (QF-POINTER (QF-MEM-READ (- QF-ARRAY-HEADER-ADDRESS 2)))) (T QF-ARRAY-LENGTH))) (STR (MAKE-ARRAY NIL ART-STRING LEN))) (DO ((I 0 (1+ I)) (ADR QF-ARRAY-DATA-ORIGIN) (CH) (WD)) ((= I LEN) STR) (COND ((ZEROP (LOGAND 3 I)) ;Get next word (SETQ WD (QF-MEM-READ ADR) ADR (1+ ADR)))) (SETQ CH (LOGAND 377 WD) WD (ASH WD -8)) (AS-1 CH STR I)))) (DEFUN QF-SXHASH-STRING (STRING) (DO ((I 0 (1+ I)) (N (ARRAY-ACTIVE-LENGTH STRING)) (HASH 0)) (( I N) (IF (MINUSP HASH) (LOGXOR HASH -37777777) ;-37777777 = 40000001 HASH)) (SETQ HASH (ROT (LOGXOR (LOGAND (AREF STRING I) 337) HASH) 7)))) ;;;BASIC OPERATIONS ;;; Note that if we have a pointer to old-space, either it has not been copied ;;; out of oldspace yet and that is OK, or there is a GC-forwarding pointer there ;;; which we will end up chasing. EQ, however, is not well-defined in QF ;;; because of not really grokking old-space. At least NIL is in a static area. (DEFUN QF-CAR (LMOB &optional inhibit-forwarding-messages) (LET ((TYPE (QF-DATA-TYPE LMOB))) (cond ((or (= TYPE DTP-LIST) (= TYPE DTP-LOCATIVE) (= TYPE DTP-CLOSURE) ; (= type dtp-stack-closure) (= TYPE DTP-ENTITY)) (QF-TYPED-POINTER (QF-MEM-READ-TRANSPORT LMOB inhibit-forwarding-messages))) ((and (= type dtp-symbol) (zerop (qf-pointer lmob))) lmob) ((= type dtp-gc-forward) (unless inhibit-forwarding-messages (format t " GC-FORWARD ")) (qf-car (qf-typed-pointer (qf-mem-read-transport lmob inhibit-forwarding-messages)) inhibit-forwarding-messages)) (t (ferror nil "Neither a cons nor a locative -- QF-CAR: ~s" LMOB))))) (DEFUN QF-CDR (LMOB &optional inhibit-forwarding-messages) (LET ((TYPE (QF-DATA-TYPE LMOB))(L LMOB)) (SELECT TYPE (DTP-LOCATIVE (QF-CAR LMOB)) ((DTP-LIST DTP-CLOSURE DTP-ENTITY) ;once included DTP-STACK-CLOSURE (LET ((CDRC (QF-CDR-CODE (DO ((X (QF-MEM-READ LMOB) (QF-MEM-READ L))) (NIL) (SELECT (QF-DATA-TYPE X) ((DTP-HEADER-FORWARD DTP-GC-FORWARD DTP-RPLACD-FORWARD) (unless inhibit-forwarding-messages (format t " ~s " (nth (qf-data-type x) q-data-types))) (SETQ L X)) (OTHERWISE (RETURN X))))))) (LET ((X (SELECT CDRC (cdr-normal (QF-MEM-READ (1+ L))) ;FULL CONS (cdr-error (ERROR '|CDR-ERROR encountered - QF-CDR| LMOB 'FAIL-ACT)) (cdr-nil QF-NIL) ;CDR NIL (cdr-next (1+ L)) (OTHERWISE (ERROR '|Lose big -- QF-CDR|))))) (DO ((X X (QF-MEM-READ X)) (ADR L X)) (NIL) (SELECT (QF-DATA-TYPE X) ((DTP-HEADER-FORWARD DTP-GC-FORWARD dtp-rplacd-forward DTP-ONE-Q-FORWARD DTP-EXTERNAL-VALUE-CELL-POINTER) (unless inhibit-forwarding-messages (format t " ~s " (nth (qf-data-type x) q-data-types))) NIL) (DTP-BODY-FORWARD (unless inhibit-forwarding-messages (format t " BODY-FORWARD ")) (LET ((OFFSET (- (QF-POINTER ADR) (QF-POINTER X)))) (SETQ X (+ (QF-MEM-READ X) OFFSET)))) (OTHERWISE (RETURN (QF-TYPED-POINTER X)))))))) (DTP-SYMBOL (cond ((and (= type dtp-symbol) (zerop (qf-pointer lmob))) lmob) (t (ferror nil "non-NIL symbol -- QF-CDR: ~s" LMOB)))) (dtp-gc-forward (unless inhibit-forwarding-messages (format t " GC-FORWARD ")) (qf-cdr (qf-typed-pointer (qf-mem-read-transport lmob inhibit-forwarding-messages)))) (OTHERWISE (ferror nil "Neither a cons nor a locative -- QF-CDR: ~s" LMOB))))) (DEFUN QF-LISTP (THING) (= (QF-DATA-TYPE THING) DTP-LIST)) (DEFUN QF-MEMQ (ELT LIST) (DO ((TAIL LIST (QF-CDR TAIL))) ((QF-NULL TAIL) NIL) (WHEN (= (QF-CAR TAIL) ELT) (RETURN TAIL)))) (DEFUN QF-GET (LIST-OR-SYMBOL ELT) (LET ((LIST LIST-OR-SYMBOL)) (IF (= (QF-DATA-TYPE LIST) DTP-SYMBOL) (SETQ LIST (QF-PROPERTY-CELL-LOCATION LIST))) (DO ((TAIL (QF-CDR LIST) (QF-CDR (QF-CDR TAIL)))) ((QF-NULL TAIL) QF-NIL) (WHEN (= (QF-CAR TAIL) ELT) (RETURN (QF-CAR (QF-CDR TAIL))))))) (DEFUN QF-GET-FROM-ALTERNATING-LIST (LIST ELT) (DO ((TAIL LIST (QF-CDR (QF-CDR TAIL)))) ((QF-NULL TAIL) QF-NIL) (WHEN (= (QF-CAR TAIL) ELT) (RETURN (QF-CAR (QF-CDR TAIL)))))) (DEFUN QF-ASSQ (ELT LIST) (DO ((TAIL LIST (QF-CDR TAIL))) ((QF-NULL TAIL) NIL) (WHEN (= (QF-CAR (QF-CAR TAIL)) ELT) (RETURN (QF-CAR TAIL))))) (DEFUN QF-NTH (N LIST) (LET ((TEM LIST)) (DOTIMES (I N) (SETQ TEM (QF-CDR TEM))) (QF-CAR TEM))) (DEFUN QF-MAPCAR (FCTN LIST) (IF (QF-NULL LIST) NIL (CONS (FUNCALL FCTN (QF-CAR LIST)) (QF-MAPCAR FCTN (QF-CDR LIST))))) (DEFUN QF-FEF-INITIAL-PC (FEF) (LOGLDB %%FEFH-PC (QF-MEM-READ (+ FEF %FEFHI-IPC)))) (DEFUN QF-FEF-INSTRUCTION (FEF PC) "Given a FEF and a PC, returns the corresponding 16-bit macro instruction. There is no error checking." (LOGLDB (COND ((ZEROP (LOGAND 1 PC)) %%Q-LOW-HALF) (T %%Q-HIGH-HALF)) (QF-MEM-READ (+ FEF (TRUNCATE PC 2))))) (DEFUN QF-FEF-INSTRUCTION-LENGTH (WD FEF PC &AUX OP DISP) "Return the length in halfwords of the instruction at PC in FEF and its effect on the PDL" fef pc (SETQ OP (LDB 1104 WD) ;"old" op field DISP (LDB 0011 WD)) (WHEN (< OP 11) (SETQ OP (LDB 1105 WD))) (COND ((AND (= OP 14) (= DISP 777)) 2) ;branch delta ((AND (or (< OP 14) (and (= op 16) (memq (ldb 1503 wd) '(5 6)))) (= DISP 776)) 2) ;addressible instruction "extension" (T 1))) (DEFUN QF-FEF-LIMIT-PC (FEF &AUX LIM-PC) "Return the pc value of the end of the code of the fef." (SETQ LIM-PC (* 2 (QF-POINTER (QF-MEM-READ (+ FEF %FEFHI-STORAGE-LENGTH))))) (COND ((ZEROP (QF-FEF-INSTRUCTION FEF (1- LIM-PC))) (1- LIM-PC)) (T LIM-PC))) (DEFUN QF-FEF-DEBUGGING-INFO (FEF) (LOGLDB %%QF-TYPED-POINTER (QF-MEM-READ (+ FEF (1- (LOGLDB %%FEFH-PC-IN-WORDS (QF-MEM-READ FEF))))))) (DEFUN QF-FEF-FLAVOR-NAME (FEF) "Return the flavor which the compiled function FEF assumes SELF is an instance of." (AND (NOT (ZEROP (LOGLDB %%FEFH-GET-SELF-MAPPING-TABLE (QF-MEM-READ FEF)))) (QF-TYPED-POINTER (QF-MEM-READ (+ FEF (1- (LOGLDB %%FEFHI-MS-ARG-DESC-ORG (QF-MEM-READ (+ FEF %FEFHI-MISC))))))))) (DEFUN QF-FLAVOR-DECODE-SELF-REF-POINTER (FLAVOR-NAME POINTER-NUMBER) "Decode the pointer field of a DTP-SELF-REF-POINTER. Assumes that it is used with flavor FLAVOR-NAME. Values are an instance variable name and NIL, or a component flavor name and T." (DECLARE (RETURN-LIST INSTANCE-VAR-OR-COMPONENT-FLAVOR T-IF-COMPONENT-FLAVOR)) (LET ((FLAVOR (QF-GET FLAVOR-NAME (QF-SYMBOL 'SI:FLAVOR)))) (COND ((NULL FLAVOR) NIL) ((LDB-TEST %%SELF-REF-MAP-LEADER-FLAG POINTER-NUMBER) (VALUES (QF-NTH (- (LDB %%SELF-REF-INDEX POINTER-NUMBER) 3) (QF-FLAVOR-MAPPED-COMPONENT-FLAVORS FLAVOR)) T)) ((LDB-TEST %%SELF-REF-RELOCATE-FLAG POINTER-NUMBER) (QF-NTH (LDB %%SELF-REF-INDEX POINTER-NUMBER) (QF-FLAVOR-MAPPED-INSTANCE-VARIABLES FLAVOR))) (T (QF-NTH (LDB %%SELF-REF-INDEX POINTER-NUMBER) (QF-FLAVOR-UNMAPPED-INSTANCE-VARIABLES FLAVOR)))))) (DEFUN QF-FLAVOR-UNMAPPED-INSTANCE-VARIABLES (FLAVOR) (QF-GET (QF-MAKE-Q (+ FLAVOR 1 (LAM-GET-DEFSTRUCT-INDEX 'SI:FLAVOR-PLIST 'AREF)) DTP-LOCATIVE) (QF-SYMBOL 'SI:UNMAPPED-INSTANCE-VARIABLES))) (DEFUN QF-FLAVOR-MAPPED-COMPONENT-FLAVORS (FLAVOR) (QF-GET (QF-MAKE-Q (+ FLAVOR 1 (LAM-GET-DEFSTRUCT-INDEX 'SI:FLAVOR-PLIST 'AREF)) DTP-LOCATIVE) (QF-SYMBOL 'SI:MAPPED-COMPONENT-FLAVORS))) (DEFUN QF-FLAVOR-MAPPED-INSTANCE-VARIABLES (FLAVOR) (QF-AR-1 FLAVOR (LAM-GET-DEFSTRUCT-INDEX 'SI:FLAVOR-MAPPED-INSTANCE-VARIABLES 'AREF))) (DEFUN QF-FLAVOR-ALL-INSTANCE-VARIABLES (FLAVOR) (QF-AR-1 FLAVOR (LAM-GET-DEFSTRUCT-INDEX 'SI:FLAVOR-ALL-INSTANCE-VARIABLES 'AREF))) (DEFUN QF-VALUE-CELL-LOCATION (Q) (OR (= (QF-DATA-TYPE Q) DTP-SYMBOL) (ERROR '|NOT SYMBOL - QF-VALUE-CELL-LOCATION| Q 'FAIL-ACT)) (QF-MAKE-Q (1+ Q) DTP-LOCATIVE)) (DEFUN QF-FUNCTION-CELL-LOCATION (Q) (OR (= (QF-DATA-TYPE Q) DTP-SYMBOL) (ERROR '|NOT SYMBOL - QF-FUNCTION-CELL-LOCATION| Q 'FAIL-ACT)) (QF-MAKE-Q (+ 2 Q) DTP-LOCATIVE)) (DEFUN QF-PROPERTY-CELL-LOCATION (Q) (OR (= (QF-DATA-TYPE Q) DTP-SYMBOL) (ERROR '|NOT SYMBOL - QF-PROPERTY-CELL-LOCATION| Q 'FAIL-ACT)) (QF-MAKE-Q (+ 3 Q) DTP-LOCATIVE)) (DEFUN QF-PACKAGE-CELL-LOCATION (Q) (OR (= (QF-DATA-TYPE Q) DTP-SYMBOL) (ERROR '|NOT SYMBOL - QF-PACKAGE-CELL-LOCATION| Q 'FAIL-ACT)) (QF-MAKE-Q (+ 4 Q) DTP-LOCATIVE)) (DEFUN QF-FUNCTION-CELL-CONTENTS (QQ) (AND (TYPEP QQ 'SYMBOL) (SETQ QQ (QF-SYMBOL QQ))) (OR (= (QF-DATA-TYPE QQ) DTP-SYMBOL) (ERROR 'WTA-QF-FUNCTION-CELL-CONTENTS QQ 'FAIL-ACT)) (QF-CAR (QF-FUNCTION-CELL-LOCATION QQ))) (DEFUN QF-VALUE-CELL-CONTENTS (QQ) (AND (TYPEP QQ 'SYMBOL) (SETQ QQ (QF-SYMBOL QQ))) (OR (= (QF-DATA-TYPE QQ) DTP-SYMBOL) (ERROR 'WTA-QF-VALUE-CELL-CONTENTS QQ 'FAIL-ACT)) (QF-CAR (QF-VALUE-CELL-LOCATION QQ))) (DEFUN QF-SYMBOL-PACKAGE (QQ) (AND (TYPEP QQ 'SYMBOL) (SETQ QQ (QF-SYMBOL QQ))) (OR (= (QF-DATA-TYPE QQ) DTP-SYMBOL) (ERROR 'WTA-QF-PACKAGE-CELL-CONTENTS QQ 'FAIL-ACT)) (QF-CAR (QF-PACKAGE-CELL-LOCATION QQ))) ;Kludge to allow incompatible systems to debug each other ;Associate from system major version to initial area list ;The major version is the earliest version with that set of areas (DEFCONST QF-SYSTEM-AREA-LIST-ALIST '( ; (98. RESIDENT-SYMBOL-AREA SYSTEM-COMMUNICATION-AREA SCRATCH-PAD-INIT-AREA ; MICRO-CODE-SYMBOL-AREA REGION-ORIGIN REGION-LENGTH REGION-BITS ; REGION-FREE-POINTER PAGE-TABLE-AREA PHYSICAL-PAGE-DATA ADDRESS-SPACE-MAP ; REGION-GC-POINTER REGION-LIST-THREAD AREA-NAME AREA-REGION-LIST ; AREA-REGION-BITS AREA-REGION-SIZE AREA-MAXIMUM-SIZE SUPPORT-ENTRY-VECTOR ; CONSTANTS-AREA EXTRA-PDL-AREA MICRO-CODE-ENTRY-AREA ; MICRO-CODE-ENTRY-NAME-AREA MICRO-CODE-ENTRY-ARGS-INFO-AREA ; MICRO-CODE-ENTRY-MAX-PDL-USAGE ; MICRO-CODE-PAGING-AREA PAGE-GC-BITS ; MICRO-CODE-ENTRY-ARGLIST-AREA ; MICRO-CODE-SYMBOL-NAME-AREA LINEAR-PDL-AREA LINEAR-BIND-PDL-AREA ; INIT-LIST-AREA WORKING-STORAGE-AREA) (99. RESIDENT-SYMBOL-AREA SYSTEM-COMMUNICATION-AREA SCRATCH-PAD-INIT-AREA MICRO-CODE-SYMBOL-AREA REGION-ORIGIN REGION-LENGTH REGION-BITS REGION-FREE-POINTER PAGE-TABLE-AREA PHYSICAL-PAGE-DATA ADDRESS-SPACE-MAP REGION-GC-POINTER REGION-LIST-THREAD AREA-NAME AREA-REGION-LIST AREA-REGION-BITS AREA-REGION-SIZE AREA-MAXIMUM-SIZE SUPPORT-ENTRY-VECTOR CONSTANTS-AREA EXTRA-PDL-AREA MICRO-CODE-ENTRY-AREA MICRO-CODE-ENTRY-NAME-AREA MICRO-CODE-ENTRY-ARGS-INFO-AREA MICRO-CODE-ENTRY-MAX-PDL-USAGE MICRO-CODE-PAGING-AREA PAGE-GC-BITS PAGE-STRUCTURE-HANDLES MICRO-CODE-ENTRY-ARGLIST-AREA MICRO-CODE-SYMBOL-NAME-AREA LINEAR-PDL-AREA LINEAR-BIND-PDL-AREA INIT-LIST-AREA WORKING-STORAGE-AREA) ; (103. RESIDENT-SYMBOL-AREA SYSTEM-COMMUNICATION-AREA SCRATCH-PAD-INIT-AREA ; MICRO-CODE-SYMBOL-AREA REGION-ORIGIN REGION-LENGTH REGION-BITS ; REGION-FREE-POINTER PAGE-TABLE-AREA PHYSICAL-PAGE-DATA ADDRESS-SPACE-MAP ; REGION-GC-POINTER REGION-LIST-THREAD AREA-NAME AREA-REGION-LIST ; AREA-REGION-BITS AREA-REGION-SIZE region-area-map SUPPORT-ENTRY-VECTOR ; CONSTANTS-AREA EXTRA-PDL-AREA MICRO-CODE-ENTRY-AREA ; MICRO-CODE-ENTRY-NAME-AREA MICRO-CODE-ENTRY-ARGS-INFO-AREA ; MICRO-CODE-ENTRY-MAX-PDL-USAGE ; MICRO-CODE-PAGING-AREA PAGE-GC-BITS PAGE-STRUCTURE-HANDLES ; MICRO-CODE-ENTRY-ARGLIST-AREA ; MICRO-CODE-SYMBOL-NAME-AREA LINEAR-PDL-AREA LINEAR-BIND-PDL-AREA ; INIT-LIST-AREA WORKING-STORAGE-AREA) (104. RESIDENT-SYMBOL-AREA SYSTEM-COMMUNICATION-AREA SCRATCH-PAD-INIT-AREA MICRO-CODE-SYMBOL-AREA REGION-ORIGIN REGION-LENGTH REGION-BITS REGION-FREE-POINTER WIRED-DISK-BUFFER PAGE-TABLE-AREA PHYSICAL-PAGE-DATA ADDRESS-SPACE-map virtual-page-volatility region-maximum-virtual-page-volatility REGION-GC-POINTER REGION-LIST-THREAD region-allocation-status region-area-map AREA-NAME AREA-REGION-LIST AREA-REGION-BITS AREA-REGION-SIZE SUPPORT-ENTRY-VECTOR CONSTANTS-AREA EXTRA-PDL-AREA MICRO-CODE-ENTRY-AREA MICRO-CODE-ENTRY-NAME-AREA MICRO-CODE-ENTRY-ARGS-INFO-AREA MICRO-CODE-ENTRY-MAX-PDL-USAGE MICRO-CODE-PAGING-AREA virtual-page-data scavenger-queue ;Make sure things are spelled correctly MICRO-CODE-ENTRY-ARGLIST-AREA MICRO-CODE-SYMBOL-NAME-AREA INIT-LIST-AREA WORKING-STORAGE-AREA) (114. RESIDENT-SYMBOL-AREA SYSTEM-COMMUNICATION-AREA SCRATCH-PAD-INIT-AREA MICRO-CODE-SYMBOL-AREA REGION-ORIGIN REGION-LENGTH REGION-BITS REGION-FREE-POINTER WIRED-DISK-BUFFER QUANTUM-MAP PAGE-TABLE-AREA PHYSICAL-PAGE-DATA ADDRESS-SPACE-map virtual-page-volatility region-moby-bits-array region-namespace-origin region-spare REGION-GC-POINTER REGION-LIST-THREAD region-allocation-status region-area-map AREA-NAME AREA-REGION-LIST AREA-REGION-BITS AREA-REGION-SIZE SUPPORT-ENTRY-VECTOR CONSTANTS-AREA EXTRA-PDL-AREA MICRO-CODE-ENTRY-AREA MICRO-CODE-ENTRY-NAME-AREA MICRO-CODE-ENTRY-ARGS-INFO-AREA MICRO-CODE-ENTRY-MAX-PDL-USAGE MICRO-CODE-PAGING-AREA virtual-page-data scavenger-queue ;LAM fails if this is spelled wrong. MICRO-CODE-ENTRY-ARGLIST-AREA MICRO-CODE-SYMBOL-NAME-AREA INIT-LIST-AREA WORKING-STORAGE-AREA) )) ;RETURN BASE ADDRSS OF AREA WHICH WAS PRESENT IN COLD-LOAD. FASTER THAN QF-AREA-ORIGIN, ; AND MORE IMPORTANTLY, GUARANTEED NOT TO CAUSE ANY SWAPPING ACTIVITY. (DEFUN QF-INITIAL-AREA-ORIGIN (NAME) (OR (CDR (ASSQ NAME QF-AREA-ORIGIN-CACHE)) (LET ((AREA-NUMBER (FIND-POSITION-IN-LIST NAME (QF-INITIAL-AREA-LIST)))) (IF AREA-NUMBER (LET ((ORIGIN (QF-POINTER (PHYS-MEM-READ (+ AREA-NUMBER (PHYS-MEM-READ (+ 400 %SYS-COM-AREA-ORIGIN-PNTR))))))) (PUSH (CONS NAME ORIGIN) QF-AREA-ORIGIN-CACHE) ORIGIN))) (FERROR NIL "~S area not found" NAME))) (defvar his-system-version-override nil) (defvar *his-version* nil) (DEFUN QF-INITIAL-AREA-LIST () ;This is also called to initialize version dependant stuff. Must not ;lose state of machine in any case. (LET ((MY-VERSION (OR (SYS:SYSTEM-COMMUNICATION-AREA %SYS-COM-MAJOR-VERSION) (SI:GET-SYSTEM-VERSION)))) (cond ((and (null pht-addr) (null (QF-SETUP-PHT-ADDR))) nil) (t (setq *HIS-VERSION* (or his-system-version-override ;sys-com stuff hard wired. (QF-POINTER (phys-MEM-READ (+ 400 %SYS-COM-MAJOR-VERSION))))) (COND ((ZEROP *HIS-VERSION*) (SETQ *HIS-VERSION* 114. MY-VERSION -1) (cond ((null *major-version-warning-printed*) (FORMAT T "~%His SYS-COM-MAJOR-VERSION-NOT-SET-UP, assuming it is ~D" *HIS-VERSION*) (setq *major-version-warning-printed* t))))) (cond ((and (> *his-version* 102.) *old-hash-table-setup*) (format t "~%Setting up for new page hash table, his version ~D" *his-version*) (setup-for-new-page-hash-table) (setq cdr-next-is-0 t) (qf-setup-q-fields) (qf-clear-cache nil)) ((and (<= *his-version* 102.) (null *old-hash-table-setup*)) (format t "~%Setting up for old page hash table, his version ~D" *his-version*) (setup-for-old-page-hash-table) (setq cdr-next-is-0 nil) (qf-setup-q-fields) (qf-clear-cache nil))) ; (IF (= MY-VERSION *HIS-VERSION*) AREA-LIST ) ;** this can lose if a new QCOM is in!! (DO ((L QF-SYSTEM-AREA-LIST-ALIST (CDR L)) (RES NIL (IF ( *HIS-VERSION* (CAAR L)) (CDAR L) RES))) ((NULL L) RES)))))) ;RETURN AREA NUMBER OF AREA - BETTER BE AN INITIAL AREA (DEFUN QF-AREA-NUMBER (NAME) (OR (FIND-POSITION-IN-LIST-SAMEPNAME NAME (QF-INITIAL-AREA-LIST)) (ERROR NAME '|NOT KNOWN - QF-AREA-NUMBER|))) (DEFUN FIND-POSITION-IN-LIST-SAMEPNAME (NAME LIST) (DO ((L LIST (CDR L)) (C 0 (1+ C))) ((NULL L) NIL) (COND ((inhibit-style-warnings (SAMEPNAMEP NAME (CAR L))) (RETURN C))))) ;;; ARRAYS. ONLY 1-DIMENSIONAL FOR NOW. ;FUNCTION TO SET UP FOR AN ARRAY REFERENCE ;CORRESPONDS TO GAHDR IN MICRO CODE. ;ARGUMENT IS ARRAY-POINTER-Q ;SETS THE FOLLOWING SPECIAL VARIABLES: ; QF-ARRAY-HEADER ; QF-ARRAY-DISPLACED-P ; QF-ARRAY-HAS-LEADER-P ; QF-ARRAY-NUMBER-DIMS ; QF-ARRAY-HEADER-ADDRESS ; QF-ARRAY-DATA-ORIGIN ; QF-ARRAY-LENGTH (DEFUN QF-ARRAY-SETUP (Q &optional inhibit-forwarding-messages) (PROG (N) (OR (= (QF-DATA-TYPE Q) DTP-ARRAY-POINTER) (FERROR NIL "Data type of supposed array is ~s, not DTP-ARRAY-POINTER" (QF-DATA-TYPE Q))) A (SETQ QF-ARRAY-HEADER-ADDRESS (QF-POINTER Q)) (SETQ QF-ARRAY-HEADER (QF-MEM-READ QF-ARRAY-HEADER-ADDRESS)) (SETQ N (QF-DATA-TYPE QF-ARRAY-HEADER)) (COND ((= N DTP-ARRAY-HEADER)) ((OR (= N DTP-HEADER-FORWARD) (= N DTP-GC-FORWARD)) (unless inhibit-forwarding-messages (format t " ~s " (nth (qf-data-type qf-array-header) q-data-types))) (SETQ Q QF-ARRAY-HEADER) (GO A)) (T (FERROR NIL "Data type of supposed array header is ~s, not DTP-ARRAY-HEADER" N))) (SETQ QF-ARRAY-DISPLACED-P (= 1 (LDB %%ARRAY-DISPLACED-BIT QF-ARRAY-HEADER))) (SETQ QF-ARRAY-HAS-LEADER-P (= 1 (LDB %%ARRAY-LEADER-BIT QF-ARRAY-HEADER))) (SETQ QF-ARRAY-NUMBER-DIMS (LDB %%ARRAY-NUMBER-DIMENSIONS QF-ARRAY-HEADER)) (SETQ QF-ARRAY-DATA-ORIGIN (+ QF-ARRAY-NUMBER-DIMS QF-ARRAY-HEADER-ADDRESS)) (COND ((= 0 (LDB %%ARRAY-LONG-LENGTH-FLAG QF-ARRAY-HEADER)) (SETQ QF-ARRAY-LENGTH (LDB %%ARRAY-INDEX-LENGTH-IF-SHORT QF-ARRAY-HEADER))) (T (SETQ QF-ARRAY-DATA-ORIGIN (1+ QF-ARRAY-DATA-ORIGIN)) (SETQ QF-ARRAY-LENGTH (QF-POINTER (QF-MEM-READ (1+ QF-ARRAY-HEADER-ADDRESS)))))) )) ;FUNCTION THAT CORRESPONDS TO DSP-ARRAY-SETUP IN MICRO CODE. ;ARGUMENT IS COMPUTED INDEX, RESULT IS NEW, POSSIBLY-OFFSET INDEX. ;HANDLES DISPLACED AND INDIRECT ARRAYS. BARFS IF INDEX OUT OF BOUNDS. ;MAY MODIFY SPECIAL VARIABLE QF-ARRAY-DATA-ORIGIN. (DEFUN QF-ARRAY-DISPLACE (I) (COND (QF-ARRAY-DISPLACED-P (SETQ QF-ARRAY-LENGTH (QF-POINTER (QF-MEM-READ (1+ QF-ARRAY-DATA-ORIGIN)))) (PROG (K) (SETQ K (QF-MEM-READ QF-ARRAY-DATA-ORIGIN)) (OR (= (QF-DATA-TYPE K) DTP-ARRAY-POINTER) (RETURN (SETQ QF-ARRAY-DATA-ORIGIN K))) ;INDIRECT ARRAY (ERROR '|I REALLY DON'T FEEL LIKE HACKING INDIRECT ARRAYS, SORRY - QF-ARRAY-DISPLACE| NIL 'FAIL-ACT)))) (OR (< I QF-ARRAY-LENGTH) (ERROR '|ARRAY INDEX OUT OF BOUNDS - QF-ARRAY-DISPLACE| I 'FAIL-ACT)) I) ;FUNCTION TO READ OUT CONTENTS OF THE SET UP ARRAY. ARG IS INDEX. (DEFUN QF-ARRAY-READ (I) (PROG (N TYPE K M Q J) (SETQ TYPE (NTH (LDB %%ARRAY-TYPE-FIELD QF-ARRAY-HEADER) ARRAY-TYPES)) (SETQ K (CDR (ASSQ TYPE ARRAY-ELEMENTS-PER-Q))) ;K ELEMENTS PER Q ;**KNOWS ABOUT LENGTH OF POINTER** (SETQ N (CDR (OR (ASSQ TYPE '((ART-1B . 1) (ART-2B . 2) (ART-4B . 4) (ART-8B . 8.) (ART-16B . 16.) (ART-32B . 32.) (ART-Q . 32.) (ART-Q-LIST . 29.) (ART-STRING . 8) (ART-STACK-GROUP-HEAD . 32.) (ART-SPECIAL-PDL . 32.) (ART-HALF-FIX . 16.) (ART-REG-PDL . 32.) (ART-FPS-FLOAT . 16.) (ART-FAT-STRING . 16.) )) ;N BITS PER ELEMENT (ERROR '|ARRAY TYPE NOT KNOWN ABOUT - QF-ARRAY-READ| TYPE 'FAIL-ACT)))) (SETQ M (1- (ASH 1 N))) ;M MASK FOR 1 ELEMENT (SETQ Q (TRUNCATE I K) J (* (\ I K) N)) ;Q WD INDEX, J BIT INDEX (SETQ Q (QF-MEM-READ (+ Q QF-ARRAY-DATA-ORIGIN))) (RETURN (LOGAND M (ASH Q (- J)))))) ;SIMILAR FUNCTION TO WRITE INTO SET UP ARRAY. (DEFUN QF-ARRAY-WRITE (I DATA) (PROG (N TYPE K M Q J ADR) (SETQ TYPE (NTH (LDB %%ARRAY-TYPE-FIELD QF-ARRAY-HEADER) ARRAY-TYPES)) (SETQ K (CDR (ASSQ TYPE ARRAY-ELEMENTS-PER-Q))) ;**KNOWS ABOUT NUMBER OF BITS IN POINTER** (SETQ N (CDR (OR (ASSQ TYPE '((ART-1B . 1) (ART-2B . 2) (ART-4B . 4) (ART-8B . 8.) (ART-16B . 16.) (ART-32B . 32.) (ART-Q . 32.) (ART-Q-LIST . 29.) (ART-STRING . 8) (ART-STACK-GROUP-HEAD . 32.) (ART-SPECIAL-PDL . 32.) (ART-HALF-FIX . 16.) (ART-REG-PDL . 32.) (ART-FPS-FLOAT . 16.) (ART-FAT-STRING . 16.) )) ;N BITS PER ELEMENT (ERROR '|ARRAY TYPE NOT KNOWN ABOUT - QF-ARRAY-WRITE| TYPE 'FAIL-ACT)))) (SETQ M (1- (LSH 1 N))) (SETQ Q (TRUNCATE I K) J (* (\ I K) N)) (SETQ Q (QF-MEM-READ (SETQ ADR (+ Q QF-ARRAY-DATA-ORIGIN)))) (RETURN (QF-MEM-WRITE ADR (LOGIOR (ASH (LOGAND M DATA) J) (LOGAND (LOGXOR -1 (ASH M J)) Q)))))) (DEFUN QF-ARRAY-DIMENSION-N (I Q) (QF-ARRAY-SETUP Q) (COND ((= I QF-ARRAY-NUMBER-DIMS) (ERROR '|QF-ARRAY-DIMENSION-N ON LAST DIMENSION|))) (QF-POINTER (QF-MEM-READ (+ I (- QF-ARRAY-DATA-ORIGIN QF-ARRAY-NUMBER-DIMS))))) (DEFUN QF-AR-1 (Q I) (QF-ARRAY-SETUP Q) (QF-TYPED-POINTER (QF-ARRAY-READ (QF-ARRAY-DISPLACE I)))) (DEFUN QF-AR-OR-IR-1 (Q I) "Do AR-1 if Q is an array, or %INSTANCE-REF if it is an instance. Note that the first element is index 0 in AR-1, but 1 in %INSTANCE-REF. We treat I the same as AR-1 or %INSTANCE-REF accordingly." (IF (= (QF-DATA-TYPE Q) DTP-INSTANCE) (QF-MEM-READ (+ I (QF-POINTER Q))) (QF-AR-1 Q I))) (DEFUN QF-AR-2 (Q I J) (QF-ARRAY-SETUP Q) (QF-TYPED-POINTER (QF-ARRAY-READ (QF-ARRAY-DISPLACE (+ (* J (QF-P-POINTER (1+ (- QF-ARRAY-DATA-ORIGIN QF-ARRAY-NUMBER-DIMS)))) I))))) (DEFUN QF-ARRAY-LEADER (Q I &optional inhibit-forwarding-messages) (QF-ARRAY-SETUP Q inhibit-forwarding-messages) (OR QF-ARRAY-HAS-LEADER-P (ERROR '|NO ARRAY LEADER - QF-ARRAY-LEADER| Q 'FAIL-ACT)) (OR (< I (QF-POINTER (QF-MEM-READ (- QF-ARRAY-HEADER-ADDRESS 1)))) (ERROR '|ARRAY LEADER INDEX OUT OF BOUNDS - QF-ARRAY-LEADER| Q 'FAIL-ACT)) (QF-TYPED-POINTER (QF-MEM-READ (- QF-ARRAY-HEADER-ADDRESS I 2)))) (DEFUN QF-ARRAY-LENGTH (Q) (QF-ARRAY-SETUP Q) QF-ARRAY-LENGTH) (DEFUN QF-ARRAY-ACTIVE-LENGTH (Q) (QF-ARRAY-SETUP Q) (COND ((NOT QF-ARRAY-HAS-LEADER-P) QF-ARRAY-LENGTH) ((QF-POINTER (QF-MEM-READ (- QF-ARRAY-HEADER-ADDRESS 2)))))) ;INITIALIZE ON LOADING (QF-CLEAR-CACHE T) (defun find-pht-entries-with-dt-fix () (if (null pht-addr) (qf-setup-pht-addr)) (or qf-pht-cache (qf-refill-pht-cache)) (let ((pht-size (cadr qf-pht-cache))) (do ((p pht-addr (1+ p))) ((>= p (+ pht-addr pht-size))) (cond ((= (qf-p-data-type p) dtp-fix) (format t "~o " p)))))) (defun lam-page-number (address) (ldb (byte #o21 #o10) address)) (defmacro lam-for-every-region-in-area ((region area) &body body) "Execute BODY iteratively with REGION bound to every region in AREA." (once-only (area) `(let ((A-RL (QF-INITIAL-AREA-ORIGIN 'AREA-REGION-LIST)) (R-LT (QF-INITIAL-AREA-ORIGIN 'REGION-LIST-THREAD))) (do ((,region (LOGLDB %%QF-POINTER (QF-MEM-READ (+ A-RL ,AREA))) (LOGLDB %%QF-POINTER (QF-MEM-READ (+ R-LT ,region))))) ((LDB-TEST %%QF-BOXED-SIGN-BIT ,region)) ,@body)))) (defmacro lam-for-every-region ((region) &body body) `(dotimes (,region number-of-regions) ,@body)) (defun lam-verify-area-volatilities (area) (lam-for-every-region-in-area (region area) (format t "~%Region ~D." region) (lam-describe-region region) (lam-verify-region-volatilities region))) ;incompletely converted. (defun lam-verify-region-volatilities (region) (loop with ro = (qf-initial-area-origin 'region-origin) with fp = (qf-initial-area-origin 'region-free-pointer) with origin = (qf-pointer (qf-mem-read (+ ro region))) with object = origin with page = (lam-page-number origin) with maximum-volatility = 0 with region-top = (+ origin (qf-pointer (qf-mem-read (+ fp region)))) until (= object region-top) for boxed = (lam-%structure-boxed-size object) for total = (lam-%structure-total-size object) do (loop for offset from 0 below boxed for location = (+ object offset) when ( page (lam-page-number location)) do (when ( (lam-page-volatility page) maximum-volatility) (if (< (lam-page-volatility page) maximum-volatility) (format t "~%Page ~O not volatile enough!! Page V~s, found ~s." page (lam-page-volatility page) maximum-volatility) (format t "~%Page ~O too volatile. Page V~s, found ~s." page (lam-page-volatility page) maximum-volatility))) (setq page (lam-page-number location) maximum-volatility 0) when (lam-%p-pointerp location) do (let ((target-region (lam-%region-number (%p-pointer location)))) (if (and (> (lam-%region-volatility target-region) (lam-page-volatility page)) ( (lam-%region-type target-region) %region-space-old)) (format t "~%Pointer at ~O too volatile. Page V~s, Pntr V~s." location (lam-page-volatility page) (lam-%region-volatility target-region))) (setq maximum-volatility (max (lam-%region-volatility target-region) maximum-volatility)))) do (setq object (+ object total)))) ;---- (defvar *region-origin*) (defvar *region-length*) (defvar *region-bits*) (defvar *region-free-pointer*) (defvar *band-stream*) (defvar *band-stream*) (defun lam-region-origin (region) (aref *region-origin* region)) (defun lam-region-length (region) (aref *region-length* region)) (defun lam-region-bits (region) (aref *region-bits* region)) (defun lam-region-free-pointer (region) (aref *region-free-pointer* region)) (defun quantum-initialize (&optional (band (si:current-band))) (setq *band-stream* (si:make-partition-input-stream :partition-name band))) (defun band-seek (q) (send *band-stream* :set-pointer (* q 4))) (defun band-ref (q) (send *band-stream* :set-pointer (* q 4)) (let* ((b0 (send *band-stream* :tyi)) (b1 (send *band-stream* :tyi)) (b2 (send *band-stream* :tyi)) (b3 (send *band-stream* :tyi))) (+ (dpb b3 (byte 8 24.) 0) (dpb b2 (byte 8 16.) 0) (dpb b1 (byte 8 8) 0) b0))) (defun band-ref-next () (let* ((b0 (send *band-stream* :tyi)) (b1 (send *band-stream* :tyi)) (b2 (send *band-stream* :tyi)) (b3 (send *band-stream* :tyi))) (+ (dpb b3 (byte 8 24.) 0) (dpb b2 (byte 8 16.) 0) (dpb b1 (byte 8 8) 0) b0))) (defun address-to-quantum-number (adr) (ldb (byte 11. (+ 8 6)) adr)) (defun address-to-offset-in-quantum (adr) (ldb (byte 6 8) adr)) (defun address-to-offset-in-page (adr) (ldb (byte 8 0) adr)) (defun find-number-of-regions () (qf-pointer (band-ref (+ #o400 si:%sys-com-number-regions)))) (defun read-region-tables () (let ((number-of-regions (find-number-of-regions))) (setq *region-origin* (make-array number-of-regions)) (setq *region-length* (make-array number-of-regions)) (setq *region-bits* (make-array number-of-regions)) (setq *region-free-pointer* (make-array number-of-regions)) (band-seek (* #o400 3)) (dotimes (i number-of-regions) (setf (aref *region-origin* i) (qf-pointer (band-ref-next)))) (dotimes (i number-of-regions) (setf (aref *region-length* i) (qf-pointer (band-ref-next)))) (dotimes (i number-of-regions) (setf (aref *region-bits* i) (qf-pointer (band-ref-next)))) (dotimes (i number-of-regions) (setf (aref *region-free-pointer* i) (qf-pointer (band-ref-next)))))) (defvar *vadr-to-lod-offset-table* (make-array (ash 1 17.))) (defun fill-in-vadr-to-lod-offset-table () (array-initialize *vadr-to-lod-offset-table* nil) (let ((number-of-regions (find-number-of-regions)) (band-offset 0)) (dotimes (region number-of-regions) (when (not (zerop (ldb %%region-space-type (lam-region-bits region)))) (do* ((page (floor (lam-region-origin region) #o400) (+ page 1)) (end (+ page (ceiling (lam-region-free-pointer region) #o400)))) ((= page end)) (setf (aref *vadr-to-lod-offset-table* page) band-offset) (incf band-offset)))))) (defun vread (adr) (setq adr (qf-pointer adr)) (let ((page-number (ash adr -8))) (let ((band-offset (aref *vadr-to-lod-offset-table* page-number))) (when (null band-offset) (ferror nil "can't find it")) (band-ref (+ (ash band-offset 8) (ldb (byte 8 0) adr)))))) (defun vread-virtual-to-lod-page (virtual-page) (let ((band-offset (aref *vadr-to-lod-offset-table* virtual-page))) (when (null band-offset) (ferror nil "can't find it")) band-offset)) (defvar *quantum-map* (make-array (ash 1 (- 25. 6 8)))) (defun initialize-quantum-map () (array-initialize *quantum-map* nil) (let ((number-of-regions (find-number-of-regions)) (band-offset 0)) (dotimes (region number-of-regions) (when (not (zerop (ldb %%region-space-type (lam-region-bits region)))) (do* ((quantum (ash (lsh (lam-region-origin region) -8) -6) (+ quantum 1)) (pages (ceiling (lam-region-free-pointer region) #o400)) (pages-done 0 (+ pages-done 64.))) ((>= pages-done pages)) (setf (aref *quantum-map* quantum) band-offset) (incf band-offset (min 64. (- pages pages-done)))))))) (defun compare-tables () (dotimes (i (ash 1 (- 25. 6 8))) (let ((a (aref *vadr-to-lod-offset-table* (* i 64.))) (b (aref *quantum-map* i))) (when (not (eql a b)) (format t "~&~o ~o ~o" i a b))))) (defun read-quantum-map-from-machine (quantum-number) (let* ((quantum-map-index (* 2 quantum-number)) (quantum-map-base (+ (qf-initial-area-origin 'quantum-map) (* page-size quantum-map-offset-in-tables))) (pq1 (phys-mem-read (qf-virtual-mem-map (+ quantum-map-index quantum-map-base) nil))) (pq2 (phys-mem-read (qf-virtual-mem-map (+ 1 quantum-map-index quantum-map-base) nil))) ) (values (ldb pq1m-page-offset pq1) pq1 pq2))) (defun verify-quantum-map () (format t "~&# lam machine") (do* ((quantum-number 0 (1+ quantum-number)) (lqm (aref *quantum-map* quantum-number) (aref *quantum-map* quantum-number)) (mqm (read-quantum-map-from-machine quantum-number) (read-quantum-map-from-machine quantum-number))) ((>= quantum-number (ash 1 (- 25. 6 8)))) (unless (eql lqm mqm) (format t "~&#o~o ~a ~a" quantum-number lqm mqm))))