;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 126.128 ;;; Reason: ;;; BYTE-spec cleanups in SYS:SYS;QMISC. ;;; Written 23-Oct-88 19:11:31 by keith (Keith Corbett) at site Gigamos Cambridge ;;; while running on Johannes Brahms from band 1 ;;; with Experimental System 126.123, Experimental ZWEI 126.21, Experimental ZMail 74.9, Experimental Local-File 76.0, Experimental File-Server 25.0, Experimental Lambda-Diag 18.0, Experimental Unix-Interface 15.0, Experimental Tape 26.4, Microcode 1762, SDU Boot Tape 3.14, SDU ROM 103, 10/17. ; From modified file DJ: L.SYS; QMISC.LISP#741 at 23-Oct-88 19:11:37 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QMISC  " (DEFUN %MAKE-POINTER-UNSIGNED (N) "Convert N to a fixnum which, regarded as unsigned, has same value as N. Thus, a number just too big to be a signed fixnum becomes a fixnum which, if regarded as signed, would be negative." (IF (FIXNUMP N) N (LOGIOR (LDB (byte (1- %%Q-POINTER) 0) N) (ROT (LDB (BYTE 1 (1- %%Q-POINTER)) N) -1)))) )) ; From modified file DJ: L.SYS; QMISC.LISP#741 at 23-Oct-88 19:11:46 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QMISC  " (DEFUN COUNT-WIRED-PAGES () (DECLARE (VALUES NUMBER-OF-WIRED-PAGES NUMBER-OF-FIXED-WIRED-PAGES)) (DO ((ADR (%REGION-ORIGIN PAGE-TABLE-AREA) (+ ADR 2)) (N (TRUNCATE (AREF (SYMBOL-FUNCTION 'SYSTEM-COMMUNICATION-AREA) %SYS-COM-PAGE-TABLE-SIZE) 2) (1- N)) (N-WIRED 0)) ((ZEROP N) (DO ((ADR (%REGION-ORIGIN PHYSICAL-PAGE-DATA) (1+ ADR)) (N (TRUNCATE (AREF (SYMBOL-FUNCTION 'SYSTEM-COMMUNICATION-AREA) %SYS-COM-MEMORY-SIZE) PAGE-SIZE) (1- N)) (N-FIXED-WIRED 0)) ((ZEROP N) (RETURN (VALUES (+ N-WIRED N-FIXED-WIRED) N-FIXED-WIRED))) (AND (= (%P-LDB (BYTE 16. 0.) ADR) #o177777) ( (%P-LDB (BYTE 16. 16.) ADR) #o177777) (SETQ N-FIXED-WIRED (1+ N-FIXED-WIRED))))) (AND (NOT (ZEROP (%P-LDB %%PHT1-VALID-BIT ADR))) (= (%P-LDB %%PHT1-SWAP-STATUS-CODE ADR) %PHT-SWAP-STATUS-WIRED) (SETQ N-WIRED (1+ N-WIRED))))) )) ; From modified file DJ: L.SYS; QMISC.LISP#741 at 23-Oct-88 19:11:49 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QMISC  " (DEFUN %MAKE-PAGE-READ-ONLY (P) "Make virtual page at address P read only. Lasts only until it is swapped out!" (%CHANGE-PAGE-STATUS P NIL (DPB %PHT-MAP-STATUS-READ-ONLY (BYTE 3. 6.) (LDB %%REGION-MAP-BITS ;Change map-status (%REGION-BITS (%REGION-NUMBER P)))))) ;;;; MAR-hacking functions )) ; From modified file DJ: L.SYS; QMISC.LISP#741 at 23-Oct-88 19:12:00 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QMISC  " (DEFUN SET-MAR (LOCATION CYCLE-TYPE &OPTIONAL (N-WORDS 1)) ;N-WORDS SHOULD DEFAULT TO (SIZE LOCATION) "Set trap on reference to N-WORDS words starting at LOCATION. N-WORDS defaults to 1. CYCLE-TYPE is T, :READ or :WRITE." (SETQ CYCLE-TYPE (ECASE CYCLE-TYPE (:READ 1) (:WRITE 2) ((T) 3))) (CLEAR-MAR) ;Clear old mar (SETQ %MAR-HIGH (+ (1- N-WORDS) (SETQ %MAR-LOW (%POINTER LOCATION)))) ;; If MAR'ed pages are in core, set up their traps (DO ((P %MAR-LOW (+ P #o200))) ((> P %MAR-HIGH)) (%CHANGE-PAGE-STATUS P NIL (DPB 6 (BYTE 4. 6.) (LDB %%REGION-MAP-BITS ;Change map-status (%REGION-BITS (%REGION-NUMBER P)))))) (SETQ %MODE-FLAGS (%LOGDPB CYCLE-TYPE %%M-FLAGS-MAR-MODE %MODE-FLAGS)) ;Energize! T) )) ; From modified file DJ: L.SYS; QMISC.LISP#741 at 23-Oct-88 19:12:13 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QMISC  " (DEFUN DISK-RESTORE (&OPTIONAL PARTITION UNIT &AUX NAME COMMENT DESIRED-UCODE) "Restore partition PARTITION as a saved Lisp world. PARTITION can be either a string naming a partition, or a number which signifies a partition whose name starts with LOD. Note that this does not change the running microcode. You cannot successfully DISK-RESTORE a world that will not work with the microcode that is running." ;; If the user didn't specify a unit then select one. (When (Null unit) (select-processor ((:cadr :lambda) (setq unit 0)) (:explorer (setq unit (explorer-lod-band-logical-unit))))) (LET ((L (DISK-RESTORE-DECODE PARTITION)) BLOCK) (using-resource (rqb si:rqb disk-label-rqb-pages 4) ;(SETQ RQB (GET-DISK-LABEL-RQB)) (READ-DISK-LABEL RQB UNIT) (SETQ NAME (IF PARTITION (STRING-APPEND (LDB (BYTE 8. 0.) (CADR L)) (LDB (BYTE 8. 8.) (CADR L)) (LDB (BYTE 8. 0.) (CAR L)) (LDB (BYTE 8. 8.) (CAR L))) (GET-DISK-STRING RQB 7 4))) (SETQ BLOCK (FIND-DISK-PARTITION-FOR-READ NAME RQB unit) COMMENT (PARTITION-COMMENT NAME UNIT)) ;;; +++ Incremental bands can't work with current system so don't bother checking +++ ;;; (MULTIPLE-VALUE-BIND (BASE-BAND VALID-FLAG) ;;; (INC-BAND-BASE-BAND NAME UNIT) ;;; (WHEN (AND BASE-BAND (NOT VALID-FLAG)) ;;; (FERROR "Band ~A is incremental, and the base band ~A is no longer valid." ;;; NAME BASE-BAND))) (SETQ DESIRED-UCODE (GET-UCODE-VERSION-OF-BAND NAME UNIT))) ; (RETURN-DISK-RQB RQB) (AND ( DESIRED-UCODE %MICROCODE-VERSION-NUMBER) (NOT (ZEROP DESIRED-UCODE)) ;Not stored yet (FORMAT *QUERY-IO* "~&That band prefers microcode ~D but the running microcode is ~D.~%" DESIRED-UCODE %MICROCODE-VERSION-NUMBER)) (WHEN (FQUERY FORMAT:YES-OR-NO-QUIETLY-P-OPTIONS "Do you really want to reload ~A (~A)? " NAME COMMENT) (INITIALIZATIONS 'DISABLE-SERVICES-INITIALIZATION-LIST) ;; Stuff the unit number to restore from. (select-processor (:explorer (%p-dpb (convert-logical-unit-to-physical-unit unit) (byte 6 0) (%pointer-plus si:a-memory-virtual-address #o1775))) ((:cadr :lambda))) (%DISK-RESTORE (CAR L) (CADR L))))) )) ; From modified file DJ: L.SYS; QMISC.LISP#741 at 23-Oct-88 19:12:17 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QMISC  " (DEFUN DISK-SAVE (PARTITION &OPTIONAL NO-QUERY INCREMENTAL) "Save the current Lisp world in partition PARTITION. PARTITION can be either a string naming a partition, or a number which signifies a partition whose name starts with LOD. NO-QUERY says do not ask for confirmation (or any keyboard input at all). INCREMENTAL means to write out only those parts of the world which have changed since the it was loaded from disk. (The effect of loading a world from a band saved incrementally is that the incremental saves /"patch/" the original full save." (PROG* ((L (DISK-RESTORE-DECODE PARTITION)) (PART-NAME (STRING-APPEND (LDB (BYTE 8. 0.) (CADR L)) (LDB (BYTE 8. 8.) (CADR L)) (LDB (BYTE 8. 0.) (CAR L)) (LDB (BYTE 8. 8.) (CAR L)))) PART-BASE PART-SIZE SYSTEM-VERSION MAX-ADDR (INC-PAGES-SAVED 0) unit) (setq unit (unit-for-partition part-name)) (OR (MULTIPLE-VALUE-SETQ (PART-BASE PART-SIZE) (IF NO-QUERY (FIND-DISK-PARTITION-FOR-READ PART-NAME nil unit) (FIND-DISK-PARTITION-FOR-WRITE PART-NAME nil unit))) (RETURN NIL)) (UNLESS NO-QUERY (DOLIST (PATCH-SYSTEM PATCH-SYSTEMS-LIST) (WHEN (EQ (PATCH-STATUS PATCH-SYSTEM) :INCONSISTENT) (BEEP) (FORMAT *QUERY-IO* "~&You have loaded patches out of sequence, or loaded unreleased patches, in ~A. As a result, the environment is probably inconsistent with the current patches and will remain so despite attempts to update it. Unless you understand these problems well and know how to be sure whether they are occurring, or how to clean them up, you should not save this environment." (PATCH-NAME PATCH-SYSTEM)) (SEND *QUERY-IO* :CLEAR-INPUT) (UNLESS (YES-OR-NO-P "Dump anyway? ") (RETURN-FROM DISK-SAVE NIL))))) ;; This will catch most lossages before the user has waited. (UNLESS INCREMENTAL (CHECK-PARTITION-SIZE PART-SIZE)) ;; Prompt now for this rather than waiting through all the initializations. (LET ((MAX (OR (MAXIMUM-PARTITION-COMMENT-LENGTH PART-NAME unit) 16.))) (SETQ SYSTEM-VERSION (IF NO-QUERY (LET ((VERS (SYSTEM-VERSION-INFO T))) (SUBSTRING VERS 0 (MIN (LENGTH VERS) MAX))) (GET-NEW-SYSTEM-VERSION MAX :INCREMENTAL INCREMENTAL :query T)))) ;; Cause cold boot initializations to happen when rebooted ;; and do the BEFORE-COLD initializations now (amazing-kludge-order-cold-initialization-list) (format t "~%Beginning shut-down initializations...") (INITIALIZATIONS 'BEFORE-COLD-INITIALIZATION-LIST T) (RESET-INITIALIZATIONS 'COLD-INITIALIZATION-LIST) (let ((gc-status gc:*gc-process-control*)) (when (eq gc-status :active) (gc:gc-off)) ;Wait for current reclamation (if any) to complete (gc:maybe-flip-level-2) ;Flip level 2 in batch mode (when (eq gc-status :active) (gc:gc-on))) ;Reenable the GC Process (SETQ WHO-LINE-JUST-COLD-BOOTED-P T) (LOGOUT) ;; Help stop user from getting worried. (WHEN INCREMENTAL (FORMAT T "~&NOTE: Comparing current memory contents with the original band will take a few minutes.") (PROCESS-SLEEP 120.)) ;; This can't be a before-cold initialization, because some other ;; initializations sometimes type out (when (get 'tv:window 'si:flavor) TV:(SHEET-FORCE-ACCESS (INITIAL-LISP-LISTENER) (SEND INITIAL-LISP-LISTENER :REFRESH) (SEND INITIAL-LISP-LISTENER :HOME-CURSOR))) ;; :before-cold intialization list deconfigures entire network... ;;(CHAOS:RESET) ;Otherwise, UCODE could lose hacking packets as world dumped. ;; Compare all pages with band we booted from, ;; record unchanged pages in a bitmap in the band being saved in. (WHEN INCREMENTAL (SETQ INC-PAGES-SAVED (DISK-SAVE-INCREMENTAL PART-BASE))) ;; Check again before updating the partition comment. (CHECK-PARTITION-SIZE (+ INC-PAGES-SAVED PART-SIZE)) (UPDATE-PARTITION-COMMENT PART-NAME SYSTEM-VERSION unit) ;; Now shut down the world and check the partition size for real, just ;; to make sure that we didn't exceed the size very recently. (cond ((get 'tv:window 'si:flavor) (DOLIST (S TV:ALL-THE-SCREENS) (TV:SHEET-GET-LOCK S)) (TV:WITH-MOUSE-USURPED (WITHOUT-INTERRUPTS (SETQ TV:MOUSE-SHEET NIL) (DOLIST (S TV:ALL-THE-SCREENS) (SEND S :DEEXPOSE) (TV:SHEET-RELEASE-LOCK S)) (disk-save-1 max-addr inc-pages-saved part-size incremental l)))) ('else (without-interrupts (disk-save-1 max-addr inc-pages-saved part-size incremental l)))))) )) ; From modified file DJ: L.SYS; QMISC.LISP#741 at 23-Oct-88 19:12:19 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QMISC  " (defun read-meter (meter) "Read microcode meter METER." (coerce-to-meter-location meter) (without-interrupts (dpb (%p-ldb (BYTE 16. 16.) meter) (BYTE 16. 16.) (%p-ldb (BYTE 16. 0.) meter)))) )) ; From modified file DJ: L.SYS; QMISC.LISP#741 at 23-Oct-88 19:12:20 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QMISC  " (defun clear-meter (meter) "Clear microcode meter METER, returning its previous value." (coerce-to-meter-location meter) (without-interrupts (prog1 (dpb (%p-ldb (BYTE 16. 16.) meter) (BYTE 16. 16.) (%p-ldb (BYTE 16. 0.) meter)) (%p-dpb 0 (BYTE 16. 16.) meter) (%p-dpb 0 (BYTE 16. 0.) meter)))) )) ; From modified file DJ: L.SYS; QMISC.LISP#741 at 23-Oct-88 19:12:22 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QMISC  " (defun write-meter (meter value) "Modify microcode meter METER." (coerce-to-meter-location meter) (without-interrupts (%p-dpb (ldb (BYTE 16. 16.) value) (BYTE 16. 16.) meter) (%p-dpb (ldb (BYTE 16. 0.) value) ;must ldb to get correct low bits if bignum! (BYTE 16. 0.) meter))) ;;; STRING-IO stream handler. ;;; Note that DEFSELECT doesn't work in the cold load. ;;; WITH-INPUT-FROM-STRING and WITH-OUTPUT-FROM-STRING used to compile into calls to this. ;;; It is now obsolete, but present for the sake of old compiled code. ;;; Supported operations: ;;; :READ-CHAR, :WRITE-CHAR, :STRING-OUT, :LINE-OUT, :FRESH-LINE, :READ-POINTER ;;; -- these are normal ;;; :SET-POINTER ;;; -- This works to any location in the string. If done to an output string, ;;; and it hasn't gotten there yet, the string will be extended. (The elements ;;; in between will contain garbage.) ;;; :UNTYI ;;; -- you can UNTYI as many characters as you like. The argument is ignored. ;;; :READ-CURSORPOS, :INCREMENT-CURSORPOS ;;; -- These work on the X axis only; they ignore Y. ;;; They are defined only for :CHARACTER units; :PIXEL will give an error. ;;; :UNTYO, :UNTYO-MARK ;;; -- These exist to keep the grinder happy. ;;; :CONSTRUCTED-STRING ;;; -- This is a special operation required by the operation of the WITH-OPEN-STRING macro. ;;; This is how the string is extracted from the stream closure. ;;; You shouldn't need to use this. ;(defvar *string-io-string*) ;(defvar *string-io-index*) ;(defvar *string-io-limit*) ;(defvar *string-io-direction*) ;(defvar *string-io-stream*) ;(defmacro maybe-grow-io-string (index) ; `(if ( ,index *string-io-limit*) ; (adjust-array-size *string-io-string* ; (setq *string-io-limit* (fix (* (1+ ,index) 1.5s0)))))) ;(defmacro string-io-add-character (ch) ; `(progn (maybe-grow-io-string *string-io-index*) ; (setf (char *string-io-string* *string-io-index*) ,ch) ; (incf *string-io-index*))) ;(defmacro string-io-add-line (string start end) ; `(let* ((string-io-length (- ,end ,start)) ; (string-io-finish-index (+ *string-io-index* string-io-length))) ; (maybe-grow-io-string string-io-finish-index) ; (copy-array-portion ,string ,start ,end ; *string-io-string* *string-io-index* string-io-finish-index) ; (setq *string-io-index* string-io-finish-index))) ;(defselect (string-io string-io-default-handler) ; (:tyi (&optional eof) ; (if (< *string-io-index* *string-io-limit*) ; (prog1 (zl:aref *string-io-string* *string-io-index*) ; (incf *string-io-index*)) ; (and eof (ferror 'sys:end-of-file-1 "End of file on ~S." *string-io-stream*)))) ; (:read-char () ; (if (< *string-io-index* *string-io-limit*) ; (prog1 (char *string-io-string* *string-io-index*) ; (incf *string-io-index*)) ; nil)) ; ((:untyi :unread-char) (ignore) ; (if (minusp (decf *string-io-index*)) ; (error "Attempt ~S past beginning -- ~S" :unread-char 'string-io))) ; ((:write-char :tyo) (ch) ; (string-io-add-character ch)) ; (:string-out (string &optional (start 0) end) ; (or end (setq end (length string))) ; (string-io-add-line string start end)) ; (:line-out (string &optional (start 0) end) ; (or end (setq end (length string))) ; (string-io-add-line string start end) ; (string-io-add-character #/Newline)) ; (:fresh-line () ; (and (plusp *string-io-index*) ; ( (char *string-io-string* *string-io-index*) #/Newline) ; (string-io-add-character #/Newline))) ; (:read-pointer () ; *string-io-index*) ; (:set-pointer (ptr) ; (and (neq *string-io-direction* :in) ; (< ptr *string-io-limit*) ; (error "Attempt to ~S beyond end of string -- ~S" :set-pointer 'string-io)) ; (setq *string-io-index* ptr)) ; (:untyo-mark () ; *string-io-index*) ; (:untyo (mark) ; (setq *string-io-index* mark)) ; (:read-cursorpos (&optional (units :pixel)) ; (string-io-confirm-movement-units units) ; (let ((string-io-return-index ; (string-reverse-search-char #/Newline *string-io-string* *string-io-index*))) ; (if string-io-return-index ; (- *string-io-index* string-io-return-index) ; *string-io-index*))) ; (:increment-cursorpos (x ignore &optional (units :pixel)) ; (string-io-confirm-movement-units units) ; (dotimes (i x) (string-io-add-character #/Space))) ; (:constructed-string () ; ;; Don't change allocated size if we have a fill pointer! ; (if (array-has-fill-pointer-p *string-io-string*) ; (setf (fill-pointer *string-io-string*) *string-io-index*) ; (setq *string-io-string* ; (adjust-array-size *string-io-string* *string-io-index*))))) ;(defun string-io-default-handler (op &optional arg1 &rest rest) ; (stream-default-handler 'string-io op arg1 rest)) ;(defun string-io-confirm-movement-units (units) ; (if (neq units :character) ; (ferror "Unimplemented cursor-movement unit ~A -- STRING-IO." units))) ;;;; Super-hairy module support ))