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 objcode)
  31   #:use-module (system foreign)
  32   #:use-module (rnrs bytevectors)
  33   #:use-module (ice-9 match)
  34   #:use-module (srfi srfi-9)
  35   #:export (debug-context-image
  36             debug-context-base
  37             debug-context-text-base
  38
  39             program-debug-info-name
  40             program-debug-info-context
  41             program-debug-info-image
  42             program-debug-info-offset
  43             program-debug-info-addr
  44             program-debug-info-u32-offset
  45             program-debug-info-u32-offset-end
  46
  47             arity?
  48             arity-low-pc
  49             arity-high-pc
  50             arity-nreq
  51             arity-nopt
  52             arity-has-rest?
  53             arity-allow-other-keys?
  54             arity-has-keyword-args?
  55             arity-is-case-lambda?
  56
  57             debug-context-from-image
  58             for-each-elf-symbol
  59             find-debug-context
  60             find-program-debug-info
  61             arity-arguments-alist
  62             find-program-arities
  63             program-minimum-arity
  64
  65             find-program-docstring
  66
  67             find-program-properties
  68
  69             source?
  70             source-pre-pc
  71             source-post-pc
  72             source-file
  73             source-line
  74             source-line-for-user
  75             source-column
  76             find-source-for-addr
  77             find-program-sources))
  78
  79 ;;; A compiled procedure comes from a specific loaded ELF image.  A
  80 ;;; debug context identifies that image.
  81 ;;;
  82 (define-record-type <debug-context>
  83   (make-debug-context elf base text-base)
  84   debug-context?
  85   (elf debug-context-elf)
  86   ;; Address at which this image is loaded in memory, in bytes.
  87   (base debug-context-base)
  88   ;; Offset of the text section relative to the image start, in bytes.
  89   (text-base debug-context-text-base))
  90
  91 (define (debug-context-image context)
  92   "Return the bytevector aliasing the mapped ELF image corresponding to
  93 @var{context}."
  94   (elf-bytes (debug-context-elf context)))
  95
  96 (define (for-each-elf-symbol context proc)
  97   "Call @var{proc} on each symbol in the symbol table of @var{context}."
  98   (let ((elf (debug-context-elf context)))
  99     (cond
 100      ((elf-section-by-name elf ".symtab")
 101       => (lambda (symtab)
 102            (let ((len (elf-symbol-table-len symtab))
 103                  (strtab (elf-section elf (elf-section-link symtab))))
 104              (let lp ((n 0))
 105                (when (< n len)
 106                  (proc (elf-symbol-table-ref elf symtab n strtab))
 107                  (lp (1+ n))))))))))
 108
 109 ;;; A program debug info (PDI) is a handle on debugging meta-data for a
 110 ;;; particular program.
 111 ;;;
 112 (define-record-type <program-debug-info>
 113   (make-program-debug-info context name offset size)
 114   program-debug-info?
 115   (context program-debug-info-context)
 116   (name program-debug-info-name)
 117   ;; Offset of the procedure in the text section, in bytes.
 118   (offset program-debug-info-offset)
 119   (size program-debug-info-size))
 120
 121 (define (program-debug-info-addr pdi)
 122   "Return the address in memory of the entry of the program represented
 123 by the debugging info @var{pdi}."
 124   (+ (program-debug-info-offset pdi)
 125      (debug-context-text-base (program-debug-info-context pdi))
 126      (debug-context-base (program-debug-info-context pdi))))
 127
 128 (define (program-debug-info-image pdi)
 129   "Return the ELF image containing @var{pdi}, as a bytevector."
 130   (debug-context-image (program-debug-info-context pdi)))
 131
 132 (define (program-debug-info-u32-offset pdi)
 133   "Return the start address of the program represented by @var{pdi}, as
 134 an offset from the beginning of the ELF image in 32-bit units."
 135   (/ (+ (program-debug-info-offset pdi)
 136         (debug-context-text-base (program-debug-info-context pdi)))
 137      4))
 138
 139 (define (program-debug-info-u32-offset-end pdi)
 140   "Return the end address of the program represented by @var{pdi}, as an
 141 offset from the beginning of the ELF image in 32-bit units."
 142   (/ (+ (program-debug-info-size pdi)
 143         (program-debug-info-offset pdi)
 144         (debug-context-text-base (program-debug-info-context pdi)))
 145      4))
 146
 147 (define (debug-context-from-image bv)
 148   "Build a debugging context corresponding to a given ELF image."
 149   (let* ((elf (parse-elf bv))
 150          (base (pointer-address (bytevector->pointer (elf-bytes elf))))
 151          (text-base (elf-section-offset
 152                      (or (elf-section-by-name elf ".rtl-text")
 153                          (error "ELF object has no text section")))))
 154     (make-debug-context elf base text-base)))
 155
 156 (define (find-debug-context addr)
 157   "Find and return the debugging context corresponding to the ELF image
 158 containing the address @var{addr}.  @var{addr} is an integer.  If no ELF
 159 image is found, return @code{#f}.  It's possible for an RTL program not
 160 to have an ELF image if the program was defined in as a stub in C."
 161   (and=> (find-mapped-elf-image addr)
 162          debug-context-from-image))
 163
 164 (define (find-elf-symbol elf text-offset)
 165   "Search the symbol table of @var{elf} for the ELF symbol containing
 166 @var{text-offset}.  @var{text-offset} is a byte offset in the text
 167 section of the ELF image.  Returns an ELF symbol, or @code{#f}."
 168   (and=>
 169    (elf-section-by-name elf ".symtab")
 170    (lambda (symtab)
 171      (let ((len (elf-symbol-table-len symtab))
 172            (strtab (elf-section elf (elf-section-link symtab))))
 173        ;; The symbols should be sorted, but maybe somehow that fails
 174        ;; (for example if multiple objects are relinked together).  So,
 175        ;; a modicum of tolerance.
 176        (define (bisect)
 177          ;; FIXME: Implement.
 178          #f)
 179        (define (linear-search)
 180          (let lp ((n 0))
 181            (and (< n len)
 182                 (let ((sym (elf-symbol-table-ref elf symtab n strtab)))
 183                   (if (and (<= (elf-symbol-value sym) text-offset)
 184                            (< text-offset (+ (elf-symbol-value sym)
 185                                              (elf-symbol-size sym))))
 186                       sym
 187                       (lp (1+ n)))))))
 188        (or (bisect) (linear-search))))))
 189
 190 (define* (find-program-debug-info addr #:optional
 191                                   (context (find-debug-context addr)))
 192   "Find and return the @code{<program-debug-info>} containing
 193 @var{addr}, or @code{#f}."
 194   (cond
 195    ((and context
 196          (find-elf-symbol (debug-context-elf context)
 197                           (- addr
 198                              (debug-context-base context)
 199                              (debug-context-text-base context))))
 200     => (lambda (sym)
 201          (make-program-debug-info context
 202                                   (and=> (elf-symbol-name sym)
 203                                          ;; The name might be #f if
 204                                          ;; the string table was
 205                                          ;; stripped somehow.
 206                                          (lambda (x)
 207                                            (and (string? x)
 208                                                 (not (string-null? x))
 209                                                 (string->symbol x))))
 210                                   (elf-symbol-value sym)
 211                                   (elf-symbol-size sym))))
 212    (else #f)))
 213
 214 (define-record-type <arity>
 215   (make-arity context base header-offset)
 216   arity?
 217   (context arity-context)
 218   (base arity-base)
 219   (header-offset arity-header-offset))
 220
 221 (define arities-prefix-len 4)
 222 (define arity-header-len (* 6 4))
 223
 224 ;;;   struct arity_header {
 225 ;;;     uint32_t low_pc;
 226 ;;;     uint32_t high_pc;
 227 ;;;     uint32_t offset;
 228 ;;;     uint32_t flags;
 229 ;;;     uint32_t nreq;
 230 ;;;     uint32_t nopt;
 231 ;;;   }
 232
 233 (define (arity-low-pc* bv header-pos)
 234   (bytevector-u32-native-ref bv (+ header-pos (* 0 4))))
 235 (define (arity-high-pc* bv header-pos)
 236   (bytevector-u32-native-ref bv (+ header-pos (* 1 4))))
 237 (define (arity-offset* bv header-pos)
 238   (bytevector-u32-native-ref bv (+ header-pos (* 2 4))))
 239 (define (arity-flags* bv header-pos)
 240   (bytevector-u32-native-ref bv (+ header-pos (* 3 4))))
 241 (define (arity-nreq* bv header-pos)
 242   (bytevector-u32-native-ref bv (+ header-pos (* 4 4))))
 243 (define (arity-nopt* bv header-pos)
 244   (bytevector-u32-native-ref bv (+ header-pos (* 5 4))))
 245
 246 ;;;    #x1: has-rest?
 247 ;;;    #x2: allow-other-keys?
 248 ;;;    #x4: has-keyword-args?
 249 ;;;    #x8: is-case-lambda?
 250
 251 (define (has-rest? flags)         (not (zero? (logand flags (ash 1 0)))))
 252 (define (allow-other-keys? flags) (not (zero? (logand flags (ash 1 1)))))
 253 (define (has-keyword-args? flags) (not (zero? (logand flags (ash 1 2)))))
 254 (define (is-case-lambda? flags)   (not (zero? (logand flags (ash 1 3)))))
 255
 256 (define (arity-low-pc arity)
 257   (arity-low-pc* (elf-bytes (debug-context-elf (arity-context arity)))
 258                  (arity-header-offset arity)))
 259
 260 (define (arity-high-pc arity)
 261   (arity-high-pc* (elf-bytes (debug-context-elf (arity-context arity)))
 262                   (arity-header-offset arity)))
 263
 264 (define (arity-nreq arity)
 265   (arity-nreq* (elf-bytes (debug-context-elf (arity-context arity)))
 266                (arity-header-offset arity)))
 267
 268 (define (arity-nopt arity)
 269   (arity-nopt* (elf-bytes (debug-context-elf (arity-context arity)))
 270                (arity-header-offset arity)))
 271
 272 (define (arity-flags arity)
 273   (arity-flags* (elf-bytes (debug-context-elf (arity-context arity)))
 274                 (arity-header-offset arity)))
 275
 276 (define (arity-has-rest? arity) (has-rest? (arity-flags arity)))
 277 (define (arity-allow-other-keys? arity) (allow-other-keys? (arity-flags arity)))
 278 (define (arity-has-keyword-args? arity) (has-keyword-args? (arity-flags arity)))
 279 (define (arity-is-case-lambda? arity) (is-case-lambda? (arity-flags arity)))
 280
 281 (define (arity-load-symbol arity)
 282   (let ((elf (debug-context-elf (arity-context arity))))
 283     (cond
 284      ((elf-section-by-name elf ".guile.arities")
 285       =>
 286       (lambda (sec)
 287         (let* ((strtab (elf-section elf (elf-section-link sec)))
 288                (bv (elf-bytes elf))
 289                (strtab-offset (elf-section-offset strtab)))
 290           (lambda (n)
 291             (string->symbol (string-table-ref bv (+ strtab-offset n)))))))
 292      (else (error "couldn't find arities section")))))
 293
 294 (define (arity-arguments-alist arity)
 295   (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
 296          (%load-symbol (arity-load-symbol arity))
 297          (header (arity-header-offset arity))
 298          (link-offset (arity-offset* bv header))
 299          (link (+ (arity-base arity) link-offset))
 300          (flags (arity-flags* bv header))
 301          (nreq (arity-nreq* bv header))
 302          (nopt (arity-nopt* bv header)))
 303     (define (load-symbol idx)
 304       (%load-symbol (bytevector-u32-native-ref bv (+ link (* idx 4)))))
 305     (define (load-symbols skip n)
 306       (let lp ((n n) (out '()))
 307         (if (zero? n)
 308             out
 309             (lp (1- n)
 310                 (cons (load-symbol (+ skip (1- n))) out)))))
 311     (define (unpack-scm n)
 312       (pointer->scm (make-pointer n)))
 313     (define (load-non-immediate idx)
 314       (let ((offset (bytevector-u32-native-ref bv (+ link (* idx 4)))))
 315         (unpack-scm (+ (debug-context-base (arity-context arity)) offset))))
 316     (and (not (is-case-lambda? flags))
 317          `((required . ,(load-symbols 0 nreq))
 318            (optional . ,(load-symbols nreq nopt))
 319            (rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt))))
 320            (keyword . ,(if (has-keyword-args? flags)
 321                            (load-non-immediate
 322                             (+ nreq nopt (if (has-rest? flags) 1 0)))
 323                            '()))
 324            (allow-other-keys? . ,(allow-other-keys? flags))))))
 325
 326 (define (find-first-arity context base addr)
 327   (let* ((bv (elf-bytes (debug-context-elf context)))
 328          (text-offset (- addr
 329                          (debug-context-text-base context)
 330                          (debug-context-base context)))
 331          (headers-start (+ base arities-prefix-len))
 332          (headers-end (+ base (bytevector-u32-native-ref bv base))))
 333     ;; FIXME: This is linear search.  Change to binary search.
 334     (let lp ((pos headers-start))
 335       (cond
 336        ((>= pos headers-end) #f)
 337        ((< text-offset (* (arity-low-pc* bv pos) 4))
 338         #f)
 339        ((<= (* (arity-high-pc* bv pos) 4) text-offset)
 340         (lp (+ pos arity-header-len)))
 341        (else
 342         (make-arity context base pos))))))
 343
 344 (define (read-sub-arities context base outer-header-offset)
 345   (let* ((bv (elf-bytes (debug-context-elf context)))
 346          (headers-end (+ base (bytevector-u32-native-ref bv base)))
 347          (low-pc (arity-low-pc* bv outer-header-offset))
 348          (high-pc (arity-high-pc* bv outer-header-offset)))
 349     (let lp ((pos (+ outer-header-offset arity-header-len)) (out '()))
 350       (if (and (< pos headers-end) (<= (arity-high-pc* bv pos) high-pc))
 351           (lp (+ pos arity-header-len)
 352               (cons (make-arity context base pos) out))
 353           (reverse out)))))
 354
 355 (define* (find-program-arities addr #:optional
 356                                (context (find-debug-context addr)))
 357   (and=>
 358    (and context
 359         (elf-section-by-name (debug-context-elf context) ".guile.arities"))
 360    (lambda (sec)
 361      (let* ((base (elf-section-offset sec))
 362             (first (find-first-arity context base addr)))
 363        ;; FIXME: Handle case-lambda arities.
 364        (cond
 365         ((not first) '())
 366         ((arity-is-case-lambda? first)
 367          (read-sub-arities context base (arity-header-offset first)))
 368         (else (list first)))))))
 369
 370 (define* (program-minimum-arity addr #:optional
 371                                 (context (find-debug-context addr)))
 372   (and=>
 373    (and context
 374         (elf-section-by-name (debug-context-elf context) ".guile.arities"))
 375    (lambda (sec)
 376      (let* ((base (elf-section-offset sec))
 377             (first (find-first-arity context base addr)))
 378        (if (arity-is-case-lambda? first)
 379            (list 0 0 #t) ;; FIXME: be more precise.
 380            (list (arity-nreq first)
 381                  (arity-nopt first)
 382                  (arity-has-rest? first)))))))
 383
 384 (define* (find-program-docstring addr #:optional
 385                                  (context (find-debug-context addr)))
 386   (and=>
 387    (and context
 388         (elf-section-by-name (debug-context-elf context) ".guile.docstrs"))
 389    (lambda (sec)
 390      ;; struct docstr {
 391      ;;   uint32_t pc;
 392      ;;   uint32_t str;
 393      ;; }
 394      (define docstr-len 8)
 395      (let* ((start (elf-section-offset sec))
 396             (end (+ start (elf-section-size sec)))
 397             (bv (elf-bytes (debug-context-elf context)))
 398             (text-offset (- addr
 399                             (debug-context-text-base context)
 400                             (debug-context-base context))))
 401        ;; FIXME: This is linear search.  Change to binary search.
 402        (let lp ((pos start))
 403          (cond
 404           ((>= pos end) #f)
 405           ((< (bytevector-u32-native-ref bv pos) text-offset)
 406            (lp (+ pos docstr-len)))
 407           ((= text-offset (bytevector-u32-native-ref bv pos))
 408            (let ((strtab (elf-section (debug-context-elf context)
 409                                       (elf-section-link sec)))
 410                  (idx (bytevector-u32-native-ref bv (+ pos 4))))
 411              (string-table-ref bv (+ (elf-section-offset strtab) idx))))
 412           (else #f)))))))
 413
 414 (define* (find-program-properties addr #:optional
 415                                   (context (find-debug-context addr)))
 416   (define (add-name-and-docstring props)
 417     (define (maybe-acons k v tail)
 418       (if v (acons k v tail) tail))
 419     (let ((name (and=> (find-program-debug-info addr context)
 420                        program-debug-info-name))
 421           (docstring (find-program-docstring addr context)))
 422       (maybe-acons 'name name
 423                    (maybe-acons 'documentation docstring props))))
 424   (add-name-and-docstring
 425    (cond
 426     ((and context
 427           (elf-section-by-name (debug-context-elf context) ".guile.procprops"))
 428      => (lambda (sec)
 429           ;; struct procprop {
 430           ;;   uint32_t pc;
 431           ;;   uint32_t offset;
 432           ;; }
 433           (define procprop-len 8)
 434           (let* ((start (elf-section-offset sec))
 435                  (end (+ start (elf-section-size sec)))
 436                  (bv (elf-bytes (debug-context-elf context)))
 437                  (text-offset (- addr
 438                                  (debug-context-text-base context)
 439                                  (debug-context-base context))))
 440             (define (unpack-scm addr)
 441               (pointer->scm (make-pointer addr)))
 442             (define (load-non-immediate offset)
 443               (unpack-scm (+ (debug-context-base context) offset)))
 444             ;; FIXME: This is linear search.  Change to binary search.
 445             (let lp ((pos start))
 446               (cond
 447                ((>= pos end) '())
 448                ((< text-offset (bytevector-u32-native-ref bv pos))
 449                 (lp (+ pos procprop-len)))
 450                ((> text-offset (bytevector-u32-native-ref bv pos))
 451                 '())
 452                (else
 453                 (load-non-immediate
 454                  (bytevector-u32-native-ref bv (+ pos 4)))))))))
 455     (else '()))))
 456
 457 (define-record-type <source>
 458   (make-source pre-pc file line column)
 459   source?
 460   (pre-pc source-pre-pc)
 461   (file source-file)
 462   (line source-line)
 463   (column source-column))
 464
 465 (define (make-source/dwarf pc file line column)
 466   (make-source pc file
 467                ;; Convert DWARF-numbered (1-based) lines and
 468                ;; columns to Guile conventions (0-based).
 469                (and line (1- line)) (and column (1- column))))
 470
 471 ;; FIXME
 472 (define (source-post-pc source)
 473   (source-pre-pc source))
 474
 475 ;; Lines are zero-indexed inside Guile, but users expect them to be
 476 ;; one-indexed. Columns, on the other hand, are zero-indexed to both. Go
 477 ;; figure.
 478 (define (source-line-for-user source)
 479   (1+ (source-line source)))
 480
 481 (define* (find-source-for-addr addr #:optional
 482                                (context (find-debug-context addr))
 483                                #:key exact?)
 484   (and=>
 485    (and context
 486         (false-if-exception
 487          (elf->dwarf-context (debug-context-elf context))))
 488    (lambda (dwarf-ctx)
 489      (let* ((base (debug-context-base context))
 490             (pc (- addr base)))
 491        (or-map (lambda (die)
 492                  (and=>
 493                   (die-line-prog die)
 494                   (lambda (prog)
 495                     (call-with-values
 496                         (lambda () (line-prog-scan-to-pc prog pc))
 497                       (lambda (pc* file line col)
 498                         (and pc* (or (= pc pc*) (not exact?))
 499                              (make-source/dwarf (+ pc* base)
 500                                                 file line col)))))))
 501                (read-die-roots dwarf-ctx))))))
 502
 503 (define* (find-program-die addr #:optional
 504                            (context (find-debug-context addr)))
 505   (and=> (and context
 506               (false-if-exception
 507                (elf->dwarf-context (debug-context-elf context))))
 508          (lambda (dwarf-ctx)
 509            (find-die-by-pc (read-die-roots dwarf-ctx)
 510                            (- addr (debug-context-base context))))))
 511
 512 (define* (find-program-sources addr #:optional
 513                                (context (find-debug-context addr)))
 514   (cond
 515    ((find-program-die addr context)
 516     => (lambda (die)
 517          (let* ((base (debug-context-base context))
 518                 (low-pc (die-ref die 'low-pc))
 519                 (high-pc (die-high-pc die))
 520                 (prog (let line-prog ((die die))
 521                         (and die
 522                              (or (die-line-prog die)
 523                                  (line-prog (ctx-die (die-ctx die))))))))
 524            (cond
 525             ((and low-pc high-pc prog)
 526              (let lp ((sources '()))
 527                (call-with-values (lambda ()
 528                                    (if (null? sources)
 529                                        (line-prog-scan-to-pc prog low-pc)
 530                                        (line-prog-advance prog)))
 531                  (lambda (pc file line col)
 532                    (if (and pc (< pc high-pc))
 533                        ;; For the first source, it's probable that the
 534                        ;; address of the line program is before the
 535                        ;; low-pc, since the line program is for the
 536                        ;; entire compilation unit, and there are no
 537                        ;; redundant "rows" in the line program.
 538                        ;; Therefore in that case use the addr of low-pc
 539                        ;; instead of the one we got back.
 540                        (let ((addr (+ (if (null? sources) low-pc pc) base)))
 541                          (lp (cons (make-source/dwarf addr file line col)
 542                                    sources)))
 543                        (reverse sources))))))
 544             (else '())))))
 545    (else '())))