tests/test-util.lisp

   1 (defpackage :test-util
   2   (:use :cl :sb-ext)
   3   (:export #:with-test #:report-test-status #:*failures*
   4            #:really-invoke-debugger
   5            #:*break-on-failure* #:*break-on-expected-failure*
   6            #:make-kill-thread #:make-join-thread
   7            #:runtime))
   8
   9 (in-package :test-util)
  10
  11 (defvar *test-count* 0)
  12 (defvar *test-file* nil)
  13 (defvar *failures* nil)
  14 (defvar *break-on-failure* nil)
  15 (defvar *break-on-expected-failure* nil)
  16
  17 (defvar *threads-to-kill*)
  18 (defvar *threads-to-join*)
  19
  20 #+sb-thread
  21 (defun make-kill-thread (&rest args)
  22   (let ((thread (apply #'sb-thread:make-thread args)))
  23     (when (boundp '*threads-to-kill*)
  24       (push thread *threads-to-kill*))
  25     thread))
  26
  27 #+sb-thread
  28 (defun make-join-thread (&rest args)
  29   (let ((thread (apply #'sb-thread:make-thread args)))
  30     (when (boundp '*threads-to-join*)
  31       (push thread *threads-to-join*))
  32     thread))
  33
  34 (defun log-msg (&rest args)
  35   (format *trace-output* "~&::: ")
  36   (apply #'format *trace-output* args)
  37   (terpri *trace-output*)
  38   (force-output *trace-output*))
  39
  40 (defmacro with-test ((&key fails-on broken-on skipped-on name)
  41                      &body body)
  42   (let ((block-name (gensym))
  43         #+sb-thread (threads (gensym "THREADS")))
  44     `(progn
  45        (start-test)
  46        (cond
  47          ((broken-p ,broken-on)
  48           (fail-test :skipped-broken ',name "Test broken on this platform"))
  49          ((skipped-p ,skipped-on)
  50           (fail-test :skipped-disabled ',name "Test disabled for this combination of platform and features"))
  51          (t
  52           (let (#+sb-thread (,threads (sb-thread:list-all-threads))
  53                 (*threads-to-join* nil)
  54                 (*threads-to-kill* nil))
  55             (block ,block-name
  56               (handler-bind ((error (lambda (error)
  57                                       (if (expected-failure-p ,fails-on)
  58                                           (fail-test :expected-failure ',name error)
  59                                           (fail-test :unexpected-failure ',name error))
  60                                       (return-from ,block-name))))
  61                 (progn
  62                   (log-msg "Running ~S" ',name)
  63                   ,@body
  64                   #+sb-thread
  65                   (let ((any-leftover nil))
  66                     (dolist (thread *threads-to-join*)
  67                       (ignore-errors (sb-thread:join-thread thread)))
  68                     (dolist (thread *threads-to-kill*)
  69                       (ignore-errors (sb-thread:terminate-thread thread)))
  70                     (setf ,threads (union (union *threads-to-kill*
  71                                                  *threads-to-join*)
  72                                           ,threads))
  73                     #+(and sb-safepoint-strictly (not win32))
  74                     (dolist (thread (sb-thread:list-all-threads))
  75                       (when (typep thread 'sb-thread:signal-handling-thread)
  76                         (ignore-errors (sb-thread:join-thread thread))))
  77                     (dolist (thread (sb-thread:list-all-threads))
  78                       (unless (or (not (sb-thread:thread-alive-p thread))
  79                                   (eql thread sb-thread:*current-thread*)
  80                                   (member thread ,threads)
  81                                   (sb-thread:thread-emphemeral-p thread))
  82                         (setf any-leftover thread)
  83                         (ignore-errors (sb-thread:terminate-thread thread))))
  84                     (when any-leftover
  85                       (fail-test :leftover-thread ',name any-leftover)
  86                       (return-from ,block-name)))
  87                   (if (expected-failure-p ,fails-on)
  88                       (fail-test :unexpected-success ',name nil)
  89                       (log-msg "Success ~S" ',name)))))))))))
  90
  91 (defun report-test-status ()
  92   (with-standard-io-syntax
  93       (with-open-file (stream "test-status.lisp-expr"
  94                               :direction :output
  95                               :if-exists :supersede)
  96         (format stream "~s~%" *failures*))))
  97
  98 (defun start-test ()
  99   (unless (eq *test-file* *load-pathname*)
 100     (setf *test-file* *load-pathname*)
 101     (setf *test-count* 0))
 102   (incf *test-count*))
 103
 104 (defun really-invoke-debugger (condition)
 105   (with-simple-restart (continue "Continue")
 106     (let ((*invoke-debugger-hook* *invoke-debugger-hook*))
 107       (enable-debugger)
 108       (invoke-debugger condition))))
 109
 110 (defun fail-test (type test-name condition)
 111   (if (stringp condition)
 112       (log-msg "~@<~A ~S ~:_~A~:>"
 113                type test-name condition)
 114       (log-msg "~@<~A ~S ~:_due to ~S: ~4I~:_\"~A\"~:>"
 115                type test-name condition condition))
 116   (push (list type *test-file* (or test-name *test-count*))
 117         *failures*)
 118   (unless (stringp condition)
 119     (when (or (and *break-on-failure*
 120                    (not (eq type :expected-failure)))
 121               *break-on-expected-failure*)
 122       (really-invoke-debugger condition))))
 123
 124 (defun expected-failure-p (fails-on)
 125   (sb-impl::featurep fails-on))
 126
 127 (defun broken-p (broken-on)
 128   (sb-impl::featurep broken-on))
 129
 130 (defun skipped-p (skipped-on)
 131   (sb-impl::featurep skipped-on))
 132
 133 (defun test-env ()
 134   (cons (format nil "SBCL_MACHINE_TYPE=~A" (machine-type))
 135         (cons (format nil "SBCL_SOFTWARE_TYPE=~A" (software-type))
 136               (posix-environ))))
 137
 138 ;;; Repeat calling THUNK until its cumulated runtime, measured using
 139 ;;; GET-INTERNAL-RUN-TIME, is larger than PRECISION. Repeat this
 140 ;;; REPETITIONS many times and return the time one call to THUNK took
 141 ;;; in seconds as a float, according to the minimum of the cumulated
 142 ;;; runtimes over the repetitions.
 143 ;;; This allows to easily measure the runtime of expressions that take
 144 ;;; much less time than one internal time unit. Also, the results are
 145 ;;; unaffected, modulo quantization effects, by changes to
 146 ;;; INTERNAL-TIME-UNITS-PER-SECOND.
 147 ;;; Taking the minimum is intended to reduce the error introduced by
 148 ;;; garbage collections occurring at unpredictable times. The inner
 149 ;;; loop doubles the number of calls to THUNK each time before again
 150 ;;; measuring the time spent, so that the time measurement overhead
 151 ;;; doesn't distort the result if calling THUNK takes very little time.
 152 (defun runtime* (thunk repetitions precision)
 153   (loop repeat repetitions
 154         minimize
 155         (loop with start = (get-internal-run-time)
 156               with duration = 0
 157               for n = 1 then (* n 2)
 158               for total-runs = n then (+ total-runs n)
 159               do (dotimes (i n)
 160                    (funcall thunk))
 161                  (setf duration (- (get-internal-run-time) start))
 162               when (> duration precision)
 163               return (/ (float duration) (float total-runs)))
 164         into min-internal-time-units-per-call
 165         finally (return (/ min-internal-time-units-per-call
 166                            (float internal-time-units-per-second)))))
 167
 168 (defmacro runtime (form &key (repetitions 3) (precision 10))
 169   `(runtime* (lambda () ,form) ,repetitions ,precision))