master: debug-dump: store package-ids
stassats via Sbcl-commits <[email protected]>
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 4eb17c020e028ea6a9f9004bb69d305480870ab6 (commit)
from a8d783b39ac082b3ea00fcf84fa0081128ea78bc (commit)
- Log -----------------------------------------------------------------
commit 4eb17c020e028ea6a9f9004bb69d305480870ab6
Author: Stas Boukarev <[email protected]>
Date: Sat Aug 29 07:20:21 2026 +0300
debug-dump: store package-ids
Saves 288KB on a 35MB core.
---
src/code/debug-info.lisp | 4 +-
src/code/debug-int.lisp | 112 ++++++++++++++++++++------------------
src/code/package.lisp | 25 +++++++++
src/compiler/debug-dump.lisp | 20 +++++--
src/compiler/generic/genesis.lisp | 20 ++++---
5 files changed, 114 insertions(+), 67 deletions(-)
diff --git a/src/code/debug-info.lisp b/src/code/debug-info.lisp
index 15343b23d..ab2494014 100644
--- a/src/code/debug-info.lisp
+++ b/src/code/debug-info.lisp
@@ -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)
diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 65e0905b9..87ee1c951 100644
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -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))
diff --git a/src/code/package.lisp b/src/code/package.lisp
index a947bad1e..21909e0f0 100644
--- a/src/code/package.lisp
+++ b/src/code/package.lisp
@@ -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=))
diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp
index 94dcdd8e8..7706b5826 100644
--- a/src/compiler/debug-dump.lisp
+++ b/src/compiler/debug-dump.lisp
@@ -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
diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 0edfac0b1..b5e44ce64 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -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
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL