[Guile-commits] GNU Guile branch, master, updated. release_1-9-12-72-g6edf585

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=6edf58538f852102a80b0fce84e85ffca3c78c96

The branch, master has been updated
       via  6edf58538f852102a80b0fce84e85ffca3c78c96 (commit)
       via  639b2eb7107b26207d13bb8acb4c1d38d7dba3bd (commit)
       via  ede3d96bd675246bbe138bacb2fdbbdf2523d247 (commit)
       via  271c3d3196d93746917426ecb0d494de4d27c071 (commit)
      from  f4a23f910f8ce4c8e656fe6c050a30ea39ac0fcf (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 6edf58538f852102a80b0fce84e85ffca3c78c96
Author: Ludovic Courtès <address@hidden>
Date:   Fri Sep 24 15:39:10 2010 +0200

    Make `procedure-execution-count' fail gracefully when no source info is 
available.
    
    * module/system/vm/coverage.scm (procedure-execution-count): Handle the
      case where (null? (program-sources PROC)).

commit 639b2eb7107b26207d13bb8acb4c1d38d7dba3bd
Author: Ludovic Courtès <address@hidden>
Date:   Fri Sep 24 15:19:49 2010 +0200

    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.

commit ede3d96bd675246bbe138bacb2fdbbdf2523d247
Author: Ludovic Courtès <address@hidden>
Date:   Fri Sep 24 15:15:43 2010 +0200

    Remove unused declarations.
    
    * libguile/vm.h (scm_vm_option_ref, scm_vm_option_set_x): Remove.

commit 271c3d3196d93746917426ecb0d494de4d27c071
Author: Ludovic Courtès <address@hidden>
Date:   Fri Sep 24 15:14:11 2010 +0200

    Add `thread-vm' and `set-thread-vm!'.
    
    * libguile/vm.c (thread_vm, scm_thread_vm, scm_set_thread_vm_x): New
      functions.
      (scm_the_vm): Add docstring.  Use `thread_vm'.
    
    * libguile/vm.h (scm_thread_vm, scm_set_thread_vm_x): New declarations.
    
    * module/system/vm/vm.scm: Export `thread-vm' and `set-thread-vm!'.

-----------------------------------------------------------------------

Summary of changes:
 libguile/vm.c                  |   49 ++++++++++++++++++++++++++++++++++-----
 libguile/vm.h                  |    4 +-
 module/system/vm/coverage.scm  |   23 +++++++++++-------
 module/system/vm/vm.scm        |    3 +-
 test-suite/tests/coverage.test |   21 ++++++++++++++++-
 5 files changed, 80 insertions(+), 20 deletions(-)

diff --git a/libguile/vm.c b/libguile/vm.c
index 01963f1..b229c27 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -597,18 +597,53 @@ SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
-           (void),
-           "")
-#define FUNC_NAME s_scm_the_vm
+/* Return T's VM.  */
+static inline SCM
+thread_vm (scm_i_thread *t)
 {
-  scm_i_thread *t = SCM_I_CURRENT_THREAD;
-
-  if (SCM_UNLIKELY (scm_is_false ((t->vm))))
+  if (SCM_UNLIKELY (scm_is_false (t->vm)))
     t->vm = make_vm ();
 
   return t->vm;
 }
+
+SCM_DEFINE (scm_thread_vm, "thread-vm", 1, 0, 0,
+           (SCM thread),
+           "Return @var{thread}'s VM.")
+#define FUNC_NAME s_scm_thread_vm
+{
+  SCM_VALIDATE_THREAD (1, thread);
+
+  return thread_vm (SCM_I_THREAD_DATA (thread));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_thread_vm_x, "set-thread-vm!", 2, 0, 0,
+           (SCM thread, SCM vm),
+           "Set @var{thread}'s VM to @var{vm}.  Warning: Code being\n"
+           "executed by @var{thread}'s current VM won't automatically\n"
+           "switch to @var{vm}.")
+#define FUNC_NAME s_scm_set_thread_vm_x
+{
+  scm_i_thread *t;
+
+  SCM_VALIDATE_THREAD (1, thread);
+  SCM_VALIDATE_VM (2, vm);
+
+  t = SCM_I_THREAD_DATA (thread);
+  t->vm = vm;
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
+           (void),
+           "Return the current thread's VM.")
+#define FUNC_NAME s_scm_the_vm
+{
+  return thread_vm (SCM_I_CURRENT_THREAD);
+}
 #undef FUNC_NAME
 
 
diff --git a/libguile/vm.h b/libguile/vm.h
index acf43c2..86b096d 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -64,10 +64,10 @@ SCM_API SCM scm_the_vm ();
 SCM_API SCM scm_make_vm (void);
 SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args);
 SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
-SCM_API SCM scm_vm_option_ref (SCM vm, SCM key);
-SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
 
 SCM_API SCM scm_vm_version (void);
+SCM_API SCM scm_thread_vm (SCM t);
+SCM_API SCM scm_set_thread_vm_x (SCM t, SCM vm);
 SCM_API SCM scm_the_vm (void);
 SCM_API SCM scm_vm_p (SCM obj);
 SCM_API SCM scm_vm_ip (SCM vm);
diff --git a/module/system/vm/coverage.scm b/module/system/vm/coverage.scm
index 2600974..17e2f40 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
@@ -196,12 +199,14 @@ coverage data.  Return code coverage data and the values 
returned by THUNK."
 if PROC was not executed.  When PROC is a closure, the number of times its code
 was executed is returned, not the number of times this code associated with 
this
 particular closure was executed."
-  (and=> (hashx-ref hashq-proc assq-proc
-                    (data-procedure->ip-counts data) proc)
-         (let ((sources (program-sources* data proc)))
-           (lambda (ip-counts)
-             (let ((entry-ip (source:addr (car sources)))) ;; FIXME: broken 
with lambda*
-               (hashv-ref ip-counts entry-ip 0))))))
+  (let ((sources (program-sources* data proc)))
+    (and (pair? sources)
+         (and=> (hashx-ref hashq-proc assq-proc
+                           (data-procedure->ip-counts data) proc)
+                (lambda (ip-counts)
+                  ;; FIXME: broken with lambda*
+                  (let ((entry-ip (source:addr (car sources))))
+                    (hashv-ref ip-counts entry-ip 0)))))))
 
 (define (program-sources* data proc)
   ;; A memoizing version of `program-sources'.
diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm
index 3fd96f4..66afdbb 100644
--- a/module/system/vm/vm.scm
+++ b/module/system/vm/vm.scm
@@ -21,7 +21,8 @@
 (define-module (system vm vm)
   #:use-module (system vm frame)
   #:use-module (system vm program)
-  #:export (vm? the-vm make-vm vm-version vm-apply
+  #:export (vm? make-vm vm-version vm-apply
+            the-vm thread-vm set-thread-vm!
             vm:ip vm:sp vm:fp vm:last-ip
 
             vm-load vm-option set-vm-option! vm-version
diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test
index 52635a9..6869a3a 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"


hooks/post-receive
-- 
GNU Guile