thread-ring Lisp SBCL program
source code
;;; The Computer Language Benchmarks Game
;;; http://benchmarksgame.alioth.debian.org/
;;;
;;; contributed by Witali Kusnezow 2008-12-02
(defparameter *mutex* (sb-thread:make-mutex :name "lock"))
(defconstant +threads+ 503)
(defparameter *counter* 0)
(defparameter *current* 0)
(defparameter *main-queue* (sb-thread:make-waitqueue))
(defparameter *queues*
(make-array +threads+
:initial-contents
(loop for i of-type fixnum below +threads+
collect (sb-thread:make-waitqueue))))
(declaim (type fixnum *counter* *current*))
(defun thread-body ()
(sb-thread:with-mutex (*mutex* :wait-p t)
(let ((number *current*)
(next (incf *current*)))
(declare (fixnum number next))
(if (= next +threads+) (setq next 0))
(loop
with (curr_queue next_queue) =
(list (svref *queues* number) (svref *queues* next))
do (sb-thread:condition-wait curr_queue *mutex*)
until (zerop *counter*)
do (decf *counter*) (sb-thread:condition-notify next_queue)
finally (format t "~d~%" (1+ number))
(sb-thread:condition-notify *main-queue*)))))
(defun start (n)
(declare (type fixnum n))
(setq *counter* n *current* 0)
(let ((threads
(loop
for i of-type fixnum below +threads+
collect (sb-thread:make-thread #'thread-body))))
(sb-thread:condition-notify (svref *queues* 0))
(sb-thread:with-mutex (*mutex* :wait-p t)
(sb-thread:condition-wait *main-queue* *mutex*))
(dolist (i threads)
(handler-case (sb-thread:terminate-thread i)
(sb-thread:interrupt-thread-error () nil)))))
(defun main ()
(let ((n (parse-integer (or (car (last #+sbcl sb-ext:*posix-argv*
#+cmu extensions:*command-line-strings*
#+gcl si::*command-args*)) "1"))))
(start n)))
notes, command-line, and program output
NOTES:
64-bit Ubuntu quad core
SBCL 1.4.0
Thu, 26 Oct 2017 17:50:11 GMT
MAKE:
cp: 'threadring.sbcl' and './threadring.sbcl' are the same file
SBCL built with: /opt/src/sbcl-1.4.0/bin/sbcl --userinit /dev/null --batch --eval '(load "threadring.sbcl_compile")'
### START threadring.sbcl_compile
(handler-bind ((sb-ext:defconstant-uneql (lambda (c) (abort c)))) (load (compile-file "threadring.sbcl" ))) (save-lisp-and-die "sbcl.core" :purify t)
### END threadring.sbcl_compile
; compiling file "/home/dunham/benchmarksgame/bench/threadring/threadring.sbcl" (written 24 JAN 2013 01:22:34 PM):
; compiling (DEFPARAMETER *MUTEX* ...)
; compiling (DEFCONSTANT +THREADS+ ...)
; compiling (DEFPARAMETER *COUNTER* ...)
; compiling (DEFPARAMETER *CURRENT* ...)
; compiling (DEFPARAMETER *MAIN-QUEUE* ...)
; compiling (DEFPARAMETER *QUEUES* ...)
; compiling (DECLAIM (TYPE FIXNUM ...))
; compiling (DEFUN THREAD-BODY ...)
; compiling (DEFUN START ...)
; compiling (DEFUN MAIN ...)
; /home/dunham/benchmarksgame_quadcore/threadring/tmp/threadring.fasl written
; compilation finished in 0:00:00.020
### START threadring.sbcl_run
(main) (quit)
### END threadring.sbcl_run
3.50s to complete and log all make actions
COMMAND LINE:
/opt/src/sbcl-1.4.0/bin/sbcl --noinform --core sbcl.core --userinit /dev/null --load threadring.sbcl_run 50000000
PROGRAM OUTPUT:
292