mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
1186 lines
51 KiB
Common Lisp
1186 lines
51 KiB
Common Lisp
;;;; stuff that creates debugger information from the compiler's
|
||
;;;; internal data structures
|
||
|
||
;;;; This software is part of the SBCL system. See the README file for
|
||
;;;; more information.
|
||
;;;;
|
||
;;;; This software is derived from the CMU CL system, which was
|
||
;;;; written at Carnegie Mellon University and released into the
|
||
;;;; public domain. The software is in the public domain and is
|
||
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
|
||
;;;; files for more information.
|
||
|
||
(in-package "SB-C")
|
||
|
||
(deftype byte-buffer () '(vector (unsigned-byte 8)))
|
||
(defvar *byte-buffer*)
|
||
(declaim (type byte-buffer *byte-buffer*))
|
||
(defvar *contexts*)
|
||
(declaim (type (vector t) *contexts*))
|
||
(defvar *local-call-context*)
|
||
(defvar *location-context* nil)
|
||
|
||
;;;; debug blocks
|
||
|
||
(deftype location-kind ()
|
||
'(member :unknown-return :known-return :internal-error :non-local-exit
|
||
:block-start :call-site :single-value-return :non-local-entry))
|
||
|
||
;;; The LOCATION-INFO structure holds the information what we need
|
||
;;; about locations which code generation decided were "interesting".
|
||
(defstruct (location-info
|
||
(:constructor make-location-info (kind label vop context))
|
||
(:copier nil))
|
||
;; The kind of location noted.
|
||
(kind nil :type location-kind)
|
||
(context nil)
|
||
;; The label pointing to the interesting code location.
|
||
(label nil :type (or label index null))
|
||
;; The VOP that emitted this location (for node, save-set, ir2-block, etc.)
|
||
(vop nil :type vop))
|
||
|
||
(defstruct (restart-location
|
||
(:constructor make-restart-location (&optional label tn))
|
||
(:copier nil))
|
||
(label nil :type (or null label))
|
||
(tn nil :type (or null tn) :read-only t))
|
||
(!set-load-form-method restart-location (:xc :target) :ignore-it)
|
||
|
||
;;; This is called during code generation in places where there is an
|
||
;;; "interesting" location: someplace where we are likely to end up
|
||
;;; in the debugger, and thus want debug info.
|
||
(defun note-debug-location (vop label kind &optional context)
|
||
(declare (type vop vop) (type (or label null) label)
|
||
(type location-kind kind))
|
||
(let ((location (make-location-info kind label vop context)))
|
||
(setf (ir2-block-locations (vop-block vop))
|
||
(nconc (ir2-block-locations (vop-block vop))
|
||
(list location)))
|
||
location))
|
||
|
||
(defun note-this-location (vop kind)
|
||
"NOTE-THIS-LOCATION VOP Kind
|
||
Note that the current code location is an interesting (to the debugger)
|
||
location of the specified Kind. VOP is the VOP responsible for this code.
|
||
This VOP must specify some non-null :SAVE-P value (perhaps :COMPUTE-ONLY) so
|
||
that the live set is computed."
|
||
(let ((lab (gen-label)))
|
||
(emit-label lab)
|
||
(note-debug-location vop lab kind *location-context*)))
|
||
|
||
(defun note-next-instruction (vop kind)
|
||
"NOTE-NEXT-INSTRUCTION VOP Kind
|
||
Similar to NOTE-THIS-LOCATION, except the use the location of the next
|
||
instruction for the code location, wherever the scheduler decided to put
|
||
it."
|
||
(let ((loc (note-debug-location vop nil kind)))
|
||
(emit-postit (lambda (segment posn)
|
||
(setf (location-info-label loc)
|
||
(- posn (segment-header-skew segment))))))
|
||
(values))
|
||
|
||
(declaim (inline ir2-block-environment))
|
||
(defun ir2-block-environment (2block)
|
||
(declare (type ir2-block 2block))
|
||
(block-environment (ir2-block-block 2block)))
|
||
|
||
(defun make-lexenv-var-cache (lexenv)
|
||
(or (lexenv-var-cache lexenv)
|
||
(let ((cache (make-hash-table :test #'eq)))
|
||
(labels ((populate (lexenv)
|
||
(loop for (nil . var) in (lexenv-vars lexenv)
|
||
when (lambda-var-p var)
|
||
do (setf (gethash var cache) t))
|
||
(let* ((lambda (lexenv-lambda lexenv))
|
||
(call-lexenv (and lambda
|
||
(lambda-call-lexenv lambda))))
|
||
(cond ((not call-lexenv))
|
||
((lexenv-var-cache call-lexenv)
|
||
(loop for var being each hash-key of (lexenv-var-cache call-lexenv)
|
||
do (setf (gethash var cache) t)))
|
||
(t
|
||
(populate call-lexenv))))))
|
||
(populate lexenv))
|
||
(setf (lexenv-var-cache lexenv) cache))))
|
||
|
||
(defun leaf-visible-to-debugger-p (leaf node)
|
||
(gethash leaf (make-lexenv-var-cache (node-lexenv node))))
|
||
|
||
(defun optional-leaf-p (leaf)
|
||
(let ((home (lambda-var-home leaf)))
|
||
(functional-kind-case home
|
||
(external
|
||
(let ((entry (lambda-entry-fun home)))
|
||
(when (optional-dispatch-p entry)
|
||
(let ((pos (position leaf (lambda-vars home))))
|
||
(and pos
|
||
(>= (1- pos) (optional-dispatch-min-args entry))))))))))
|
||
|
||
;;; Type checks of the arguments in an external function happen before
|
||
;;; all the &optionals are initialized. PROPAGATE-TO-ARGS marks such
|
||
;;; locations with the entry point, which allows to deduce if an
|
||
;;; optional is alive at that point.
|
||
(defun optional-processed (leaf)
|
||
(let ((home (lambda-var-home leaf)))
|
||
(functional-kind-case home
|
||
(external
|
||
(let ((entry (lambda-entry-fun home)))
|
||
(if (and (optional-dispatch-p entry)
|
||
*local-call-context*)
|
||
(let ((pos (position leaf (lambda-vars home)))
|
||
(entry-pos (position *local-call-context*
|
||
(optional-dispatch-entry-points entry)
|
||
:key #'force)))
|
||
(not (and pos
|
||
entry-pos
|
||
(>= (1- pos) (+ (optional-dispatch-min-args entry) entry-pos)))))
|
||
t)))
|
||
(t t))))
|
||
|
||
;;; Given a local conflicts vector and an IR2 block to represent the
|
||
;;; set of live TNs, and the VAR-LOCS hash-table representing the
|
||
;;; variables dumped, compute a bit-vector representing the set of
|
||
;;; live variables. If the TN is environment-live, we only mark it as
|
||
;;; live when it is in scope at NODE.
|
||
(defun compute-live-vars (live node block var-locs vop)
|
||
(declare (type ir2-block block) (type local-tn-bit-vector live)
|
||
(type hash-table var-locs) (type node node)
|
||
(type (or vop null) vop)
|
||
#-sb-xc-host (values simple-bit-vector))
|
||
(let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
|
||
:element-type 'bit
|
||
:initial-element 0))
|
||
(spilled (gethash vop
|
||
(ir2-component-spilled-vops
|
||
(component-info *component-being-compiled*)))))
|
||
(do-live-tns (tn live block)
|
||
(let ((leaf (tn-leaf tn)))
|
||
(when (and (lambda-var-p leaf)
|
||
(not (lambda-var-no-debug leaf))
|
||
(or (not (member (tn-kind tn)
|
||
'(:environment :debug-environment)))
|
||
(leaf-visible-to-debugger-p leaf node))
|
||
(or (null spilled)
|
||
(not (member tn spilled)))
|
||
(optional-processed leaf))
|
||
(let ((num (gethash leaf var-locs)))
|
||
(when num
|
||
|
||
(setf (sbit res num) 1))))))
|
||
res))
|
||
|
||
;;; The PC for the location most recently dumped.
|
||
(defvar *previous-location*)
|
||
(declaim (type index *previous-location*))
|
||
(defvar *previous-live*)
|
||
(defvar *previous-form-number*)
|
||
|
||
(defun encode-restart-location (location x)
|
||
(flet ((encode-restart (restart)
|
||
(let ((offset (- (label-position (restart-location-label restart))
|
||
location))
|
||
(tn (restart-location-tn restart))
|
||
(registers-size #.(integer-length (sb-size (sb-or-lose 'sb-vm::registers)))))
|
||
(if tn
|
||
(the fixnum (logior (ash offset registers-size)
|
||
(tn-offset tn)))
|
||
offset))))
|
||
(typecase x
|
||
((cons restart-location)
|
||
(cons (encode-restart (car x))
|
||
(cdr x)))
|
||
(restart-location
|
||
(encode-restart x))
|
||
(t
|
||
x))))
|
||
|
||
(defun decode-restart-location (x)
|
||
(declare (fixnum x))
|
||
(let ((registers-size #.(integer-length (sb-size (sb-or-lose 'sb-vm::registers)))))
|
||
(values (make-sc+offset sb-vm:descriptor-reg-sc-number
|
||
(ldb (byte registers-size 0) x))
|
||
(ash x (- registers-size)))))
|
||
|
||
;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes
|
||
;;; the code/source map and live info. If true, VOP is the VOP
|
||
;;; associated with this location, for use in determining whether TNs
|
||
;;; are spilled.
|
||
(defun dump-1-location (node block kind tlf-num label live var-locs vop
|
||
&optional context)
|
||
(declare (type node node) (type ir2-block block)
|
||
(type (or null local-tn-bit-vector) live)
|
||
(type (or label index) label)
|
||
(type location-kind kind) (type (or index null) tlf-num)
|
||
(type hash-table var-locs) (type (or vop null) vop))
|
||
(let* ((byte-buffer *byte-buffer*)
|
||
(stepping (and (combination-p node)
|
||
(combination-step-info node)))
|
||
(*local-call-context*
|
||
(if (local-call-context-p context)
|
||
(local-call-context-fun context)))
|
||
(context (if (local-call-context-p context)
|
||
(local-call-context-var context)
|
||
context))
|
||
(live (and live
|
||
(compute-live-vars live node block var-locs vop)))
|
||
(anything-alive (and live
|
||
(find 1 live)))
|
||
(equal-live (and anything-alive
|
||
(equal live *previous-live*)))
|
||
|
||
(path (node-source-path node))
|
||
(loc (if (fixnump label) label (label-position label)))
|
||
(form-number (source-path-form-number path)))
|
||
(vector-push-extend
|
||
(logior
|
||
(if context
|
||
compiled-code-location-context
|
||
0)
|
||
(if stepping
|
||
compiled-code-location-stepping
|
||
0)
|
||
(if (zerop form-number)
|
||
compiled-code-location-zero-form-number
|
||
0)
|
||
(cond (equal-live
|
||
(cond ((eql form-number *previous-form-number*)
|
||
;; Repurpose this bit for equal-form-number since
|
||
;; -equal-live and -live don't need to appear at the
|
||
;; same time.
|
||
(setf form-number 0)
|
||
compiled-code-location-live)
|
||
(t
|
||
0)))
|
||
(anything-alive
|
||
compiled-code-location-live)
|
||
(t
|
||
0))
|
||
(if equal-live
|
||
compiled-code-location-equal-live
|
||
0)
|
||
(position-or-lose kind +compiled-code-location-kinds+))
|
||
byte-buffer)
|
||
(write-var-integer (- loc *previous-location*) byte-buffer)
|
||
(setq *previous-location* loc)
|
||
|
||
(unless tlf-num
|
||
(write-var-integer (source-path-tlf-number path) byte-buffer))
|
||
(unless (zerop form-number)
|
||
(setf *previous-form-number* form-number)
|
||
(write-var-integer form-number byte-buffer))
|
||
|
||
(when (and anything-alive
|
||
(not equal-live))
|
||
(setf *previous-live* live)
|
||
(write-packed-bit-vector live byte-buffer))
|
||
(when stepping
|
||
(write-var-string stepping byte-buffer))
|
||
(when context
|
||
(let ((context (encode-restart-location loc context)))
|
||
(write-var-integer (or (position context *contexts* :test #'equal)
|
||
(vector-push-extend context *contexts*))
|
||
byte-buffer))))
|
||
(values))
|
||
|
||
;;; Extract context info from a Location-Info structure and use it to
|
||
;;; dump a compiled code-location.
|
||
(defun dump-location-from-info (loc tlf-num var-locs)
|
||
(declare (type location-info loc) (type (or index null) tlf-num)
|
||
(type hash-table var-locs))
|
||
(let ((vop (location-info-vop loc)))
|
||
(dump-1-location (vop-node vop)
|
||
(vop-block vop)
|
||
(location-info-kind loc)
|
||
tlf-num
|
||
(location-info-label loc)
|
||
(vop-save-set vop)
|
||
var-locs
|
||
vop
|
||
(location-info-context loc)))
|
||
(values))
|
||
|
||
;;; Scan all the blocks, determining if all locations are in the same
|
||
;;; TLF, and returning it or NIL.
|
||
(defun find-tlf-number (fun)
|
||
(declare (type clambda fun))
|
||
(let ((res (source-path-tlf-number (node-source-path (lambda-bind fun)))))
|
||
(declare (type (or index null) res))
|
||
(do-environment-ir2-blocks (2block (lambda-environment fun))
|
||
(let ((block (ir2-block-block 2block)))
|
||
(when (eq (block-info block) 2block)
|
||
(unless (eql (source-path-tlf-number
|
||
(node-source-path
|
||
(block-start-node block)))
|
||
res)
|
||
(setq res nil)))
|
||
|
||
(dolist (loc (ir2-block-locations 2block))
|
||
(unless (eql (source-path-tlf-number
|
||
(node-source-path
|
||
(vop-node (location-info-vop loc))))
|
||
res)
|
||
(setq res nil)))))
|
||
res))
|
||
|
||
;;; Dump out the number of locations and the locations for Block.
|
||
(defun dump-block-locations (block locations tlf-num var-locs)
|
||
(declare (type cblock block) (list locations))
|
||
(if (and locations
|
||
(eq (location-info-kind (first locations))
|
||
:non-local-entry))
|
||
(write-var-integer (length locations) *byte-buffer*)
|
||
(let ((2block (block-info block)))
|
||
(write-var-integer (+ (length locations) 1) *byte-buffer*)
|
||
(dump-1-location (block-start-node block)
|
||
2block :block-start tlf-num
|
||
(ir2-block-%label 2block)
|
||
(ir2-block-live-out 2block)
|
||
var-locs
|
||
nil)))
|
||
(dolist (loc locations)
|
||
(dump-location-from-info loc tlf-num var-locs))
|
||
(values))
|
||
|
||
;;; Dump the successors of Block, being careful not to fly into space
|
||
;;; on weird successors.
|
||
(defun dump-block-successors (block env)
|
||
(declare (type cblock block) (type environment env))
|
||
(let* ((tail (component-tail (block-component block)))
|
||
(succ (block-succ block))
|
||
(valid-succ
|
||
(if (and succ
|
||
(or (eq (car succ) tail)
|
||
(not (eq (block-environment (car succ)) env))))
|
||
()
|
||
succ))
|
||
(byte-buffer *byte-buffer*))
|
||
(write-var-integer (ash (length valid-succ) compiled-debug-block-nsucc-shift)
|
||
byte-buffer)
|
||
(let ((base (block-number
|
||
(node-block
|
||
(lambda-bind (environment-lambda env))))))
|
||
(dolist (b valid-succ)
|
||
(write-var-integer
|
||
(the index (- (block-number b) base))
|
||
byte-buffer))))
|
||
(values))
|
||
|
||
;;; Return a vector and an integer (or null) suitable for use as the
|
||
;;; BLOCKS and TLF-NUMBER in FUN's DEBUG-FUN. This requires two
|
||
;;; passes to compute:
|
||
;;; -- Scan all blocks, dumping the header and successors followed
|
||
;;; by all the non-elsewhere locations.
|
||
;;; -- Dump the elsewhere block header and all the elsewhere
|
||
;;; locations (if any.)
|
||
(defun compute-debug-blocks (fun var-locs elsewhere-label)
|
||
(declare (type clambda fun) (type hash-table var-locs))
|
||
(let ((*previous-location* 0)
|
||
*previous-live*
|
||
*previous-form-number*
|
||
(tlf-num (find-tlf-number fun))
|
||
(env (lambda-environment fun))
|
||
(prev-locs nil)
|
||
(prev-block nil)
|
||
(byte-buffer *byte-buffer*))
|
||
(setf (fill-pointer byte-buffer) 0)
|
||
(collect ((elsewhere))
|
||
(do-environment-ir2-blocks (2block env)
|
||
(let ((block (ir2-block-block 2block)))
|
||
(when (eq (block-info block) 2block)
|
||
(when prev-block
|
||
(dump-block-locations prev-block prev-locs tlf-num var-locs))
|
||
(setf prev-block block prev-locs ())
|
||
(dump-block-successors block env)))
|
||
|
||
(collect ((here prev-locs))
|
||
(dolist (loc (ir2-block-locations 2block))
|
||
(if (label-elsewhere-p (location-info-label loc)
|
||
(location-info-kind loc)
|
||
elsewhere-label)
|
||
(elsewhere loc)
|
||
(here loc)))
|
||
(setq prev-locs (here))))
|
||
|
||
(dump-block-locations prev-block prev-locs tlf-num var-locs)
|
||
|
||
(when (elsewhere)
|
||
(vector-push-extend compiled-debug-block-elsewhere-p byte-buffer)
|
||
(write-var-integer (length (elsewhere)) byte-buffer)
|
||
(dolist (loc (elsewhere))
|
||
(dump-location-from-info loc tlf-num var-locs))))
|
||
|
||
(values (coerce byte-buffer '(simple-array (unsigned-byte 8) (*))) tlf-num)))
|
||
|
||
;;; Return DEBUG-SOURCE structure containing information derived from
|
||
;;; INFO.
|
||
(defun debug-source-for-info (info &key core)
|
||
(declare (type source-info info))
|
||
(let ((file-info (get-toplevelish-file-info info)))
|
||
(multiple-value-call
|
||
(if core 'sb-di::make-core-debug-source 'make-debug-source)
|
||
:namestring (or *source-namestring*
|
||
(make-file-info-namestring
|
||
(let ((pathname
|
||
(case *name-context-file-path-selector*
|
||
(pathname (file-info-pathname file-info))
|
||
(truename (file-info-truename file-info)))))
|
||
(if (pathnamep pathname) pathname))
|
||
file-info))
|
||
:created
|
||
#+sb-xc-host (file-info-write-date file-info)
|
||
#-sb-xc-host (let ((source-date-epoch (posix-getenv "SOURCE_DATE_EPOCH"))
|
||
(file-write-date (file-info-write-date file-info)))
|
||
(if source-date-epoch
|
||
(multiple-value-bind (val end)
|
||
(parse-integer source-date-epoch :junk-allowed t)
|
||
(if (and (= end (length source-date-epoch))
|
||
(and val file-write-date)
|
||
(< (+ val unix-to-universal-time) file-write-date))
|
||
(+ val unix-to-universal-time)
|
||
file-write-date))
|
||
file-write-date))
|
||
:start-positions (coerce-to-smallest-eltype
|
||
(file-info-positions file-info))
|
||
(if core
|
||
(values :form (let ((direct-file-info (source-info-file-info info)))
|
||
(when (eq :lisp (file-info-%truename direct-file-info))
|
||
(elt (file-info-forms direct-file-info) 0))))
|
||
(values)))))
|
||
|
||
(defun smallest-element-type (integer negative)
|
||
(let ((bits (max (+ (integer-length integer)
|
||
(if negative 1 0))
|
||
8)))
|
||
(list (if negative
|
||
'signed-byte
|
||
'unsigned-byte)
|
||
(if (= (logcount bits) 1) ;; power of two?
|
||
bits
|
||
;; Next power of two
|
||
(ash 1 (integer-length bits))))))
|
||
|
||
;;; Given an arbitrary sequence, coerce it to an unsigned vector if
|
||
;;; possible. Ordinarily we coerce it to the smallest specialized
|
||
;;; vector we can.
|
||
;;; During cross-compilation the in-memory representation is opaque -
|
||
;;; we don't care how it looks, but can recover the intended specialization.
|
||
(defun coerce-to-smallest-eltype (seq)
|
||
(declare (type sequence seq))
|
||
;; Silence "Clause CHARACTER is shadowed by BASE-CHAR" depending on +/-unicode of host+target
|
||
#+host-quirks-sbcl (declare (host-sb-ext:muffle-conditions style-warning))
|
||
(let ((max-positive 0)
|
||
(max-negative 0)
|
||
(length 0)
|
||
(character t))
|
||
(labels ((t-vector ()
|
||
(return-from coerce-to-smallest-eltype
|
||
(logically-readonlyize
|
||
(coerce seq 'simple-vector))))
|
||
(frob (x)
|
||
(typecase x
|
||
((integer 0)
|
||
(when character
|
||
(unless (eq character t)
|
||
(t-vector))
|
||
(setf character nil))
|
||
(when (>= x max-positive)
|
||
(setf max-positive x)))
|
||
((integer * -1)
|
||
(when character
|
||
(unless (eq character t)
|
||
(t-vector))
|
||
(setf character nil))
|
||
(setf character nil)
|
||
(let ((abs (- x)))
|
||
(when (>= abs max-negative)
|
||
(setf max-negative abs))))
|
||
#+sb-unicode
|
||
(base-char
|
||
(unless character
|
||
(t-vector))
|
||
(when (eq character t)
|
||
(setf character 'base-char)))
|
||
(character
|
||
(unless character
|
||
(t-vector))
|
||
(setf character 'character))
|
||
(t
|
||
(t-vector)))))
|
||
(if (listp seq)
|
||
(dolist (i seq)
|
||
(incf length) ; so not to traverse again to compute it
|
||
(frob i))
|
||
(dovector (i seq (setq length (length seq)))
|
||
(frob i)))
|
||
(if (zerop length)
|
||
#()
|
||
(logically-readonlyize
|
||
(coerce seq
|
||
`(simple-array
|
||
,(or character
|
||
(smallest-element-type (max max-positive
|
||
(1- max-negative))
|
||
(plusp max-negative)))
|
||
1)))))))
|
||
|
||
(defun compact-vector (sequence)
|
||
(cond ((and (= (length sequence) 1)
|
||
(not (typep (elt sequence 0) '(and vector (not string)))))
|
||
(elt sequence 0))
|
||
(t
|
||
(coerce-to-smallest-eltype sequence))))
|
||
|
||
;;;; variables
|
||
|
||
;;; Return a SC+OFFSET describing TN's location.
|
||
(defun tn-sc+offset (tn)
|
||
(declare (type tn tn))
|
||
(make-sc+offset (sc-number (tn-sc tn))
|
||
(tn-offset tn)))
|
||
|
||
(defvar *previous-package*)
|
||
|
||
;;; Dump info to represent VAR's location being TN. ID is an integer
|
||
;;; that makes VAR's name unique in the function. BUFFER is the vector
|
||
;;; we stick the result in. If MINIMAL, we suppress name dumping, and
|
||
;;; set the minimal flag.
|
||
;;;
|
||
;;; The DEBUG-VAR is only marked as always-live if the TN is
|
||
;;; environment live and is an argument. If a :DEBUG-ENVIRONMENT TN,
|
||
;;; then we also exclude set variables, since the variable is not
|
||
;;; guaranteed to be live everywhere in that case.
|
||
;;;
|
||
;;; This is read by sb-di::parse-compiled-debug-vars
|
||
(defun dump-1-var (fun var tn minimal buffer &optional name same-name-p)
|
||
(declare (type lambda-var var) (type (or tn null) tn)
|
||
(type clambda fun))
|
||
(let* ((package (sb-xc:symbol-package name))
|
||
(package-p (and package (not (eq package *package*))))
|
||
(save-tn (and tn (tn-save-tn tn)))
|
||
(kind (and tn (tn-kind tn)))
|
||
(flags 0)
|
||
(indirect (and (lambda-var-indirect var)
|
||
(not (lambda-var-explicit-value-cell var))
|
||
(neq (lambda-environment fun)
|
||
(lambda-environment (lambda-var-home var))))))
|
||
(declare (type (and sb-xc:fixnum unsigned-byte) flags))
|
||
(let ((info (lambda-var-arg-info var)))
|
||
;; &more vars need no name
|
||
(when (and info
|
||
(memq (arg-info-kind info)
|
||
'(:more-context :more-count)))
|
||
(setq minimal t)))
|
||
(cond (minimal
|
||
(setq flags (logior flags compiled-debug-var-minimal-p))
|
||
(unless (and tn (tn-offset tn))
|
||
(setq flags (logior flags compiled-debug-var-deleted-p))))
|
||
(same-name-p
|
||
(setq flags (logior flags compiled-debug-var-same-name-p)))
|
||
((not package)
|
||
(setq flags (logior flags compiled-debug-var-uninterned)))
|
||
(package-p
|
||
(setq flags (logior flags compiled-debug-var-packaged))
|
||
(cond ((eq package *previous-package*)
|
||
(setf flags (logior flags compiled-debug-var-same-name-p)) ;; overloaded
|
||
(setf package-p nil))
|
||
;; Write a packe-id integer
|
||
((or (eq package *cl-package*)
|
||
(system-package-p package))
|
||
(let ((id (sb-impl::package-id package)))
|
||
(when (< id sb-impl::+last-stable-package-id+) ;; exclude contribs
|
||
(setf package-p id)))))))
|
||
(when (and (or (eq kind :environment)
|
||
(and (eq kind :debug-environment)
|
||
(null (basic-var-sets var))))
|
||
(not (gethash tn (ir2-component-spilled-tns
|
||
(component-info *component-being-compiled*))))
|
||
(or (eq (lambda-var-home var) fun)
|
||
(member var (environment-closure (lambda-environment fun))))
|
||
(not (optional-leaf-p var))) ;; not always initialized
|
||
(setq flags (logior flags compiled-debug-var-environment-live)))
|
||
(when save-tn
|
||
(setq flags (logior flags compiled-debug-var-save-loc-p)))
|
||
(when indirect
|
||
(setq flags (logior flags compiled-debug-var-indirect-p)))
|
||
(when (integerp package-p)
|
||
(setf flags (logior flags compiled-debug-var-uninterned)))
|
||
(vector-push-extend flags buffer)
|
||
(unless (or minimal same-name-p)
|
||
(write-var-string (symbol-name name) buffer)
|
||
(when package-p
|
||
(if (integerp package-p)
|
||
(vector-push-extend package-p buffer)
|
||
(write-var-string (sb-xc:package-name package) buffer))
|
||
(setf *previous-package* package)))
|
||
|
||
(cond (indirect
|
||
;; Indirect variables live in the parent frame, and are
|
||
;; accessed through a saved frame pointer.
|
||
;; The first one/two sc-offsets are for the frame pointer,
|
||
;; the third is for the stack offset.
|
||
(write-var-integer (tn-sc+offset tn) buffer)
|
||
(when save-tn
|
||
(write-var-integer (tn-sc+offset save-tn) buffer))
|
||
(write-var-integer (tn-sc+offset (leaf-info var)) buffer))
|
||
(t
|
||
(if (and tn (tn-offset tn))
|
||
(write-var-integer (tn-sc+offset tn) buffer)
|
||
(aver minimal))
|
||
(when save-tn
|
||
(write-var-integer (tn-sc+offset save-tn) buffer)))))
|
||
(values))
|
||
|
||
(defun leaf-principal-name (leaf)
|
||
;; If all the references are from the same substituted variable
|
||
;; use its name.
|
||
;; Helps with &key processing variables.
|
||
(let ((refs (leaf-refs leaf)))
|
||
(loop for ref in refs
|
||
for name = (ref-%source-name ref)
|
||
for first-name = name then first-name
|
||
unless (eq name first-name)
|
||
return (leaf-debug-name leaf)
|
||
finally (return name))))
|
||
|
||
;;; Return a vector suitable for use as the DEBUG-FUN-VARS
|
||
;;; of FUN. LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a
|
||
;;; 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-vars (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-principal-name leaf)))
|
||
(when (and name (leaf-refs leaf) (tn-offset tn)
|
||
(or gensym-p (cl:symbol-package name)))
|
||
(vars (list* name leaf tn)))))
|
||
(frob-lambda (x gensym-p)
|
||
(dolist (leaf (lambda-vars x))
|
||
(frob-leaf leaf (leaf-info leaf) gensym-p))))
|
||
(frob-lambda fun t)
|
||
(when (>= level 1)
|
||
(dolist (x (ir2-environment-closure (environment-info (lambda-environment fun))))
|
||
(let ((thing (car x)))
|
||
(when (lambda-var-p thing)
|
||
(frob-leaf thing (cdr x) (>= level 2)))))
|
||
|
||
(dolist (let (lambda-lets fun))
|
||
(frob-lambda let (>= level 2)))))
|
||
|
||
(setf (fill-pointer *byte-buffer*) 0)
|
||
(let ((sorted (stable-sort
|
||
(sort (vars) #'string<
|
||
:key (lambda (x)
|
||
(symbol-name (car x))))
|
||
#'string<
|
||
:key (lambda (x)
|
||
(let ((package (sb-xc:symbol-package (car x))))
|
||
(when package
|
||
(sb-xc:package-name package))))))
|
||
(prev-name nil)
|
||
(i 0)
|
||
;; XEPs don't have any useful variables
|
||
(minimal (functional-kind-eq fun external))
|
||
*previous-package*)
|
||
(declare (type index i))
|
||
(loop for (name var . tn) in sorted
|
||
do
|
||
(dump-1-var fun var tn minimal *byte-buffer*
|
||
name
|
||
(and prev-name (eq prev-name name)))
|
||
(setf prev-name name)
|
||
(setf (gethash var var-locs) i)
|
||
(incf i))
|
||
(copy-seq *byte-buffer*))))
|
||
|
||
;;; Return a vector suitable for use as the DEBUG-FUN-VARS of
|
||
;;; FUN, representing the arguments to FUN in minimal variable format.
|
||
(defun compute-minimal-vars (fun)
|
||
(declare (type clambda fun))
|
||
(setf (fill-pointer *byte-buffer*) 0)
|
||
(dolist (var (lambda-vars fun))
|
||
(dump-1-var fun var (leaf-info var) t *byte-buffer*))
|
||
(copy-seq *byte-buffer*))
|
||
|
||
;;; 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)))
|
||
(cond (res)
|
||
(t
|
||
(aver (or (null (leaf-refs var))
|
||
(not (tn-offset (leaf-info var)))))
|
||
'deleted))))
|
||
|
||
;;;; arguments/returns
|
||
|
||
;;; Return a vector to be used as the COMPILED-DEBUG-FUN-ARGS for FUN.
|
||
;;; If FUN is the MAIN-ENTRY for an optional dispatch, then look at
|
||
;;; the ARGLIST to determine the syntax, otherwise pretend all
|
||
;;; arguments are fixed.
|
||
;;;
|
||
;;; ### This assumption breaks down in EPs other than the main-entry,
|
||
;;; since they may or may not have supplied-p vars, etc.
|
||
(defun compute-args (fun var-locs)
|
||
(declare (type clambda fun) (type hash-table var-locs))
|
||
(collect ((res))
|
||
(let ((od (lambda-optional-dispatch fun)))
|
||
(if (and od (eq (optional-dispatch-main-entry od) fun))
|
||
(let ((actual-vars (lambda-vars fun))
|
||
(saw-optional nil))
|
||
(labels ((one-arg (arg)
|
||
(let ((info (lambda-var-arg-info arg))
|
||
(actual (pop actual-vars)))
|
||
(cond (info
|
||
(case (arg-info-kind info)
|
||
(:keyword
|
||
(res (arg-info-key info)))
|
||
(:rest
|
||
(let ((more (arg-info-default info)))
|
||
(cond ((and (consp more) (third more))
|
||
(one-arg (first (arg-info-default info)))
|
||
(one-arg (second (arg-info-default info)))
|
||
(return-from one-arg))
|
||
(more
|
||
(setf (arg-info-default info) t)))
|
||
(res 'rest-arg)))
|
||
(:more-context
|
||
(res 'more-arg))
|
||
(:optional
|
||
(unless saw-optional
|
||
(res 'optional-args)
|
||
(setq saw-optional t))))
|
||
(res (debug-location-for actual var-locs))
|
||
(when (arg-info-supplied-p info)
|
||
(res 'supplied-p)
|
||
(res (debug-location-for (pop actual-vars) var-locs))))
|
||
(t
|
||
(res (debug-location-for actual var-locs)))))))
|
||
(dolist (arg (optional-dispatch-arglist od))
|
||
(one-arg arg))))
|
||
(dolist (var (lambda-vars fun))
|
||
(res (debug-location-for var var-locs)))))
|
||
|
||
(coerce-to-smallest-eltype (res))))
|
||
|
||
;;; Return a vector of SC offsets describing FUN's return locations.
|
||
;;; (Must be known values return...)
|
||
(defun compute-debug-returns (fun)
|
||
(coerce-to-smallest-eltype
|
||
(mapcar #'tn-sc+offset
|
||
(return-info-locations (tail-set-info (lambda-tail-set fun))))))
|
||
|
||
;;;; debug functions
|
||
|
||
;;; Return a C-D-F structure with all the mandatory slots filled in.
|
||
(defun dfun-from-fun (fun)
|
||
(declare (type clambda fun))
|
||
(let* ((2env (environment-info (lambda-environment fun)))
|
||
(dispatch (lambda-optional-dispatch fun))
|
||
(main-p (and dispatch
|
||
(eq fun (optional-dispatch-main-entry dispatch))))
|
||
(kind (if main-p nil (ecase (functional-kind fun)
|
||
(#.(functional-kind-attributes nil) nil)
|
||
(#.(functional-kind-attributes optional) :optional)
|
||
(#.(functional-kind-attributes external) :external)
|
||
(#.(functional-kind-attributes toplevel) :toplevel)
|
||
(#.(functional-kind-attributes cleanup) :cleanup))))
|
||
(name (leaf-debug-name fun))
|
||
(name (if (consp name)
|
||
(case (car name)
|
||
((xep)
|
||
(aver (eql kind :external))
|
||
(second name))
|
||
(&optional-processor
|
||
(setf kind :optional)
|
||
(second name))
|
||
(&more-processor
|
||
(setf kind :more)
|
||
(second name))
|
||
(t
|
||
name))
|
||
name)))
|
||
(make-compiled-debug-fun
|
||
:name name
|
||
:kind kind
|
||
#-fp-and-pc-standard-save :return-pc
|
||
#-fp-and-pc-standard-save (tn-sc+offset (ir2-environment-return-pc 2env))
|
||
#-fp-and-pc-standard-save :return-pc-pass
|
||
#-fp-and-pc-standard-save (tn-sc+offset (ir2-environment-return-pc-pass 2env))
|
||
#-fp-and-pc-standard-save :old-fp
|
||
#-fp-and-pc-standard-save (tn-sc+offset (ir2-environment-old-fp 2env))
|
||
#-fp-and-pc-standard-save :lra-saved-pc
|
||
#-fp-and-pc-standard-save (label-position (ir2-environment-lra-saved-pc 2env))
|
||
#-fp-and-pc-standard-save :cfp-saved-pc
|
||
#-fp-and-pc-standard-save (label-position (ir2-environment-cfp-saved-pc 2env))
|
||
:closure-save
|
||
(when (ir2-environment-closure-save-tn 2env)
|
||
(tn-sc+offset (ir2-environment-closure-save-tn 2env)))
|
||
#+unwind-to-frame-and-call-vop :bsp-save
|
||
#+unwind-to-frame-and-call-vop
|
||
(when (ir2-environment-bsp-save-tn 2env)
|
||
(tn-sc+offset (ir2-environment-bsp-save-tn 2env)))
|
||
:start-pc
|
||
(label-position (ir2-environment-environment-start 2env))
|
||
:elsewhere-pc
|
||
(label-position (ir2-environment-elsewhere-start 2env)))))
|
||
|
||
;;; 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 elsewhere-label)
|
||
(declare (type clambda fun) (type hash-table var-locs))
|
||
(let* ((dfun (dfun-from-fun fun))
|
||
(actual-level (policy (lambda-bind fun) compute-debug-fun))
|
||
(level (cond #+sb-dyncount
|
||
(*collect-dynamic-statistics*
|
||
(max actual-level 2))
|
||
(actual-level))))
|
||
(cond ((or (and (zerop level)
|
||
(let ((od (lambda-optional-dispatch fun)))
|
||
(or (not od)
|
||
(not (eq (optional-dispatch-main-entry od) fun)))))
|
||
(eq (compiled-debug-fun-kind dfun) :more))
|
||
(setf (compiled-debug-fun-vars dfun)
|
||
(compute-minimal-vars fun))
|
||
(setf (compiled-debug-fun-arguments dfun) :minimal))
|
||
(t
|
||
(setf (compiled-debug-fun-vars dfun)
|
||
(compute-vars fun level var-locs))
|
||
(setf (compiled-debug-fun-arguments dfun)
|
||
(compute-args fun var-locs))))
|
||
|
||
(if (>= level 1)
|
||
(multiple-value-bind (blocks tlf-num)
|
||
(compute-debug-blocks fun var-locs elsewhere-label)
|
||
(setf (compiled-debug-fun-blocks dfun) blocks
|
||
(compiled-debug-fun-tlf-number dfun) tlf-num))
|
||
(setf (compiled-debug-fun-tlf-number dfun) (find-tlf-number fun)))
|
||
|
||
(if (xep-p fun)
|
||
(setf (compiled-debug-fun-returns dfun) :standard)
|
||
(let ((info (tail-set-info (lambda-tail-set fun))))
|
||
(when info
|
||
(cond ((eq (return-info-kind info) :unknown)
|
||
(setf (compiled-debug-fun-returns dfun)
|
||
:standard))
|
||
((eq (return-info-kind info) :unboxed))
|
||
((/= level 0)
|
||
(setf (compiled-debug-fun-returns dfun)
|
||
(compute-debug-returns fun)))))))
|
||
dfun))
|
||
|
||
|
||
;;;; Packed debug functions:
|
||
|
||
;;; 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-packed-dfun (dfun prev-start start prev-elsewhere)
|
||
(declare (type compiled-debug-fun dfun)
|
||
(type index prev-start start prev-elsewhere)
|
||
(special *debug-component-name*))
|
||
(let* ((name (compiled-debug-fun-name dfun))
|
||
(same-name-p (eq name
|
||
*debug-component-name*)))
|
||
(let ((options 0))
|
||
(setf (ldb packed-debug-fun-kind-byte options)
|
||
(position-or-lose (compiled-debug-fun-kind dfun)
|
||
packed-debug-fun-kinds))
|
||
(setf (ldb packed-debug-fun-returns-byte options)
|
||
(etypecase (compiled-debug-fun-returns dfun)
|
||
((member :standard) packed-debug-fun-returns-standard)
|
||
((member :fixed) packed-debug-fun-returns-fixed)
|
||
(vector packed-debug-fun-returns-specified)))
|
||
(vector-push-extend options *byte-buffer*))
|
||
|
||
(let ((flags 0))
|
||
(when (compiled-debug-fun-vars dfun)
|
||
(setq flags (logior flags packed-debug-fun-variables-bit)))
|
||
(when (compiled-debug-fun-blocks dfun)
|
||
(setq flags (logior flags packed-debug-fun-blocks-bit)))
|
||
(when (compiled-debug-fun-tlf-number dfun)
|
||
(setq flags (logior flags packed-debug-fun-tlf-number-bit)))
|
||
(unless (memq (compiled-debug-fun-arguments dfun) '(nil :minimal))
|
||
(setq flags (logior flags packed-debug-fun-non-minimal-arguments-bit)))
|
||
(when (compiled-debug-fun-closure-save dfun)
|
||
(setq flags (logior flags packed-debug-fun-closure-save-loc-bit)))
|
||
#+unwind-to-frame-and-call-vop
|
||
(when (compiled-debug-fun-bsp-save dfun)
|
||
(setq flags (logior flags packed-debug-fun-bsp-save-loc-bit)))
|
||
(when same-name-p
|
||
(setq flags (logior flags packed-debug-fun-previous-name)))
|
||
(vector-push-extend flags *byte-buffer*))
|
||
(unless same-name-p
|
||
(setf *debug-component-name* name)
|
||
(write-var-integer (or (position name *contexts* :test #'equal)
|
||
(vector-push-extend name *contexts*))
|
||
*byte-buffer*))
|
||
|
||
(let ((vars (compiled-debug-fun-vars 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 ((blocks (compiled-debug-fun-blocks dfun)))
|
||
(when blocks
|
||
(let ((len (length blocks)))
|
||
(write-var-integer len *byte-buffer*)
|
||
(dotimes (i len)
|
||
(vector-push-extend (mask-field (byte 8 0) (aref blocks i))
|
||
*byte-buffer*)))))
|
||
|
||
(when (compiled-debug-fun-tlf-number dfun)
|
||
(write-var-integer (compiled-debug-fun-tlf-number dfun)
|
||
*byte-buffer*))
|
||
|
||
(let ((arguments (compiled-debug-fun-arguments dfun)))
|
||
(unless (memq arguments '(nil :minimal))
|
||
(let ((len (length arguments)))
|
||
(write-var-integer len *byte-buffer*)
|
||
(dotimes (i len)
|
||
(let ((argument (aref arguments i)))
|
||
(case argument
|
||
(deleted
|
||
(write-var-integer packed-debug-fun-arg-deleted
|
||
*byte-buffer*))
|
||
(supplied-p
|
||
(write-var-integer packed-debug-fun-arg-supplied-p
|
||
*byte-buffer*))
|
||
(optional
|
||
(write-var-integer packed-debug-fun-arg-optional
|
||
*byte-buffer*))
|
||
(rest
|
||
(write-var-integer packed-debug-fun-arg-rest
|
||
*byte-buffer*))
|
||
(more
|
||
(write-var-integer packed-debug-fun-arg-more
|
||
*byte-buffer*))
|
||
(otherwise
|
||
(cond ((integerp argument)
|
||
(write-var-integer (+ argument
|
||
packed-debug-fun-arg-index-offset)
|
||
*byte-buffer*))
|
||
((keywordp argument)
|
||
(write-var-integer packed-debug-fun-key-arg-keyword
|
||
*byte-buffer*)
|
||
(write-var-string (symbol-name argument)
|
||
*byte-buffer*))
|
||
((sb-xc:symbol-package argument)
|
||
(write-var-integer packed-debug-fun-key-arg-packaged
|
||
*byte-buffer*)
|
||
(write-var-string (symbol-name argument)
|
||
*byte-buffer*)
|
||
(write-var-string (sb-xc:package-name
|
||
(sb-xc:symbol-package argument))
|
||
*byte-buffer*))
|
||
(t
|
||
(write-var-integer packed-debug-fun-key-arg-uninterned
|
||
*byte-buffer*)
|
||
(write-var-string (symbol-name argument)
|
||
*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*)))))
|
||
|
||
#-fp-and-pc-standard-save
|
||
(progn
|
||
(write-var-integer (compiled-debug-fun-return-pc dfun)
|
||
*byte-buffer*)
|
||
(write-var-integer (compiled-debug-fun-return-pc-pass dfun)
|
||
*byte-buffer*)
|
||
(write-var-integer (compiled-debug-fun-old-fp dfun)
|
||
*byte-buffer*)
|
||
(write-var-integer (compiled-debug-fun-lra-saved-pc dfun)
|
||
*byte-buffer*)
|
||
(write-var-integer (compiled-debug-fun-cfp-saved-pc dfun)
|
||
*byte-buffer*))
|
||
(when (compiled-debug-fun-closure-save dfun)
|
||
(write-var-integer (compiled-debug-fun-closure-save dfun)
|
||
*byte-buffer*))
|
||
#+unwind-to-frame-and-call-vop
|
||
(when (compiled-debug-fun-bsp-save dfun)
|
||
(write-var-integer (compiled-debug-fun-bsp-save 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 PACKED-DEBUG-FUN format.
|
||
(defun compute-packed-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-packed-dfun (cdr dfun) prev-start start prev-elsewhere)
|
||
(setq prev-start start prev-elsewhere elsewhere))))
|
||
(logically-readonlyize (compress *byte-buffer*)))
|
||
|
||
|
||
;;;; full component dumping
|
||
|
||
(defun empty-fun-p (fun)
|
||
(let* ((2block (block-info (lambda-block fun)))
|
||
(start (ir2-block-start-vop 2block))
|
||
(next (ir2-block-next 2block)))
|
||
(and
|
||
start
|
||
(eq start (ir2-block-last-vop 2block))
|
||
(eq (vop-name start) 'note-environment-start)
|
||
next
|
||
(neq (ir2-block-environment 2block)
|
||
(ir2-block-environment next)))))
|
||
|
||
;;; Return a DEBUG-INFO structure describing COMPONENT. This has to be
|
||
;;; called after assembly so that source map information is available.
|
||
(defun debug-info-for-component (component assembly)
|
||
(declare (type component component))
|
||
(flet ((lambda-position (lambda)
|
||
(let ((2block (block-info (lambda-block lambda))))
|
||
(label-position (or (ir2-block-%trampoline-label 2block)
|
||
(ir2-block-%label 2block))))))
|
||
(let* ((dfuns nil)
|
||
(simple-fun-headers
|
||
;; Compute all simple-fun metadata and store into a simple-vector
|
||
(let* ((entries (ir2-component-entries (component-info component)))
|
||
(nfuns (length entries))
|
||
(i (* sb-vm:code-slots-per-simple-fun nfuns))
|
||
(v (make-array i)))
|
||
(dolist (e entries v)
|
||
;; Process in reverse order of ENTRIES.
|
||
(decf i sb-vm:code-slots-per-simple-fun)
|
||
(setf (svref v (+ i sb-vm:simple-fun-name-slot)) (entry-info-name e)
|
||
(svref v (+ i sb-vm:simple-fun-arglist-slot)) (entry-info-arguments e)
|
||
(svref v (+ i sb-vm:simple-fun-source-slot)) (entry-info-form/doc e)
|
||
(svref v (+ i sb-vm:simple-fun-info-slot)) (entry-info-type/xref e)))))
|
||
(var-locs (make-hash-table :test 'eq))
|
||
(*byte-buffer* (make-array 10
|
||
:element-type '(unsigned-byte 8)
|
||
:fill-pointer 0
|
||
:adjustable t))
|
||
(*contexts* (make-array 10
|
||
:fill-pointer 0
|
||
:adjustable t))
|
||
(lambdas (sort (copy-list (component-lambdas component))
|
||
#'<
|
||
:key #'lambda-position))
|
||
(name (loop for lambda in lambdas
|
||
for entry = (leaf-info lambda)
|
||
when entry
|
||
return
|
||
(entry-info-name entry)))
|
||
(*debug-component-name* name))
|
||
(declare (special *debug-component-name*))
|
||
(dolist (lambda lambdas)
|
||
(unless (empty-fun-p lambda)
|
||
(clrhash var-locs)
|
||
(push (cons (lambda-position lambda)
|
||
(compute-1-debug-fun lambda var-locs (asm-elsewhere-label assembly)))
|
||
dfuns)))
|
||
(let ((map (compute-packed-debug-funs (nreverse dfuns)))
|
||
(eh-locs (awhen (asm-eh-locs assembly)
|
||
(logically-readonlyize
|
||
(sb-xc:coerce it '(simple-array (unsigned-byte 32) 1)))))
|
||
(contexts (compact-vector *contexts*)))
|
||
#+sb-xc-host
|
||
(!make-compiled-debug-info name eh-locs *package* map contexts simple-fun-headers)
|
||
#-sb-xc-host
|
||
(let ((di (%make-instance (+ (1- (sb-kernel::type-dd-length compiled-debug-info))
|
||
(length simple-fun-headers)))))
|
||
(setf (%instance-layout di) #.(find-layout 'compiled-debug-info)
|
||
;; The fixed slots except for SOURCE are declared readonly
|
||
(%instance-ref di (get-dsd-index compiled-debug-info name)) name
|
||
(%instance-ref di (get-dsd-index compiled-debug-info source)) nil
|
||
(%instance-ref di (get-dsd-index compiled-debug-info eh-locs)) eh-locs
|
||
(%instance-ref di (get-dsd-index compiled-debug-info package)) *package*
|
||
(%instance-ref di (get-dsd-index compiled-debug-info fun-map)) map
|
||
(%instance-ref di (get-dsd-index compiled-debug-info contexts)) contexts)
|
||
(let ((i (get-dsd-index compiled-debug-info rest)))
|
||
(dovector (x simple-fun-headers di)
|
||
(setf (%instance-ref di i) x)
|
||
(incf i))))))))
|
||
|
||
;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of
|
||
;;; BITS must be evenly divisible by eight.
|
||
(defun write-packed-bit-vector (bits byte-buffer)
|
||
(declare (type simple-bit-vector bits) (type byte-buffer byte-buffer))
|
||
|
||
;; Enforce constraint from CMU-CL-era comment.
|
||
(aver (zerop (mod (length bits) 8)))
|
||
|
||
(multiple-value-bind (initial step done)
|
||
(ecase *backend-byte-order*
|
||
(:little-endian (values 0 1 8))
|
||
(:big-endian (values 7 -1 -1)))
|
||
(let ((shift initial)
|
||
(byte 0))
|
||
(dotimes (i (length bits))
|
||
(let ((int (aref bits i)))
|
||
(setf byte (logior byte (ash int shift)))
|
||
(incf shift step))
|
||
(when (= shift done)
|
||
(vector-push-extend byte byte-buffer)
|
||
(setf shift initial
|
||
byte 0)))
|
||
(unless (= shift initial)
|
||
(vector-push-extend byte byte-buffer))))
|
||
(values))
|
||
|
||
(declaim (ftype (sfunction ((and byte-buffer (not simple-array)))
|
||
(or (simple-array (unsigned-byte 8) 1)
|
||
(simple-array (signed-byte 8) 1)))
|
||
compress)
|
||
(ftype (sfunction ((or (simple-array (unsigned-byte 8) 1)
|
||
(simple-array (signed-byte 8) 1)))
|
||
(simple-array (unsigned-byte 8) 1))
|
||
decompress))
|
||
|
||
#-(and sb-core-compression (not sb-xc-host))
|
||
(progn
|
||
(defun compress (vector)
|
||
#-sb-xc-host (%shrink-vector (%array-data vector) (length vector))
|
||
#+sb-xc-host (coerce vector '(simple-array (unsigned-byte 8) 1)))
|
||
|
||
(defun decompress (vector)
|
||
vector))
|
||
|
||
#+(and sb-core-compression (not sb-xc-host))
|
||
(progn
|
||
(defun compress (vector)
|
||
(let ((backing (truly-the (simple-array * (*)) (%array-data vector))))
|
||
(with-pinned-objects (backing)
|
||
(with-alien ((compress-vector (function int unsigned size-t) :extern))
|
||
(alien-funcall compress-vector (get-lisp-obj-address backing) (length vector)))
|
||
backing)))
|
||
|
||
(defun decompress (vector)
|
||
(declare (sb-c::tlab :system))
|
||
(if (typep vector '(simple-array (signed-byte 8) (*)))
|
||
(with-alien ((decompress-vector (function int unsigned int system-area-pointer int) :extern))
|
||
(with-pinned-objects (vector)
|
||
(binding* ((sap (vector-sap vector))
|
||
((preamble skip) (sap-read-var-integer sap 0)) ; preamble = uncompressed size
|
||
(output (make-array preamble :element-type '(unsigned-byte 8))))
|
||
(with-pinned-objects (output)
|
||
(alien-funcall decompress-vector
|
||
(get-lisp-obj-address vector) skip
|
||
(vector-sap output) preamble))
|
||
output)))
|
||
vector)))
|