LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031658. :SYSTEM-TYPE :LOGICAL :VERSION 12. :TYPE "LISP" :NAME "DISK-SAVE-INTERNAL" :DIRECTORY ("REL3-SOURCE" "MEMORY-MANAGEMENT") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758727762. :AUTHOR "REL3" :LENGTH-IN-BYTES 59174. :LENGTH-IN-BLOCKS 58. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                       ;;; -*- 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 (b)(3)(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,1987 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.;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 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-End-Region-FP nil);;; 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 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 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* :line-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)(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)(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))  ) (Defun DS-Init-RQB (rqb first-pfn 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.  (setq nubus-address (convert-pfn-to-physical-address first-pfn))  (setf (array-leader rqb %DS-RQB-Data-Buffer-Phys-Adr-Slot-Offset)(ldb %%NuBus-All-But-F-And-Slot-Bits nubus-address))  (setf (array-leader rqb %DS-RQB-Data-Buffer-Phys-Adr-Slot-Bits)(ldb %%NuBus-F-And-Slot-Bits nubus-address))  ;; Leader element 3 contains displaced physical array pointing to data buffer in physical memory  (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-SizeDOING (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!(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 (get-logical-unit unit) 7.); device descriptor #-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.(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))))    ;; Note: Timeout count is about 18-20 seconds as currently written.    ;; If processing speeds change, this will have to be re-done.    (when (> timeout-count 500000.)      (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 0DS-RQB-Page-Offset 0        DS-Last-Unit -1DS-Last-Disk-Address -1DS-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)  ;; 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    (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-offsetcluster-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.(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 (get-logical-unit save-unit) 7.); device descriptor #-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)    ;; ********** This is temporary code to support the old 1k page size bands ******* *1*    ;; 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       (abs (convert-to-signed      (* (- 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)    ;; *********** End of temporary block of code.  *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       (abs (convert-to-signed      (* (- 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.  Furthermore, we leave NUMBER-TO-LEAVE-DELETED;;; consecutive pages (the highest in physical memory) out of the pool to use as;;; RQB data buffers.(Defun Swap-Out-All-Pages (&optional (number-to-leave-deleted 0)   (display-for-disk-save nil))  (let* ((phys-pgs (pages-of-physical-memory)) (ppd-slot (get-ppd-slot-addr)) (ppd-offset (get-ppd-slot-offset)) (last-pg-nbr-to-recreate (- phys-pgs number-to-leave-deleted 1)) (all-pages 1) (rem 0) (DS-Display-Estimated-Time nil))    (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))(when (%delete-physical-page page-frame-number)  ;; %delete-physical-page returns t if page actually deleted from PPD (and  ;; swapped out if necessary).  (if (<= page-frame-number last-pg-nbr-to-recreate)      ;; Add back into PPD      (%create-physical-page page-frame-number)));; 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))))  );;; 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)  (DECLARE (INLINE convert-to-unsigned))  ;; 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    (unless (eq area-symbol 'disk-save-area)      (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))(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* ".")))  )))    ));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Main Disk Save routine;; *tgc*(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)    ;; 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-AreaDefault-Cons-Area Working-Storage-AreaBackground-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.  ;;  ;; Here we reserve a couple of "consing pages" by making and returning an array.  ;; 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.  (let* ((fudge-array-size 500.) ;; 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* (ary (make-array fudge-array-size  :type art-32b  :initial-element (DPB dtp-array-header%%q-data-type(%p-ldb %%q-pointer (MAKE-ARRAY 0))))) (va1 (prog1 (%pointer ary) (return-storage ary t)))                ;; Hdr word (va2 (%make-pointer-offset DTP-Fix va1 Page-Size))                 ;; Hdr word + 1 pg (va3 (%make-pointer-offset DTP-Fix va1 fudge-array-size)))         ;; Adr of last Q                                                                    ;; (could be on same pg as va2)    (setq ary nil DS-Fudge-Array-Address va1)      ;; 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.  The argument to SWAP-OUT-ALL-PAGES is how many physical memory    ;; pages to free up for use as disk-io data buffers.    (swap-out-all-pages (* 2 DS-RQB-Size) t)    (display-disk-save-activity "Saving wired pages")    (SETQ DS-End-Region-FP (AREF #'region-free-pointer (%region-number va1)))      ;; 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 va1)      (%delete-physical-page (convert-physical-address-to-pfn       (%physical-address va1))))    (when (%page-status va2)      (%delete-physical-page (convert-physical-address-to-pfn       (%physical-address va2))))    (when (%page-status va3)      (%delete-physical-page (convert-physical-address-to-pfn       (%physical-address va3))))    ;; 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))))))        ;; 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))  ;;  ;;;;;;;;;;;;;;;;;;;;; End Cons-Critical Code ;;;;;;;;;;;;;;;;;;;;;  ;; Virtual memory image is now captured on disk.  Must not swap in after this, so   ;; must do something here to catch any attempt to swap in: 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!)  (make-all-page-devices-read-only)  ;; 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)        ;; Write the new DPMT to saved partition, and a couple of other areas that    ;; need updating.  Then disk restore to the fresh band.    (display-disk-save-activity "About to disk-restore...")    (display-disk-save-status t)     (update-sca save-part-base save-unit)    (save-new-dpmt save-part-base save-unit new-dpmt)    (%disk-restore save-part-name-hi-16-bits save-part-name-lo-16-bits save-unit)   )) (WRITE-FILE-P T))    (DECLARE (SPECIAL NAME MAJOR-VERSION MINOR-VERSION SUBMINOR-VERSION      AUTHOR STATUS SYSTEM-PRODUCT-P PATHNAME      WRITE-FILE-P))    (COND ((EQ SYSTEMS-TO-INCLUDE :NO-WINDOW-SYSTEM)  