-;;;; 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