X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftest-util.lisp;h=c4e4804286ef69e72a698c8ef9b463ff8a603b95;hb=bd1a7d535c9639ed6d79a55a53978fcc7a998837;hp=43bafa04c4f0d943472deb3e0fe3788ce6b79761;hpb=69990bc42314706e9d646ddd8f6b911f46d0052c;p=sbcl.git

diff --git a/tests/test-util.lisp b/tests/test-util.lisp
index 43bafa0..c4e4804 100644
--- a/tests/test-util.lisp
+++ b/tests/test-util.lisp
@@ -3,7 +3,8 @@
   (:export #:with-test #:report-test-status #:*failures*
            #:really-invoke-debugger
            #:*break-on-failure* #:*break-on-expected-failure*
-           #:make-kill-thread #:make-join-thread))
+           #:make-kill-thread #:make-join-thread
+           #:runtime))
 
 (in-package :test-util)
 
@@ -39,7 +40,7 @@
 (defmacro with-test ((&key fails-on broken-on skipped-on name)
                      &body body)
   (let ((block-name (gensym))
-        (threads    (gensym "THREADS")))
+        #+sb-thread (threads (gensym "THREADS")))
     `(progn
        (start-test)
        (cond
@@ -69,10 +70,15 @@
                     (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))
+                                  (member thread ,threads)
+                                  (sb-thread:thread-emphemeral-p thread))
                         (setf any-leftover thread)
                         (ignore-errors (sb-thread:terminate-thread thread))))
                     (when any-leftover
@@ -128,3 +134,36 @@
   (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))