[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-10-106-g3
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-10-106-g36b5e39 |
|
Date: |
Fri, 07 May 2010 12:07:21 +0000 |
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=36b5e394072c94b062a69a6d77b418e16ce70fce
The branch, master has been updated
via 36b5e394072c94b062a69a6d77b418e16ce70fce (commit)
via b3567435e1ba8b4bdef78fc020a2032c02d73075 (commit)
via f9a86f72a6ea7ab480f4bfd6ef61c835620df5eb (commit)
via e6bd58af8fd847dc1e7af2c8d658905ea889edca (commit)
via 0a935b2ab59a73c802283692c868a8315434839e (commit)
from d9b1c71ac61b9e510ff0e2ce819e4002348eceb6 (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 36b5e394072c94b062a69a6d77b418e16ce70fce
Author: Ludovic Courtès <address@hidden>
Date: Sun May 2 14:17:41 2010 +0200
Add (system vm coverage).
* module/system/vm/coverage.scm: New file.
* module/Makefile.am (SYSTEM_SOURCES): Add `system/vm/coverage.scm'.
* test-suite/guile-test (main): Use (system vm coverage). Handle
`--coverage' and `-c'.
* test-suite/tests/coverage.test: New file.
* test-suite/Makefile.am (SCM_TESTS): Add `tests/coverage.test'.
* doc/ref/Makefile.am (guile_TEXINFOS): Add `api-coverage.texi'.
* doc/ref/api-coverage.texi: New file.
* doc/ref/guile.texi (API Reference): Include it.
commit b3567435e1ba8b4bdef78fc020a2032c02d73075
Author: Ludovic Courtès <address@hidden>
Date: Wed Apr 21 01:05:42 2010 +0200
Allocate frame objects on the stack when invoking VM hooks.
* libguile/vm.c (vm_dispatch_hook): Don't call `scm_c_make_frame ()'.
Instead, allocate FRAME on the stack.
commit f9a86f72a6ea7ab480f4bfd6ef61c835620df5eb
Author: Ludovic Courtès <address@hidden>
Date: Wed Apr 21 23:30:48 2010 +0200
Add `program-free-variables' to `(system vm program)'.
* module/system/vm/program.scm (program-free-variables): New procedure.
* module/language/objcode/spec.scm (program-free-variables): Remove.
commit e6bd58af8fd847dc1e7af2c8d658905ea889edca
Author: Ludovic Courtès <address@hidden>
Date: Mon Apr 19 00:27:47 2010 +0200
Fix the type tag produced by `SCM_STATIC_PROGRAM'.
* libguile/snarf.h (SCM_STATIC_PROGRAM): Fix typo.
commit 0a935b2ab59a73c802283692c868a8315434839e
Author: Ludovic Courtès <address@hidden>
Date: Wed Apr 14 23:46:41 2010 +0200
When printing a VM, show the type of engine being used.
* libguile/vm.c (scm_i_vm_print): Print the engine type.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/Makefile.am | 1 +
doc/ref/api-coverage.texi | 81 +++++++++
doc/ref/guile.texi | 2 +
libguile/snarf.h | 2 +-
libguile/vm.c | 45 +++++-
module/Makefile.am | 1 +
module/language/objcode/spec.scm | 5 -
module/system/vm/coverage.scm | 362 ++++++++++++++++++++++++++++++++++++++
module/system/vm/program.scm | 14 ++-
test-suite/Makefile.am | 1 +
test-suite/guile-test | 24 ++-
test-suite/tests/coverage.test | 201 +++++++++++++++++++++
12 files changed, 722 insertions(+), 17 deletions(-)
create mode 100644 doc/ref/api-coverage.texi
create mode 100644 module/system/vm/coverage.scm
create mode 100644 test-suite/tests/coverage.test
diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am
index 1a933db..60146a3 100644
--- a/doc/ref/Makefile.am
+++ b/doc/ref/Makefile.am
@@ -51,6 +51,7 @@ guile_TEXINFOS = preface.texi \
api-options.texi \
api-i18n.texi \
api-debug.texi \
+ api-coverage.texi \
scheme-reading.texi \
scheme-indices.texi \
slib.texi \
diff --git a/doc/ref/api-coverage.texi b/doc/ref/api-coverage.texi
new file mode 100644
index 0000000..123e1d3
--- /dev/null
+++ b/doc/ref/api-coverage.texi
@@ -0,0 +1,81 @@
address@hidden -*-texinfo-*-
address@hidden This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 2010 Free Software Foundation, Inc.
address@hidden See the file guile.texi for copying conditions.
+
+
address@hidden
address@hidden Code Coverage
address@hidden Code Coverage Reports
+
address@hidden code coverage
address@hidden coverage
+When writing a test suite for a program or library, it is desirable to know
what
+part of the code is @dfn{covered} by the test suite. The @code{(system vm
+coverage)} module provides tools to gather code coverage data and to present
+them, as detailed below.
+
address@hidden {Scheme Procedure} with-code-coverage vm thunk
+Run @var{thunk}, a zero-argument procedure, using @var{vm}; instrument @var{vm}
+to collect code coverage data. Return code coverage data and the values
+returned by @var{thunk}.
address@hidden deffn
+
address@hidden {Scheme Procedure} coverage-data? obj
+Return @code{#t} if @var{obj} is a @dfn{coverage data} object as returned by
address@hidden
address@hidden deffn
+
address@hidden {Scheme Procedure} coverage-data->lcov data port #:key modules
+Traverse code coverage information @var{data}, as obtained with
address@hidden, and write coverage information to port in the
address@hidden format used by @url{http://ltp.sourceforge.net/coverage/lcov.php,
+LCOV}. The report will include all of @var{modules} (or, by default, all the
+currently loaded modules) even if their code was not executed.
+
+The generated data can be fed to LCOV's @command{genhtml} command to produce an
+HTML report, which aids coverage data visualization.
address@hidden deffn
+
+Here's an example use:
+
address@hidden
+(use-modules (system vm coverage)
+ (system vm vm))
+
+(call-with-values (lambda ()
+ (with-code-coverage (the-vm)
+ (lambda ()
+ (do-something-tricky))))
+ (lambda (data result)
+ (let ((port (open-output-file "lcov.info")))
+ (coverage-data->lcov data port)
+ (close file))))
address@hidden example
+
+In addition, the module provides low-level procedures that would make it
+possible to write other user interfaces to the coverage data.
+
address@hidden {Scheme Procedures} instrumented-source-files data
+Return the list of ``instrumented'' source files, i.e., source files whose
+code was loaded at the time @var{data} was collected.
address@hidden deffn
+
address@hidden {Scheme Procedures} line-execution-counts data file
+Return a list of line number/execution count pairs for @var{file}, or
address@hidden if @var{file} is not among the files covered by @var{data}. This
+includes lines with zero count.
address@hidden deffn
+
address@hidden {Scheme Procedures} instrumented/executed-lines data file
+Return the number of instrumented and the number of executed source lines
+in @var{file} according to @var{data}.
address@hidden deffn
+
address@hidden {Scheme Procedures} procedure-execution-count data proc
+Return the number of times @var{proc}'s code was executed, according to
address@hidden, or @code{#f} if @var{proc} was not executed. When @var{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.
address@hidden deffn
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index a3a212a..27d6c7b 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -312,6 +312,7 @@ available through both Scheme and C interfaces.
* Other Languages:: Emacs Lisp, ECMAScript, and more.
* Internationalization:: Support for gettext, etc.
* Debugging:: Debugging infrastructure and Scheme interface.
+* Code Coverage:: Gathering code coverage data.
@end menu
@include api-overview.texi
@@ -339,6 +340,7 @@ available through both Scheme and C interfaces.
@include api-languages.texi
@include api-i18n.texi
@include api-debug.texi
address@hidden api-coverage.texi
@node Guile Modules
@chapter Guile Modules
diff --git a/libguile/snarf.h b/libguile/snarf.h
index 98f6601..360cb94 100644
--- a/libguile/snarf.h
+++ b/libguile/snarf.h
@@ -378,7 +378,7 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req),
(opt), (rest));)
#define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars) \
SCM_STATIC_DOUBLE_CELL (c_name, \
- scm_tc7_program | (SCM_F_PROGRAM_IS_PRIMITIVE<<8), \
+ scm_tc7_program | SCM_F_PROGRAM_IS_PRIMITIVE,
\
(scm_t_bits) objcode, \
(scm_t_bits) objtable, \
(scm_t_bits) freevars)
diff --git a/libguile/vm.c b/libguile/vm.c
index 54a143e..4f766cb 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -185,7 +185,9 @@ vm_dispatch_hook (SCM vm, int hook_num)
{
struct scm_vm *vp;
SCM hook;
- SCM frame;
+ struct scm_frame c_frame;
+ scm_t_cell frame;
+ SCM args[1];
vp = SCM_VM_DATA (vm);
hook = vp->hooks[hook_num];
@@ -193,10 +195,28 @@ vm_dispatch_hook (SCM vm, int hook_num)
if (SCM_LIKELY (scm_is_false (hook))
|| scm_is_null (SCM_HOOK_PROCEDURES (hook)))
return;
-
+
vp->trace_level--;
- frame = scm_c_make_frame (vm, vp->fp, vp->sp, vp->ip, 0);
- scm_c_run_hookn (hook, &frame, 1);
+
+ /* Allocate a frame object on the stack. This is more efficient than calling
+ `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
+ capture frame objects.
+
+ At the same time, procedures such as `frame-procedure' make sense only
+ while the stack frame represented by the frame object is visible, so it
+ seems reasonable to limit the lifetime of frame objects. */
+
+ c_frame.stack_holder = vm;
+ c_frame.fp = vp->fp;
+ c_frame.sp = vp->sp;
+ c_frame.ip = vp->ip;
+ c_frame.offset = 0;
+ frame.word_0 = SCM_PACK (scm_tc7_frame);
+ frame.word_1 = PTR2SCM (&c_frame);
+ args[0] = PTR2SCM (&frame);
+
+ scm_c_run_hookn (hook, args, 1);
+
vp->trace_level++;
}
@@ -315,7 +335,24 @@ static SCM sym_vm_run, sym_vm_error,
sym_keyword_argument_error, sym_debug;
void
scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
{
+ const struct scm_vm *vm;
+
+ vm = SCM_VM_DATA (x);
+
scm_puts ("#<vm ", port);
+ switch (vm->engine)
+ {
+ case SCM_VM_REGULAR_ENGINE:
+ scm_puts ("regular-engine ", port);
+ break;
+
+ case SCM_VM_DEBUG_ENGINE:
+ scm_puts ("debug-engine ", port);
+ break;
+
+ default:
+ scm_puts ("unknown-engine ", port);
+ }
scm_uintprint (SCM_UNPACK (x), 16, port);
scm_puts (">", port);
}
diff --git a/module/Makefile.am b/module/Makefile.am
index 2410cb2..cbe945f 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -278,6 +278,7 @@ OOP_SOURCES = \
SYSTEM_SOURCES = \
system/vm/inspect.scm \
+ system/vm/coverage.scm \
system/vm/debug.scm \
system/vm/frame.scm \
system/vm/instruction.scm \
diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm
index a4cb062..bbd7454 100644
--- a/module/language/objcode/spec.scm
+++ b/module/language/objcode/spec.scm
@@ -53,11 +53,6 @@
(lp (acons (binding:index b) (list b) ret)
(cdr locs))))))))
-(define (program-free-variables program)
- (list->vector
- (map (lambda (i) (program-free-variable-ref program i))
- (iota (program-num-free-variables program)))))
-
(define (decompile-value x env opts)
(cond
((program? x)
diff --git a/module/system/vm/coverage.scm b/module/system/vm/coverage.scm
new file mode 100644
index 0000000..2600974
--- /dev/null
+++ b/module/system/vm/coverage.scm
@@ -0,0 +1,362 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (system vm coverage)
+ #:use-module (system vm vm)
+ #:use-module (system vm frame)
+ #:use-module (system vm program)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:export (with-code-coverage
+ coverage-data?
+ instrumented-source-files
+ instrumented/executed-lines
+ line-execution-counts
+ procedure-execution-count
+ coverage-data->lcov))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; This module provides support to gather code coverage data by instrumenting
+;;; the VM.
+;;;
+;;; Code:
+
+
+;;;
+;;; Gathering coverage data.
+;;;
+
+(define (hashq-proc proc n)
+ ;; Return the hash of PROC's objcode.
+ (hashq (program-objcode proc) n))
+
+(define (assq-proc proc alist)
+ ;; Instead of really looking for PROC in ALIST, look for the objcode of PROC.
+ ;; IOW the alist is indexed by procedures, not objcodes, but those procedures
+ ;; are taken as an arbitrary representative of all the procedures (closures)
+ ;; sharing that objcode. This can significantly reduce memory consumption.
+ (let ((code (program-objcode proc)))
+ (find (lambda (pair)
+ (eq? code (program-objcode (car pair))))
+ alist)))
+
+(define (with-code-coverage vm thunk)
+ "Run THUNK, a zero-argument procedure, using VM; instrument VM to collect
code
+coverage data. Return code coverage data and the values returned by THUNK."
+
+ (define procedure->ip-counts
+ ;; Mapping from procedures to hash tables; said hash tables map instruction
+ ;; pointers to the number of times they were executed.
+ (make-hash-table 500))
+
+ (define (collect! frame)
+ ;; Update PROCEDURE->IP-COUNTS with info from FRAME.
+ (let* ((proc (frame-procedure frame))
+ (ip (frame-instruction-pointer frame))
+ (proc-entry (hashx-create-handle! hashq-proc assq-proc
+ procedure->ip-counts proc #f)))
+ (let loop ()
+ (define ip-counts (cdr proc-entry))
+ (if ip-counts
+ (let ((ip-entry (hashv-create-handle! ip-counts ip 0)))
+ (set-cdr! ip-entry (+ (cdr ip-entry) 1)))
+ (begin
+ (set-cdr! proc-entry (make-hash-table))
+ (loop))))))
+
+ (call-with-values (lambda ()
+ (let ((level (vm-trace-level vm))
+ (hook (vm-next-hook vm)))
+ (dynamic-wind
+ (lambda ()
+ (set-vm-trace-level! vm (+ level 1))
+ (add-hook! hook collect!))
+ (lambda ()
+ (vm-apply vm thunk '()))
+ (lambda ()
+ (set-vm-trace-level! vm level)
+ (remove-hook! hook collect!)))))
+ (lambda args
+ (apply values (make-coverage-data procedure->ip-counts) args))))
+
+
+;;;
+;;; Coverage data summary.
+;;;
+
+(define-record-type <coverage-data>
+ (%make-coverage-data procedure->ip-counts
+ procedure->sources
+ file->procedures
+ file->line-counts)
+ coverage-data?
+
+ ;; Mapping from procedures to hash tables; said hash tables map instruction
+ ;; pointers to the number of times they were executed.
+ (procedure->ip-counts data-procedure->ip-counts)
+
+ ;; Mapping from procedures to the result of `program-sources'.
+ (procedure->sources data-procedure->sources)
+
+ ;; Mapping from source file names to lists of procedures defined in the file.
+ (file->procedures data-file->procedures)
+
+ ;; Mapping from file names to hash tables, which in turn map from line
numbers
+ ;; to execution counts.
+ (file->line-counts data-file->line-counts))
+
+
+(define (make-coverage-data procedure->ip-counts)
+ ;; Return a `coverage-data' object based on the coverage data available in
+ ;; PROCEDURE->IP-COUNTS. Precompute the other hash tables that make up
+ ;; `coverage-data' objects.
+ (let* ((procedure->sources (make-hash-table 500))
+ (file->procedures (make-hash-table 100))
+ (file->line-counts (make-hash-table 100))
+ (data (%make-coverage-data procedure->ip-counts
+ procedure->sources
+ file->procedures
+ file->line-counts)))
+ (define (increment-execution-count! file line count)
+ ;; Make the execution count of FILE:LINE the maximum of its current value
+ ;; and COUNT. This is so that LINE's execution count is correct when
+ ;; several instruction pointers map to LINE.
+ (let ((file-entry (hash-create-handle! file->line-counts file #f)))
+ (if (not (cdr file-entry))
+ (set-cdr! file-entry (make-hash-table 500)))
+ (let ((line-entry (hashv-create-handle! (cdr file-entry) line 0)))
+ (set-cdr! line-entry (max (cdr line-entry) count)))))
+
+ ;; Update execution counts for procs that were executed.
+ (hash-for-each (lambda (proc ip-counts)
+ (let* ((sources (program-sources* data proc))
+ (file (and (pair? sources)
+ (source:file (car sources)))))
+ (and file
+ (begin
+ ;; Add a zero count for all IPs in SOURCES and in
+ ;; the sources of procedures closed over by PROC.
+ (for-each
+ (lambda (source)
+ (let ((file (source:file source))
+ (line (source:line source)))
+ (increment-execution-count! file line 0)))
+ (append-map (cut program-sources* data <>)
+ (closed-over-procedures proc)))
+
+ ;; Add the actual execution count collected.
+ (hash-for-each
+ (lambda (ip count)
+ (let ((line (closest-source-line sources ip)))
+ (increment-execution-count! file line
count)))
+ ip-counts)))))
+ procedure->ip-counts)
+
+ ;; Set the execution count to zero for procedures loaded and not executed.
+ ;; FIXME: Traversing thousands of procedures here is inefficient.
+ (for-each (lambda (proc)
+ (and (not (hashq-ref procedure->sources proc))
+ (for-each (lambda (proc)
+ (let* ((sources (program-sources* data proc))
+ (file (and (pair? sources)
+ (source:file (car
sources)))))
+ (and file
+ (for-each
+ (lambda (ip)
+ (let ((line (closest-source-line
sources ip)))
+ (increment-execution-count! file
line 0)))
+ (map source:addr sources)))))
+ (closed-over-procedures proc))))
+ (append-map module-procedures (loaded-modules)))
+
+ data))
+
+(define (procedure-execution-count data proc)
+ "Return the number of times PROC's code was executed, according to DATA, or
#f
+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))))))
+
+(define (program-sources* data proc)
+ ;; A memoizing version of `program-sources'.
+ (or (hashq-ref (data-procedure->sources data) proc)
+ (and (program? proc)
+ (let ((sources (program-sources proc))
+ (p->s (data-procedure->sources data))
+ (f->p (data-file->procedures data)))
+ (if (pair? sources)
+ (let* ((file (source:file (car sources)))
+ (entry (hash-create-handle! f->p file '())))
+ (hashq-set! p->s proc sources)
+ (set-cdr! entry (cons proc (cdr entry)))
+ sources)
+ sources)))))
+
+(define (file-procedures data file)
+ ;; Return the list of globally bound procedures defined in FILE.
+ (hash-ref (data-file->procedures data) file '()))
+
+(define (instrumented/executed-lines data file)
+ "Return the number of instrumented and the number of executed source lines in
+FILE according to DATA."
+ (define instr+exec
+ (and=> (hash-ref (data-file->line-counts data) file)
+ (lambda (line-counts)
+ (hash-fold (lambda (line count instr+exec)
+ (let ((instr (car instr+exec))
+ (exec (cdr instr+exec)))
+ (cons (+ 1 instr)
+ (if (> count 0)
+ (+ 1 exec)
+ exec))))
+ '(0 . 0)
+ line-counts))))
+
+ (values (car instr+exec) (cdr instr+exec)))
+
+(define (line-execution-counts data file)
+ "Return a list of line number/execution count pairs for FILE, or #f if FILE
+is not among the files covered by DATA."
+ (and=> (hash-ref (data-file->line-counts data) file)
+ (lambda (line-counts)
+ (hash-fold alist-cons '() line-counts))))
+
+(define (instrumented-source-files data)
+ "Return the list of `instrumented' source files, i.e., source files whose
code
+was loaded at the time DATA was collected."
+ (hash-fold (lambda (file counts files)
+ (cons file files))
+ '()
+ (data-file->line-counts data)))
+
+
+;;;
+;;; Helpers.
+;;;
+
+(define (loaded-modules)
+ ;; Return the list of all the modules currently loaded.
+ (define seen (make-hash-table))
+
+ (let loop ((modules (module-submodules (resolve-module '() #f)))
+ (result '()))
+ (hash-fold (lambda (name module result)
+ (if (hashq-ref seen module)
+ result
+ (begin
+ (hashq-set! seen module #t)
+ (loop (module-submodules module)
+ (cons module result)))))
+ result
+ modules)))
+
+(define (module-procedures module)
+ ;; Return the list of procedures bound globally in MODULE.
+ (hash-fold (lambda (binding var result)
+ (if (variable-bound? var)
+ (let ((value (variable-ref var)))
+ (if (procedure? value)
+ (cons value result)
+ result))
+ result))
+ '()
+ (module-obarray module)))
+
+(define (closest-source-line sources ip)
+ ;; Given SOURCES, as returned by `program-sources' for a given procedure,
+ ;; return the source line of code that is the closest to IP. This is similar
+ ;; to what `program-source' does.
+ (let loop ((sources sources)
+ (line (and (pair? sources) (source:line (car sources)))))
+ (if (null? sources)
+ line
+ (let ((source (car sources)))
+ (if (> (source:addr source) ip)
+ line
+ (loop (cdr sources) (source:line source)))))))
+
+(define (closed-over-procedures proc)
+ ;; Return the list of procedures PROC closes over, PROC included.
+ (let loop ((proc proc)
+ (result '()))
+ (if (and (program? proc) (not (memq proc result)))
+ (fold loop (cons proc result)
+ (append (vector->list (or (program-objects proc) #()))
+ (program-free-variables proc)))
+ result)))
+
+
+;;;
+;;; LCOV output.
+;;;
+
+(define* (coverage-data->lcov data port)
+ "Traverse code coverage information DATA, as obtained with
+`with-code-coverage', and write coverage information in the LCOV format to
PORT.
+The report will include all the modules loaded at the time coverage data was
+gathered, even if their code was not executed."
+
+ (define (dump-function proc)
+ ;; Dump source location and basic coverage data for PROC.
+ (and (program? proc)
+ (let ((sources (program-sources* data proc)))
+ (and (pair? sources)
+ (let* ((line (source:line (car sources)))
+ (name (or (procedure-name proc)
+ (format #f "anonymous-l~a" (+ 1 line)))))
+ (format port "FN:~A,~A~%" (+ 1 line) name)
+ (and=> (procedure-execution-count data proc)
+ (lambda (count)
+ (format port "FNDA:~A,~A~%" count name))))))))
+
+ ;; Output per-file coverage data.
+ (format port "TN:~%")
+ (for-each (lambda (file)
+ (let ((procs (file-procedures data file))
+ (path (search-path %load-path file)))
+ (if (string? path)
+ (begin
+ (format port "SF:~A~%" path)
+ (for-each dump-function procs)
+ (for-each (lambda (line+count)
+ (let ((line (car line+count))
+ (count (cdr line+count)))
+ (format port "DA:~A,~A~%"
+ (+ 1 line) count)))
+ (line-execution-counts data file))
+ (let-values (((instr exec)
+ (instrumented/executed-lines data file)))
+ (format port "LH: ~A~%" exec)
+ (format port "LF: ~A~%" instr))
+ (format port "end_of_record~%"))
+ (begin
+ (format (current-error-port)
+ "skipping unknown source file: ~a~%"
+ file)))))
+ (instrumented-source-files data)))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index f3892cb..30f8c7e 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -20,7 +20,8 @@
(define-module (system vm program)
#:use-module (system base pmatch)
- #:use-module (ice-9 optargs)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:export (make-program
make-binding binding:name binding:boxed? binding:index
@@ -35,10 +36,11 @@
arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
program-arguments-alist program-lambda-list
-
+
program-meta
program-objcode program? program-objects
program-module program-base
+ program-free-variables
program-num-free-variables
program-free-variable-ref program-free-variable-set!))
@@ -190,6 +192,14 @@
,@(if (pair? key) (cons #:key key) '())
. ,rest)))
+(define (program-free-variables prog)
+ "Return the list of free variables of PROG."
+ (let ((count (program-num-free-variables prog)))
+ (unfold (lambda (i) (>= i count))
+ (cut program-free-variable-ref prog <>)
+ 1+
+ 0)))
+
(define (write-program prog port)
(format port "#<procedure ~a~a>"
(or (procedure-name prog)
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 4444be4..eed9618 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -35,6 +35,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/common-list.test \
tests/control.test \
tests/continuations.test \
+ tests/coverage.test \
tests/curried-definitions.test \
tests/ecmascript.test \
tests/elisp.test \
diff --git a/test-suite/guile-test b/test-suite/guile-test
index 0031bbf..c114ad6 100755
--- a/test-suite/guile-test
+++ b/test-suite/guile-test
@@ -85,6 +85,9 @@
:use-module (ice-9 getopt-long)
:use-module (ice-9 and-let-star)
:use-module (ice-9 rdelim)
+ :use-module (system vm coverage)
+ :use-module (srfi srfi-11)
+ :use-module (system vm vm)
:export (main data-file-name test-file-name))
@@ -175,6 +178,8 @@
(log-file
(single-char #\l)
(value #t))
+ (coverage
+ (single-char #\c))
(debug
(single-char #\d))))))
(define (opt tag default)
@@ -227,11 +232,20 @@
(set! global-pass #f)))))
;; Run the tests.
- (for-each (lambda (test)
- (display (string-append "Running " test "\n"))
- (with-test-prefix test
- (load (test-file-name test))))
- tests)
+ (let ((run-tests
+ (lambda ()
+ (for-each (lambda (test)
+ (display (string-append "Running " test "\n"))
+ (with-test-prefix test
+ (load (test-file-name test))))
+ tests))))
+ (if (opt 'coverage #f)
+ (let-values (((coverage-data _)
+ (with-code-coverage (the-vm) run-tests)))
+ (let ((out (open-output-file "guile.info")))
+ (coverage-data->lcov coverage-data out)
+ (close out)))
+ (run-tests)))
;; Display the final counts, both to the user and in the log
;; file.
diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test
new file mode 100644
index 0000000..eefb7bb
--- /dev/null
+++ b/test-suite/tests/coverage.test
@@ -0,0 +1,201 @@
+;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (test-coverage)
+ #:use-module (test-suite lib)
+ #:use-module (system vm coverage)
+ #:use-module (system vm vm)
+ #:use-module (system base compile)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11))
+
+(define-syntax code
+ (syntax-rules ()
+ ((_ filename snippet)
+ (let ((input (open-input-string snippet)))
+ (set-port-filename! input filename)
+ (read-enable 'positions)
+ (compile (read input))))))
+
+(define %test-vm (make-vm))
+
+
+(with-test-prefix "instrumented/executed-lines"
+
+ (pass-if "instr = exec"
+ (let ((proc (code "foo.scm" "(lambda (x y) ;; 0
+ (+ x y)) ;; 1")))
+ (let-values (((data result)
+ (with-code-coverage %test-vm
+ (lambda () (proc 1 2)))))
+ (and (coverage-data? data)
+ (= 3 result)
+ (let-values (((instr exec)
+ (instrumented/executed-lines data "foo.scm")))
+ (and (= 2 instr) (= 2 exec)))))))
+
+ (pass-if "instr >= exec"
+ (let ((proc (code "foo.scm" "(lambda (x y) ;; 0
+ (if (> x y) ;; 1
+ (begin ;; 2
+ (display x) ;; 3
+ (+ x y)))) ;; 4")))
+ (let-values (((data result)
+ (with-code-coverage %test-vm
+ (lambda () (proc 1 2)))))
+ (and (coverage-data? data)
+ (let-values (((instr exec)
+ (instrumented/executed-lines data "foo.scm")))
+ (and (> instr 0) (>= instr exec))))))))
+
+
+(with-test-prefix "line-execution-counts"
+
+ (pass-if "once"
+ (let ((proc (code "bar.scm" "(lambda (x y) ;; 0
+ (+ (/ x y) ;; 1
+ (* x y))) ;; 2")))
+ (let-values (((data result)
+ (with-code-coverage %test-vm
+ (lambda () (proc 1 2)))))
+ (let ((counts (line-execution-counts data "bar.scm")))
+ (and (pair? counts)
+ (every (lambda (line+count)
+ (let ((line (car line+count))
+ (count (cdr line+count)))
+ (and (>= line 0)
+ (<= line 2)
+ (= count 1))))
+ counts))))))
+
+ (pass-if "several times"
+ (let ((proc (code "fooz.scm" "(lambda (x) ;; 0
+ (format #f \"hello\") ;; 1
+ (let loop ((x x)) ;; 2
+ (cond ((> x 0) ;; 3
+ (begin ;; 4
+ (format #f \"~a\" x)
+ (loop (1- x)))) ;; 6
+ ((= x 0) #t) ;; 7
+ ((< x 0) 'never))))")))
+ (let-values (((data result)
+ (with-code-coverage %test-vm
+ (lambda () (proc 77)))))
+ (let ((counts (line-execution-counts data "fooz.scm")))
+ (and (pair? counts)
+ (every (lambda (line+count)
+ (let ((line (car line+count))
+ (count (cdr line+count)))
+ (case line
+ ((0 1) (= count 1))
+ ((2 3) (= count 78))
+ ((4 5 6) (= count 77))
+ ((7) (= count 1))
+ ((8) (= count 0)))))
+ counts))))))
+
+ (pass-if "some"
+ (let ((proc (code "baz.scm" "(lambda (x y) ;; 0
+ (if (> x y) ;; 1
+ (begin ;; 2
+ (display x) ;; 3
+ (+ x y)) ;; 4
+ (+ x y))) ;; 5")))
+ (let-values (((data result)
+ (with-code-coverage %test-vm
+ (lambda () (proc 1 2)))))
+ (let ((counts (line-execution-counts data "baz.scm")))
+ (and (pair? counts)
+ (every (lambda (line+count)
+ (let ((line (car line+count))
+ (count (cdr line+count)))
+ (case line
+ ((0 1 5) (= count 1))
+ ((2 3) (= count 0))
+ ((4) #t) ;; the start of the `else' branch is
+ ;; attributed to line 4
+ (else #f))))
+ counts))))))
+
+ (pass-if "one proc hit, one proc unused"
+ (let ((proc (code "baz.scm" "(letrec ((even? (lambda (x) ;; 0
+ (or (= x 0) ;; 1
+ (not (odd? (1- x))))))
+ (odd? (lambda (x) ;; 3
+ (not (even? (1- x)))))) ;; 4
+ even?)")))
+ (let-values (((data result)
+ (with-code-coverage %test-vm
+ (lambda () (proc 0)))))
+ (let ((counts (line-execution-counts data "baz.scm")))
+ (and (pair? counts)
+ (every (lambda (line+count)
+ (let ((line (car line+count))
+ (count (cdr line+count)))
+ (case line
+ ((0 1) (= count 1))
+ ((2 3 4) (= count 0))
+ ((5) (= count 1))
+ (else #f))))
+ counts))))))
+
+ (pass-if "all code on one line"
+ ;; There are several proc/IP pairs pointing to this source line, yet the
hit
+ ;; count for the line should be 1.
+ (let ((proc (code "one-liner.scm"
+ "(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))")))
+ (let-values (((data result)
+ (with-code-coverage %test-vm
+ (lambda () (proc 451 1884)))))
+ (let ((counts (line-execution-counts data "one-liner.scm")))
+ (equal? counts '((0 . 1))))))))
+
+
+(with-test-prefix "procedure-execution-count"
+
+ (pass-if "several times"
+ (let ((proc (code "foo.scm" "(lambda (x y) x)")))
+ (let-values (((data result)
+ (with-code-coverage %test-vm
+ (lambda () (+ (proc 1 2) (proc 2 3))))))
+ (and (coverage-data? data)
+ (= 3 result)
+ (= (procedure-execution-count data proc) 2)))))
+
+ (pass-if "never"
+ (let ((proc (code "foo.scm" "(lambda (x y) x)")))
+ (let-values (((data result)
+ (with-code-coverage %test-vm
+ (lambda () (+ 1 2)))))
+ (and (coverage-data? data)
+ (= 3 result)
+ (not (procedure-execution-count data proc)))))))
+
+
+(with-test-prefix "instrumented-source-files"
+
+ (pass-if "source files are listed as expected"
+ (let ((proc (code "chbouib.scm" "(lambda (x y) x)")))
+ (let-values (((data result)
+ (with-code-coverage %test-vm
+ (lambda () (proc 1 2)))))
+
+ (let ((files (map basename (instrumented-source-files data))))
+ (and (member "boot-9.scm" files)
+ (member "chbouib.scm" files)
+ (not (member "foo.scm" files))))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-10-106-g36b5e39,
Ludovic Courtès <=