mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Fix source locations from block-compilation.
Since a single code object can contain multiple top level forms each debug fun needs to contain its own tlf number.
This commit is contained in:
Stas Boukarev
parent
99a64531a1
commit
2b3585478c
|
|
@ -460,18 +460,18 @@ If an unsupported TYPE is requested, the function will return NIL.
|
|||
(defun find-function-definition-source (function)
|
||||
(let* ((debug-info (function-debug-info function))
|
||||
(debug-source (debug-info-source debug-info))
|
||||
(debug-fun (debug-info-debug-function function debug-info))
|
||||
(tlf (sb-c::compiled-debug-info-tlf-number debug-info)))
|
||||
(make-definition-source
|
||||
:pathname
|
||||
(when (stringp (debug-source-namestring debug-source))
|
||||
(parse-namestring (debug-source-namestring debug-source)))
|
||||
:character-offset
|
||||
(sb-c::compiled-debug-info-char-offset debug-info)
|
||||
:form-path (if tlf (list tlf))
|
||||
:form-number (sb-c::compiled-debug-fun-form-number debug-fun)
|
||||
:file-write-date (debug-source-created debug-source)
|
||||
:plist (sb-c::debug-source-plist debug-source))))
|
||||
(debug-fun (debug-info-debug-function function debug-info)))
|
||||
(multiple-value-bind (tlf character-offset)
|
||||
(sb-di::debug-fun-tlf-and-offset debug-info debug-fun)
|
||||
(make-definition-source
|
||||
:pathname
|
||||
(when (stringp (debug-source-namestring debug-source))
|
||||
(parse-namestring (debug-source-namestring debug-source)))
|
||||
:character-offset character-offset
|
||||
:form-path (if tlf (list tlf))
|
||||
:form-number (sb-c::compiled-debug-fun-form-number debug-fun)
|
||||
:file-write-date (debug-source-created debug-source)
|
||||
:plist (sb-c::debug-source-plist debug-source)))))
|
||||
|
||||
(defun translate-source-location (location)
|
||||
(if location
|
||||
|
|
|
|||
|
|
@ -191,6 +191,9 @@
|
|||
(return-pc-pass (missing-arg) :type sc+offset)
|
||||
#-fp-and-pc-standard-save
|
||||
(old-fp (missing-arg) :type sc+offset)
|
||||
;; When block compiling a single code object can have multiple top level forms,
|
||||
;; in that case it's a (cons (pack-tlf-num+offset tlf offset) integer)
|
||||
;; otherwise just an integer:
|
||||
;; An integer which contains between 4 and 6 varint-encoded fields:
|
||||
;; START-PC -
|
||||
;; The earliest PC in this function at which the environment is properly
|
||||
|
|
@ -200,7 +203,7 @@
|
|||
;; OFFSET
|
||||
;; The start of elsewhere code for this function (if any.)
|
||||
;; CLOSURE-SAVE, and BSP-SAVE.
|
||||
(encoded-locs (missing-arg) :type unsigned-byte :read-only t)
|
||||
(encoded-locs (missing-arg) :type (or cons unsigned-byte) :read-only t)
|
||||
(next))
|
||||
|
||||
(defun cdf-encode-locs (start-pc elsewhere-pc
|
||||
|
|
@ -231,8 +234,11 @@
|
|||
(integer-from-octets bytes)))
|
||||
|
||||
(defun cdf-decode-locs (cdf)
|
||||
(let ((encoding (compiled-debug-fun-encoded-locs cdf))
|
||||
(input-pointer 0))
|
||||
(let* ((encoding (compiled-debug-fun-encoded-locs cdf))
|
||||
(encoding (if (consp encoding)
|
||||
(cdr encoding)
|
||||
encoding))
|
||||
(input-pointer 0))
|
||||
(flet ((decode-varint (&aux (accumulator 0) (shift 0))
|
||||
(loop
|
||||
(let ((byte (ldb (byte 8 input-pointer) encoding)))
|
||||
|
|
@ -412,7 +418,7 @@
|
|||
(contexts nil :type t :read-only t)
|
||||
;; Packed integers. Also can be a cons of that plus an alist which
|
||||
;; maps SB-C::COMPILED-DEBUG-FUN to SB-DI::COMPILED-DEBUG-FUN instances.
|
||||
(tlf-num+offset (missing-arg) :type (or integer cons)))
|
||||
(tlf-num+offset (missing-arg) :type (or integer cons (eql :multiple))))
|
||||
|
||||
;;; The TLF-NUMBER and CHAR-OFFSET of a compiled-debug-info can each be NIL,
|
||||
;;; but aren't often. However, to allow that, convert NIL to 0 and non-nil
|
||||
|
|
|
|||
|
|
@ -2044,14 +2044,26 @@ register."
|
|||
(debug-signal 'no-debug-blocks :debug-fun
|
||||
(code-location-debug-fun code-location)))))
|
||||
|
||||
(defun debug-fun-tlf-and-offset (debug-info debug-fun)
|
||||
(if (typep (sb-c::compiled-debug-info-tlf-num+offset debug-info)
|
||||
'(or (eql :multiple) (cons (eql :multiple))))
|
||||
(let* ((encoded-locs (sb-c::compiled-debug-fun-encoded-locs debug-fun))
|
||||
(tlf-num+offset (and (consp encoded-locs)
|
||||
(car encoded-locs))))
|
||||
(if tlf-num+offset
|
||||
(sb-c::unpack-tlf-num+offset tlf-num+offset)))
|
||||
(values (sb-c::compiled-debug-info-tlf-number debug-info)
|
||||
(sb-c::compiled-debug-info-char-offset debug-info))))
|
||||
|
||||
;;; Returns the number of top level forms before the one containing
|
||||
;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A
|
||||
;;; compilation unit is not necessarily a single file, see the section
|
||||
;;; on debug-sources.)
|
||||
(defun code-location-toplevel-form-offset (code-location)
|
||||
(let ((di (compiled-debug-fun-debug-info
|
||||
(code-location-debug-fun code-location))))
|
||||
(sb-c::compiled-debug-info-tlf-number di)))
|
||||
(let ((df (code-location-debug-fun code-location)))
|
||||
(values
|
||||
(debug-fun-tlf-and-offset (compiled-debug-fun-debug-info df)
|
||||
(compiled-debug-fun-compiler-debug-fun df)))))
|
||||
|
||||
;;; Return the number of the form corresponding to CODE-LOCATION. The
|
||||
;;; form number is derived by a walking the subforms of a top level
|
||||
|
|
@ -3032,24 +3044,26 @@ register."
|
|||
(let* ((d-source (code-location-debug-source location))
|
||||
(di (compiled-debug-fun-debug-info
|
||||
(code-location-debug-fun location)))
|
||||
(tlf-offset (sb-c::compiled-debug-info-tlf-number di))
|
||||
(char-offset (sb-c::compiled-debug-info-char-offset di))
|
||||
(namestring (debug-source-namestring d-source)))
|
||||
;; FIXME: External format?
|
||||
(with-open-file (f namestring :if-does-not-exist nil)
|
||||
(when f
|
||||
(let ((*readtable* (safe-readtable)))
|
||||
(cond ((eql (debug-source-created d-source) (file-write-date f))
|
||||
(file-position f char-offset))
|
||||
(t
|
||||
(format *debug-io*
|
||||
"~%; File has been modified since compilation:~%; ~A~@
|
||||
(multiple-value-bind (tlf-offset char-offset)
|
||||
(debug-fun-tlf-and-offset di
|
||||
(compiled-debug-fun-compiler-debug-fun
|
||||
(code-location-debug-fun location)))
|
||||
;; FIXME: External format?
|
||||
(with-open-file (f namestring :if-does-not-exist nil)
|
||||
(when f
|
||||
(let ((*readtable* (safe-readtable)))
|
||||
(cond ((eql (debug-source-created d-source) (file-write-date f))
|
||||
(file-position f char-offset))
|
||||
(t
|
||||
(format *debug-io*
|
||||
"~%; File has been modified since compilation:~%; ~A~@
|
||||
; Using form offset instead of character position.~%"
|
||||
namestring)
|
||||
(let ((*read-suppress* t))
|
||||
(loop repeat tlf-offset
|
||||
do (read f)))))
|
||||
(read f))))))
|
||||
namestring)
|
||||
(let ((*read-suppress* t))
|
||||
(loop repeat tlf-offset
|
||||
do (read f)))))
|
||||
(read f)))))))
|
||||
|
||||
;;;; PREPROCESS-FOR-EVAL
|
||||
|
||||
|
|
|
|||
|
|
@ -637,27 +637,27 @@
|
|||
;;; Decode the packed TLF-NUM+OFFSET slot, which might have ancillary
|
||||
;;; data for the debugger pushed in. So if it's a cons, take the CDR.
|
||||
;;; This is target-only code, so doesn't belong in 'debug-info.lisp'
|
||||
(flet ((unpack-tlf-num+offset (cdi &aux (tlf-num+offset
|
||||
(compiled-debug-info-tlf-num+offset cdi))
|
||||
(integer (if (consp tlf-num+offset)
|
||||
(car tlf-num+offset)
|
||||
tlf-num+offset))
|
||||
(bytepos 0))
|
||||
(flet ((unpack-1 ()
|
||||
(let ((shift 0) (acc 0))
|
||||
(declare (notinline sb-kernel:%ldb)) ; lp#1573398
|
||||
(loop
|
||||
(let ((byte (ldb (byte 8 bytepos) integer)))
|
||||
(incf bytepos 8)
|
||||
(setf acc (logior acc (ash (logand byte #x7f) shift)))
|
||||
(if (logtest byte #x80)
|
||||
(incf shift 7)
|
||||
(return acc)))))))
|
||||
(let ((v1 (unpack-1))
|
||||
(v2 (unpack-1)))
|
||||
(values (if (eql v1 0) nil (1- v1))
|
||||
(if (eql v2 0) nil (1- v2)))))))
|
||||
(defun compiled-debug-info-tlf-number (cdi)
|
||||
(nth-value 0 (unpack-tlf-num+offset cdi)))
|
||||
(defun unpack-tlf-num+offset (tlf-num+offset
|
||||
&aux (integer (if (consp tlf-num+offset)
|
||||
(car tlf-num+offset)
|
||||
tlf-num+offset))
|
||||
(bytepos 0))
|
||||
(flet ((unpack-1 ()
|
||||
(let ((shift 0) (acc 0))
|
||||
(declare (notinline sb-kernel:%ldb)) ; lp#1573398
|
||||
(loop
|
||||
(let ((byte (ldb (byte 8 bytepos) integer)))
|
||||
(incf bytepos 8)
|
||||
(setf acc (logior acc (ash (logand byte #x7f) shift)))
|
||||
(if (logtest byte #x80)
|
||||
(incf shift 7)
|
||||
(return acc)))))))
|
||||
(let ((v1 (unpack-1))
|
||||
(v2 (unpack-1)))
|
||||
(values (if (eql v1 0) nil (1- v1))
|
||||
(if (eql v2 0) nil (1- v2))))))
|
||||
|
||||
(defun compiled-debug-info-tlf-number (cdi)
|
||||
(nth-value 0 (unpack-tlf-num+offset (compiled-debug-info-tlf-num+offset cdi))))
|
||||
(defun compiled-debug-info-char-offset (cdi)
|
||||
(nth-value 1 (unpack-tlf-num+offset cdi))))
|
||||
(nth-value 1 (unpack-tlf-num+offset (compiled-debug-info-tlf-num+offset cdi))))
|
||||
|
|
|
|||
|
|
@ -660,7 +660,7 @@
|
|||
;;;; debug functions
|
||||
|
||||
;;; Return a C-D-F structure with all the mandatory slots filled in.
|
||||
(defun dfun-from-fun (fun)
|
||||
(defun dfun-from-fun (fun tlf)
|
||||
(declare (type clambda fun))
|
||||
(let* ((2env (environment-info (lambda-environment fun)))
|
||||
(dispatch (lambda-optional-dispatch fun))
|
||||
|
|
@ -681,7 +681,22 @@
|
|||
(second name))
|
||||
(t
|
||||
name))
|
||||
name)))
|
||||
name))
|
||||
(encoded-locs
|
||||
(cdf-encode-locs
|
||||
(label-position (ir2-environment-environment-start 2env))
|
||||
(label-position (ir2-environment-elsewhere-start 2env))
|
||||
(source-path-form-number (node-source-path (lambda-bind fun)))
|
||||
(label-position (block-label (lambda-block fun)))
|
||||
(when (ir2-environment-closure-save-tn 2env)
|
||||
(tn-sc+offset (ir2-environment-closure-save-tn 2env)))
|
||||
#+unwind-to-frame-and-call-vop
|
||||
(when (ir2-environment-bsp-save-tn 2env)
|
||||
(tn-sc+offset (ir2-environment-bsp-save-tn 2env)))
|
||||
#-fp-and-pc-standard-save
|
||||
(label-position (ir2-environment-lra-saved-pc 2env))
|
||||
#-fp-and-pc-standard-save
|
||||
(label-position (ir2-environment-cfp-saved-pc 2env)))))
|
||||
(funcall (compiled-debug-fun-ctor kind)
|
||||
:name name
|
||||
#-fp-and-pc-standard-save :return-pc
|
||||
|
|
@ -691,27 +706,21 @@
|
|||
#-fp-and-pc-standard-save :old-fp
|
||||
#-fp-and-pc-standard-save (tn-sc+offset (ir2-environment-old-fp 2env))
|
||||
:encoded-locs
|
||||
(cdf-encode-locs
|
||||
(label-position (ir2-environment-environment-start 2env))
|
||||
(label-position (ir2-environment-elsewhere-start 2env))
|
||||
(source-path-form-number (node-source-path (lambda-bind fun)))
|
||||
(label-position (block-label (lambda-block fun)))
|
||||
(when (ir2-environment-closure-save-tn 2env)
|
||||
(tn-sc+offset (ir2-environment-closure-save-tn 2env)))
|
||||
#+unwind-to-frame-and-call-vop
|
||||
(when (ir2-environment-bsp-save-tn 2env)
|
||||
(tn-sc+offset (ir2-environment-bsp-save-tn 2env)))
|
||||
#-fp-and-pc-standard-save
|
||||
(label-position (ir2-environment-lra-saved-pc 2env))
|
||||
#-fp-and-pc-standard-save
|
||||
(label-position (ir2-environment-cfp-saved-pc 2env))))))
|
||||
(if tlf
|
||||
(cons (pack-tlf-num+offset
|
||||
tlf
|
||||
(aref (file-info-positions
|
||||
(source-info-file-info *source-info*))
|
||||
tlf))
|
||||
encoded-locs)
|
||||
encoded-locs))))
|
||||
|
||||
;;; Return a complete C-D-F structure for FUN. This involves
|
||||
;;; determining the DEBUG-INFO level and filling in optional slots as
|
||||
;;; appropriate.
|
||||
(defun compute-1-debug-fun (fun var-locs)
|
||||
(defun compute-1-debug-fun (fun var-locs tlf)
|
||||
(declare (type clambda fun) (type hash-table var-locs))
|
||||
(let* ((dfun (dfun-from-fun fun))
|
||||
(let* ((dfun (dfun-from-fun fun tlf))
|
||||
(actual-level (policy (lambda-bind fun) compute-debug-fun))
|
||||
(level (cond #+sb-dyncount
|
||||
(*collect-dynamic-statistics*
|
||||
|
|
@ -782,14 +791,23 @@
|
|||
component-tlf-num)
|
||||
(dolist (lambda (component-lambdas component))
|
||||
(unless (empty-fun-p lambda)
|
||||
(clrhash var-locs)
|
||||
(let ((tlf-num (source-path-tlf-number
|
||||
(node-source-path (lambda-bind lambda)))))
|
||||
(if component-tlf-num
|
||||
(aver (or (block-compile *compilation*)
|
||||
(= component-tlf-num tlf-num)))
|
||||
(setf component-tlf-num tlf-num))
|
||||
(push (compute-1-debug-fun lambda var-locs) dfuns))))
|
||||
(let ((tlf-num (source-path-tlf-number
|
||||
(node-source-path (lambda-bind lambda)))))
|
||||
(cond ((not component-tlf-num)
|
||||
(setf component-tlf-num tlf-num))
|
||||
((= component-tlf-num tlf-num))
|
||||
((block-compile *compilation*)
|
||||
(setf component-tlf-num :multiple)
|
||||
(return))
|
||||
(t
|
||||
(bug "tlf-num mismatch"))))))
|
||||
(dolist (lambda (component-lambdas component))
|
||||
(unless (empty-fun-p lambda)
|
||||
(clrhash var-locs)
|
||||
(let ((tlf-num (and (eq component-tlf-num :multiple)
|
||||
(source-path-tlf-number
|
||||
(node-source-path (lambda-bind lambda))))))
|
||||
(push (compute-1-debug-fun lambda var-locs tlf-num) dfuns))))
|
||||
(let* ((sorted (sort dfuns #'< :key #'compiled-debug-fun-offset))
|
||||
(fun-map (compute-debug-fun-map sorted)))
|
||||
(make-compiled-debug-info
|
||||
|
|
@ -803,12 +821,14 @@
|
|||
(sb-c::entry-info-name (car entries)))
|
||||
(component-name component)))
|
||||
:fun-map fun-map
|
||||
:tlf-num+offset (pack-tlf-num+offset
|
||||
component-tlf-num
|
||||
(and component-tlf-num
|
||||
(aref (file-info-positions
|
||||
(source-info-file-info *source-info*))
|
||||
component-tlf-num)))
|
||||
:tlf-num+offset (if (eq component-tlf-num :multiple)
|
||||
component-tlf-num
|
||||
(pack-tlf-num+offset
|
||||
component-tlf-num
|
||||
(and component-tlf-num
|
||||
(aref (file-info-positions
|
||||
(source-info-file-info *source-info*))
|
||||
component-tlf-num))))
|
||||
:contexts (compact-vector *contexts*)))))
|
||||
|
||||
;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of
|
||||
|
|
|
|||
Loading…
Reference in a new issue