module/system/vm/coverage.scm

   1 ;;; -*- mode: scheme; coding: utf-8; -*-
   2 ;;;
   3 ;;; Copyright (C) 2010 Free Software Foundation, Inc.
   4 ;;;
   5 ;;; This library is free software; you can redistribute it and/or
   6 ;;; modify it under the terms of the GNU Lesser General Public
   7 ;;; License as published by the Free Software Foundation; either
   8 ;;; version 3 of the License, or (at your option) any later version.
   9 ;;;
  10 ;;; This library is distributed in the hope that it will be useful,
  11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;; Lesser General Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU Lesser General Public
  16 ;;; License along with this library; if not, write to the Free Software
  17 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (system vm coverage)
  20   #:use-module (system vm vm)
  21   #:use-module (system vm frame)
  22   #:use-module (system vm program)
  23   #:use-module (srfi srfi-1)
  24   #:use-module (srfi srfi-9)
  25   #:use-module (srfi srfi-11)
  26   #:use-module (srfi srfi-26)
  27   #:export (with-code-coverage
  28             coverage-data?
  29             instrumented-source-files
  30             instrumented/executed-lines
  31             line-execution-counts
  32             procedure-execution-count
  33             coverage-data->lcov))
  34
  35 ;;; Author: Ludovic Courtès
  36 ;;;
  37 ;;; Commentary:
  38 ;;;
  39 ;;; This module provides support to gather code coverage data by instrumenting
  40 ;;; the VM.
  41 ;;;
  42 ;;; Code:
  43
  44 \f
  45 ;;;
  46 ;;; Gathering coverage data.
  47 ;;;
  48
  49 (define (hashq-proc proc n)
  50   ;; Return the hash of PROC's objcode.
  51   (hashq (program-objcode proc) n))
  52
  53 (define (assq-proc proc alist)
  54   ;; Instead of really looking for PROC in ALIST, look for the objcode of PROC.
  55   ;; IOW the alist is indexed by procedures, not objcodes, but those procedures
  56   ;; are taken as an arbitrary representative of all the procedures (closures)
  57   ;; sharing that objcode.  This can significantly reduce memory consumption.
  58   (let ((code (program-objcode proc)))
  59     (find (lambda (pair)
  60             (eq? code (program-objcode (car pair))))
  61           alist)))
  62
  63 (define (with-code-coverage vm thunk)
  64   "Run THUNK, a zero-argument procedure, using VM; instrument VM to collect code
  65 coverage data.  Return code coverage data and the values returned by THUNK."
  66
  67   (define procedure->ip-counts
  68     ;; Mapping from procedures to hash tables; said hash tables map instruction
  69     ;; pointers to the number of times they were executed.
  70     (make-hash-table 500))
  71
  72   (define (collect! frame)
  73     ;; Update PROCEDURE->IP-COUNTS with info from FRAME.
  74     (let* ((proc       (frame-procedure frame))
  75            (ip         (frame-instruction-pointer frame))
  76            (proc-entry (hashx-create-handle! hashq-proc assq-proc
  77                                              procedure->ip-counts proc #f)))
  78       (let loop ()
  79         (define ip-counts (cdr proc-entry))
  80         (if ip-counts
  81             (let ((ip-entry (hashv-create-handle! ip-counts ip 0)))
  82               (set-cdr! ip-entry (+ (cdr ip-entry) 1)))
  83             (begin
  84               (set-cdr! proc-entry (make-hash-table))
  85               (loop))))))
  86
  87   ;; FIXME: It's unclear what the dynamic-wind is for, given that if the
  88   ;; VM is different from the current one, continuations will not be
  89   ;; resumable.
  90   (call-with-values (lambda ()
  91                       (let ((level   (vm-trace-level vm))
  92                             (hook    (vm-next-hook vm)))
  93                         (dynamic-wind
  94                           (lambda ()
  95                             (set-vm-trace-level! vm (+ level 1))
  96                             (add-hook! hook collect!))
  97                           (lambda ()
  98                             (call-with-vm vm thunk))
  99                           (lambda ()
 100                             (set-vm-trace-level! vm level)
 101                             (remove-hook! hook collect!)))))
 102     (lambda args
 103       (apply values (make-coverage-data procedure->ip-counts) args))))
 104
 105 \f
 106 ;;;
 107 ;;; Coverage data summary.
 108 ;;;
 109
 110 (define-record-type <coverage-data>
 111   (%make-coverage-data procedure->ip-counts
 112                        procedure->sources
 113                        file->procedures
 114                        file->line-counts)
 115   coverage-data?
 116
 117   ;; Mapping from procedures to hash tables; said hash tables map instruction
 118   ;; pointers to the number of times they were executed.
 119   (procedure->ip-counts data-procedure->ip-counts)
 120
 121   ;; Mapping from procedures to the result of `program-sources'.
 122   (procedure->sources   data-procedure->sources)
 123
 124   ;; Mapping from source file names to lists of procedures defined in the file.
 125   (file->procedures     data-file->procedures)
 126
 127   ;; Mapping from file names to hash tables, which in turn map from line numbers
 128   ;; to execution counts.
 129   (file->line-counts    data-file->line-counts))
 130
 131
 132 (define (make-coverage-data procedure->ip-counts)
 133   ;; Return a `coverage-data' object based on the coverage data available in
 134   ;; PROCEDURE->IP-COUNTS.  Precompute the other hash tables that make up
 135   ;; `coverage-data' objects.
 136   (let* ((procedure->sources (make-hash-table 500))
 137          (file->procedures   (make-hash-table 100))
 138          (file->line-counts  (make-hash-table 100))
 139          (data               (%make-coverage-data procedure->ip-counts
 140                                                   procedure->sources
 141                                                   file->procedures
 142                                                   file->line-counts)))
 143     (define (increment-execution-count! file line count)
 144       ;; Make the execution count of FILE:LINE the maximum of its current value
 145       ;; and COUNT.  This is so that LINE's execution count is correct when
 146       ;; several instruction pointers map to LINE.
 147       (let ((file-entry (hash-create-handle! file->line-counts file #f)))
 148         (if (not (cdr file-entry))
 149             (set-cdr! file-entry (make-hash-table 500)))
 150         (let ((line-entry (hashv-create-handle! (cdr file-entry) line 0)))
 151           (set-cdr! line-entry (max (cdr line-entry) count)))))
 152
 153     ;; Update execution counts for procs that were executed.
 154     (hash-for-each (lambda (proc ip-counts)
 155                      (let* ((sources (program-sources* data proc))
 156                             (file    (and (pair? sources)
 157                                           (source:file (car sources)))))
 158                        (and file
 159                             (begin
 160                               ;; Add a zero count for all IPs in SOURCES and in
 161                               ;; the sources of procedures closed over by PROC.
 162                               (for-each
 163                                (lambda (source)
 164                                  (let ((file (source:file source))
 165                                        (line (source:line source)))
 166                                    (increment-execution-count! file line 0)))
 167                                (append-map (cut program-sources* data <>)
 168                                            (closed-over-procedures proc)))
 169
 170                               ;; Add the actual execution count collected.
 171                               (hash-for-each
 172                                (lambda (ip count)
 173                                  (let ((line (closest-source-line sources ip)))
 174                                    (increment-execution-count! file line count)))
 175                                ip-counts)))))
 176                    procedure->ip-counts)
 177
 178     ;; Set the execution count to zero for procedures loaded and not executed.
 179     ;; FIXME: Traversing thousands of procedures here is inefficient.
 180     (for-each (lambda (proc)
 181                 (and (not (hashq-ref procedure->sources proc))
 182                      (for-each (lambda (proc)
 183                                  (let* ((sources (program-sources* data proc))
 184                                         (file    (and (pair? sources)
 185                                                       (source:file (car sources)))))
 186                                    (and file
 187                                         (for-each
 188                                          (lambda (ip)
 189                                            (let ((line (closest-source-line sources ip)))
 190                                              (increment-execution-count! file line 0)))
 191                                          (map source:addr sources)))))
 192                                (closed-over-procedures proc))))
 193               (append-map module-procedures (loaded-modules)))
 194
 195     data))
 196
 197 (define (procedure-execution-count data proc)
 198   "Return the number of times PROC's code was executed, according to DATA, or #f
 199 if PROC was not executed.  When PROC is a closure, the number of times its code
 200 was executed is returned, not the number of times this code associated with this
 201 particular closure was executed."
 202   (let ((sources (program-sources* data proc)))
 203     (and (pair? sources)
 204          (and=> (hashx-ref hashq-proc assq-proc
 205                            (data-procedure->ip-counts data) proc)
 206                 (lambda (ip-counts)
 207                   ;; FIXME: broken with lambda*
 208                   (let ((entry-ip (source:addr (car sources))))
 209                     (hashv-ref ip-counts entry-ip 0)))))))
 210
 211 (define (program-sources* data proc)
 212   ;; A memoizing version of `program-sources'.
 213   (or (hashq-ref (data-procedure->sources data) proc)
 214       (and (program? proc)
 215            (let ((sources (program-sources proc))
 216                  (p->s    (data-procedure->sources data))
 217                  (f->p    (data-file->procedures data)))
 218              (if (pair? sources)
 219                  (let* ((file  (source:file (car sources)))
 220                         (entry (hash-create-handle! f->p file '())))
 221                    (hashq-set! p->s proc sources)
 222                    (set-cdr! entry (cons proc (cdr entry)))
 223                    sources)
 224                  sources)))))
 225
 226 (define (file-procedures data file)
 227   ;; Return the list of globally bound procedures defined in FILE.
 228   (hash-ref (data-file->procedures data) file '()))
 229
 230 (define (instrumented/executed-lines data file)
 231   "Return the number of instrumented and the number of executed source lines in
 232 FILE according to DATA."
 233   (define instr+exec
 234     (and=> (hash-ref (data-file->line-counts data) file)
 235            (lambda (line-counts)
 236              (hash-fold (lambda (line count instr+exec)
 237                           (let ((instr (car instr+exec))
 238                                 (exec  (cdr instr+exec)))
 239                             (cons (+ 1 instr)
 240                                   (if (> count 0)
 241                                       (+ 1 exec)
 242                                       exec))))
 243                         '(0 . 0)
 244                         line-counts))))
 245
 246   (values (car instr+exec) (cdr instr+exec)))
 247
 248 (define (line-execution-counts data file)
 249   "Return a list of line number/execution count pairs for FILE, or #f if FILE
 250 is not among the files covered by DATA."
 251   (and=> (hash-ref (data-file->line-counts data) file)
 252          (lambda (line-counts)
 253            (hash-fold alist-cons '() line-counts))))
 254
 255 (define (instrumented-source-files data)
 256   "Return the list of `instrumented' source files, i.e., source files whose code
 257 was loaded at the time DATA was collected."
 258   (hash-fold (lambda (file counts files)
 259                (cons file files))
 260              '()
 261              (data-file->line-counts data)))
 262
 263 \f
 264 ;;;
 265 ;;; Helpers.
 266 ;;;
 267
 268 (define (loaded-modules)
 269   ;; Return the list of all the modules currently loaded.
 270   (define seen (make-hash-table))
 271
 272   (let loop ((modules (module-submodules (resolve-module '() #f)))
 273              (result  '()))
 274     (hash-fold (lambda (name module result)
 275                  (if (hashq-ref seen module)
 276                      result
 277                      (begin
 278                        (hashq-set! seen module #t)
 279                        (loop (module-submodules module)
 280                              (cons module result)))))
 281                result
 282                modules)))
 283
 284 (define (module-procedures module)
 285   ;; Return the list of procedures bound globally in MODULE.
 286   (hash-fold (lambda (binding var result)
 287                (if (variable-bound? var)
 288                    (let ((value (variable-ref var)))
 289                      (if (procedure? value)
 290                          (cons value result)
 291                          result))
 292                    result))
 293              '()
 294              (module-obarray module)))
 295
 296 (define (closest-source-line sources ip)
 297   ;; Given SOURCES, as returned by `program-sources' for a given procedure,
 298   ;; return the source line of code that is the closest to IP.  This is similar
 299   ;; to what `program-source' does.
 300   (let loop ((sources sources)
 301              (line    (and (pair? sources) (source:line (car sources)))))
 302     (if (null? sources)
 303         line
 304         (let ((source (car sources)))
 305           (if (> (source:addr source) ip)
 306               line
 307               (loop (cdr sources) (source:line source)))))))
 308
 309 (define (closed-over-procedures proc)
 310   ;; Return the list of procedures PROC closes over, PROC included.
 311   (let loop ((proc   proc)
 312              (result '()))
 313     (if (and (program? proc) (not (memq proc result)))
 314         (fold loop (cons proc result)
 315               (append (vector->list (or (program-objects proc) #()))
 316                       (program-free-variables proc)))
 317         result)))
 318
 319 \f
 320 ;;;
 321 ;;; LCOV output.
 322 ;;;
 323
 324 (define* (coverage-data->lcov data port)
 325   "Traverse code coverage information DATA, as obtained with
 326 `with-code-coverage', and write coverage information in the LCOV format to PORT.
 327 The report will include all the modules loaded at the time coverage data was
 328 gathered, even if their code was not executed."
 329
 330   (define (dump-function proc)
 331     ;; Dump source location and basic coverage data for PROC.
 332     (and (program? proc)
 333          (let ((sources (program-sources* data proc)))
 334            (and (pair? sources)
 335                 (let* ((line (source:line-for-user (car sources)))
 336                        (name (or (procedure-name proc)
 337                                  (format #f "anonymous-l~a" line))))
 338                   (format port "FN:~A,~A~%" line name)
 339                   (and=> (procedure-execution-count data proc)
 340                          (lambda (count)
 341                            (format port "FNDA:~A,~A~%" count name))))))))
 342
 343   ;; Output per-file coverage data.
 344   (format port "TN:~%")
 345   (for-each (lambda (file)
 346               (let ((procs (file-procedures data file))
 347                     (path  (search-path %load-path file)))
 348                 (if (string? path)
 349                     (begin
 350                       (format port "SF:~A~%" path)
 351                       (for-each dump-function procs)
 352                       (for-each (lambda (line+count)
 353                                   (let ((line  (car line+count))
 354                                         (count (cdr line+count)))
 355                                     (format port "DA:~A,~A~%"
 356                                             (+ 1 line) count)))
 357                                 (line-execution-counts data file))
 358                       (let-values (((instr exec)
 359                                     (instrumented/executed-lines data file)))
 360                         (format port "LH: ~A~%" exec)
 361                         (format port "LF: ~A~%" instr))
 362                       (format port "end_of_record~%"))
 363                     (begin
 364                       (format (current-error-port)
 365                               "skipping unknown source file: ~a~%"
 366                               file)))))
 367             (instrumented-source-files data)))