test-suite/tests/coverage.test

   1 ;;;; coverage.test --- Code coverage.    -*- mode: scheme; coding: utf-8; -*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2010, 2011, 2012, 2013, 2014 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   (pass-if "several times"
  92     (let ((proc (code "fooz.scm" "(lambda (x)                   ;; 0
  93                                     (format #f \"hello\")       ;; 1
  94                                     (let loop ((x x))           ;; 2
  95                                       (cond ((> x 0)            ;; 3
  96                                              (begin             ;; 4
  97                                                (format #f \"~a\" x)
  98                                                (loop (1- x))))  ;; 6
  99                                             ((= x 0) #t)        ;; 7
 100                                             ((< x 0) 'never))))")))
 101       (let-values (((data result)
 102                     (with-code-coverage
 103                       (lambda () (proc 77)))))
 104         (let ((counts (line-execution-counts data "fooz.scm")))
 105           (and (pair? counts)
 106                (every (lambda (line+count)
 107                         (let ((line  (car line+count))
 108                               (count (cdr line+count)))
 109                           ;; The actual line counts for aliasing
 110                           ;; operations, like the loop header that
 111                           ;; initializes "x" to "x", are sensitive to
 112                           ;; whether there is an associated "mov"
 113                           ;; instruction, or whether the value is left
 114                           ;; in place.  Currently there are no
 115                           ;; instructions for line 2, but we allow 1 as
 116                           ;; well.
 117                           (case line
 118                             ((0 1)   (= count 1))
 119                             ((2)     (<= 0 count 1))
 120                             ((3)     (= count 78))
 121                             ((4 5 6) (= count 77))
 122                             ((7)     (= count 1))
 123                             ((8)     (= count 0))
 124                             (else    #f))))
 125                       counts))))))
 126
 127   (pass-if "some"
 128     (let ((proc (code "baz.scm" "(lambda (x y)       ;; 0
 129                                    (if (> x y)       ;; 1
 130                                        (begin        ;; 2
 131                                          (display x) ;; 3
 132                                          (+ x y))    ;; 4
 133                                        (+ x y)))     ;; 5")))
 134       (let-values (((data result)
 135                     (with-code-coverage
 136                       (lambda () (proc 1 2)))))
 137         (let ((counts (line-execution-counts data "baz.scm")))
 138           (and (pair? counts)
 139                (every (lambda (line+count)
 140                         (let ((line  (car line+count))
 141                               (count (cdr line+count)))
 142                           (case line
 143                             ((0 1 5) (= count 1))
 144                             ((2 3)   (= count 0))
 145                             ((4)     #t) ;; the start of the `else' branch is
 146                                          ;; attributed to line 4
 147                             (else    #f))))
 148                       counts))))))
 149
 150   (pass-if "one proc hit, one proc unused"
 151     (let ((proc (code "baz.scm" "(letrec ((even? (lambda (x)               ;; 0
 152                                                    (or (= x 0)             ;; 1
 153                                                        (not (odd? (1- x))))))
 154                                           (odd?  (lambda (x)               ;; 3
 155                                                    (not (even? (1- x)))))) ;; 4
 156                                    even?)")))
 157       (let-values (((data result)
 158                     (with-code-coverage
 159                       (lambda () (proc 0)))))
 160         (let ((counts (line-execution-counts data "baz.scm")))
 161           (and (pair? counts)
 162                (every (lambda (line+count)
 163                         (let ((line  (car line+count))
 164                               (count (cdr line+count)))
 165                           (case line
 166                             ((0 1)     (= count 1))
 167                             ((2 3 4 5) (= count 0))
 168                             (else      #f))))
 169                       counts))))))
 170
 171   (pass-if "case-lambda"
 172     (let ((proc (code "cl.scm"  "(case-lambda       ;; 0
 173                                    ((x)   (+ x 3))  ;; 1
 174                                    ((x y) (+ x y))) ;; 2")))
 175       (let-values (((data result)
 176                     (with-code-coverage
 177                       (lambda ()
 178                         (+ (proc 1) (proc 2 3))))))
 179         (let ((counts (line-execution-counts data "cl.scm")))
 180           (and (pair? counts)
 181                (lset= equal? '((0 . 2) (1 . 1) (2 . 1)) counts))))))
 182
 183   (pass-if "all code on one line"
 184     ;; There are several proc/IP pairs pointing to this source line, yet the hit
 185     ;; count for the line should be 1.
 186     (let ((proc (code "one-liner.scm"
 187             "(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))")))
 188       (let-values (((data result)
 189                     (with-code-coverage
 190                       (lambda () (proc 451 1884)))))
 191         (let ((counts (line-execution-counts data "one-liner.scm")))
 192           (equal? counts '((0 . 1))))))))
 193
 194 \f
 195 (with-test-prefix "procedure-execution-count"
 196
 197   (pass-if "several times"
 198     (let ((proc (code "foo.scm" "(lambda (x y) x)")))
 199       (let-values (((data result)
 200                     (with-code-coverage
 201                       (lambda () (+ (proc 1 2) (proc 2 3))))))
 202         (and (coverage-data? data)
 203              (= 3 result)
 204              (= (procedure-execution-count data proc) 2)))))
 205
 206   (pass-if "case-lambda"
 207     (let ((proc (code "foo.scm" "(case-lambda ((x) x) ((x y) (+ x y)))")))
 208       (let-values (((data result)
 209                     (with-code-coverage
 210                       (lambda ()
 211                         (+ (proc 1) (proc 2 3))))))
 212         (and (coverage-data? data)
 213              (= 6 result)
 214              (= (procedure-execution-count data proc) 2)))))
 215
 216   (pass-if "never"
 217     (let ((proc (code "foo.scm" "(lambda (x y) x)")))
 218       (let-values (((data result)
 219                     (with-code-coverage
 220                       (lambda () (+ 1 2)))))
 221         (and (coverage-data? data)
 222              (= 3 result)
 223              (zero? (procedure-execution-count data proc))))))
 224
 225   (pass-if "applicable struct"
 226     (let* ((<box> (make-struct <applicable-struct-vtable> 0 'pw))
 227            (proc  (lambda args (length args)))
 228            (b     (make-struct <box> 0 proc)))
 229       (let-values (((data result)
 230                     (with-code-coverage b)))
 231         (and (coverage-data? data)
 232              (= 0 result)
 233              (= (procedure-execution-count data proc) 1)))))
 234
 235   (pass-if "called from C"
 236     ;; The `scm_call_N' functions use the VM returned by `the-vm'.  This
 237     ;; test makes sure that their calls are traced.
 238     (let ((proc (code "foo.scm" "(lambda (x y) (+ x y))"))
 239           (call (false-if-exception       ; can we resolve `scm_call_2'?
 240                  (pointer->procedure '*
 241                                      (dynamic-func "scm_call_2"
 242                                                    (dynamic-link))
 243                                      '(* * *)))))
 244       (if call
 245           (let-values (((data result)
 246                         (with-code-coverage
 247                           (lambda ()
 248                             (call (make-pointer (object-address proc))
 249                                   (make-pointer (object-address 1))
 250                                   (make-pointer (object-address 2)))))))
 251             (and (coverage-data? data)
 252                  (= (object-address 3) (pointer-address result))
 253                  (= (procedure-execution-count data proc) 1)))
 254           (throw 'unresolved))))
 255
 256   (pass-if "called from eval"
 257     (let-values (((data result)
 258                   (with-code-coverage
 259                     (lambda ()
 260                       (eval '(test-procedure 123) (current-module))))))
 261       (and (coverage-data? data)
 262            (= (test-procedure 123) result)
 263            (= (procedure-execution-count data test-procedure) 1)))))
 264
 265 \f
 266 (with-test-prefix "instrumented-source-files"
 267
 268   (pass-if "source files are listed as expected"
 269     (let ((proc (code "chbouib.scm" "(lambda (x y) x)")))
 270       (let-values (((data result)
 271                     (with-code-coverage
 272                       (lambda () (proc 1 2)))))
 273
 274         (let ((files (map basename (instrumented-source-files data))))
 275           (and (member "boot-9.scm" files)
 276                (member "chbouib.scm" files)
 277                #t))))))