examples/mtbench.lisp

   1 (require '#:asdf)
   2 (asdf:oos 'asdf:load-op '#:cl-glfw)
   3
   4 ;; have to rename this class to thread-signal because it's a built-in typename in lisp
   5 (defclass thread-signal ()
   6   ((cond :initform (glfw:create-cond) :reader signal-cond) ; have to rename this reader to signal-cond because it's a built-in macro
   7    (mutex :initform (glfw:create-mutex) :reader mutex)
   8    (flag :initform nil :accessor flag)))
   9
  10 (defmethod initialize-instance :after ((s thread-signal) &key)
  11   (format t "Created thread-signal with cond ~a and mutex ~a~%" (signal-cond s) (mutex s)))
  12
  13 (defun kill-signal (s)
  14   (declare (type thread-signal s))
  15   (glfw:destroy-mutex (mutex s))
  16   (glfw:destroy-cond (signal-cond s))
  17   (setf (flag s) nil))
  18
  19 (defun wait-signal (s)
  20   (declare (type thread-signal s))
  21   (glfw:with-lock-mutex (mutex s)
  22     (loop while (not (flag s)) do
  23          (glfw:wait-cond (signal-cond s) (mutex s) glfw:+infinity+))
  24     (setf (flag s) nil)))
  25
  26 (defun set-signal (s)
  27   (declare (type thread-signal s))
  28   (glfw:with-lock-mutex (mutex s)
  29    (setf (flag s) t))
  30   (glfw:signal-cond (signal-cond s)))
  31
  32
  33 (unless (glfw:init)
  34   (error "Could not glfw:init"))
  35
  36 (format t "Multithreading benchmarking program
  37 -----------------------------------
  38
  39 This program consists of two tests. In the first test two threads are created,
  40 which continously signal/wait each other. This forces the execution to
  41 alternate between the two threads, and gives a measure of the thread
  42 synchronization granularity. In the second test, the main thread is repeatedly
  43 put to sleep for a very short interval using glfwSleep. The average sleep time
  44 is measured, which tells the minimum supported sleep interval.
  45
  46 Results:
  47 --------
  48
  49 ")
  50
  51 (format t "Number of CPUs: ~d~%~%" (glfw:get-number-of-processors))
  52
  53 (defparameter *done-mutex* nil)
  54 (defparameter *thread-done* nil)
  55 (defparameter *goto-a* nil)
  56 (defparameter *goto-b* nil)
  57 (defparameter *goto-a-count* 0)
  58 (defparameter *goto-b-count* 0)
  59 (defparameter *done-count* 0)
  60 (defparameter *max-count* 10000)
  61
  62 (defun setup ()
  63   (declare (optimize (debug 3) (safety 3) (speed 0) (compilation-speed 0)))
  64   (setf *done-mutex* (glfw:create-mutex)
  65         *thread-done* (glfw:create-cond)
  66         *goto-a* (make-instance 'thread-signal)
  67         *goto-b* (make-instance 'thread-signal)
  68         *goto-a-count* 0
  69         *goto-b-count* 0
  70         *done-count* 0))
  71
  72 (defun teardown ()
  73   (declare (optimize (debug 3) (safety 3) (speed 0) (compilation-speed 0)))
  74   (glfw:destroy-mutex *done-mutex*)
  75   (glfw:destroy-cond *thread-done*)
  76   (kill-signal *goto-a*)
  77   (kill-signal *goto-b*))
  78
  79
  80 (defmacro make-thread-callback (name signal-var other-signal-var count-var)
  81   `(cffi:defcallback ,name :void ((arg :pointer))
  82      (declare (ignore arg))
  83      (do ()
  84          ((>= ,count-var *max-count*))
  85        (incf ,count-var)
  86        (set-signal ,other-signal-var)
  87        (wait-signal ,signal-var))
  88      (set-signal ,other-signal-var)
  89      (glfw:with-lock-mutex *done-mutex*
  90        (incf *done-count*))
  91      (glfw:signal-cond *thread-done*)))
  92
  93 (make-thread-callback thread-a-fun *goto-a* *goto-b* *goto-a-count*)
  94 (make-thread-callback thread-b-fun *goto-b* *goto-a* *goto-b-count*)
  95
  96 (defun test-1 ()
  97   (declare (optimize (debug 3) (safety 3) (speed 0) (compilation-speed 0)))
  98   (sb-ext::without-gcing
  99     (let ((thread-a (glfw:create-thread (cffi:callback thread-a-fun) (cffi:null-pointer)))
 100           (thread-b (glfw:create-thread (cffi:callback thread-b-fun) (cffi:null-pointer))))
 101
 102       (when (or (minusp thread-a) (minusp thread-b))
 103         (format t "One of the threads failed~%")
 104         (glfw:with-lock-mutex *done-mutex*
 105           (setf *done-count* 2)))
 106
 107       (let ((t1 (glfw:get-time)))
 108         (glfw:with-lock-mutex *done-mutex*
 109           (loop until (= *done-count* 2)
 110              do (glfw:wait-cond *thread-done* *done-mutex* glfw:+infinity+)))
 111         (let* ((t2 (glfw:get-time))
 112                (csps (/ (+ *goto-a-count* *goto-b-count*)
 113                         (- t2 t1))))
 114           (format t "Test 1: ~,0f context switches / second (~,3f us/switch)~%" csps (/ 1000000 csps))))
 115
 116       (format t "waiting for thread a to finish completely~%")
 117       (glfw:wait-thread thread-a glfw:+wait+)
 118       (format t "waiting for thread b to finish completely~%")
 119       (glfw:wait-thread thread-b glfw:+wait+)
 120       (format t "finished waiting~%"))))
 121
 122 (defun test-2 ()
 123   (let ((t1 (glfw:get-time))
 124         count)
 125     (dotimes (i 10)
 126       (glfw:sleep 0.0001))
 127     (setf count (/ 1.0 (/ (- (glfw:get-time) t1)
 128                           10.0)))
 129     (setf t1 (glfw:get-time))
 130     (dotimes (i count)
 131       (glfw:sleep 0.0001))
 132     (format t "Test 2: ~,3f ms / sleep (mean)~%~%"
 133             (/ (* 1000.0 (- (glfw:get-time) t1))
 134                count))))
 135
 136
 137 (unwind-protect
 138      (progn
 139        (setup)
 140        (test-1))
 141   (teardown))
 142
 143 (test-2)
 144 (glfw:terminate)