diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp index ee929c786..3e60f7849 100644 --- a/contrib/sb-introspect/introspect.lisp +++ b/contrib/sb-introspect/introspect.lisp @@ -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 diff --git a/src/code/debug-info.lisp b/src/code/debug-info.lisp index f41a80038..945e29285 100644 --- a/src/code/debug-info.lisp +++ b/src/code/debug-info.lisp @@ -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 diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index fbae4cec3..ffb314efc 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -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 diff --git a/src/code/simple-fun.lisp b/src/code/simple-fun.lisp index 699938a81..21c2b2506 100644 --- a/src/code/simple-fun.lisp +++ b/src/code/simple-fun.lisp @@ -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)))) diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index e69a42bf0..41e1fec55 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -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