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

diff --git a/tests/test-util.lisp b/tests/test-util.lisp
index 43bafa0..7ec458c 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)
 
@@ -16,6 +17,12 @@
 (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)))
@@ -39,7 +46,18 @@
 (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")))
+    (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
@@ -69,10 +87,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-ephemeral-p thread))
                         (setf any-leftover thread)
                         (ignore-errors (sb-thread:terminate-thread thread))))
                     (when any-leftover
@@ -124,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))