module/system/vm/coverage.scm

   1 ;;; -*- mode: scheme; coding: utf-8; -*-
   2 ;;;
   3 ;;; Copyright (C) 2010, 2013 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 (system vm debug)
  24   #:use-module (ice-9 format)
  25   #:use-module (srfi srfi-1)
  26   #:use-module (srfi srfi-9)
  27   #:use-module (srfi srfi-9 gnu)
  28   #:use-module (srfi srfi-11)
  29   #:use-module (srfi srfi-26)
  30   #:use-module (ice-9 match)
  31   #:export (with-code-coverage
  32             coverage-data?
  33             instrumented-source-files
  34             instrumented/executed-lines
  35             line-execution-counts
  36             procedure-execution-count
  37             coverage-data->lcov))
  38
  39 ;;; Author: Ludovic Courtès
  40 ;;;
  41 ;;; Commentary:
  42 ;;;
  43 ;;; This module provides support to gather code coverage data by instrumenting
  44 ;;; the VM.
  45 ;;;
  46 ;;; Code:
  47
  48 \f
  49 ;;;
  50 ;;; Gathering coverage data.
  51 ;;;
  52
  53 (define (with-code-coverage vm thunk)
  54   "Run THUNK, a zero-argument procedure, using VM; instrument VM to collect code
  55 coverage data.  Return code coverage data and the values returned by THUNK."
  56
  57   (define ip-counts
  58     ;; A table mapping instruction pointers to the number of times they were
  59     ;; executed.
  60     (make-hash-table 5000))
  61
  62   (define (collect! frame)
  63     ;; Update IP-COUNTS with info from FRAME.
  64     (let* ((ip (frame-instruction-pointer frame))
  65            (ip-entry (hashv-create-handle! ip-counts ip 0)))
  66       (set-cdr! ip-entry (+ (cdr ip-entry) 1))))
  67
  68   ;; FIXME: It's unclear what the dynamic-wind is for, given that if the
  69   ;; VM is different from the current one, continuations will not be
  70   ;; resumable.
  71   (call-with-values (lambda ()
  72                       (let ((level   (vm-trace-level vm))
  73                             (hook    (vm-next-hook vm)))
  74                         (dynamic-wind
  75                           (lambda ()
  76                             (set-vm-trace-level! vm (+ level 1))
  77                             (add-hook! hook collect!))
  78                           (lambda ()
  79                             (call-with-vm vm thunk))
  80                           (lambda ()
  81                             (set-vm-trace-level! vm level)
  82                             (remove-hook! hook collect!)))))
  83     (lambda args
  84       (apply values (make-coverage-data ip-counts) args))))
  85
  86
  87 \f
  88
  89 ;;;
  90 ;;; Source chunks.
  91 ;;;
  92
  93 (define-record-type <source-chunk>
  94   (make-source-chunk base length sources)
  95   source-chunk?
  96   (base source-chunk-base)
  97   (length source-chunk-length)
  98   (sources source-chunk-sources))
  99
 100 (set-record-type-printer!
 101  <source-chunk>
 102  (lambda (obj port)
 103    (format port "<source-chunk #x~x-#x~x>"
 104            (source-chunk-base obj)
 105            (+ (source-chunk-base obj) (source-chunk-length obj)))))
 106
 107 (define (compute-source-chunk ctx)
 108   "Build a sorted vector of source information for a given debugging
 109 context (ELF image).  The return value is a @code{<source-chunk>}, which also
 110 records the address range to which the source information applies."
 111   (make-source-chunk
 112    (debug-context-base ctx)
 113    (debug-context-length ctx)
 114    ;; The source locations are sorted already, but collected in reverse order.
 115    (list->vector (reverse! (fold-source-locations cons '() ctx)))))
 116
 117 (define (all-source-information)
 118   "Build and return a vector of source information corresponding to all
 119 loaded code.  The vector will be sorted by ascending address order."
 120   (sort! (list->vector (fold-all-debug-contexts
 121                         (lambda (ctx seed)
 122                           (cons (compute-source-chunk ctx) seed))
 123                         '()))
 124          (lambda (x y)
 125            (< (source-chunk-base x) (source-chunk-base y)))))
 126
 127 \f
 128 ;;;
 129 ;;; Coverage data summary.
 130 ;;;
 131
 132 (define-record-type <coverage-data>
 133   (%make-coverage-data ip-counts
 134                        sources
 135                        file->procedures
 136                        file->line-counts)
 137   coverage-data?
 138
 139   ;; Mapping from instruction pointers to the number of times they were
 140   ;; executed, as a sorted vector of IP-count pairs.
 141   (ip-counts data-ip-counts)
 142
 143   ;; Complete source census at the time the coverage analysis was run, as a
 144   ;; sorted vector of <source-chunk> values.
 145   (sources data-sources)
 146
 147   ;; Mapping from source file names to lists of procedures defined in the file.
 148   ;; FIXME.
 149   (file->procedures     data-file->procedures)
 150
 151   ;; Mapping from file names to hash tables, which in turn map from line numbers
 152   ;; to execution counts.
 153   (file->line-counts    data-file->line-counts))
 154
 155 (set-record-type-printer!
 156  <coverage-data>
 157  (lambda (obj port)
 158    (format port "<coverage-data ~x>" (object-address obj))))
 159
 160 (define (make-coverage-data ip-counts)
 161   ;; Return a `coverage-data' object based on the coverage data available in
 162   ;; IP-COUNTS.  Precompute the other hash tables that make up `coverage-data'
 163   ;; objects.
 164   (let* ((all-sources (all-source-information))
 165          (all-counts (sort! (list->vector (hash-fold acons '() ip-counts))
 166                             (lambda (x y)
 167                               (< (car x) (car y)))))
 168          (file->procedures   (make-hash-table 100))
 169          (file->line-counts  (make-hash-table 100))
 170          (data               (%make-coverage-data all-counts
 171                                                   all-sources
 172                                                   file->procedures
 173                                                   file->line-counts)))
 174
 175     (define (observe-execution-count! file line count)
 176       ;; Make the execution count of FILE:LINE the maximum of its current value
 177       ;; and COUNT.  This is so that LINE's execution count is correct when
 178       ;; several instruction pointers map to LINE.
 179       (when file
 180         (let ((file-entry (hash-create-handle! file->line-counts file #f)))
 181           (if (not (cdr file-entry))
 182               (set-cdr! file-entry (make-hash-table 500)))
 183           (let ((line-entry (hashv-create-handle! (cdr file-entry) line 0)))
 184             (set-cdr! line-entry (max (cdr line-entry) count))))))
 185
 186     ;; First, visit every known source location and mark it as instrumented but
 187     ;; unvisited.
 188     ;;
 189     ;; FIXME: This is not always necessary.  It's important to have the ability
 190     ;; to know when a source location is not reached, but sometimes all we need
 191     ;; to know is that a particular site *was* reached.  In that case we
 192     ;; wouldn't need to load up all the DWARF sections.  As it is, though, we
 193     ;; use the complete source census as part of the later phase.
 194     (let visit-chunk ((chunk-idx 0))
 195       (when (< chunk-idx (vector-length all-sources))
 196         (match (vector-ref all-sources chunk-idx)
 197           (($ <source-chunk> base chunk-length chunk-sources)
 198            (let visit-source ((source-idx 0))
 199              (when (< source-idx (vector-length chunk-sources))
 200                (let ((s (vector-ref chunk-sources source-idx)))
 201                  (observe-execution-count! (source-file s) (source-line s) 0)
 202                  (visit-source (1+ source-idx)))))))
 203         (visit-chunk (1+ chunk-idx))))
 204
 205     ;; Then, visit the measured execution counts, walking the complete source
 206     ;; census at the same time.  This allows us to map observed addresses to
 207     ;; source locations.  Record observed execution counts.
 208     (let visit-chunk ((chunk-idx 0) (count-idx 0))
 209       (when (< chunk-idx (vector-length all-sources))
 210         (match (vector-ref all-sources chunk-idx)
 211           (($ <source-chunk> base chunk-length chunk-sources)
 212            (let visit-count ((count-idx count-idx) (source-idx 0) (source #f))
 213              (when (< count-idx (vector-length all-counts))
 214                (match (vector-ref all-counts count-idx)
 215                  ((ip . count)
 216                   (cond
 217                    ((< ip base)
 218                     ;; Address before chunk base; no corresponding source.
 219                     (visit-count (1+ count-idx) source-idx source))
 220                    ((< ip (+ base chunk-length))
 221                     ;; Address in chunk; count it.
 222                     (let visit-source ((source-idx source-idx) (source source))
 223                       (define (finish)
 224                         (when source
 225                           (observe-execution-count! (source-file source)
 226                                                     (source-line source)
 227                                                     count))
 228                         (visit-count (1+ count-idx) source-idx source))
 229                       (cond
 230                        ((< source-idx (vector-length chunk-sources))
 231                         (let ((source* (vector-ref chunk-sources source-idx)))
 232                           (if (<= (source-pre-pc source*) ip)
 233                               (visit-source (1+ source-idx) source*)
 234                               (finish))))
 235                        (else
 236                         (finish)))))
 237                    (else
 238                     ;; Address past chunk; fetch the next chunk.
 239                     (visit-chunk (1+ chunk-idx) count-idx)))))))))))
 240
 241     data))
 242
 243 (define (procedure-execution-count data proc)
 244   "Return the number of times PROC's code was executed, according to DATA.  When
 245 PROC is a closure, the number of times its code was executed is returned, not
 246 the number of times this code associated with this particular closure was
 247 executed."
 248   (define (binary-search v key val)
 249     (let lp ((start 0) (end (vector-length v)))
 250       (and (not (eqv? start end))
 251            (let* ((idx (floor/ (+ start end) 2))
 252                   (elt (vector-ref v idx))
 253                   (val* (key elt)))
 254              (cond
 255               ((< val val*)
 256                (lp start idx))
 257               ((< val* val)
 258                (lp (1+ idx) end))
 259               (else elt))))))
 260   (and (program? proc)
 261        (match (binary-search (data-ip-counts data) car (program-code proc))
 262          (#f 0)
 263          ((ip . code) code))))
 264
 265 (define (instrumented/executed-lines data file)
 266   "Return the number of instrumented and the number of executed source lines in
 267 FILE according to DATA."
 268   (define instr+exec
 269     (and=> (hash-ref (data-file->line-counts data) file)
 270            (lambda (line-counts)
 271              (hash-fold (lambda (line count instr+exec)
 272                           (let ((instr (car instr+exec))
 273                                 (exec  (cdr instr+exec)))
 274                             (cons (+ 1 instr)
 275                                   (if (> count 0)
 276                                       (+ 1 exec)
 277                                       exec))))
 278                         '(0 . 0)
 279                         line-counts))))
 280
 281   (values (car instr+exec) (cdr instr+exec)))
 282
 283 (define (line-execution-counts data file)
 284   "Return a list of line number/execution count pairs for FILE, or #f if FILE
 285 is not among the files covered by DATA."
 286   (and=> (hash-ref (data-file->line-counts data) file)
 287          (lambda (line-counts)
 288            (hash-fold alist-cons '() line-counts))))
 289
 290 (define (instrumented-source-files data)
 291   "Return the list of `instrumented' source files, i.e., source files whose code
 292 was loaded at the time DATA was collected."
 293   (hash-fold (lambda (file counts files)
 294                (cons file files))
 295              '()
 296              (data-file->line-counts data)))
 297
 298 \f
 299 ;;;
 300 ;;; LCOV output.
 301 ;;;
 302
 303 (define* (coverage-data->lcov data port)
 304   "Traverse code coverage information DATA, as obtained with
 305 `with-code-coverage', and write coverage information in the LCOV format to PORT.
 306 The report will include all the modules loaded at the time coverage data was
 307 gathered, even if their code was not executed."
 308
 309   ;; FIXME: Re-enable this code, but using for-each-elf-symbol on each source
 310   ;; chunk.  Use that to build a map of file -> proc-addr + line + name.  Then
 311   ;; use something like procedure-execution-count to get the execution count.
 312   #;
 313   (define (dump-function proc)
 314     ;; Dump source location and basic coverage data for PROC.
 315     (and (or (program? proc))
 316          (let ((sources (program-sources* data proc)))
 317            (and (pair? sources)
 318                 (let* ((line (source:line-for-user (car sources)))
 319                        (name (or (procedure-name proc)
 320                                  (format #f "anonymous-l~a" line))))
 321                   (format port "FN:~A,~A~%" line name)
 322                   (and=> (procedure-execution-count data proc)
 323                          (lambda (count)
 324                            (format port "FNDA:~A,~A~%" count name))))))))
 325
 326   ;; Output per-file coverage data.
 327   (format port "TN:~%")
 328   (for-each (lambda (file)
 329               (let ((path (search-path %load-path file)))
 330                 (if (string? path)
 331                     (begin
 332                       (format port "SF:~A~%" path)
 333                       #;
 334                       (for-each dump-function procs)
 335                       (for-each (lambda (line+count)
 336                                   (let ((line  (car line+count))
 337                                         (count (cdr line+count)))
 338                                     (format port "DA:~A,~A~%"
 339                                             (+ 1 line) count)))
 340                                 (line-execution-counts data file))
 341                       (let-values (((instr exec)
 342                                     (instrumented/executed-lines data file)))
 343                         (format port "LH: ~A~%" exec)
 344                         (format port "LF: ~A~%" instr))
 345                       (format port "end_of_record~%"))
 346                     (begin
 347                       (format (current-error-port)
 348                               "skipping unknown source file: ~a~%"
 349                               file)))))
 350             (instrumented-source-files data)))