module/system/vm/traps.scm

   1 ;;; Traps: stepping, breakpoints, and such.
   2
   3 ;; Copyright (C)  2010, 2012, 2013, 2014 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 debugging capabilities come from the hooks that its VM
  22 ;;; provides. For example, there is a hook that is fired when a function
  23 ;;; is called, and even a hook that gets fired at every retired
  24 ;;; instruction.
  25 ;;;
  26 ;;; But as the firing of these hooks is interleaved with the program
  27 ;;; execution, if we want to debug a program, we have to write an
  28 ;;; imperative program that mutates the state of these hooks, and to
  29 ;;; dispatch the hooks to a more semantic context.
  30 ;;;
  31 ;;; For example if we have placed a breakpoint at foo.scm:38, and
  32 ;;; determined that that location maps to the 18th instruction in
  33 ;;; procedure `bar', then we will need per-instruction hooks within
  34 ;;; `bar' -- but when running other procedures, we can have the
  35 ;;; per-instruction hooks off.
  36 ;;;
  37 ;;; Our approach is to define "traps". The behavior of a trap is
  38 ;;; specified when the trap is created. After creation, traps expose a
  39 ;;; limited, uniform interface: they are either on or off.
  40 ;;;
  41 ;;; To take our foo.scm:38 example again, we can define a trap that
  42 ;;; calls a function when control transfers to that source line --
  43 ;;; trap-at-source-location below. Calling the trap-at-source-location
  44 ;;; function adds to the VM hooks in such at way that it can do its job.
  45 ;;; The result of calling the function is a "disable-hook" closure that,
  46 ;;; when called, will turn off that trap.
  47 ;;;
  48 ;;; The result of calling the "disable-hook" closure, in turn, is an
  49 ;;; "enable-hook" closure, which when called turns the hook back on, and
  50 ;;; returns a "disable-hook" closure.
  51 ;;;
  52 ;;; It's a little confusing. The summary is, call these functions to add
  53 ;;; a trap; and call their return value to disable the trap.
  54 ;;;
  55 ;;; Code:
  56
  57 (define-module (system vm traps)
  58   #:use-module (system base pmatch)
  59   #:use-module (system vm vm)
  60   #:use-module (system vm debug)
  61   #:use-module (system vm frame)
  62   #:use-module (system vm program)
  63   #:use-module (system xref)
  64   #:use-module (rnrs bytevectors)
  65   #:export (trap-at-procedure-call
  66             trap-in-procedure
  67             trap-instructions-in-procedure
  68             trap-at-procedure-ip-in-range
  69             trap-at-source-location
  70             trap-frame-finish
  71             trap-in-dynamic-extent
  72             trap-calls-in-dynamic-extent
  73             trap-instructions-in-dynamic-extent
  74             trap-calls-to-procedure
  75             trap-matching-instructions))
  76
  77 (define-syntax arg-check
  78   (syntax-rules ()
  79     ((_ arg predicate? message)
  80      (if (not (predicate? arg))
  81          (error "bad argument ~a: ~a" 'arg message)))
  82     ((_ arg predicate?)
  83      (if (not (predicate? arg))
  84          (error "bad argument ~a: expected ~a" 'arg 'predicate?)))))
  85
  86 (define (new-disabled-trap enable disable)
  87   (let ((enabled? #f))
  88     (define-syntax disabled?
  89       (identifier-syntax
  90        (disabled? (not enabled?))
  91        ((set! disabled? val) (set! enabled? (not val)))))
  92
  93     (define* (enable-trap #:optional frame)
  94       (if enabled? (error "trap already enabled"))
  95       (enable frame)
  96       (set! enabled? #t)
  97       disable-trap)
  98
  99     (define* (disable-trap #:optional frame)
 100       (if disabled? (error "trap already disabled"))
 101       (disable frame)
 102       (set! disabled? #t)
 103       enable-trap)
 104
 105     enable-trap))
 106
 107 (define (new-enabled-trap frame enable disable)
 108   ((new-disabled-trap enable disable) frame))
 109
 110 ;; Returns an absolute IP.
 111 (define (program-last-ip prog)
 112   (let ((pdi (find-program-debug-info (program-code prog))))
 113     (and pdi (program-debug-info-size pdi))))
 114
 115 (define (frame-matcher proc match-code?)
 116   (let ((proc (if (struct? proc)
 117                   (procedure proc)
 118                   proc)))
 119     (if match-code?
 120         (if (program? proc)
 121             (let ((start (program-code proc))
 122                   (end (program-last-ip proc)))
 123               (lambda (frame)
 124                 (let ((ip (frame-instruction-pointer frame)))
 125                   (and (<= start ip) (< ip end)))))
 126             (lambda (frame) #f))
 127         (lambda (frame)
 128           (eq? (frame-procedure frame) proc)))))
 129
 130 ;; A basic trap, fires when a procedure is called.
 131 ;;
 132 (define* (trap-at-procedure-call proc handler #:key (closure? #f)
 133                                  (our-frame? (frame-matcher proc closure?)))
 134   (arg-check proc procedure?)
 135   (arg-check handler procedure?)
 136   (let ()
 137     (define (apply-hook frame)
 138       (if (our-frame? frame)
 139           (handler frame)))
 140
 141     (new-enabled-trap
 142      #f
 143      (lambda (frame)
 144        (add-hook! (vm-apply-hook) apply-hook))
 145      (lambda (frame)
 146        (remove-hook! (vm-apply-hook) apply-hook)))))
 147
 148 ;; A more complicated trap, traps when control enters a procedure.
 149 ;;
 150 ;; Control can enter a procedure via:
 151 ;;  * A procedure call.
 152 ;;  * A return to a procedure's frame on the stack.
 153 ;;  * A continuation returning directly to an application of this
 154 ;;    procedure.
 155 ;;
 156 ;; Control can leave a procedure via:
 157 ;;  * A normal return from the procedure.
 158 ;;  * An application of another procedure.
 159 ;;  * An invocation of a continuation.
 160 ;;  * An abort.
 161 ;;
 162 (define* (trap-in-procedure proc enter-handler exit-handler
 163                             #:key current-frame (closure? #f)
 164                             (our-frame? (frame-matcher proc closure?)))
 165   (arg-check proc procedure?)
 166   (arg-check enter-handler procedure?)
 167   (arg-check exit-handler procedure?)
 168   (let ((in-proc? #f))
 169     (define (enter-proc frame)
 170       (if in-proc?
 171           (warn "already in proc" frame)
 172           (begin
 173             (enter-handler frame)
 174             (set! in-proc? #t))))
 175
 176     (define (exit-proc frame)
 177       (if in-proc?
 178           (begin
 179             (exit-handler frame)
 180             (set! in-proc? #f))
 181           (warn "not in proc" frame)))
 182
 183     (define (apply-hook frame)
 184       (if in-proc?
 185           (exit-proc frame))
 186       (if (our-frame? frame)
 187           (enter-proc frame)))
 188
 189     (define (pop-cont-hook frame . values)
 190       (if in-proc?
 191           (exit-proc frame))
 192       (if (our-frame? frame)
 193           (enter-proc frame)))
 194
 195     (define (abort-hook frame . values)
 196       (if in-proc?
 197           (exit-proc frame))
 198       (if (our-frame? frame)
 199           (enter-proc frame)))
 200
 201     (new-enabled-trap
 202      current-frame
 203      (lambda (frame)
 204        (add-hook! (vm-apply-hook) apply-hook)
 205        (add-hook! (vm-pop-continuation-hook) pop-cont-hook)
 206        (add-hook! (vm-abort-continuation-hook) abort-hook)
 207        (if (and frame (our-frame? frame))
 208            (enter-proc frame)))
 209      (lambda (frame)
 210        (if in-proc?
 211            (exit-proc frame))
 212        (remove-hook! (vm-apply-hook) apply-hook)
 213        (remove-hook! (vm-pop-continuation-hook) pop-cont-hook)
 214        (remove-hook! (vm-abort-continuation-hook) abort-hook)))))
 215
 216 ;; Building on trap-in-procedure, we have trap-instructions-in-procedure
 217 ;;
 218 (define* (trap-instructions-in-procedure proc next-handler exit-handler
 219                                          #:key current-frame (closure? #f)
 220                                          (our-frame?
 221                                           (frame-matcher proc closure?)))
 222   (arg-check proc procedure?)
 223   (arg-check next-handler procedure?)
 224   (arg-check exit-handler procedure?)
 225   (let ()
 226     (define (next-hook frame)
 227       (if (our-frame? frame)
 228           (next-handler frame)))
 229
 230     (define (enter frame)
 231       (add-hook! (vm-next-hook) next-hook)
 232       (if frame (next-hook frame)))
 233
 234     (define (exit frame)
 235       (exit-handler frame)
 236       (remove-hook! (vm-next-hook) next-hook))
 237
 238     (trap-in-procedure proc enter exit
 239                        #:current-frame current-frame
 240                        #:our-frame? our-frame?)))
 241
 242 (define (non-negative-integer? x)
 243   (and (number? x) (integer? x) (exact? x) (not (negative? x))))
 244
 245 (define (positive-integer? x)
 246   (and (number? x) (integer? x) (exact? x) (positive? x)))
 247
 248 (define (range? x)
 249   (and (list? x)
 250        (and-map (lambda (x)
 251                   (and (pair? x)
 252                        (non-negative-integer? (car x))
 253                        (non-negative-integer? (cdr x))))
 254                 x)))
 255
 256 (define (in-range? range i)
 257   (or-map (lambda (bounds)
 258             (and (<= (car bounds) i)
 259                  (< i (cdr bounds))))
 260           range))
 261
 262 ;; Building on trap-instructions-in-procedure, we have
 263 ;; trap-at-procedure-ip-in-range.
 264 ;;
 265 (define* (trap-at-procedure-ip-in-range proc range handler
 266                                         #:key current-frame (closure? #f)
 267                                         (our-frame?
 268                                          (frame-matcher proc closure?)))
 269   (arg-check proc procedure?)
 270   (arg-check range range?)
 271   (arg-check handler procedure?)
 272   (let ((fp-stack '()))
 273     (define (cull-frames! fp)
 274       (let lp ((frames fp-stack))
 275         (if (and (pair? frames) (< (car frames) fp))
 276             (lp (cdr frames))
 277             (set! fp-stack frames))))
 278
 279     (define (next-handler frame)
 280       (let ((fp (frame-address frame))
 281             (ip (frame-instruction-pointer frame)))
 282         (cull-frames! fp)
 283         (let ((now-in-range? (in-range? range ip))
 284               (was-in-range? (and (pair? fp-stack) (= (car fp-stack) fp))))
 285           (cond
 286            (was-in-range?
 287             (if (not now-in-range?)
 288                 (set! fp-stack (cdr fp-stack))))
 289            (now-in-range?
 290             (set! fp-stack (cons fp fp-stack))
 291             (handler frame))))))
 292
 293     (define (exit-handler frame)
 294       (if (and (pair? fp-stack)
 295                (= (car fp-stack) (frame-address frame)))
 296           (set! fp-stack (cdr fp-stack))))
 297
 298     (trap-instructions-in-procedure proc next-handler exit-handler
 299                                     #:current-frame current-frame
 300                                     #:our-frame? our-frame?)))
 301
 302 (define (program-sources-by-line proc file)
 303   (cond
 304    ((program? proc)
 305     (let ((code (program-code proc)))
 306       (let lp ((sources (program-sources proc))
 307                (out '()))
 308         (if (pair? sources)
 309             (lp (cdr sources)
 310                 (pmatch (car sources)
 311                   ((,start-ip ,start-file ,start-line . ,start-col)
 312                    (if (equal? start-file file)
 313                        (acons start-line
 314                               (if (pair? (cdr sources))
 315                                   (pmatch (cadr sources)
 316                                     ((,end-ip . _)
 317                                      (cons (+ start-ip code)
 318                                            (+ end-ip code)))
 319                                     (else (error "unexpected")))
 320                                   (cons (+ start-ip code)
 321                                         (program-last-ip proc)))
 322                               out)
 323                        out))
 324                   (else (error "unexpected"))))
 325             (let ((alist '()))
 326               (for-each
 327                (lambda (pair)
 328                  (set! alist
 329                        (assv-set! alist (car pair)
 330                                   (cons (cdr pair)
 331                                         (or (assv-ref alist (car pair))
 332                                             '())))))
 333                out)
 334               (sort! alist (lambda (x y) (< (car x) (car y))))
 335               alist)))))
 336    (else '())))
 337
 338 (define (source->ip-range proc file line)
 339   (or (or-map (lambda (line-and-ranges)
 340                 (cond
 341                  ((= (car line-and-ranges) line)
 342                   (cdr line-and-ranges))
 343                  ((> (car line-and-ranges) line)
 344                   (warn "no instructions found at" file ":" line
 345                         "; using line" (car line-and-ranges) "instead")
 346                   (cdr line-and-ranges))
 347                  (else #f)))
 348               (program-sources-by-line proc file))
 349       (begin
 350         (warn "no instructions found for" file ":" line)
 351         '())))
 352
 353 (define (source-closures-or-procedures file line)
 354   (let ((closures (source-closures file line)))
 355     (if (pair? closures)
 356         (values closures #t)
 357         (values (source-procedures file line) #f))))
 358
 359 ;; Building on trap-on-instructions-in-procedure, we have
 360 ;; trap-at-source-location. The parameter `user-line' is one-indexed, as
 361 ;; a user counts lines, instead of zero-indexed, as Guile counts lines.
 362 ;;
 363 (define* (trap-at-source-location file user-line handler #:key current-frame)
 364   (arg-check file string?)
 365   (arg-check user-line positive-integer?)
 366   (arg-check handler procedure?)
 367   (let ((traps #f))
 368     (call-with-values
 369         (lambda () (source-closures-or-procedures file (1- user-line)))
 370       (lambda (procs closures?)
 371         (new-enabled-trap
 372          current-frame
 373          (lambda (frame)
 374            (set! traps
 375                  (map
 376                   (lambda (proc)
 377                     (let ((range (source->ip-range proc file (1- user-line))))
 378                       (trap-at-procedure-ip-in-range proc range handler
 379                                                      #:current-frame current-frame
 380                                                      #:closure? closures?)))
 381                   procs))
 382            (if (null? traps)
 383                (error "No procedures found at ~a:~a." file user-line)))
 384          (lambda (frame)
 385            (for-each (lambda (trap) (trap frame)) traps)
 386            (set! traps #f)))))))
 387
 388 \f
 389
 390 ;; On a different tack, now we're going to build up a set of traps that
 391 ;; do useful things during the dynamic extent of a procedure's
 392 ;; application. First, a trap for when a frame returns.
 393 ;;
 394 (define (trap-frame-finish frame return-handler abort-handler)
 395   (arg-check frame frame?)
 396   (arg-check return-handler procedure?)
 397   (arg-check abort-handler procedure?)
 398   (let ((fp (frame-address frame)))
 399     (define (pop-cont-hook frame . values)
 400       (if (and fp (< (frame-address frame) fp))
 401           (begin
 402             (set! fp #f)
 403             (apply return-handler frame values))))
 404
 405     (define (abort-hook frame . values)
 406       (if (and fp (< (frame-address frame) fp))
 407           (begin
 408             (set! fp #f)
 409             (apply abort-handler frame values))))
 410
 411     (new-enabled-trap
 412      frame
 413      (lambda (frame)
 414        (if (not fp)
 415            (error "return-or-abort traps may only be enabled once"))
 416        (add-hook! (vm-pop-continuation-hook) pop-cont-hook)
 417        (add-hook! (vm-abort-continuation-hook) abort-hook))
 418      (lambda (frame)
 419        (set! fp #f)
 420        (remove-hook! (vm-pop-continuation-hook) pop-cont-hook)
 421        (remove-hook! (vm-abort-continuation-hook) abort-hook)))))
 422
 423 ;; A more traditional dynamic-wind trap. Perhaps this should not be
 424 ;; based on the above trap-frame-finish?
 425 ;;
 426 (define* (trap-in-dynamic-extent proc enter-handler return-handler abort-handler
 427                                  #:key current-frame (closure? #f)
 428                                  (our-frame? (frame-matcher proc closure?)))
 429   (arg-check proc procedure?)
 430   (arg-check enter-handler procedure?)
 431   (arg-check return-handler procedure?)
 432   (arg-check abort-handler procedure?)
 433   (let ((exit-trap #f))
 434     (define (return-hook frame . values)
 435       (exit-trap frame) ; disable the return/abort trap.
 436       (set! exit-trap #f)
 437       (return-handler frame))
 438
 439     (define (abort-hook frame . values)
 440       (exit-trap frame) ; disable the return/abort trap.
 441       (set! exit-trap #f)
 442       (abort-handler frame))
 443
 444     (define (apply-hook frame)
 445       (if (and (not exit-trap) (our-frame? frame))
 446           (begin
 447             (enter-handler frame)
 448             (set! exit-trap
 449                   (trap-frame-finish frame return-hook abort-hook)))))
 450
 451     (new-enabled-trap
 452      current-frame
 453      (lambda (frame)
 454        (add-hook! (vm-apply-hook) apply-hook))
 455      (lambda (frame)
 456        (if exit-trap
 457            (abort-hook frame))
 458        (set! exit-trap #f)
 459        (remove-hook! (vm-apply-hook) apply-hook)))))
 460
 461 ;; Trapping all procedure calls within a dynamic extent, recording the
 462 ;; depth of the call stack relative to the original procedure.
 463 ;;
 464 (define* (trap-calls-in-dynamic-extent proc apply-handler return-handler
 465                                        #:key current-frame (closure? #f)
 466                                        (our-frame?
 467                                         (frame-matcher proc closure?)))
 468   (arg-check proc procedure?)
 469   (arg-check apply-handler procedure?)
 470   (arg-check return-handler procedure?)
 471   (let ((*call-depth* 0))
 472     (define (trace-push frame)
 473       (set! *call-depth* (1+ *call-depth*)))
 474
 475     (define (trace-pop frame . values)
 476       (apply return-handler frame *call-depth* values)
 477       (set! *call-depth* (1- *call-depth*)))
 478
 479     (define (trace-apply frame)
 480       (apply-handler frame *call-depth*))
 481
 482     ;; FIXME: recalc depth on abort
 483
 484     (define (enter frame)
 485       (add-hook! (vm-push-continuation-hook) trace-push)
 486       (add-hook! (vm-pop-continuation-hook) trace-pop)
 487       (add-hook! (vm-apply-hook) trace-apply))
 488
 489     (define (leave frame)
 490       (remove-hook! (vm-push-continuation-hook) trace-push)
 491       (remove-hook! (vm-pop-continuation-hook) trace-pop)
 492       (remove-hook! (vm-apply-hook) trace-apply))
 493
 494     (define (return frame)
 495       (leave frame))
 496
 497     (define (abort frame)
 498       (leave frame))
 499
 500     (trap-in-dynamic-extent proc enter return abort
 501                             #:current-frame current-frame
 502                             #:our-frame? our-frame?)))
 503
 504 ;; Trapping all retired intructions within a dynamic extent.
 505 ;;
 506 (define* (trap-instructions-in-dynamic-extent proc next-handler
 507                                               #:key current-frame (closure? #f)
 508                                               (our-frame?
 509                                                (frame-matcher proc closure?)))
 510   (arg-check proc procedure?)
 511   (arg-check next-handler procedure?)
 512   (let ()
 513     (define (trace-next frame)
 514       (next-handler frame))
 515
 516     (define (enter frame)
 517       (add-hook! (vm-next-hook) trace-next))
 518
 519     (define (leave frame)
 520       (remove-hook! (vm-next-hook) trace-next))
 521
 522     (define (return frame)
 523       (leave frame))
 524
 525     (define (abort frame)
 526       (leave frame))
 527
 528     (trap-in-dynamic-extent proc enter return abort
 529                             #:current-frame current-frame
 530                             #:our-frame? our-frame?)))
 531
 532 ;; Traps calls and returns for a given procedure, keeping track of the call depth.
 533 ;;
 534 (define (trap-calls-to-procedure proc apply-handler return-handler)
 535   (arg-check proc procedure?)
 536   (arg-check apply-handler procedure?)
 537   (arg-check return-handler procedure?)
 538   (let ((pending-finish-traps '())
 539         (last-fp #f))
 540     (define (apply-hook frame)
 541       (let ((depth (length pending-finish-traps)))
 542
 543         (apply-handler frame depth)
 544
 545         (if (not (eqv? (frame-address frame) last-fp))
 546             (let ((finish-trap #f))
 547               (define (frame-finished frame)
 548                 (finish-trap frame) ;; disables the trap.
 549                 (set! pending-finish-traps
 550                       (delq finish-trap pending-finish-traps))
 551                 (set! finish-trap #f))
 552
 553               (define (return-hook frame . values)
 554                 (frame-finished frame)
 555                 (apply return-handler frame depth values))
 556
 557               ;; FIXME: abort handler?
 558               (define (abort-hook frame . values)
 559                 (frame-finished frame))
 560
 561               (set! finish-trap
 562                     (trap-frame-finish frame return-hook abort-hook))
 563               (set! pending-finish-traps
 564                     (cons finish-trap pending-finish-traps))))))
 565
 566     ;; The basic idea is that we install one trap that fires for calls,
 567     ;; but that each call installs its own finish trap. Those finish
 568     ;; traps remove themselves as their frames finish or abort.
 569     ;;
 570     ;; However since to the outside world we present the interface of
 571     ;; just being one trap, disabling this calls-to-procedure trap
 572     ;; should take care of disabling all of the pending finish traps. We
 573     ;; keep track of pending traps through the pending-finish-traps
 574     ;; list.
 575     ;;
 576     ;; So since we know that the trap-at-procedure will be enabled, and
 577     ;; thus returning a disable closure, we make sure to wrap that
 578     ;; closure in something that will disable pending finish traps.
 579     (define (with-pending-finish-disablers trap)
 580       (define (with-pending-finish-enablers trap)
 581         (lambda* (#:optional frame)
 582           (with-pending-finish-disablers (trap frame))))
 583
 584       (lambda* (#:optional frame)
 585         (for-each (lambda (disable) (disable frame))
 586                   pending-finish-traps)
 587         (set! pending-finish-traps '())
 588         (with-pending-finish-enablers (trap frame))))
 589
 590     (with-pending-finish-disablers
 591      (trap-at-procedure-call proc apply-hook))))
 592
 593 ;; Trap when the source location changes.
 594 ;;
 595 (define (trap-matching-instructions frame-pred handler)
 596   (arg-check frame-pred procedure?)
 597   (arg-check handler procedure?)
 598   (let ()
 599     (define (next-hook frame)
 600       (if (frame-pred frame)
 601           (handler frame)))
 602
 603     (new-enabled-trap
 604      #f
 605      (lambda (frame)
 606        (add-hook! (vm-next-hook) next-hook))
 607      (lambda (frame)
 608        (remove-hook! (vm-next-hook) next-hook)))))