;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 121.27 ;;; Reason: ;;; MRC's fix to LISP-REINITIALIZE to allow (disk-restore ...) to work ;;; Written 10-Feb-87 18:22:11 by pld (Peter L. DeWolf) at site LMI Cambridge ;;; while running on Azathoth from band 3 ;;; with Experimental System 121.26, Experimental Lambda-Diag 15.0, Experimental ZMail 70.2, Experimental KERMIT 32.0, Experimental Unix-Interface 10.0, Experimental Local-File 72.0, Experimental FILE-Server 21.0, Experimental Tape 13.0, Experimental Site Data Editor 5.0, microcode 1733, SDU Boot Tape 3.12, SDU ROM 102, the old ones. ; From modified file DJ: L.SYS; LTOP.LISP#571 at 10-Feb-87 18:22:12 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; LTOP  " (DEFUN LISP-REINITIALIZE (&OPTIONAL (CALLED-BY-USER T) &AUX (COLD-BOOT *COLD-BOOTING*)) "Resets various global constants and initializes the error system." (unless called-by-user (unclosurebind 'inhibit-scheduling-flag 'default-cons-area) ;; Flush any likely losing closure binding forwarding pointers ;; left around from a closure we were in when we warm booted. (UNCLOSUREBIND 'PRIN1 'SELF '*PACKAGE* '*READTABLE*)) (SETQ INHIBIT-SCHEDULING-FLAG T) ;In case called by the user (SETQ DEFAULT-CONS-AREA WORKING-STORAGE-AREA) ;; these are defvar-resettabled too late for the cold-load, since things use getdecl (setq local-declarations nil file-local-declarations nil compiler::qc-file-in-progress nil undo-declarations-flag nil eh::condition-resume-handlers nil eh::condition-handlers nil eh::condition-default-handlers nil) ;; This is ok to do asap since it doesn't do any evaluation. (when (not cold-boot) ;>> Not sure if this is right. (dolist (x *boot-reset-values*) (unless called-by-user (unclosurebind (car x))) (set (car x) (cdr x)))) (unless called-by-user (unclosurebind 'zwei::*local-variables* 'zwei::*local-bound-variables*) (when (variable-boundp zwei::*local-bound-variables*) (apply #'unclosurebind zwei::*local-bound-variables*)) (when (variable-boundp *default-process-closure-variables*) (apply #'unclosurebind *default-process-closure-variables*))) (UNLESS (GET 'CDR-NIL 'SYSTEM-CONSTANT) (MAPC (LAMBDA (Y) (MAPC (LAMBDA (X) (OR (GET X 'SYSTEM-CONSTANT) (SETF (GET X 'SYSTEM-CONSTANT) T))) (SYMBOL-VALUE Y))) SYSTEM-CONSTANT-LISTS) (MAPC (LAMBDA (Y) (MAPC (LAMBDA (X) (OR (GET X 'SPECIAL) (SETF (GET X 'SPECIAL) T))) (SYMBOL-VALUE Y))) SYSTEM-VARIABLE-LISTS) (PUTPROP T T 'SYSTEM-CONSTANT) (PUTPROP T T 'SPECIAL) (PUTPROP NIL T 'SYSTEM-CONSTANT) (PUTPROP NIL T 'SPECIAL)) (SELECT-PROCESSOR (:EXPLORER (SETQ TV::TV-QUAD-SLOT #xf5) (SETQ RG-QUAD-SLOT NIL) (SETQ SDU-QUAD-SLOT NIL) (setq video-board-type :explorer) ) (:LAMBDA (setq rg-quad-slot (%lambda-rg-quad-slot)) (setq sdu-quad-slot (%lambda-sdu-quad-slot)) (let ((tv (%lambda-tv-quad-slot))) (case (ldb (byte 8 8) tv) ((0 1) (setq tv::tv-quad-slot (ldb (byte 8 0) tv)) (setq video-board-type :vcmem)) (2 (setq video-board-type :quad) (setq quad-video-control-virtual-address (lsh (ash 177277400 -1) 1))) (t (ferror "bad video board type"))))) (:CADR (SETQ TV::TV-QUAD-SLOT nil) (SETQ RG-QUAD-SLOT NIL) (SETQ SDU-QUAD-SLOT NIL) (setq video-board-type :cadr))) ;;; This section below causes DISK-RESTORE and DISK-SAVE to fail. The microcode ;;; that refers to AMEM-EVCP-VECTOR has all been commented out (previous to this) ;;; and the LMM says that AMEM-EVCP-VECTOR is obsolete. --mrc ; ;; Provide ucode with space to keep EVCPs stuck into a-memory locations ; ;; by closure-binding the variables that forward there. ; (UNLESS (AND (BOUNDP 'AMEM-EVCP-VECTOR) AMEM-EVCP-VECTOR) ; (SETQ AMEM-EVCP-VECTOR ; (MAKE-ARRAY (+ (LENGTH A-MEMORY-LOCATION-NAMES) #o100 #o20) ; ;; in case ucode grows. ; :AREA PERMANENT-STORAGE-AREA))) (UNLESS CALLED-BY-USER (AND (FBOUNDP 'COMPILER::MA-RESET) ;Unload microcompiled defs, because they are gone! (COMPILER::MA-RESET)) ; Hopefully manage to do this before any gets called. ;; Set up the TV sync program as soon as possible; until it is set up ;; read references to the TV buffer can get NXM errors which cause a ;; main-memory parity error halt. Who-line updating can do this. (TV::INITIALIZE-RUN-LIGHT-LOCATIONS) ;; Clear all the bits of the main screen after a cold boot. (AND COLD-BOOT (CLEAR-SCREEN-BUFFER IO-SPACE-VIRTUAL-ADDRESS))) ;; Do something at least if errors occur during loading (OR (FBOUNDP 'FERROR) (FSET 'FERROR #'FERROR-COLD-LOAD)) (OR (FBOUNDP 'CERROR) (FSET 'CERROR #'CERROR-COLD-LOAD)) (OR (FBOUNDP 'UNENCAPSULATE-FUNCTION-SPEC) (FSET 'UNENCAPSULATE-FUNCTION-SPEC (LAMBDA (X) X))) (OR (FBOUNDP 'FS::MAKE-PATHNAME-INTERNAL) (FSET 'FS::MAKE-PATHNAME-INTERNAL #'LIST)) (OR (FBOUNDP 'FS::MAKE-FASLOAD-PATHNAME) (FSET 'FS::MAKE-FASLOAD-PATHNAME #'LIST)) ;; defined is in sys2;gc However, we need this stuff far earlier than that. (or (variable-boundp gc::*gc-flip-generations*) ;; used by the hasharrays before gc is loaded (setq gc::*gc-flip-generations* (make-array 4 :initial-element 0 :area control-tables))) ;; used by expansions of gc:without-flipping and gc:without-scavenging (or (fboundp 'gc::without-flipping-internal) (fset 'gc::without-flipping-internal 'funcall)) (or (fboundp 'gc::without-scavenging-internal) (fset 'gc::without-scavenging-internal 'funcall)) ;; Allow streams to work before WHOLIN loaded (OR (BOUNDP 'TV::WHO-LINE-FILE-STATE-SHEET) (SETQ TV::WHO-LINE-FILE-STATE-SHEET 'IGNORE)) (NUMBER-GC-ON) ;This seems to work now, make it the default (UNLESS (VARIABLE-BOUNDP *PACKAGE*) (PKG-INITIALIZE)) (SETQ *PACKAGE* PKG-USER-PACKAGE) ;; initialize the reader ;; Get the right readtable. (unless (variable-boundp initial-readtable) (setq initial-readtable *readtable* *readtable* (copy-readtable *readtable*) standard-readtable *readtable*) (setf (rdtbl-names *readtable*) (rdtbl-names initial-readtable)) (setq initial-common-lisp-readtable common-lisp-readtable common-lisp-readtable (copy-readtable common-lisp-readtable)) (setf (rdtbl-names common-lisp-readtable) (rdtbl-names initial-common-lisp-readtable)) (setq *all-readtables* (list *readtable* common-lisp-readtable))) ;; initialize the printer (unless (boundp 'prin1) (setq prin1 nil)) (WHEN (NOT (BOUNDP 'CURRENT-PROCESS)) ;Very first time around (SETQ SCHEDULER-EXISTS NIL CURRENT-PROCESS NIL TV::WHO-LINE-PROCESS NIL TV::LAST-WHO-LINE-PROCESS NIL) (UNLESS (FBOUNDP 'TV::WHO-LINE-RUN-STATE-UPDATE) (FSET 'TV:WHO-LINE-RUN-STATE-UPDATE (LAMBDA (&REST IGNORE) NIL)))) (SETQ TV::KBD-LAST-ACTIVITY-TIME (TIME)) ; Booting is keyboard activity. (INITIALIZE-WIRED-KBD-BUFFER) (ecase video-board-type (:vcmem ;; now that the "unibus" channel is set up, turn on 60Hz interrupts ;; first the vector (compiler::%nubus-write tv::tv-quad-slot 8 (dpb rg-quad-slot (byte 8 24.) (* 4 (+ #o400 #o260)))) (compiler::%nubus-write tv::tv-quad-slot 4 (logior #o40 (compiler::%nubus-read tv::tv-quad-slot 4)))) (:quad (%p-store-tag-and-pointer (%pointer-plus quad-video-control-virtual-address (// #x14 4)) 0 #o242) ;;read this location to clear pending vertical blank interrupt (%p-pointer (%pointer-plus quad-video-control-virtual-address 4)) ;;clear pending keyboard interrupt (%p-pointer (%pointer-plus quad-video-control-virtual-address 3)) ;;clear pending mouse interrupt (%p-pointer (%pointer-plus quad-video-control-virtual-address 11.)) ) (:explorer (start-si-ints))) (SETQ SELF NIL SELF-MAPPING-TABLE NIL) (DISABLE-SERVICES) (IF COLD-BOOT (SETQ FS::USER-LOGIN-MACHINE NIL)) ;; The first time, this does top-level EVAL's from the cold-load files (OR (BOUNDP 'ORIGINAL-LISP-CRASH-LIST) ;Save it for possible later inspection (SETQ ORIGINAL-LISP-CRASH-LIST LISP-CRASH-LIST)) (MAPC #'EVAL LISP-CRASH-LIST) (SETQ LISP-CRASH-LIST NIL) (when (fboundp 'eh::initialize-debugger) (eh::initialize-debugger)) (if (fboundp 'gc::initialize) (gc::initialize)) ;; Reattach IO streams. Note that *TERMINAL-IO* will be fixed later to go to a window. (UNLESS CALLED-BY-USER (UNCLOSUREBIND '*TERMINAL-IO* '*STANDARD-OUTPUT* '*STANDARD-INPUT* '*QUERY-IO* '*TRACE-OUTPUT* '*ERROR-OUTPUT* '*DEBUG-IO*) (SETQ *TERMINAL-IO* COLD-LOAD-STREAM *STANDARD-OUTPUT* SYN-TERMINAL-IO *STANDARD-INPUT* SYN-TERMINAL-IO *QUERY-IO* SYN-TERMINAL-IO *DEBUG-IO* SYN-TERMINAL-IO *TRACE-OUTPUT* SYN-TERMINAL-IO *ERROR-OUTPUT* SYN-TERMINAL-IO) (SEND *TERMINAL-IO* :HOME-CURSOR)) (SETQ TV::MOUSE-WINDOW NIL) ;This gets looked at before the mouse process is turned on (KBD-CONVERT-NEW 1_15.) ;Reset state of shift keys ; (select-processor ; (:cadr ; (WHEN (FBOUNDP 'CADR::CLEAR-UNIBUS-MAP) ;clear valid bits on unibus map. ; (CADR:CLEAR-UNIBUS-MAP))) ; and necessary if sharing Unibus with PDP11. ; ; Do this before SYSTEM-INITIALIZATION-LIST to ; ; avoid screwing ETHERNET code. ; ((:explorer :lambda))) (if (fboundp 'find-processor-configuration-structure) (find-processor-configuration-structure)) ;; These are initializations that have to be done before other initializations (INITIALIZATIONS 'SYSTEM-INITIALIZATION-LIST T) ;; At this point if the window system is loaded, it is all ready to go ;; and the initial Lisp listener has been exposed and selected. So do ;; any future typeout on it. But if any typeout happened on the cold-load ;; stream, leave it there (clobbering the Lisp listener's bits). This does not ;; normally happen, but just in case we do the set-cursorpos below so that ;; if anything strange gets typed out it won't get erased. Note that normally ;; we do not do any typeout nor erasing on the cold-load-stream, to avoid bashing ;; the bits of whatever window was exposed before a warm boot. (COND (CALLED-BY-USER) ((FBOUNDP 'TV::WINDOW-INITIALIZE) (MULTIPLE-VALUE-BIND (X Y) (SEND *TERMINAL-IO* :READ-CURSORPOS) (SEND TV::INITIAL-LISP-LISTENER :SET-CURSORPOS X Y)) (SETQ *TERMINAL-IO* TV::INITIAL-LISP-LISTENER) (SEND *TERMINAL-IO* :SEND-IF-HANDLES :SET-PACKAGE *PACKAGE*) (SEND *TERMINAL-IO* :FRESH-LINE)) (T (SETQ TV::INITIAL-LISP-LISTENER NIL) ;Not created yet (SEND *TERMINAL-IO* :CLEAR-REST-OF-LINE))) (WHEN CURRENT-PROCESS (SEND CURRENT-PROCESS :RUN-REASON 'LISP-INITIALIZE)) ;; prevent screw from things being traced during initialization (if (fboundp 'untrace) (untrace)) (if (fboundp 'breakon) (unbreakon)) ;; Have to check explicitly for cold-booting since can't just rely on initializations ;; to see that everything in this list has already run (ie at last cold boot) ;; since luser may have added own new inits since then ;; The "SYSTEM-START-UP-FILE" is run first, because it may set up the network ;; address etc. (WHEN *COLD-BOOTING* (IF (FBOUNDP 'EXECUTE-SYSTEM-STARTUP-FILE) (EXECUTE-SYSTEM-STARTUP-FILE)) (INITIALIZATIONS 'COLD-INITIALIZATION-LIST)) (INITIALIZATIONS 'WARM-INITIALIZATION-LIST T) (IF (BOUNDP 'EH::ERROR-TABLE) (EH::ENABLE-TRAPPING)) (AND *COLD-BOOTING* (BOUNDP 'TIME:*LAST-TIME-UPDATE-TIME*) (let ((frob (catch-error (list si:local-host (get-universal-time))))) (when frob (push frob cold-boot-history)))) (SETQ *COLD-BOOTING* NIL) (IF (FBOUNDP 'PRINT-HERALD) (PRINT-HERALD) (SEND *STANDARD-OUTPUT* :FRESH-LINE) (PRINC "Lisp Machine cold load environment, beware! ;; *READ//PRINT-BASE* = ") (LET ((*PRINT-BASE* 10.)) (PRINC *READ-BASE*)) (PRINC ", *PACKAGE* = ") (PRINC (PACKAGE-NAME *PACKAGE*)) (PRINC ".")) ;; This process no longer needs to be able to run except for the usual reasons. ;; The delayed-restart processes may now be allowed to run (WHEN CURRENT-PROCESS (SEND CURRENT-PROCESS :REVOKE-RUN-REASON 'LISP-INITIALIZE) (WHEN WARM-BOOTED-PROCESS (FORMAT T "Warm boot while running ~S. Its variable bindings remain in effect; its unwind-protects have been lost.~%" WARM-BOOTED-PROCESS) (WHEN (NOT (OR (EQ (PROCESS-WARM-BOOT-ACTION WARM-BOOTED-PROCESS) 'PROCESS-WARM-BOOT-RESTART) (EQ WARM-BOOTED-PROCESS INITIAL-PROCESS) (TYPEP WARM-BOOTED-PROCESS 'SI:SIMPLE-PROCESS))) (IF (YES-OR-NO-P "Reset it? Answer No if you want to debug it. ") (RESET-WARM-BOOTED-PROCESS) (FORMAT T "~&Do ~S to examine it, or do /~S to reset it and let it run again.~% If you examine it, you will see a state that is not quite the latest one." '(DEBUG-WARM-BOOTED-PROCESS) '(RESET-WARM-BOOTED-PROCESS))))) (LOOP FOR (P . RR) IN DELAYED-RESTART-PROCESSES DO (WITHOUT-INTERRUPTS (SETF (PROCESS-RUN-REASONS P) RR) (PROCESS-CONSIDER-RUNNABILITY P))) (SETQ DELAYED-RESTART-PROCESSES NIL)) ;; The global value of *TERMINAL-IO* is a stream which goes to an auto-exposing ;; window. Some processes, such as Lisp listeners, rebind it to something else. ;; CALLED-BY-USER is T if called from inside one of those. (WHEN (AND (NOT CALLED-BY-USER) (FBOUNDP TV::DEFAULT-BACKGROUND-STREAM) (NEQ (SYMBOL-FUNCTION TV::DEFAULT-BACKGROUND-STREAM) COLD-LOAD-STREAM)) (SETQ *TERMINAL-IO* TV::DEFAULT-BACKGROUND-STREAM)) ;; Now that -all- initialization has been completed, allow network servers if we are an ;; ordinary machine. If we are a primarily a server, an INIT file should call ;; (SI:ENABLE-SERVICES). The idea is that random machines aren't important enough to ;; be manually enabled as servers, but real server machines should, so that they ;; have a chance to be properly initialized, which would usually include loading an ;; INIT file which did things like load patches and salvage the file system. (when (fboundp 'get-site-option) (unless (get-site-option :server-machine) (enable-services)) (when (and (get-site-option :default-initial-form) cold-boot) (maybe-execute-default-initial-form))) ) ))