X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftest-util.lisp;h=7ec458cced6cf2e439bd3eb4b96a4812b0e4eaa4;hb=31f68584d0732dc0d17f379773e5f87f1e5a78ad;hp=8381019c7be36d165902be558dfdd26ff3ab93ac;hpb=9ef5527c3db71fcb3a98b5a37a1006789834ac0a;p=sbcl.git diff --git a/tests/test-util.lisp b/tests/test-util.lisp index 8381019..7ec458c 100644 --- a/tests/test-util.lisp +++ b/tests/test-util.lisp @@ -2,7 +2,9 @@ (:use :cl :sb-ext) (:export #:with-test #:report-test-status #:*failures* #:really-invoke-debugger - #:*break-on-failure* #:*break-on-expected-failure*)) + #:*break-on-failure* #:*break-on-expected-failure* + #:make-kill-thread #:make-join-thread + #:runtime)) (in-package :test-util) @@ -12,14 +14,50 @@ (defvar *break-on-failure* nil) (defvar *break-on-expected-failure* nil) +(defvar *threads-to-kill*) +(defvar *threads-to-join*) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sb-posix)) + +(sb-posix:putenv (format nil "SBCL_MACHINE_TYPE=~A" (machine-type))) +(sb-posix:putenv (format nil "SBCL_SOFTWARE_TYPE=~A" (software-type))) + +#+sb-thread +(defun make-kill-thread (&rest args) + (let ((thread (apply #'sb-thread:make-thread args))) + (when (boundp '*threads-to-kill*) + (push thread *threads-to-kill*)) + thread)) + +#+sb-thread +(defun make-join-thread (&rest args) + (let ((thread (apply #'sb-thread:make-thread args))) + (when (boundp '*threads-to-join*) + (push thread *threads-to-join*)) + thread)) + (defun log-msg (&rest args) (format *trace-output* "~&::: ") (apply #'format *trace-output* args) (terpri *trace-output*) (force-output *trace-output*)) -(defmacro with-test ((&key fails-on broken-on skipped-on name) &body body) - (let ((block-name (gensym))) +(defmacro with-test ((&key fails-on broken-on skipped-on name) + &body body) + (let ((block-name (gensym)) + #+sb-thread (threads (gensym "THREADS"))) + (flet ((name-ok (x y) + (declare (ignore y)) + (typecase x + (symbol (let ((package (symbol-package x))) + (or (null package) + (eql package (find-package "CL")) + (eql package (find-package "KEYWORD")) + (eql (mismatch "SB-" (package-name package)) 3)))) + (integer t)))) + (unless (tree-equal name name :test #'name-ok) + (error "test name must be all-keywords: ~S" name))) `(progn (start-test) (cond @@ -28,18 +66,44 @@ ((skipped-p ,skipped-on) (fail-test :skipped-disabled ',name "Test disabled for this combination of platform and features")) (t - (block ,block-name - (handler-bind ((error (lambda (error) - (if (expected-failure-p ,fails-on) - (fail-test :expected-failure ',name error) - (fail-test :unexpected-failure ',name error)) - (return-from ,block-name)))) - (progn - (log-msg "Running ~S" ',name) - ,@body - (if (expected-failure-p ,fails-on) - (fail-test :unexpected-success ',name nil) - (log-msg "Success ~S" ',name)))))))))) + (let (#+sb-thread (,threads (sb-thread:list-all-threads)) + (*threads-to-join* nil) + (*threads-to-kill* nil)) + (block ,block-name + (handler-bind ((error (lambda (error) + (if (expected-failure-p ,fails-on) + (fail-test :expected-failure ',name error) + (fail-test :unexpected-failure ',name error)) + (return-from ,block-name)))) + (progn + (log-msg "Running ~S" ',name) + ,@body + #+sb-thread + (let ((any-leftover nil)) + (dolist (thread *threads-to-join*) + (ignore-errors (sb-thread:join-thread thread))) + (dolist (thread *threads-to-kill*) + (ignore-errors (sb-thread:terminate-thread thread))) + (setf ,threads (union (union *threads-to-kill* + *threads-to-join*) + ,threads)) + #+(and sb-safepoint-strictly (not win32)) + (dolist (thread (sb-thread:list-all-threads)) + (when (typep thread 'sb-thread:signal-handling-thread) + (ignore-errors (sb-thread:join-thread thread)))) + (dolist (thread (sb-thread:list-all-threads)) + (unless (or (not (sb-thread:thread-alive-p thread)) + (eql thread sb-thread:*current-thread*) + (member thread ,threads) + (sb-thread:thread-ephemeral-p thread)) + (setf any-leftover thread) + (ignore-errors (sb-thread:terminate-thread thread)))) + (when any-leftover + (fail-test :leftover-thread ',name any-leftover) + (return-from ,block-name))) + (if (expected-failure-p ,fails-on) + (fail-test :unexpected-success ',name nil) + (log-msg "Success ~S" ',name))))))))))) (defun report-test-status () (with-standard-io-syntax @@ -83,7 +147,35 @@ (defun skipped-p (skipped-on) (sb-impl::featurep skipped-on)) -(defun test-env () - (cons (format nil "SBCL_MACHINE_TYPE=~A" (machine-type)) - (cons (format nil "SBCL_SOFTWARE_TYPE=~A" (software-type)) - (posix-environ)))) +;;; Repeat calling THUNK until its cumulated runtime, measured using +;;; GET-INTERNAL-RUN-TIME, is larger than PRECISION. Repeat this +;;; REPETITIONS many times and return the time one call to THUNK took +;;; in seconds as a float, according to the minimum of the cumulated +;;; runtimes over the repetitions. +;;; This allows to easily measure the runtime of expressions that take +;;; much less time than one internal time unit. Also, the results are +;;; unaffected, modulo quantization effects, by changes to +;;; INTERNAL-TIME-UNITS-PER-SECOND. +;;; Taking the minimum is intended to reduce the error introduced by +;;; garbage collections occurring at unpredictable times. The inner +;;; loop doubles the number of calls to THUNK each time before again +;;; measuring the time spent, so that the time measurement overhead +;;; doesn't distort the result if calling THUNK takes very little time. +(defun runtime* (thunk repetitions precision) + (loop repeat repetitions + minimize + (loop with start = (get-internal-run-time) + with duration = 0 + for n = 1 then (* n 2) + for total-runs = n then (+ total-runs n) + do (dotimes (i n) + (funcall thunk)) + (setf duration (- (get-internal-run-time) start)) + when (> duration precision) + return (/ (float duration) (float total-runs))) + into min-internal-time-units-per-call + finally (return (/ min-internal-time-units-per-call + (float internal-time-units-per-second))))) + +(defmacro runtime (form &key (repetitions 3) (precision 10)) + `(runtime* (lambda () ,form) ,repetitions ,precision))