mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 05:50:26 +02:00
Code Activity

Fix coverage analysis of procedures called from C.

Browse source 
* module/system/vm/coverage.scm (with-code-coverage): Switch current
  thread to VM, using `set-thread-vm!'.

* test-suite/tests/coverage.test ("procedure-execution-count")["called
  from C"]: New test.
This commit is contained in:
Ludovic Courtès 2010-09-24 15:19:49 +02:00
parent ede3d96bd6
commit 639b2eb710
2 changed files with 26 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

9
module/system/vm/coverage.scm
View file

@ -85,15 +85,18 @@ coverage data. Return code coverage data and the values returned by THUNK."
(loop))))))
(call-with-values (lambda ()
(let ((level (vm-trace-level vm))
(hook (vm-next-hook vm)))
(let ((level (vm-trace-level vm))
(hook (vm-next-hook vm))
(prev-vm (thread-vm (current-thread))))
(dynamic-wind
(lambda ()
(set-vm-trace-level! vm (+ level 1))
(add-hook! hook collect!))
(add-hook! hook collect!)
(set-thread-vm! (current-thread) vm))
(lambda ()
(vm-apply vm thunk '()))
(lambda ()
(set-thread-vm! (current-thread) prev-vm)
(set-vm-trace-level! vm level)
(remove-hook! hook collect!)))))
(lambda args

21
test-suite/tests/coverage.test
View file

@ -21,6 +21,7 @@
#:use-module (system vm coverage)
#:use-module (system vm vm)
#:use-module (system base compile)
#:use-module (system foreign)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11))
@ -185,7 +186,25 @@
(lambda () (+ 1 2)))))
(and (coverage-data? data)
(= 3 result)
(not (procedure-execution-count data proc)))))))
(not (procedure-execution-count data proc))))))
(pass-if "called from C"
;; The `scm_call_N' functions use the VM returned by `the-vm'. This
;; test makes sure that they get to use %TEST-VM.
(let ((proc (code "foo.scm" "(lambda (x y) (+ x y))"))
(call (pointer->procedure '*
(dynamic-func "scm_call_2"
(dynamic-link))
'(* * *))))
(let-values (((data result)
(with-code-coverage %test-vm
(lambda ()
(call (make-pointer (object-address proc))
(make-pointer (object-address 1))
(make-pointer (object-address 2)))))))
(and (coverage-data? data)
(= (object-address 3) (pointer-address result))
(= (procedure-execution-count data proc) 1))))))
(with-test-prefix "instrumented-source-files"