summaryrefslogtreecommitdiff
path: root/module/system/vm/coverage.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/vm/coverage.scm')
-rw-r--r--module/system/vm/coverage.scm362
1 files changed, 362 insertions, 0 deletions
diff --git a/module/system/vm/coverage.scm b/module/system/vm/coverage.scm
new file mode 100644
index 000000000..260097491
--- /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)))