traps.scm 21 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623
  1. ;;; Traps: stepping, breakpoints, and such.
  2. ;; Copyright (C) 2010,2012-2014,2017-2018 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 (ice-9 match)
  55. #:use-module (system vm vm)
  56. #:use-module (system vm debug)
  57. #:use-module (system vm program)
  58. #:use-module (system xref)
  59. #:export (trap-at-procedure-call
  60. trap-in-procedure
  61. trap-instructions-in-procedure
  62. trap-at-procedure-ip-in-range
  63. trap-at-source-location
  64. trap-frame-finish
  65. trap-in-dynamic-extent
  66. trap-calls-in-dynamic-extent
  67. trap-instructions-in-dynamic-extent
  68. trap-calls-to-procedure
  69. trap-matching-instructions))
  70. (define-syntax arg-check
  71. (syntax-rules ()
  72. ((_ arg predicate? message)
  73. (if (not (predicate? arg))
  74. (error (format #f "bad argument ~a: ~a" 'arg message))))
  75. ((_ arg predicate?)
  76. (if (not (predicate? arg))
  77. (error (format #f "bad argument ~a: expected ~a" 'arg 'predicate?))))))
  78. (define (new-disabled-trap enable disable)
  79. (let ((enabled? #f))
  80. (define-syntax disabled?
  81. (identifier-syntax
  82. (disabled? (not enabled?))
  83. ((set! disabled? val) (set! enabled? (not val)))))
  84. (define* (enable-trap #:optional frame)
  85. (if enabled? (error "trap already enabled"))
  86. (enable frame)
  87. (set! enabled? #t)
  88. disable-trap)
  89. (define* (disable-trap #:optional frame)
  90. (if disabled? (error "trap already disabled"))
  91. (disable frame)
  92. (set! disabled? #t)
  93. enable-trap)
  94. enable-trap))
  95. (define (new-enabled-trap frame enable disable)
  96. ((new-disabled-trap enable disable) frame))
  97. ;; Returns an absolute IP.
  98. (define (program-last-ip prog)
  99. (let ((pdi (find-program-debug-info (program-code prog))))
  100. (and pdi
  101. (+ (program-debug-info-addr pdi)
  102. (program-debug-info-size pdi)))))
  103. (define (frame-matcher proc)
  104. (let ((proc (if (struct? proc)
  105. (procedure proc)
  106. proc)))
  107. (cond
  108. ((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)
  114. end (< ip end))))))
  115. ((struct? proc)
  116. (frame-matcher (procedure proc)))
  117. (else
  118. (error "Not a VM program" proc)))))
  119. ;; A basic trap, fires when a procedure is called.
  120. ;;
  121. (define* (trap-at-procedure-call proc handler #:key
  122. (our-frame? (frame-matcher proc)))
  123. (arg-check proc procedure?)
  124. (arg-check handler procedure?)
  125. (let ()
  126. (define (apply-hook frame)
  127. (if (our-frame? frame)
  128. (handler frame)))
  129. (new-enabled-trap
  130. #f
  131. (lambda (frame)
  132. (vm-add-apply-hook! apply-hook))
  133. (lambda (frame)
  134. (vm-remove-apply-hook! apply-hook)))))
  135. ;; A more complicated trap, traps when control enters a procedure.
  136. ;;
  137. ;; Control can enter a procedure via:
  138. ;; * A procedure call.
  139. ;; * A return to a procedure's frame on the stack.
  140. ;; * A continuation returning directly to an application of this
  141. ;; procedure.
  142. ;;
  143. ;; Control can leave a procedure via:
  144. ;; * A normal return from the procedure.
  145. ;; * An application of another procedure.
  146. ;; * An invocation of a continuation.
  147. ;; * An abort.
  148. ;;
  149. (define* (trap-in-procedure proc enter-handler exit-handler
  150. #:key current-frame
  151. (our-frame? (frame-matcher proc)))
  152. (arg-check proc procedure?)
  153. (arg-check enter-handler procedure?)
  154. (arg-check exit-handler procedure?)
  155. (let ((in-proc? #f))
  156. (define (enter-proc frame)
  157. (if in-proc?
  158. (warn "already in proc" frame)
  159. (begin
  160. (enter-handler frame)
  161. (set! in-proc? #t))))
  162. (define (exit-proc frame)
  163. (if in-proc?
  164. (begin
  165. (exit-handler frame)
  166. (set! in-proc? #f))
  167. (warn "not in proc" frame)))
  168. (define (apply-hook frame)
  169. (if in-proc?
  170. (exit-proc frame))
  171. (if (our-frame? frame)
  172. (enter-proc frame)))
  173. (define (return-hook frame)
  174. (if in-proc?
  175. (exit-proc frame))
  176. (let ((prev (frame-previous frame)))
  177. (if (our-frame? prev)
  178. (enter-proc prev))))
  179. (define (abort-hook frame)
  180. (if in-proc?
  181. (exit-proc frame))
  182. (if (our-frame? frame)
  183. (enter-proc frame)))
  184. (new-enabled-trap
  185. current-frame
  186. (lambda (frame)
  187. (vm-add-apply-hook! apply-hook)
  188. (vm-add-return-hook! return-hook)
  189. (vm-add-abort-hook! abort-hook)
  190. (if (and frame (our-frame? frame))
  191. (enter-proc frame)))
  192. (lambda (frame)
  193. (if in-proc?
  194. (exit-proc frame))
  195. (vm-remove-apply-hook! apply-hook)
  196. (vm-remove-return-hook! return-hook)
  197. (vm-remove-abort-hook! abort-hook)))))
  198. ;; Building on trap-in-procedure, we have trap-instructions-in-procedure
  199. ;;
  200. (define* (trap-instructions-in-procedure proc next-handler exit-handler
  201. #:key current-frame
  202. (our-frame? (frame-matcher proc)))
  203. (arg-check proc procedure?)
  204. (arg-check next-handler procedure?)
  205. (arg-check exit-handler procedure?)
  206. (let ()
  207. (define (next-hook frame)
  208. (if (our-frame? frame)
  209. (next-handler frame)))
  210. (define (enter frame)
  211. (vm-add-next-hook! next-hook)
  212. (if frame (next-hook frame)))
  213. (define (exit frame)
  214. (exit-handler frame)
  215. (vm-remove-next-hook! next-hook))
  216. (trap-in-procedure proc enter exit
  217. #:current-frame current-frame
  218. #:our-frame? our-frame?)))
  219. (define (non-negative-integer? x)
  220. (and (number? x) (integer? x) (exact? x) (not (negative? x))))
  221. (define (positive-integer? x)
  222. (and (number? x) (integer? x) (exact? x) (positive? x)))
  223. (define (range? x)
  224. (and (list? x)
  225. (and-map (lambda (x)
  226. (and (pair? x)
  227. (non-negative-integer? (car x))
  228. (non-negative-integer? (cdr x))))
  229. x)))
  230. (define (in-range? range i)
  231. (or-map (lambda (bounds)
  232. (and (<= (car bounds) i)
  233. (< i (cdr bounds))))
  234. range))
  235. ;; Building on trap-instructions-in-procedure, we have
  236. ;; trap-at-procedure-ip-in-range.
  237. ;;
  238. (define* (trap-at-procedure-ip-in-range proc range handler
  239. #:key current-frame
  240. (our-frame? (frame-matcher proc)))
  241. (arg-check proc procedure?)
  242. (arg-check range range?)
  243. (arg-check handler procedure?)
  244. (let ((fp-stack '()))
  245. (define (cull-frames! fp)
  246. (let lp ((frames fp-stack))
  247. (if (and (pair? frames) (< (car frames) fp))
  248. (lp (cdr frames))
  249. (set! fp-stack frames))))
  250. (define (next-handler frame)
  251. (let ((fp (frame-address frame))
  252. (ip (frame-instruction-pointer frame)))
  253. (cull-frames! fp)
  254. (let ((now-in-range? (in-range? range ip))
  255. (was-in-range? (and (pair? fp-stack) (= (car fp-stack) fp))))
  256. (cond
  257. (was-in-range?
  258. (if (not now-in-range?)
  259. (set! fp-stack (cdr fp-stack))))
  260. (now-in-range?
  261. (set! fp-stack (cons fp fp-stack))
  262. (handler frame))))))
  263. (define (exit-handler frame)
  264. (if (and (pair? fp-stack)
  265. (= (car fp-stack) (frame-address frame)))
  266. (set! fp-stack (cdr fp-stack))))
  267. (trap-instructions-in-procedure proc next-handler exit-handler
  268. #:current-frame current-frame
  269. #:our-frame? our-frame?)))
  270. (define (program-sources-by-line proc file)
  271. (cond
  272. ((program? proc)
  273. (let ((code (program-code proc)))
  274. (let lp ((sources (program-sources proc))
  275. (out '()))
  276. (match sources
  277. (((start-ip start-file start-line . start-col) . sources)
  278. (lp sources
  279. (if (equal? start-file file)
  280. (acons start-line
  281. (cons (+ start-ip code)
  282. (match sources
  283. (((end-ip . _) . _)
  284. (+ end-ip code))
  285. (()
  286. (program-last-ip proc))))
  287. out)
  288. out)))
  289. (()
  290. (let ((alist '()))
  291. (for-each
  292. (lambda (pair)
  293. (set! alist
  294. (assv-set! alist (car pair)
  295. (cons (cdr pair)
  296. (or (assv-ref alist (car pair))
  297. '())))))
  298. out)
  299. (sort! alist (lambda (x y) (< (car x) (car y))))
  300. alist))))))
  301. (else '())))
  302. (define (source->ip-range proc file line)
  303. (or (or-map (lambda (line-and-ranges)
  304. (cond
  305. ((= (car line-and-ranges) line)
  306. (cdr line-and-ranges))
  307. ((> (car line-and-ranges) line)
  308. (warn "no instructions found at" file ":" line
  309. "; using line" (car line-and-ranges) "instead")
  310. (cdr line-and-ranges))
  311. (else #f)))
  312. (program-sources-by-line proc file))
  313. (begin
  314. (warn "no instructions found for" file ":" line)
  315. '())))
  316. (define (source-closures-or-procedures file line)
  317. (let ((closures (source-closures file line)))
  318. (if (pair? closures)
  319. (values closures #t)
  320. (values (source-procedures file line) #f))))
  321. ;; Building on trap-on-instructions-in-procedure, we have
  322. ;; trap-at-source-location. The parameter `user-line' is one-indexed, as
  323. ;; a user counts lines, instead of zero-indexed, as Guile counts lines.
  324. ;;
  325. (define* (trap-at-source-location file user-line handler #:key current-frame)
  326. (arg-check file string?)
  327. (arg-check user-line positive-integer?)
  328. (arg-check handler procedure?)
  329. (let ((traps #f))
  330. (call-with-values
  331. (lambda () (source-closures-or-procedures file (1- user-line)))
  332. (lambda (procs closures?)
  333. (new-enabled-trap
  334. current-frame
  335. (lambda (frame)
  336. (set! traps
  337. (map
  338. (lambda (proc)
  339. (let ((range (source->ip-range proc file (1- user-line))))
  340. (trap-at-procedure-ip-in-range proc range handler
  341. #:current-frame
  342. current-frame)))
  343. procs))
  344. (if (null? traps)
  345. (error
  346. (format #f "No procedures found at ~a:~a." file user-line))))
  347. (lambda (frame)
  348. (for-each (lambda (trap) (trap frame)) traps)
  349. (set! traps #f)))))))
  350. ;; On a different tack, now we're going to build up a set of traps that
  351. ;; do useful things during the dynamic extent of a procedure's
  352. ;; application. First, a trap for when a frame returns.
  353. ;;
  354. (define (trap-frame-finish frame return-handler abort-handler)
  355. (arg-check frame frame?)
  356. (arg-check return-handler procedure?)
  357. (arg-check abort-handler procedure?)
  358. (let ((fp (frame-address frame)))
  359. (define (return-hook frame)
  360. (if (and fp (<= (frame-address frame) fp))
  361. (begin
  362. (set! fp #f)
  363. (return-handler frame))))
  364. (define (abort-hook frame)
  365. (if (and fp (<= (frame-address frame) fp))
  366. (begin
  367. (set! fp #f)
  368. (abort-handler frame))))
  369. (new-enabled-trap
  370. frame
  371. (lambda (frame)
  372. (if (not fp)
  373. (error "return-or-abort traps may only be enabled once"))
  374. (vm-add-return-hook! return-hook)
  375. (vm-add-abort-hook! abort-hook))
  376. (lambda (frame)
  377. (set! fp #f)
  378. (vm-remove-return-hook! return-hook)
  379. (vm-remove-abort-hook! abort-hook)))))
  380. ;; A more traditional dynamic-wind trap. Perhaps this should not be
  381. ;; based on the above trap-frame-finish?
  382. ;;
  383. (define* (trap-in-dynamic-extent proc enter-handler return-handler abort-handler
  384. #:key current-frame
  385. (our-frame? (frame-matcher proc)))
  386. (arg-check proc procedure?)
  387. (arg-check enter-handler procedure?)
  388. (arg-check return-handler procedure?)
  389. (arg-check abort-handler procedure?)
  390. (let ((exit-trap #f))
  391. (define (return-hook frame)
  392. (exit-trap frame) ; disable the return/abort trap.
  393. (set! exit-trap #f)
  394. (return-handler frame))
  395. (define (abort-hook frame)
  396. (exit-trap frame) ; disable the return/abort trap.
  397. (set! exit-trap #f)
  398. (abort-handler frame))
  399. (define (apply-hook frame)
  400. (if (and (not exit-trap) (our-frame? frame))
  401. (begin
  402. (enter-handler frame)
  403. (set! exit-trap
  404. (trap-frame-finish frame return-hook abort-hook)))))
  405. (new-enabled-trap
  406. current-frame
  407. (lambda (frame)
  408. (vm-add-apply-hook! apply-hook))
  409. (lambda (frame)
  410. (if exit-trap
  411. (abort-hook frame))
  412. (set! exit-trap #f)
  413. (vm-remove-apply-hook! apply-hook)))))
  414. ;; Trapping all procedure calls within a dynamic extent, recording the
  415. ;; depth of the call stack relative to the original procedure.
  416. ;;
  417. (define* (trap-calls-in-dynamic-extent proc apply-handler return-handler
  418. #:key current-frame
  419. (our-frame? (frame-matcher proc)))
  420. (arg-check proc procedure?)
  421. (arg-check apply-handler procedure?)
  422. (arg-check return-handler procedure?)
  423. (let ((*stack* '()))
  424. (define (trace-return frame)
  425. (let ((fp* (frame-address frame)))
  426. (let lp ((stack *stack*))
  427. (match stack
  428. (() (values))
  429. ((fp . stack)
  430. (cond
  431. ((> fp fp*)
  432. (set! *stack* stack)
  433. (lp stack))
  434. ((= fp fp*) (set! *stack* stack))
  435. ((< fp fp*) (values)))))))
  436. (return-handler frame (1+ (length *stack*))))
  437. (define (trace-apply frame)
  438. (let ((fp* (frame-address frame)))
  439. (define (same-fp? fp) (= fp fp*))
  440. (define (newer-fp? fp) (> fp fp*))
  441. (let lp ((stack *stack*))
  442. (match stack
  443. (((? same-fp?) . stack)
  444. ;; A tail call, nothing to do.
  445. (values))
  446. (((? newer-fp?) . stack)
  447. ;; Unless there are continuations, we shouldn't get here.
  448. (set! *stack* stack)
  449. (lp stack))
  450. (stack
  451. (set! *stack* (cons fp* stack))))))
  452. (apply-handler frame (length *stack*)))
  453. (define (enter frame)
  454. (vm-add-return-hook! trace-return)
  455. (vm-add-apply-hook! trace-apply))
  456. (define (leave frame)
  457. (vm-remove-return-hook! trace-return)
  458. (vm-remove-apply-hook! trace-apply))
  459. (define (return frame)
  460. (leave frame))
  461. (define (abort frame)
  462. (leave frame))
  463. (trap-in-dynamic-extent proc enter return abort
  464. #:current-frame current-frame
  465. #:our-frame? our-frame?)))
  466. ;; Trapping all retired intructions within a dynamic extent.
  467. ;;
  468. (define* (trap-instructions-in-dynamic-extent proc next-handler
  469. #:key current-frame
  470. (our-frame? (frame-matcher proc)))
  471. (arg-check proc procedure?)
  472. (arg-check next-handler procedure?)
  473. (let ()
  474. (define (trace-next frame)
  475. (next-handler frame))
  476. (define (enter frame)
  477. (vm-add-next-hook! trace-next))
  478. (define (leave frame)
  479. (vm-remove-next-hook! trace-next))
  480. (define (return frame)
  481. (leave frame))
  482. (define (abort frame)
  483. (leave frame))
  484. (trap-in-dynamic-extent proc enter return abort
  485. #:current-frame current-frame
  486. #:our-frame? our-frame?)))
  487. ;; Traps calls and returns for a given procedure, keeping track of the call depth.
  488. ;;
  489. (define (trap-calls-to-procedure proc apply-handler return-handler)
  490. (arg-check proc procedure?)
  491. (arg-check apply-handler procedure?)
  492. (arg-check return-handler procedure?)
  493. (let ((pending-finish-traps '())
  494. (last-fp #f))
  495. (define (apply-hook frame)
  496. (let ((depth (length pending-finish-traps)))
  497. (apply-handler frame depth)
  498. (if (not (eqv? (frame-address frame) last-fp))
  499. (let ((finish-trap #f))
  500. (define (frame-finished frame)
  501. (finish-trap frame) ;; disables the trap.
  502. (set! pending-finish-traps
  503. (delq finish-trap pending-finish-traps))
  504. (set! finish-trap #f))
  505. (define (return-hook frame)
  506. (frame-finished frame)
  507. (return-handler frame depth))
  508. ;; FIXME: abort handler?
  509. (define (abort-hook frame)
  510. (frame-finished frame))
  511. (set! finish-trap
  512. (trap-frame-finish frame return-hook abort-hook))
  513. (set! pending-finish-traps
  514. (cons finish-trap pending-finish-traps))))))
  515. ;; The basic idea is that we install one trap that fires for calls,
  516. ;; but that each call installs its own finish trap. Those finish
  517. ;; traps remove themselves as their frames finish or abort.
  518. ;;
  519. ;; However since to the outside world we present the interface of
  520. ;; just being one trap, disabling this calls-to-procedure trap
  521. ;; should take care of disabling all of the pending finish traps. We
  522. ;; keep track of pending traps through the pending-finish-traps
  523. ;; list.
  524. ;;
  525. ;; So since we know that the trap-at-procedure will be enabled, and
  526. ;; thus returning a disable closure, we make sure to wrap that
  527. ;; closure in something that will disable pending finish traps.
  528. (define (with-pending-finish-disablers trap)
  529. (define (with-pending-finish-enablers trap)
  530. (lambda* (#:optional frame)
  531. (with-pending-finish-disablers (trap frame))))
  532. (lambda* (#:optional frame)
  533. (for-each (lambda (disable) (disable frame))
  534. pending-finish-traps)
  535. (set! pending-finish-traps '())
  536. (with-pending-finish-enablers (trap frame))))
  537. (with-pending-finish-disablers
  538. (trap-at-procedure-call proc apply-hook))))
  539. ;; Trap when the source location changes.
  540. ;;
  541. (define (trap-matching-instructions frame-pred handler)
  542. (arg-check frame-pred procedure?)
  543. (arg-check handler procedure?)
  544. (let ()
  545. (define (next-hook frame)
  546. (if (frame-pred frame)
  547. (handler frame)))
  548. (new-enabled-trap
  549. #f
  550. (lambda (frame)
  551. (vm-add-next-hook! next-hook))
  552. (lambda (frame)
  553. (vm-remove-next-hook! next-hook)))))