-;;;; minimal debug functions
-
-;;; Return true if DFUN can be represented as a minimal debug
-;;; function. DFUN is a cons (<start offset> . C-D-F).
-(defun debug-function-minimal-p (dfun)
- (declare (type cons dfun))
- (let ((dfun (cdr dfun)))
- (and (member (compiled-debug-function-arguments dfun) '(:minimal nil))
- (null (compiled-debug-function-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-function dfun)
- (type index prev-start start prev-elsewhere))
- (let* ((name (compiled-debug-function-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-function-name-component)
- ((not pkg)
- minimal-debug-function-name-uninterned)
- ((eq pkg (sane-package))
- minimal-debug-function-name-symbol)
- (t
- minimal-debug-function-name-packaged))))
- (assert (or (atom name) setf-p))
- (let ((options 0))
- (setf (ldb minimal-debug-function-name-style-byte options) name-rep)
- (setf (ldb minimal-debug-function-kind-byte options)
- (position-or-lose (compiled-debug-function-kind dfun)
- *minimal-debug-function-kinds*))
- (setf (ldb minimal-debug-function-returns-byte options)
- (etypecase (compiled-debug-function-returns dfun)
- ((member :standard) minimal-debug-function-returns-standard)
- ((member :fixed) minimal-debug-function-returns-fixed)
- (vector minimal-debug-function-returns-specified)))
- (vector-push-extend options *byte-buffer*))
-
- (let ((flags 0))
- (when setf-p
- (setq flags (logior flags minimal-debug-function-setf-bit)))
- (when (compiled-debug-function-nfp dfun)
- (setq flags (logior flags minimal-debug-function-nfp-bit)))
- (when (compiled-debug-function-variables dfun)
- (setq flags (logior flags minimal-debug-function-variables-bit)))
- (vector-push-extend flags *byte-buffer*))
-
- (when (eql name-rep minimal-debug-function-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-function-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-function-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-function-return-pc dfun)
- *byte-buffer*)
- (write-var-integer (compiled-debug-function-old-fp dfun)
- *byte-buffer*)
- (when (compiled-debug-function-nfp dfun)
- (write-var-integer (compiled-debug-function-nfp dfun)
- *byte-buffer*))
- (write-var-integer (- start prev-start) *byte-buffer*)
- (write-var-integer (- (compiled-debug-function-start-pc dfun) start)
- *byte-buffer*)
- (write-var-integer (- (compiled-debug-function-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-function format.
-(defun compute-minimal-debug-functions (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-function-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