tools-for-build/readcore.lisp

   1
   2 ;;; This script can be used to help diagnose failure in rebuild-pathname-cache
   3 ;;; by dumping the cache as-is from any core for offline examination.
   4 ;;; Usage:
   5 ;;; * (load "tools-for-build/readcore")
   6 ;;; * (sb-editcore:dump-pathname-hashsets "/path/to/your.core"))
   7 ;;;
   8
   9 (load (merge-pathnames "editcore.lisp" *load-pathname*))
  10
  11 (in-package sb-editcore)
  12
  13 ;; layout IDs will be the same as the host's, assuming you're using the same SBCL git revision
  14 (import 'sb-kernel::layout-id)
  15 (defconstant pathname-layout-id (layout-id (find-layout 'pathname)))
  16 (defconstant lpn-layout-id (layout-id (find-layout 'logical-pathname)))
  17 (defconstant pattern-layout-id (layout-id (find-layout 'sb-impl::pattern)))
  18 (defconstant physhost-layout-id (layout-id
  19                                  (find-layout #+unix 'sb-impl::unix-host
  20                                               #+win32 'sb-impl::win32-host)))
  21 (defconstant loghost-layout-id (layout-id (find-layout 'sb-impl::logical-host)))
  22
  23 (defconstant keyword-package-id (sb-impl::package-id (find-package 'keyword)))
  24
  25 (defun convert-to-host-object (x spacemap)
  26   (let ((nil-object (compute-nil-object spacemap)))
  27     (labels ((recurse (x)
  28                (cond ((not (is-lisp-pointer (get-lisp-obj-address x)))
  29                       x)
  30                      ((eq x nil-object) nil)
  31                      (t
  32                       (let ((x (translate x spacemap)))
  33                         (ecase (lowtag-of x)
  34                           (#.list-pointer-lowtag
  35                            (cons (recurse (car x)) (recurse (cdr x))))
  36                           (#.instance-pointer-lowtag
  37                            ;; pathnames and patterns have only tagged slots
  38                            (let ((length (%instance-length x))
  39                                  (layout-id
  40                                   (sb-kernel::layout-id
  41                                    (translate (%instance-layout x) spacemap))))
  42                              (case layout-id
  43                                ;; don't display all slots in an instance of either subtype of HOST
  44                                (#.physhost-layout-id "#<physical-host>")
  45                                (#.loghost-layout-id
  46                                 (list ':logical-host
  47                                       (the simple-string
  48                                            (translate (sb-impl::logical-host-name x) spacemap))))
  49                                (t
  50                                 (list (ecase layout-id
  51                                         (#.pathname-layout-id :pathname)
  52                                         (#.lpn-layout-id :logical-pathname)
  53                                         (#.pattern-layout-id :pattern))
  54                                       (loop for i from instance-data-start below length
  55                                             collect (recurse (%instance-ref x i))))))))
  56                           (#.other-pointer-lowtag
  57                            (cond ((simple-string-p x) x)
  58                                  ((symbolp x)
  59                                   (aver (= (symbol-package-id x) keyword-package-id))
  60                                   (intern(translate (symbol-name x) spacemap)
  61                                          'keyword))
  62                                  (t (bug "What? ~x ~x"
  63                                          (get-lisp-obj-address x)
  64                                          (%other-pointer-widetag x)))))))))))
  65       (recurse x))))
  66
  67 (defun show-robinhood-hashset (symbol spacemap)
  68   (format t "~A~%" (translate (symbol-name symbol) spacemap))
  69   (let* ((hashset (translate (symbol-global-value symbol) spacemap))
  70          (storage (translate (sb-impl::hashset-storage hashset) spacemap))
  71          (cells (translate (sb-impl::hss-cells storage) spacemap))
  72          (n (length (the simple-vector cells)))
  73          (*print-pretty* nil)
  74          (*print-length* nil)
  75          (*print-level* nil))
  76     (dotimes (i n)
  77       (let ((elt (svref cells i)))
  78         ;; skip unused cells, but do show NIL and unbound-maker
  79         (unless (eql elt 0) ; unused
  80           (format t " [~4d]=~S~%" i (convert-to-host-object elt spacemap)))))))
  81
  82 (defun dump-pathname-hashsets (corefile-name)
  83   (with-open-file (input corefile-name :element-type '(unsigned-byte 8))
  84     (binding* ((core-header (make-array +backend-page-bytes+ :element-type '(unsigned-byte 8)))
  85                (core-offset (read-core-header input core-header t))
  86                ((npages space-list card-mask-nbits core-dir-start initfun)
  87                 (parse-core-header input core-header)))
  88         (declare (ignore card-mask-nbits core-dir-start initfun))
  89         (with-mapped-core (sap core-offset npages input)
  90           (let* ((spacemap (cons sap (sort (copy-list space-list) #'> :key #'space-addr)))
  91                  (sb-impl-pkgid (symbol-package-id 'sb-impl::*pn-dir-table*))
  92                  (pn-table (find-target-symbol sb-impl-pkgid "*PN-DIR-TABLE*" spacemap))
  93                  (dir-table (find-target-symbol sb-impl-pkgid "*PN-TABLE*" spacemap)))
  94             (show-robinhood-hashset dir-table spacemap)
  95             (show-robinhood-hashset pn-table spacemap))))))