(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)

(filecreated " 4-Jun-87 18:33:02" {eris}<daniels>lisp>lfhacks.\;14
 29149  

      |changes| |to:|  (functions determine-system-volume chase-boot-links get-boot-pointer pda-to-vp 
                              vol-num-containing-page vol-index-containing-page 
                              determine-boot-file-runs-using-pointers print-runs-attractively 
                              read-bad-page-table make-page-bad unmake-page-bad determine-file-runs 
                              vp-to-da da-to-vp show-vmem-run-table default-bft fetch-long-cardinal 
                              bootfile-fd write-pv-root-page max-bad-pages write-bad-page-table 
                              bad-page-count list-from-bpt bpt-ref list-bad-pages)
                       (vars lfhackscoms)
                       (variables bpt bft-pilot-boot-file bft-germ bft-emulator-microcode 
                              bft-diagnostic-microcode +boot-file-types+)
                       (setfs bad-page-count bpt-ref)
                       (commands "EC")
                       (structures file-run)
                       (records |PilotDiskAddress| bad-page-table bpt-entry)

      |previous| |date:| " 3-Jun-87 18:31:15" {eris}<daniels>lisp>lfhacks.\;11)


; Copyright (c) 1987 by Xerox Corporation.  All rights reserved.

(prettycomprint lfhackscoms)

(rpaqq lfhackscoms
 ((coms (functions read-label)
                          (variables bpt-label pv-root-page-label))
                    (coms (variables +boot-file-types+ bft-diagnostic-microcode 
                                 bft-emulator-microcode bft-germ bft-pilot-boot-file)
                          (declare\: eval@compile eval@load dontcopy (records |PilotDiskAddress|))
                          (functions vol-num-containing-page get-boot-pointer write-pv-root-page 
                                 bootfile-fd default-bft determine-system-volume fetch-long-cardinal 
                                 filedesc-from-name first-volume-page vp-to-da da-to-vp pda-to-vp))
                    (coms (declare\: eval@compile eval@load dontcopy (records bad-page-table 
                                                                            bpt-entry))
                          (functions read-bad-page-table)
                          (variables bpt)
                          (functions bad-page-count bpt-ref list-bad-pages list-from-bpt 
                                 make-page-bad max-bad-pages unmake-page-bad write-bad-page-table)
                          (setfs bad-page-count bpt-ref))
                    (coms (structures file-run)
                          (functions determine-file-runs show-vmem-run-table check-pages-free 
                                 print-runs-attractively)
                          (functions chase-boot-links determine-boot-file-runs-using-pointers))
                    (commands "EC")
                    (variables dsktw)
                    (advice |\\DoveDisk.HandleMajorError| |\\DoveDisk.TryRecalibrate|
                           (\\dove.xferdisk :in \\dldisk.execute))
                    (prop filetype lfhacks)))

(cl:defun read-label
 (pv-page) (let ((label (create
 |Label|)))
                                    (|\\PFTransferPage| pv-page (ncreate 'vmempagep)
                                           'vrr label 1)
                                    label))


(cl:defparameter bpt-label
 (read-label 1) )


(cl:defparameter pv-root-page-label
 (read-label 0) )


(cl:defconstant +boot-file-types+
 '((bft-diagnostic-microcode 0)
                                    (bft-emulator-microcode 1)
                                    (bft-germ 2)
                                    (bft-pilot-boot-file 3)) )


(cl:defconstant bft-diagnostic-microcode
 0)


(cl:defconstant bft-emulator-microcode
 1)


(cl:defconstant bft-germ
 2)


(cl:defconstant bft-pilot-boot-file
 3)

(declare\: eval@compile eval@load dontcopy 
(declare\: eval@compile

(blockrecord |PilotDiskAddress|
 ((head byte)
                                 (sector byte)
                                 (cylinder word)))
)
)

(cl:defun vol-num-containing-page
 (physical-page-number)
   (for
 vol-num from
 0 to
 (sub1 (|fetch|
 (|PhysicalVolumeDescriptor| |subVolumeCount|) |of|
 
                                                                                   |\\PhysVolumePage|
                                       ))
      do
 (let ((sv-desc (mesaelt (fetch
 (|PhysicalVolumeDescriptor| |subVolumes|) of
 
                                                                                   |\\PhysVolumePage|
                                        )
                               |SubVolumeArray| vol-num)))
              (cl:when (and (igeq physical-page-number (fetch
 (|SubVolumeDesc| |pvPage|) of
 sv-desc))
                            (ilessp physical-page-number (iplus (fetch
 (|SubVolumeDesc| |pvPage|)
                                                                   of
 sv-desc)
                                                                (fetch
 (|SubVolumeDesc| |nPages|)
                                                                   of
 sv-desc))))
                     (return vol-num)))))


(cl:defun get-boot-pointer
 (vol-num bft) (cl:if vol-num (mesaelt (fetch
 (|LogicalVolumeDescriptor|
                                                                         |bootingInfo|)
                                                                    of
 (elt |\\DFSLogicalVolumes| 
                                                                            vol-num))
                                                               |LVBootFiles| bft)
                                                (mesaelt (fetch
 (|PhysicalVolumeDescriptor| 
                                                                       |bootingInfo|) of
 
                                                                                   |\\PhysVolumePage|
                                                                )
                                                       |PVBootFiles| bft)))


(cl:defun write-pv-root-page
 nil (|\\PFTransferPage| 0 |\\PhysVolumePage| 'vvw pv-root-page-label 1))


(cl:defun bootfile-fd
 (&optional volume-num (bft (default-bft)))
   (or volume-num 
          
          (* |;;| "VOLUME-NUM = NIL means use the running sysout.")


       (cl:setf volume-num (determine-system-volume)))
   (create
 |FileDescriptor|
          |fileID| _ (fetch-long-cardinal (fetch
 (|DiskFileID| \fid)
                                             of
 (mesaelt (fetch
 (|LogicalVolumeDescriptor| 
                                                                       |bootingInfo|)
                                                            of
 (elt |\\DFSLogicalVolumes| volume-num)
                                                                )
                                                       |LVBootFiles| bft)))
          |volNum| _ volume-num
          |type| _ |tDiagnosticMicrocode|))


(cl:defun default-bft
 nil (case (machinetype)
                                (dove bft-germ)
                                (cl:otherwise bft-diagnostic-microcode)))


(cl:defun determine-system-volume
 nil (let* ((first-run (locf (fetch
 dlvmemfileinfo of
 \\iocbpage)))
                                             (boot-file-page (da-to-vp (fetch
 dlvmcyl of
 first-run)
                                                                    (fetch
 dlvmhead of
 first-run)
                                                                    (fetch
 dlvmsector of
 first-run)))
                                             )
                                            (vol-num-containing-page boot-file-page)))


(cl:defun fetch-long-cardinal
 (ptr) (\\makenumber (\\getbase ptr 1)
                                           (\\getbase ptr 0)))


(cl:defun filedesc-from-name
 (name) (let ((filespec (|\\LFFileSpec| name 'old))
                                          |volNum|)
                                         (create
 |FileDescriptor|
                                                |fileID| _ (|\\LFReadFileID|
                                                            (|\\LFGetDirectory|
                                                             (setq |volNum|
                                                              (|fetch|
 (|ExpandedName| volnum)
                                                                 |of|
 (|fetch|
 (|DFSFileSpec| 
                                                                                      expandedname)
                                                                         |of|
 filespec))))
                                                            (|fetch|
 (|DFSFileSpec| fsdirptr)
                                                               |of|
 filespec))
                                                |volNum| _ |volNum|
                                                |type| _ |tLispFile|)))


(cl:defun first-volume-page
 (vol-index) (fetch
 (|SubVolumeDesc| |pvPage|)
                                           of
 (mesaelt (fetch
 (|PhysicalVolumeDescriptor| 
                                                                     |subVolumes|) of
 
                                                                                   |\\PhysVolumePage|
                                                              )
                                                     |SubVolumeArray| vol-index)))


(defmacro vp-to-da
 (vp) `(cl:locally (declare
 (globalvars \\dldiskshape.sectorspercylinder 
                                                     \\dldiskshape.sectorsperhead))
                                (cl:multiple-value-bind (cylinder rem)
                                       (cl:floor ,vp \\dldiskshape.sectorspercylinder)
                                       (cl:multiple-value-call 'list cylinder (cl:floor rem 
                                                                         \\dldiskshape.sectorsperhead
                                                                                     )))))


(defmacro da-to-vp
 (cyl hd sec) `(cl:locally (declare
 (globalvars \\dldiskshape.sectorspercylinder 
                                                             \\dldiskshape.sectorsperhead))
                                        (iplus (itimes ,cyl \\dldiskshape.sectorspercylinder)
                                               (itimes ,hd \\dldiskshape.sectorsperhead)
                                               ,sec)))


(defmacro pda-to-vp
 (pda) `(let ((pda ,pda))
                                (da-to-vp (fetch
 (|PilotDiskAddress| cylinder) of
 pda)
                                       (fetch
 (|PilotDiskAddress| head) of
 pda)
                                       (fetch
 (|PilotDiskAddress| sector) of
 pda))))

(declare\: eval@compile eval@load dontcopy 
(declare\: eval@compile

(mesaarray bad-page-table
 ((0 127))
                          bpt-entry)

(mesarecord bpt-entry
 ((page swappedfixp)))
)
)

(cl:defun read-bad-page-table
 (&optional (table bpt)) (|\\PFTransferPage| 1 table 'vvr bpt-label 1))


(cl:defparameter bpt
 (let ((table (ncreate 'vmempagep)))
                          (read-bad-page-table table)
                          table) )


(definline bad-page-count
 nil (fetch
 (|PhysicalVolumeDescriptor| |badPageCount|) of
 
                                                                                   |\\PhysVolumePage|
                                     ))


(defmacro bpt-ref
 (index) `(fetch
 (bpt-entry page) of
 (mesaelt bpt bad-page-table ,index)))


(cl:defun list-bad-pages
 (&optional read?) (and read? (read-bad-page-table))
                                           (cl:dotimes (i (bad-page-count)
                                                          (terpri))
                                                  (cl:format t "~D " (bpt-ref i))))


(cl:defun list-from-bpt
 nil (for
 i from
 0 to
 (cl:1- (bad-page-count)) collect
 (bpt-ref i)))


(cl:defun make-page-bad
 (physical-page-number &optional read?)
   (and read? (read-bad-page-table))
   (let ((bp-list (list-from-bpt)))
        (cond
           ((igeq (cl:list-length bp-list)
                  (max-bad-pages))
            (cl:error "Too many bad pages"))
           ((member physical-page-number bp-list)
            (cl:format *error-output* "~D already marked bad~%" physical-page-number))
           (t (let ((new-bp-list (cl:merge 'list (list physical-page-number)
                                        bp-list
                                        'ilessp)))
                   (for
 page in
 new-bp-list as
 index from
 0 do
 (cl:setf (bpt-ref index)
                                                                      page)
                      finally
 (cl:setf (bad-page-count)
                                     (cl:list-length new-bp-list))
                            (uninterruptably
                                (write-bad-page-table)
                                (write-pv-root-page))))))))


(defmacro max-bad-pages
 nil (fetch
 (|PhysicalVolumeDescriptor| |maxBadPages|) of
 |\\PhysVolumePage|))


(cl:defun unmake-page-bad
 (physical-page-number &optional read?)
   (and read? (read-bad-page-table))
   (let ((bp-list (list-from-bpt)))
        (cond
           ((member physical-page-number bp-list)
            (cl:setf bp-list (remove physical-page-number bp-list))
            (for
 page in
 bp-list as
 index from
 0 do
 (cl:setf (bpt-ref index)
                                                           page) finally
 (cl:setf (bad-page-count)
                                                                                (cl:list-length
                                                                                 bp-list))
                                                                       (uninterruptably
                                                                           (write-bad-page-table)
                                                                           (write-pv-root-page))))
           (t (cl:format *error-output* "~D not in bad page table~%" physical-page-number)))))


(cl:defun write-bad-page-table
 nil (|\\PFTransferPage| 1 bpt 'vvw bpt-label 1))


(cl:defsetf bad-page-count
 nil (new-count)
                               `(cl:if (> ,new-count (max-bad-pages))
                                       (cl:error "Too many bad pages")
                                       (replace
 (|PhysicalVolumeDescriptor| |badPageCount|)
                                          of
 |\\PhysVolumePage| with
 ,new-count)))


(cl:defsetf bpt-ref
 (index) (new-val)
                            `(replace
 (bpt-entry page)
                                of
 (\\addbase bpt (iplus ((openlambda (|index|)
                                                                 (or (and (ileq 0 |index|)
                                                                          (ileq |index| 127))
                                                                     (error '|indexOutOfRange|))
                                                                 (itimes 2 (idifference |index| 0)))
                                                          ,index))) with
 ,new-val))


(cl:defstruct (file-run
 (:type list)
                        (:conc-name "FR-")) file-page vol-page length)


(cl:defun determine-file-runs
 (file-desc)
   (let ((file-length (|\\PFFindFileSize| file-desc))
         (page-runs nil)
         (file-page 0))
        (cl:loop (cl:push (make-file-run :file-page file-page :vol-page (|\\PFFindPageAddr| file-desc 
                                                                               file-page)
                                 :length
                                 (difference (fetch
 (|PageGroup| |nextFilePage|)
                                                of
 (fetch
 (|FileDescriptor| pagegroup) of
 file-desc))
                                        file-page))
                        page-runs)
               (setq file-page (fetch
 (|PageGroup| |nextFilePage|) of
 (fetch
 (|FileDescriptor| 
                                                                                    pagegroup)
                                                                         of
 file-desc)))
               (cl:when (>= file-page file-length)
                      (return (reverse page-runs))))))


(cl:defun show-vmem-run-table

   nil (let ((linkbase (locf (fetch
 (iocbpage dlvmemfileinfo) of
 \\iocbpage))))
            (cl:format t "File Page Numbers  =>  Disk Page Numbers~%")
            (bind
 (vp _ 0)
                  end-of-run-vp da end-of-run-da run-list
               eachtime
 (cl:setf da (da-to-vp (fetch
 (dlvmemrun dlvmcyl) of
 linkbase)
                                           (fetch
 (dlvmemrun dlvmhead) of
 linkbase)
                                           (fetch
 (dlvmemrun dlvmsector) of
 linkbase)))
               while
 (neq 0 (fetch
 (dlvmemrun dlfirstfilepage) of
 (fetch
 (dlvmemrun dlnextrun)
                                                                     of
 linkbase)))
               do
 (cl:setf end-of-run-vp (cl:1- (fetch
 (dlvmemrun dlfirstfilepage)
                                                   of
 (fetch
 (dlvmemrun dlnextrun) of
 linkbase)))
                         end-of-run-da
                         (iplus da (idifference end-of-run-vp vp)))
                  (cl:format t "[~D..~D]  =>  [~D..~D]~A~%" vp end-of-run-vp da end-of-run-da
                         (cond
                            ((some run-list #'(lambda (prev-addr-range)
                                                (and (igeq da (car prev-addr-range))
                                                     (ileq da (cdr prev-addr-range)))))
                             " <= Entirely bogus VMem run!")
                            ((not (eqp (idifference end-of-run-vp vp)
                                       (idifference end-of-run-da da)))
                             " <= VMem run length doesn't match disk run length!")
                            (t "")))
                  (push
 run-list (cons da end-of-run-da))
                  (cl:setf vp (fetch
 (dlvmemrun dlfirstfilepage) of
 (fetch
 (dlvmemrun dlnextrun)
                                                                       of
 linkbase))
                         linkbase
                         (fetch
 (dlvmemrun dlnextrun) of
 linkbase))
               finally
 (cl:setf end-of-run-vp (fetch
 (ifpage |DLLastVmemPage|) of
 |\\InterfacePage|))
                     (cl:format t "[~D..~D]  =>  [~D..~D]~%" vp end-of-run-vp da
                            (iplus da (idifference end-of-run-vp vp))))))


(cl:defun check-pages-free
 (vol file-runs &optional (one-at-a-time? t)) 
          
          (* |;;| "Check that the labels for the given pages look good. Doesn't check the VAM yet.")

 (for
 run in
 file-runs
    do
 (with-resource |\\DFSVAMjunkPage| (if
 one-at-a-time?
                                             then
 (for
 vol-page from
 (fr-vol-page run) as
 counter
                                                     from
 1 to
 (fr-length run)
                                                     do
 (proceed-case (|\\PFGetFreePage| vol vol-page 
                                                                             |\\DFSVAMjunkPage| 1)
                                                               (continue nil :report 
                                                                      "Skip this page and continue"))
                                                       )
                                           else
 (|\\PFGetFreePage| vol (fr-vol-page run)
                                                       |\\DFSVAMjunkPage|
                                                       (fr-length run))))))


(cl:defun print-runs-attractively
 (file-runs &optional vol-num)
   (let ((offset (cl:if vol-num (first-volume-page vol-num)
                        0)))
        (for
 run in
 file-runs first
 (cl:format t "File Page Numbers  =>  Disk Page Numbers~%")
           do
 (cl:format t "[~D..~D]  =>  [~D..~D]~%" (fr-file-page run)
                     (cl:1- (+ (fr-file-page run)
                               (fr-length run)))
                     (+ (fr-vol-page run)
                        offset)
                     (cl:1- (+ (fr-vol-page run)
                               offset
                               (fr-length run)))))))


(cl:defun chase-boot-links
 (fn &key vol-num (bft (default-bft))
                               verbose) 
          
          (* |;;| "runs through the bootfile starting from the appropriate boot pointer, using the LV boot pointer is a particular volume is specified, following the boot links. FN is called on each page with a physical page number, file page number, and file id. If verbose is true, will print something every 100 pages.")

 (let ((boot-pointer (get-boot-pointer vol-num bft)))
      (cl:when (cl:zerop (fetch
 (|DiskFileID| |da|) of
 boot-pointer))
             (cl:error "No boot pointer found."))
      (with-resource |label| (bind
 (correct-id _ (fetch-long-cardinal (fetch
 (|DiskFileID| \fid)
                                                                         of
 boot-pointer)))
                                   (last-boot-file-page _ (cl:1- (|\\PFFindFileSize| (bootfile-fd
                                                                                      vol-num bft))))
                                   (vp _ (pda-to-vp (fetch
 (|DiskFileID| |da|) of
 boot-pointer)))
                                   (fp _ (cl:1- (fetch
 (|DiskFileID| |firstPage|) of
 boot-pointer)))
                                   (buffer _ (ncreate 'vmempagep))
                                   file-id first
 (cl:when verbose (cl:princ "Processing bootfile" 
                                                                         *error-output*))
                                for
 page-num from
 0
                                do
 
          
          (* |;;| "Read next page")


                                   (cl:when (eql (cl:mod fp 100)
                                                 99)
                                          (cl:when verbose (cl:princ "." *error-output*))
                                          (block))
                                   (let ((status (|\\PFTransferPage| vp buffer 'vrr |label| 1)))
                                        (cl:when (not (eq status 'ok))
                                               (cl:cerror "Continue processing the file" 
                                                      "Can't read page ~D: status = ~S" vp status)))
                                   (cl:when (not (eql (cl:1+ fp)
                                                      (fetch
 (|Label| |filePage|) of
 |label|)))
                                          (cl:cerror "Continue processing the file" 
                                            "Boot file pages not contiguous: prev = ~D, current = ~D" 
                                                 fp (fetch
 (|Label| |filePage|) of
 |label|)))
                                   (cl:when (not (eql (cl:setf file-id (fetch
 (|Label| |fileID|)
                                                                          of
 |label|))
                                                      correct-id))
                                          (cl:cerror "Continue processing the file" 
                                              "File id in label (~D) doesn't match boot pointer (~D)" 
                                                 file-id correct-id))
                                   (cl:setf fp (fetch
 (|Label| |filePage|) of
 |label|))
                                   (cl:funcall fn vp fp page-num file-id)
                                   (cond
                                      ((and (eql -1 (fetch
 (|PilotDiskLabel| |BootLinkA|)
                                                       of
 |label|))
                                            (eql -1 (fetch
 (|PilotDiskLabel| |BootLinkB|)
                                                       of
 |label|)))
                                       (cl:when verbose (cl:princ "<boot link all 1's> " 
                                                               *error-output*))
                                       (return))
                                      ((igeq fp last-boot-file-page)
                                       (cl:when verbose (cl:princ "<end of file> " *error-output*))
                                       (return))
                                      ((and (cl:zerop (fetch
 (|PilotDiskLabel| |BootLinkA|)
                                                         of
 |label|))
                                            (cl:zerop (fetch
 (|PilotDiskLabel| |BootLinkB|)
                                                         of
 |label|)))
          
          (* |;;| "No boot link - continue to next page")


                                       (cl:incf vp))
                                      (t 
          
          (* |;;| "Have a real boot link - jump to new disk address")


                                         (cl:setf vp (pda-to-vp (\\makenumber (fetch
 (
                                                                                     |PilotDiskLabel|
                                                                                      |BootLinkB|)
                                                                                 of
 |label|)
                                                                       (fetch
 (|PilotDiskLabel|
                                                                               |BootLinkA|)
                                                                          of
 |label|))))
                                         (cl:when verbose (cl:format *error-output* "<Jump to ~D>" vp
                                                                 ))))))
      (cl:when verbose (cl:princ "done." *error-output*)
             (cl:terpri *error-output*))))


(cl:defun determine-boot-file-runs-using-pointers
 (&rest key-args &key vol-num (bft (default-bft))
                                                         verbose)
   (let ((offset (first-volume-page (vol-num-containing-page (pda-to-vp (fetch
 (|DiskFileID| |da|)
                                                                           of
 (get-boot-pointer
                                                                               vol-num bft))))))
         (run-list nil)
         last-vp run)
        (cl:apply 'chase-boot-links
               #'(cl:lambda (vp fp page-num file-id)
                        (declare
 (ignore page-num file-id))
                        (cl:flet ((new-run (fp vp)
                                         (cl:push (cl:setf run (make-file-run :file-page fp :vol-page
                                                                      (- vp offset)
                                                                      :length 1))
                                                run-list)
                                         (cl:setf last-vp vp)))
                               (cond
                                  ((null last-vp)
                                   (new-run fp vp))
                                  ((eql vp (cl:incf last-vp))
                                   (cl:incf (fr-length run)))
                                  (t (new-run fp vp))))) key-args)
        (reverse run-list)))


(defcommand "EC"
 (expression) 
          
          (* |;;| "\"eval compiled\"")

 (cl:funcall (cl:compile nil `(cl:lambda nil ,expression))))


(defglobalvar dsktw
 )

(xcl:reinstall-advice '|\\DoveDisk.HandleMajorError| :before '((:last (prin2 'h dsktw))))
(xcl:reinstall-advice '|\\DoveDisk.TryRecalibrate| :before '((:last (prin2 'r dsktw))))
(xcl:reinstall-advice '(\\dove.xferdisk :in \\dldisk.execute) :after
       '((:last (if (eq !value 'ok)
                    then
                    (prin2 '+ dsktw)
                    else
                    (prin2 '- dsktw)))))

(putprops lfhacks filetype
 :compile-file)
(putprops lfhacks copyright ("Xerox Corporation" 1987))
(declare\: dontcopy
  (filemap (nil)))
stop