guile/test-suite/tests/coverage.test

;;;; coverage.test --- Code coverage.    -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; 	Copyright (C) 2010, 2011, 2012, 2013, 2014, 2015, 2017 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 (test-coverage)
  #:use-module (test-suite lib)
  #:use-module (system vm coverage)
  #:use-module (system vm vm)
  #:use-module (system base compile)
  #:use-module (system foreign)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11))

(define-syntax code
  (syntax-rules ()
    ((_ filename snippet)
     (let ((input (open-input-string snippet)))
       (set-port-filename! input filename)
       (read-enable 'positions)
       (compile (read input))))))

(define test-procedure
  (compile '(lambda (x)
              (if (> x 2)
                  (- x 2)
                  (+ x 2)))))


(with-test-prefix "instrumented/executed-lines"

  (pass-if "instr = exec"
    (let ((proc (code "foo.scm" "(lambda (x y)  ;; 0
                                   (+ x y))     ;; 1")))
      (let-values (((data result)
                    (with-code-coverage
                      (lambda () (proc 1 2)))))
        (and (coverage-data? data)
             (= 3 result)
             (let-values (((instr exec)
                           (instrumented/executed-lines data "foo.scm")))
               (and (= 2 instr) (= 2 exec)))))))

  (pass-if "instr >= exec"
    (let ((proc (code "foo.scm" "(lambda (x y)       ;; 0
                                   (if (> x y)       ;; 1
                                       (begin        ;; 2
                                         (display x) ;; 3
                                         (+ x y))))  ;; 4")))
      (let-values (((data result)
                    (with-code-coverage
                      (lambda () (proc 1 2)))))
        (and (coverage-data? data)
             (let-values (((instr exec)
                           (instrumented/executed-lines data "foo.scm")))
               (and (> instr 0) (>= instr exec))))))))


(with-test-prefix "line-execution-counts"

  (pass-if "once"
    (let ((proc (code "bar.scm" "(lambda (x y)   ;; 0
                                   (+ (/ x y)    ;; 1
                                      (* x y)))  ;; 2")))
      (let-values (((data result)
                    (with-code-coverage
                      (lambda () (proc 1 2)))))
        (let ((counts (line-execution-counts data "bar.scm")))
          (and (pair? counts)
               (every (lambda (line+count)
                        (let ((line  (car line+count))
                              (count (cdr line+count)))
                          (and (>= line 0)
                               (<= line 2)
                               (= count 1))))
                      counts))))))

  ;; Unhappily, lack of source location on identifiers combined with a
  ;; block reordering change makes this test fail.  The right solution
  ;; is to fix the compiler, but really it should happen by fixing
  ;; psyntax to have source location info for identifiers and immediate
  ;; values.
  (expect-fail "several times"
    (let ((proc (code "fooz.scm" "(lambda (x)                   ;; 0
                                    (format #f \"hello\")       ;; 1
                                    (let loop ((x x))           ;; 2
                                      (cond ((> x 0)            ;; 3
                                             (begin             ;; 4
                                               (format #f \"~a\" x)
                                               (loop (1- x))))  ;; 6
                                            ((= x 0) #t)        ;; 7
                                            ((< x 0) 'never))))")))
      (let-values (((data result)
                    (with-code-coverage
                      (lambda () (proc 77)))))
        (let ((counts (line-execution-counts data "fooz.scm")))
          (and (pair? counts)
               (every (lambda (line+count)
                        (let ((line  (car line+count))
                              (count (cdr line+count)))
                          ;; The actual line counts for aliasing
                          ;; operations, like the loop header that
                          ;; initializes "x" to "x", are sensitive to
                          ;; whether there is an associated "mov"
                          ;; instruction, or whether the value is left
                          ;; in place.  Currently there are no
                          ;; instructions for line 2, but we allow 1 as
                          ;; well.
                          (case line
                            ((0 1)   (= count 1))
                            ((2)     (<= 0 count 1))
                            ((3)     (= count 78))
                            ((4 5 6) (= count 77))
                            ((7)     (= count 1))
                            ((8)     (= count 0))
                            (else    #f))))
                      counts))))))

  (pass-if "some"
    (let ((proc (code "baz.scm" "(lambda (x y)       ;; 0
                                   (if (> x y)       ;; 1
                                       (begin        ;; 2
                                         (display x) ;; 3
                                         (+ x y))    ;; 4
                                       (+ x y)))     ;; 5")))
      (let-values (((data result)
                    (with-code-coverage
                      (lambda () (proc 1 2)))))
        (let ((counts (line-execution-counts data "baz.scm")))
          (and (pair? counts)
               (every (lambda (line+count)
                        (let ((line  (car line+count))
                              (count (cdr line+count)))
                          (case line
                            ((0 1 5) (= count 1))
                            ((2 3)   (= count 0))
                            ((4)     #t) ;; the start of the `else' branch is
                                         ;; attributed to line 4
                            (else    #f))))
                      counts))))))

  ;; Same unfortunate caveat as above: block ordering and source
  ;; locations :(
  (expect-fail "one proc hit, one proc unused"
    (let ((proc (code "baz.scm" "(letrec ((even? (lambda (x)               ;; 0
                                                   (or (= x 0)             ;; 1
                                                       (not (odd? (1- x))))))
                                          (odd?  (lambda (x)               ;; 3
                                                   (not (even? (1- x)))))) ;; 4
                                   even?)")))
      (let-values (((data result)
                    (with-code-coverage
                      (lambda () (proc 0)))))
        (let ((counts (line-execution-counts data "baz.scm")))
          (and (pair? counts)
               (every (lambda (line+count)
                        (let ((line  (car line+count))
                              (count (cdr line+count)))
                          (case line
                            ((0 1)     (= count 1))
                            ((2 3 4 5) (= count 0))
                            (else      #f))))
                      counts))))))

  (pass-if "case-lambda"
    (let ((proc (code "cl.scm"  "(case-lambda       ;; 0
                                   ((x)   (+ x 3))  ;; 1
                                   ((x y) (+ x y))) ;; 2")))
      (let-values (((data result)
                    (with-code-coverage
                      (lambda ()
                        (+ (proc 1) (proc 2 3))))))
        (let ((counts (line-execution-counts data "cl.scm")))
          (and (pair? counts)
               (lset= equal? '((0 . 2) (1 . 1) (2 . 1)) counts))))))

  (pass-if "all code on one line"
    ;; There are several proc/IP pairs pointing to this source line, yet the hit
    ;; count for the line should be 1.
    (let ((proc (code "one-liner.scm"
            "(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))")))
      (let-values (((data result)
                    (with-code-coverage
                      (lambda () (proc 451 1884)))))
        (let ((counts (line-execution-counts data "one-liner.scm")))
          (equal? counts '((0 . 1)))))))

  (pass-if "tail calls"
    (let ((proc (code "tail-calls.scm"
                      "(begin
                         (define (tail-call-test)
                           (display \"foo\\n\")
                           (tail-call-target))

                         (define (tail-call-target)
                           (display \"bar\\n\"))

                         tail-call-test)")))
      (let-values (((data result)
                    (with-code-coverage
                      (lambda () (with-output-to-string proc)))))
        (let ((counts (line-execution-counts data "tail-calls.scm")))
          (define (lset-contains? eq? a b)
            (lset= eq? b (lset-intersection eq? a b)))
          ;; Due to top-level binding optimization, the target may be
          ;; inlined or into the caller.  All we can say is that the
          ;; entry was seen, and the two displays were called.
          (lset-contains? equal? counts '((1 . 1) (2 . 1) (6 . 1))))))))


(with-test-prefix "procedure-execution-count"

  (pass-if "several times"
    (let ((proc (code "foo.scm" "(lambda (x y) x)")))
      (let-values (((data result)
                    (with-code-coverage
                      (lambda () (+ (proc 1 2) (proc 2 3))))))
        (and (coverage-data? data)
             (= 3 result)
             (= (procedure-execution-count data proc) 2)))))

  (pass-if "case-lambda"
    (let ((proc (code "foo.scm" "(case-lambda ((x) x) ((x y) (+ x y)))")))
      (let-values (((data result)
                    (with-code-coverage
                      (lambda ()
                        (+ (proc 1) (proc 2 3))))))
        (and (coverage-data? data)
             (= 6 result)
             (= (procedure-execution-count data proc) 2)))))

  (pass-if "never"
    (let ((proc (code "foo.scm" "(lambda (x y) x)")))
      (let-values (((data result)
                    (with-code-coverage
                      (lambda () (+ 1 2)))))
        (and (coverage-data? data)
             (= 3 result)
             (zero? (procedure-execution-count data proc))))))

  (pass-if "applicable struct"
    (let* ((<box> (make-struct/no-tail <applicable-struct-vtable> 'pw))
           (proc  (lambda args (length args)))
           (b     (make-struct/no-tail <box> proc)))
      (let-values (((data result)
                    (with-code-coverage b)))
        (and (coverage-data? data)
             (= 0 result)
             (= (procedure-execution-count data proc) 1)))))

  (pass-if "called from C"
    ;; The `scm_call_N' functions use the VM returned by `the-vm'.  This
    ;; test makes sure that their calls are traced.
    (let ((proc (code "foo.scm" "(lambda (x y) (+ x y))"))
          (call (false-if-exception       ; can we resolve `scm_call_2'?
                 (pointer->procedure '*
                                     (dynamic-func "scm_call_2"
                                                   (dynamic-link))
                                     '(* * *)))))
      (if call
          (let-values (((data result)
                        (with-code-coverage
                          (lambda ()
                            (call (make-pointer (object-address proc))
                                  (make-pointer (object-address 1))
                                  (make-pointer (object-address 2)))))))
            (and (coverage-data? data)
                 (= (object-address 3) (pointer-address result))
                 (= (procedure-execution-count data proc) 1)))
          (throw 'unresolved))))

  (pass-if "called from eval"
    (let-values (((data result)
                  (with-code-coverage
                    (lambda ()
                      (eval '(test-procedure 123) (current-module))))))
      (and (coverage-data? data)
           (= (test-procedure 123) result)
           (= (procedure-execution-count data test-procedure) 1)))))


(with-test-prefix "instrumented-source-files"

  (pass-if "source files are listed as expected"
    (let ((proc (code "chbouib.scm" "(lambda (x y) x)")))
      (let-values (((data result)
                    (with-code-coverage
                      (lambda () (proc 1 2)))))

        (let ((files (map basename (instrumented-source-files data))))
          (and (member "boot-9.scm" files)
               (member "chbouib.scm" files)
               #t))))))