diff options
author | Ludovic Courtès <ludo@gnu.org> | 2010-09-24 15:19:49 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2010-09-24 15:39:47 +0200 |
commit | 639b2eb7107b26207d13bb8acb4c1d38d7dba3bd (patch) | |
tree | 137aee74fd4743902b190fbb3be41c4d40a1663e | |
parent | ede3d96bd675246bbe138bacb2fdbbdf2523d247 (diff) | |
download | guile-639b2eb7107b26207d13bb8acb4c1d38d7dba3bd.tar.gz |
Fix coverage analysis of procedures called from C.
* 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.
-rw-r--r-- | module/system/vm/coverage.scm | 9 | ||||
-rw-r--r-- | test-suite/tests/coverage.test | 21 |
2 files changed, 26 insertions, 4 deletions
diff --git a/module/system/vm/coverage.scm b/module/system/vm/coverage.scm index 260097491..0f4c73ec9 100644 --- a/module/system/vm/coverage.scm +++ b/module/system/vm/coverage.scm @@ -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 diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test index 52635a98a..6869a3a62 100644 --- a/test-suite/tests/coverage.test +++ b/test-suite/tests/coverage.test @@ -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" |