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            #:checked-compile #:checked-compile-capturing-source-paths
   8            #:checked-compile-condition-source-paths
   9            #:runtime #:split-string #:shuffle))
  10
  11 (in-package :test-util)
  12
  13 (defvar *test-count* 0)
  14 (defvar *test-file* nil)
  15 (defvar *failures* nil)
  16 (defvar *break-on-failure* nil)
  17 (defvar *break-on-expected-failure* nil)
  18
  19 (defvar *threads-to-kill*)
  20 (defvar *threads-to-join*)
  21
  22 (eval-when (:compile-toplevel :load-toplevel :execute)
  23   (require :sb-posix))
  24
  25 (sb-posix:putenv (format nil "SBCL_MACHINE_TYPE=~A" (machine-type)))
  26 (sb-posix:putenv (format nil "SBCL_SOFTWARE_TYPE=~A" (software-type)))
  27
  28 #+sb-thread
  29 (defun make-kill-thread (&rest args)
  30   (let ((thread (apply #'sb-thread:make-thread args)))
  31     (when (boundp '*threads-to-kill*)
  32       (push thread *threads-to-kill*))
  33     thread))
  34
  35 #+sb-thread
  36 (defun make-join-thread (&rest args)
  37   (let ((thread (apply #'sb-thread:make-thread args)))
  38     (when (boundp '*threads-to-join*)
  39       (push thread *threads-to-join*))
  40     thread))
  41
  42 (defun log-msg (&rest args)
  43   (apply #'format *trace-output* "~&::: ~@?~%" args)
  44   (force-output *trace-output*))
  45
  46 (defun log-msg/non-pretty (&rest args)
  47   (let ((*print-pretty* nil))
  48     (apply #'log-msg args)))
  49
  50 (defmacro with-test ((&key fails-on broken-on skipped-on name)
  51                      &body body)
  52   (let ((block-name (gensym))
  53         #+sb-thread (threads (gensym "THREADS")))
  54     (flet ((name-ok (x y)
  55              (declare (ignore y))
  56              (typecase x
  57                (symbol (let ((package (symbol-package x)))
  58                          (or (null package)
  59                              (eql package (find-package "CL"))
  60                              (eql package (find-package "KEYWORD"))
  61                              (eql (mismatch "SB-" (package-name package)) 3))))
  62                (integer t))))
  63       (unless (tree-equal name name :test #'name-ok)
  64         (error "test name must be all-keywords: ~S" name)))
  65     `(progn
  66        (start-test)
  67        (cond
  68          ((broken-p ,broken-on)
  69           (fail-test :skipped-broken ',name "Test broken on this platform"))
  70          ((skipped-p ,skipped-on)
  71           (fail-test :skipped-disabled ',name "Test disabled for this combination of platform and features"))
  72          (t
  73           (let (#+sb-thread (,threads (sb-thread:list-all-threads))
  74                 (*threads-to-join* nil)
  75                 (*threads-to-kill* nil))
  76             (block ,block-name
  77               (handler-bind ((error (lambda (error)
  78                                       (if (expected-failure-p ,fails-on)
  79                                           (fail-test :expected-failure ',name error)
  80                                           (fail-test :unexpected-failure ',name error))
  81                                       (return-from ,block-name))))
  82                 (progn
  83                   ;; Non-pretty is for cases like (with-test (:name (let ...)) ...
  84                   (log-msg/non-pretty "Running ~S" ',name)
  85                   ,@body
  86                   #+sb-thread
  87                   (let ((any-leftover nil))
  88                     (dolist (thread *threads-to-join*)
  89                       (ignore-errors (sb-thread:join-thread thread)))
  90                     (dolist (thread *threads-to-kill*)
  91                       (ignore-errors (sb-thread:terminate-thread thread)))
  92                     (setf ,threads (union (union *threads-to-kill*
  93                                                  *threads-to-join*)
  94                                           ,threads))
  95                     #+(and sb-safepoint-strictly (not win32))
  96                     (dolist (thread (sb-thread:list-all-threads))
  97                       (when (typep thread 'sb-thread:signal-handling-thread)
  98                         (ignore-errors (sb-thread:join-thread thread))))
  99                     (dolist (thread (sb-thread:list-all-threads))
 100                       (unless (or (not (sb-thread:thread-alive-p thread))
 101                                   (eql (the sb-thread:thread thread)
 102                                        sb-thread:*current-thread*)
 103                                   (member thread ,threads)
 104                                   (sb-thread:thread-ephemeral-p thread))
 105                         (setf any-leftover thread)
 106                         (ignore-errors (sb-thread:terminate-thread thread))))
 107                     (when any-leftover
 108                       (fail-test :leftover-thread ',name any-leftover)
 109                       (return-from ,block-name)))
 110                   (if (expected-failure-p ,fails-on)
 111                       (fail-test :unexpected-success ',name nil)
 112                       ;; Non-pretty is for cases like (with-test (:name (let ...)) ...
 113                       (log-msg/non-pretty "Success ~S" ',name)))))))))))
 114
 115 (defun report-test-status ()
 116   (with-standard-io-syntax
 117       (with-open-file (stream "test-status.lisp-expr"
 118                               :direction :output
 119                               :if-exists :supersede)
 120         (format stream "~s~%" *failures*))))
 121
 122 (defun start-test ()
 123   (unless (eq *test-file* *load-pathname*)
 124     (setf *test-file* *load-pathname*)
 125     (setf *test-count* 0))
 126   (incf *test-count*))
 127
 128 (defun really-invoke-debugger (condition)
 129   (with-simple-restart (continue "Continue")
 130     (let ((*invoke-debugger-hook* *invoke-debugger-hook*))
 131       (enable-debugger)
 132       (invoke-debugger condition))))
 133
 134 (defun fail-test (type test-name condition)
 135   (if (stringp condition)
 136       (log-msg "~@<~A ~S ~:_~A~:>"
 137                type test-name condition)
 138       (log-msg "~@<~A ~S ~:_due to ~S: ~4I~:_\"~A\"~:>"
 139                type test-name (type-of condition) condition))
 140   (push (list type *test-file* (or test-name *test-count*))
 141         *failures*)
 142   (unless (stringp condition)
 143     (when (or (and *break-on-failure*
 144                    (not (eq type :expected-failure)))
 145               *break-on-expected-failure*)
 146       (really-invoke-debugger condition))))
 147
 148 (defun expected-failure-p (fails-on)
 149   (sb-impl::featurep fails-on))
 150
 151 (defun broken-p (broken-on)
 152   (sb-impl::featurep broken-on))
 153
 154 (defun skipped-p (skipped-on)
 155   (sb-impl::featurep skipped-on))
 156
 157 ;;; Compile FORM capturing and muffling all [style-]warnings and notes
 158 ;;; and return six values: 1) the compiled function 2) a Boolean
 159 ;;; indicating whether compilation failed 3) a list of warnings 4) a
 160 ;;; list of style-warnings 5) a list of notes 6) a list of
 161 ;;; SB-C:COMPILER-ERROR conditions.
 162 ;;;
 163 ;;; An error can be signaled when COMPILE indicates failure as well as
 164 ;;; in case [style-]warning or note conditions are signaled. The
 165 ;;; keyword parameters
 166 ;;; ALLOW-{FAILURE,[STYLE-]WARNINGS,NOTES,COMPILER-ERRORS} control
 167 ;;; this behavior. All but ALLOW-NOTES default to NIL.
 168 ;;;
 169 ;;; Arguments to the
 170 ;;; ALLOW-{FAILURE,[STYLE-]WARNINGS,NOTES,COMPILER-ERRORS} keyword
 171 ;;; parameters are interpreted as type specifiers restricting the
 172 ;;; allowed conditions of the respective kind.
 173 ;;;
 174 ;;; When supplied, the value of CONDITION-TRANSFORM has to be a
 175 ;;; function of one argument, the condition currently being
 176 ;;; captured. The returned value is captured and later returned in
 177 ;;; place of the condition.
 178 (defun checked-compile (form
 179                         &key
 180                         name
 181                         allow-failure
 182                         allow-warnings
 183                         allow-style-warnings
 184                         (allow-notes t)
 185                         (allow-compiler-errors allow-failure)
 186                         condition-transform)
 187   (let ((warnings '())
 188         (style-warnings '())
 189         (notes '())
 190         (compiler-errors '())
 191         (error-output (make-string-output-stream)))
 192     (flet ((maybe-transform (condition)
 193              (if condition-transform
 194                  (funcall condition-transform condition)
 195                  condition)))
 196       (handler-bind ((sb-ext:compiler-note
 197                       (lambda (condition)
 198                         (push (maybe-transform condition) notes)
 199                         (muffle-warning condition)))
 200                      (style-warning
 201                       (lambda (condition)
 202                         (push (maybe-transform condition) style-warnings)
 203                         (muffle-warning condition)))
 204                      (warning
 205                       (lambda (condition)
 206                         (push (maybe-transform condition) warnings)
 207                         (muffle-warning condition)))
 208                      (sb-c:compiler-error
 209                       (lambda (condition)
 210                         (push (maybe-transform condition) compiler-errors))))
 211         (multiple-value-bind (function warnings-p failure-p)
 212             (let ((*error-output* error-output))
 213               (compile name form))
 214           (declare (ignore warnings-p))
 215           (labels ((fail (kind conditions &optional allowed-type)
 216                      (error "~@<Compilation of ~S signaled ~A~P:~
 217                              ~{~@:_~@:_~{~/sb-impl:print-symbol-with-prefix/: ~A~}~}~
 218                              ~@[~@:_~@:_Allowed type is ~S.~]~@:>"
 219                             form kind (length conditions)
 220                             (mapcar (lambda (condition)
 221                                       (list (type-of condition) condition))
 222                                     conditions)
 223                             allowed-type))
 224                    (check-conditions (kind conditions allow)
 225                      (cond
 226                        (allow
 227                         (let ((offenders (remove-if (lambda (condition)
 228                                                       (typep condition allow))
 229                                                     conditions)))
 230                           (when offenders
 231                             (fail kind offenders allow))))
 232                        (conditions
 233                         (fail kind conditions)))))
 234
 235             (when (and (not allow-failure) failure-p)
 236               (let ((output (get-output-stream-string error-output)))
 237                 (error "~@<Compilation of ~S failed~@[ with ~
 238                         output~@:_~@:_~A~@:_~@:_~].~@:>"
 239                        form (when (plusp (length output)) output))))
 240
 241             (check-conditions "warning"        warnings        allow-warnings)
 242             (check-conditions "style-warning"  style-warnings  allow-style-warnings)
 243             (check-conditions "note"           notes           allow-notes)
 244             (check-conditions "compiler-error" compiler-errors allow-compiler-errors)
 245
 246             ;; Since we may have prevented warnings from being taken
 247             ;; into account for FAILURE-P by muffling them, adjust the
 248             ;; second return value accordingly.
 249             (values function (when (or failure-p warnings) t)
 250                     warnings style-warnings notes compiler-errors)))))))
 251
 252 ;;; Like CHECKED-COMPILE, but for each captured condition, capture and
 253 ;;; later return a cons
 254 ;;;
 255 ;;;   (CONDITION . SOURCE-PATH)
 256 ;;;
 257 ;;; instead. SOURCE-PATH is the path of the source form associated to
 258 ;;; CONDITION.
 259 (defun checked-compile-capturing-source-paths (form &rest args)
 260   (labels ((context-source-path ()
 261              (let ((context (sb-c::find-error-context nil)))
 262                (sb-c::compiler-error-context-original-source-path
 263                 context)))
 264            (add-source-path (condition)
 265              (cons condition (context-source-path))))
 266     (apply #'checked-compile form :condition-transform #'add-source-path
 267            args)))
 268
 269 ;;; Similar to CHECKED-COMPILE, but allow compilation failure and
 270 ;;; warnings and only return source paths associated to those
 271 ;;; conditions.
 272 (defun checked-compile-condition-source-paths (form)
 273   (let ((source-paths '()))
 274     (labels ((context-source-path ()
 275                (let ((context (sb-c::find-error-context nil)))
 276                  (sb-c::compiler-error-context-original-source-path
 277                   context)))
 278              (push-source-path (condition)
 279                (declare (ignore condition))
 280                (push (context-source-path) source-paths)))
 281       (checked-compile form
 282                        :allow-failure t
 283                        :allow-warnings t
 284                        :allow-style-warnings t
 285                        :condition-transform #'push-source-path))
 286     (nreverse source-paths)))
 287
 288 ;;; Repeat calling THUNK until its cumulated runtime, measured using
 289 ;;; GET-INTERNAL-RUN-TIME, is larger than PRECISION. Repeat this
 290 ;;; REPETITIONS many times and return the time one call to THUNK took
 291 ;;; in seconds as a float, according to the minimum of the cumulated
 292 ;;; runtimes over the repetitions.
 293 ;;; This allows to easily measure the runtime of expressions that take
 294 ;;; much less time than one internal time unit. Also, the results are
 295 ;;; unaffected, modulo quantization effects, by changes to
 296 ;;; INTERNAL-TIME-UNITS-PER-SECOND.
 297 ;;; Taking the minimum is intended to reduce the error introduced by
 298 ;;; garbage collections occurring at unpredictable times. The inner
 299 ;;; loop doubles the number of calls to THUNK each time before again
 300 ;;; measuring the time spent, so that the time measurement overhead
 301 ;;; doesn't distort the result if calling THUNK takes very little time.
 302 (defun runtime* (thunk repetitions precision)
 303   (loop repeat repetitions
 304         minimize
 305         (loop with start = (get-internal-run-time)
 306               with duration = 0
 307               for n = 1 then (* n 2)
 308               for total-runs = n then (+ total-runs n)
 309               do (dotimes (i n)
 310                    (funcall thunk))
 311                  (setf duration (- (get-internal-run-time) start))
 312               when (> duration precision)
 313               return (/ (float duration) (float total-runs)))
 314         into min-internal-time-units-per-call
 315         finally (return (/ min-internal-time-units-per-call
 316                            (float internal-time-units-per-second)))))
 317
 318 (defmacro runtime (form &key (repetitions 3) (precision 10))
 319   `(runtime* (lambda () ,form) ,repetitions ,precision))
 320
 321 (defun split-string (string delimiter)
 322   (loop for begin = 0 then (1+ end)
 323         for end = (position delimiter string) then (position delimiter string :start begin)
 324         collect (subseq string begin end)
 325         while end))
 326
 327 (defun shuffle (sequence)
 328   (typecase sequence
 329     (list
 330      (coerce (shuffle (coerce sequence 'vector)) 'list))
 331     (vector ; destructive
 332      (let ((vector sequence))
 333        (loop for lim from (1- (length vector)) downto 0
 334              for chosen = (random (1+ lim))
 335              unless (= chosen lim)
 336              do (rotatef (aref vector chosen) (aref vector lim)))
 337        vector))))