;;; -*- Mode:Common-Lisp; Package:SI; Base:8.; Cold-Load:t; -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1986- 1989 Texas Instruments Incorporated. All rights reserved. ;;; This file contains the actual workings of Disk-Save. ;;; ;;; Edit History ;;; ;;; Patch ;;; Date Author Number Description ;;;------------------------------------------------------------------------------ ;;; 01-10-86 ab Original. ;;; 02-13-86 ab Common Lisp conversion for VM2. ;;; 03-10-86 ab Fixed bug in VA-Valid-P that caused regions ;;; whose starting addresses were 24-bit numbers ;;; but whose ending addresses were 25-bit numbers ;;; not to be seen as valid (hence not copied). ;;; Re-wrote Save-SCA to read in previously saved ;;; area from disk & make necessary modifications. ;;; This way, we avoid saving side-effects to SCA ;;; that occurred between Save-Wired-Pages (at ;;; beginning of save) and Save-SCA (at end of save). ;;; Re-wrote Save-Fixed-Non-Wired-Areas to save first ;;; partial cluster specially (using save-first- ;;; partial-cluster). This avoids smashing the ;;; parts of the just-saved wired pages (the parts ;;; that overlap the first partial cluster), hence ;;; avoids having to fix up these overlapping pages ;;; at the end of the save (their memory-version ;;; may have been side-effected by then). ;;; 04-03-86 ab Couple of array changes to avoid Common-Lisp ;;; restrictions. Fix Defvar of DS-RQBs. ;;; 04-09-86 ab Changes to be compatible with new LRU paging Ucode. ;;; This version now MUST be run with Ucode >= 285. ;;; 04-20-86 ab Fix up the status display. [SPR 933] ;;; 05-02-86 ab Fix VM image consistency problem during cons-critical ;;; section of code. Problem could cause resulting ;;; band to be un-gc-able. ;;; 05-09-86 ab Moved the setup of *Terminal-IO* to Cold-Load-Stream ;;; to Disk-Save-Caller function in DISK-SAVE-RESTORE. ;;; Change status display again. Figures now more ;;; accurate and time remaining granularity is 1/2 min. ;;; Also, it won't start displaying estimate until it ;;; has sampled longer during clearing-physical-memory ;;; phase. ;;; 05-14-86 ab Fix display % work done from going above 100 % in ;;; save-over-yourself mode. Minor tweak to status ;;; display so it shows 100 % done at very end. ;;; 05-20-86 ab Fix (again) VM image consistency problem during ;;; cons-critical code. Original fix didn't work. ;;; 06-23-86 ab Integrated into VM2. Derived from ;;; SYS:MEMORY-MANAGEMENT; DISK_SAVE_INTERNAL#2. ;;; This effectively integrates part of Rel 2.1 Ucode- ;;; Dependent patch 2-4 to VM2. ;;; Moved DPMT accessor macros to PAGE-DEFS file. ;;; 07-25-86 ab Fix minor bug in Calculate-Disk-Save-Work that ;;; underestimated the amount of clearing memory ;;; work to be done in save-over-self mode. ;;; 09-22-86 ab Moved Va-Valid-P to AREAS. Moved %Disk-Address, ;;; Count-Unmodified-Load-Band-Pages, and ;;; Make-All-Page-Devices-Read-Only to PAGE-DEVICE. ;;; Update Swap-Out-All-Pages for new physical-memory tables. ;;; 02-05-87 grh *1* Hacks to support saving SCA info to block 1 as well as ;;; block 2 of saved load band. ;;; 02-08-87 ab *tgc* Changed Disk-Save-Internal for TGC: ;;; - Call Return-Storage w/extra arg of T to force the ;;; return-storage code to execute even if %tgc-enabled. ;;; - Change order of functions slightly in cons-critical ;;; code section to further minimize critical window. ;;; 05-01-87 ab *P - Make sure cache inhibit gets set for disk-save RQBs. ;;; Required for Explorer II support. ;;; 01-18-88 ab -- Changes for MX. ;;; 01-21-88 ab -- - Fix DISK-SAVE not to hard-code the physical memory ;;; it uses for RQBs. ;;; 02-10-88 ab *4.17 - Store region free-pointer info after cons-critical ;;; code so we can tell if we've exceeded our pre-allocation. ;;; 2-19-88 RJF *4-23 - Fixed allocation to next page boundary to handle ;;; region change. ;;; 4-22-88 ab vm 4-2 - Fixed disk-save to partitions > 1 for the microExplorer. ;;; 8/29/88 ab vm 5-2 - Add support to DISK-SAVE on microExplorer to resize the ;;; load band after save completed. ;;; 9/22/88 RJF - Fixed update-sca to correctly calculate valid-size when ;;; band is greater than #xffff blocks. ;;; 04/25/89 RJF/HRC Added changes to allow disk-saving of band with EAS on. Added ;;; SWAP-OUT-WORLD-RECORD-AREA, SAVE-EXTERNAL-REGIONS, Save-area, ;;; and SAVE-EXTERNAL-CLUSTER. Changed Internal-Disk-save, Save ;;; -Page, and save-areas. ;;; 05/01/89 RJF Changed internal-disk-save to clear the disk-save stack group ;;; pdl pointers so we don't scavenge them when we reboot. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Misc Vars & Declarations (Proclaim '(special Cluster-Size Cluster-Size-In-Words First-Non-Fixed-Area-Name First-Non-Fixed-Wired-Area-Name Last-Fixed-Area-Name Band-Format-Is-Compressed-Code Disk-Save-Area %Logical-Page-Device-Information-Block-Length )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; DPMT Support ;;; Sets all DPMT entries to the appropriate initial values. (Defun Initialize-DPMT (dpmt num-entries) (dotimes (i num-entries) (set-dpmt-bitmap i 0 dpmt) ;All pages assigned to r/w band (0), dev A. (set-dpmt-device-status i 0 dpmt) (set-dpmt-device-A-status ;Dev A (page dev) RW-Unassigned i %DPMTE-Read-Write-But-No-Disk-Block-Assigned dpmt) (set-dpmt-device-B-status ;Dev B (load dev) Read-Only i %DPMTE-Read-Only-Band dpmt) (set-dpmt-device-B-offset i 0 dpmt) ;Both offsets 0. (set-dpmt-device-A-offset i 0 dpmt))) ;;; DPMT array is art-16b array. There are 2 DPMT words (4 entries) ;;; per DPMT cluster (16 pages). The DPMT holds enough cluster entries ;;; to represent all virtual pages. (Defun Calculate-DPMT-Array-Size () (lsh 4 (- (BYTE-SIZE %%q-pointer) (BYTE-SIZE %%va-offset-into-cluster) (BYTE-SIZE %%va-offset-into-page))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Status Display Help Functions ;;;; ;; DS-Display-Mode can be :normal, :debug, or nil (Defvar DS-Display-Mode :normal) (Defvar DS-Display-Debug nil) (Defvar DS-Dirty-Core-Page-Factor 3.6) (Defvar DS-Dirty-To-Total-Memory-Page-Ratio nil) (Defvar DS-Memory-Page-Factor 0.4) (Defvar DS-Migrate-Page-Factor 4.0) (Defvar DS-Save-Over-Self-Copy-Page-Factor 0.8) (Defvar DS-Normal-Copy-Page-Factor 1.) (Defvar DS-Fudge-Factor 800.) (Defvar DS-Total-Work nil) (Defvar DS-Work-Done nil) (Defvar DS-Start-Time nil) (Defvar DS-Write-Count 0) (Defvar DS-Saving-Over-Self nil) (Defvar DS-Start-Clock-Time nil) (Defvar DS-Unweighted-Work-Done nil) (Defvar DS-Previous-Time nil) (Defvar DS-Activity-Cursorpos-X nil) (Defvar DS-Activity-Cursorpos-Y nil) (Defvar DS-Percent-Cursorpos-X nil) (Defvar DS-Percent-Cursorpos-Y nil) (Defvar DS-Est-Time-Cursorpos-X nil) (Defvar DS-Est-Time-Cursorpos-Y nil) (Defvar DS-Elaps-Time-Cursorpos-X nil) (Defvar DS-Elaps-Time-Cursorpos-Y nil) (Defvar DS-Type-Work-Cursorpos-X nil) (Defvar DS-Type-Work-Cursorpos-Y nil) (Defvar DS-Time-Work-Cursorpos-X nil) (Defvar DS-Time-Work-Cursorpos-Y nil) (Defvar DS-Time-Estimate-Displayed nil) (Defvar DS-Display-Estimated-Time nil) (Defvar DS-Pages-Estimated-To-Migrate nil) (Defvar DS-Pages-Estimated-Dirty nil) (Defvar DS-Estimated-Dump-Size nil) (Defvar DS-Second-Dirty-Core-Page-Estimate nil) (Defvar DS-Pages-Actually-Migrated nil) (Defvar DS-Estimated-Memory-Size nil) (Defvar DS-Actual-Memory-Page-Count nil) (Defvar DS-Fudge-Array-Address nil) (Defvar DS-Fudge-Array-Initial-Value (DPB dtp-array-header %%q-data-type (%p-ldb %%q-pointer (MAKE-ARRAY 0)))) (Defvar DS-Fudge-List-Address nil) (Defvar DS-End-Region-FP nil) (DEFVAR ds-after-cons-critical-list-address 0) (DEFVAR ds-after-cons-critical-structure-address 0) ;;; Disk Save work to be done consists of: ;;; ;;; 1) Clearing physical memory & swapping out dirty pages. ;;; 2) Migrating unmodified load band pages to page band ;;; (only if in save-over-self mode) ;;; 3) Copying all allocated virtual memory from load/swap ;;; partitions to destination partition. ;;; ;;; Of these, 3) takes the shortest amount of time per page, ;;; 2) is next, and 1) takes the most time per page. ;;; This function figures out how many pages fall into each ;;; category, and returns a weighted sum of the three categories. ;;; The weights are relative indicators of time/page of each ;;; kind of work. (Defun Calculate-Disk-Save-Work () (let ((dirty-core-pages (estimate-modified-core-pages)) (mem-size (- (pages-of-physical-memory) (count-perm-wired-pages) (if DS-Saving-Over-Self 0 ;; If saving over self, free ;; pages will be used in process ;; of migrating LOD pages. (count-free-core-pages)))) (dump-size (estimate-dump-size)) (unmodified-load-band-pages (count-unmodified-load-band-pages)) work) (setq DS-Dirty-To-Total-Memory-Page-Ratio (if DS-Saving-Over-Self 1. ;; All core pages will be dirty after ;; we do (make-all-pages-dirty) (/ (float dirty-core-pages) mem-size))) (setq DS-Pages-Estimated-To-Migrate unmodified-load-band-pages) (setq DS-Pages-Estimated-Dirty dirty-core-pages) (setq DS-Estimated-Dump-Size dump-size) (setq DS-Estimated-Memory-Size mem-size) (setq work (+ (if DS-Saving-Over-Self (+ (* mem-size DS-Dirty-Core-Page-Factor) (* mem-size DS-Memory-Page-Factor)) (+ (* dirty-core-pages DS-Dirty-Core-Page-Factor) (* mem-size DS-Memory-Page-Factor))) (if DS-Saving-Over-Self (* dump-size DS-Save-Over-Self-Copy-Page-Factor) (* dump-size DS-Normal-Copy-Page-Factor)) (if DS-Saving-Over-Self (* unmodified-load-band-pages DS-Migrate-Page-Factor) 0) DS-Fudge-Factor)) ;; Record the start time and amount of work to do. (setq DS-Start-Time (time-in-60ths) DS-Previous-Time (time-in-60ths) DS-Write-Count 0 DS-Work-Done -250 ;; extra fudge DS-Unweighted-Work-Done 1 DS-Total-Work (floor work)) )) (Defun Record-Disk-Save-Work (npages type) (incf DS-Unweighted-Work-Done npages) (setq DS-Work-Done (+ DS-Work-Done (case type (:memory-page (+ (* npages DS-Memory-Page-Factor) (* DS-Dirty-Core-Page-Factor (* npages DS-Dirty-To-Total-Memory-Page-Ratio)))) (:migrate-page (* npages DS-Migrate-Page-Factor)) (:copy-page (if DS-Saving-Over-Self (* npages DS-Save-Over-Self-Copy-Page-Factor) (* npages DS-Normal-Copy-Page-Factor)))))) ) (Defun (:cond (NOT (addin-p)) Initialize-Disk-Save-Display) () ;; *Terminal-IO* has been set to the Cold-Load-Stream by Disk-Save-Caller. ;; We can't use other windows because we have to run with scheduling ;; absolutely inhibited. (calculate-disk-save-work) (if (eq DS-Display-Mode :normal) (progn (format *Terminal-IO* "~10%~55TDISK SAVE STATUS") (format *Terminal-IO* "~%~55T----------------") (format *Terminal-IO* "~6%~33T Disk-Save Started: ~a" (or DS-Start-Clock-Time "Time Unknown")) (format *Terminal-IO* "~6%~33T Current Activity: ") (multiple-value-setq (DS-Activity-Cursorpos-X DS-Activity-Cursorpos-Y) (send *Terminal-IO* :read-cursorpos)) (format *Terminal-IO* "~6%~33T Work Done: ") (multiple-value-setq (DS-Percent-Cursorpos-X DS-Percent-Cursorpos-Y) (send *Terminal-IO* :read-cursorpos)) (format *Terminal-IO* "0 %") ;; Leave Estimated Time Remaining blank for now. (format *Terminal-IO* "~6%") (setq DS-Time-Estimate-Displayed nil DS-Display-Estimated-Time t) (multiple-value-setq (DS-Est-Time-Cursorpos-X DS-Est-Time-Cursorpos-Y) (send *Terminal-IO* :read-cursorpos)) (when DS-Display-Debug (format *Terminal-IO* "~6%~33T Elapsed Time: ") (multiple-value-setq (DS-Elaps-Time-Cursorpos-X DS-Elaps-Time-Cursorpos-Y) (send *Terminal-IO* :read-cursorpos)) (format *Terminal-IO* "~%~33T Time / This Type Work Unit: ") (multiple-value-setq (DS-Type-Work-Cursorpos-X DS-Type-Work-Cursorpos-Y) (send *Terminal-IO* :read-cursorpos)) (format *Terminal-IO* "~%~33T Cumulative Time / Work Unit: ") (multiple-value-setq (DS-Time-Work-Cursorpos-X DS-Time-WOrk-Cursorpos-Y) (send *Terminal-IO* :read-cursorpos)))) ;; Simple message for debug & no-display mode. (format *Terminal-IO* "~3% Disk-Save in progress...")) ) (Defun (:cond (addin-p) Initialize-Disk-Save-Display) () ;; *Terminal-IO* has been set to the Cold-Load-Stream by Disk-Save-Caller. ;; We can't use other windows because we have to run with scheduling ;; absolutely inhibited. (calculate-disk-save-work) (if (eq DS-Display-Mode :normal) (progn (format *Terminal-IO* "~3%~37TDISK SAVE STATUS") (format *Terminal-IO* "~%~37T----------------") (format *Terminal-IO* "~3%~15T Disk-Save Started: ~a" (or DS-Start-Clock-Time "Time Unknown")) (format *Terminal-IO* "~3%~15T Current Activity: ") (multiple-value-setq (DS-Activity-Cursorpos-X DS-Activity-Cursorpos-Y) (send *Terminal-IO* :read-cursorpos)) (format *Terminal-IO* "~3%~15T Work Done: ") (multiple-value-setq (DS-Percent-Cursorpos-X DS-Percent-Cursorpos-Y) (send *Terminal-IO* :read-cursorpos)) (format *Terminal-IO* "0 %") ;; Leave Estimated Time Remaining blank for now. (format *Terminal-IO* "~3%") (setq DS-Time-Estimate-Displayed nil DS-Display-Estimated-Time t) (multiple-value-setq (DS-Est-Time-Cursorpos-X DS-Est-Time-Cursorpos-Y) (send *Terminal-IO* :read-cursorpos)) (when DS-Display-Debug (format *Terminal-IO* "~3%~15T Elapsed Time: ") (multiple-value-setq (DS-Elaps-Time-Cursorpos-X DS-Elaps-Time-Cursorpos-Y) (send *Terminal-IO* :read-cursorpos)) (format *Terminal-IO* "~%~15T Time / This Type Work Unit: ") (multiple-value-setq (DS-Type-Work-Cursorpos-X DS-Type-Work-Cursorpos-Y) (send *Terminal-IO* :read-cursorpos)) (format *Terminal-IO* "~%~15T Cumulative Time / Work Unit: ") (multiple-value-setq (DS-Time-Work-Cursorpos-X DS-Time-WOrk-Cursorpos-Y) (send *Terminal-IO* :read-cursorpos)))) ;; Simple message for debug & no-display mode. (format *Terminal-IO* "~3% Disk-Save in progress...")) ) ;;ab 3/18/88. Use :string-out instead of :line-out to avoid more-processing in cold load. (Defun Display-Disk-Save-Activity (string) (case DS-Display-Mode (:normal (send *Terminal-IO* :set-cursorpos DS-Activity-Cursorpos-X DS-Activity-Cursorpos-Y) (send *Terminal-IO* :clear-eol) (send *Terminal-IO* :string-out string)) (:debug (format *Terminal-IO* "~%~a" string)) )) (Defun Display-Disk-Save-Status (&optional (done nil) &aux time percent-work time-remaining time-per-work-unit elapsed-time mins secs) (when (eq DS-Display-Mode :normal) (setq time (time-in-60ths) elapsed-time (time-difference time DS-Start-Time) percent-work (truncate (* DS-Work-Done 100.0) DS-Total-Work) time-per-work-unit (/ (float elapsed-time) DS-Work-Done) time-remaining (floor (* time-per-work-unit (- DS-Total-Work DS-Work-Done)))) (multiple-value-setq (mins secs) (floor (truncate time-remaining 60.) 60.)) ;; Display percent work done (send *Terminal-IO* :set-cursorpos DS-Percent-Cursorpos-X DS-Percent-Cursorpos-Y) (send *Terminal-IO* :clear-eol) (if done (format *Terminal-IO* "100 %") (format *Terminal-IO* "~d %" percent-work)) (when DS-Display-Estimated-Time (unless DS-Time-Estimate-Displayed (send *Terminal-IO* :set-cursorpos DS-Est-Time-Cursorpos-X DS-Est-Time-Cursorpos-Y) (COND ((addin-p) (format *Terminal-IO* "~15T Estimated Time Left: ")) (t (format *Terminal-IO* "~33T Estimated Time Left: "))) ;; Now get new positions & reset flag. (multiple-value-setq (DS-Est-Time-Cursorpos-X DS-Est-Time-Cursorpos-Y) (send *Terminal-IO* :read-cursorpos)) (setq DS-Time-Estimate-Displayed t)) ;; Display estimated time remaining. (send *Terminal-IO* :set-cursorpos DS-Est-Time-Cursorpos-X DS-Est-Time-Cursorpos-Y) (send *Terminal-IO* :clear-eol) (setq secs (* (ceiling secs 30.) 30.)) ;; Round to next half minute. (when (= secs 60.) ;; If rounded to 60 seconds, (setq mins (1+ mins) ;; increment minutes. secs 0)) (if done (format *Terminal-IO* "Finished...") (format *Terminal-IO* "~a" (if (plusp mins) (format nil "~d~:[ 1/2 ~; ~]minute~p" mins (zerop secs) (if (zerop secs) mins 2)) (format nil "1/2 minute"))))) (when DS-Display-Debug (send *Terminal-IO* :set-cursorpos DS-Elaps-Time-Cursorpos-X DS-Elaps-Time-Cursorpos-Y) (send *Terminal-IO* :clear-eol) (multiple-value-bind (min sec) (floor (truncate elapsed-time 60.) 60.) (format *Terminal-IO* "~a~d second~:p" (if (plusp min) (format nil "~d minute~:p " min) "") sec)) (let* ((curr-time (time-in-60ths)) (elaps-time (time-difference curr-time DS-Previous-Time)) (time-per-work (/ (float elaps-time) DS-Unweighted-Work-Done))) (send *Terminal-IO* :set-cursorpos DS-Type-Work-Cursorpos-X DS-Type-Work-Cursorpos-Y) (send *Terminal-IO* :clear-eol) (format *Terminal-IO* "~6,4,0,,f" time-per-work) (setq DS-Previous-Time curr-time DS-Unweighted-Work-Done 1)) (send *Terminal-IO* :set-cursorpos DS-Time-Work-Cursorpos-X DS-Time-Work-Cursorpos-Y) (send *Terminal-IO* :clear-eol) (format *Terminal-IO* "~6,4,0,,f" time-per-work-unit)) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Disk I/O Support Routines ;;;; Disk-Save uses its own disk-io primitives in order to reduce overhead. ;;;; The RQB it sets up is non-standard (the data buffer is not even in ;;;; virtual memory). This was done to 1) avoid the overhead of wiring ;;;; and unwiring the RQB data pages each time an i/o request is issued; ;;;; and 2) reduce paging caused by wiring RQB data buffer pages and by ;;;; calling disk subsystem functions. ;; Number of elements in 16-B RQB command block array. (DefConstant DS-RQB-Command-Block-Size 100.) (DEFCONSTANT %DS-RQB-Leader-Word-Unused 0) (DEFCONSTANT %DS-RQB-Data-Buffer-Phys-Adr-Slot-Offset 1) (DEFCONSTANT %DS-RQB-Data-Buffer-Phys-Adr-Slot-Bits 2) (DEFCONSTANT %DS-RQB-Data-Buffer-Array 3) (DefParameter DS-RQB-Leader-Elements '(%DS-RQB-Leader-Word-Unused %DS-RQB-Data-Buffer-Phys-Adr-Slot-Offset %DS-RQB-Data-Buffer-Phys-Adr-Slot-Bits %DS-RQB-Data-Buffer-Array)) (DefVar DS-RQB-1 nil) (DefVar DS-RQB-2 nil) ;;ab 1/21/88. Don't init RQBs here. Wait until after SWAP-OUT-ALL-PAGES when ;; we know where they will be. (Defun Make-Disk-Save-RQBs () ;; We must make sure that the whole RQB command block is on the same page. ;; Actually, since each of our 2 command blocks is 50. words long (+ overhead of 7), ;; the two of them will fit on one page. Thus make sure we're on a page boundary ;; before we do the make-arrays. If not, cons a bit until we are. (DECLARE (INLINE convert-to-unsigned)) (let* ((curr-adr ;; Address of 0 length array will be the last used word in the current ;; structure region. (convert-to-unsigned (%pointer (make-array 0)))) (next-page-adr (+ Page-Size (logand curr-adr (- Page-Size)))) (words-to-next-page (- next-page-adr curr-adr 1))) ;; Use up space between here & next page. (when (not (zerop words-to-next-page)) (make-array (1- words-to-next-page)))) ;; Make the arrays. (setq DS-RQB-1 (make-array DS-RQB-Command-Block-Size :element-type '(unsigned-byte 16.) :leader-length (length DS-RQB-Leader-Elements))) (setq DS-RQB-2 (make-array DS-RQB-Command-Block-Size :element-type '(unsigned-byte 16.) :leader-length (length DS-RQB-Leader-Elements))) ;; ;; Wire them & set up leaders with the appropriate physical addresses ;; ;; (although we haven't freed up the physical memory yet). ;; (let* ((phys-pgs (pages-of-physical-memory)) ;; (first-pfn-1 (- phys-pgs DS-RQB-Size)) ;; (first-pfn-2 (- first-pfn-1 DS-RQB-Size))) ;; (ds-init-rqb DS-RQB-1 first-pfn-1 DS-RQB-Size) ;; (ds-init-rqb DS-RQB-2 first-pfn-2 DS-RQB-Size)) ) ;;ab 1/21/88. Change args to this & have it called after SWAP-OUT-ALL-PAGES. (Defun DS-Init-RQB-Addrs (rqb slot offset npages &aux nubus-address) ;; Wire the command block array. (wire-array rqb) ;; Now initialize the RQB command block ;; Leader element 1 contains the slot offset portion of the RQB data buffer physical address. ;; Leader element 2 contains slot address (#x+Fs) portion of the RQB data buffer physical address. ;; These will be used in setting up the data buffer address in the command block. ;; First calculate the NuBus 32-bit address of the data buffer's first page number. (setf (array-leader rqb %DS-RQB-Data-Buffer-Phys-Adr-Slot-Bits) slot) (setf (array-leader rqb %DS-RQB-Data-Buffer-Phys-Adr-Slot-Offset) offset) ;; Leader element 3 contains displaced physical array pointing to data buffer in physical memory (SETQ nubus-address (DPB slot %%Nubus-F-And-Slot-Bits offset)) (setf (array-leader rqb %DS-RQB-Data-Buffer-Array) (make-array (* npages Page-Size 2) :type 'ART-16b :displaced-to-physical-address nubus-address)) ;; Zero out all of the command block. (loop FOR i FROM 0 BELOW DS-RQB-Command-Block-Size DOING (setf (aref rqb i) 0)) (when (eq DS-Display-Mode :debug) (format *Terminal-Io* "~%DS-RQB-1: #o+~o, Slot bits: #x+~16r, Offset: #x+~16r ~ ~%DS-RQB-2: #o+~o, Slot bits: #x+~16r, Offset: #x+~16r" (%pointer (%find-structure-leader DS-RQB-1)) (array-leader DS-RQB-1 %DS-RQB-Data-Buffer-Phys-Adr-Slot-Offset) (array-leader DS-RQB-1 %DS-RQB-Data-Buffer-Phys-Adr-Slot-Bits) (%pointer (%find-structure-leader DS-RQB-2)) (array-leader DS-RQB-2 %DS-RQB-Data-Buffer-Phys-Adr-Slot-Offset) (array-leader DS-RQB-2 %DS-RQB-Data-Buffer-Phys-Adr-Slot-Bits))) ) ;;; Sets up the appropriate fields in the command block and initiates the i/o. ;;; Note that this function does no error checking on OFFSET, NPAGES, etc in ;;; order to be fast, so the args better be right! ;;ab 1/18/88. Change for MX. (DefSubst DS-Disk-IO (rqb unit address npages offset cmd) (let* ((transfer-length (* npages Page-Size 4.)) (data-start-offset (array-leader rqb %DS-RQB-Data-Buffer-Phys-Adr-Slot-Offset)) (offset-offset (+ data-start-offset (* offset Page-Size 4.)))) ;; Clear the info word (setf (aref rqb %IO-RQ-INFORMATION) 0) (setf (aref rqb %IO-RQ-INFORMATION-HIGH) 0) ;; Set up command and physical unit (also clears option word) (setf (aref rqb %IO-RQ-COMMAND-HIGH) (dpb cmd %%IO-RQ-Command-Command 0)) (setf (aref rqb %IO-RQ-COMMAND) unit) ;; Clear the status words. (setf (aref rqb %IO-RQ-STATUS) 0) (setf (aref rqb %IO-RQ-STATUS-HIGH) 0) ;; Set up physical address of the data buffer. This will change for ;; different values of OFFSET. The physical address of the data buffer ;; associated with this command block is stored in 2 parts in the array ;; leader. Note that we do not have to worry about scatter tables, ;; since the data buffer is contiguous in physical memory. (setf (aref rqb %IO-RQ-BUFFER) (ldb %%Q-LOW-HALF offset-offset)) (setf (aref rqb %IO-RQ-BUFFER-HIGH) (+ (lsh (array-leader rqb %DS-RQB-Data-Buffer-Phys-Adr-Slot-Bits) (BYTE-SIZE %%Nubus-F-and-Slot-Bits)) (ldb %%Q-HIGH-HALF offset-offset))) ;; Set up transfer length (in bytes) (setf (aref rqb %IO-RQ-TRANSFER-LENGTH) (ldb %%Q-LOW-HALF transfer-length)) (setf (aref rqb %IO-RQ-TRANSFER-LENGTH-HIGH) (ldb %%Q-HIGH-HALF transfer-length)) ;; Set up disk block to read (setf (aref rqb %IO-RQ-DEVICE-ADDRESS) (ldb %%Q-LOW-HALF address)) (setf (aref rqb %IO-RQ-DEVICE-ADDRESS-HIGH) (ldb %%Q-HIGH-HALF address)) ;; Initiate the i/o. (%io rqb #+elroy (AREF disk-type-table ; device descriptor (IF (resource-present-p :disk) (get-logical-unit unit) *default-disk-unit*) ;ab 4-22-88, vm 4-2 7.) #-elroy *Nupi*) )) (Defun DS-Disk-Read (rqb unit address npages offset) (ds-disk-io rqb unit address npages offset %NUPI-COMMAND-READ)) (Defun DS-Disk-Write (rqb unit address npages offset) (ds-disk-io rqb unit address npages offset %NUPI-COMMAND-WRITE)) ;;; Waits for i/o done to be signalled in the RQB call block. ;;; Crashes if i/o takes too long or if disk error. ;;ab 1/18/88. Change for MX. (Defun DS-Wait-IO-Complete (rqb) (do ((timeout-count 0 (1+ timeout-count))) ((%io-done rqb) ;; Check for device error (when (ldb-test %%NUPI-STATUS-HIGH-ERROR (aref rqb %IO-RQ-STATUS-HIGH)) (ferror nil "*** FATAL ERROR IN DISK-SAVE: NuPi Device or Controller error encountered. ~ ~% Error type: ~a" (decode-nupi-status rqb)))) ;; Don't time out for MX. (when (AND (> timeout-count 500000.) (resource-present-p :disk)) ;; Note: Timeout count is about 18-20 seconds as currently written. ;; If processing speeds change, this will have to be re-done. (ferror nil "*** FATAL ERROR IN DISK-SAVE: Disk request timed out.")) )) ;;; Returns an array which is displaced to the data buffer. (DefSubst DS-RQB-Data-Buffer (rqb) (array-leader rqb %DS-RQB-Data-Buffer-Array)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; RQB manipulation / page saving routines ;;;; These routines manage disk-save's RQBs, filling them with pages ;;;; to be written out to the new band, and performing the i/o. (Defvar DS-RQB nil) (Defvar DS-RQB-Page-Offset 0) (Defvar DS-Destination-Disk-Address nil) (DefVar DS-Last-Disk-Address nil) (DefVar DS-Last-Unit nil) (DefVar DS-Consecutive-Pages nil) (DefVar DS-First-Time-Thru :unbound) ;;; Timing tests indicate 256. is the best buffer size. I/O ;;; timings don't decrease if it's bigger. (DefConstant DS-RQB-Size 256.) ;; This is in pages. (Defun Init-Disk-Vars (save-part-base VA) (setq DS-RQB DS-RQB-1) ;; Make sure io-done bit is set in RQB for first time thru ;; double-buffer read/write loop. (setf (aref DS-RQB-1 %IO-RQ-INFORMATION) (dpb 1 %%IO-RQ-DONE 0)) (setf (aref DS-RQB-2 %IO-RQ-INFORMATION) (dpb 1 %%IO-RQ-DONE 0)) ;; Set global var to disk block where we want to start saving. ;; Leave space in save band for wired pages. (setq DS-Destination-Disk-Address (+ save-part-base (truncate VA Disk-Block-Word-Size))) (setq DS-Consecutive-Pages 0 DS-RQB-Page-Offset 0 DS-Last-Unit -1 DS-Last-Disk-Address -1 DS-First-Time-Thru t)) ;;; The algorithm used here follows closely the one used by the Ucode disk-save. ;;; On entry, VA is the virtual address of the page we're considering. We scan, ;;; in general, increasing virtual addresses (at least within regions). ;;; DISK-BLOCK and UNIT represent where the page can be found on the source band. ;;; Since it is very likely that successive VA's will be contigous on the LOAD ;;; or PAGE band they live on, the idea is to minimize i/o operations by keeping ;;; track of contiguous disk addresses, and perform the read only when we get ;;; a disk address that isn't contiguous with the last one. ;;; ;;; Definition of variables: ;;; DS-Destination-Disk-Address always contains the absolute disk address of ;;; the next free block in the TARGET partition. This will always be ;;; on a 16-page boundary, since we always save all pages in a cluster ;;; (even if some aren't really allocated virtual memory). ;;; DS-Consecutive-Pages is a running count of disk addresses that are ;;; contiguous (on same unit and = last address + 1) ;;; DS-Last-Unit and DS-Last-Disk-Address keep track of the disk address of ;;; the VA we considered last time through this routine. ;;; DS-RQB-Offset is the page offset into the RQB data buffer where the ;;; next read's data should begin. ;;; DS-First-Time-Thru flags initial entry. This is important because the ;;; actual i/o being done at any give time is for the address considered ;;; the last time thru the loop. ;;; ;;; As we write pages to the destination band, we must update the new world's ;;; DPMT with the page's address in the new partition. We do this once per cluster. ;;; FILL-IN-DPMT will be T for the first VA in a cluster, else nil. ;;; ;;; This is really ugly code. I apologize. But it's fast! (Defun Save-Page (VA new-dpmt fill-in-DPMT disk-block unit save-part-base save-part-size save-unit &OPTIONAL (CLUSTER NIL)) ;; Crash now if save band too small. (when (>= (+ (- DS-Destination-Disk-Address save-part-base) (* DS-RQB-Size disk-blocks-per-page)) save-part-size) (ferror nil "*** FATAL ERROR IN DISK-SAVE: Save partition too small. Size: ~d." save-part-size)) ;; New cluster. Fill in its new DPMT entry. (when fill-in-DPMT (IF CLUSTER ;; HERE WE ARE SAVING A PAGE OF AN EXTERNAL REGION (PROGN (SETF (AREF CLUSTER 0) #X6020FFFF) ;; SET ALL PAGES OF CLUSTER TO DEV B, LOAD BAND ;; ALSO STAT-A = 3, STAT-B = 1, DEV-A = DEV-B = 0. (SETF (AREF CLUSTER 1) (floor (- (+ DS-Destination-Disk-Address (* DS-RQB-Page-Offset disk-blocks-per-page) (* DS-Consecutive-Pages disk-blocks-per-page)) save-part-base) Cluster-Size-In-Blocks))) ;; ELSE OF IF (let ((cluster-number (floor VA Cluster-Size-in-Words))) ;; Assign all pages to load band (dev B) in new DPMT (set-dpmt-bitmap cluster-number (- %DPMT-ASSIGNED-TO-LOAD-BAND) new-dpmt) ;; Record Dev B (Load Band) offset. This is offset in the NEW partition. (set-dpmt-device-B-offset cluster-number (floor (- (+ DS-Destination-Disk-Address (* DS-RQB-Page-Offset disk-blocks-per-page) (* DS-Consecutive-Pages disk-blocks-per-page)) save-part-base) Cluster-Size-In-Blocks) new-dpmt)))) ;; Now process RQB. ;; This is written to maximize the overlap of computation and i/o, and ;; to minimize the number of reads required to fill our RQB. (if (and (< (+ DS-RQB-Page-Offset DS-Consecutive-Pages) DS-RQB-Size) (= unit DS-Last-Unit) (= (+ DS-Last-Disk-Address disk-blocks-per-page) disk-block)) ;; If this disk address is one PAGE farther than last one on same unit, ;; just add it to list of blocks to read (provided there's space in RQB). (setq DS-Last-Disk-Address disk-block DS-Consecutive-Pages (1+ DS-Consecutive-Pages)) ;; If it's not on same unit or contiguous, we must perform read for RQB ;; already set up, then start new list with this address. (progn (if DS-First-Time-Thru (setq DS-First-Time-Thru nil) (progn ;; Wait for prior read or write to complete. (ds-wait-io-complete DS-RQB) ;; Initiate i/o. (ds-disk-read DS-RQB DS-Last-Unit (- DS-Last-Disk-Address (- (* DS-Consecutive-Pages disk-blocks-per-page) disk-blocks-per-page)) DS-Consecutive-Pages DS-RQB-Page-Offset) )) (setq DS-Last-Unit unit DS-Last-Disk-Address disk-block DS-RQB-Page-Offset (+ DS-RQB-Page-Offset DS-Consecutive-Pages) DS-Consecutive-Pages 1))) ;; If RQB is filled, initiate a write. (when (= DS-RQB-Page-Offset DS-RQB-Size) ;; Note fact we're copying a block of pages. (record-disk-save-work DS-RQB-Size :copy-page) (incf DS-Write-Count) (when (zerop (rem DS-Write-Count 4.)) (display-disk-save-status)) ;; Wait for any i/o on this RQB to finish (would be a read). (ds-wait-io-complete DS-RQB) ;; Initiate the write (ds-disk-write DS-RQB save-unit DS-Destination-Disk-Address DS-RQB-Size 0) (setq DS-Destination-Disk-Address (+ DS-Destination-Disk-Address (* DS-RQB-Size disk-blocks-per-page))) (setq DS-RQB-Page-Offset 0) ;; Next time through start filling other RQB. Make sure any ;; outstanding i/o on other RQB is done also. (setq DS-RQB (if (eq DS-RQB DS-RQB-1) DS-RQB-2 DS-RQB-1))) ) ;;; Finish last read/write if necessary. ;;; Note DPMT already updated for these pages, but must increase ;;; DS-Destination-Disk-Address properly to track where we left off. ;;; Full RQBs are always written immediately, but there will always ;;; be a partial read left to do, then a write (unless it was 1st time thru). (Defun Force-RQB-Write (save-unit) (unless DS-First-Time-Thru ;; Wait for prior read or write to complete. (ds-wait-io-complete DS-RQB) ;; Perform partial read. (ds-disk-read DS-RQB DS-Last-Unit (- DS-Last-Disk-Address (- (* DS-Consecutive-Pages disk-blocks-per-page) disk-blocks-per-page)) DS-Consecutive-Pages DS-RQB-Page-Offset) ;; Note work about to be done. (record-disk-save-work (+ DS-RQB-Page-Offset DS-Consecutive-Pages) :copy-page) (incf DS-Write-Count) (when (zerop (rem DS-Write-Count 8.)) (display-disk-save-status)) (ds-wait-io-complete DS-RQB) ;; Now write. (ds-disk-write DS-RQB save-unit DS-Destination-Disk-Address (+ DS-RQB-Page-Offset DS-Consecutive-Pages) 0) ;; Fix up vars for next time thru. (setq DS-First-Time-Thru t DS-Destination-Disk-Address (+ DS-Destination-Disk-Address (* (+ DS-RQB-Page-Offset DS-Consecutive-Pages) disk-blocks-per-page)) DS-RQB-Page-Offset 0 DS-Consecutive-Pages 0 DS-Last-Unit -1 DS-Last-Disk-Address -1))) ;;; The PERMANENTLY-WIRED pages exist in low physical memory and are allocated ;;; to areas up through Address-Space-Map area. They are read in from disk ;;; during boot, but are never swapped out after that. Since their image on ;;; disk does not represent their current state, we must save them off from ;;; memory. ;;ab 1/18/88. Change for MX. (Defun Save-Wired-Pages (save-part-base save-unit) (let* ((num-pages (number-of-system-wired-pages)) ;; Number of bytes = num-pages * page-size-in-bytes (transfer-byte-count (lsh num-pages (BYTE-SIZE %%Physical-Page-Offset))) ;; Start of wired pages is at virtual page 0. Get physical address. (phys-addr (%physical-address 0))) ;; Hack RQB to set it up to point to permanently ;; wired pages. Note this can be done in one arbitrarily large ;; transfer because we're just dumping the first number-of-wired-pages ;; physical memory pages to disk. ;; Clear the info word (setf (aref DS-RQB-1 %IO-RQ-INFORMATION) 0) (setf (aref DS-RQB-1 %IO-RQ-INFORMATION-HIGH) 0) ;; Set up write command and physical unit. (setf (aref DS-RQB-1 %IO-RQ-COMMAND-HIGH) (dpb %NuPI-Command-Write %%IO-RQ-Command-Command 0)) (setf (aref DS-RQB-1 %IO-RQ-COMMAND) save-unit) ;; Clear the status words. (setf (aref DS-RQB-1 %IO-RQ-STATUS) 0) (setf (aref DS-RQB-1 %IO-RQ-STATUS-HIGH) 0) ;; Set up Data Buffer pointer: physical address of start of data. (setf (aref DS-RQB-1 %IO-RQ-BUFFER) (ldb %%Q-LOW-HALF phys-addr)) (setf (aref DS-RQB-1 %IO-RQ-BUFFER-HIGH) (ldb %%Q-HIGH-HALF phys-addr)) ;; Set up transfer length. (setf (aref DS-RQB-1 %IO-RQ-TRANSFER-LENGTH) (ldb %%Q-LOW-HALF transfer-byte-count)) (setf (aref DS-RQB-1 %IO-RQ-TRANSFER-LENGTH-HIGH) (ldb %%Q-HIGH-HALF transfer-byte-count)) ;; Set up disk block to write: start of partition (setf (aref DS-RQB-1 %IO-RQ-DEVICE-ADDRESS) (ldb %%Q-LOW-HALF save-part-base)) (setf (aref DS-RQB-1 %IO-RQ-DEVICE-ADDRESS-HIGH) (ldb %%Q-HIGH-HALF save-part-base)) ;; Initiate the i/o and wait for it to complete. (%io DS-RQB-1 #+elroy (AREF disk-type-table ; device descriptor (IF (resource-present-p :disk) (get-logical-unit save-unit) *default-disk-unit*) ;ab 4-22-88, vm 4-2 7.) #-elroy *Nupi*) ;; Record work done. Call these copy pages since that's the fastest. (record-disk-save-work num-pages :copy-page) (ds-wait-io-complete DS-RQB-1) )) ;;;; Even though the wired pages are saved off early, we must later update some ;;;; of them in the save partition with new info garnered during the save. The ;;;; next few routines do saving of these special areas. ;;; Copy the new partition's DPMT into the RQB and write it out to save band ;;; in appropriate place. This must be done AFTER all other pages are saved. (Defun Save-New-DPMT (save-part-base save-unit new-dpmt) (DECLARE (INLINE convert-to-unsigned)) (let ((dpmt-last-index-to-copy (1- (array-total-size new-dpmt))) (dpmt-num-pages (ceiling (truncate (calculate-dpmt-array-size) 2) Page-Size)) (save-partition-dpmt-block-offset ;; DPMT is in the wired pages, which take up one disk ;; block per page of virtual memory at the start of the band. (truncate (convert-to-unsigned (AREF #'region-origin Disk-Page-Map-Area)) Disk-Block-Word-Size))) ;; Note: the current dpmt is 32. pages long. (when (> dpmt-num-pages DS-RQB-Size) (ferror nil "*** FATAL ERROR IN DISK-SAVE: RQB too small for DPMT, ~d. pages needed" dpmt-num-pages)) ;; Copy new-DPMT data into RQB for writing. (copy-array-portion new-dpmt 0 dpmt-last-index-to-copy (ds-rqb-data-buffer DS-RQB-2) 0 dpmt-last-index-to-copy) ;; Perform the i/o. (ds-disk-write DS-RQB-2 save-unit (+ save-part-base save-partition-dpmt-block-offset) dpmt-num-pages 0) (ds-wait-io-complete DS-RQB-2) )) ;;; Update SCA area saved previously. Read in disk-version, update it ;;; and write it back out. (Defun Update-SCA (save-part-base save-unit) ;; Need to make sure info stored in our in the SCA is valid for the ;; new band. Read SCA we saved earlier back in from disk. (let* ((SCA-block-offset (floor (AREF #'region-origin System-Communication-Area) Disk-Block-Word-Size)) (SCA-npages (floor (AREF #'region-length System-Communication-Area) Page-Size)) (sca-disk-adr (+ save-part-base SCA-block-offset)) (block-1-disk-adr (+ save-part-base 1)) ;; *1* (buf1 (ds-rqb-data-buffer DS-RQB-1)) ;; *1* (buf2 (ds-rqb-data-buffer DS-RQB-2)) valid-size) ;; Read in saved SCA from disk. (ds-disk-read DS-RQB-2 save-unit sca-disk-adr SCA-npages 0) (ds-wait-io-complete DS-RQB-2) ;; Duplicate some information in the second half of the first page where the old ;; 1k page bands expect it to be. ;; Read in saved SCA from disk. (ds-disk-read DS-RQB-1 save-unit sca-disk-adr SCA-npages 0) (ds-wait-io-complete DS-RQB-1) ;; Set correct values for band format, valid size, Ucode version. ;; Band Format Compressed = code #o2000. (setf (get-16b-array-word buf1 8. ) ;; 1k - %Sys-Com-Band-Format) (dpb dtp-fix %%Q-Data-Type Band-Format-Is-Compressed-Code)) ;; Desired Ucode is either from error handler or current running Ucode number. (setf (get-16b-array-word buf1 24.) ;; 1k - %Sys-Com-Desired-Microcode-Version) (dpb dtp-fix %%Q-Data-Type (IF (AND (VARIABLE-BOUNDP eh:*error-table-number*) (NUMBERP eh:*error-table-number*)) eh:*error-table-number* %Microcode-Version-Number))) ;; Valid size in words = # blocks written * disk-block-word-size (setq valid-size (dpb dtp-fix %%Q-Data-Type (* (- DS-Destination-Disk-Address save-part-base) Disk-Block-Word-Size))) (setf (get-16b-array-word buf1 %Sys-Com-Valid-Size) valid-size) ;; Write to block 1 of band (this is a hack to help menu-boot) (ds-disk-write DS-RQB-1 save-unit block-1-disk-adr SCA-npages 0) (ds-wait-io-complete DS-RQB-1) ;; Set correct values for band format, valid size, Ucode version. ;; Band Format Compressed = code #o2000. (setf (get-16b-array-word buf2 %Sys-Com-Band-Format) (dpb dtp-fix %%Q-Data-Type Band-Format-Is-Compressed-Code)) ;; Desired Ucode is either from error handler or current running Ucode number. (setf (get-16b-array-word buf2 %Sys-Com-Desired-Microcode-Version) (dpb dtp-fix %%Q-Data-Type (IF (AND (VARIABLE-BOUNDP eh:*error-table-number*) (NUMBERP eh:*error-table-number*)) eh:*error-table-number* %Microcode-Version-Number))) ;; Valid size in words = # blocks written * disk-block-word-size (setq valid-size (dpb dtp-fix %%Q-Data-Type (* (- DS-Destination-Disk-Address save-part-base) Disk-Block-Word-Size))) (setf (get-16b-array-word buf2 %Sys-Com-Valid-Size) valid-size) ;; Write SCA back out. (ds-disk-write DS-RQB-2 save-unit sca-disk-adr SCA-npages 0) (ds-wait-io-complete DS-RQB-2) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Help Functions ;;;; ;;; This function makes sure that all virtual pages currently in physical memory ;;; have a disk address associated with them. Dirty pages in memory may not yet ;;; have swap space assigned, or their swap image may not be updated. Here we ;;; assure they are swapped out. ;;; Since there is no %SWAP-OUT primitive, we use %DELETE-PHYSICAL-PAGE. This ;;; has the unfortunate side effect of marking the physical page as not available ;;; to hold a virtual page (ie, removed from the available physical page pool). We ;;; must therefore add the page back in with %CREATE-PHYSICAL-PAGE. When this ;;; function is done, memory is clean. ;;ab 1/21/88. Remove NUMBER-TO-LEAVE-DELETED support. (Defun Swap-Out-All-Pages (&optional ignore (display-for-disk-save nil)) (let* ((phys-pgs (pages-of-physical-memory)) (ppd-slot (get-ppd-slot-addr)) (ppd-offset (get-ppd-slot-offset)) (all-pages 1) (rem 0) (DS-Display-Estimated-Time nil) (reserve-counter 0)) (dotimes (page-frame-number phys-pgs (setq DS-Actual-Memory-Page-Count all-pages)) ;; Don't waste time deleting/creating perm wired or free pages. (unless (or (page-free-p page-frame-number ppd-slot ppd-offset) (page-perm-wired-p page-frame-number ppd-slot ppd-offset)) (IF (< reserve-counter 400.) (when (%delete-physical-page page-frame-number) ;; Add back into PPD (%create-physical-page page-frame-number) (incf reserve-counter)) ;; GET A RESERVE OF PROCESSED PAGES AT THE FRONT OF THE LRU. (%DELETE-PHT-ENTRY PAGE-FRAME-NUMBER)) ;; USE FAST METHOD FOR THE MIDDLE ;; Note work done. (incf all-pages) ;; Wait a while before displaying estimated time remaining. This ;; is because we can get better estimates with more time behind us. (when (> all-pages 3001.) (setq DS-Display-Estimated-Time t)) (when display-for-disk-save (when (zerop (setq rem (rem all-pages 1500.))) (record-disk-save-work 1500. :memory-page) ;; (display-disk-save-status) )))) ;; Record last group of less than 1500. pages processed. (when display-for-disk-save (record-disk-save-work rem :memory-page) ;; (display-disk-save-status) ) )) ;; Makes all allocated pages of virtual memory dirty so that they will (eventually) ;; be assigned swap band addresses. This is used only when saving on top of the ;; currently running band. ;; Notes: 1) This is painfully slow, since it uses the virtual memory system ;; to "automatically" do the swap-in swap-out when pages are read ;; and written. ;; 2) The dirtied pages will not necessarily all be assigned swap band ;; space when this function exits. Some of the dirtied pages will ;; still be in core, and will not be allocated swap band space (in ;; the DPMT) until SWAP-OUT-ALL-PAGES is run. (Defun Make-All-Pages-Dirty (&optional (record-work-for-disk-save nil) &aux (%Inhibit-Read-Only t) (rem 0)) ;; Start with first non-permanently-wired page & go through all pages. (do* ((first-non-wired-page (ldb %%VA-Page-Number (AREF #'region-origin (symbol-value First-Non-Fixed-Wired-Area-Name)))) (last-virtual-page (ldb %%VA-Page-Number -1)) (pg first-non-wired-page (1+ pg)) ;; Address of start of page. Must remain a fixnum. (page-start-va (lsh pg (BYTE-SIZE %%VA-Offset-Into-Page)) (lsh pg (BYTE-SIZE %%VA-Offset-Into-Page))) (i 1) (DS-Display-Estimated-Time nil)) ((> pg last-virtual-page) (setq DS-Pages-Actually-Migrated i)) ;; If page is valid and on load band, dirty it. (when (va-valid-p page-start-va) (multiple-value-bind (nil nil status) (%disk-address page-start-va) (when (= status %DPMTE-READ-ONLY-BAND) (incf i) ;; Count page migrated. ;; To dirty page, read bit 0 of page's word 0 & write it back. (%p-dpb (%p-ldb (byte 1 0) page-start-va) (byte 1 0) page-start-va)))) (when (>= i 3000.) (setq DS-Display-Estimated-Time t)) (when record-work-for-disk-save ;; Record work & display status for disk-save every 1500 pages migrated. (when (zerop (setq rem (rem i 1500.))) (incf i) ;; don't let work get recorded twice. (record-disk-save-work 1500. :migrate-page) (display-disk-save-status)))) (when record-work-for-disk-save ;; Record last group of less than 1500. migrated pages processed. (record-disk-save-work rem :migrate-page)) ) ;;; Given a CLUSTER-VA, call SAVE-PAGE on each virtual page in the cluster, passing ;;; the source partition disk address. (Defun Save-Cluster (cluster-va new-dpmt save-part-base save-part-size save-unit) (do ((i 0 (1+ i)) (VA cluster-va (+ VA Page-Size))) ((= i 16.)) (multiple-value-bind (disk-address unit) (%disk-address VA) (if disk-address (save-page VA new-dpmt (= i 0) disk-address unit save-part-base save-part-size save-unit) ;; Special case: VA is valid, but block not assigned because hasn't been ;; swapped out. This could ONLY be because it is stuff we've cons'd since ;; taking our memory image. In this case, don't save the cluster. (progn ;; This cannot be a page > the first page in the cluster, because if the ;; first page is assigned a disk address, ALL pages in the cluster are. (when (> i 0) (ferror nil "*** FATAL ERROR IN DISK-SAVE: Cluster inconsistent. ~ ~% VA: #o+~o, Area: ~a" va (let ((a (%area-number (convert-to-signed va)))) (if a (area-name a))))) (when (eq DS-Display-Mode :debug) (format *Terminal-IO* "~% *** VA: ~o, valid but unassigned" VA)) (return nil)))) )) (Defun Save-First-Partial-Cluster (new-dpmt save-part-base save-unit) ;; Fixed areas do not start on cluster boundaries. If the first fixed (but not ;; wired) address starts in the middle of a cluster, that means the previously ;; saved wired pages ended in a partial cluster. We must start by saving off ;; the fixed pages that complete this cluster. (let ((wired-size (AREF #'system-communication-area %SYS-COM-WIRED-SIZE)) rem partial-cluster-size partial-cluster-number) ;; See if there is initial partial cluster to be saved. (multiple-value-setq (partial-cluster-number rem) (floor wired-size Cluster-Size-In-Words)) (when (not (zerop rem)) ;; Partial cluster size in pages. (setq partial-cluster-size (- Cluster-Size (truncate rem Page-Size))) ;; Save first partial cluster page by page. (do* ((i 1 (1+ i)) (va wired-size (+ va Page-Size)) (dest-disk-adr (+ save-part-base (* partial-cluster-number Cluster-Size-In-Blocks) (* (truncate rem Page-Size) disk-blocks-per-page)) (+ dest-disk-adr disk-blocks-per-page)) (valid (va-valid-p va) (va-valid-p va))) ((> i partial-cluster-size) ;; At end, update DPMT for partial cluster. ;; Assign all pages to load band (dev B) (set-dpmt-bitmap partial-cluster-number (- %DPMT-ASSIGNED-TO-LOAD-BAND) new-dpmt) ;; Record Dev B (Load Band) offset. This is offset in the NEW partition. (set-dpmt-device-B-offset partial-cluster-number partial-cluster-number new-dpmt)) ;; Only copy valid pages. (when valid (multiple-value-bind (address unit) (%disk-address va) (when (null address) (ferror nil "*** FATAL ERROR IN DISK-SAVE: Cluster inconsistent. ~ ~% VA: #o+~o, Area: ~a" va (let ((a (%area-number (convert-to-signed va)))) (if a (area-name a))))) (ds-disk-read DS-RQB-1 unit address 1 0) (ds-wait-io-complete DS-RQB-1) (ds-disk-write DS-RQB-1 save-unit dest-disk-adr 1 0) (ds-wait-io-complete DS-RQB-1))))) )) ;;; Save all allocated virtual memory between end of wired space and start of ;;; non-fixed areas (ie, the fixed but not wired space). (Defun Save-Fixed-Non-Wired-Space (new-dpmt save-part-base save-part-size save-unit &aux first-cluster-va) (DECLARE (INLINE convert-to-unsigned)) ;; If Fixed areas start in middle of cluster, save off first partial cluster specially. (save-first-partial-cluster new-dpmt save-part-base save-unit) (setq first-cluster-va (* Cluster-Size-In-Words (ceiling (AREF #'system-communication-area %Sys-Com-Wired-Size) Cluster-Size-In-Words))) ;; Now save off rest of Fixed-Non-Wired areas. (init-disk-vars save-part-base first-cluster-va) (do* ((end-address (* Cluster-Size-In-Words (ceiling (+ (convert-to-unsigned (AREF #'region-origin (symbol-value Last-Fixed-Area-Name))) (convert-to-unsigned (AREF #'region-length (symbol-value Last-Fixed-Area-Name)))) Cluster-Size-In-Words))) (cluster-va ;; Start with the first page in first complete 16-page group ;; containing non-wired pages, then increment by page size. first-cluster-va (+ cluster-va Cluster-Size-In-Words))) ;; Stop when we get to start of normal areas ((>= cluster-va end-address) ;; At end, make sure partially-filled RQB is written. (force-RQB-write save-unit)) ;; Scan cluster to see if it should be saved (if it contains valid Virtual Memory). (do* ((i 0 (1+ i)) (VA cluster-va (+ VA Page-Size)) (valid (va-valid-p VA) (va-valid-p VA))) ((= i 16.)) (when valid (save-cluster (logand VA (- Cluster-Size-In-Words)) new-dpmt save-part-base save-part-size save-unit) (return nil)))) ) (DEFUN SAVE-AREA (AREA-SYMBOL NEW-DPMT SAVE-PART-BASE SAVE-PART-SIZE SAVE-UNIT) (DECLARE (INLINE convert-to-unsigned)) (display-disk-save-activity (format nil "Saving ~a" area-symbol)) ;; Loop over all regions in area (do ((region (AREF #'area-region-list (symbol-value area-symbol)) (AREF #'region-list-thread region))) ((minusp region)) (UNLESS (= (LDB %%REGION-SPACE-TYPE (REGION-BITS REGION)) ;; DON'T SAVE TRAIN-A REGIONS, THEY ONLY ARE JUNK %REGION-SPACE-TRAIN-A) ;; WHICH HAS FAULTED IN SINCE THE SNAPSHOT. (when (eq DS-Display-Mode :debug) (format *Terminal-Io* " ~o" region)) ;; Save all clusters in the region (do ((cluster-va (convert-to-unsigned (AREF #'region-origin region)) (+ cluster-va Cluster-Size-in-Words)) (end (+ (convert-to-unsigned (AREF #'region-origin region)) (convert-to-unsigned (AREF #'region-free-pointer region))))) ;; Loop until we fail to save a cluster (which will mean ;; we've saved all valid address space in region) or end ;; of used portion of region reached. ((>= cluster-va end) ;; At end of region, make sure partially-filled RQB is written. (force-RQB-write save-unit)) ;; For regular areas, don't have to check all pages in cluster, since all ;; their regions start on cluster boundaries. (when (va-valid-p cluster-va) (save-cluster cluster-va new-dpmt save-part-base save-part-size save-unit) (when (eq DS-Display-Mode :debug) (format *Terminal-Io* "."))) )))) ;;; Save off all memory in "regular" areas (non-fixed). ;;; DEBUGGING NOTE: ;;; To print out name of area being saved, each region number, and a "." for each ;;; cluster in the region, set DS-Display-Mode to :debug. (Defun Save-Areas (new-dpmt save-part-base save-part-size save-unit) ;; Start with first non-fixed area, process all areas in sublist. (dolist (area-symbol (member First-Non-Fixed-Area-Name Area-List :test #'eq)) ;; Exclude disk-save-area and world-record-area if extended-address-space (unless (OR (eq area-symbol 'disk-save-area) (AND EXTENDED-ADDRESS-SPACE (EQ AREA-SYMBOL 'WORLD-RECORD-AREA))) ;; DON'T SAVE THE WORLD RECORD AREA YET IF EAS ON. (SAVE-AREA AREA-SYMBOL NEW-DPMT SAVE-PART-BASE SAVE-PART-SIZE SAVE-UNIT)))) ;;; Extended-address-space - swaps out world record area ;;; (DEFUN SWAP-OUT-WORLD-RECORD-AREA () (DO ((REGION (AREA-REGION-LIST WORLD-RECORD-AREA) (REGION-LIST-THREAD REGION))) ((MINUSP REGION)) (DO ((VA (REGION-ORIGIN REGION) (%MAKE-POINTER-OFFSET DTP-FIX VA PAGE-SIZE)) (MAX-VA (%MAKE-POINTER-OFFSET DTP-FIX (REGION-ORIGIN REGION) (REGION-FREE-POINTER REGION)))) ((>= VA MAX-VA)) (WHEN (%PAGE-FRAME-NUMBER VA) (%DELETE-PHT-ENTRY (%PAGE-FRAME-NUMBER VA)))))) ;;; Save off all external clusters to the new load band (DEFUN SAVE-EXTERNAL-CLUSTER (CLUSTER SAVE-PART-BASE SAVE-PART-SIZE SAVE-UNIT) (DO ((I 0 (1+ I)) (C0 (AREF CLUSTER 0)) (C1 (AREF CLUSTER 1))) ((= I 16.)) (LET* ((dev-B ;; T if load band (device B = 1) NIL if page band (device A = 0) (= %DPMT-ASSIGNED-TO-LOAD-BAND (ldb (byte 1 I) C0))) (logical-device (if dev-B (ldb %%DPMTE-DEVICE-B-LPDIB-INDEX C0) (ldb %%DPMTE-DEVICE-A-LPDIB-INDEX C0))) LPDIB-address unit-number partition-offset partition-start-block-number DISK-ADDRESS) (setq LPDIB-address (+ Address-of-Page-Device-Table (* %LOGICAL-PAGE-DEVICE-INFORMATION-BLOCK-LENGTH logical-device))) (setq unit-number (%p-ldb %%LPDIB-UNIT-NUMBER (+ LPDIB-address %LPDIB-FLAG-WORD))) (setq partition-offset (* Cluster-Size-in-Blocks (if dev-B (ldb %%DPMTE-DEVICE-B-OFFSET C1) (ldb %%DPMTE-DEVICE-A-OFFSET C1)))) (setq partition-start-block-number ;Will always fit in fixnum (%P-LDB %%Q-Pointer (+ LPDIB-address %LPDIB-STARTING-BLOCK))) (setq disk-address (+ partition-start-block-number partition-offset (* I disk-blocks-per-page))) (save-page 0. 0. (= i 0) disk-address unit-number save-part-base save-part-size save-unit CLUSTER)))) ;;; Save off all external regions to the new load band updating the pseudo ;;; dpmt entries in the world-record-area. (DEFUN SAVE-EXTERNAL-REGIONS (SAVE-PART-BASE SAVE-PART-SIZE SAVE-UNIT) (LET ((I 1) (TEMP-DPMT NIL) (PSEUDO-DPMT-LIST NIL)) (DOLIST (WORLD EXTENDED-ADDRESS-SPACE (DS-WAIT-IO-COMPLETE DS-RQB)) (display-disk-save-activity (format nil "Saving external world ~d." i)) (incf i) (DOLIST (EXTERNAL-REGION (AREF WORLD %EXTERNAL-REGIONS)) (DOLIST (CLUSTER (NTH %EXTERNAL-PAGE-CLUSTERS EXTERNAL-REGION) (FORCE-RQB-WRITE SAVE-UNIT)) ;; FORCE WRITE OF PARTIAL RQB AT ENT OF REGION. (SETF TEMP-DPMT (MAKE-ARRAY 2. :ELEMENT-TYPE '(UNSIGNED-BYTE 32.) :AREA DISK-SAVE-AREA)) (SETF (AREF TEMP-DPMT 0) (AREF CLUSTER 0)) (SETF (AREF TEMP-DPMT 1) (AREF CLUSTER 1)) (PUSH TEMP-DPMT PSEUDO-DPMT-LIST) (SAVE-EXTERNAL-CLUSTER CLUSTER SAVE-PART-BASE SAVE-PART-SIZE SAVE-UNIT)))) PSEUDO-DPMT-LIST)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Main Disk Save routine ;; *tgc* ;;ab 1/18/88. Change for MX. (Defun Internal-Disk-Save (save-unit save-part-name-hi-16-bits save-part-name-lo-16-bits save-part-base save-part-size saving-over-self save-part-name) ;ab 8/29/88 (declare (ignore save-part-name)) ;RJF 1/20/89 ;; Before we do anything else, turn off bignum GC by setting number consing area ;; to Working-Storage-Area. All our bignum consing will be garbage anyway. ;; Also disable scheduling (just in case), and scavenging. (setq Inhibit-Scheduling-Flag t Inhibit-Scavenging-Flag t) (setq Number-Cons-Area Working-Storage-Area Default-Cons-Area Working-Storage-Area Background-Cons-Area Working-Storage-Area) ;; Set %disk-switches to turn on clean-page switch. Normally, the paging Ucode ;; will evict the least recently used page when swapping in a new page, even if ;; it is a dirty page. The clean-page switch makes the Ucode look for a clean ;; page to evict. We must do this so that we don't try to swap a page out until ;; all memory is dirty, since we're going to turn off swapouts completely soon. (set-disk-switches :clean-page-search 1) (if saving-over-self (setq DS-Saving-Over-Self t) (setq DS-Saving-Over-Self nil)) ;; Disk-Save can write only to *Terminal-IO*, which has been set ;; to Cold-Load-Stream by Disk-Save-Caller. (initialize-disk-save-display) ;; Make our special RQBs, wire them, and otherwise initialize them. (make-disk-save-rqbs) ;; If we are saving on top of the currently running band, we must first ;; migrate all load band pages over to the swap bands. Then, when we ;; reference a page, it will always be read in from the swap band rather ;; than attempting to read it from the load band being saved over. ;; We accomplish the migration by making all allocated pages of virtual ;; memory dirty. Then, after all pages have been swapped out, they ;; will all exist on the swap bands. (when DS-Saving-Over-Self (display-disk-save-activity "Preparing to save over current band") (make-all-pages-dirty t)) (display-disk-save-activity "Clearing physical memory") (setq DS-Second-Dirty-Core-Page-Estimate (estimate-modified-core-pages)) ;;;;;;;;;;;;;;;;;;; Start Cons-Critical Code ;;;;;;;;;;;;;;;;;; ;; ;; Now we want to take a "snapshot" of current virtual memory. It is this ;; snapshot state that will constitute the new load band. Anything altered ;; after the snapshot is taken is alive only for the duration of disk-save, ;; and will not be in the new band. Most of the snapshot already exists ;; in the pages assigned to the load and swap bands. We complete this by ;; assuring all dirty pages currently in core memory are written to disk, ;; and by saving the permanently-wired pages of memory. ;; ;; Note: there is a potential problem with the region and area-info areas. ;; Since their snapshots are taken at slightly different times (some by ;; SWAP-OUT-ALL-PAGES and some by SAVE-WIRED-PAGES), we must make sure they ;; are consistent by making sure consing done between the functions ;; calls doesn't affect the region-tables. Do this by consing then "unconsing" ;; a couple of pages. If this causes a region-cons, it will happen now, instead ;; of in the middle of saving the memory image. ;; ;; First we assure that region free pointers are just one beyond the next page boundary. ;; (DOTIMES (CTR (IF (OR EXTENDED-ADDRESS-SPACE (and (fboundp 'training-active) (training-active))) 2. 1.)) ;; FORCE ALL OBJECT FAULTING ON FIRST PASS, GET GOOD RESULTS SECOND PASS (WHEN EXTENDED-ADDRESS-SPACE (SETF %TGC-TRAINING-ENABLED NIL) ;; LOCK CREATION OF NEW TRAINSPACE REGIONS IN THE FOLLOWING COLLECTION. (GC-IMMEDIATELY :MAX-GEN 1 :PROMOTE NIL :SILENT T) ;; FORCE DEPORT OF ALL EXTERNAL REGIONS (SETF %TGC-TRAINING-ENABLED T)) ;; TURN TRAINING BACK ON. ;; Make sure we do not scavenge the pdls of the disk-save stack group. (setf (sg-regular-pdl-pointer current-stack-group) 0) (setf (sg-special-pdl-pointer current-stack-group) 0) (loop for reg = (%region-number (make-array 0)) for fp = (aref #'region-free-pointer reg) until (= 1 (rem fp page-size)) do nil) (loop for reg = (%region-number (make-list 1)) for fp = (aref #'region-free-pointer reg) until (= 1 (rem fp page-size)) do nil) ;; ;; Here we reserve a couple of "consing pages" by making and returning an array & list. ;; Trick here is to remember where they are. At very end of capturing memory-image, ;; when ALL intermediate consing is finished, swap them out again. This will ;; guarantee consistent disk image. ;; ;; Create an array then return it right away. This may cause a region-cons, ;; and will cause part of the "current region" to be initialized virtual ;; memory. Have each element of the 32b array look like a 0-length array. ;; Then, if our region free pointer in the saved band is a bit beyond the ;; last thing we "really" cons, we'll still be ok if we ever scavenge this ;; region. *whew* (let ((ary (make-array (- page-size 2) :type art-32b :initial-element DS-Fudge-Array-Initial-Value)) (lst (make-list (- page-size 2)))) (return-storage lst t) (return-storage ary t) (setq DS-Fudge-Array-Address (%pointer ary) DS-Fudge-List-Address (%pointer lst) ary nil lst nil) ;; Swap out all pages currently in memory to the page bands on disk. Does not swap ;; out permanently wired paged. Permanently wired pages will be saved explicitly ;; from memory. (swap-out-all-pages nil t) ;;ab 1/21/88. Reserve physical-memory for RQB data buffers & set up RQBs to point to this memory. (MULTIPLE-VALUE-BIND (slot offset) (get-contiguous-physical-pages (* 2 DS-RQB-Size) nil) (ds-init-rqb-addrs DS-RQB-1 slot offset DS-RQB-Size) (ds-init-rqb-addrs DS-RQB-2 slot (+ offset (* DS-RQB-Size page-size-in-bytes)) DS-RQB-Size)) (display-disk-save-activity "Saving wired pages") ;; Now make sure our "consing pages" have up-to-date disk image. ;; If the consing pages are in core, swap them out. ;; Note the next few lines themselves are guaranteed to cause a bit of consing ;; (from the call to %physical-address which returns a bignum). (when (%page-status DS-Fudge-Array-Address) (%delete-physical-page (convert-physical-address-to-pfn (%physical-address DS-Fudge-Array-Address)))) (when (%page-status DS-Fudge-List-Address) (%delete-physical-page (convert-physical-address-to-pfn (%physical-address DS-Fudge-List-Address)))) ;; Now make sure pages in INDIRECTION-CELL-AREA have up-to-date disk image. ;; Really we'll only dump out the last 2 pages of each region. This should be enough. (LOOP FOR region = (AREF #'area-region-list Indirection-Cell-Area) THEN (AREF #'region-list-thread region) UNTIL (MINUSP region) WITH origin WITH fp DO (SETQ origin (AREF #'region-origin region) fp (AREF #'region-free-pointer region)) (LOOP FOR ptr = (%pointer-plus origin fp) THEN (%pointer-difference ptr Page-Size) FOR ct = 0 THEN (1+ ct) UNTIL (OR (%pointer< ptr origin) (>= ct 2)) DO (WHEN (%page-status ptr) (%delete-physical-page (convert-physical-address-to-pfn (%physical-address ptr)))))) ;; Ensure that RQBs are swapped in and then wire 'em (indirecty cache inhibiting them) ;; Required for Explorer II (SETF (AREF ds-rqb-1 %io-rq-status-high) 0) (WIRE-ARRAY ds-rqb-1) (SETF (AREF ds-rqb-2 %io-rq-status-high) 0) (WIRE-ARRAY ds-rqb-2) ;; Now we have clean memory. ;; Write out the permanently wired pages. The DPMT will be written again ;; later, but we want to save the region-info areas now before they change due ;; to our consing and new area creation. (save-wired-pages save-part-base save-unit)) (SETQ ds-after-cons-critical-list-address (%pointer (CONS 0 1))) (SETQ ds-after-cons-critical-structure-address (%pointer (MAKE-ARRAY 1))) (WHEN (%page-status (VALUE-CELL-LOCATION 'ds-after-cons-critical-list-address)) (%delete-physical-page (convert-physical-address-to-pfn (%physical-address (VALUE-CELL-LOCATION 'ds-after-cons-critical-list-address))))) (WHEN (%page-status (VALUE-CELL-LOCATION 'ds-after-cons-critical-structure-address)) (%delete-physical-page (convert-physical-address-to-pfn (%physical-address (VALUE-CELL-LOCATION 'ds-after-cons-critical-structure-address)))))) ;; ;;;;;;;;;;;;;;;;;;;;; End Cons-Critical Code ;;;;;;;;;;;;;;;;;;;;; (WHEN EXTENDED-ADDRESS-SPACE ;; SHOULD NOT HAVE ANY TRAIN-A REGIONS HERE. CHECK TO MAKE SURE. ;; NOTE: UGLY USE OF HARD CODED CONSTANTS BELOW IS INTENTIONAL SO THAT WE DON'T CAUSE ;; THE FAULTIN OF A POSSIBLY EXTERNAL SYMBOL. (DOTIMES (I 2048.) (WHEN (= (LDB #O1104 (REGION-BITS I)) #O17) ;; OOPS, SOMETHING IS WRONG, WE HAVE A TRAIN-A REGION. (ferror nil "*** FATAL ERROR IN DISK-SAVE: Region ~d. is a train-a region." I)))) ;; Virtual memory image is now captured on disk. Must not swap OUT after this, so ;; must do something here to catch any attempt to swap OUT: mark all paging devices ;; as read-only in their LPDIBs. This will cause an Out-of-Swap-Space ;; crash if we try to swap a page out after this. (Note that we can, of ;; course, swap in pages!) (UNLESS EXTENDED-ADDRESS-SPACE ;; CAN'T DO THIS TRICK IF EXTENDED ADDRESS SPACE SINCE GOING TO NEED (make-all-page-devices-read-only)) ;; TO FORCE THE WRITE OF THE WORLD-RECORD-AREA LATER. ;; Create disk-save-area to do all our consing in. (if (not (boundp 'Disk-Save-Area)) (make-area :name 'Disk-Save-Area :region-size (* 2 %ADDRESS-SPACE-QUANTUM-SIZE))) ;; From now on do all consing (including further garbage bignum consing) ;; in disk-save-area. Since memory image is already on disk, our garbage ;; consing won't get saved with the new band. (setq Default-Cons-Area Disk-Save-Area) (setq Background-Cons-Area Disk-Save-Area) (setq Number-Cons-Area Disk-Save-Area) ;; Now start processing to write the snapshot of memory to the save partition. ;; We can cons now, since the area info tables have already been saved. (let ((new-dpmt ;; This will be the DPMT for the new band (make-array (calculate-dpmt-array-size) :element-type '(unsigned-byte 16.) :area Disk-Save-Area))) ;; Set up DPMT for the new band. (display-disk-save-activity "Initializing data structures") (initialize-dpmt new-dpmt (truncate (calculate-dpmt-array-size) 4.)) ;; Record fact we've done some work (record-disk-save-work (truncate DS-Fudge-Factor 4.) :copy-page) ;; First save off areas between end of wired space and first non-fixed area. ;; Function to perform this returns next available disk address. (display-disk-save-activity "Saving fixed areas") (save-fixed-non-wired-space new-dpmt save-part-base save-part-size save-unit) ;; Next save off all pages in normal areas. These all start on cluster boundary. ;; This will be done in a faster way than the above function. (display-disk-save-activity "Saving normal areas") (save-areas new-dpmt save-part-base save-part-size save-unit) (ds-wait-io-complete DS-RQB) (WHEN EXTENDED-ADDRESS-SPACE (LET ((PSEUDO-DPMT-LIST NIL) (TEMP-DPMT NIL)) ;; DUMMY CALLS TO MAKE SURE ALL NECESSARY FAULTINS OCCUR BEFORE PSEUDO DPMT UPDATE (SETF PSEUDO-DPMT-LIST (NREVERSE PSEUDO-DPMT-LIST)) (SWAP-OUT-WORLD-RECORD-AREA) ;;MOVE EXTERNAL REGIONS TO NEW LOAD BAND (SETF PSEUDO-DPMT-LIST (SAVE-EXTERNAL-REGIONS SAVE-PART-BASE SAVE-PART-SIZE SAVE-UNIT)) (DOLIST (WORLD EXTENDED-ADDRESS-SPACE) (ARRAY-INITIALIZE (AREF WORLD %EXTERNAL-INTERNAL-TRANSLATE-TABLE) NIL) ;; FOLLOWING CODE IS AN ATTEMPT TO PROTECT AGAINST THE POSSIBLE, BUT VERY, VERY ;; UNLIKLY CASE OF CREATION OF A NEW ENTRY/EXIT REGION SINCE THE SNAPSHOT WAS TAKEN. ;; IF THIS HAS HAPPENED WE JUST WANT TO BACK THE WORLD RECORD UP TO THE PREVIOUS ;; FIRST ENTRY/EXIT REGION SINCE THIS IS THE LATEST ONE WHICH HAS BEEN SAVED. (UNLESS (%DISK-ADDRESS (REGION-ORIGIN (AREF WORLD %EXIT-REGIONS))) (SETF (AREF WORLD %EXIT-REGIONS) (AREF REGION-WORLD-LIST-THREAD (AREF WORLD %EXIT-REGIONS)))) (UNLESS (%DISK-ADDRESS (REGION-ORIGIN (AREF WORLD %ENTRY-REGIONS))) (SETF (AREF WORLD %ENTRY-REGIONS) (AREF REGION-WORLD-LIST-THREAD (AREF WORLD %ENTRY-REGIONS))))) ;; FORCE WORLD-RECORD AREA OUT TO DISK WITH UPDATED VALUES (SWAP-OUT-WORLD-RECORD-AREA) ;; (SWAP-OUT-ALL-PAGES) ;; RESTORE TO PSEUDO-DPMT VALUES TO THEIR PREVIOUS VALUES SO THAT FAULTIN CAN WORK RIGHT IN REST OF DISK-SAVE. (SETF PSEUDO-DPMT-LIST (NREVERSE PSEUDO-DPMT-LIST)) (DOLIST (WORLD EXTENDED-ADDRESS-SPACE) (DOLIST (EXTERNAL-REGION (AREF WORLD %EXTERNAL-REGIONS)) (DOLIST (CLUSTER (NTH %EXTERNAL-PAGE-CLUSTERS EXTERNAL-REGION)) (SETF TEMP-DPMT (POP PSEUDO-DPMT-LIST)) (SETF (AREF CLUSTER 0) (AREF TEMP-DPMT 0)) (SETF (AREF CLUSTER 1) (AREF TEMP-DPMT 1))))) (SAVE-AREA 'WORLD-RECORD-AREA NEW-DPMT SAVE-PART-BASE SAVE-PART-SIZE SAVE-UNIT) ;; DUMP THE WORLD RECORD AREA (DS-WAIT-IO-COMPLETE DS-RQB))) ;; Write the new DPMT to saved partition, and a couple of other areas that ;; need updating. Then disk restore to the fresh band. (UNLESS (addin-p) (display-disk-save-activity "About to disk-restore...")) ;***TEMP, until DISK-RESTORE fixed (display-disk-save-status t) (update-sca save-part-base save-unit) (save-new-dpmt save-part-base save-unit new-dpmt) (WHEN (addin-p) (COMMENT ;take this out for now--it is unreliable. ab 9/8/88 (WHEN (AND (NOT (resource-present-p :disk)) (FBOUNDP 'resize-load-band)) (resize-load-band save-part-name (get-logical-unit save-unit)))) ;ab 8/29/88 (display-disk-save-activity "DISK-SAVE finished. Please re-boot.")) ;***TEMP, for addin (IF (addin-p) ;;***TEMP, until DISK-RESTORE fixed (PROGN (SEND *terminal-io* :set-cursorpos 0 (- (SEND *terminal-io* :height) (* 2 (SEND *terminal-io* :line-height)))) (%crash 0. 'DISK-SAVE t)) ;ab 3/18/88 (%disk-restore save-part-name-hi-16-bits save-part-name-lo-16-bits save-unit)) ))