1;;;; stuff that creates debugger information from the compiler's 2;;;; internal data structures 3 4;;;; This software is part of the SBCL system. See the README file for 5;;;; more information. 6;;;; 7;;;; This software is derived from the CMU CL system, which was 8;;;; written at Carnegie Mellon University and released into the 9;;;; public domain. The software is in the public domain and is 10;;;; provided with absolutely no warranty. See the COPYING and CREDITS 11;;;; files for more information. 12 13(in-package "SB!C") 14 15(deftype byte-buffer () '(vector (unsigned-byte 8))) 16(defvar *byte-buffer*) 17(declaim (type byte-buffer *byte-buffer*)) 18 19;;;; debug blocks 20 21(deftype location-kind () 22 '(member :unknown-return :known-return :internal-error :non-local-exit 23 :block-start :call-site :single-value-return :non-local-entry 24 :step-before-vop)) 25 26;;; The LOCATION-INFO structure holds the information what we need 27;;; about locations which code generation decided were "interesting". 28(defstruct (location-info 29 (:constructor make-location-info (kind label vop)) 30 (:copier nil)) 31 ;; The kind of location noted. 32 (kind nil :type location-kind) 33 ;; The label pointing to the interesting code location. 34 (label nil :type (or label index null)) 35 ;; The VOP that emitted this location (for node, save-set, ir2-block, etc.) 36 (vop nil :type vop)) 37 38;;; This is called during code generation in places where there is an 39;;; "interesting" location: someplace where we are likely to end up 40;;; in the debugger, and thus want debug info. 41(defun note-debug-location (vop label kind) 42 (declare (type vop vop) (type (or label null) label) 43 (type location-kind kind)) 44 (let ((location (make-location-info kind label vop))) 45 (setf (ir2-block-locations (vop-block vop)) 46 (nconc (ir2-block-locations (vop-block vop)) 47 (list location))) 48 location)) 49 50#!-sb-fluid (declaim (inline ir2-block-physenv)) 51(defun ir2-block-physenv (2block) 52 (declare (type ir2-block 2block)) 53 (block-physenv (ir2-block-block 2block))) 54 55(defun make-lexenv-var-cache (lexenv) 56 (or (lexenv-var-cache lexenv) 57 (let ((cache (make-hash-table :test #'eq))) 58 (labels ((populate (lexenv) 59 (loop for (nil . var) in (lexenv-vars lexenv) 60 when (lambda-var-p var) 61 do (setf (gethash var cache) t)) 62 (let* ((lambda (lexenv-lambda lexenv)) 63 (call-lexenv (and lambda 64 (lambda-call-lexenv lambda)))) 65 (cond ((not call-lexenv)) 66 ((lexenv-var-cache call-lexenv) 67 (loop for var being each hash-key of (lexenv-var-cache call-lexenv) 68 do (setf (gethash var cache) t))) 69 (t 70 (populate call-lexenv)))))) 71 (populate lexenv)) 72 (setf (lexenv-var-cache lexenv) cache)))) 73 74(defun leaf-visible-to-debugger-p (leaf node) 75 (gethash leaf (make-lexenv-var-cache (node-lexenv node)))) 76 77;;; Given a local conflicts vector and an IR2 block to represent the 78;;; set of live TNs, and the VAR-LOCS hash-table representing the 79;;; variables dumped, compute a bit-vector representing the set of 80;;; live variables. If the TN is environment-live, we only mark it as 81;;; live when it is in scope at NODE. 82(defun compute-live-vars (live node block var-locs vop) 83 (declare (type ir2-block block) (type local-tn-bit-vector live) 84 (type hash-table var-locs) (type node node) 85 (type (or vop null) vop)) 86 (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7) 87 :element-type 'bit 88 :initial-element 0)) 89 (spilled (gethash vop 90 (ir2-component-spilled-vops 91 (component-info *component-being-compiled*))))) 92 (do-live-tns (tn live block) 93 (let ((leaf (tn-leaf tn))) 94 (when (and (lambda-var-p leaf) 95 (or (not (member (tn-kind tn) 96 '(:environment :debug-environment))) 97 (leaf-visible-to-debugger-p leaf node)) 98 (or (null spilled) 99 (not (member tn spilled)))) 100 (let ((num (gethash leaf var-locs))) 101 (when num 102 (setf (sbit res num) 1)))))) 103 res)) 104 105;;; The PC for the location most recently dumped. 106(defvar *previous-location*) 107(declaim (type index *previous-location*)) 108 109;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes 110;;; the code/source map and live info. If true, VOP is the VOP 111;;; associated with this location, for use in determining whether TNs 112;;; are spilled. 113(defun dump-1-location (node block kind tlf-num label live var-locs vop) 114 (declare (type node node) (type ir2-block block) 115 (type (or null local-tn-bit-vector) live) 116 (type (or label index) label) 117 (type location-kind kind) (type (or index null) tlf-num) 118 (type hash-table var-locs) (type (or vop null) vop)) 119 120 (let ((byte-buffer *byte-buffer*)) 121 (vector-push-extend 122 (position-or-lose kind *compiled-code-location-kinds*) 123 byte-buffer) 124 125 (let ((loc (if (fixnump label) label (label-position label)))) 126 (write-var-integer (- loc *previous-location*) byte-buffer) 127 (setq *previous-location* loc)) 128 129 (let ((path (node-source-path node))) 130 (unless tlf-num 131 (write-var-integer (source-path-tlf-number path) byte-buffer)) 132 (write-var-integer (source-path-form-number path) byte-buffer)) 133 134 (if live 135 (write-packed-bit-vector (compute-live-vars live node block var-locs vop) 136 byte-buffer) 137 (write-packed-bit-vector 138 (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7) 139 :initial-element 0 140 :element-type 'bit) 141 byte-buffer)) 142 143 (write-var-string (or (and (typep node 'combination) 144 (combination-step-info node)) 145 "") 146 byte-buffer)) 147 (values)) 148 149;;; Extract context info from a Location-Info structure and use it to 150;;; dump a compiled code-location. 151(defun dump-location-from-info (loc tlf-num var-locs) 152 (declare (type location-info loc) (type (or index null) tlf-num) 153 (type hash-table var-locs)) 154 (let ((vop (location-info-vop loc))) 155 (dump-1-location (vop-node vop) 156 (vop-block vop) 157 (location-info-kind loc) 158 tlf-num 159 (location-info-label loc) 160 (vop-save-set vop) 161 var-locs 162 vop)) 163 (values)) 164 165;;; Scan all the blocks, determining if all locations are in the same 166;;; TLF, and returning it or NIL. 167(defun find-tlf-number (fun) 168 (declare (type clambda fun)) 169 (let* ((source-path (node-source-path (lambda-bind fun))) 170 (res (source-path-tlf-number source-path))) 171 (declare (type (or index null) res)) 172 (do-physenv-ir2-blocks (2block (lambda-physenv fun)) 173 (let ((block (ir2-block-block 2block))) 174 (when (eq (block-info block) 2block) 175 (unless (eql (source-path-tlf-number 176 (node-source-path 177 (block-start-node block))) 178 res) 179 (setq res nil))) 180 181 (dolist (loc (ir2-block-locations 2block)) 182 (unless (eql (source-path-tlf-number 183 (node-source-path 184 (vop-node (location-info-vop loc)))) 185 res) 186 (setq res nil))))) 187 (values res (source-path-form-number source-path)))) 188 189;;; Dump out the number of locations and the locations for Block. 190(defun dump-block-locations (block locations tlf-num var-locs) 191 (declare (type cblock block) (list locations)) 192 (if (and locations 193 (eq (location-info-kind (first locations)) 194 :non-local-entry)) 195 (write-var-integer (length locations) *byte-buffer*) 196 (let ((2block (block-info block))) 197 (write-var-integer (+ (length locations) 1) *byte-buffer*) 198 (dump-1-location (block-start-node block) 199 2block :block-start tlf-num 200 (ir2-block-%label 2block) 201 (ir2-block-live-out 2block) 202 var-locs 203 nil))) 204 (dolist (loc locations) 205 (dump-location-from-info loc tlf-num var-locs)) 206 (values)) 207 208;;; Return a vector and an integer (or null) suitable for use as the 209;;; BLOCKS and TLF-NUMBER in FUN's DEBUG-FUN. 210(defun compute-debug-blocks (fun var-locs) 211 (declare (type clambda fun) (type hash-table var-locs)) 212 (multiple-value-bind (tlf-num form-number) (find-tlf-number fun) 213 (let ((*previous-location* 0) 214 (physenv (lambda-physenv fun)) 215 (byte-buffer *byte-buffer*) 216 prev-block 217 locations 218 elsewhere-locations) 219 (setf (fill-pointer byte-buffer) 0) 220 (do-physenv-ir2-blocks (2block physenv) 221 (let ((block (ir2-block-block 2block))) 222 (when (eq (block-info block) 2block) 223 (when prev-block 224 (dump-block-locations prev-block (nreverse (shiftf locations nil)) 225 tlf-num var-locs)) 226 (setf prev-block block))) 227 (dolist (loc (ir2-block-locations 2block)) 228 (if (label-elsewhere-p (location-info-label loc) 229 (location-info-kind loc)) 230 (push loc elsewhere-locations) 231 (push loc locations)))) 232 233 (dump-block-locations prev-block (nreverse locations) 234 tlf-num var-locs) 235 236 (when elsewhere-locations 237 (write-var-integer (length elsewhere-locations) byte-buffer) 238 (dolist (loc (nreverse elsewhere-locations)) 239 (push loc locations) 240 (dump-location-from-info loc tlf-num var-locs))) 241 242 (values (!make-specialized-array (length byte-buffer) '(unsigned-byte 8) 243 byte-buffer) 244 tlf-num form-number)))) 245 246;;; Return DEBUG-SOURCE structure containing information derived from 247;;; INFO. 248(defun debug-source-for-info (info &key function) 249 (declare (type source-info info)) 250 (let ((file-info (get-toplevelish-file-info info))) 251 (make-debug-source 252 :compiled (source-info-start-time info) 253 254 :namestring (or *source-namestring* 255 (make-file-info-namestring 256 (if (pathnamep (file-info-name file-info)) 257 (file-info-name file-info)) 258 file-info)) 259 :created (file-info-write-date file-info) 260 :start-positions (coerce-to-smallest-eltype 261 (file-info-positions file-info)) 262 263 :form (let ((direct-file-info (source-info-file-info info))) 264 (when (eq :lisp (file-info-name direct-file-info)) 265 (elt (file-info-forms direct-file-info) 0))) 266 :function function))) 267 268;;; Given an arbitrary sequence, coerce it to an unsigned vector if 269;;; possible. Ordinarily we coerce it to the smallest specialized 270;;; vector we can. 271;;; During cross-compilation the in-memory representation is opaque - 272;;; we don't care how it looks, but can recover the intended specialization. 273 274(defun coerce-to-smallest-eltype (seq) 275 (let ((maxoid 0) (length 0)) 276 (flet ((frob (x) 277 (if (typep x 'unsigned-byte) 278 (when (>= x maxoid) 279 (setf maxoid x)) 280 (return-from coerce-to-smallest-eltype 281 (coerce seq 'simple-vector))))) 282 (if (listp seq) 283 (dolist (i seq) 284 (incf length) ; so not to traverse again to compute it 285 (frob i)) 286 (dovector (i seq (setq length (length seq))) 287 (frob i))) 288 (let ((specializer (etypecase maxoid 289 ((unsigned-byte 8) '(unsigned-byte 8)) 290 ((unsigned-byte 16) '(unsigned-byte 16)) 291 ((unsigned-byte 32) '(unsigned-byte 32)) 292 ((unsigned-byte 64) '(unsigned-byte 64))))) 293 ;; formerly (coerce seq `(simple-array ,specializer (*))) 294 ;; plus a kludge for cross-compilation. This is nicer. 295 (!make-specialized-array length specializer seq))))) 296 297;;;; variables 298 299;;; Return a SC-OFFSET describing TN's location. 300(defun tn-sc-offset (tn) 301 (declare (type tn tn)) 302 (make-sc-offset (sc-number (tn-sc tn)) 303 (tn-offset tn))) 304 305(defun lambda-ancestor-p (maybe-ancestor maybe-descendant) 306 (declare (type clambda maybe-ancestor) 307 (type (or clambda null) maybe-descendant)) 308 (loop 309 (when (eq maybe-ancestor maybe-descendant) 310 (return t)) 311 (setf maybe-descendant (lambda-parent maybe-descendant)) 312 (when (null maybe-descendant) 313 (return nil)))) 314 315;;; Dump info to represent VAR's location being TN. ID is an integer 316;;; that makes VAR's name unique in the function. BUFFER is the vector 317;;; we stick the result in. If MINIMAL, we suppress name dumping, and 318;;; set the minimal flag. 319;;; 320;;; The DEBUG-VAR is only marked as always-live if the TN is 321;;; environment live and is an argument. If a :DEBUG-ENVIRONMENT TN, 322;;; then we also exclude set variables, since the variable is not 323;;; guaranteed to be live everywhere in that case. 324(defun dump-1-var (fun var tn id minimal buffer) 325 (declare (type lambda-var var) (type (or tn null) tn) (type index id) 326 (type clambda fun)) 327 (let* ((name (leaf-debug-name var)) 328 (save-tn (and tn (tn-save-tn tn))) 329 (kind (and tn (tn-kind tn))) 330 (flags 0) 331 (info (lambda-var-arg-info var)) 332 (indirect (and (lambda-var-indirect var) 333 (not (lambda-var-explicit-value-cell var)) 334 (neq (lambda-physenv fun) 335 (lambda-physenv (lambda-var-home var)))))) 336 (declare (type index flags)) 337 (when minimal 338 (setq flags (logior flags compiled-debug-var-minimal-p)) 339 (unless (and tn (tn-offset tn)) 340 (setq flags (logior flags compiled-debug-var-deleted-p)))) 341 (when (and (or (eq kind :environment) 342 (and (eq kind :debug-environment) 343 (null (basic-var-sets var)))) 344 (not (gethash tn (ir2-component-spilled-tns 345 (component-info *component-being-compiled*)))) 346 (lambda-ancestor-p (lambda-var-home var) fun)) 347 (setq flags (logior flags compiled-debug-var-environment-live))) 348 (when save-tn 349 (setq flags (logior flags compiled-debug-var-save-loc-p))) 350 (unless (or (zerop id) minimal) 351 (setq flags (logior flags compiled-debug-var-id-p))) 352 (when indirect 353 (setq flags (logior flags compiled-debug-var-indirect-p))) 354 (when info 355 (case (arg-info-kind info) 356 (:more-context 357 (setq flags (logior flags compiled-debug-var-more-context-p))) 358 (:more-count 359 (setq flags (logior flags compiled-debug-var-more-count-p))))) 360 #!+64-bit 361 (cond (indirect 362 (setf (ldb (byte 27 8) flags) (tn-sc-offset tn)) 363 (when save-tn 364 (setf (ldb (byte 27 35) flags) (tn-sc-offset save-tn)))) 365 (t 366 (if (and tn (tn-offset tn)) 367 (setf (ldb (byte 27 8) flags) (tn-sc-offset tn)) 368 (aver minimal)) 369 (when save-tn 370 (setf (ldb (byte 27 35) flags) (tn-sc-offset save-tn))))) 371 (vector-push-extend flags buffer) 372 (unless minimal 373 (vector-push-extend name buffer) 374 (unless (zerop id) 375 (vector-push-extend id buffer))) 376 377 (cond (indirect 378 ;; Indirect variables live in the parent frame, and are 379 ;; accessed through a saved frame pointer. 380 ;; The first one/two sc-offsets are for the frame pointer, 381 ;; the third is for the stack offset. 382 #!-64-bit 383 (vector-push-extend (tn-sc-offset tn) buffer) 384 #!-64-bit 385 (when save-tn 386 (vector-push-extend (tn-sc-offset save-tn) buffer)) 387 (vector-push-extend (tn-sc-offset (leaf-info var)) buffer)) 388 #!-64-bit 389 (t 390 (if (and tn (tn-offset tn)) 391 (vector-push-extend (tn-sc-offset tn) buffer) 392 (aver minimal)) 393 (when save-tn 394 (vector-push-extend (tn-sc-offset save-tn) buffer))))) 395 (values)) 396 397;;; Return a vector suitable for use as the DEBUG-FUN-VARS 398;;; of FUN. LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a 399;;; hash table in which we enter the translation from LAMBDA-VARS to 400;;; the relative position of that variable's location in the resulting 401;;; vector. 402(defun compute-vars (fun level var-locs) 403 (declare (type clambda fun) (type hash-table var-locs)) 404 (collect ((vars)) 405 (labels ((frob-leaf (leaf tn gensym-p) 406 (let ((name (leaf-debug-name leaf))) 407 (when (and name (leaf-refs leaf) (tn-offset tn) 408 (or gensym-p (symbol-package name))) 409 (vars (cons leaf tn))))) 410 (frob-lambda (x gensym-p) 411 (dolist (leaf (lambda-vars x)) 412 (frob-leaf leaf (leaf-info leaf) gensym-p)))) 413 (frob-lambda fun t) 414 (when (>= level 2) 415 (dolist (x (ir2-physenv-closure (physenv-info (lambda-physenv fun)))) 416 (let ((thing (car x))) 417 (when (lambda-var-p thing) 418 (frob-leaf thing (cdr x) (= level 3))))) 419 420 (dolist (let (lambda-lets fun)) 421 (frob-lambda let (= level 3))))) 422 423 (let ((sorted (sort (vars) #'string< 424 :key (lambda (x) 425 (symbol-name (leaf-debug-name (car x)))))) 426 (prev-name nil) 427 (id 0) 428 (i 0) 429 (buffer (make-array 0 :fill-pointer 0 :adjustable t))) 430 (declare (type (or simple-string null) prev-name) 431 (type index id i)) 432 (dolist (x sorted) 433 (let* ((var (car x)) 434 (name (symbol-name (leaf-debug-name var)))) 435 (cond ((and prev-name (string= prev-name name)) 436 (incf id)) 437 (t 438 (setq id 0 prev-name name))) 439 (dump-1-var fun var (cdr x) id nil buffer) 440 (setf (gethash var var-locs) i) 441 (incf i))) 442 (coerce buffer 'simple-vector)))) 443 444;;; Return a vector suitable for use as the DEBUG-FUN-VARS of 445;;; FUN, representing the arguments to FUN in minimal variable format. 446(defun compute-minimal-vars (fun) 447 (declare (type clambda fun)) 448 (let ((buffer (make-array 0 :fill-pointer 0 :adjustable t))) 449 (dolist (var (lambda-vars fun)) 450 (dump-1-var fun var (leaf-info var) 0 t buffer)) 451 (coerce buffer 'simple-vector))) 452 453;;; Return VAR's relative position in the function's variables (determined 454;;; from the VAR-LOCS hashtable). If VAR is deleted, then return DELETED. 455(defun debug-location-for (var var-locs) 456 (declare (type lambda-var var) (type hash-table var-locs)) 457 (let ((res (gethash var var-locs))) 458 (cond (res) 459 (t 460 (aver (or (null (leaf-refs var)) 461 (not (tn-offset (leaf-info var))))) 462 'deleted)))) 463 464;;;; arguments/returns 465 466;;; Return a vector to be used as the COMPILED-DEBUG-FUN-ARGS for FUN. 467;;; If FUN is the MAIN-ENTRY for an optional dispatch, then look at 468;;; the ARGLIST to determine the syntax, otherwise pretend all 469;;; arguments are fixed. 470;;; 471;;; ### This assumption breaks down in EPs other than the main-entry, 472;;; since they may or may not have supplied-p vars, etc. 473(defun compute-args (fun var-locs) 474 (declare (type clambda fun) (type hash-table var-locs)) 475 (collect ((res)) 476 (let ((od (lambda-optional-dispatch fun))) 477 (if (and od (eq (optional-dispatch-main-entry od) fun)) 478 (let ((actual-vars (lambda-vars fun)) 479 (saw-optional nil)) 480 (labels ((one-arg (arg) 481 (let ((info (lambda-var-arg-info arg)) 482 (actual (pop actual-vars))) 483 (cond (info 484 (case (arg-info-kind info) 485 (:keyword 486 (res (arg-info-key info))) 487 (:rest 488 (let ((more (arg-info-default info))) 489 (cond ((and (consp more) (third more)) 490 (one-arg (first (arg-info-default info))) 491 (one-arg (second (arg-info-default info))) 492 (return-from one-arg)) 493 (more 494 (setf (arg-info-default info) t))) 495 (res 'rest-arg))) 496 (:more-context 497 (res 'more-arg)) 498 (:optional 499 (unless saw-optional 500 (res 'optional-args) 501 (setq saw-optional t)))) 502 (res (debug-location-for actual var-locs)) 503 (when (arg-info-supplied-p info) 504 (res 'supplied-p) 505 (res (debug-location-for (pop actual-vars) var-locs)))) 506 (t 507 (res (debug-location-for actual var-locs))))))) 508 (dolist (arg (optional-dispatch-arglist od)) 509 (one-arg arg)))) 510 (dolist (var (lambda-vars fun)) 511 (res (debug-location-for var var-locs))))) 512 513 (coerce-to-smallest-eltype (res)))) 514 515;;; Return a vector of SC offsets describing FUN's return locations. 516;;; (Must be known values return...) 517(defun compute-debug-returns (fun) 518 (coerce-to-smallest-eltype 519 (mapcar (lambda (loc) 520 (tn-sc-offset loc)) 521 (return-info-locations (tail-set-info (lambda-tail-set fun)))))) 522 523;;;; debug functions 524 525;;; Return a C-D-F structure with all the mandatory slots filled in. 526(defun dfun-from-fun (fun) 527 (declare (type clambda fun)) 528 (let* ((2env (physenv-info (lambda-physenv fun))) 529 (dispatch (lambda-optional-dispatch fun)) 530 (main-p (and dispatch 531 (eq fun (optional-dispatch-main-entry dispatch))))) 532 (make-compiled-debug-fun 533 :name (leaf-debug-name fun) 534 :kind (if main-p nil (functional-kind fun)) 535 #!-fp-and-pc-standard-save :return-pc 536 #!-fp-and-pc-standard-save (tn-sc-offset (ir2-physenv-return-pc 2env)) 537 #!-fp-and-pc-standard-save :old-fp 538 #!-fp-and-pc-standard-save (tn-sc-offset (ir2-physenv-old-fp 2env)) 539 :start-pc (label-position (ir2-physenv-environment-start 2env)) 540 :elsewhere-pc (label-position (ir2-physenv-elsewhere-start 2env)) 541 :closure-save (when (ir2-physenv-closure-save-tn 2env) 542 (tn-sc-offset (ir2-physenv-closure-save-tn 2env))) 543 #!+unwind-to-frame-and-call-vop 544 :bsp-save 545 #!+unwind-to-frame-and-call-vop 546 (when (ir2-physenv-bsp-save-tn 2env) 547 (tn-sc-offset (ir2-physenv-bsp-save-tn 2env)))))) 548 549;;; Return a complete C-D-F structure for FUN. This involves 550;;; determining the DEBUG-INFO level and filling in optional slots as 551;;; appropriate. 552(defun compute-1-debug-fun (fun var-locs) 553 (declare (type clambda fun) (type hash-table var-locs)) 554 (let* ((dfun (dfun-from-fun fun)) 555 (actual-level (policy (lambda-bind fun) compute-debug-fun)) 556 (level (if #!+sb-dyncount *collect-dynamic-statistics* 557 #!-sb-dyncount nil 558 (max actual-level 2) 559 actual-level)) 560 (toplevel-p (eq :toplevel (compiled-debug-fun-kind dfun)))) 561 (cond ((or (zerop level) toplevel-p)) 562 ((and (<= level 1) 563 (let ((od (lambda-optional-dispatch fun))) 564 (or (not od) 565 (not (eq (optional-dispatch-main-entry od) fun))))) 566 (setf (compiled-debug-fun-vars dfun) 567 (compute-minimal-vars fun)) 568 (setf (compiled-debug-fun-arguments dfun) :minimal)) 569 (t 570 (setf (compiled-debug-fun-vars dfun) 571 (compute-vars fun level var-locs)) 572 (setf (compiled-debug-fun-arguments dfun) 573 (compute-args fun var-locs)))) 574 575 (if (and (>= level 2) (not toplevel-p)) 576 (multiple-value-bind (blocks tlf-num form-number) 577 (compute-debug-blocks fun var-locs) 578 (setf (compiled-debug-fun-blocks dfun) blocks 579 (compiled-debug-fun-tlf-number dfun) tlf-num 580 (compiled-debug-fun-form-number dfun) form-number)) 581 (multiple-value-bind (tlf-num form-number) (find-tlf-number fun) 582 (setf (compiled-debug-fun-tlf-number dfun) tlf-num 583 (compiled-debug-fun-form-number dfun) form-number))) 584 (if (xep-p fun) 585 (setf (compiled-debug-fun-returns dfun) :standard) 586 (let ((info (tail-set-info (lambda-tail-set fun)))) 587 (when info 588 (cond ((eq (return-info-kind info) :unknown) 589 (setf (compiled-debug-fun-returns dfun) 590 :standard)) 591 ((/= level 0) 592 (setf (compiled-debug-fun-returns dfun) 593 (compute-debug-returns fun))))))) 594 dfun)) 595 596;;;; full component dumping 597 598;;; Compute the full form (simple-vector) function map. 599(defun compute-debug-fun-map (sorted) 600 (declare (list sorted)) 601 (let* ((len (1- (* (length sorted) 2))) 602 (funs-vec (make-array len))) 603 (do ((i -1 (+ i 2)) 604 (sorted sorted (cdr sorted))) 605 ((= i len)) 606 (declare (fixnum i)) 607 (let ((dfun (car sorted))) 608 (unless (minusp i) 609 (setf (svref funs-vec i) (car dfun))) 610 (setf (svref funs-vec (1+ i)) (cdr dfun)))) 611 funs-vec)) 612 613;;; Return a DEBUG-INFO structure describing COMPONENT. This has to be 614;;; called after assembly so that source map information is available. 615(defun debug-info-for-component (component) 616 (declare (type component component)) 617 (let ((dfuns nil) 618 (var-locs (make-hash-table :test 'eq)) 619 (*byte-buffer* (make-array 10 620 :element-type '(unsigned-byte 8) 621 :fill-pointer 0 622 :adjustable t))) 623 (dolist (lambda (component-lambdas component)) 624 (clrhash var-locs) 625 (push (cons (label-position (block-label (lambda-block lambda))) 626 (compute-1-debug-fun lambda var-locs)) 627 dfuns)) 628 (let* ((sorted (sort dfuns #'< :key #'car)) 629 (fun-map (compute-debug-fun-map sorted))) 630 (make-compiled-debug-info :name (component-name component) 631 :fun-map fun-map)))) 632 633;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of 634;;; BITS must be evenly divisible by eight. 635(defun write-packed-bit-vector (bits byte-buffer) 636 (declare (type simple-bit-vector bits) (type byte-buffer byte-buffer)) 637 638 ;; Enforce constraint from CMU-CL-era comment. 639 (aver (zerop (mod (length bits) 8))) 640 641 (multiple-value-bind (initial step done) 642 (ecase *backend-byte-order* 643 (:little-endian (values 0 1 8)) 644 (:big-endian (values 7 -1 -1))) 645 (let ((shift initial) 646 (byte 0)) 647 (dotimes (i (length bits)) 648 (let ((int (aref bits i))) 649 (setf byte (logior byte (ash int shift))) 650 (incf shift step)) 651 (when (= shift done) 652 (vector-push-extend byte byte-buffer) 653 (setf shift initial 654 byte 0))) 655 (unless (= shift initial) 656 (vector-push-extend byte byte-buffer)))) 657 (values)) 658