(defun dump-1-variable (fun var tn id minimal buffer)
(declare (type lambda-var var) (type (or tn null) tn) (type index id)
(type clambda fun))
- (let* ((name (leaf-name var))
+ (let* ((name (leaf-debug-name var))
(save-tn (and tn (tn-save-tn tn)))
(kind (and tn (tn-kind tn)))
(flags 0))
;;; Return a vector suitable for use as the DEBUG-FUN-VARIABLES
;;; of FUN. LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a
-;;; hashtable in which we enter the translation from LAMBDA-VARS to
+;;; hash table in which we enter the translation from LAMBDA-VARS to
;;; the relative position of that variable's location in the resulting
;;; vector.
(defun compute-variables (fun level var-locs)
(declare (type clambda fun) (type hash-table var-locs))
(collect ((vars))
(labels ((frob-leaf (leaf tn gensym-p)
- (let ((name (leaf-name leaf)))
+ (let ((name (leaf-debug-name leaf)))
(when (and name (leaf-refs leaf) (tn-offset tn)
(or gensym-p (symbol-package name)))
(vars (cons leaf tn)))))
(let ((sorted (sort (vars) #'string<
:key #'(lambda (x)
- (symbol-name (leaf-name (car x))))))
+ (symbol-name (leaf-debug-name (car x))))))
(prev-name nil)
(id 0)
(i 0)
(type index id i))
(dolist (x sorted)
(let* ((var (car x))
- (name (symbol-name (leaf-name var))))
+ (name (symbol-name (leaf-debug-name var))))
(cond ((and prev-name (string= prev-name name))
(incf id))
(t
(dump-1-variable fun var (leaf-info var) 0 t buffer))
(coerce buffer 'simple-vector)))
-;;; Return Var's relative position in the function's variables (determined
-;;; from the Var-Locs hashtable.) If Var is deleted, then return DELETED.
+;;; Return VAR's relative position in the function's variables (determined
+;;; from the VAR-LOCS hashtable). If VAR is deleted, then return DELETED.
(defun debug-location-for (var var-locs)
(declare (type lambda-var var) (type hash-table var-locs))
(let ((res (gethash var var-locs)))
(main-p (and dispatch
(eq fun (optional-dispatch-main-entry dispatch)))))
(make-compiled-debug-fun
- :name (cond ((leaf-name fun))
- ((let ((ef (functional-entry-function fun)))
- (and ef (leaf-name ef))))
- ((and main-p (leaf-name dispatch)))
- (t
- (component-name
- (block-component (node-block (lambda-bind fun))))))
+ :name (leaf-debug-name fun)
:kind (if main-p nil (functional-kind fun))
:return-pc (tn-sc-offset (ir2-physenv-return-pc 2env))
:old-fp (tn-sc-offset (ir2-physenv-old-fp 2env))
(compute-debug-returns fun)))))))
dfun))
\f
-;;;; MINIMAL-DEBUG-FUNs
-
-;;; Return true if DFUN can be represented as a MINIMAL-DEBUG-FUN.
-;;; DFUN is a cons (<start offset> . C-D-F).
-(defun debug-fun-minimal-p (dfun)
- (declare (type cons dfun))
- (let ((dfun (cdr dfun)))
- (and (member (compiled-debug-fun-arguments dfun) '(:minimal nil))
- (null (compiled-debug-fun-blocks dfun)))))
-
-;;; Dump a packed binary representation of a DFUN into *BYTE-BUFFER*.
-;;; PREV-START and START are the byte offsets in the code where the
-;;; previous function started and where this one starts.
-;;; PREV-ELSEWHERE is the previous function's elsewhere PC.
-(defun dump-1-minimal-dfun (dfun prev-start start prev-elsewhere)
- (declare (type compiled-debug-fun dfun)
- (type index prev-start start prev-elsewhere))
- (let* ((name (compiled-debug-fun-name dfun))
- (setf-p (and (consp name) (eq (car name) 'setf)
- (consp (cdr name)) (symbolp (cadr name))))
- (base-name (if setf-p (cadr name) name))
- (pkg (when (symbolp base-name)
- (symbol-package base-name)))
- (name-rep
- (cond ((stringp base-name)
- minimal-debug-fun-name-component)
- ((not pkg)
- minimal-debug-fun-name-uninterned)
- ((eq pkg (sane-package))
- minimal-debug-fun-name-symbol)
- (t
- minimal-debug-fun-name-packaged))))
- (aver (or (atom name) setf-p))
- (let ((options 0))
- (setf (ldb minimal-debug-fun-name-style-byte options) name-rep)
- (setf (ldb minimal-debug-fun-kind-byte options)
- (position-or-lose (compiled-debug-fun-kind dfun)
- *minimal-debug-fun-kinds*))
- (setf (ldb minimal-debug-fun-returns-byte options)
- (etypecase (compiled-debug-fun-returns dfun)
- ((member :standard) minimal-debug-fun-returns-standard)
- ((member :fixed) minimal-debug-fun-returns-fixed)
- (vector minimal-debug-fun-returns-specified)))
- (vector-push-extend options *byte-buffer*))
-
- (let ((flags 0))
- (when setf-p
- (setq flags (logior flags minimal-debug-fun-setf-bit)))
- (when (compiled-debug-fun-nfp dfun)
- (setq flags (logior flags minimal-debug-fun-nfp-bit)))
- (when (compiled-debug-fun-variables dfun)
- (setq flags (logior flags minimal-debug-fun-variables-bit)))
- (vector-push-extend flags *byte-buffer*))
-
- (when (eql name-rep minimal-debug-fun-name-packaged)
- (write-var-string (package-name pkg) *byte-buffer*))
- (unless (stringp base-name)
- (write-var-string (symbol-name base-name) *byte-buffer*))
-
- (let ((vars (compiled-debug-fun-variables dfun)))
- (when vars
- (let ((len (length vars)))
- (write-var-integer len *byte-buffer*)
- (dotimes (i len)
- (vector-push-extend (aref vars i) *byte-buffer*)))))
-
- (let ((returns (compiled-debug-fun-returns dfun)))
- (when (vectorp returns)
- (let ((len (length returns)))
- (write-var-integer len *byte-buffer*)
- (dotimes (i len)
- (write-var-integer (aref returns i) *byte-buffer*)))))
-
- (write-var-integer (compiled-debug-fun-return-pc dfun)
- *byte-buffer*)
- (write-var-integer (compiled-debug-fun-old-fp dfun)
- *byte-buffer*)
- (when (compiled-debug-fun-nfp dfun)
- (write-var-integer (compiled-debug-fun-nfp dfun)
- *byte-buffer*))
- (write-var-integer (- start prev-start) *byte-buffer*)
- (write-var-integer (- (compiled-debug-fun-start-pc dfun) start)
- *byte-buffer*)
- (write-var-integer (- (compiled-debug-fun-elsewhere-pc dfun)
- prev-elsewhere)
- *byte-buffer*)))
-
-;;; Return a byte-vector holding all the debug functions for a
-;;; component in the packed binary MINIMAL-DEBUG-FUN format.
-(defun compute-minimal-debug-funs (dfuns)
- (declare (list dfuns))
- (setf (fill-pointer *byte-buffer*) 0)
- (let ((prev-start 0)
- (prev-elsewhere 0))
- (dolist (dfun dfuns)
- (let ((start (car dfun))
- (elsewhere (compiled-debug-fun-elsewhere-pc (cdr dfun))))
- (dump-1-minimal-dfun (cdr dfun) prev-start start prev-elsewhere)
- (setq prev-start start prev-elsewhere elsewhere))))
- (copy-seq *byte-buffer*))
-\f
;;;; full component dumping
;;; Compute the full form (simple-vector) function map.
(declare (type component component))
(collect ((dfuns))
(let ((var-locs (make-hash-table :test 'eq))
- ;; FIXME: What is *BYTE-BUFFER* for? Has it become dead code
- ;; now that we no longer use MINIMAL-DEBUG-FUN
- ;; representation?
(*byte-buffer* (make-array 10
:element-type '(unsigned-byte 8)
:fill-pointer 0
:adjustable t)))
(dolist (fun (component-lambdas component))
(clrhash var-locs)
- (dfuns (cons (label-position
- (block-label (node-block (lambda-bind fun))))
+ (dfuns (cons (label-position (block-label (lambda-block fun)))
(compute-1-debug-fun fun var-locs))))
(let* ((sorted (sort (dfuns) #'< :key #'car))
- ;; FIXME: CMU CL had
- ;; (IF (EVERY #'DEBUG-FUN-MINIMAL-P SORTED)
- ;; (COMPUTE-MINIMAL-DEBUG-FUNS SORTED)
- ;; (COMPUTE-DEBUG-FUN-MAP SORTED))
- ;; here. We've gotten rid of the MINIMAL-DEBUG-FUN
- ;; case in SBCL because the minimal representation
- ;; couldn't be made to transform properly under package
- ;; renaming. Now that that case is gone, a lot of code is
- ;; dead, and once everything is known to work, the dead
- ;; code should be deleted.
- (function-map (compute-debug-fun-map sorted)))
+ (fun-map (compute-debug-fun-map sorted)))
(make-compiled-debug-info :name (component-name component)
- :function-map function-map)))))
+ :fun-map fun-map)))))
\f
;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of
;;; BITS must be evenly divisible by eight.
projects / sbcl.git / blobdiff