traps.scm 22 KB

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