test-suite/tests/coverage.test

   1 ;;;; coverage.test --- Code coverage.    -*- mode: scheme; coding: utf-8; -*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2010, 2011, 2012, 2013, 2014, 2015 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 (test-coverage)
  20   #:use-module (test-suite lib)
  21   #:use-module (system vm coverage)
  22   #:use-module (system vm vm)
  23   #:use-module (system base compile)
  24   #:use-module (system foreign)
  25   #:use-module (srfi srfi-1)
  26   #:use-module (srfi srfi-11))
  27
  28 (define-syntax code
  29   (syntax-rules ()
  30     ((_ filename snippet)
  31      (let ((input (open-input-string snippet)))
  32        (set-port-filename! input filename)
  33        (read-enable 'positions)
  34        (compile (read input))))))
  35
  36 (define test-procedure
  37   (compile '(lambda (x)
  38               (if (> x 2)
  39                   (- x 2)
  40                   (+ x 2)))))
  41
  42 \f
  43 (with-test-prefix "instrumented/executed-lines"
  44
  45   (pass-if "instr = exec"
  46     (let ((proc (code "foo.scm" "(lambda (x y)  ;; 0
  47                                    (+ x y))     ;; 1")))
  48       (let-values (((data result)
  49                     (with-code-coverage
  50                       (lambda () (proc 1 2)))))
  51         (and (coverage-data? data)
  52              (= 3 result)
  53              (let-values (((instr exec)
  54                            (instrumented/executed-lines data "foo.scm")))
  55                (and (= 2 instr) (= 2 exec)))))))
  56
  57   (pass-if "instr >= exec"
  58     (let ((proc (code "foo.scm" "(lambda (x y)       ;; 0
  59                                    (if (> x y)       ;; 1
  60                                        (begin        ;; 2
  61                                          (display x) ;; 3
  62                                          (+ x y))))  ;; 4")))
  63       (let-values (((data result)
  64                     (with-code-coverage
  65                       (lambda () (proc 1 2)))))
  66         (and (coverage-data? data)
  67              (let-values (((instr exec)
  68                            (instrumented/executed-lines data "foo.scm")))
  69                (and (> instr 0) (>= instr exec))))))))
  70
  71 \f
  72 (with-test-prefix "line-execution-counts"
  73
  74   (pass-if "once"
  75     (let ((proc (code "bar.scm" "(lambda (x y)   ;; 0
  76                                    (+ (/ x y)    ;; 1
  77                                       (* x y)))  ;; 2")))
  78       (let-values (((data result)
  79                     (with-code-coverage
  80                       (lambda () (proc 1 2)))))
  81         (let ((counts (line-execution-counts data "bar.scm")))
  82           (and (pair? counts)
  83                (every (lambda (line+count)
  84                         (let ((line  (car line+count))
  85                               (count (cdr line+count)))
  86                           (and (>= line 0)
  87                                (<= line 2)
  88                                (= count 1))))
  89                       counts))))))
  90
  91   ;; Unhappily, lack of source location on identifiers combined with a
  92   ;; block reordering change makes this test fail.  The right solution
  93   ;; is to fix the compiler, but really it should happen by fixing
  94   ;; psyntax to have source location info for identifiers and immediate
  95   ;; values.
  96   (expect-fail "several times"
  97     (let ((proc (code "fooz.scm" "(lambda (x)                   ;; 0
  98                                     (format #f \"hello\")       ;; 1
  99                                     (let loop ((x x))           ;; 2
 100                                       (cond ((> x 0)            ;; 3
 101                                              (begin             ;; 4
 102                                                (format #f \"~a\" x)
 103                                                (loop (1- x))))  ;; 6
 104                                             ((= x 0) #t)        ;; 7
 105                                             ((< x 0) 'never))))")))
 106       (let-values (((data result)
 107                     (with-code-coverage
 108                       (lambda () (proc 77)))))
 109         (let ((counts (line-execution-counts data "fooz.scm")))
 110           (and (pair? counts)
 111                (every (lambda (line+count)
 112                         (let ((line  (car line+count))
 113                               (count (cdr line+count)))
 114                           ;; The actual line counts for aliasing
 115                           ;; operations, like the loop header that
 116                           ;; initializes "x" to "x", are sensitive to
 117                           ;; whether there is an associated "mov"
 118                           ;; instruction, or whether the value is left
 119                           ;; in place.  Currently there are no
 120                           ;; instructions for line 2, but we allow 1 as
 121                           ;; well.
 122                           (case line
 123                             ((0 1)   (= count 1))
 124                             ((2)     (<= 0 count 1))
 125                             ((3)     (= count 78))
 126                             ((4 5 6) (= count 77))
 127                             ((7)     (= count 1))
 128                             ((8)     (= count 0))
 129                             (else    #f))))
 130                       counts))))))
 131
 132   (pass-if "some"
 133     (let ((proc (code "baz.scm" "(lambda (x y)       ;; 0
 134                                    (if (> x y)       ;; 1
 135                                        (begin        ;; 2
 136                                          (display x) ;; 3
 137                                          (+ x y))    ;; 4
 138                                        (+ x y)))     ;; 5")))
 139       (let-values (((data result)
 140                     (with-code-coverage
 141                       (lambda () (proc 1 2)))))
 142         (let ((counts (line-execution-counts data "baz.scm")))
 143           (and (pair? counts)
 144                (every (lambda (line+count)
 145                         (let ((line  (car line+count))
 146                               (count (cdr line+count)))
 147                           (case line
 148                             ((0 1 5) (= count 1))
 149                             ((2 3)   (= count 0))
 150                             ((4)     #t) ;; the start of the `else' branch is
 151                                          ;; attributed to line 4
 152                             (else    #f))))
 153                       counts))))))
 154
 155   ;; Same unfortunate caveat as above: block ordering and source
 156   ;; locations :(
 157   (expect-fail "one proc hit, one proc unused"
 158     (let ((proc (code "baz.scm" "(letrec ((even? (lambda (x)               ;; 0
 159                                                    (or (= x 0)             ;; 1
 160                                                        (not (odd? (1- x))))))
 161                                           (odd?  (lambda (x)               ;; 3
 162                                                    (not (even? (1- x)))))) ;; 4
 163                                    even?)")))
 164       (let-values (((data result)
 165                     (with-code-coverage
 166                       (lambda () (proc 0)))))
 167         (let ((counts (line-execution-counts data "baz.scm")))
 168           (and (pair? counts)
 169                (every (lambda (line+count)
 170                         (let ((line  (car line+count))
 171                               (count (cdr line+count)))
 172                           (case line
 173                             ((0 1)     (= count 1))
 174                             ((2 3 4 5) (= count 0))
 175                             (else      #f))))
 176                       counts))))))
 177
 178   (pass-if "case-lambda"
 179     (let ((proc (code "cl.scm"  "(case-lambda       ;; 0
 180                                    ((x)   (+ x 3))  ;; 1
 181                                    ((x y) (+ x y))) ;; 2")))
 182       (let-values (((data result)
 183                     (with-code-coverage
 184                       (lambda ()
 185                         (+ (proc 1) (proc 2 3))))))
 186         (let ((counts (line-execution-counts data "cl.scm")))
 187           (and (pair? counts)
 188                (lset= equal? '((0 . 2) (1 . 1) (2 . 1)) counts))))))
 189
 190   (pass-if "all code on one line"
 191     ;; There are several proc/IP pairs pointing to this source line, yet the hit
 192     ;; count for the line should be 1.
 193     (let ((proc (code "one-liner.scm"
 194             "(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))")))
 195       (let-values (((data result)
 196                     (with-code-coverage
 197                       (lambda () (proc 451 1884)))))
 198         (let ((counts (line-execution-counts data "one-liner.scm")))
 199           (equal? counts '((0 . 1))))))))
 200
 201 \f
 202 (with-test-prefix "procedure-execution-count"
 203
 204   (pass-if "several times"
 205     (let ((proc (code "foo.scm" "(lambda (x y) x)")))
 206       (let-values (((data result)
 207                     (with-code-coverage
 208                       (lambda () (+ (proc 1 2) (proc 2 3))))))
 209         (and (coverage-data? data)
 210              (= 3 result)
 211              (= (procedure-execution-count data proc) 2)))))
 212
 213   (pass-if "case-lambda"
 214     (let ((proc (code "foo.scm" "(case-lambda ((x) x) ((x y) (+ x y)))")))
 215       (let-values (((data result)
 216                     (with-code-coverage
 217                       (lambda ()
 218                         (+ (proc 1) (proc 2 3))))))
 219         (and (coverage-data? data)
 220              (= 6 result)
 221              (= (procedure-execution-count data proc) 2)))))
 222
 223   (pass-if "never"
 224     (let ((proc (code "foo.scm" "(lambda (x y) x)")))
 225       (let-values (((data result)
 226                     (with-code-coverage
 227                       (lambda () (+ 1 2)))))
 228         (and (coverage-data? data)
 229              (= 3 result)
 230              (zero? (procedure-execution-count data proc))))))
 231
 232   (pass-if "applicable struct"
 233     (let* ((<box> (make-struct <applicable-struct-vtable> 0 'pw))
 234            (proc  (lambda args (length args)))
 235            (b     (make-struct <box> 0 proc)))
 236       (let-values (((data result)
 237                     (with-code-coverage b)))
 238         (and (coverage-data? data)
 239              (= 0 result)
 240              (= (procedure-execution-count data proc) 1)))))
 241
 242   (pass-if "called from C"
 243     ;; The `scm_call_N' functions use the VM returned by `the-vm'.  This
 244     ;; test makes sure that their calls are traced.
 245     (let ((proc (code "foo.scm" "(lambda (x y) (+ x y))"))
 246           (call (false-if-exception       ; can we resolve `scm_call_2'?
 247                  (pointer->procedure '*
 248                                      (dynamic-func "scm_call_2"
 249                                                    (dynamic-link))
 250                                      '(* * *)))))
 251       (if call
 252           (let-values (((data result)
 253                         (with-code-coverage
 254                           (lambda ()
 255                             (call (make-pointer (object-address proc))
 256                                   (make-pointer (object-address 1))
 257                                   (make-pointer (object-address 2)))))))
 258             (and (coverage-data? data)
 259                  (= (object-address 3) (pointer-address result))
 260                  (= (procedure-execution-count data proc) 1)))
 261           (throw 'unresolved))))
 262
 263   (pass-if "called from eval"
 264     (let-values (((data result)
 265                   (with-code-coverage
 266                     (lambda ()
 267                       (eval '(test-procedure 123) (current-module))))))
 268       (and (coverage-data? data)
 269            (= (test-procedure 123) result)
 270            (= (procedure-execution-count data test-procedure) 1)))))
 271
 272 \f
 273 (with-test-prefix "instrumented-source-files"
 274
 275   (pass-if "source files are listed as expected"
 276     (let ((proc (code "chbouib.scm" "(lambda (x y) x)")))
 277       (let-values (((data result)
 278                     (with-code-coverage
 279                       (lambda () (proc 1 2)))))
 280
 281         (let ((files (map basename (instrumented-source-files data))))
 282           (and (member "boot-9.scm" files)
 283                (member "chbouib.scm" files)
 284                #t))))))