mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
104 lines
5.4 KiB
Common Lisp
104 lines
5.4 KiB
Common Lisp
|
|
;;; This script can be used to help diagnose failure in rebuild-pathname-cache
|
|
;;; by dumping the cache as-is from any core for offline examination.
|
|
;;; Usage:
|
|
;;; * (load "tools-for-build/readcore")
|
|
;;; * (sb-editcore:dump-pathname-hashsets "/path/to/your.core"))
|
|
;;;
|
|
|
|
(load (merge-pathnames "editcore.lisp" *load-pathname*))
|
|
|
|
(in-package sb-editcore)
|
|
|
|
;; layout IDs will be the same as the host's, assuming you're using the same SBCL git revision
|
|
(import 'sb-kernel::layout-id)
|
|
(defconstant pathname-layout-id (layout-id (find-layout 'pathname)))
|
|
(defconstant lpn-layout-id (layout-id (find-layout 'logical-pathname)))
|
|
(defconstant pattern-layout-id (layout-id (find-layout 'sb-impl::pattern)))
|
|
(defconstant physhost-layout-id (layout-id
|
|
(find-layout #+unix 'sb-impl::unix-host
|
|
#+win32 'sb-impl::win32-host)))
|
|
(defconstant loghost-layout-id (layout-id (find-layout 'sb-impl::logical-host)))
|
|
|
|
(defconstant keyword-package-id (sb-impl::package-id (find-package 'keyword)))
|
|
|
|
(defun convert-to-host-object (x spacemap)
|
|
(let ()
|
|
(labels ((recurse (x)
|
|
(cond ((not (is-lisp-pointer (get-lisp-obj-address x)))
|
|
x)
|
|
((core-null-p x) nil)
|
|
(t
|
|
(let ((x (translate x spacemap)))
|
|
(ecase (lowtag-of x)
|
|
(#.list-pointer-lowtag
|
|
(cons (recurse (car x)) (recurse (cdr x))))
|
|
(#.instance-pointer-lowtag
|
|
;; pathnames and patterns have only tagged slots
|
|
(let ((length (%instance-length x))
|
|
(layout-id
|
|
(sb-kernel::layout-id
|
|
(translate (%instance-layout x) spacemap))))
|
|
(case layout-id
|
|
;; don't display all slots in an instance of either subtype of HOST
|
|
(#.physhost-layout-id "#<physical-host>")
|
|
(#.loghost-layout-id
|
|
(list ':logical-host
|
|
(the simple-string
|
|
(translate (sb-impl::logical-host-name x) spacemap))))
|
|
(t
|
|
(list (ecase layout-id
|
|
(#.pathname-layout-id :pathname)
|
|
(#.lpn-layout-id :logical-pathname)
|
|
(#.pattern-layout-id :pattern))
|
|
(loop for i from instance-data-start below length
|
|
collect (recurse (%instance-ref x i))))))))
|
|
(#.other-pointer-lowtag
|
|
(cond ((simple-string-p x) x)
|
|
((symbolp x)
|
|
(aver (= (symbol-package-id x) keyword-package-id))
|
|
(intern(translate (symbol-name x) spacemap)
|
|
'keyword))
|
|
(t (bug "What? ~x ~x"
|
|
(get-lisp-obj-address x)
|
|
(%other-pointer-widetag x)))))))))))
|
|
(recurse x))))
|
|
|
|
(defun show-robinhood-hashset (symbol spacemap)
|
|
(format t "~A~%" (translate (symbol-name symbol) spacemap))
|
|
(let* ((hashset (translate (symbol-global-value symbol) spacemap))
|
|
(storage (translate (sb-impl::hashset-storage hashset) spacemap))
|
|
(cells (translate (sb-impl::hss-cells storage) spacemap))
|
|
(hv (translate (sb-impl::hss-hash-vector storage) spacemap))
|
|
(pslv (translate (sb-impl::hss-psl-vector storage) spacemap))
|
|
(n (length (the simple-vector cells)))
|
|
(capacity (- n 3))
|
|
(*print-pretty* nil)
|
|
(*print-base* 16)
|
|
(*print-radix* t)
|
|
(*print-length* nil)
|
|
(*print-level* nil))
|
|
(dotimes (i n)
|
|
(let ((elt (convert-to-host-object (svref cells i) spacemap)))
|
|
(cond ((>= i capacity) ; trailing data
|
|
(format t " (~5d ~S)~%" i elt))
|
|
;; skip over never-used cells, but do show NIL and unbound-maker
|
|
((not (eq elt 0))
|
|
(format t " (~5d #x~4,'0x ~D ~S)~%" i (aref hv i) (aref pslv i) elt)))))))
|
|
|
|
(export 'dump-pathname-hashsets)
|
|
(defun dump-pathname-hashsets (corefile-name)
|
|
(with-open-file (input corefile-name :element-type '(unsigned-byte 8))
|
|
(binding* ((core-header (make-array +backend-page-bytes+ :element-type '(unsigned-byte 8)))
|
|
(core-offset (read-core-header input core-header t))
|
|
((npages space-list card-mask-nbits core-dir-start initfun)
|
|
(parse-core-header input core-header)))
|
|
(declare (ignore card-mask-nbits core-dir-start initfun))
|
|
(with-mapped-core (sap core-offset npages input)
|
|
(let* ((spacemap (cons sap (sort (copy-list space-list) #'> :key #'space-addr)))
|
|
(sb-impl-pkgid (symbol-package-id 'sb-impl::*pn-dir-table*))
|
|
(pn-table (find-target-symbol sb-impl-pkgid "*PN-DIR-TABLE*" spacemap))
|
|
(dir-table (find-target-symbol sb-impl-pkgid "*PN-TABLE*" spacemap)))
|
|
(show-robinhood-hashset dir-table spacemap)
|
|
(show-robinhood-hashset pn-table spacemap))))))
|