common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

debug-dump: store package-ids

Browse source 
Saves 288KB on a 35MB core.
This commit is contained in:
Stas Boukarev 2026-08-29 07:20:21 +03:00
parent a8d783b39a
commit 4eb17c020e
5 changed files with 114 additions and 67 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
src/code/debug-info.lisp
View file

@ -31,11 +31,11 @@
;;; SC-Offset of primary location (as var-length integer)
;;; [If has save SC, SC-OFFSET of save location (as var-length integer)]
(defconstant compiled-debug-var-uninterned #b00000001)
(defconstant compiled-debug-var-uninterned #b00000001) ;; if -packaged then package-id is stored
(defconstant compiled-debug-var-packaged #b00000010)
(defconstant compiled-debug-var-environment-live #b00000100)
(defconstant compiled-debug-var-save-loc-p #b00001000)
(defconstant compiled-debug-var-same-name-p #b00010000) ;; if -packaged is 1 then this becomes same-package-p
(defconstant compiled-debug-var-same-name-p #b00010000) ;; if -packaged => -same-package-p
(defconstant compiled-debug-var-minimal-p #b00100000)
(defconstant compiled-debug-var-deleted-p #b01000000)
(defconstant compiled-debug-var-indirect-p #b10000000)

112
src/code/debug-int.lisp
View file

@ -1724,6 +1724,8 @@
;;; Parse the packed representation of DEBUG-VARs from
;;; DEBUG-FUN's SB-C::COMPILED-DEBUG-FUN, returning a vector
;;; of DEBUG-VARs, or NIL if there was no information to parse.
;;;
;;; This is written by SB-C::DUMP-1-VAR
(defun parse-compiled-debug-vars (debug-fun)
(let* ((cdebug-fun (compiled-debug-fun-compiler-debug-fun
debug-fun))
@ -1745,58 +1747,64 @@
previously-read-package
previous-package)
(loop
;; The routines in the "SB-C" package are macros that advance the
;; index.
(let* ((flags (prog1 (aref packed-vars i) (incf i)))
(minimal (logtest sb-c::compiled-debug-var-minimal-p flags))
(deleted (logtest sb-c::compiled-debug-var-deleted-p flags))
(packaged (logtest sb-c::compiled-debug-var-packaged flags))
(same-name-p (logtest sb-c::compiled-debug-var-same-name-p flags))
(name (cond (minimal "")
;; If packaged is 1 then same-name-p means same-package-p
((and (not packaged)
same-name-p)
prev-name)
(t (sb-c::read-var-string packed-vars i))))
(package (cond
(minimal default-package)
(packaged
(cond (same-name-p ; now same-package-p
previously-read-package)
(t
(setf previously-read-package
(find-package (sb-c::read-var-string packed-vars i))))))
((logtest sb-c::compiled-debug-var-uninterned flags)
nil)
(same-name-p
previous-package)
(t
default-package)))
(sc+offset
(if deleted 0 (sb-c::read-var-integerf packed-vars i)))
(save-sc+offset
(if (logtest sb-c::compiled-debug-var-save-loc-p flags)
(sb-c::read-var-integerf packed-vars i)
nil))
(indirect-sc+offset
(if (logtest sb-c::compiled-debug-var-indirect-p flags)
(sb-c::read-var-integerf packed-vars i)
nil)))
(aver (not (and args-minimal (not minimal))))
(cond ((and prev-name (string= prev-name name))
(incf id))
(t
(setf id 0
prev-name name)))
(setf previous-package package)
(vector-push-extend
(make-compiled-debug-var
name package id
(logtest sb-c::compiled-debug-var-environment-live flags)
sc+offset save-sc+offset
indirect-sc+offset)
buffer))
(when (>= i len) (return)))
;; The routines in the "SB-C" package are macros that advance the
;; index.
(let* ((flags (prog1 (aref packed-vars i) (incf i)))
(minimal (logtest sb-c::compiled-debug-var-minimal-p flags))
(deleted (logtest sb-c::compiled-debug-var-deleted-p flags))
(packaged (logtest sb-c::compiled-debug-var-packaged flags))
(same-name-p (logtest sb-c::compiled-debug-var-same-name-p flags))
(uninterned (logtest sb-c::compiled-debug-var-uninterned flags))
(name (cond (minimal "")
;; If packaged is 1 then same-name-p means same-package-p
((and (not packaged)
same-name-p)
prev-name)
(t (sb-c::read-var-string packed-vars i))))
(package (cond
(minimal default-package)
(packaged
(cond (same-name-p ; now same-package-p
previously-read-package)
;; packaged & uninterned means it's
;; writen as an integer package-id
(uninterned
(aref sb-impl::*id->package*
(prog1 (aref packed-vars i) (incf i))))
(t
(setf previously-read-package
(find-package (sb-c::read-var-string packed-vars i))))))
(uninterned
nil)
(same-name-p
previous-package)
(t
default-package)))
(sc+offset
(if deleted 0 (sb-c::read-var-integerf packed-vars i)))
(save-sc+offset
(if (logtest sb-c::compiled-debug-var-save-loc-p flags)
(sb-c::read-var-integerf packed-vars i)
nil))
(indirect-sc+offset
(if (logtest sb-c::compiled-debug-var-indirect-p flags)
(sb-c::read-var-integerf packed-vars i)
nil)))
(aver (not (and args-minimal (not minimal))))
(cond ((and prev-name (string= prev-name name))
(incf id))
(t
(setf id 0
prev-name name)))
(setf previous-package package)
(vector-push-extend
(make-compiled-debug-var
name package id
(logtest sb-c::compiled-debug-var-environment-live flags)
sc+offset save-sc+offset
indirect-sc+offset)
buffer))
(when (>= i len) (return)))
(let ((result (coerce buffer 'simple-vector)))
(when args-minimal
(assign-minimal-var-names result))

25
src/code/package.lisp
View file

@ -175,3 +175,28 @@ body. Body can begin with declarations."
;; only ppc64 needs this constant at compile-time. The others don't.
;; The package of this constant is sb-fasl for convenience in genesis.
(defconstant sb-fasl::+package-id-lisp+ 2)
;;; Stable IDs for the debugger
(eval-when (:compile-toplevel :load-toplevel :execute)
;; Before which system-package-p can be used, otherwise it'll include contribs
(defconstant +last-stable-package-id+
(1- (length
#1=(remove-if
(lambda (n)
(and n
(not (find-package n))))
#(nil "KEYWORD" "COMMON-LISP" "COMMON-LISP-USER" "SB-KERNEL" "SB-SYS"
"SB-VM" "SB-IMPL" "SB-THREAD" "SB-APROF" "SB-UNIX"
"SB-DEBUG" "SB-C" "SB-ALIEN-INTERNALS" "SB-PCL" "SB-DI" "SB-INT" "SB-LOOP"
"SB-ALIEN" "SB-EXT" "SB-PRETTY" "SB-FASL" "SB-ASSEM" "SB-BIGNUM" "SB-FORMAT"
"SB-DISASSEM" "SB-REGALLOC" "SB-EVAL" "SB-SEQUENCE" "SB-MOP"
"SB-BROTHERTREE" "SB-UNICODE" "SB-GRAY" "SB-WALKER" "SB-PROFILE"
"SB-WIN32" "SB-INTERPRETER" "SB-LOCKLESS"
#.(sb-cold::backend-asm-package-name))))))
#+sb-xc-host
(defvar *preassigned-package-ids* #1#))
#+sb-xc-host
(defun package-id (name)
(position (sb-xc:package-name name) *preassigned-package-ids* :test #'string=))

20
src/compiler/debug-dump.lisp
View file

@ -549,6 +549,8 @@
;;; environment live and is an argument. If a :DEBUG-ENVIRONMENT TN,
;;; then we also exclude set variables, since the variable is not
;;; guaranteed to be live everywhere in that case.
;;;
;;; This is read by sb-di::parse-compiled-debug-vars
(defun dump-1-var (fun var tn minimal buffer &optional name same-name-p)
(declare (type lambda-var var) (type (or tn null) tn)
(type clambda fun))
@ -578,9 +580,15 @@
(setq flags (logior flags compiled-debug-var-uninterned)))
(package-p
(setq flags (logior flags compiled-debug-var-packaged))
(when (eq package *previous-package*)
(setf flags (logior flags compiled-debug-var-same-name-p)) ;; overloaded
(setf package-p nil))))
(cond ((eq package *previous-package*)
(setf flags (logior flags compiled-debug-var-same-name-p)) ;; overloaded
(setf package-p nil))
;; Write a packe-id integer
((or (eq package *cl-package*)
(system-package-p package))
(let ((id (sb-impl::package-id package)))
(when (< id sb-impl::+last-stable-package-id+) ;; exclude contribs
(setf package-p id)))))))
(when (and (or (eq kind :environment)
(and (eq kind :debug-environment)
(null (basic-var-sets var))))
@ -594,11 +602,15 @@
(setq flags (logior flags compiled-debug-var-save-loc-p)))
(when indirect
(setq flags (logior flags compiled-debug-var-indirect-p)))
(when (integerp package-p)
(setf flags (logior flags compiled-debug-var-uninterned)))
(vector-push-extend flags buffer)
(unless (or minimal same-name-p)
(write-var-string (symbol-name name) buffer)
(when package-p
(write-var-string (sb-xc:package-name package) buffer)
(if (integerp package-p)
(vector-push-extend package-p buffer)
(write-var-string (sb-xc:package-name package) buffer))
(setf *previous-package* package)))
(cond (indirect

20
src/compiler/generic/genesis.lisp
View file

@ -1631,19 +1631,21 @@ core and return a descriptor to it."
(declaim (type hash-table *cold-package-symbols*))
(defvar *package-graph*)
(defun package-name-id (name)
(position name sb-impl::*preassigned-package-ids* :test #'string=))
;; These fixed IDs have no use in lisp code, but we need known values
;; for C to find packages easily
(defconstant +package-id-user+ 3)
(defconstant +package-id-kernel+ 4)
(defconstant +package-id-sys+ 5)
(defvar *package-id-count* 5) ; pre-incremented on use
(defvar +package-id-user+ (package-name-id "COMMON-LISP-USER"))
(defvar +package-id-kernel+ (package-name-id "SB-KERNEL"))
(defvar +package-id-sys+ (package-name-id "SB-SYS"))
(defvar *package-id-count* sb-impl::+last-stable-package-id+) ; pre-incremented on use
(defun package-id-generator (name)
(cond ((string= name "SB-KERNEL") +package-id-kernel+)
((string= name "SB-SYS") +package-id-sys+)
;; These were for C, but they seem unused
;;((string= name "SB-INT") +package-id-int+)
;;((string= name "SB-EXT") +package-id-ext+)
(cond ((package-name-id name))
(t (incf *package-id-count*))))
(assert (= +package-id-lisp+ (package-name-id "COMMON-LISP")))
(assert (= sb-impl::+package-id-keyword+ (package-name-id "KEYWORD")))
;;; Initialize the cold package named by NAME. The information is
;;; usually derived from the host package of the same name, except