module/system/vm/debug.scm

   1 ;;; Guile runtime debug information
   2
   3 ;;; Copyright (C) 2013 Free Software Foundation, Inc.
   4 ;;;
   5 ;;; This library is free software; you can redistribute it and/or
   6 ;;; modify it under the terms of the GNU Lesser General Public
   7 ;;; License as published by the Free Software Foundation; either
   8 ;;; version 3 of the License, or (at your option) any later version.
   9 ;;;
  10 ;;; This library is distributed in the hope that it will be useful,
  11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;; Lesser General Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU Lesser General Public
  16 ;;; License along with this library; if not, write to the Free Software
  17 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Commentary:
  20 ;;;
  21 ;;; Guile's RTL compiler and linker serialize debugging information into
  22 ;;; separate sections of the ELF image.  This module reads those
  23 ;;; sections.
  24 ;;;
  25 ;;; Code:
  26
  27 (define-module (system vm debug)
  28   #:use-module (system vm elf)
  29   #:use-module (system vm dwarf)
  30   #:use-module (system vm loader)
  31   #:use-module (system foreign)
  32   #:use-module (rnrs bytevectors)
  33   #:use-module (ice-9 match)
  34   #:use-module ((srfi srfi-1) #:select (fold))
  35   #:use-module (srfi srfi-9)
  36   #:export (debug-context-image
  37             debug-context-base
  38             debug-context-length
  39             debug-context-text-base
  40
  41             program-debug-info-name
  42             program-debug-info-context
  43             program-debug-info-image
  44             program-debug-info-offset
  45             program-debug-info-size
  46             program-debug-info-addr
  47             program-debug-info-u32-offset
  48             program-debug-info-u32-offset-end
  49
  50             arity?
  51             arity-low-pc
  52             arity-high-pc
  53             arity-nreq
  54             arity-nopt
  55             arity-has-rest?
  56             arity-allow-other-keys?
  57             arity-has-keyword-args?
  58             arity-is-case-lambda?
  59
  60             debug-context-from-image
  61             fold-all-debug-contexts
  62             for-each-elf-symbol
  63             find-debug-context
  64             find-program-debug-info
  65             arity-arguments-alist
  66             find-program-arities
  67             find-program-minimum-arity
  68
  69             find-program-docstring
  70
  71             find-program-properties
  72
  73             source?
  74             source-pre-pc
  75             source-post-pc
  76             source-file
  77             source-line
  78             source-line-for-user
  79             source-column
  80             find-source-for-addr
  81             find-program-sources
  82             fold-source-locations))
  83
  84 ;;; A compiled procedure comes from a specific loaded ELF image.  A
  85 ;;; debug context identifies that image.
  86 ;;;
  87 (define-record-type <debug-context>
  88   (make-debug-context elf base text-base)
  89   debug-context?
  90   (elf debug-context-elf)
  91   ;; Address at which this image is loaded in memory, in bytes.
  92   (base debug-context-base)
  93   ;; Offset of the text section relative to the image start, in bytes.
  94   (text-base debug-context-text-base))
  95
  96 (define (debug-context-image context)
  97   "Return the bytevector aliasing the mapped ELF image corresponding to
  98 @var{context}."
  99   (elf-bytes (debug-context-elf context)))
 100
 101 (define (debug-context-length context)
 102   "Return the size of the mapped ELF image corresponding to
 103 @var{context}, in bytes."
 104   (bytevector-length (debug-context-image context)))
 105
 106 (define (for-each-elf-symbol context proc)
 107   "Call @var{proc} on each symbol in the symbol table of @var{context}."
 108   (let ((elf (debug-context-elf context)))
 109     (cond
 110      ((elf-section-by-name elf ".symtab")
 111       => (lambda (symtab)
 112            (let ((len (elf-symbol-table-len symtab))
 113                  (strtab (elf-section elf (elf-section-link symtab))))
 114              (let lp ((n 0))
 115                (when (< n len)
 116                  (proc (elf-symbol-table-ref elf symtab n strtab))
 117                  (lp (1+ n))))))))))
 118
 119 ;;; A program debug info (PDI) is a handle on debugging meta-data for a
 120 ;;; particular program.
 121 ;;;
 122 (define-record-type <program-debug-info>
 123   (make-program-debug-info context name offset size)
 124   program-debug-info?
 125   (context program-debug-info-context)
 126   (name program-debug-info-name)
 127   ;; Offset of the procedure in the text section, in bytes.
 128   (offset program-debug-info-offset)
 129   (size program-debug-info-size))
 130
 131 (define (program-debug-info-addr pdi)
 132   "Return the address in memory of the entry of the program represented
 133 by the debugging info @var{pdi}."
 134   (+ (program-debug-info-offset pdi)
 135      (debug-context-text-base (program-debug-info-context pdi))
 136      (debug-context-base (program-debug-info-context pdi))))
 137
 138 (define (program-debug-info-image pdi)
 139   "Return the ELF image containing @var{pdi}, as a bytevector."
 140   (debug-context-image (program-debug-info-context pdi)))
 141
 142 (define (program-debug-info-u32-offset pdi)
 143   "Return the start address of the program represented by @var{pdi}, as
 144 an offset from the beginning of the ELF image in 32-bit units."
 145   (/ (+ (program-debug-info-offset pdi)
 146         (debug-context-text-base (program-debug-info-context pdi)))
 147      4))
 148
 149 (define (program-debug-info-u32-offset-end pdi)
 150   "Return the end address of the program represented by @var{pdi}, as an
 151 offset from the beginning of the ELF image in 32-bit units."
 152   (/ (+ (program-debug-info-size pdi)
 153         (program-debug-info-offset pdi)
 154         (debug-context-text-base (program-debug-info-context pdi)))
 155      4))
 156
 157 (define (debug-context-from-image bv)
 158   "Build a debugging context corresponding to a given ELF image."
 159   (let* ((elf (parse-elf bv))
 160          (base (pointer-address (bytevector->pointer (elf-bytes elf))))
 161          (text-base (elf-section-offset
 162                      (or (elf-section-by-name elf ".rtl-text")
 163                          (error "ELF object has no text section")))))
 164     (make-debug-context elf base text-base)))
 165
 166 (define (fold-all-debug-contexts proc seed)
 167   "Fold @var{proc} over debug contexts corresponding to all images that
 168 are mapped at the time this procedure is called.  Any images mapped
 169 during the fold are omitted."
 170   (fold (lambda (image seed)
 171           (proc (debug-context-from-image image) seed))
 172         seed
 173         (all-mapped-elf-images)))
 174
 175 (define (find-debug-context addr)
 176   "Find and return the debugging context corresponding to the ELF image
 177 containing the address @var{addr}.  @var{addr} is an integer.  If no ELF
 178 image is found, return @code{#f}.  It's possible for an RTL program not
 179 to have an ELF image if the program was defined in as a stub in C."
 180   (and=> (find-mapped-elf-image addr)
 181          debug-context-from-image))
 182
 183 (define-inlinable (binary-search start end inc try failure)
 184   (let lp ((start start) (end end))
 185     (if (eqv? start end)
 186         (failure)
 187         (let ((mid (+ start (* inc (floor/ (- end start) (* 2 inc))))))
 188           (try mid
 189                (lambda ()
 190                  (lp start mid))
 191                (lambda ()
 192                  (lp (+ mid inc) end)))))))
 193
 194 (define (find-elf-symbol elf text-offset)
 195   "Search the symbol table of @var{elf} for the ELF symbol containing
 196 @var{text-offset}.  @var{text-offset} is a byte offset in the text
 197 section of the ELF image.  Returns an ELF symbol, or @code{#f}."
 198   (and=>
 199    (elf-section-by-name elf ".symtab")
 200    (lambda (symtab)
 201      (let ((strtab (elf-section elf (elf-section-link symtab))))
 202        (binary-search
 203         0 (elf-symbol-table-len symtab) 1
 204         (lambda (n continue-before continue-after)
 205           (let* ((sym (elf-symbol-table-ref elf symtab n strtab))
 206                  (val (elf-symbol-value sym))
 207                  (size (elf-symbol-size sym)))
 208             (cond
 209              ((< text-offset val) (continue-before))
 210              ((<= (+ val size) text-offset) (continue-after))
 211              (else sym))))
 212         (lambda ()
 213           #f))))))
 214
 215 (define* (find-program-debug-info addr #:optional
 216                                   (context (find-debug-context addr)))
 217   "Find and return the @code{<program-debug-info>} containing
 218 @var{addr}, or @code{#f}."
 219   (cond
 220    ((and context
 221          (find-elf-symbol (debug-context-elf context)
 222                           (- addr
 223                              (debug-context-base context)
 224                              (debug-context-text-base context))))
 225     => (lambda (sym)
 226          (make-program-debug-info context
 227                                   (and=> (elf-symbol-name sym)
 228                                          ;; The name might be #f if
 229                                          ;; the string table was
 230                                          ;; stripped somehow.
 231                                          (lambda (x)
 232                                            (and (string? x)
 233                                                 (not (string-null? x))
 234                                                 (string->symbol x))))
 235                                   (elf-symbol-value sym)
 236                                   (elf-symbol-size sym))))
 237    (else #f)))
 238
 239 (define-record-type <arity>
 240   (make-arity context base header-offset)
 241   arity?
 242   (context arity-context)
 243   (base arity-base)
 244   (header-offset arity-header-offset))
 245
 246 (define arities-prefix-len 4)
 247 (define arity-header-len (* 6 4))
 248
 249 ;;;   struct arity_header {
 250 ;;;     uint32_t low_pc;
 251 ;;;     uint32_t high_pc;
 252 ;;;     uint32_t offset;
 253 ;;;     uint32_t flags;
 254 ;;;     uint32_t nreq;
 255 ;;;     uint32_t nopt;
 256 ;;;   }
 257
 258 (define (arity-low-pc* bv header-pos)
 259   (bytevector-u32-native-ref bv (+ header-pos (* 0 4))))
 260 (define (arity-high-pc* bv header-pos)
 261   (bytevector-u32-native-ref bv (+ header-pos (* 1 4))))
 262 (define (arity-offset* bv header-pos)
 263   (bytevector-u32-native-ref bv (+ header-pos (* 2 4))))
 264 (define (arity-flags* bv header-pos)
 265   (bytevector-u32-native-ref bv (+ header-pos (* 3 4))))
 266 (define (arity-nreq* bv header-pos)
 267   (bytevector-u32-native-ref bv (+ header-pos (* 4 4))))
 268 (define (arity-nopt* bv header-pos)
 269   (bytevector-u32-native-ref bv (+ header-pos (* 5 4))))
 270
 271 ;;;    #x1: has-rest?
 272 ;;;    #x2: allow-other-keys?
 273 ;;;    #x4: has-keyword-args?
 274 ;;;    #x8: is-case-lambda?
 275 ;;;   #x10: is-in-case-lambda?
 276
 277 (define (has-rest? flags)         (not (zero? (logand flags (ash 1 0)))))
 278 (define (allow-other-keys? flags) (not (zero? (logand flags (ash 1 1)))))
 279 (define (has-keyword-args? flags) (not (zero? (logand flags (ash 1 2)))))
 280 (define (is-case-lambda? flags)   (not (zero? (logand flags (ash 1 3)))))
 281 (define (is-in-case-lambda? flags) (not (zero? (logand flags (ash 1 4)))))
 282
 283 (define (arity-low-pc arity)
 284   (let ((ctx (arity-context arity)))
 285     (+ (debug-context-base ctx)
 286        (debug-context-text-base ctx)
 287        (arity-low-pc* (elf-bytes (debug-context-elf ctx))
 288                       (arity-header-offset arity)))))
 289
 290 (define (arity-high-pc arity)
 291   (let ((ctx (arity-context arity)))
 292     (+ (debug-context-base ctx)
 293        (debug-context-text-base ctx)
 294        (arity-high-pc* (elf-bytes (debug-context-elf ctx))
 295                        (arity-header-offset arity)))))
 296
 297 (define (arity-nreq arity)
 298   (arity-nreq* (elf-bytes (debug-context-elf (arity-context arity)))
 299                (arity-header-offset arity)))
 300
 301 (define (arity-nopt arity)
 302   (arity-nopt* (elf-bytes (debug-context-elf (arity-context arity)))
 303                (arity-header-offset arity)))
 304
 305 (define (arity-flags arity)
 306   (arity-flags* (elf-bytes (debug-context-elf (arity-context arity)))
 307                 (arity-header-offset arity)))
 308
 309 (define (arity-has-rest? arity) (has-rest? (arity-flags arity)))
 310 (define (arity-allow-other-keys? arity) (allow-other-keys? (arity-flags arity)))
 311 (define (arity-has-keyword-args? arity) (has-keyword-args? (arity-flags arity)))
 312 (define (arity-is-case-lambda? arity) (is-case-lambda? (arity-flags arity)))
 313 (define (arity-is-in-case-lambda? arity) (is-in-case-lambda? (arity-flags arity)))
 314
 315 (define (arity-load-symbol arity)
 316   (let ((elf (debug-context-elf (arity-context arity))))
 317     (cond
 318      ((elf-section-by-name elf ".guile.arities")
 319       =>
 320       (lambda (sec)
 321         (let* ((strtab (elf-section elf (elf-section-link sec)))
 322                (bv (elf-bytes elf))
 323                (strtab-offset (elf-section-offset strtab)))
 324           (lambda (n)
 325             (string->symbol (string-table-ref bv (+ strtab-offset n)))))))
 326      (else (error "couldn't find arities section")))))
 327
 328 (define (arity-arguments-alist arity)
 329   (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
 330          (%load-symbol (arity-load-symbol arity))
 331          (header (arity-header-offset arity))
 332          (link-offset (arity-offset* bv header))
 333          (link (+ (arity-base arity) link-offset))
 334          (flags (arity-flags* bv header))
 335          (nreq (arity-nreq* bv header))
 336          (nopt (arity-nopt* bv header)))
 337     (define (load-symbol idx)
 338       (%load-symbol (bytevector-u32-native-ref bv (+ link (* idx 4)))))
 339     (define (load-symbols skip n)
 340       (let lp ((n n) (out '()))
 341         (if (zero? n)
 342             out
 343             (lp (1- n)
 344                 (cons (load-symbol (+ skip (1- n))) out)))))
 345     (define (unpack-scm n)
 346       (pointer->scm (make-pointer n)))
 347     (define (load-non-immediate idx)
 348       (let ((offset (bytevector-u32-native-ref bv (+ link (* idx 4)))))
 349         (unpack-scm (+ (debug-context-base (arity-context arity)) offset))))
 350     (and (not (is-case-lambda? flags))
 351          `((required . ,(load-symbols 0 nreq))
 352            (optional . ,(load-symbols nreq nopt))
 353            (keyword . ,(if (has-keyword-args? flags)
 354                            (load-non-immediate
 355                             (+ nreq nopt (if (has-rest? flags) 1 0)))
 356                            '()))
 357            (allow-other-keys? . ,(allow-other-keys? flags))
 358            (rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt))))))))
 359
 360 (define (find-first-arity context base addr)
 361   (let* ((bv (elf-bytes (debug-context-elf context)))
 362          (text-offset (- addr
 363                          (debug-context-text-base context)
 364                          (debug-context-base context))))
 365     (binary-search
 366      (+ base arities-prefix-len)
 367      (+ base (bytevector-u32-native-ref bv base))
 368      arity-header-len
 369      (lambda (pos continue-before continue-after)
 370        (let lp ((pos pos))
 371          (cond
 372           ((is-in-case-lambda? (arity-flags* bv pos))
 373            (lp (- pos arity-header-len)))
 374           ((< text-offset (arity-low-pc* bv pos))
 375            (continue-before))
 376           ((<= (arity-high-pc* bv pos) text-offset)
 377            (continue-after))
 378           (else
 379            (make-arity context base pos)))))
 380      (lambda ()
 381        #f))))
 382
 383 (define (read-sub-arities context base outer-header-offset)
 384   (let* ((bv (elf-bytes (debug-context-elf context)))
 385          (headers-end (+ base (bytevector-u32-native-ref bv base)))
 386          (low-pc (arity-low-pc* bv outer-header-offset))
 387          (high-pc (arity-high-pc* bv outer-header-offset)))
 388     (let lp ((pos (+ outer-header-offset arity-header-len)) (out '()))
 389       (if (and (< pos headers-end) (<= (arity-high-pc* bv pos) high-pc))
 390           (lp (+ pos arity-header-len)
 391               (cons (make-arity context base pos) out))
 392           (reverse out)))))
 393
 394 (define* (find-program-arities addr #:optional
 395                                (context (find-debug-context addr)))
 396   (and=>
 397    (and context
 398         (elf-section-by-name (debug-context-elf context) ".guile.arities"))
 399    (lambda (sec)
 400      (let* ((base (elf-section-offset sec))
 401             (first (find-first-arity context base addr)))
 402        (cond
 403         ((not first) '())
 404         ((arity-is-case-lambda? first)
 405          (read-sub-arities context base (arity-header-offset first)))
 406         (else (list first)))))))
 407
 408 (define* (find-program-minimum-arity addr #:optional
 409                                      (context (find-debug-context addr)))
 410   (and=>
 411    (and context
 412         (elf-section-by-name (debug-context-elf context) ".guile.arities"))
 413    (lambda (sec)
 414      (let* ((base (elf-section-offset sec))
 415             (first (find-first-arity context base addr)))
 416        (if (arity-is-case-lambda? first)
 417            (let ((arities (read-sub-arities context base
 418                                             (arity-header-offset first))))
 419              (and (pair? arities)
 420                   (list (apply min (map arity-nreq arities))
 421                         0
 422                         (or-map (lambda (arity)
 423                                   (or (positive? (arity-nopt arity))
 424                                       (arity-has-rest? arity)
 425                                       (arity-has-keyword-args? arity)
 426                                       (arity-allow-other-keys? arity)))
 427                                 arities))))
 428            (list (arity-nreq first)
 429                  (arity-nopt first)
 430                  (arity-has-rest? first)))))))
 431
 432 (define* (find-program-docstring addr #:optional
 433                                  (context (find-debug-context addr)))
 434   (and=>
 435    (and context
 436         (elf-section-by-name (debug-context-elf context) ".guile.docstrs"))
 437    (lambda (sec)
 438      ;; struct docstr {
 439      ;;   uint32_t pc;
 440      ;;   uint32_t str;
 441      ;; }
 442      (let ((start (elf-section-offset sec))
 443            (bv (elf-bytes (debug-context-elf context)))
 444            (text-offset (- addr
 445                            (debug-context-text-base context)
 446                            (debug-context-base context))))
 447        (binary-search
 448         start
 449         (+ start (elf-section-size sec))
 450         8
 451         (lambda (pos continue-before continue-after)
 452           (let ((pc (bytevector-u32-native-ref bv pos)))
 453             (cond
 454              ((< text-offset pc) (continue-before))
 455              ((< pc text-offset) (continue-after))
 456              (else
 457               (let ((strtab (elf-section (debug-context-elf context)
 458                                          (elf-section-link sec)))
 459                     (idx (bytevector-u32-native-ref bv (+ pos 4))))
 460                 (string-table-ref bv (+ (elf-section-offset strtab) idx)))))))
 461         (lambda ()
 462           #f))))))
 463
 464 (define* (find-program-properties addr #:optional
 465                                   (context (find-debug-context addr)))
 466   (define (add-name-and-docstring props)
 467     (define (maybe-acons k v tail)
 468       (if v (acons k v tail) tail))
 469     (let ((name (and=> (find-program-debug-info addr context)
 470                        program-debug-info-name))
 471           (docstring (find-program-docstring addr context)))
 472       (maybe-acons 'name name
 473                    (maybe-acons 'documentation docstring props))))
 474   (add-name-and-docstring
 475    (cond
 476     ((and context
 477           (elf-section-by-name (debug-context-elf context) ".guile.procprops"))
 478      => (lambda (sec)
 479           ;; struct procprop {
 480           ;;   uint32_t pc;
 481           ;;   uint32_t offset;
 482           ;; }
 483           (define procprop-len 8)
 484           (let* ((start (elf-section-offset sec))
 485                  (bv (elf-bytes (debug-context-elf context)))
 486                  (text-offset (- addr
 487                                  (debug-context-text-base context)
 488                                  (debug-context-base context))))
 489             (define (unpack-scm addr)
 490               (pointer->scm (make-pointer addr)))
 491             (define (load-non-immediate offset)
 492               (unpack-scm (+ (debug-context-base context) offset)))
 493             (binary-search
 494              start (+ start (elf-section-size sec)) 8
 495              (lambda (pos continue-before continue-after)
 496                (let ((pc (bytevector-u32-native-ref bv pos)))
 497                  (cond
 498                   ((< text-offset pc) (continue-before))
 499                   ((< pc text-offset) (continue-after))
 500                   (else
 501                    (load-non-immediate
 502                     (bytevector-u32-native-ref bv (+ pos 4)))))))
 503              (lambda ()
 504                '())))))
 505     (else '()))))
 506
 507 (define-record-type <source>
 508   (make-source pre-pc file line column)
 509   source?
 510   (pre-pc source-pre-pc)
 511   (file source-file)
 512   (line source-line)
 513   (column source-column))
 514
 515 (define (make-source/dwarf pc file line column)
 516   (make-source pc file
 517                ;; Convert DWARF-numbered (1-based) lines and
 518                ;; columns to Guile conventions (0-based).
 519                (and line (1- line)) (and column (1- column))))
 520
 521 ;; FIXME
 522 (define (source-post-pc source)
 523   (source-pre-pc source))
 524
 525 ;; Lines are zero-indexed inside Guile, but users expect them to be
 526 ;; one-indexed. Columns, on the other hand, are zero-indexed to both. Go
 527 ;; figure.
 528 (define (source-line-for-user source)
 529   (1+ (source-line source)))
 530
 531 (define* (find-source-for-addr addr #:optional
 532                                (context (find-debug-context addr))
 533                                #:key exact?)
 534   (and=>
 535    (and context
 536         (false-if-exception
 537          (elf->dwarf-context (debug-context-elf context))))
 538    (lambda (dwarf-ctx)
 539      (let* ((base (debug-context-base context))
 540             (pc (- addr base)))
 541        (or-map (lambda (die)
 542                  (and=>
 543                   (die-line-prog die)
 544                   (lambda (prog)
 545                     (call-with-values
 546                         (lambda () (line-prog-scan-to-pc prog pc))
 547                       (lambda (pc* file line col)
 548                         (and pc* (or (= pc pc*) (not exact?))
 549                              (make-source/dwarf (+ pc* base)
 550                                                 file line col)))))))
 551                (read-die-roots dwarf-ctx))))))
 552
 553 (define* (find-program-die addr #:optional
 554                            (context (find-debug-context addr)))
 555   (and=> (and context
 556               (false-if-exception
 557                (elf->dwarf-context (debug-context-elf context))))
 558          (lambda (dwarf-ctx)
 559            (find-die-by-pc (read-die-roots dwarf-ctx)
 560                            (- addr (debug-context-base context))))))
 561
 562 (define* (find-program-sources addr #:optional
 563                                (context (find-debug-context addr)))
 564   (cond
 565    ((find-program-die addr context)
 566     => (lambda (die)
 567          (let* ((base (debug-context-base context))
 568                 (low-pc (die-ref die 'low-pc))
 569                 (high-pc (die-high-pc die))
 570                 (prog (let line-prog ((die die))
 571                         (and die
 572                              (or (die-line-prog die)
 573                                  (line-prog (ctx-die (die-ctx die))))))))
 574            (cond
 575             ((and low-pc high-pc prog)
 576              (let lp ((sources '()))
 577                (call-with-values (lambda ()
 578                                    (if (null? sources)
 579                                        (line-prog-scan-to-pc prog low-pc)
 580                                        (line-prog-advance prog)))
 581                  (lambda (pc file line col)
 582                    (if (and pc (< pc high-pc))
 583                        ;; For the first source, it's probable that the
 584                        ;; address of the line program is before the
 585                        ;; low-pc, since the line program is for the
 586                        ;; entire compilation unit, and there are no
 587                        ;; redundant "rows" in the line program.
 588                        ;; Therefore in that case use the addr of low-pc
 589                        ;; instead of the one we got back.
 590                        (let ((addr (+ (if (null? sources) low-pc pc) base)))
 591                          (lp (cons (make-source/dwarf addr file line col)
 592                                    sources)))
 593                        (reverse sources))))))
 594             (else '())))))
 595    (else '())))
 596
 597 (define* (fold-source-locations proc seed context)
 598   "Fold @var{proc} over all source locations in @var{context}.
 599 @var{proc} will be called with two arguments: the source object and the
 600 seed."
 601   (cond
 602    ((and context
 603          (false-if-exception
 604           (elf->dwarf-context (debug-context-elf context))))
 605     =>
 606     (lambda (dwarf-ctx)
 607       (let ((base (debug-context-base context)))
 608         (fold
 609          (lambda (die seed)
 610            (cond
 611             ((die-line-prog die)
 612              =>
 613              (lambda (prog)
 614                (let lp ((seed seed))
 615                  (call-with-values
 616                      (lambda () (line-prog-advance prog))
 617                    (lambda (pc* file line col)
 618                      (if pc*
 619                          (lp
 620                           (proc (make-source/dwarf (+ pc* base) file line col)
 621                                 seed))
 622                          seed))))))
 623             (else seed)))
 624          seed
 625          (read-die-roots dwarf-ctx)))))
 626    (else seed)))