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 (when (zerop (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* (glfw:create-mutex))
  54 (defparameter *thread-done* (glfw:create-cond))
  55 (defparameter *goto-a* (make-instance 'thread-signal))
  56 (defparameter *goto-b* (make-instance 'thread-signal))
  57 (defparameter *goto-a-count* 0)
  58 (defparameter *goto-b-count* 0)
  59 (defparameter *done-count* 0)
  60 (defparameter *max-count* 10000)
  61
  62
  63 (defmacro make-thread-callback (name signal-var other-signal-var count-var)
  64   `(cffi:defcallback ,name :void ((arg :pointer))
  65      (declare (ignore arg))
  66      (do ()
  67          ((>= ,count-var *max-count*))
  68        (incf ,count-var)
  69        (set-signal ,other-signal-var)
  70        (wait-signal ,signal-var))
  71      (set-signal ,other-signal-var)
  72      (glfw:with-lock-mutex *done-mutex*
  73        (incf *done-count*))
  74      (glfw:signal-cond *thread-done*)))
  75
  76 (make-thread-callback thread-a-fun *goto-a* *goto-b* *goto-a-count*)
  77 (make-thread-callback thread-b-fun *goto-b* *goto-a* *goto-b-count*)
  78
  79 (defun test-1 ()
  80   ;; (declare (optimize (debug 3)))
  81   (let ((thread-a (glfw:create-thread (cffi:callback thread-a-fun) (cffi:null-pointer)))
  82         (thread-b (glfw:create-thread (cffi:callback thread-b-fun) (cffi:null-pointer))))
  83
  84     (when (or (minusp thread-a) (minusp thread-b))
  85       (format t "One of the threads failed~%")
  86       (glfw:with-lock-mutex *done-mutex*
  87         (setf *done-count* 2)))
  88
  89     (let ((t1 (glfw:get-time)))
  90       (glfw:with-lock-mutex *done-mutex*
  91         (loop until (= *done-count* 2)
  92            do (glfw:wait-cond *thread-done* *done-mutex* glfw:+infinity+)))
  93       (let* ((t2 (glfw:get-time))
  94              (csps (/ (+ *goto-a-count* *goto-b-count*)
  95                       (- t2 t1))))
  96         (format t "Test 1: ~,0f context switches / second (~,3f us/switch)~%" csps (/ 1000000 csps))))
  97
  98     (format t "waiting for thread a to finish completely~%")
  99     (glfw:wait-thread thread-a glfw:+wait+)
 100     (format t "waiting for thread b to finish completely~%")
 101     (glfw:wait-thread thread-b glfw:+wait+)
 102     (format t "finished waiting~%"))
 103
 104   (glfw:destroy-mutex *done-mutex*)
 105   (glfw:destroy-cond *thread-done*)
 106   (kill-signal *goto-a*)
 107   (kill-signal *goto-b*))
 108
 109 (defun test-2 ()
 110   (let ((t1 (glfw:get-time))
 111         count)
 112     (dotimes (i 10)
 113       (glfw:sleep 0.0001))
 114     (setf count (/ 1.0 (/ (- (glfw:get-time) t1)
 115                           10.0)))
 116     (setf t1 (glfw:get-time))
 117     (dotimes (i count)
 118       (glfw:sleep 0.0001))
 119     (format t "Test 2: ~,3f ms / sleep (mean)~%~%"
 120             (/ (* 1000.0 (- (glfw:get-time) t1))
 121                count))))
 122
 123 (test-1)
 124 (test-2)
 125 (glfw:terminate)