Coverage report: /home/ellis/comp/core/lib/rt/bench.lisp

KindCoveredAll%
expression062 0.0
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; lib/rt/bench.lisp --- Benchmarking Framework
2
 
3
 ;; This package provides an interface for benchmarking Lisp code.
4
 
5
 ;;; Code:
6
 (in-package :rt/bench)
7
 
8
 (defvar *bench-count* 10 "Default number of iterations to repeat a bench test for. This value is
9
 used when the slot value of :BENCH is t.")
10
 
11
 (defmacro time-total (n &body body)
12
   "N-average the execution time of BODY in seconds"
13
   (declare (optimize (speed 0)))
14
   (with-gensyms (start end)
15
     `(let (,start ,end)
16
        (sb-ext:gc :full t)
17
        (setf ,start (get-internal-real-time))
18
        (loop for i below ,n
19
              do ,@body)
20
        (setf ,end (get-internal-real-time))
21
        (coerce (/ (- ,end ,start) internal-time-units-per-second)
22
                'float))))
23
 
24
 (defmacro bench (iter &body body)
25
   `(loop for i from 1 to ,iter
26
          do ,@body))
27
 
28
 (defmethod do-bench ((self test) &optional fx)
29
   (declare (ignorable fx))
30
   (with-test-env self
31
     (flet ((%do ()
32
              (if *compile-tests*
33
                  (with-compilation-unit (:override t :policy (or (and *test-suite* (test-policy *test-suite*)) *test-policy*))
34
                    ;; TODO 2023-09-21: handle failures here
35
                    (let ((fn (compile-test self :declare (test-declare self))))
36
                    (bench *bench-count* (funcall fn)))
37
                  (setf %test-result (make-test-result :pass (test-fn self))))
38
                (progn
39
                  (bench *bench-count* (eval-test self))
40
                  (setf %test-result (make-test-result :pass (name self)))))))
41
       (if *catch-test-errors*
42
           (handler-bind
43
               ((style-warning #'muffle-warning)
44
                (error 
45
                  #'(lambda (c)
46
                      (setf %test-bail t)
47
                      (setf %test-result (make-test-result :fail c))
48
                      (return-from %test-bail %test-result))))
49
             (%do))
50
           (%do)))))
51
 
52
 (defmethod do-bench ((self t) &optional fx)
53
   (declare (ignorable fx))
54
   (when-let ((test (find-test *test-suite* self)))
55
     (do-bench test)))
56
 
57
 (defclass benchmark (test-object) ())
58
 
59
 (defmacro defbench (name props &body body)
60
   "Define a BENCHMARK with NAME modulo PROPS with a benchmark-form of BODY.
61
 
62
 PROPS is a plist which accepts the following keywords:
63
 
64
 tbd"
65
   nil)