Permalink
Browse files

add stealing scheduler

  • Loading branch information...
1 parent 8577929 commit 10bd989754a6c5e734d4e98e636f06ac9155129f @lmj committed May 3, 2012
View
2 bench/bench.lisp
@@ -137,7 +137,7 @@ results are riffled for comparison."
(mapcar (compose 'funcall 'args-fn) specs)))))))))
(defun call-with-temp-kernel (worker-count fn)
- (let1 *kernel* (make-kernel worker-count)
+ (let1 *kernel* (make-kernel worker-count :spin-count 10000)
(unwind-protect (funcall fn)
(end-kernel :wait t))))
View
8 bench/profile.lisp
@@ -74,9 +74,13 @@
(defun enable-profiling ()
(profile-fns #.(home-functions-in-packages-passing
- (curry 'match-package-p "lparallel")))
- ;; causes recursion problem in profiler
+ (lambda (pkg)
+ (or (match-package-p "lparallel" pkg)
+ (match-package-p "bordeaux-threads" pkg)
+ #+(and sbcl lparallel.with-stealing-scheduler)
+ (match-package-p "sb-concurrency" pkg)))))
#+(or)
+ ;; causes recursion problem in profiler
(profile-fns (sort map-into map reduce)))
(defun profile (&rest args)
View
10 lparallel.asd
@@ -28,6 +28,12 @@
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;; default to stealing scheduler on sbcl
+#.(when (and (find :sbcl *features*)
+ (not (find :lparallel.without-stealing-scheduler *features*)))
+ (pushnew :lparallel.with-stealing-scheduler *features*)
+ (values))
+
(defsystem :lparallel
:version "1.2.2"
:description "Parallelism for Common Lisp"
@@ -76,13 +82,15 @@ See http://lparallel.com for documentation and examples.
(:file "queue")
(:file "counter")
(:file "biased-queue")
+ (:file "spin-queue")
(:module "kernel"
:serial t
:components ((:file "util")
(:file "thread-locals")
(:file "handling")
(:file "classes")
- (:file "central-scheduler")
+ #-lparallel.with-stealing-scheduler (:file "central-scheduler")
+ #+lparallel.with-stealing-scheduler (:file "stealing-scheduler")
(:file "core")
(:file "timeout")))
(:file "kernel-util")
View
1 packages-test.lisp
@@ -34,6 +34,7 @@
#:lparallel.thread-util
#:lparallel.raw-queue
#:lparallel.queue
+ #:lparallel.spin-queue
#:lparallel.kernel
#:lparallel.cognate
#:lparallel.defpun
View
17 packages.lisp
@@ -128,12 +128,26 @@
#:dec-counter
#:counter-value))
+(defpackage #:lparallel.spin-queue
+ (:use #:cl
+ #:lparallel.util
+ #:lparallel.raw-queue
+ #:lparallel.counter)
+ (:export #:spin-queue
+ #:make-spin-queue
+ #:push-spin-queue
+ #:pop-spin-queue
+ #:peek-spin-queue
+ #:spin-queue-count
+ #:spin-queue-empty-p))
+
(defpackage #:lparallel.kernel
(:use #:cl
#:lparallel.util
#:lparallel.thread-util
#:lparallel.queue
- #:lparallel.biased-queue)
+ #:lparallel.biased-queue
+ #:lparallel.spin-queue)
(:export #:make-kernel
#:kernel-worker-count
#:check-kernel
@@ -148,6 +162,7 @@
#:kill-tasks
#:task-handler-bind)
(:export #:*kernel*
+ #:*kernel-spin-count*
#:*task-category*
#:*task-priority*)
(:export #:transfer-error
View
16 src/kernel/central-scheduler.lisp
@@ -14,9 +14,12 @@
(alias-function biased-queue-lock lparallel.biased-queue::lock)
-(alias-function make-scheduler make-biased-queue)
+(defun make-scheduler (workers spin-count)
+ (declare (ignore workers spin-count))
+ (make-biased-queue))
-(defun/type schedule-task (scheduler task priority) (scheduler task t) t
+(defun/type schedule-task (scheduler task priority)
+ (scheduler (or task null) t) t
(declare #.*normal-optimize*)
(ccase priority
(:default (push-biased-queue task scheduler))
@@ -34,12 +37,3 @@
;; don't steal nil, the end condition flag
(when (peek-biased-queue/no-lock scheduler)
(pop-biased-queue/no-lock scheduler))))
-
-(setf (macro-function 'with-locked-scheduler)
- (macro-function 'with-locked-biased-queue))
-
-(alias-function scheduler-empty-p/no-lock biased-queue-empty-p/no-lock)
-
-(defun/type distribute-tasks/no-lock (scheduler tasks) (scheduler sequence) t
- (dosequence (task tasks)
- (push-biased-queue/no-lock task scheduler)))
View
22 src/kernel/classes.lisp
@@ -37,9 +37,27 @@
(defslots worker ()
((thread :reader thread)
- (running-category :reader running-category :initform nil)))
+ (running-category :reader running-category :initform nil)
+ (index :reader worker-index :type fixnum)
+ (from-worker :reader from-worker :initform (make-queue) :type queue)
+ (to-worker :reader to-worker :initform (make-queue) :type queue)
+ #+lparallel.with-stealing-scheduler
+ (tasks :reader tasks :type spin-queue)))
-(deftype scheduler () 'biased-queue)
+#+lparallel.with-stealing-scheduler
+(defslots scheduler ()
+ ((workers :type simple-vector)
+ (wait-cvar :initform (make-condition-variable))
+ (wait-lock :initform (make-lock))
+ (wait-count :initform 0 :type fixnum)
+ (notify-count :initform 0)
+ (spin-count)
+ (low-priority-tasks :initform (make-spin-queue) :type spin-queue)))
+
+#-lparallel.with-stealing-scheduler
+(progn
+ (deftype scheduler () 'biased-queue)
+ (defun tasks (scheduler) (declare (ignore scheduler))))
(locally (declare #.*full-optimize*)
(defslots optimizer ()
View
148 src/kernel/core.lisp
@@ -59,16 +59,28 @@
(exec-task/non-worker task)))
t))
+(defun/type handshake/to-worker (worker) (worker) t
+ (with-worker-slots (from-worker to-worker) worker
+ (push-queue 'proceed to-worker)
+ (assert (eq 'ok (pop-queue from-worker)))))
+
+(defun/type handshake/from-worker (worker) (worker) t
+ (with-worker-slots (from-worker to-worker) worker
+ (assert (eq 'proceed (pop-queue to-worker)))
+ (push-queue 'ok from-worker)))
+
(defun/type replace-worker (kernel worker) (kernel worker) t
(with-kernel-slots (workers workers-lock) kernel
(with-lock-held (workers-lock)
(let1 index (position worker workers :test #'eq)
(assert index)
+ (assert (eql index (with-worker-slots (index) worker
+ index)))
(unwind-protect/ext
:prepare (warn "lparallel: Replacing lost or dead worker.")
- :main (multiple-value-bind (new-worker guard) (make-worker kernel)
+ :main (let1 new-worker (make-worker kernel index (tasks worker))
(setf (svref workers index) new-worker)
- (funcall guard))
+ (handshake/to-worker new-worker))
:abort (warn "lparallel: Worker replacement failed! ~
Kernel is defunct -- call `end-kernel'."))))))
@@ -105,30 +117,45 @@
context
kernel))))
-(defun/type make-worker (kernel) (kernel) (values worker function)
+#+lparallel.with-stealing-scheduler
+(defun %make-worker (index tasks)
+ (make-worker-instance :thread nil :index index :tasks tasks))
+
+#-lparallel.with-stealing-scheduler
+(defun %make-worker (index tasks)
+ (declare (ignore tasks))
+ (make-worker-instance :thread nil :index index))
+
+(defun make-worker (kernel index tasks)
(with-kernel-slots (worker-info) kernel
(with-worker-info-slots (bindings name) worker-info
- (let* ((worker (make-worker-instance :thread nil))
- (guard (make-queue))
- (worker-thread (with-thread (:bindings bindings :name name)
- (pop-queue guard)
- (enter-worker-loop kernel worker))))
+ (let* ((worker (%make-worker index tasks))
+ (worker-thread (with-worker-slots (from-worker to-worker) worker
+ (with-thread (:bindings bindings :name name)
+ (unwind-protect/ext
+ :prepare (handshake/from-worker worker)
+ :main (enter-worker-loop kernel worker)
+ :cleanup (push-queue 'exit from-worker))))))
(with-worker-slots (thread) worker
(setf thread worker-thread))
- (values worker (lambda () (push-queue 'proceed guard)))))))
+ worker))))
(defvar *optimizer* nil)
(defgeneric make-optimizer-data (specializer)
(:method ((specializer (eql nil)))
(declare (ignore specializer))))
+(defvar *kernel-spin-count* 10 ; need data to determine a good number
+ "Default value of the `spin-count' argument to `make-kernel'.")
+
(defun make-kernel (worker-count
&key
(bindings `((*standard-output* . ,*standard-output*)
(*error-output* . ,*error-output*)))
(worker-context #'funcall)
- (name "lparallel-worker"))
+ (name "lparallel-worker")
+ (spin-count *kernel-spin-count*))
"Create a kernel with `worker-count' number of worker threads.
`bindings' is an alist for establishing thread-local variables inside
@@ -141,6 +168,9 @@ function which must be funcalled. It begins the worker loop and will
not return until the worker exits. Default value of `worker-context'
is #'funcall.
+When a worker discovers that no tasks are available, `spin-count' is
+the number of stealing iterations done by the worker before sleeping.
+
`name' is a string identifier for worker threads. It corresponds to
the string returned by `bordeaux-threads:thread-name'."
(check-type worker-count (integer 1 #.most-positive-fixnum))
@@ -153,21 +183,22 @@ the string returned by `bordeaux-threads:thread-name'."
:name name))
(workers (make-array worker-count))
(kernel (make-kernel-instance
- :scheduler (make-scheduler)
+ :scheduler (make-scheduler workers spin-count)
:workers workers
:workers-lock (make-lock)
:worker-info worker-info
:optimizer-data (make-optimizer-data *optimizer*))))
(with-kernel-slots (workers worker-info) kernel
(with-worker-info-slots (bindings) worker-info
(push (cons '*kernel* kernel) bindings)
- (let1 guards ()
+ (let1 index 0
(map-into workers
(lambda ()
- (multiple-value-bind (worker guard) (make-worker kernel)
- (push guard guards)
- worker)))
- (mapc #'funcall guards))))
+ (make-worker kernel
+ (prog1 index (incf index))
+ (make-spin-queue))))
+ (dosequence (worker workers)
+ (handshake/to-worker worker)))))
kernel))
(defun check-kernel ()
@@ -294,8 +325,8 @@ return value is the number of tasks that would have been killed if
(when *kernel*
(when (null task-category)
(error "task category cannot be NIL in KILL-TASKS"))
- (with-kernel-slots (workers scheduler) *kernel*
- (with-locked-scheduler scheduler
+ (with-kernel-slots (workers workers-lock) *kernel*
+ (with-lock-held (workers-lock)
(let1 victims (map 'vector
#'thread
(remove-if-not (lambda (worker)
@@ -306,79 +337,50 @@ return value is the number of tasks that would have been killed if
(map nil #'destroy-thread victims))
(length victims))))))
-(defun kernel-idle-p/no-lock (kernel)
- (with-kernel-slots (scheduler workers) kernel
- (and (scheduler-empty-p/no-lock scheduler)
- (notany #'running-category workers))))
-
-(defun kernel-idle-p (kernel)
- (with-kernel-slots (scheduler) kernel
- (with-locked-scheduler scheduler
- (kernel-idle-p/no-lock kernel))))
-
-(defun wait-for-tasks (channel kernel)
- (loop
- (when (kernel-idle-p kernel)
- (return))
- (let1 *task-priority* :low
- (submit-task channel (lambda ())))
- (receive-result channel)))
-
-(defmacro/once with-idle-kernel (&once channel &once kernel &body body)
- (with-gensyms (retry)
- `(tagbody ,retry
- (wait-for-tasks ,channel ,kernel)
- (with-locked-scheduler (scheduler ,kernel)
- (unless (kernel-idle-p/no-lock ,kernel)
- (go ,retry))
- ,@body))))
-
(defun shutdown (channel kernel)
- (with-kernel-slots (scheduler) kernel
- (with-idle-kernel channel kernel
- (distribute-tasks/no-lock
- scheduler (make-array (%kernel-worker-count kernel)
- :initial-element nil)))))
+ (let1 *task-priority* :low
+ (submit-task channel (lambda ())))
+ (receive-result channel)
+ (with-kernel-slots (scheduler workers) kernel
+ (repeat (length workers)
+ (schedule-task scheduler nil :low))
+ (dosequence (worker workers)
+ (assert (eq 'exit (pop-queue (from-worker worker)))))))
(defun end-kernel (&key wait)
"Sets `*kernel*' to nil and ends all workers gracefully.
-But hang on -- are you certain you wish to do this? `end-kernel' is an
-expensive operation involving heavy locking to detect a finished
-state. Creating and destroying threads is also expensive. A kernel is
-meant to be your trusted friend for the lifetime of the Lisp process.
-Having more than one kernel is fine; simply use `let' to bind a kernel
-instance to `*kernel*' when you need it. Use `kill-tasks' to terminate
-deadlocked or infinite looping tasks.
+`end-kernel' should not be used as a substitute for properly waiting
+on tasks with `receive-result' or otherwise.
If `wait' is nil (the default) then `end-kernel' returns immediately.
-Current tasks are waited upon by a separate shutdown manager thread.
+Workers are waited upon by a separate shutdown manager thread.
-If `wait' is non-nil then `end-kernel' blocks until all tasks are
-complete. No shutdown manager thread is created. If you are merely
-waiting on tasks then you almost certainly want to use
-`receive-result' instead. However there are rare cases where waiting
-on a temporary kernel is warranted, for example when benchmarking with
-a variety of kernels.
+If `wait' is non-nil then `end-kernel' blocks until all workers are
+finished. No shutdown manager thread is created.
A list of the implementation-defined worker thread objects is
returned. If `wait' is nil then the shutdown manager thread is also
-returned as the first element in the list."
+returned as the first element in the list.
+
+Note that creating and destroying kernels is relatively expensive. A
+kernel typically exists for lifetime of the Lisp process. Having more
+than one kernel is fine -- simply use `let' to bind a kernel instance
+to `*kernel*' when you need it. Use `kill-tasks' to terminate
+deadlocked or infinite looping tasks."
(when *kernel*
(let ((kernel *kernel*)
(channel (make-channel)))
(setf *kernel* nil)
- (labels ((call-shutdown ()
- (shutdown channel kernel))
- (spawn-shutdown ()
- (make-thread #'call-shutdown
- :name "lparallel kernel shutdown manager")))
- (let1 threads (map 'list #'thread (workers kernel))
+ (with-kernel-slots (workers) kernel
+ (let1 threads (map 'list #'thread workers)
(cond (wait
- (call-shutdown)
+ (shutdown channel kernel)
threads)
(t
- (cons (spawn-shutdown) threads))))))))
+ (cons (with-thread (:name "lparallel kernel shutdown manager")
+ (shutdown channel kernel))
+ threads))))))))
;;; deprecated
#-abcl
View
148 src/kernel/stealing-scheduler.lisp
@@ -0,0 +1,148 @@
+;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;;
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials provided
+;;; with the distribution.
+;;;
+;;; * Neither the name of the project nor the names of its
+;;; contributors may be used to endorse or promote products derived
+;;; from this software without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package #:lparallel.kernel)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; util
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmacro inc-mod (place n)
+ `(setf ,place (the fixnum (mod (the fixnum (1+ (the fixnum ,place)))
+ (the fixnum ,n)))))
+
+(defun/type/inline random-fixnum (n) (fixnum) fixnum
+ (declare #.*normal-optimize*)
+ (random (the fixnum n)))
+
+(defmacro with-pop-success (var queue &body body)
+ (with-gensyms (presentp)
+ `(multiple-value-bind (,var ,presentp) (pop-spin-queue ,queue)
+ (when ,presentp
+ ,@body))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; scheduler
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun/type make-scheduler (workers spin-count)
+ (simple-vector (integer 0)) scheduler
+ (make-scheduler-instance :workers workers :spin-count spin-count))
+
+(defun/type/inline push-to-random-worker (task workers) (task simple-vector) t
+ (declare #.*normal-optimize*)
+ (push-spin-queue
+ task
+ (tasks (svref workers (random-fixnum (length workers))))))
+
+(defun/type maybe-wake-a-worker (scheduler) (scheduler) t
+ (declare #.*normal-optimize*)
+ (with-scheduler-slots (wait-lock wait-cvar wait-count notify-count) scheduler
+ (with-lock-held (wait-lock)
+ (when (plusp wait-count)
+ (incf notify-count)
+ (condition-notify-and-yield wait-cvar)))))
+
+(defun/type schedule-task (scheduler task priority) (scheduler
+ (or task null) t) t
+ (declare #.*normal-optimize*)
+ (with-scheduler-slots (workers low-priority-tasks) scheduler
+ (ccase priority
+ (:low (push-spin-queue task low-priority-tasks))
+ (:default (push-to-random-worker task workers))))
+ (maybe-wake-a-worker scheduler))
+
+(defmacro/once do-workers ((worker-var &once worker-index scheduler) &body body)
+ "Loop through all workers, starting on the right of worker-index."
+ (with-gensyms (workers worker-count victim)
+ `(with-scheduler-slots ((,workers workers)) ,scheduler
+ (let ((,worker-count (the fixnum (length (the simple-vector ,workers))))
+ (,victim (the fixnum ,worker-index)))
+ (declare (fixnum ,worker-count ,victim))
+ (loop
+ :repeat (the fixnum ,worker-count)
+ :do (progn
+ (inc-mod ,victim ,worker-count)
+ (let1 ,worker-var (svref (the simple-vector ,workers) ,victim)
+ (declare (type worker ,worker-var))
+ ,@body)))))))
+
+(defun/type next-task (scheduler worker) (scheduler worker) (or task null)
+ (declare #.*normal-optimize*)
+ (labels ((try-pop (queue)
+ (declare (type spin-queue queue))
+ (with-pop-success task queue
+ (return-from next-task task)))
+ (find-a-task ()
+ (try-pop (tasks worker))
+ (do-workers (worker (worker-index worker) scheduler)
+ (try-pop (tasks worker))))
+ (maybe-sleep ()
+ (with-scheduler-slots (wait-cvar wait-lock wait-count
+ notify-count low-priority-tasks) scheduler
+ (with-lock-held (wait-lock)
+ (try-pop (tasks worker))
+ (try-pop low-priority-tasks)
+ (if (plusp notify-count)
+ (decf notify-count) ; steal a notification
+ (unwind-protect/ext
+ :prepare (incf wait-count)
+ :main (loop
+ :do (condition-wait wait-cvar wait-lock)
+ :until (plusp notify-count)
+ :finally (decf notify-count))
+ :cleanup (decf wait-count)))))))
+ (declare (dynamic-extent #'try-pop #'find-a-task #'maybe-sleep))
+ (with-scheduler-slots (spin-count) scheduler
+ (loop
+ (find-a-task)
+ (repeat spin-count
+ (find-a-task))
+ (maybe-sleep)))))
+
+(defun/type steal-task (scheduler) (scheduler) (or task null)
+ (declare #.*normal-optimize*)
+ (with-scheduler-slots (workers) scheduler
+ (do-workers (worker (random-fixnum (length workers)) scheduler)
+ (with-pop-success task (tasks worker)
+ (if task
+ (return-from steal-task task)
+ ;; don't steal nil, the end condition flag
+ (push-spin-queue task (tasks worker))))))
+ nil)
+
+(defun/type scheduler-empty-p (scheduler) (scheduler) boolean
+ (with-scheduler-slots (workers) scheduler
+ (every (lambda (worker) (spin-queue-empty-p (tasks worker)))
+ workers)))
View
69 src/spin-queue.lisp
@@ -0,0 +1,69 @@
+;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;;
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials provided
+;;; with the distribution.
+;;;
+;;; * Neither the name of the project nor the names of its
+;;; contributors may be used to endorse or promote products derived
+;;; from this software without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package #:lparallel.spin-queue)
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require 'sb-concurrency))
+
+#+sbcl
+(progn
+ (deftype spin-queue () 'sb-concurrency:queue)
+
+ (defun make-spin-queue (&optional initial-capacity)
+ (declare (ignore initial-capacity))
+ (sb-concurrency:make-queue))
+
+ ;; only used for testing
+ (defun peek-spin-queue (queue)
+ (let1 list (sb-concurrency:list-queue-contents queue)
+ (if list
+ (values (first list) t)
+ (values nil nil))))
+
+ (alias-function push-spin-queue sb-concurrency:enqueue)
+ (alias-function pop-spin-queue sb-concurrency:dequeue)
+ (alias-function spin-queue-count sb-concurrency:queue-count)
+ (alias-function spin-queue-empty-p sb-concurrency:queue-empty-p))
+
+#-sbcl
+(progn
+ (deftype spin-queue () 'lparallel.queue:queue)
+
+ (defun make-spin-queue (&optional initial-capacity)
+ (declare (ignore initial-capacity))
+ (lparallel.queue:make-queue))
+
+ (alias-function push-spin-queue lparallel.queue:push-queue)
+ (alias-function pop-spin-queue lparallel.queue:try-pop-queue)
+ (alias-function peek-spin-queue lparallel.queue:peek-queue)
+ (alias-function spin-queue-count lparallel.queue:queue-count)
+ (alias-function spin-queue-empty-p lparallel.queue:queue-empty-p))
View
18 test/base.lisp
@@ -41,12 +41,12 @@
(defmacro/once with-new-kernel ((&once worker-count
&rest args
- &key bindings worker-context name)
+ &key bindings worker-context name spin-count)
&body body)
- (declare (ignore bindings worker-context name))
+ (declare (ignore bindings context name spin-count))
`(let1 *kernel* (make-kernel ,worker-count ,@args)
(unwind-protect (progn ,@body)
- (end-kernel))))
+ (end-kernel :wait t))))
(defmacro lp-base-test (name &body body)
`(progn
@@ -58,12 +58,15 @@
(debug! ',name))))
(defmacro lp-test (name &body body)
- (with-gensyms (n)
+ (with-gensyms (body-fn n)
`(lp-base-test ,name
(let1 *random-state* (make-random-state t)
(dolist (,n '(1 2 4 8 16))
- (with-new-kernel (,n)
- ,@body))))))
+ (flet ((,body-fn () ,@body))
+ (with-new-kernel (,n :spin-count 0)
+ (,body-fn))
+ (with-new-kernel (,n :spin-count 2000)
+ (,body-fn))))))))
(define-condition client-error (error) ())
(define-condition foo-error (error) ())
@@ -94,3 +97,6 @@
(sleep 0.2)
(is (eql ,old-thread-count
(length (bordeaux-threads:all-threads))))))))
+
+(defparameter *nil* nil)
+(defun infinite-loop () (loop :until *nil*))
View
63 test/kernel-test.lisp
@@ -42,6 +42,66 @@
(signals no-kernel-error
(submit-task (make-channel) (lambda ())))))
+(lp-base-test end-kernel-test
+ (repeat 10
+ (loop
+ :for n :from 1 :below 32
+ :do (with-new-kernel (n)
+ (is (= 1 1))))))
+
+(lp-test many-task-test
+ (let1 channel (make-channel)
+ (repeat 1000
+ (submit-task channel (lambda ()))
+ (is (null (receive-result channel))))
+ (repeat 1000
+ (submit-task channel (lambda ())))
+ (repeat 1000
+ (is (null (receive-result channel))))
+ (repeat 1000
+ (let1 *task-priority* :low
+ (submit-task channel (lambda ())))
+ (is (null (receive-result channel))))
+ (repeat 1000
+ (let1 *task-priority* :low
+ (submit-task channel (lambda ()))))
+ (repeat 1000
+ (is (null (receive-result channel))))))
+
+(lp-base-test kill-during-end-kernel-test
+ (let* ((*kernel* (make-kernel 2))
+ (kernel *kernel*)
+ (out *standard-output*)
+ (channel (make-channel))
+ (handled (make-queue))
+ (finished (make-queue)))
+ (task-handler-bind ((error
+ (lambda (e) (invoke-restart 'transfer-error e))))
+ (submit-task channel (lambda ()
+ (setf *error-output* (make-broadcast-stream))
+ (infinite-loop))))
+ (with-thread ()
+ (block top
+ (handler-bind ((task-killed-error
+ (lambda (e)
+ (declare (ignore e))
+ (push-queue t handled)
+ (return-from top))))
+ (receive-result channel))))
+ (sleep 0.2)
+ (let1 thread (with-thread ()
+ (let1 *standard-output* out
+ (let1 *kernel* kernel
+ (end-kernel :wait t)
+ (push-queue t finished))))
+ (sleep 0.2)
+ (is (null (peek-queue finished)))
+ (is (eql 1 (kill-tasks :default)))
+ (sleep 0.2)
+ (is (eq t (peek-queue handled)))
+ (is (eq t (peek-queue finished)))
+ (is (not (null thread))))))
+
(lp-test channel-capacity-test
(let1 channel (make-channel 10)
(submit-task channel (lambda () 3))
@@ -239,9 +299,6 @@
(receive-result channel)))
(is (eq :called result))))
-(defparameter *nil* nil)
-(defun infinite-loop () (loop :until *nil*))
-
#-abcl
(lp-base-test custom-kill-task-test
(with-thread-count-check
View
162 test/queue-test.lisp
@@ -30,43 +30,125 @@
(in-package #:lparallel-test)
-(lp-test queue-test
- (dolist (n (loop :for i :below 20 :collect i))
- (let1 q (make-queue n)
- (is (eq t (queue-empty-p q)))
- (multiple-value-bind (a b) (try-pop-queue q)
- (is (null a))
- (is (null b)))
- (multiple-value-bind (a b) (peek-queue q)
- (is (null a))
- (is (null b)))
- (push-queue 3 q)
- (is (eq nil (queue-empty-p q)))
- (push-queue 4 q)
- (is (eq nil (queue-empty-p q)))
- (multiple-value-bind (a b) (peek-queue q)
- (is (= 3 a))
- (is (not (null b))))
- (push-queue 5 q)
- (push-queue 6 q)
- (push-queue 7 q)
- (is (eql 5 (queue-count q)))
- (is (eql 3 (pop-queue q)))
- (multiple-value-bind (a b) (try-pop-queue q)
- (is (= 4 a))
- (is (not (null b))))
- (is (equal '(5 6 7)
- (loop :repeat 3 :collect (pop-queue q))))
- (is (eq t (queue-empty-p q)))
- (multiple-value-bind (a b) (try-pop-queue q)
- (is (null a))
- (is (null b)))
- (multiple-value-bind (a b) (peek-queue q)
- (is (null a))
- (is (null b)))
- (push-queue 88 q)
- (is (eq nil (queue-empty-p q)))
- (is (eq 1 (queue-count q)))
- (pop-queue q)
- (is (eq t (queue-empty-p q)))
- (is (eq 0 (queue-count q))))))
+(defmacro define-queue-test (name
+ &key
+ make-queue
+ push-queue
+ pop-queue
+ try-pop-queue
+ queue-empty-p
+ queue-count
+ peek-queue)
+ `(lp-base-test ,name
+ (dolist (n (loop :for i :below 20 :collect i))
+ (let1 q (,make-queue n)
+ (is (eq t (,queue-empty-p q)))
+ (multiple-value-bind (a b) (,try-pop-queue q)
+ (is (null a))
+ (is (null b)))
+ (multiple-value-bind (a b) (,peek-queue q)
+ (is (null a))
+ (is (null b)))
+ (,push-queue 3 q)
+ (is (eq nil (,queue-empty-p q)))
+ (,push-queue 4 q)
+ (is (eq nil (,queue-empty-p q)))
+ (multiple-value-bind (a b) (,peek-queue q)
+ (is (= 3 a))
+ (is (not (null b))))
+ (,push-queue 5 q)
+ (,push-queue 6 q)
+ (,push-queue 7 q)
+ (is (eql 5 (,queue-count q)))
+ (is (eql 3 (,pop-queue q)))
+ (multiple-value-bind (a b) (,try-pop-queue q)
+ (is (= 4 a))
+ (is (not (null b))))
+ (is (equal '(5 6 7)
+ (loop :repeat 3 :collect (,pop-queue q))))
+ (is (eq t (,queue-empty-p q)))
+ (multiple-value-bind (a b) (,try-pop-queue q)
+ (is (null a))
+ (is (null b)))
+ (multiple-value-bind (a b) (,peek-queue q)
+ (is (null a))
+ (is (null b)))
+ (,push-queue 88 q)
+ (is (eq nil (,queue-empty-p q)))
+ (is (eq 1 (,queue-count q)))
+ (,pop-queue q)
+ (is (eq t (,queue-empty-p q)))
+ (is (eq 0 (,queue-count q)))))))
+
+(define-queue-test raw-queue-test
+ :make-queue make-raw-queue
+ :push-queue push-raw-queue
+ :pop-queue pop-raw-queue
+ :try-pop-queue pop-raw-queue
+ :queue-empty-p raw-queue-empty-p
+ :queue-count raw-queue-count
+ :peek-queue peek-raw-queue)
+
+(define-queue-test queue-test
+ :make-queue make-queue
+ :push-queue push-queue
+ :pop-queue pop-queue
+ :try-pop-queue try-pop-queue
+ :queue-empty-p queue-empty-p
+ :queue-count queue-count
+ :peek-queue peek-queue)
+
+(define-queue-test spin-queue-test
+ :make-queue make-spin-queue
+ :push-queue push-spin-queue
+ :pop-queue pop-spin-queue
+ :try-pop-queue pop-spin-queue
+ :queue-empty-p spin-queue-empty-p
+ :queue-count spin-queue-count
+ :peek-queue peek-spin-queue)
+
+(defmacro define-grind-queue (name
+ &key make-queue push-queue pop-queue queue-count)
+ `(lp-base-test ,name
+ (let ((obj-count 100000)
+ (iter-count 2))
+ (with-thread-count-check
+ (dolist (thread-count '(1 2 3 4 8 16 32 64 128))
+ (let ((to-workers (,make-queue))
+ (from-workers (,make-queue)))
+ (with-thread (:name "grind-queue"
+ :bindings `((*standard-output* .
+ ,*standard-output*)))
+ (loop (let1 obj (,pop-queue to-workers)
+ (if obj
+ (,push-queue obj from-workers)
+ (return)))))
+ (repeat iter-count
+ (dotimes (i obj-count)
+ (,push-queue 'hello to-workers))
+ (dotimes (i obj-count)
+ (,pop-queue from-workers))
+ (is (zerop (,queue-count to-workers)))
+ (is (zerop (,queue-count from-workers))))
+ (repeat thread-count
+ (,push-queue nil to-workers))))
+ (sleep 0.5)))))
+
+(define-grind-queue grind-queue-test
+ :make-queue make-queue
+ :push-queue push-queue
+ :pop-queue pop-queue
+ :queue-count queue-count)
+
+#+sbcl
+(progn
+ (defun sb-dequeue/wait (queue)
+ (loop (multiple-value-bind (item presentp) (sb-concurrency:dequeue queue)
+ (when presentp
+ (return item)))))
+
+ (define-grind-queue grind-sb-queue-test
+ :make-queue sb-concurrency:make-queue
+ :push-queue sb-concurrency:enqueue
+ :pop-queue sb-dequeue/wait
+ :queue-count sb-concurrency:queue-count))

0 comments on commit 10bd989

Please sign in to comment.