master: debug-dump: don't store var symbol packages twice
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 a8d783b39ac082b3ea00fcf84fa0081128ea78bc (commit)
from 99c5b76053eb85d10ba2694b6417a5a12bc1f372 (commit)
- Log -----------------------------------------------------------------
commit a8d783b39ac082b3ea00fcf84fa0081128ea78bc
Author: Stas Boukarev <[email protected]>
Date: Sat Aug 29 05:54:07 2026 +0300
debug-dump: don't store var symbol packages twice
---
src/code/debug-info.lisp | 2 +-
src/code/debug-int.lisp | 25 ++++++++++++++++++-------
src/compiler/debug-dump.lisp | 41 ++++++++++++++++++++++++++---------------
3 files changed, 45 insertions(+), 23 deletions(-)
diff --git a/src/code/debug-info.lisp b/src/code/debug-info.lisp
index 39eb650ad..15343b23d 100644
--- a/src/code/debug-info.lisp
+++ b/src/code/debug-info.lisp
@@ -35,7 +35,7 @@
(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)
+(defconstant compiled-debug-var-same-name-p #b00010000) ;; if -packaged is 1 then this becomes 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 0ed0f44cb..65e0905b9 100644
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -1741,25 +1741,35 @@
(id 0)
(len (length packed-vars))
(buffer (make-array 0 :fill-pointer 0 :adjustable t))
- prev-name)
+ prev-name
+ 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 "")
- ((logtest sb-c::compiled-debug-var-same-name-p flags)
+ ;; 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)
- ((logtest sb-c::compiled-debug-var-packaged
- flags)
- (find-package (sb-c::read-var-string packed-vars i)))
- ((logtest sb-c::compiled-debug-var-uninterned
- flags)
+ (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
@@ -1778,6 +1788,7 @@
(t
(setf id 0
prev-name name)))
+ (setf previous-package package)
(vector-push-extend
(make-compiled-debug-var
name package id
diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp
index 6c989f640..94dcdd8e8 100644
--- a/src/compiler/debug-dump.lisp
+++ b/src/compiler/debug-dump.lisp
@@ -538,6 +538,8 @@
(make-sc+offset (sc-number (tn-sc tn))
(tn-offset tn)))
+(defvar *previous-package*)
+
;;; Dump info to represent VAR's location being TN. ID is an integer
;;; that makes VAR's name unique in the function. BUFFER is the vector
;;; we stick the result in. If MINIMAL, we suppress name dumping, and
@@ -570,11 +572,15 @@
(setq flags (logior flags compiled-debug-var-minimal-p))
(unless (and tn (tn-offset tn))
(setq flags (logior flags compiled-debug-var-deleted-p))))
- (t
- (unless package
- (setq flags (logior flags compiled-debug-var-uninterned)))
- (when package-p
- (setq flags (logior flags compiled-debug-var-packaged)))))
+ (same-name-p
+ (setq flags (logior flags compiled-debug-var-same-name-p)))
+ ((not package)
+ (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))))
(when (and (or (eq kind :environment)
(and (eq kind :debug-environment)
(null (basic-var-sets var))))
@@ -588,14 +594,12 @@
(setq flags (logior flags compiled-debug-var-save-loc-p)))
(when indirect
(setq flags (logior flags compiled-debug-var-indirect-p)))
- (when (and same-name-p (not minimal))
- (setq flags (logior flags compiled-debug-var-same-name-p)))
(vector-push-extend flags buffer)
- (unless minimal
- (unless same-name-p
- (write-var-string (symbol-name name) 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)))
+ (write-var-string (sb-xc:package-name package) buffer)
+ (setf *previous-package* package)))
(cond (indirect
;; Indirect variables live in the parent frame, and are
@@ -653,13 +657,20 @@
(frob-lambda let (>= level 2)))))
(setf (fill-pointer *byte-buffer*) 0)
- (let ((sorted (sort (vars) #'string<
- :key (lambda (x)
- (symbol-name (car x)))))
+ (let ((sorted (stable-sort
+ (sort (vars) #'string<
+ :key (lambda (x)
+ (symbol-name (car x))))
+ #'string<
+ :key (lambda (x)
+ (let ((package (sb-xc:symbol-package (car x))))
+ (when package
+ (sb-xc:package-name package))))))
(prev-name nil)
(i 0)
;; XEPs don't have any useful variables
- (minimal (functional-kind-eq fun external)))
+ (minimal (functional-kind-eq fun external))
+ *previous-package*)
(declare (type index i))
(loop for (name var . tn) in sorted
do
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL