├── CHANGES ├── LICENSE ├── README.md ├── bench ├── README.md ├── bench.lisp ├── governor.sh ├── package.lisp ├── profile.lisp └── suite.lisp ├── lparallel-bench.asd ├── lparallel-test.asd ├── lparallel.asd ├── src ├── biased-queue.lisp ├── cognate │ ├── option.lisp │ ├── package.lisp │ ├── pandor.lisp │ ├── pcount.lisp │ ├── pdotimes.lisp │ ├── pfind.lisp │ ├── plet.lisp │ ├── pmap-open-coded.lisp │ ├── pmap.lisp │ ├── pquantifier.lisp │ ├── preduce.lisp │ ├── premove.lisp │ ├── psort.lisp │ ├── subdivide.lisp │ └── util.lisp ├── cons-queue.lisp ├── counter.lisp ├── defpun.lisp ├── kernel-util.lisp ├── kernel │ ├── central-scheduler.lisp │ ├── classes.lisp │ ├── core.lisp │ ├── handling.lisp │ ├── kill.lisp │ ├── package.lisp │ ├── specials.lisp │ ├── stealing-scheduler.lisp │ └── timeout.lisp ├── package.lisp ├── promise.lisp ├── ptree.lisp ├── queue.lisp ├── raw-queue.lisp ├── slet.lisp ├── spin-queue │ ├── cas-spin-queue.lisp │ ├── default-spin-queue.lisp │ └── package.lisp ├── thread-util.lisp ├── util │ ├── config.lisp │ ├── defmacro.lisp │ ├── defpair.lisp │ ├── defslots.lisp │ ├── defun.lisp │ ├── misc.lisp │ └── package.lisp └── vector-queue.lisp └── test ├── 1am.lisp ├── base.lisp ├── cognate-test.lisp ├── defpun-test.lisp ├── kernel-test.lisp ├── package.lisp ├── promise-test.lisp ├── ptree-test.lisp ├── queue-test.lisp └── thread-util-test.lisp /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions 5 | are met: 6 | 7 | * Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above 11 | copyright notice, this list of conditions and the following 12 | disclaimer in the documentation and/or other materials provided 13 | with the distribution. 14 | 15 | * Neither the name of the project nor the names of its 16 | contributors may be used to endorse or promote products derived 17 | from this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # lparallel 3 | 4 | lparallel is a library for parallel programming in Common Lisp, featuring 5 | 6 | * a simple model of task submission with receiving queue 7 | * constructs for expressing fine-grained parallelism 8 | * asynchronous condition handling across thread boundaries 9 | * parallel versions of map, reduce, sort, remove, and many others 10 | * promises, futures, and delayed evaluation constructs 11 | * computation trees for parallelizing interconnected tasks 12 | * bounded and unbounded FIFO queues 13 | * high and low priority tasks 14 | * task killing by category 15 | * integrated timeouts 16 | 17 | See http://lparallel.org for documentation and examples. 18 | 19 | ### Running 20 | 21 | lparallel should run on any Common Lisp implementation supported by 22 | bordeaux-threads. The following implementations successfully pass the 23 | test suite: 24 | 25 | * ABCL 26 | * Allegro 27 | * Clozure 28 | * LispWorks 29 | * SBCL 30 | 31 | To run tests, load `lparallel-test.asd` and call `(lparallel-test:execute)`. 32 | 33 | To run benchmarks, load `lparallel-bench.asd` and call 34 | `(lparallel-bench:execute N)` where `N` is the number of worker threads. 35 | 36 | ### Author 37 | 38 | James M. Lawrence 39 | -------------------------------------------------------------------------------- /bench/README.md: -------------------------------------------------------------------------------- 1 | 2 | You may need to unthrottle your CPUs in order to see significant 3 | speedup. 4 | 5 | ### Unthrottling on Linux 6 | 7 | First run 8 | 9 | $ sh governor.sh 10 | 11 | to see a list of available governors along with the current status. 12 | 13 | A governor called "performance" will presumably be available. To 14 | switch to the performance governor, 15 | 16 | $ sudo sh governor.sh performance 17 | 18 | Each CPU should now report "performance". 19 | 20 | After benchmarking you may wish to switch back. If the original 21 | setting was "ondemand" then 22 | 23 | $ sudo sh governor.sh ondemand 24 | 25 | ### Hyperthreading 26 | 27 | Hyperthreading may or may not negatively impact benchmarks. 28 | 29 | If you have hyperthreading enabled, using twice as many workers as 30 | CPUs (or some intermediate value) may or may not improve benchmarks. 31 | -------------------------------------------------------------------------------- /bench/bench.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel-bench) 32 | 33 | ;;;; helpers 34 | 35 | (defmacro collecting1 (&body body) 36 | (with-gensyms (result value) 37 | `(let ((,result nil)) 38 | (flet ((collect (,value) (push ,value ,result))) 39 | ,@body) 40 | (nreverse ,result)))) 41 | 42 | (defun groups-of (n list) 43 | (loop for pos on list by (partial-apply 'nthcdr n) 44 | collect (subseq pos 0 n))) 45 | 46 | (defun riffle (groups deck) 47 | (apply #'mapcar #'list (groups-of (/ (length deck) groups) deck))) 48 | 49 | ;;;; wall time 50 | 51 | #-sbcl 52 | (progn 53 | (alias-function get-time get-internal-real-time) 54 | (defun time-interval (start end) 55 | (- end start))) 56 | 57 | #+sbcl 58 | (progn 59 | (defun get-time () 60 | (multiple-value-list (sb-ext:get-time-of-day))) 61 | (defun to-microseconds (time) 62 | (destructuring-bind (sec usec) time 63 | (+ (* 1000000 sec) usec))) 64 | (defun time-interval (start end) 65 | (- (to-microseconds end) 66 | (to-microseconds start)))) 67 | 68 | (defun wall-time (fn args) 69 | (let ((start (get-time))) 70 | (apply fn args) 71 | (let ((end (get-time))) 72 | (time-interval start end)))) 73 | 74 | ;;;; bench 75 | 76 | (defslots bench-spec () 77 | ((args-fn :reader args-fn) 78 | (exec-fn :reader exec-fn) 79 | (desc-fn :reader desc-fn)) 80 | (:documentation 81 | "A benchmark specification. 82 | 83 | `args-fn' creates the arguments to be passed to `exec-fn'. The 84 | execution time of `exec-fn' is passed to `desc-fn', which returns a 85 | descriptive string.")) 86 | 87 | (alias-function make-bench-spec make-bench-spec-instance) 88 | 89 | (defun print-chunk (chunk) 90 | (format t "~&") 91 | (mapc 'princ chunk) 92 | (format t "~%")) 93 | 94 | (defun ping (x) 95 | (format t ".") 96 | x) 97 | 98 | (defun bench (num-fns num-trials num-rehearsals specs) 99 | "Run bench specs. 100 | 101 | To minimize GC interactions, all arguments are generated at the outset 102 | and each benchmarked function is held constant while the generated 103 | argument lists are applied successively. 104 | 105 | When benchmarks are complete, the rehearsals are discarded and the 106 | results are riffled for comparison." 107 | (mapc 'print-chunk 108 | (mapcar 'flatten 109 | (riffle num-fns 110 | (mapcar (partial-apply 'nthcdr num-rehearsals) 111 | (groups-of num-trials 112 | (mapcar 'funcall 113 | (mapcar 'desc-fn specs) 114 | (mapcar (compose 'ping 'wall-time) 115 | (mapcar 'exec-fn specs) 116 | (mapcar (compose 'funcall 'args-fn) specs))))))))) 117 | -------------------------------------------------------------------------------- /bench/governor.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | govs=`cat /sys/devices/system/cpu/cpu0/cpufreq/scaling_available_governors` 4 | 5 | echo "available governors:" 6 | echo $govs 7 | echo 8 | 9 | echo "current governor on each CPU:" 10 | cat /sys/devices/system/cpu/cpu*/cpufreq/scaling_governor 11 | echo 12 | 13 | valid="false" 14 | 15 | for gov in $govs ; do 16 | if [ "$1" = "$gov" ] ; then 17 | valid="true" 18 | fi 19 | done 20 | 21 | if [ "$valid" = "true" ] ; then 22 | echo "changing to $1..." 23 | echo 24 | for cpu in /sys/devices/system/cpu/cpu*/cpufreq/scaling_governor ; do 25 | [ -f $cpu ] || continue 26 | echo -n $1 > $cpu 27 | done 28 | echo "new governor on each CPU:" 29 | cat /sys/devices/system/cpu/cpu*/cpufreq/scaling_governor 30 | elif [ "$1" != "" ] ; then 31 | echo "invalid governor: $1" 32 | fi 33 | -------------------------------------------------------------------------------- /bench/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defpackage #:lparallel-bench 32 | (:documentation 33 | "Benchmarks for lparallel.") 34 | (:use #:cl 35 | #:lparallel.util 36 | #:lparallel.cognate 37 | #:lparallel.defpun 38 | #:lparallel.kernel) 39 | (:import-from #:lparallel.kernel-util 40 | #:with-temp-kernel) 41 | (:export #:execute) 42 | #+sbcl 43 | (:export #:profile 44 | #:stat-profile) 45 | (:export #:with-temp-kernel 46 | #:with-wall-time) 47 | (:import-from #:trivial-garbage 48 | #:gc) 49 | (:import-from #:alexandria 50 | #:compose 51 | #:flatten)) 52 | 53 | #+sbcl 54 | (require :sb-sprof) 55 | 56 | (in-package #:lparallel-bench) 57 | -------------------------------------------------------------------------------- /bench/profile.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel-bench) 32 | 33 | ;;;; util 34 | 35 | (eval-when (:compile-toplevel :load-toplevel :execute) 36 | (defun home-symbols (pkg) 37 | (loop for sym being the present-symbols in pkg 38 | when (eq (find-package pkg) (symbol-package sym)) 39 | collect sym)) 40 | 41 | (defun home-functions (pkg) 42 | (remove-if-not #'fboundp (home-symbols pkg))) 43 | 44 | (defun packages-passing (predicate) 45 | (remove-if-not predicate (list-all-packages))) 46 | 47 | (defun home-functions-in-packages-passing (predicate) 48 | (reduce #'nconc (packages-passing predicate) :key #'home-functions)) 49 | 50 | (defun match-package-p (string pkg) 51 | (search string (package-name pkg) :test #'equalp))) 52 | 53 | (defmacro without-warnings (&body body) 54 | `(handler-bind ((warning #'muffle-warning)) 55 | ,@body)) 56 | 57 | ;;;; profile 58 | 59 | (defmacro profile-fns (syms) 60 | `(progn 61 | ,@(loop for sym in syms 62 | collect `(sb-profile:profile ,sym)))) 63 | 64 | (defun enable-profiling () 65 | (profile-fns #.(home-functions-in-packages-passing 66 | (lambda (pkg) 67 | (or (match-package-p "lparallel" pkg) 68 | (match-package-p "bordeaux-threads" pkg) 69 | #+(and sbcl lparallel.with-stealing-scheduler) 70 | (match-package-p "sb-concurrency" pkg)))))) 71 | 72 | (defun profile (&rest args) 73 | (without-warnings 74 | (enable-profiling)) 75 | (sb-profile:reset) 76 | (apply #'execute args) 77 | (sb-profile:report)) 78 | 79 | ;;;; stat-profile 80 | 81 | (defun stat-profile (&rest args) 82 | (sb-sprof:with-profiling (:max-samples 100000 83 | :sample-interval (/ sb-sprof:*sample-interval* 2) 84 | :report :graph 85 | :loop nil 86 | :threads :all 87 | :show-progress nil) 88 | (apply #'execute args))) 89 | -------------------------------------------------------------------------------- /lparallel-bench.asd: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defsystem :lparallel-bench 32 | :description "Benchmarks for lparallel." 33 | :licence "BSD" 34 | :author "James M. Lawrence " 35 | :depends-on (:lparallel 36 | :trivial-garbage) 37 | :serial t 38 | :components ((:module "bench" 39 | :serial t 40 | :components ((:file "package") 41 | (:file "bench") 42 | (:file "suite") 43 | #+sbcl (:file "profile"))))) 44 | -------------------------------------------------------------------------------- /lparallel-test.asd: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defsystem :lparallel-test 32 | :description "Test suite for lparallel." 33 | :licence "BSD" 34 | :author "James M. Lawrence " 35 | :depends-on (:lparallel) 36 | :serial t 37 | :components ((:module "test" 38 | :serial t 39 | :components ((:file "1am") 40 | (:file "package") 41 | (:file "base") 42 | (:file "thread-util-test") 43 | (:file "queue-test") 44 | (:file "kernel-test") 45 | (:file "cognate-test") 46 | (:file "promise-test") 47 | (:file "defpun-test") 48 | (:file "ptree-test"))))) 49 | 50 | (defmethod perform ((o test-op) (c (eql (find-system :lparallel-test)))) 51 | (declare (ignore o c)) 52 | (funcall (intern (string '#:execute) :lparallel-test))) 53 | -------------------------------------------------------------------------------- /lparallel.asd: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (eval-when (:compile-toplevel :load-toplevel :execute) 32 | ;; unless otherwise requested, default to stealing scheduler on sbcl 33 | #+(and sbcl (not lparallel.without-stealing-scheduler)) 34 | (pushnew :lparallel.with-stealing-scheduler *features*) 35 | 36 | ;; unless otherwise requested, use compare-and-swap optimizations 37 | #+(and (or sbcl ccl lispworks) 38 | (not lparallel.without-cas) 39 | (not lparallel.with-debug)) 40 | (pushnew :lparallel.with-cas *features*) 41 | 42 | ;; plet uses a cltl2 feature 43 | #+(or sbcl ccl lispworks allegro) 44 | (progn 45 | (pushnew :lparallel.with-cltl2 *features*) 46 | #+sbcl (require :sb-cltl2)) 47 | 48 | ;; green threads need calls to yield 49 | #+(and allegro (not os-threads)) 50 | (pushnew :lparallel.with-green-threads *features*) 51 | 52 | ;; thread kill does not call unwind-protect cleanup forms 53 | #+abcl 54 | (pushnew :lparallel.without-kill *features*)) 55 | 56 | (defsystem :lparallel 57 | :version "2.8.4" 58 | :description "Parallelism for Common Lisp" 59 | :long-description 60 | " 61 | lparallel is a library for parallel programming in Common Lisp, featuring 62 | 63 | * a simple model of task submission with receiving queue 64 | * constructs for expressing fine-grained parallelism 65 | * asynchronous condition handling across thread boundaries 66 | * parallel versions of map, reduce, sort, remove, and many others 67 | * promises, futures, and delayed evaluation constructs 68 | * computation trees for parallelizing interconnected tasks 69 | * bounded and unbounded FIFO queues 70 | * high and low priority tasks 71 | * task killing by category 72 | * integrated timeouts 73 | 74 | See http://lparallel.org for documentation and examples. 75 | " 76 | :licence "BSD" 77 | :author "James M. Lawrence " 78 | :depends-on (:alexandria 79 | :bordeaux-threads) 80 | :serial t 81 | :components ((:module "src" 82 | :serial t 83 | :components 84 | ((:module "util" 85 | :serial t 86 | :components 87 | ((:file "package") 88 | (:file "config") 89 | (:file "misc") 90 | (:file "defmacro") 91 | (:file "defun") 92 | (:file "defslots") 93 | (:file "defpair"))) 94 | (:file "thread-util") 95 | (:file "raw-queue") 96 | (:file "cons-queue") 97 | (:file "vector-queue") 98 | (:file "queue") 99 | #-lparallel.with-stealing-scheduler (:file "biased-queue") 100 | #+lparallel.with-stealing-scheduler (:file "counter") 101 | #+lparallel.with-stealing-scheduler (:module "spin-queue" 102 | :serial t 103 | :components 104 | ((:file "package") 105 | #+lparallel.with-cas (:file "cas-spin-queue") 106 | #-lparallel.with-cas (:file "default-spin-queue"))) 107 | (:module "kernel" 108 | :serial t 109 | :components 110 | ((:file "package") 111 | (:file "specials") 112 | (:file "handling") 113 | (:file "classes") 114 | #-lparallel.with-stealing-scheduler (:file "central-scheduler") 115 | #+lparallel.with-stealing-scheduler (:file "stealing-scheduler") 116 | #-lparallel.without-kill (:file "kill") 117 | (:file "core") 118 | (:file "timeout"))) 119 | (:file "kernel-util") 120 | (:file "promise") 121 | (:file "ptree") 122 | (:file "slet") 123 | (:file "defpun") 124 | (:module "cognate" 125 | :serial t 126 | :components 127 | ((:file "package") 128 | (:file "util") 129 | (:file "option") 130 | (:file "subdivide") 131 | (:file "pandor") 132 | (:file "plet") 133 | (:file "pmap") 134 | #-abcl (:file "pmap-open-coded") 135 | (:file "pdotimes") 136 | (:file "pquantifier") 137 | (:file "preduce") 138 | (:file "premove") 139 | (:file "pfind") 140 | (:file "pcount") 141 | (:file "psort"))) 142 | (:file "package"))))) 143 | 144 | (defmethod perform ((o test-op) (c (eql (find-system :lparallel)))) 145 | (declare (ignore o c)) 146 | (load-system '#:lparallel-test) 147 | (test-system '#:lparallel-test)) 148 | 149 | (defmethod perform :after ((o load-op) (c (eql (find-system :lparallel)))) 150 | (declare (ignore o c)) 151 | (pushnew :lparallel *features*)) 152 | 153 | ;;; svref problem in sbcl-1.1.6 154 | #+sbcl 155 | (when (string= "1.1.6" (lisp-implementation-version)) 156 | (error "Sorry, cannot use lparallel with SBCL 1.1.6; any version but that.")) 157 | -------------------------------------------------------------------------------- /src/biased-queue.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | ;;; 32 | ;;; Similar to a priority queue but with only two tiers. O(1) 33 | ;;; insertion and removal. 34 | ;;; 35 | 36 | (defpackage #:lparallel.biased-queue 37 | (:documentation 38 | "(private) Blocking two-tiered priority queue.") 39 | (:use #:cl 40 | #:lparallel.util 41 | #:lparallel.thread-util 42 | #:lparallel.raw-queue) 43 | (:export #:biased-queue 44 | #:make-biased-queue 45 | #:push-biased-queue #:push-biased-queue/no-lock 46 | #:push-biased-queue/low #:push-biased-queue/low/no-lock 47 | #:pop-biased-queue #:pop-biased-queue/no-lock 48 | #:peek-biased-queue #:peek-biased-queue/no-lock 49 | #:biased-queue-empty-p #:biased-queue-empty-p/no-lock 50 | #:try-pop-biased-queue #:try-pop-biased-queue/no-lock 51 | #:pop-biased-queue #:pop-biased-queue/no-lock 52 | #:biased-queue-count #:biased-queue-count/no-lock 53 | #:with-locked-biased-queue) 54 | (:import-from #:lparallel.thread-util 55 | #:define-locking-fn 56 | #:define-simple-locking-fn)) 57 | 58 | (in-package #:lparallel.biased-queue) 59 | 60 | (defslots biased-queue () 61 | ((lock :reader lock :initform (make-lock)) 62 | (cvar :reader cvar :initform (make-condition-variable)) 63 | (high :reader high :type raw-queue) 64 | (low :reader low :type raw-queue))) 65 | 66 | (defun make-biased-queue (&optional (size 1)) 67 | (make-biased-queue-instance :high (make-raw-queue size) 68 | :low (make-raw-queue))) 69 | 70 | (defmacro define-push-fn (name slot) 71 | `(define-simple-locking-fn ,name (object queue) (t biased-queue) (values) lock 72 | (push-raw-queue object (,slot queue)) 73 | (condition-notify (cvar queue)) 74 | (values))) 75 | 76 | (define-push-fn push-biased-queue high) 77 | (define-push-fn push-biased-queue/low low) 78 | 79 | (defmacro define-high-low-fn (name operation) 80 | `(define-locking-fn ,name (queue) (biased-queue) (values t boolean) lock 81 | (with-biased-queue-slots (high low) queue 82 | (multiple-value-bind (object presentp) (,operation high) 83 | (if presentp 84 | (values object t) 85 | (,operation low)))))) 86 | 87 | (define-high-low-fn try-pop-biased-queue pop-raw-queue) 88 | (define-high-low-fn peek-biased-queue peek-raw-queue) 89 | 90 | (define-locking-fn pop-biased-queue (queue) (biased-queue) t lock 91 | (with-biased-queue-slots (lock cvar) queue 92 | (loop (multiple-value-bind (value presentp) 93 | (try-pop-biased-queue/no-lock queue) 94 | (if presentp 95 | (return value) 96 | (condition-wait cvar lock)))))) 97 | 98 | (define-simple-locking-fn 99 | biased-queue-empty-p (queue) (biased-queue) boolean lock 100 | (and (raw-queue-empty-p (high queue)) 101 | (raw-queue-empty-p (low queue)))) 102 | 103 | (define-simple-locking-fn 104 | biased-queue-count (queue) (biased-queue) (integer 0) lock 105 | (+ (raw-queue-count (high queue)) 106 | (raw-queue-count (low queue)))) 107 | 108 | (defmacro with-locked-biased-queue (queue &body body) 109 | `(with-lock-held ((lock ,queue)) 110 | ,@body)) 111 | -------------------------------------------------------------------------------- /src/cognate/option.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.cognate) 32 | 33 | (defun get-parts-hint (parts-hint) 34 | (cond (parts-hint 35 | (check-type parts-hint (integer 1 #.most-positive-fixnum)) 36 | parts-hint) 37 | (t 38 | (kernel-worker-count)))) 39 | 40 | (defmacro pop-plist (list) 41 | `(loop while (keywordp (first ,list)) 42 | collect (pop ,list) 43 | collect (pop ,list))) 44 | 45 | (defun %parse-options (args) 46 | (destructuring-bind (&key size parts) (pop-plist args) 47 | (values args size parts))) 48 | 49 | (defun parse-options (args) 50 | (multiple-value-bind (seqs size parts) (%parse-options args) 51 | (unless seqs 52 | (error "Input sequence(s) for parallelization not found.")) 53 | (unless size 54 | (setf size (find-min-length seqs))) 55 | (setf parts (get-parts-hint parts)) 56 | (values seqs size parts))) 57 | 58 | (defmacro with-parsed-options ((args size parts) &body body) 59 | `(multiple-value-bind (,args ,size ,parts) (parse-options ,args) 60 | ,@body)) 61 | -------------------------------------------------------------------------------- /src/cognate/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defpackage #:lparallel.cognate 32 | (:documentation 33 | "Parallelized versions of some Common Lisp functions.") 34 | (:use #:cl 35 | #:lparallel.util 36 | #:lparallel.kernel 37 | #:lparallel.kernel-util 38 | #:lparallel.promise 39 | #:lparallel.defpun 40 | #:lparallel.slet) 41 | (:export #:pand 42 | #:pcount 43 | #:pcount-if 44 | #:pcount-if-not 45 | #:pdotimes 46 | #:pevery 47 | #:pfind 48 | #:pfind-if 49 | #:pfind-if-not 50 | #:pfuncall 51 | #:plet 52 | #:plet-if 53 | #:pmap 54 | #:pmapc 55 | #:pmapcan 56 | #:pmapcar 57 | #:pmapcon 58 | #:pmap-into 59 | #:pmapl 60 | #:pmaplist 61 | #:pmaplist-into 62 | #:pmap-reduce 63 | #:pnotany 64 | #:pnotevery 65 | #:por 66 | #:preduce 67 | #:preduce-partial 68 | #:premove 69 | #:premove-if 70 | #:premove-if-not 71 | #:psome 72 | #:psort 73 | #:psort* 74 | #:slet) 75 | (:import-from #:alexandria 76 | #:remove-from-plist 77 | #:simple-style-warning) 78 | (:import-from #:lparallel.slet 79 | #:parse-bindings)) 80 | 81 | (in-package #:lparallel.cognate) 82 | -------------------------------------------------------------------------------- /src/cognate/pandor.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.cognate) 32 | 33 | (defmacro with-forms-submitted (forms &body body) 34 | `(with-submit-cancelable 35 | ,@(loop for form in forms 36 | collect `(submit-cancelable (lambda () ,form))) 37 | ,@body)) 38 | 39 | (defmacro pand (&rest forms) 40 | "Parallel version of `and'. Forms in `forms' may be executed in 41 | parallel, though not necessarily at the same time. If all forms 42 | evaluate to true, then the result of any form may be returned." 43 | (with-gensyms (done result next-result) 44 | `(block ,done 45 | (with-forms-submitted ,forms 46 | (let ((,result nil)) 47 | (receive-cancelables ,next-result 48 | (unless (setf ,result ,next-result) 49 | (return-from ,done nil))) 50 | ,result))))) 51 | 52 | (defmacro por (&rest forms) 53 | "Parallel version of `or'. Forms in `forms' may be executed in 54 | parallel, though not necessarily at the same time. Any form which 55 | evaluates to non-nil may be returned." 56 | (with-gensyms (done result) 57 | `(block ,done 58 | (with-forms-submitted ,forms 59 | (receive-cancelables ,result 60 | (when ,result 61 | (return-from ,done ,result))) 62 | nil)))) 63 | -------------------------------------------------------------------------------- /src/cognate/pcount.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.cognate) 32 | 33 | (defun pcount-if (predicate sequence &key from-end (start 0) end key parts) 34 | "Parallel version of `count-if'. 35 | 36 | The `parts' option divides `sequence' into `parts' number of parts. 37 | Default is (kernel-worker-count)." 38 | (let ((subsize (subsize sequence (length sequence) start end))) 39 | (if (zerop subsize) 40 | 0 41 | (let ((predicate (ensure-function predicate))) 42 | (flet ((maybe-inc (acc x) 43 | (declare #.*normal-optimize* 44 | (fixnum acc)) 45 | (if (funcall predicate x) 46 | (the fixnum (1+ acc)) 47 | acc))) 48 | (declare (ftype (function (fixnum t) fixnum) maybe-inc)) 49 | (reduce #'+ (preduce/common #'maybe-inc 50 | sequence 51 | subsize 52 | :initial-value 0 53 | :from-end from-end 54 | :start start 55 | :key key 56 | :parts parts 57 | :partial t))))))) 58 | 59 | (defun pcount-if-not (predicate sequence 60 | &rest args 61 | &key from-end start end key parts) 62 | "Parallel version of `count-if-not'. 63 | 64 | The `parts' option divides `sequence' into `parts' number of parts. 65 | Default is (kernel-worker-count)." 66 | (declare (dynamic-extent args) 67 | (ignore from-end start end key parts)) 68 | (apply #'pcount-if (complement (ensure-function predicate)) sequence args)) 69 | 70 | (defun pcount (item sequence 71 | &key from-end (start 0) end key test test-not parts) 72 | "Parallel version of `count'. 73 | 74 | The `parts' option divides `sequence' into `parts' number of parts. 75 | Default is (kernel-worker-count)." 76 | (pcount-if (item-predicate item test test-not) sequence 77 | :from-end from-end :start start :end end :key key :parts parts)) 78 | -------------------------------------------------------------------------------- /src/cognate/pdotimes.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.cognate) 32 | 33 | (defun %pdotimes (size parts fn) 34 | (declare #.*normal-optimize*) 35 | (check-type size fixnum) 36 | (when (plusp size) 37 | (let ((fn (ensure-function fn))) 38 | (flet ((compute-part (part-offset part-size) 39 | (declare (type fixnum part-offset part-size)) 40 | (let ((index part-offset) 41 | (end (+ part-offset part-size))) 42 | (declare (type fixnum index end)) 43 | (loop while (< index end) 44 | do (funcall fn index) 45 | (incf index))))) 46 | (let ((parts (get-parts-hint parts)) 47 | (channel (make-channel))) 48 | (with-parts size parts 49 | (loop while (next-part) 50 | do (submit-task channel #'compute-part 51 | (part-offset) (part-size))) 52 | (repeat (num-parts) 53 | (receive-result channel)))))))) 54 | 55 | (defmacro/once pdotimes ((var &once count &optional result parts) 56 | &body body) 57 | "Parallel version of `dotimes'. 58 | 59 | The `parts' option divides the integer range into `parts' number of 60 | parts. Default is (kernel-worker-count). 61 | 62 | Unlike `dotimes', `pdotimes' does not define an implicit block named 63 | nil." 64 | (with-parsed-body (body declares) 65 | `(progn 66 | (%pdotimes ,count ,parts (lambda (,var) 67 | ,@declares 68 | (tagbody ,@body))) 69 | (let ((,var (max ,count 0))) 70 | (declare (ignorable ,var)) 71 | ,result)))) 72 | -------------------------------------------------------------------------------- /src/cognate/pfind.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.cognate) 32 | 33 | (defmacro with-pfind-context (sequence start end parts &body body) 34 | (with-gensyms (top result) 35 | `(block ,top 36 | (with-parts 37 | (subsize ,sequence (length ,sequence) ,start ,end) 38 | (get-parts-hint ,parts) 39 | (with-submit-cancelable 40 | ,@body 41 | (receive-cancelables ,result 42 | (when ,result 43 | (return-from ,top ,result))) 44 | nil))))) 45 | 46 | (defun pfind-if/vector (predicate sequence 47 | &key from-end (start 0) end key parts) 48 | (with-pfind-context sequence start end parts 49 | (loop with index = start 50 | while (next-part) 51 | do (submit-cancelable #'find-if 52 | predicate 53 | sequence 54 | :from-end from-end 55 | :start index 56 | :end (+ index (part-size)) 57 | :key key) 58 | (incf index (part-size))))) 59 | 60 | (defun pfind-if/list (predicate sequence 61 | &key from-end (start 0) end key parts) 62 | (with-pfind-context sequence start end parts 63 | (loop with sublist = (nthcdr start sequence) 64 | while (next-part) 65 | do (submit-cancelable #'find-if 66 | predicate 67 | sublist 68 | :from-end from-end 69 | :end (part-size) 70 | :key key) 71 | (setf sublist (nthcdr (part-size) sublist))))) 72 | 73 | (defun pfind-if (predicate sequence 74 | &rest args 75 | &key from-end start end key parts) 76 | "Parallel version of `pfind-if'. 77 | 78 | The `parts' option divides `sequence' into `parts' number of parts. 79 | Default is (kernel-worker-count)." 80 | (declare (dynamic-extent args) 81 | (ignore from-end start end key parts)) 82 | (let ((predicate (ensure-function predicate))) 83 | (typecase sequence 84 | (vector (apply #'pfind-if/vector predicate sequence args)) 85 | (list (apply #'pfind-if/list predicate sequence args)) 86 | (otherwise (apply #'find-if predicate sequence 87 | (remove-from-plist args :parts)))))) 88 | 89 | (defun pfind-if-not (predicate sequence 90 | &rest args 91 | &key from-end start end key parts) 92 | "Parallel version of `pfind-if-not'. 93 | 94 | The `parts' option divides `sequence' into `parts' number of parts. 95 | Default is (kernel-worker-count)." 96 | (declare (dynamic-extent args) 97 | (ignore from-end start end key parts)) 98 | (apply #'pfind-if (complement (ensure-function predicate)) sequence args)) 99 | 100 | (defun pfind (item sequence 101 | &rest args 102 | &key from-end test test-not start end key parts) 103 | "Parallel version of `pfind'. 104 | 105 | The `parts' option divides `sequence' into `parts' number of parts. 106 | Default is (kernel-worker-count)." 107 | (declare (dynamic-extent args) 108 | (ignore from-end start end key parts)) 109 | (apply #'pfind-if 110 | (item-predicate item test test-not) 111 | sequence 112 | (remove-from-plist args :test :test-not))) 113 | -------------------------------------------------------------------------------- /src/cognate/pmap-open-coded.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.cognate) 32 | 33 | ;;;; util 34 | 35 | (defmacro check-symbols (&rest syms) 36 | `(progn 37 | ,@(loop for sym in syms 38 | collect `(check-type ,sym symbol)))) 39 | 40 | (defmacro defmacro/syms (name params &body body) 41 | "Like `defmacro' but requires all parameters to be symbols." 42 | (with-parsed-body (body declares docstring) 43 | `(defmacro ,name ,params 44 | ,@(unsplice docstring) 45 | ,@declares 46 | (check-symbols ,@params) 47 | ,@body))) 48 | 49 | (defun quotedp (form) 50 | (and (consp form) 51 | (eq (first form) 'quote))) 52 | 53 | (defun quoted-vector-type-p (form) 54 | (and (quotedp form) 55 | ;; I pity nil vector types. Don't you? 56 | (not (null (second form))) 57 | (subtypep (second form) 'vector))) 58 | 59 | ;;;; vector-into-vector mapping 60 | 61 | (defmacro/syms map-into/vector/1-vector/range (dst fn src start end) 62 | (with-gensyms (index) 63 | `(let ((,index ,start)) 64 | (declare (type index ,index)) 65 | (loop until (eql ,index ,end) 66 | do (setf (aref ,dst ,index) (funcall ,fn (aref ,src ,index))) 67 | (incf ,index))))) 68 | 69 | (defmacro/syms pmap-into/vector/1-vector (dst fn src size parts) 70 | (with-gensyms (start end) 71 | `(let ((,start 0)) 72 | (declare (type index ,start)) 73 | (with-parts ,size ,parts 74 | (with-submit-counted 75 | (loop while (next-part) 76 | do (submit-counted (let ((,start ,start) 77 | (,end (+ ,start (part-size)))) 78 | (declare (type index ,start ,end)) 79 | (lambda () 80 | (map-into/vector/1-vector/range 81 | ,dst ,fn ,src ,start ,end)))) 82 | (incf ,start (part-size))) 83 | (receive-counted))) 84 | (when (array-has-fill-pointer-p ,dst) 85 | (setf (fill-pointer ,dst) ,size)) 86 | ,dst))) 87 | 88 | ;;;; PMAP-INTO and PMAP 89 | 90 | (define-compiler-macro pmap-into (&whole whole 91 | result-sequence function &rest args) 92 | "Open-coding for 1 vector mapped to vector." 93 | (multiple-value-bind (sequences size-form parts-form) (%parse-options args) 94 | (if (eql 1 (length sequences)) 95 | (with-gensyms (dst fn src size parts) 96 | `(let* ((,src ,(first sequences)) 97 | (,dst ,result-sequence) 98 | (,size (or ,size-form 99 | (min (if (and (vectorp ,dst) 100 | (array-has-fill-pointer-p ,dst)) 101 | (array-total-size ,dst) 102 | (length ,dst)) 103 | (length ,src)))) 104 | (,fn (ensure-function ,function)) 105 | (,parts (get-parts-hint ,parts-form))) 106 | (if (and (vectorp ,dst) 107 | (vectorp ,src) 108 | (plusp ,size)) 109 | (pmap-into/vector/1-vector ,dst ,fn ,src ,size ,parts) 110 | (locally (declare (notinline pmap-into)) 111 | (pmap-into ,dst ,fn :size ,size :parts ,parts ,src))))) 112 | whole))) 113 | 114 | (define-compiler-macro pmap (&whole whole result-type function &rest args) 115 | "Open-coding for 1 vector mapped to vector." 116 | (multiple-value-bind (sequences size-form parts-form) (%parse-options args) 117 | (if (and (eql 1 (length sequences)) 118 | ;; reject literal result-type of nil, 'list, etc immediately 119 | (not (null result-type)) 120 | (or (not (quotedp result-type)) 121 | (quoted-vector-type-p result-type))) 122 | (with-gensyms (dst fn src size parts result-type-value) 123 | `(let* ((,src ,(first sequences)) 124 | (,size (or ,size-form (length ,src))) 125 | (,fn (ensure-function ,function)) 126 | (,parts (get-parts-hint ,parts-form)) 127 | (,result-type-value ,result-type)) 128 | (if ,result-type-value 129 | (let ((,dst (make-sequence 130 | ;; attempt to use the literal result-type 131 | ,(if (quoted-vector-type-p result-type) 132 | result-type 133 | result-type-value) 134 | ,size))) 135 | (if (and (vectorp ,dst) 136 | (vectorp ,src) 137 | (plusp ,size)) 138 | (pmap-into/vector/1-vector ,dst ,fn ,src ,size ,parts) 139 | (locally (declare (notinline pmap-into)) 140 | (pmap-into ,dst ,fn :size ,size :parts ,parts ,src)))) 141 | (locally (declare (notinline pmap)) 142 | (pmap nil ,fn :size ,size :parts ,parts ,src))))) 143 | whole))) 144 | -------------------------------------------------------------------------------- /src/cognate/pquantifier.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.cognate) 32 | 33 | (defun pquantifier (quantifier predicate sequences bail) 34 | (with-parsed-options (sequences size parts-hint) 35 | (let ((input-parts (make-input-parts sequences size parts-hint))) 36 | (with-submit-cancelable 37 | (dosequence (subseqs input-parts) 38 | (submit-cancelable 'apply quantifier predicate subseqs)) 39 | (receive-cancelables result 40 | (when (eq bail (to-boolean result)) 41 | (return-from pquantifier result)))))) 42 | (not bail)) 43 | 44 | (defun pevery (predicate &rest sequences) 45 | "Parallel version of `every'. Calls to `predicate' are done in 46 | parallel, though not necessarily at the same time. Behavior is 47 | otherwise indistinguishable from `every'. 48 | 49 | Keyword arguments `parts' and `size' are also accepted (see `pmap')." 50 | (pquantifier #'every (ensure-function predicate) sequences nil)) 51 | 52 | (defun psome (predicate &rest sequences) 53 | "Parallel version of `some'. Calls to `predicate' are done in 54 | parallel, though not necessarily at the same time. Behavior is 55 | otherwise indistinguishable from `some' except that any non-nil 56 | predicate comparison result may be returned. 57 | 58 | Keyword arguments `parts' and `size' are also accepted (see `pmap')." 59 | (pquantifier #'some (ensure-function predicate) sequences t)) 60 | 61 | (defun pnotevery (predicate &rest sequences) 62 | "Parallel version of `notevery'. Calls to `predicate' are done in 63 | parallel, though not necessarily at the same time. Behavior is 64 | otherwise indistinguishable from `notevery'. 65 | 66 | Keyword arguments `parts' and `size' are also accepted (see `pmap')." 67 | (declare (dynamic-extent sequences)) 68 | (not (apply #'pevery predicate sequences))) 69 | 70 | (defun pnotany (predicate &rest sequences) 71 | "Parallel version of `notany'. Calls to `predicate' are done in 72 | parallel, though not necessarily at the same time. Behavior is 73 | otherwise indistinguishable from `notany'. 74 | 75 | Keyword arguments `parts' and `size' are also accepted (see `pmap')." 76 | (declare (dynamic-extent sequences)) 77 | (not (apply #'psome predicate sequences))) 78 | -------------------------------------------------------------------------------- /src/cognate/preduce.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.cognate) 32 | 33 | (defmacro with-preduce-context (size parts &body body) 34 | (with-gensyms (results) 35 | `(with-parts ,size ,parts 36 | (let ((,results (make-array (num-parts)))) 37 | (with-submit-indexed (num-parts) ,results 38 | ,@body 39 | (receive-indexed)))))) 40 | 41 | (defun preduce-partial/vector (function sequence start size parts 42 | &rest keyword-args) 43 | (declare (dynamic-extent keyword-args)) 44 | (with-preduce-context size parts 45 | (loop for result-index from 0 46 | while (next-part) 47 | do (apply #'submit-indexed 48 | result-index 49 | #'reduce 50 | function 51 | sequence 52 | :start (+ start (part-offset)) 53 | :end (+ start (part-offset) (part-size)) 54 | keyword-args)))) 55 | 56 | (defun preduce-partial/list (function sequence start size parts 57 | &rest keyword-args) 58 | (declare (dynamic-extent keyword-args)) 59 | (with-preduce-context size parts 60 | (loop with subseq = (nthcdr start sequence) 61 | for result-index from 0 62 | while (next-part) 63 | do (apply #'submit-indexed 64 | result-index 65 | #'reduce 66 | function 67 | subseq 68 | :end (part-size) 69 | keyword-args) 70 | (setf subseq (nthcdr (part-size) subseq))))) 71 | 72 | (defun %preduce-partial (function sequence start size parts 73 | &rest keyword-args) 74 | (declare (dynamic-extent keyword-args)) 75 | (etypecase sequence 76 | (vector (apply #'preduce-partial/vector 77 | function sequence start size parts keyword-args)) 78 | (list (apply #'preduce-partial/list 79 | function sequence start size parts keyword-args)))) 80 | 81 | (defun preduce/common (function sequence subsize 82 | &key 83 | key 84 | from-end 85 | (start 0) 86 | end 87 | (initial-value nil initial-value-given-p) 88 | parts 89 | recurse 90 | partial) 91 | (declare (ignore end)) 92 | (cond ((zerop subsize) 93 | (when partial 94 | (error "PREDUCE-PARTIAL given zero-length sequence")) 95 | (if initial-value-given-p 96 | initial-value 97 | (funcall function))) 98 | (t 99 | (let* ((parts-hint (get-parts-hint parts)) 100 | (results (apply #'%preduce-partial 101 | function sequence start subsize parts-hint 102 | :key key 103 | :from-end from-end 104 | (when initial-value-given-p 105 | (list :initial-value initial-value))))) 106 | (if partial 107 | results 108 | (let ((new-size (length results))) 109 | (if (and recurse (>= new-size 4)) 110 | (apply #'preduce/common 111 | function 112 | results 113 | new-size 114 | :from-end from-end 115 | :parts (min parts-hint (floor new-size 2)) 116 | :recurse recurse 117 | (when initial-value-given-p 118 | (list :initial-value initial-value))) 119 | (reduce function results)))))))) 120 | 121 | (defun preduce (function sequence &rest args 122 | &key key from-end (start 0) end initial-value parts recurse) 123 | "Parallel version of `reduce'. 124 | 125 | `preduce' subdivides the input sequence into `parts' number of parts 126 | and, in parallel, calls `reduce' on each part. The partial results are 127 | then reduced again, either by `reduce' (the default) or, if `recurse' 128 | is non-nil, by `preduce'. 129 | 130 | `parts' defaults to (kernel-worker-count). 131 | 132 | `key' is thrown out while reducing the partial results. It applies to 133 | the first pass only. 134 | 135 | `start' and `end' have the same meaning as in `reduce'. 136 | 137 | `from-end' means \"from the end of each part\". 138 | 139 | `initial-value' means \"initial value of each part\"." 140 | (declare (ignore key from-end initial-value parts recurse)) 141 | (declare (dynamic-extent args)) 142 | (typecase sequence 143 | ((or vector list) 144 | (apply #'preduce/common 145 | function 146 | sequence 147 | (subsize sequence (length sequence) start end) 148 | args)) 149 | (otherwise 150 | (apply #'reduce 151 | function 152 | sequence 153 | (remove-from-plist args :parts :recurse))))) 154 | 155 | (defun preduce-partial (function sequence &rest args 156 | &key key from-end (start 0) end initial-value parts) 157 | "Like `preduce' but only does a single reducing pass. 158 | 159 | The length of `sequence' must not be zero. 160 | 161 | Returns the partial results as a vector." 162 | (declare (ignore key from-end initial-value parts)) 163 | (declare (dynamic-extent args)) 164 | (apply #'preduce/common 165 | function 166 | sequence 167 | (subsize sequence (length sequence) start end) 168 | :partial t 169 | args)) 170 | -------------------------------------------------------------------------------- /src/cognate/premove.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.cognate) 32 | 33 | (defun premove-if-not/list (test list from-end start end key parts) 34 | (let* ((size (length list)) 35 | (subsize (subsize list size start end))) 36 | (if (zerop subsize) 37 | nil 38 | (let ((test (ensure-function test)) 39 | (leading (subseq list 0 start)) 40 | (trailing (if (or (null end) 41 | (eql subsize (- size start))) 42 | nil 43 | (copy-list (nthcdr end list))))) 44 | (nconc leading 45 | (reduce #'nreconc 46 | (preduce/common (lambda (acc x) 47 | (declare #.*normal-optimize*) 48 | (if (funcall test x) 49 | (cons x acc) 50 | acc)) 51 | (nthcdr start list) 52 | subsize 53 | :initial-value nil 54 | :key key 55 | :parts parts 56 | :from-end from-end 57 | :partial t) 58 | :initial-value trailing 59 | :from-end t)))))) 60 | 61 | (defun premove-if-not (test sequence 62 | &rest args 63 | &key from-end (start 0) end key parts) 64 | "Parallel version of `remove-if-not'. Note the `count' option is not 65 | supported. 66 | 67 | The `parts' option divides `sequence' into `parts' number of parts. 68 | Default is (kernel-worker-count)." 69 | (declare (dynamic-extent args)) 70 | (typecase sequence 71 | (list (premove-if-not/list test sequence 72 | from-end start end key parts)) 73 | (otherwise (apply #'remove-if-not test sequence args)))) 74 | 75 | (defun premove-if (test sequence 76 | &rest args 77 | &key from-end (start 0) end key parts) 78 | "Parallel version of `remove-if'. Note the `count' option is not 79 | supported. 80 | 81 | The `parts' option divides `sequence' into `parts' number of parts. 82 | Default is (kernel-worker-count)." 83 | (declare (dynamic-extent args)) 84 | (typecase sequence 85 | (list (premove-if-not/list (complement (ensure-function test)) sequence 86 | from-end start end key parts)) 87 | (otherwise (apply #'remove-if test sequence 88 | (remove-from-plist args :parts))))) 89 | 90 | (defun premove (item sequence 91 | &rest args 92 | &key test test-not from-end (start 0) end key parts) 93 | "Parallel version of `remove'. Note the `count' option is not 94 | supported. 95 | 96 | The `parts' option divides `sequence' into `parts' number of parts. 97 | Default is (kernel-worker-count)." 98 | (declare (dynamic-extent args)) 99 | (typecase sequence 100 | (list (premove-if-not/list (complement (item-predicate item test test-not)) 101 | sequence 102 | from-end start end key parts)) 103 | (otherwise (apply #'remove item sequence 104 | (remove-from-plist args :parts))))) 105 | -------------------------------------------------------------------------------- /src/cognate/psort.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.cognate) 32 | 33 | (defun/type/inline midpoint (a b) (fixnum fixnum) fixnum 34 | (declare #.*full-optimize*) 35 | (+ a (the fixnum (ash (the fixnum (- b a)) -1)))) 36 | 37 | ;;; 38 | ;;; Adapted from Roger Corman's usenet post. Free license. 39 | ;;; 40 | (defmacro define-quicksort-fn (name call-key key key-type gran gran-type) 41 | `(defpun/type ,name (vec lo hi compare ,@(unsplice gran) ,@(unsplice key)) 42 | (vector fixnum fixnum function 43 | ,@(unsplice gran-type) ,@(unsplice key-type)) 44 | (values) 45 | (declare #.*full-optimize*) 46 | #+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) 47 | (when (> hi lo) 48 | (let* ((mid (the fixnum (midpoint lo hi))) 49 | (i lo) 50 | (j (the fixnum (1+ hi))) 51 | (p (,call-key (aref vec mid)))) 52 | (declare (type fixnum mid i j)) 53 | (rotatef (aref vec mid) 54 | (aref vec lo)) 55 | (loop 56 | (loop do (incf i) 57 | until (or (> i hi) 58 | (funcall compare p (,call-key (aref vec i))))) 59 | (loop do (decf j) 60 | until (or (<= j lo) 61 | (funcall compare (,call-key (aref vec j)) p))) 62 | (when (< j i) 63 | (return)) 64 | (rotatef (aref vec i) 65 | (aref vec j))) 66 | (rotatef (aref vec lo) 67 | (aref vec j)) 68 | ,(let ((left `(,name vec lo (the fixnum (1- j)) 69 | compare ,@(unsplice gran) ,@(unsplice key))) 70 | (right `(,name vec i hi 71 | compare ,@(unsplice gran) ,@(unsplice key)))) 72 | (if gran 73 | `(let ((left-size (the fixnum (- j lo)))) 74 | (declare (type fixnum left-size)) 75 | (if (> left-size ,gran) 76 | (plet ((left-result ,left) 77 | (right-result ,right)) 78 | (declare (ignore left-result right-result))) 79 | (let ((right-size (the fixnum 80 | (1+ (the fixnum (- hi i)))))) 81 | (declare (type fixnum right-size)) 82 | (if (> right-size ,gran) 83 | (plet ((right-result ,right) 84 | (left-result ,left)) 85 | (declare (ignore left-result right-result))) 86 | (cond ((< left-size right-size) 87 | ,left 88 | ,right) 89 | (t 90 | ,right 91 | ,left)))))) 92 | `(plet ((right-result ,right) 93 | (left-result ,left)) 94 | (declare (ignore right-result left-result))))))) 95 | (values))) 96 | 97 | (defmacro define-quicksort-fns () 98 | (with-gensyms (iden call-key key gran) 99 | `(macrolet ((,iden (x) x) 100 | (,call-key (x) `(funcall ,',key ,x))) 101 | (define-quicksort-fn quicksort/no-key/no-gran 102 | ,iden nil nil nil nil) 103 | (define-quicksort-fn quicksort/no-key/gran 104 | ,iden nil nil ,gran fixnum) 105 | (define-quicksort-fn quicksort/key/no-gran 106 | ,call-key ,key function nil nil) 107 | (define-quicksort-fn quicksort/key/gran 108 | ,call-key ,key function ,gran fixnum)))) 109 | 110 | (define-quicksort-fns) 111 | 112 | ;;; reduce some clutter in defpun expansions; it's safe to remove 113 | ;;; these because users should not call them directly 114 | (lparallel.defpun::delete-registered-names 115 | '(quicksort/no-key/no-gran 116 | quicksort/no-key/gran 117 | quicksort/key/no-gran 118 | quicksort/key/gran)) 119 | 120 | (defun call-quicksort (vec lo hi compare granularity key) 121 | (if key 122 | (if granularity 123 | (quicksort/key/gran vec lo hi compare granularity key) 124 | (quicksort/key/no-gran vec lo hi compare key)) 125 | (if granularity 126 | (quicksort/no-key/gran vec lo hi compare granularity) 127 | (quicksort/no-key/no-gran vec lo hi compare)))) 128 | 129 | (defun psort (sequence predicate &key key granularity &allow-other-keys) 130 | (typecase sequence 131 | (vector 132 | (when granularity 133 | (check-type granularity fixnum)) 134 | (call-quicksort sequence 135 | 0 136 | (1- (length sequence)) 137 | (ensure-function predicate) 138 | granularity 139 | (and key (ensure-function key))) 140 | sequence) 141 | (otherwise 142 | (sort sequence predicate :key key)))) 143 | 144 | (setf (documentation 'psort 'function) 145 | "Parallel version of `sort'. 146 | 147 | If `granularity' is provided then parallel tasks are created only for 148 | segments larger than `granularity'. This may or may not result in 149 | better performance. 150 | 151 | At present `psort' is only parallelized for vectors; other types are 152 | given to `cl:sort'.") 153 | 154 | (defun psort* (&rest args) 155 | "Deprecated. Instead use `psort' and pass `:use-caller t' to 156 | `make-kernel'." 157 | (apply #'psort args)) 158 | 159 | (define-compiler-macro psort* (&whole whole &rest args) 160 | (declare (ignore args)) 161 | (simple-style-warning 162 | "`psort*' is deprecated. Instead use `psort' and pass ~ 163 | `:use-caller t' to `make-kernel'.") 164 | whole) 165 | -------------------------------------------------------------------------------- /src/cognate/subdivide.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.cognate) 32 | 33 | (defun find-num-parts (size parts-hint) 34 | (multiple-value-bind (quo rem) (floor size parts-hint) 35 | (values (if (zerop quo) rem parts-hint) quo rem))) 36 | 37 | (defmacro with-parts (seq-size parts-hint &body body) 38 | (with-gensyms (quo rem index num-parts part-offset part-size) 39 | `(multiple-value-bind 40 | (,num-parts ,quo ,rem) (find-num-parts ,seq-size ,parts-hint) 41 | (declare (fixnum ,num-parts ,quo ,rem)) 42 | (let ((,index 0) 43 | (,part-offset 0) 44 | (,part-size 0)) 45 | (declare (fixnum ,index ,part-offset ,part-size)) 46 | (flet ((next-part () 47 | (when (< ,index ,num-parts) 48 | (unless (zerop ,index) 49 | (incf ,part-offset ,part-size)) 50 | (setf ,part-size (if (< ,index ,rem) (1+ ,quo) ,quo)) 51 | (incf ,index))) 52 | (part-size () ,part-size) 53 | (part-offset () ,part-offset) 54 | (num-parts () ,num-parts)) 55 | (declare (inline part-size part-offset num-parts) 56 | (ignorable #'part-size #'part-offset #'num-parts)) 57 | ,@body))))) 58 | 59 | (defun subdivide-array (array size parts-hint) 60 | (with-parts size parts-hint 61 | (map-into (make-array (num-parts)) 62 | (lambda () 63 | (next-part) 64 | (make-array (part-size) 65 | :displaced-to array 66 | :displaced-index-offset (part-offset) 67 | :element-type (array-element-type array)))))) 68 | 69 | (defun subdivide-list (list size parts-hint) 70 | (with-parts size parts-hint 71 | (loop with p = list 72 | while (next-part) 73 | collect p 74 | do (setf p (nthcdr (part-size) p))))) 75 | 76 | (defun subdivide-list/slice (list size parts-hint) 77 | (with-parts size parts-hint 78 | (loop with p = list 79 | while (next-part) 80 | collect p into firsts 81 | collect (prog1 (setf p (nthcdr (1- (part-size)) p)) 82 | (setf p (prog1 (cdr p) (setf (cdr p) nil)))) into lasts 83 | finally (return (values firsts 84 | (lambda () 85 | ;; stitch it back together 86 | (loop for last in lasts 87 | for first in (cdr firsts) 88 | do (setf (cdr last) first) 89 | finally (setf (cdr last) p)))))))) 90 | 91 | (defun make-parts (result size parts-hint &key slicep) 92 | (if (listp result) 93 | (funcall (if slicep #'subdivide-list/slice #'subdivide-list) 94 | result size parts-hint) 95 | (subdivide-array result size parts-hint))) 96 | 97 | (defun make-result-parts (result size parts-hint) 98 | "Subdivide the result sequence. For a list, delineate boundaries by slicing." 99 | (make-parts result size parts-hint :slicep t)) 100 | 101 | (defun make-input-parts (sequences size parts-hint) 102 | "Subdivide and interleave sequences for parallel mapping." 103 | (zip/vector (mapcar (lambda (seq) (make-parts seq size parts-hint)) 104 | sequences))) 105 | -------------------------------------------------------------------------------- /src/cognate/util.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.cognate) 32 | 33 | (defun zip/vector (seqs) 34 | (apply #'map 'vector #'list seqs)) 35 | 36 | (defun find-min-length (seqs) 37 | (reduce #'min seqs :key #'length)) 38 | 39 | (defun item-predicate (item test test-not) 40 | (when (and test test-not) 41 | (error "Both :TEST and :TEST-NOT options given.")) 42 | (when test-not 43 | (setf test (complement (ensure-function test-not))) 44 | (setf test-not nil)) 45 | (if test 46 | (let ((test (ensure-function test))) 47 | (lambda (x) 48 | (declare #.*normal-optimize*) 49 | (funcall test item x))) 50 | (typecase item 51 | ((or number character) 52 | (lambda (x) 53 | (declare #.*full-optimize*) 54 | (eql item x))) 55 | (otherwise 56 | (lambda (x) 57 | (declare #.*full-optimize*) 58 | (eq item x)))))) 59 | 60 | (defun subsize (seq size start end) 61 | (let ((result (- (or end size) start))) 62 | (when (or (minusp result) (> result size)) 63 | (error "Bad interval for sequence operation on ~a: start=~a end=~a" 64 | seq start end)) 65 | result)) 66 | -------------------------------------------------------------------------------- /src/cons-queue.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defpackage #:lparallel.cons-queue 32 | (:documentation 33 | "(private) Blocking infinite-capacity queue.") 34 | (:use #:cl 35 | #:lparallel.util 36 | #:lparallel.thread-util 37 | #:lparallel.raw-queue) 38 | (:export #:cons-queue 39 | #:make-cons-queue 40 | #:push-cons-queue #:push-cons-queue/no-lock 41 | #:pop-cons-queue #:pop-cons-queue/no-lock 42 | #:peek-cons-queue #:peek-cons-queue/no-lock 43 | #:cons-queue-count #:cons-queue-count/no-lock 44 | #:cons-queue-empty-p #:cons-queue-empty-p/no-lock 45 | #:try-pop-cons-queue #:try-pop-cons-queue/no-lock 46 | #:with-locked-cons-queue) 47 | (:import-from #:lparallel.thread-util 48 | #:define-locking-fn 49 | #:define-simple-locking-fn 50 | #:with-countdown 51 | #:time-remaining)) 52 | 53 | (in-package #:lparallel.cons-queue) 54 | 55 | (defslots cons-queue () 56 | ((impl :reader impl :type raw-queue) 57 | (lock :reader lock :initform (make-lock)) 58 | (cvar :initform nil))) 59 | 60 | (defun %make-cons-queue () 61 | (make-cons-queue-instance :impl (make-raw-queue))) 62 | 63 | (defmacro with-locked-cons-queue (queue &body body) 64 | `(with-lock-held ((lock ,queue)) 65 | ,@body)) 66 | 67 | (define-locking-fn push-cons-queue (object queue) (t cons-queue) (values) lock 68 | (with-cons-queue-slots (impl cvar) queue 69 | (push-raw-queue object impl) 70 | (when cvar 71 | (condition-notify cvar))) 72 | (values)) 73 | 74 | (define-locking-fn pop-cons-queue (queue) (cons-queue) t lock 75 | (with-cons-queue-slots (impl lock cvar) queue 76 | (loop (multiple-value-bind (value presentp) (pop-raw-queue impl) 77 | (if presentp 78 | (return value) 79 | (condition-wait (or cvar (setf cvar (make-condition-variable))) 80 | lock)))))) 81 | 82 | (defun %try-pop-cons-queue/no-lock/timeout (queue timeout) 83 | ;; queue is empty and timeout is positive 84 | (declare #.*full-optimize*) 85 | (with-countdown (timeout) 86 | (with-cons-queue-slots (impl lock cvar) queue 87 | (loop (multiple-value-bind (value presentp) (pop-raw-queue impl) 88 | (when presentp 89 | (return (values value t))) 90 | (let ((time-remaining (time-remaining))) 91 | (when (or (not (plusp time-remaining)) 92 | (null (condition-wait 93 | (or cvar (setf cvar (make-condition-variable))) 94 | lock :timeout time-remaining))) 95 | (return (values nil nil))))))))) 96 | 97 | (defun try-pop-cons-queue/no-lock/timeout (queue timeout) 98 | (declare #.*full-optimize*) 99 | (with-cons-queue-slots (impl) queue 100 | (if (raw-queue-empty-p impl) 101 | (%try-pop-cons-queue/no-lock/timeout queue timeout) 102 | (pop-raw-queue impl)))) 103 | 104 | (defun try-pop-cons-queue (queue timeout) 105 | (declare #.*full-optimize*) 106 | (with-cons-queue-slots (impl lock) queue 107 | (cond ((plusp timeout) 108 | (with-lock-held (lock) 109 | (try-pop-cons-queue/no-lock/timeout queue timeout))) 110 | (t 111 | ;; optimization: don't lock if nothing is there 112 | (with-lock-predicate/wait lock (not (raw-queue-empty-p impl)) 113 | (return-from try-pop-cons-queue (pop-raw-queue impl))) 114 | (values nil nil))))) 115 | 116 | (defun try-pop-cons-queue/no-lock (queue timeout) 117 | (declare #.*full-optimize*) 118 | (if (plusp timeout) 119 | (try-pop-cons-queue/no-lock/timeout queue timeout) 120 | (pop-raw-queue (impl queue)))) 121 | 122 | (defmacro define-queue-fn (name arg-types raw return-type) 123 | `(define-simple-locking-fn ,name (queue) ,arg-types ,return-type lock 124 | (,raw (impl queue)))) 125 | 126 | (define-queue-fn cons-queue-count (cons-queue) 127 | raw-queue-count 128 | raw-queue-count) 129 | 130 | (define-queue-fn cons-queue-empty-p (cons-queue) 131 | raw-queue-empty-p 132 | boolean) 133 | 134 | (define-queue-fn peek-cons-queue (cons-queue) 135 | peek-raw-queue 136 | (values t boolean)) 137 | 138 | (defun make-cons-queue (&key initial-contents) 139 | (let ((queue (%make-cons-queue))) 140 | (when initial-contents 141 | (flet ((push-elem (elem) 142 | (push-cons-queue/no-lock elem queue))) 143 | (declare (dynamic-extent #'push-elem)) 144 | (map nil #'push-elem initial-contents))) 145 | queue)) 146 | -------------------------------------------------------------------------------- /src/counter.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defpackage #:lparallel.counter 32 | (:documentation 33 | "(private) Atomic counter.") 34 | (:use #:cl 35 | #:lparallel.util 36 | #:lparallel.thread-util) 37 | (:export #:counter 38 | #:make-counter 39 | #:inc-counter 40 | #:dec-counter 41 | #:counter-value)) 42 | 43 | (in-package #:lparallel.counter) 44 | 45 | ;;; Atomic counters modeled after SBCL, i.e., operations return the 46 | ;;; original value. 47 | 48 | #+sbcl 49 | (progn 50 | ;; try to avoid using sb-ext:word since it is newish 51 | (deftype counter-value () 52 | #+(or x86-64 x86) 53 | '(unsigned-byte #+x86-64 64 #+x86 32) 54 | #-(or x86-64 x86) 55 | 'sb-ext:word) 56 | 57 | (defstruct (counter (:constructor make-counter (&optional value))) 58 | (value 0 :type counter-value)) 59 | 60 | (defmacro define-counter-fn (name op) 61 | `(defun/inline ,name (counter) 62 | (,op (counter-value counter)))) 63 | 64 | (define-counter-fn inc-counter sb-ext:atomic-incf) 65 | (define-counter-fn dec-counter sb-ext:atomic-decf)) 66 | 67 | #+(or ccl lispworks) 68 | (progn 69 | (deftype counter () 'cons) 70 | 71 | (defun make-counter (&optional (value 0)) 72 | (cons value nil)) 73 | 74 | (alias-function counter-value car) 75 | 76 | (defmacro define-counter-fn (name op adjust) 77 | `(defun/inline ,name (counter) 78 | (,adjust (,op (car counter))))) 79 | 80 | ;;; Strangely, Clozure does advertise these atomic operations but does 81 | ;;; not export the symbols. 82 | 83 | (define-counter-fn inc-counter #+ccl ccl::atomic-incf 84 | #+lispworks system:atomic-incf 85 | 1-) 86 | (define-counter-fn dec-counter #+ccl ccl::atomic-decf 87 | #+lispworks system:atomic-decf 88 | 1+)) 89 | 90 | #-(or sbcl ccl lispworks) 91 | (progn 92 | (defslots counter () 93 | ((value :reader counter-value) 94 | (lock :reader lock :initform (make-lock)))) 95 | 96 | (defun make-counter (&optional (value 0)) 97 | (make-counter-instance :value value)) 98 | 99 | (defmacro define-counter-fn (name op adjust) 100 | `(defun/inline ,name (counter) 101 | (with-counter-slots (value lock) counter 102 | (,adjust (with-lock-held (lock) 103 | (,op value)))))) 104 | 105 | (define-counter-fn inc-counter incf 1-) 106 | (define-counter-fn dec-counter decf 1+)) 107 | -------------------------------------------------------------------------------- /src/kernel-util.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defpackage #:lparallel.kernel-util 32 | (:documentation 33 | "(semi-private) Abstracts some common patterns for submitting and 34 | receiving tasks. This probably won't change, but no guarantees.") 35 | (:use #:cl 36 | #:lparallel.util 37 | #:lparallel.kernel 38 | #:lparallel.queue) 39 | (:export #:with-submit-counted 40 | #:submit-counted 41 | #:receive-counted) 42 | (:export #:with-submit-indexed 43 | #:submit-indexed 44 | #:receive-indexed) 45 | (:export #:with-submit-cancelable 46 | #:submit-cancelable 47 | #:receive-cancelables) 48 | (:export #:with-temp-kernel) 49 | (:import-from #:lparallel.kernel 50 | #:*worker* 51 | #:steal-work 52 | #:channel-kernel)) 53 | 54 | (in-package #:lparallel.kernel-util) 55 | 56 | (defun steal-until-receive-result (channel worker fn) 57 | (declare #.*normal-optimize*) 58 | (loop 59 | (multiple-value-bind (result presentp) (try-receive-result channel) 60 | (when presentp 61 | (when fn 62 | (locally (declare (type function fn)) 63 | (funcall fn result))) 64 | (return))) 65 | (steal-work (channel-kernel channel) worker))) 66 | 67 | (defun receive-results (channel count fn) 68 | (declare #.*normal-optimize*) 69 | (let ((worker *worker*)) 70 | (if worker 71 | (repeat count 72 | (steal-until-receive-result channel worker fn)) 73 | (if fn 74 | (do-fast-receives (result channel count) 75 | (locally (declare (type function fn)) 76 | (funcall fn result))) 77 | (do-fast-receives (result channel count) 78 | (declare (ignore result))))))) 79 | 80 | (defmacro with-submit-counted (&body body) 81 | (with-gensyms (count channel) 82 | `(let ((,count 0) 83 | (,channel (make-channel))) 84 | (declare (fixnum ,count)) 85 | (flet ((submit-counted (&rest args) 86 | (declare (dynamic-extent args)) 87 | (apply #'submit-task ,channel args) 88 | (incf ,count)) 89 | (receive-counted () 90 | (receive-results ,channel ,count nil))) 91 | (declare (inline submit-counted receive-counted)) 92 | ,@body)))) 93 | 94 | (defun indexing-wrapper (array index function args) 95 | (setf (aref array index) (apply function args))) 96 | 97 | (defmacro/once with-submit-indexed (&once count &once array &body body) 98 | (with-gensyms (channel) 99 | `(let ((,channel (make-channel))) 100 | (flet ((submit-indexed (index function &rest args) 101 | (submit-task 102 | ,channel #'indexing-wrapper ,array index function args)) 103 | (receive-indexed () 104 | (receive-results ,channel ,count nil) 105 | ,array)) 106 | (declare (inline submit-indexed receive-indexed)) 107 | ,@body)))) 108 | 109 | (defmacro with-submit-cancelable (&body body) 110 | (with-gensyms (canceledp channel count) 111 | `(let ((,canceledp nil) 112 | (,count 0) 113 | (,channel (make-channel))) 114 | (flet ((submit-cancelable (fn &rest args) 115 | (submit-task ,channel 116 | (lambda () 117 | (if ,canceledp 118 | 'task-canceled 119 | (apply fn args)))) 120 | (incf ,count))) 121 | (macrolet ((receive-cancelables (result &body body) 122 | `(receive-results 123 | ,',channel ,',count (lambda (,result) ,@body)))) 124 | (unwind-protect (progn ,@body) 125 | (setf ,canceledp t))))))) 126 | 127 | (defun call-with-temp-kernel (fn &rest args) 128 | ;; ensure that we end the same kernel we create 129 | (let ((kernel (apply #'make-kernel args))) 130 | (unwind-protect 131 | (let ((*kernel* kernel)) 132 | (funcall fn)) 133 | (let ((*kernel* kernel)) 134 | (end-kernel :wait t))))) 135 | 136 | (defmacro with-temp-kernel ((&rest make-kernel-args) &body body) 137 | "Create a temporary kernel for the duration of `body', ensuring that 138 | `end-kernel' is eventually called. `make-kernel' is given the 139 | arguments `make-kernel-args'. 140 | 141 | **NOTE**: Use this only if you understand its implications. Since 142 | `*kernel*' is unaffected outside `body', the REPL will be useless with 143 | respect to the temporary kernel. For instance calling `kill-tasks' 144 | from the REPL will not affect tasks that are running in the temporary 145 | kernel. 146 | 147 | Multiple uses of `with-temp-kernel' within the same application are 148 | prone to defeat the purpose and benefits of having a thread pool. This 149 | is an especial risk if `with-temp-kernel' appears inside a library, 150 | which is likely to be a suboptimal situation. 151 | 152 | While using `with-temp-kernel' is generally a bad idea, there are a 153 | few valid uses, such as for testing, where the code is non-critical or 154 | where convenience trumps other concerns." 155 | `(call-with-temp-kernel (lambda () ,@body) ,@make-kernel-args)) 156 | -------------------------------------------------------------------------------- /src/kernel/central-scheduler.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.kernel) 32 | 33 | (defun make-scheduler (workers spin-count) 34 | (declare (ignore workers spin-count)) 35 | (make-biased-queue)) 36 | 37 | (defun/type schedule-task (scheduler task priority) 38 | (scheduler (or task null) t) (values) 39 | (declare #.*normal-optimize*) 40 | (ccase priority 41 | (:default (push-biased-queue task scheduler)) 42 | (:low (push-biased-queue/low task scheduler))) 43 | (values)) 44 | 45 | (defun/inline next-task (scheduler worker) 46 | (declare (ignore worker)) 47 | (pop-biased-queue scheduler)) 48 | 49 | (defun/type steal-task (scheduler) (scheduler) (or task null) 50 | (declare #.*normal-optimize*) 51 | (with-lock-predicate/wait 52 | (lparallel.biased-queue::lock scheduler) 53 | (not (biased-queue-empty-p/no-lock scheduler)) 54 | ;; don't steal nil, the end condition flag 55 | (when (peek-biased-queue/no-lock scheduler) 56 | (pop-biased-queue/no-lock scheduler)))) 57 | -------------------------------------------------------------------------------- /src/kernel/classes.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.kernel) 32 | 33 | (defslots worker-info () 34 | ((bindings :type list) 35 | (context :type function) 36 | (name :type string)) 37 | (:documentation 38 | "Information common to all workers. See `make-kernel'.")) 39 | 40 | (defslots worker-notifications () 41 | ((handshake/from-worker :initform (make-queue)) 42 | (handshake/to-worker :initform (make-queue)) 43 | (exit-notification :initform (make-queue))) 44 | (:documentation 45 | "Communication with workers. A handshake takes place when a worker 46 | is created in order to verify its existence and to ensure all data 47 | is initialized. A worker sends a notification just before it exits.")) 48 | 49 | (defslots worker (worker-notifications) 50 | ((thread :reader thread) 51 | (running-category :reader running-category :initform nil) 52 | (index :reader worker-index :type index) 53 | #+lparallel.with-stealing-scheduler 54 | (tasks :reader tasks :type spin-queue)) 55 | (:documentation 56 | "A worker represents a thread dedicated to executing tasks. See 57 | `kill-tasks' for an explanation of `running-category'. `index' is 58 | the location of the worker in the kernel's vector of workers. When 59 | the stealing scheduler is enabled, each worker has its own lockless 60 | task queue.")) 61 | 62 | #+lparallel.with-stealing-scheduler 63 | (defslots scheduler () 64 | ((workers :type simple-vector) 65 | (wait-cvar :initform (make-condition-variable)) 66 | (wait-lock :initform (make-lock)) 67 | (wait-count :initform (make-counter) :type counter) 68 | (notify-count :initform 0 :type (integer 0)) 69 | (spin-count :type index) 70 | (random-index :initform 0 :type index) 71 | (low-priority-tasks :initform (make-spin-queue) :type spin-queue)) 72 | (:documentation 73 | "A scheduler is responsible for storing tasks and finding the next 74 | task to execute. A task may also be stolen from the scheduler. 75 | 76 | `workers' -- vector of workers; kernel has the same reference. 77 | 78 | `wait-cvar', `wait-lock', `wait-count', `notify-count' -- these 79 | coordinate waking/sleeping of workers. 80 | 81 | `spin-count' -- see `make-kernel'. 82 | 83 | `random-index' -- some random index to the vector of workers. 84 | 85 | `low-priority-tasks' -- tasks submitted when `*task-priority*' is `:low'.")) 86 | 87 | #-lparallel.with-stealing-scheduler 88 | (progn 89 | ;;; The central queue scheduler. All tasks are submitted to a single 90 | ;;; queue and all workers pull from the same. 91 | (deftype scheduler () 'biased-queue) 92 | (defun tasks (scheduler) (declare (ignore scheduler)))) 93 | 94 | ;;; The limiter, if in use, places a limit on the number of queued 95 | ;;; tasks. This must be a struct for CAS. The `limiter-accept-task-p' 96 | ;;; flag must be fast/inlined in order to be useful, which is why the 97 | ;;; kernel subclasses directly from this." 98 | #-lparallel.with-debug 99 | (locally (declare #.*full-optimize*) 100 | (defstruct (limiter (:conc-name nil)) 101 | (limiter-accept-task-p (error "no init") :type boolean) 102 | (limiter-lock (error "no init")) 103 | (limiter-count (error "no init") :type fixnum))) 104 | 105 | ;;; Debug version of limiter can't be a struct since in this case 106 | ;;; `defslots' expands to `defclass'. 107 | #+lparallel.with-debug 108 | (defclass limiter () 109 | ((limiter-accept-task-p :accessor limiter-accept-task-p 110 | :initarg :limiter-accept-task-p 111 | :type boolean) 112 | (limiter-lock :accessor limiter-lock 113 | :initarg :limiter-lock) 114 | (limiter-count :accessor limiter-count 115 | :initarg :limiter-count 116 | :type fixnum))) 117 | 118 | (locally (declare #.*full-optimize*) 119 | (defslots kernel (limiter) 120 | ((scheduler :reader scheduler :type scheduler) 121 | (workers :reader workers :type simple-vector) 122 | (workers-lock) 123 | (worker-info :type worker-info) 124 | (use-caller-p :reader use-caller-p :type boolean) 125 | (alivep :reader alivep :type boolean)) 126 | (:documentation 127 | "The kernel encompasses the scheduling and execution of parallel 128 | tasks using a pool of worker threads. All parallelism in lparallel 129 | is done on top of the kernel."))) 130 | 131 | (defslots channel () 132 | ((queue :reader channel-queue :type queue) 133 | (kernel :reader channel-kernel :type kernel)) 134 | (:documentation 135 | "A task is submitted to the kernel using a channel. A channel 136 | always points to the same kernel, which is the value of `*kernel*' 137 | when the channel is created.")) 138 | 139 | #-lparallel.without-task-categories 140 | (locally (declare #.*full-optimize*) 141 | (defpair task () 142 | ((fn :reader task-fn :type function) 143 | (category :reader task-category)) 144 | (:documentation 145 | "A task consists of a function and a category. See `kill-tasks' for 146 | and explanation of task categories."))) 147 | 148 | #+lparallel.without-task-categories 149 | (progn 150 | (deftype task () 'function) 151 | (defmacro make-task (fn) fn) 152 | (defmacro task-fn (x) x)) 153 | -------------------------------------------------------------------------------- /src/kernel/handling.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.kernel) 32 | 33 | (defslots wrapped-error () 34 | ((value :type condition :reader wrapped-error-value)) 35 | (:documentation 36 | "This is a container for transferring an error that occurs inside 37 | `call-with-task-handler' to the calling thread.")) 38 | 39 | (defun wrap-error (condition) 40 | "Wrap an error. A non-error condition may also be wrapped, though it 41 | will still be signaled with `error'." 42 | (make-wrapped-error-instance 43 | :value (ctypecase condition 44 | (symbol (make-condition condition)) 45 | (condition condition)))) 46 | 47 | (defun unwrap-result (result) 48 | "In `receive-result', this is called on the stored task result. The 49 | user receives the return value of this function." 50 | (declare #.*full-optimize*) 51 | (typecase result 52 | (wrapped-error 53 | ;; A `wrapped-error' signals an error upon being unwrapped. 54 | (error (wrapped-error-value result))) 55 | (otherwise 56 | ;; Most objects unwrap to themselves. 57 | result))) 58 | 59 | (defmacro task-handler-bind (clauses &body body) 60 | "Like `handler-bind' but handles conditions signaled inside tasks 61 | that were created in `body'." 62 | (let ((forms (loop for clause in clauses 63 | for (name fn . more) = clause 64 | do (unless (and name (symbolp name) fn (not more)) 65 | (error "Ill-formed binding in `task-handler-bind': ~a" 66 | clause)) 67 | collect `(cons ',name ,fn)))) 68 | `(let ((*client-handlers* (list* ,@forms *client-handlers*))) 69 | ,@body))) 70 | 71 | (defun invoke-transfer-error (error) 72 | "Equivalent to (invoke-restart 'transfer-error error). 73 | 74 | This is a convenience function for use in `task-handler-bind'." 75 | (invoke-restart 'transfer-error error)) 76 | 77 | (defun condition-handler (condition) 78 | "Mimic the CL handling mechanism, calling handlers until one assumes 79 | control (or not)." 80 | (loop for ((condition-type . handler) . rest) on *client-handlers* 81 | do (when (typep condition condition-type) 82 | (let ((*client-handlers* rest)) 83 | (handler-bind ((condition #'condition-handler)) 84 | (funcall handler condition))))) 85 | (when (and (typep condition 'error) 86 | (not *debug-tasks-p*)) 87 | (invoke-transfer-error condition))) 88 | 89 | (defun call-with-tracked-error (condition body-fn) 90 | (unwind-protect/ext 91 | :prepare (when *worker* 92 | (with-lock-held (*erroring-workers-lock*) 93 | (push *worker* *erroring-workers*))) 94 | :main (let ((*debugger-error* condition)) 95 | (funcall body-fn)) 96 | :cleanup (when *worker* 97 | (with-lock-held (*erroring-workers-lock*) 98 | (setf *erroring-workers* 99 | (delete *worker* *erroring-workers*)))))) 100 | 101 | (defmacro with-tracked-error (condition &body body) 102 | `(call-with-tracked-error ,condition (lambda () ,@body))) 103 | 104 | (defun make-debugger-hook () 105 | "Record `*debugger-error*' for the `transfer-error' restart." 106 | (if *debugger-hook* 107 | (let ((previous-hook *debugger-hook*)) 108 | (lambda (condition self) 109 | (with-tracked-error condition 110 | (funcall previous-hook condition self)))) 111 | (lambda (condition self) 112 | (declare (ignore self)) 113 | (with-tracked-error condition 114 | (invoke-debugger condition))))) 115 | 116 | (defun transfer-error-report (stream) 117 | (format stream "Transfer this error to a dependent thread, if one exists.")) 118 | 119 | (defconstant +current-task+ 'current-task) 120 | 121 | (defun transfer-error-restart (&optional (err *debugger-error*)) 122 | (when err 123 | (throw +current-task+ (wrap-error err)))) 124 | 125 | #-lparallel.without-task-handling 126 | (progn 127 | (defmacro with-task-context (&body body) 128 | `(catch +current-task+ 129 | ,@body)) 130 | 131 | (defun %call-with-task-handler (fn) 132 | (declare #.*full-optimize*) 133 | (declare (type function fn)) 134 | (let ((*handler-active-p* t) 135 | (*debugger-hook* (make-debugger-hook))) 136 | (handler-bind ((condition #'condition-handler)) 137 | (restart-bind ((transfer-error #'transfer-error-restart 138 | :report-function #'transfer-error-report)) 139 | (funcall fn))))) 140 | 141 | (defun call-with-task-handler (fn) 142 | (declare #.*full-optimize*) 143 | (declare (type function fn)) 144 | (with-task-context 145 | (if *handler-active-p* 146 | (funcall fn) 147 | (%call-with-task-handler fn))))) 148 | 149 | #+lparallel.without-task-handling 150 | (progn 151 | (defmacro with-task-context (&body body) `(progn ,@body)) 152 | (alias-function %call-with-task-handler funcall) 153 | (alias-function call-with-task-handler funcall)) 154 | 155 | (define-condition task-killed-error (error) () 156 | (:report 157 | "The task was killed.") 158 | (:documentation 159 | "Error signaled when attempting to obtain the result of a killed task.")) 160 | 161 | (define-condition no-kernel-error (error) () 162 | (:report 163 | "Welcome to lparallel. To get started, you need to create some worker 164 | threads. Choose the MAKE-KERNEL restart to create them now. 165 | 166 | Worker threads are asleep when not in use. They are typically created 167 | once per Lisp session. 168 | 169 | Adding the following line to your startup code will prevent this 170 | message from appearing in the future (N is the number of workers): 171 | 172 | (setf lparallel:*kernel* (lparallel:make-kernel N)) 173 | ") 174 | (:documentation 175 | "Error signaled when `*kernel*' is nil.")) 176 | 177 | (define-condition kernel-creation-error (error) () 178 | (:report 179 | "Failed to create a kernel.") 180 | (:documentation 181 | "Error signaled when `make-kernel' fails.")) 182 | -------------------------------------------------------------------------------- /src/kernel/kill.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.kernel) 32 | 33 | (defconstant +worker-suicide-tag+ 'worker-suicide-tag) 34 | 35 | (defun kill (kernel category) 36 | (assert kernel) 37 | (let ((kill-count 0)) 38 | (with-kernel-slots (workers-lock workers) kernel 39 | (with-lock-held (workers-lock) 40 | (dosequence (worker workers) 41 | (when (and (not (eq (thread worker) (current-thread))) 42 | (eql category (running-category worker))) 43 | (destroy-thread (thread worker)) 44 | (incf kill-count))) 45 | (when *worker* 46 | (assert (eq (thread *worker*) (current-thread))) 47 | (when (eql category (running-category *worker*)) 48 | (throw +worker-suicide-tag+ nil))))) 49 | kill-count)) 50 | 51 | (defun kill-errors () 52 | (let ((suicide nil)) 53 | (with-lock-held (*erroring-workers-lock*) 54 | (dolist (worker *erroring-workers*) 55 | (if (and *worker* (eq worker *worker*)) 56 | (setf suicide t) 57 | ;; user could possibly (though unlikely) destroy the 58 | ;; thread simultaneously, so ignore double-destroy error 59 | (ignore-errors (destroy-thread (thread worker))))) 60 | (when suicide 61 | (assert (eq (thread *worker*) (current-thread))) 62 | (throw +worker-suicide-tag+ nil))))) 63 | 64 | (defun kill-errors-report (stream) 65 | (format stream "Kill errors in workers (remove debugger instances).")) 66 | 67 | (defmacro with-worker-restarts (&body body) 68 | `(catch +worker-suicide-tag+ 69 | (restart-bind ((kill-errors #'kill-errors 70 | :report-function #'kill-errors-report)) 71 | ,@body))) 72 | 73 | (defun kill-tasks (task-category &key dry-run) 74 | "This is an expensive function which should only be used in 75 | exceptional circumstances. 76 | 77 | Every task has an associated task category. When a task is submitted, 78 | it is assigned the category of `*task-category*' which has a default 79 | value of `:default'. 80 | 81 | `kill-tasks' interrupts running tasks whose category is `eql' to 82 | `task-category'. The corresponding worker threads are killed and 83 | replaced. Pending tasks are not affected. 84 | 85 | If you don't know what to pass for `task-category' then you should 86 | probably pass `:default', though this may kill more tasks than you 87 | wish. Binding `*task-category*' around `submit-task' enables targeted 88 | task killing. 89 | 90 | If `dry-run' is nil, the function returns the number of tasks killed. 91 | 92 | If `dry-run' is non-nil then no tasks are killed. In this case the 93 | return value is the number of tasks that would have been killed if 94 | `dry-run' were nil. 95 | 96 | `kill-tasks' is not available in ABCL." 97 | (let ((kernel *kernel*)) 98 | (when kernel 99 | (unless task-category 100 | (error "Task category cannot be nil in `kill-tasks'.")) 101 | (if dry-run 102 | (count task-category (workers kernel) :key #'running-category) 103 | (kill kernel task-category))))) 104 | -------------------------------------------------------------------------------- /src/kernel/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defpackage #:lparallel.kernel 32 | (:documentation 33 | "Encompasses the scheduling and execution of parallel tasks using a 34 | pool of worker threads. All parallelism in lparallel is done on top 35 | of the kernel.") 36 | (:use #:cl 37 | #:lparallel.util 38 | #:lparallel.thread-util 39 | #:lparallel.queue 40 | #-lparallel.with-stealing-scheduler #:lparallel.biased-queue 41 | #+lparallel.with-stealing-scheduler #:lparallel.counter 42 | #+lparallel.with-stealing-scheduler #:lparallel.spin-queue) 43 | (:export #:make-kernel 44 | #:check-kernel 45 | #:end-kernel 46 | #:kernel-worker-count 47 | #:kernel-worker-index 48 | #:kernel-bindings 49 | #:kernel-name 50 | #:kernel-context) 51 | (:export #:make-channel 52 | #:submit-task 53 | #:broadcast-task 54 | #:submit-timeout 55 | #:cancel-timeout 56 | #:receive-result 57 | #:try-receive-result 58 | #:do-fast-receives 59 | #:kill-tasks 60 | #:task-handler-bind 61 | #:task-categories-running 62 | #:invoke-transfer-error) 63 | (:export #:*kernel* 64 | #:*kernel-spin-count* 65 | #:*task-category* 66 | #:*task-priority* 67 | #:*debug-tasks-p*) 68 | (:export #:kernel 69 | #:channel 70 | #:transfer-error 71 | #:no-kernel-error 72 | #:kernel-creation-error 73 | #:task-killed-error) 74 | (:import-from #:alexandria 75 | #:simple-style-warning)) 76 | 77 | (in-package #:lparallel.kernel) 78 | -------------------------------------------------------------------------------- /src/kernel/specials.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.kernel) 32 | 33 | (defvar *debugger-error* nil 34 | "Track the error inside the debugger for the `transfer-error' restart.") 35 | 36 | (defvar *handler-active-p* nil 37 | "Non-nil when handlers have been established via `call-with-task-handler'.") 38 | 39 | (defvar *client-handlers* nil 40 | "Records handlers established with `task-handler-bind' in the 41 | calling thread.") 42 | 43 | (defvar *task-category* :default 44 | "See `kill-tasks'. Default value is `:default'.") 45 | 46 | (defvar *task-priority* :default 47 | "When bound to `:low', the kernel schedules submitted tasks at low 48 | priority. Default value is `:default'.") 49 | 50 | (defvar *worker* nil 51 | "The worker instance if inside a worker thread, otherwise nil.") 52 | 53 | (defvar *kernel* nil 54 | "The current kernel, or nil.") 55 | 56 | ;;; This is set by the only limiter client, defpun.lisp. 57 | (defvar *make-limiter-data*) 58 | 59 | ;;; On a Core-i7 3.4GHz, a single spin takes about 2.5 microseconds. 60 | (defvar *kernel-spin-count* 2000 61 | "Default value of the `spin-count' argument to `make-kernel'.") 62 | 63 | (defvar *debug-tasks-p* t 64 | "If true (the default), the debugger is invoked when an error goes 65 | unhandled inside a task, i.e. when the handlers established by 66 | `task-handler-bind' (if any) do not handle it. 67 | 68 | If false, unhandled errors from tasks are automatically transferred 69 | to their parent thread (and/or any dependent threads) via the 70 | `transfer-error' restart. This is for convenience -- sometimes you 71 | wish to avoid N debugger popups arising from N errors in N worker 72 | threads. 73 | 74 | For local control over debugger invocation, bind a task handler: 75 | 76 | (task-handler-bind ((error #'invoke-debugger)) ...) 77 | 78 | (task-handler-bind ((error #'invoke-transfer-error)) ...)") 79 | 80 | (defvar *lisp-exiting-p* nil 81 | "True if the Lisp process is exiting; for skipping auto-replacement 82 | of killed workers during exit.") 83 | 84 | (defvar *erroring-workers* nil 85 | "Track debugger popups in order to kill them.") 86 | 87 | (defvar *erroring-workers-lock* (make-lock) 88 | "Lock for *erroring-workers*.") 89 | -------------------------------------------------------------------------------- /src/kernel/stealing-scheduler.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.kernel) 32 | 33 | ;;;; util 34 | 35 | (defmacro define-mod-inc-dec (name op op-result-type) 36 | `(defmacro ,name (k n) 37 | `(the index (mod (the ,',op-result-type (,',op (the index ,k))) 38 | (the index ,n))))) 39 | 40 | (define-mod-inc-dec mod-inc 1+ index) 41 | (define-mod-inc-dec mod-dec 1- fixnum) 42 | 43 | (defmacro define-mod-incf-decf (name op) 44 | `(defmacro ,name (place n) 45 | `(the index (setf ,place (,',op ,place ,n))))) 46 | 47 | (define-mod-incf-decf mod-incf mod-inc) 48 | (define-mod-incf-decf mod-decf mod-dec) 49 | 50 | (defmacro with-pop-success (var queue &body body) 51 | (with-gensyms (presentp) 52 | `(multiple-value-bind (,var ,presentp) (pop-spin-queue ,queue) 53 | (when ,presentp 54 | ,@body)))) 55 | 56 | (defmacro repeat/fixnum (count &body body) 57 | (with-gensyms (left) 58 | `(let ((,left (the fixnum ,count))) 59 | (declare (type fixnum ,left)) 60 | (loop 61 | (when (zerop ,left) 62 | (return (values))) 63 | (decf ,left) 64 | ,@body)))) 65 | 66 | (defmacro do-indexes ((index-var size home-index from-home-index-p) &body body) 67 | ;; size is positive 68 | (with-gensyms (size-var home-index-var) 69 | `(let ((,index-var (the index ,home-index)) 70 | (,size-var (the index ,size)) 71 | (,home-index-var (the index ,home-index))) 72 | (declare (type index ,index-var ,size-var ,home-index-var)) 73 | (loop 74 | ,(let ((next `(mod-incf ,index-var ,size-var))) 75 | (if from-home-index-p 76 | `(progn ,@body ,next) 77 | `(progn ,next ,@body))) 78 | (when (= ,index-var ,home-index-var) 79 | (return (values))))))) 80 | 81 | ;;;; scheduler 82 | 83 | (defun make-scheduler (workers spin-count) 84 | (make-scheduler-instance :workers workers :spin-count spin-count)) 85 | 86 | (defun/type/inline push-to-random-worker (task scheduler) 87 | (task scheduler) (values) 88 | ;; Decrease random-index without caring about simultaneous changes. 89 | ;; The actual value of random-index does not matter as long as it 90 | ;; remains somewhat well-distributed. 91 | (declare #.*full-optimize*) 92 | (with-scheduler-slots (workers random-index) scheduler 93 | (push-spin-queue 94 | task (tasks (svref workers (mod-decf random-index (length workers)))))) 95 | (values)) 96 | 97 | (defun/type maybe-wake-a-worker (scheduler) (scheduler) (values) 98 | (declare #.*full-optimize*) 99 | (with-scheduler-slots (wait-lock wait-cvar wait-count notify-count) scheduler 100 | (with-lock-predicate/wait wait-lock (plusp (counter-value wait-count)) 101 | (incf notify-count) 102 | (condition-notify wait-cvar))) 103 | (values)) 104 | 105 | (defun/type schedule-task (scheduler task priority) 106 | (scheduler (or task null) t) (values) 107 | (declare #.*full-optimize*) 108 | (ccase priority 109 | (:low (with-scheduler-slots (low-priority-tasks) scheduler 110 | (push-spin-queue task low-priority-tasks))) 111 | (:default (push-to-random-worker task scheduler))) 112 | (maybe-wake-a-worker scheduler) 113 | (values)) 114 | 115 | (defmacro do-workers ((worker-var workers home-index from-home-index-p) 116 | &body body) 117 | (with-gensyms (workers-var index-var) 118 | `(let ((,workers-var ,workers)) 119 | (declare (type simple-vector ,workers-var)) 120 | (do-indexes (,index-var 121 | (length (the simple-vector ,workers-var)) 122 | ,home-index 123 | ,from-home-index-p) 124 | (let ((,worker-var (svref (the simple-vector ,workers-var) 125 | ,index-var))) 126 | (declare (type worker ,worker-var)) 127 | ,@body))))) 128 | 129 | (defun/type next-task (scheduler worker) (scheduler worker) (or task null) 130 | (declare #.*full-optimize*) 131 | (labels ((try-pop (queue) 132 | (declare (type spin-queue queue)) 133 | (with-pop-success task queue 134 | (return-from next-task task)) 135 | (values)) 136 | (try-pop-all () 137 | (with-scheduler-slots (workers) scheduler 138 | (do-workers (worker workers (worker-index worker) nil) 139 | (try-pop (tasks worker)))) 140 | (values)) 141 | (maybe-sleep () 142 | (with-scheduler-slots (wait-cvar wait-lock wait-count 143 | notify-count low-priority-tasks) scheduler 144 | (unwind-protect/ext 145 | :prepare (inc-counter wait-count) 146 | :main (with-lock-held (wait-lock) 147 | (try-pop (tasks worker)) 148 | (try-pop low-priority-tasks) 149 | (loop until (plusp notify-count) 150 | do (condition-wait wait-cvar wait-lock) 151 | finally (decf notify-count))) 152 | :cleanup (dec-counter wait-count))) 153 | (values))) 154 | (declare (dynamic-extent #'try-pop #'try-pop-all #'maybe-sleep)) 155 | (with-scheduler-slots (spin-count) scheduler 156 | (loop 157 | (try-pop (tasks worker)) 158 | (try-pop-all) 159 | (repeat/fixnum spin-count 160 | (try-pop-all)) 161 | (maybe-sleep))))) 162 | 163 | (defun/type steal-task (scheduler) (scheduler) (or task null) 164 | (declare #.*full-optimize*) 165 | (with-scheduler-slots (workers random-index low-priority-tasks) scheduler 166 | (let ((low-priority-tasks low-priority-tasks)) 167 | (flet ((try-pop (tasks) 168 | (declare (type spin-queue tasks low-priority-tasks)) 169 | (with-pop-success task tasks 170 | (when task 171 | (return-from steal-task task)) 172 | ;; don't steal nil, the end condition flag 173 | (push-spin-queue task low-priority-tasks)) 174 | (values))) 175 | (declare (dynamic-extent #'try-pop)) 176 | ;; Start with the worker that has the most recently submitted 177 | ;; task (approximately) and advance rightward. 178 | (do-workers (worker workers random-index t) 179 | (try-pop (tasks worker))) 180 | (try-pop low-priority-tasks)))) 181 | nil) 182 | -------------------------------------------------------------------------------- /src/kernel/timeout.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.kernel) 32 | 33 | (defslots timeout () 34 | ((canceled-result) 35 | (thread) 36 | (lock :initform (make-lock)))) 37 | 38 | (defun submit-timeout (channel timeout-seconds timeout-result) 39 | "Effectively equivalent to 40 | 41 | (submit-task channel (lambda () (sleep timeout-seconds) timeout-result)) 42 | 43 | The difference is that `submit-timeout' does not occupy a worker 44 | thread. 45 | 46 | A timeout object is returned, which may be passed to `cancel-timeout'. 47 | 48 | `submit-timeout' and `cancel-timeout' are deprecated; use the new 49 | `:timeout' option in `try-receive-result'." 50 | (let ((timeout (make-timeout-instance 51 | :canceled-result 'not-canceled :thread nil)) 52 | (pushedp nil)) 53 | (with-channel-slots (queue) channel 54 | (with-timeout-slots (canceled-result thread lock) timeout 55 | (macrolet ((push-result (form) 56 | ;; Ensure that only one result is pushed. 57 | ;; 58 | ;; We must check the canceled result inside the 59 | ;; lock, so delay evaluation via macrolet. 60 | `(with-lock-predicate/wait lock (not pushedp) 61 | (push-queue ,form queue) 62 | (setf pushedp t)))) 63 | (setf thread (with-thread (:name "lparallel-timeout") 64 | (unwind-protect/ext 65 | :main (sleep timeout-seconds) 66 | :abort (push-result 67 | (if (eq canceled-result 'not-canceled) 68 | (wrap-error 'task-killed-error) 69 | canceled-result))) 70 | (push-result timeout-result)))))) 71 | timeout)) 72 | 73 | #-lparallel.without-kill 74 | (defun cancel-timeout (timeout timeout-result) 75 | "Attempt to cancel a timeout. If successful, the channel passed to 76 | `submit-timeout' will receive `timeout-result'. 77 | 78 | At most one call to `cancel-timeout' will succeed; others will be 79 | ignored. If the timeout has expired on its own then `cancel-timeout' 80 | will have no effect. 81 | 82 | `cancel-timeout' is not available in ABCL. 83 | 84 | `submit-timeout' and `cancel-timeout' are deprecated; use the new 85 | `:timeout' option in `try-receive-result'." 86 | (with-timeout-slots (canceled-result thread lock) timeout 87 | ;; ensure that only one cancel succeeds 88 | (with-lock-predicate/wait lock (eq canceled-result 'not-canceled) 89 | (setf canceled-result timeout-result) 90 | (destroy-thread thread))) 91 | nil) 92 | 93 | (defun deprecated-timeout () 94 | (simple-style-warning 95 | "`submit-timeout' and `cancel-timeout' are deprecated; use the new~%~ 96 | `:timeout' option in `try-receive-result'.")) 97 | 98 | (define-compiler-macro submit-timeout (&whole whole &rest args) 99 | (declare (ignore args)) 100 | (deprecated-timeout) 101 | whole) 102 | 103 | (define-compiler-macro cancel-timeout (&whole whole &rest args) 104 | (declare (ignore args)) 105 | (deprecated-timeout) 106 | whole) 107 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.kernel) 32 | 33 | (macrolet 34 | ((package (package-name documentation &rest list) 35 | `(defpackage ,package-name 36 | (:documentation ,documentation) 37 | (:use #:cl ,@list) 38 | (:export 39 | ,@(loop for package in list 40 | append (loop for symbol being the external-symbols in package 41 | collect (make-symbol (string symbol)))))))) 42 | (package #:lparallel 43 | "This is a convenience package which exports the external symbols of: 44 | lparallel.kernel 45 | lparallel.promise 46 | lparallel.defpun 47 | lparallel.cognate 48 | lparallel.ptree" 49 | #:lparallel.kernel 50 | #:lparallel.promise 51 | #:lparallel.defpun 52 | #:lparallel.cognate 53 | #:lparallel.ptree)) 54 | -------------------------------------------------------------------------------- /src/raw-queue.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | ;;; 32 | ;;; raw-queue -- raw data structure 33 | ;;; 34 | 35 | (defpackage #:lparallel.raw-queue 36 | (:documentation 37 | "(private) Raw queue data structure.") 38 | (:use #:cl 39 | #:lparallel.util) 40 | (:export #:raw-queue 41 | #:make-raw-queue 42 | #:push-raw-queue 43 | #:pop-raw-queue 44 | #:peek-raw-queue 45 | #:raw-queue-count 46 | #:raw-queue-empty-p)) 47 | 48 | (in-package #:lparallel.raw-queue) 49 | 50 | (deftype raw-queue-count () '(integer 0)) 51 | 52 | (locally (declare #.*full-optimize*) 53 | (defstruct (raw-queue (:conc-name nil) 54 | (:constructor %make-raw-queue (head tail))) 55 | (head (error "no head") :type list) 56 | (tail (error "no tail") :type list))) 57 | 58 | (defun/inline make-raw-queue (&optional initial-capacity) 59 | (declare (ignore initial-capacity)) 60 | (%make-raw-queue nil nil)) 61 | 62 | (defun/type push-raw-queue (value queue) (t raw-queue) t 63 | (declare #.*full-optimize*) 64 | (let ((new (cons value nil))) 65 | (if (head queue) 66 | (setf (cdr (tail queue)) new) 67 | (setf (head queue) new)) 68 | (setf (tail queue) new))) 69 | 70 | (defun/type pop-raw-queue (queue) (raw-queue) (values t boolean) 71 | (declare #.*full-optimize*) 72 | (let ((node (head queue))) 73 | (if node 74 | (multiple-value-prog1 (values (car node) t) 75 | (when (null (setf (head queue) (cdr node))) 76 | (setf (tail queue) nil)) 77 | ;; clear node for conservative gcs 78 | (setf (car node) nil 79 | (cdr node) nil)) 80 | (values nil nil)))) 81 | 82 | (defun/inline raw-queue-count (queue) (length (the list (head queue)))) 83 | (defun/inline raw-queue-empty-p (queue) (not (head queue))) 84 | (defun/inline peek-raw-queue (queue) (let ((node (head queue))) 85 | (values (car node) 86 | (if node t nil)))) 87 | -------------------------------------------------------------------------------- /src/slet.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defpackage #:lparallel.slet 32 | (:documentation "(private) Serial let.") 33 | (:use #:cl 34 | #:lparallel.util) 35 | (:export #:slet) 36 | (:import-from #:alexandria 37 | #:ensure-list)) 38 | 39 | (in-package #:lparallel.slet) 40 | 41 | (defun parse-bindings (bindings) 42 | (let ((mv-bindings nil) 43 | (null-bindings nil)) 44 | (dolist (binding bindings) 45 | (etypecase binding 46 | (cons (if (= 1 (length binding)) 47 | (dolist (var (ensure-list (first binding))) 48 | (push var null-bindings)) 49 | (destructuring-bind (var-or-vars form) binding 50 | (push `(,(ensure-list var-or-vars) ,form) 51 | mv-bindings)))) 52 | (symbol (push binding null-bindings)))) 53 | (values (reverse mv-bindings) 54 | (reverse null-bindings)))) 55 | 56 | ;;; To ensure that `slet' is interchangeable with `plet', use 57 | ;;; temporaries to avoid `let*'-like behavior. 58 | 59 | (defun make-temp-var (var) 60 | (gensym (symbol-name var))) 61 | 62 | (defun make-binding-datum (mv-binding) 63 | (destructuring-bind (vars form) mv-binding 64 | `(,vars ,(mapcar #'make-temp-var vars) ,form))) 65 | 66 | (defun make-binding-data (bindings) 67 | (multiple-value-bind (mv-bindings null-bindings) (parse-bindings bindings) 68 | (values (mapcar #'make-binding-datum mv-bindings) 69 | null-bindings))) 70 | 71 | (defmacro bind ((vars form) &body body) 72 | (if (= 1 (length vars)) 73 | `(let ((,(first vars) ,form)) 74 | ,@body) 75 | `(multiple-value-bind ,vars ,form 76 | ,@body))) 77 | 78 | (defmacro %slet (binding-data full-binding-data null-bindings body) 79 | (if binding-data 80 | (destructuring-bind 81 | ((vars temp-vars form) &rest more-binding-data) binding-data 82 | (declare (ignore vars)) 83 | `(bind (,temp-vars ,form) 84 | (%slet ,more-binding-data ,full-binding-data ,null-bindings ,body))) 85 | `(let (,@null-bindings 86 | ,@(loop for (vars temp-vars nil) in full-binding-data 87 | append (mapcar #'list vars temp-vars))) 88 | ,@body))) 89 | 90 | (defmacro slet (bindings &body body) 91 | "`slet' (serial let) is the non-parallel counterpart to `plet'. 92 | 93 | The syntax of `slet' matches that of `plet', which includes the 94 | ability to bind multiple values." 95 | (multiple-value-bind (binding-data null-bindings) (make-binding-data bindings) 96 | `(%slet ,binding-data ,binding-data ,null-bindings ,body))) 97 | -------------------------------------------------------------------------------- /src/spin-queue/cas-spin-queue.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | ;;; Singly-linked queue with compare-and-swap operations. 32 | ;;; 33 | ;;; The following invariants hold except during updates: 34 | ;;; 35 | ;;; (node-car (spin-queue-head queue)) == +dummy+ 36 | ;;; 37 | ;;; (node-cdr (spin-queue-tail queue)) == nil 38 | ;;; 39 | ;;; If the queue is empty, (spin-queue-head queue) == (queue-tail queue). 40 | ;;; 41 | ;;; If the queue is non-empty, 42 | ;;; (node-car (node-cdr (spin-queue-head queue))) is the next value 43 | ;;; to be dequeued and (node-car (spin-queue-tail queue)) is the 44 | ;;; most recently enqueued value. 45 | ;;; 46 | ;;; The CDR of a discarded node is set to +DEAD-END+. This flag must 47 | ;;; be checked at each traversal. 48 | 49 | (in-package #:lparallel.spin-queue) 50 | 51 | ;;;; node 52 | 53 | #+(or sbcl lispworks) 54 | (progn 55 | (deftype node () 'cons) 56 | (alias-function make-node cons) 57 | (defmacro node-car (node) `(car ,node)) 58 | (defmacro node-cdr (node) `(cdr ,node))) 59 | 60 | ;;; CCL cannot compare-and-swap on a cons. Slots for defstruct must be 61 | ;;; untyped for ccl::conditional-store. 62 | #+ccl 63 | (progn 64 | (declaim (inline make-node)) 65 | (defstruct (node (:constructor make-node (car cdr))) 66 | (car (error "no car")) 67 | (cdr (error "no cdr")))) 68 | 69 | ;;;; spin-queue 70 | 71 | (defconstant +dummy+ 'dummy) 72 | (defconstant +dead-end+ 'dead-end) 73 | 74 | (defstruct (spin-queue (:constructor %make-spin-queue (head tail))) 75 | (head (error "no head") #-ccl :type #-ccl node) 76 | (tail (error "no tail") #-ccl :type #-ccl node)) 77 | 78 | (defun make-spin-queue () 79 | (let ((dummy (make-node +dummy+ nil))) 80 | (%make-spin-queue dummy dummy))) 81 | 82 | (defun/type push-spin-queue (value queue) (t spin-queue) (values) 83 | ;; Attempt CAS, repeat upon failure. Upon success update QUEUE-TAIL. 84 | (declare #.*full-optimize*) 85 | (let ((new (make-node value nil))) 86 | (loop (when (cas (node-cdr (spin-queue-tail queue)) nil new) 87 | (setf (spin-queue-tail queue) new) 88 | (return (values)))))) 89 | 90 | (defun/type pop-spin-queue (queue) (spin-queue) (values t boolean) 91 | ;; Attempt to CAS QUEUE-HEAD with the next node, repeat upon 92 | ;; failure. Upon success, clear the discarded node and set the CAR 93 | ;; of QUEUE-HEAD to +DUMMY+. 94 | (declare #.*full-optimize*) 95 | (loop (let* ((head (spin-queue-head queue)) 96 | (next (node-cdr head))) 97 | ;; NEXT could be +DEAD-END+, whereupon we try again. 98 | (typecase next 99 | (null (return (values nil nil))) 100 | (node (when (cas (spin-queue-head queue) head next) 101 | (let ((value (node-car next))) 102 | (setf (node-cdr head) +dead-end+ 103 | (node-car next) +dummy+) 104 | (return (values value t))))))))) 105 | 106 | (defun spin-queue-empty-p (queue) 107 | (null (node-cdr (spin-queue-head queue)))) 108 | 109 | (defun try-each-elem (fun queue) 110 | (let ((node (spin-queue-head queue))) 111 | (loop 112 | (let ((value (node-car node))) 113 | (unless (eq value +dummy+) 114 | (funcall fun value))) 115 | (setf node (node-cdr node)) 116 | (cond ((eq node +dead-end+) 117 | (return nil)) 118 | ((null node) 119 | (return t)))))) 120 | 121 | (defun spin-queue-count (queue) 122 | (tagbody 123 | :retry 124 | (let ((count 0)) 125 | (unless (try-each-elem (lambda (elem) 126 | (declare (ignore elem)) 127 | (incf count)) 128 | queue) 129 | (go :retry)) 130 | (return-from spin-queue-count count)))) 131 | 132 | (defun peek-spin-queue (queue) 133 | (loop until (try-each-elem (lambda (elem) 134 | (return-from peek-spin-queue (values elem t))) 135 | queue)) 136 | (values nil nil)) 137 | -------------------------------------------------------------------------------- /src/spin-queue/default-spin-queue.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.spin-queue) 32 | 33 | (deftype spin-queue () 'lparallel.queue:queue) 34 | 35 | (alias-function make-spin-queue lparallel.queue:make-queue) 36 | (alias-function push-spin-queue lparallel.queue:push-queue) 37 | (alias-function pop-spin-queue lparallel.queue:try-pop-queue) 38 | (alias-function peek-spin-queue lparallel.queue:peek-queue) 39 | (alias-function spin-queue-count lparallel.queue:queue-count) 40 | (alias-function spin-queue-empty-p lparallel.queue:queue-empty-p) 41 | -------------------------------------------------------------------------------- /src/spin-queue/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defpackage #:lparallel.spin-queue 32 | (:documentation 33 | "(private) Thread-safe FIFO queue which spins instead of locks.") 34 | (:use #:cl 35 | #:lparallel.util 36 | #:lparallel.thread-util) 37 | (:export #:spin-queue 38 | #:make-spin-queue 39 | #:push-spin-queue 40 | #:pop-spin-queue 41 | #:peek-spin-queue 42 | #:spin-queue-count 43 | #:spin-queue-empty-p)) 44 | 45 | (in-package #:lparallel.spin-queue) 46 | -------------------------------------------------------------------------------- /src/util/config.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.util) 32 | 33 | #-lparallel.with-debug 34 | (progn 35 | (defvar *normal-optimize* 36 | '(optimize 37 | (speed 3) 38 | (safety 1) 39 | (debug 1) 40 | (compilation-speed 0))) 41 | 42 | (defvar *full-optimize* 43 | '(optimize 44 | (speed 3) 45 | (safety 0) 46 | (debug 0) 47 | (compilation-speed 0)))) 48 | 49 | #+lparallel.with-debug 50 | (progn 51 | (defvar *normal-optimize* 52 | '(optimize 53 | (speed 0) 54 | (safety 3) 55 | (debug 3) 56 | (space 0) 57 | (compilation-speed 0))) 58 | 59 | (defvar *full-optimize* 60 | '(optimize 61 | (speed 0) 62 | (safety 3) 63 | (debug 3) 64 | (space 0) 65 | (compilation-speed 0)))) 66 | -------------------------------------------------------------------------------- /src/util/defmacro.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.util) 32 | 33 | (defmacro defmacro/once (name params &body body) 34 | "Like `defmacro' except that params which are immediately preceded 35 | by `&once' are passed to a `once-only' call which surrounds `body'." 36 | (labels ((once-keyword-p (obj) 37 | (and (symbolp obj) (equalp (symbol-name obj) "&once"))) 38 | (remove-once-keywords (params) 39 | (mapcar (lambda (x) (if (consp x) (remove-once-keywords x) x)) 40 | (remove-if #'once-keyword-p params))) 41 | (grab-once-param (list) 42 | (let ((target (first list))) 43 | (when (or (null list) 44 | (consp target) 45 | (find target lambda-list-keywords) 46 | (once-keyword-p target)) 47 | (error "`&once' without parameter in ~a" name)) 48 | target)) 49 | (find-once-params (params) 50 | (mapcon (lambda (cell) 51 | (destructuring-bind (elem &rest rest) cell 52 | (cond ((consp elem) 53 | (find-once-params elem)) 54 | ((once-keyword-p elem) 55 | (list (grab-once-param rest))) 56 | (t 57 | nil)))) 58 | params))) 59 | (with-parsed-body (body declares docstring) 60 | `(defmacro ,name ,(remove-once-keywords params) 61 | ,@(unsplice docstring) 62 | ,@declares 63 | (once-only ,(find-once-params params) 64 | ,@body))))) 65 | -------------------------------------------------------------------------------- /src/util/defpair.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.util) 32 | 33 | (defmacro defpair (name supers (a b) &optional doc) 34 | "Define a cons type using defclass syntax. 35 | 36 | Exactly two slots and zero superclasses must be given. 37 | 38 | Available slot options are: `:initform', `:type', `:reader'. 39 | 40 | A deftype for `name' is defined. 41 | 42 | `(defpair foo ...)' defines the function `make-foo-instance' which 43 | takes keyword arguments corresponding to slots of the same name. 44 | 45 | All slots must be initialized when an instance is created, else an 46 | error will be signaled." 47 | (unless (null supers) 48 | (error "Non-empty superclass list ~a in DEFPAIR ~a" supers name)) 49 | (when doc 50 | (unless (and (consp doc) (eq :documentation (car doc))) 51 | (error "Expected `:documentation' option in DEFPAIR, got ~a" doc))) 52 | (setf a (ensure-list a)) 53 | (setf b (ensure-list b)) 54 | (labels ((slot-name (slot) (car slot)) 55 | (slot-props (slot) (cdr slot)) 56 | (slot-type (slot) (or (getf (slot-props slot) :type) t))) 57 | (when (eq (slot-name a) (slot-name b)) 58 | (error "Multiple slots named ~a in DEFPAIR ~a" (slot-name a) name)) 59 | (dolist (slot (list a b)) 60 | (unless (slot-name slot) 61 | (error "empty slot in ~a" name)) 62 | (when (slot-props slot) 63 | (let ((diff (set-difference (plist-keys (slot-props slot)) 64 | '(:initform :type :reader)))) 65 | (unless (null diff) 66 | (error "Invalid slot option~p in DEFPAIR: ~{~a^ ~}" 67 | (length diff) diff))))) 68 | `(progn 69 | (deftype ,name () `(cons ,',(slot-type a) 70 | ,',(slot-type b))) 71 | (alias-function ,(symbolicate '#:make- name '#:-instance) cons) 72 | ,@(loop for slot in `(,a ,b) 73 | for fn in '(car cdr) 74 | for readers = (plist-values-for-key (slot-props slot) :reader) 75 | when readers 76 | collect `(progn 77 | ,@(loop for reader in readers 78 | collect `(alias-function ,reader ,fn))))))) 79 | -------------------------------------------------------------------------------- /src/util/defslots.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.util) 32 | 33 | (defun plist-keys (plist) 34 | (loop for x in plist by #'cddr 35 | collect x)) 36 | 37 | (defun plist-values-for-key (plist target-key) 38 | (loop for (key value) on plist by #'cddr 39 | when (eq key target-key) 40 | collect value)) 41 | 42 | (defun parse-defslots (supers slots options) 43 | (unless (<= (length supers) 1) 44 | (error "More than one superclass specified in DEFSLOTS: ~s" supers)) 45 | (unless (<= (length options) 1) 46 | (error "Too many options in DEFSLOTS: ~{~s ~}" options)) 47 | (unless (or (null options) 48 | (eq (caar options) :documentation)) 49 | (error "Option ~s in DEFSLOTS is not :DOCUMENTATION" (caar options))) 50 | (loop with allowed = '(:initform :type :reader) 51 | for (nil . plist) in slots 52 | for keys = (plist-keys plist) 53 | do (let ((diff (set-difference keys allowed))) 54 | (unless (null diff) 55 | (error "Slot option ~s in DEFSLOTS is not one of ~s" 56 | (first diff) allowed))))) 57 | 58 | (defun defslots-names (name) 59 | (values (symbolicate '#:make- name '#:-instance) 60 | (symbolicate '#:with- name '#:-slots) 61 | (symbolicate/no-intern '#:%%%%. name '#:.) 62 | (make-symbol (package-name *package*)))) 63 | 64 | #-lparallel.with-debug 65 | (progn 66 | (defmacro define-slots-macrolet (package conc-name entries instance 67 | &body body) 68 | `(symbol-macrolet 69 | ,(loop for entry in entries 70 | for (name slot) = (if (consp entry) entry `(,entry ,entry)) 71 | for accessor = (symbolicate/package package conc-name slot) 72 | collect `(,name (,accessor ,instance))) 73 | ,@body)) 74 | 75 | (defmacro define-with-slots-macro (name package conc-name) 76 | `(defmacro/once ,name (slots &once instance &body body) 77 | `(define-slots-macrolet ,',package ,',conc-name ,slots ,instance 78 | ,@body))) 79 | 80 | (defmacro define-struct (name supers slots options conc-name constructor) 81 | `(defstruct (,name (:conc-name ,conc-name) 82 | (:constructor ,constructor) 83 | ,@(unsplice (when supers `(:include ,(first supers))))) 84 | ,@(unsplice (getf (first options) :documentation)) 85 | ,@(loop for (slot-name . plist) in slots 86 | for initform = (getf plist :initform 87 | `(error "slot ~a in ~a not initialized" 88 | ',slot-name ',name)) 89 | for type = (getf plist :type) 90 | collect `(,slot-name ,initform ,@(when type `(:type ,type)))))) 91 | 92 | (defmacro define-reader (public private type struct) 93 | `(progn 94 | (declaim (ftype (function (,struct) (values ,(or type t) &optional)) 95 | ,public)) 96 | (alias-function ,public ,private))) 97 | 98 | (defmacro define-readers (struct conc-name slots) 99 | `(progn 100 | ,@(loop for (slot-name . plist) in slots 101 | for private = (symbolicate conc-name slot-name) 102 | for type = (getf plist :type) 103 | append (loop for public in (plist-values-for-key plist :reader) 104 | collect `(define-reader 105 | ,public ,private ,type ,struct))))) 106 | 107 | (defmacro %defslots (name supers slots options) 108 | (multiple-value-bind (constructor slots-macro-name conc-name package) 109 | (defslots-names name) 110 | `(progn 111 | (define-struct ,name ,supers ,slots ,options ,conc-name ,constructor) 112 | (define-with-slots-macro ,slots-macro-name ,package ,conc-name) 113 | (define-readers ,name ,conc-name ,slots) 114 | ',name)))) 115 | 116 | #+lparallel.with-debug 117 | (defmacro %defslots (name supers slots options) 118 | (multiple-value-bind (constructor slots-macro-name) (defslots-names name) 119 | `(progn 120 | (defclass ,name ,supers 121 | ,(loop for slot in (copy-list slots) 122 | for slot-name = (first slot) 123 | for initarg = (intern (symbol-name slot-name) 'keyword) 124 | collect `(,@slot :initarg ,initarg)) 125 | ,@options) 126 | (defmacro ,slots-macro-name (slot-names instance &body body) 127 | `(with-slots ,slot-names ,instance ,@body)) 128 | (defun ,constructor (&rest args) 129 | (apply #'make-instance ',name args)) 130 | ',name))) 131 | 132 | (defmacro defslots (name supers slots &rest options) 133 | "Define a thing with slots. 134 | 135 | A `defslots' form may expand to either a `defclass' form or a 136 | `defstruct' form. Thou art foolish to depend upon either. 137 | 138 | The syntax of `defslots' matches that of `defclass' with the following 139 | restrictions: at most one superclass is permitted; `:initform', 140 | `:type', and `:reader', are the only slot options allowed; 141 | `:documentation' is the only class option allowed. 142 | 143 | `(defslots foo ...)' defines the functions `make-foo-instance' and 144 | `with-foo-slots' which are like `make-instance' and `with-slots' 145 | respectively. `make-foo-instance' takes keyword arguments 146 | corresponding to slots of the same name. 147 | 148 | All slots must be initialized when an instance is created, else an 149 | error will be signaled." 150 | (setf slots (mapcar #'ensure-list slots)) 151 | (parse-defslots supers slots options) 152 | `(%defslots ,name ,supers ,slots ,options)) 153 | -------------------------------------------------------------------------------- /src/util/defun.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.util) 32 | 33 | (defun constrain-return-type (return-type) 34 | (if (and (consp return-type) 35 | (eq 'values (first return-type))) 36 | (if (intersection return-type lambda-list-keywords) 37 | return-type 38 | (append return-type '(&optional))) 39 | `(values ,return-type &optional))) 40 | 41 | #-lparallel.with-debug 42 | (progn 43 | (defmacro defun/inline (name lambda-list &body body) 44 | "Shortcut for 45 | (declaim (inline foo)) 46 | (defun foo ...)." 47 | `(progn 48 | (declaim (inline ,name)) 49 | (defun ,name ,lambda-list ,@body))) 50 | 51 | (defmacro defun/type (name lambda-list arg-types return-type &body body) 52 | "Shortcut for 53 | (declaim (ftype (function arg-types return-type) foo) 54 | (defun foo ...). 55 | Additionally constrains return-type to the number of values provided." 56 | (setf return-type (constrain-return-type return-type)) 57 | (with-parsed-body (body declares docstring) 58 | `(progn 59 | (declaim (ftype (function ,arg-types ,return-type) ,name)) 60 | (defun ,name ,lambda-list 61 | ,@(unsplice docstring) 62 | ,@declares 63 | ;; for a simple arg list, also declare types 64 | ,@(when (not (intersection lambda-list lambda-list-keywords)) 65 | (loop for type in arg-types 66 | for param in lambda-list 67 | collect `(declare (type ,type ,param)))) 68 | (the ,return-type (progn ,@body)))))) 69 | 70 | (defmacro defun/type/inline (name lambda-list arg-types return-type 71 | &body body) 72 | `(progn 73 | (declaim (inline ,name)) 74 | (defun/type ,name ,lambda-list ,arg-types ,return-type ,@body)))) 75 | 76 | ;;; Since return types are not always checked, check manually. 77 | #+lparallel.with-debug 78 | (progn 79 | (defmacro defun/type (name lambda-list arg-types return-type &body body) 80 | (setf return-type (constrain-return-type return-type)) 81 | (with-parsed-body (body declares docstring) 82 | `(progn 83 | (declaim (ftype (function ,arg-types ,return-type) ,name)) 84 | (defun ,name ,lambda-list 85 | ,@(unsplice docstring) 86 | ,@declares 87 | ;; for a simple arg list, check types 88 | ,@(when (not (intersection lambda-list lambda-list-keywords)) 89 | (loop for type in arg-types 90 | for param in lambda-list 91 | collect `(check-type ,param ,type))) 92 | ;; for a simple values list, check types 93 | ,(if (intersection (ensure-list return-type) lambda-list-keywords) 94 | `(progn ,@body) 95 | (let* ((return-types (if (and (consp return-type) 96 | (eq 'values (car return-type))) 97 | (cdr return-type) 98 | (list return-type))) 99 | (return-vars (mapcar (lambda (x) 100 | (if (symbolp x) 101 | (gensym (symbol-name x)) 102 | (gensym))) 103 | return-types))) 104 | `(multiple-value-bind ,return-vars (progn ,@body) 105 | ,@(loop for type in return-types 106 | for var in return-vars 107 | collect `(check-type ,var ,type)) 108 | (values ,@return-vars)))))))) 109 | 110 | (alias-macro defun/inline defun) 111 | (alias-macro defun/type/inline defun/type)) 112 | -------------------------------------------------------------------------------- /src/util/misc.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel.util) 32 | 33 | (defmacro alias-function (alias orig) 34 | `(progn 35 | (setf (symbol-function ',alias) #',orig) 36 | (define-compiler-macro ,alias (&rest args) 37 | `(,',orig ,@args)) 38 | ',alias)) 39 | 40 | (defmacro alias-macro (alias orig) 41 | `(progn 42 | (setf (macro-function ',alias) (macro-function ',orig)) 43 | ',alias)) 44 | 45 | (defun unsplice (form) 46 | (if form (list form) nil)) 47 | 48 | (defun symbolicate/package (package &rest string-designators) 49 | "Concatenate `string-designators' then intern the result into `package'." 50 | (let ((*package* (find-package package))) 51 | (apply #'symbolicate string-designators))) 52 | 53 | (defun symbolicate/no-intern (&rest string-designators) 54 | "Concatenate `string-designators' then make-symbol the result." 55 | (format-symbol nil "~{~a~}" string-designators)) 56 | 57 | (defmacro with-parsed-body ((body declares &optional docstring) &body own-body) 58 | "Pop docstring and declarations off `body' and assign them to the 59 | variables `docstring' and `declares' respectively. If `docstring' is 60 | not present then no docstring is parsed." 61 | (if docstring 62 | `(multiple-value-bind (,body ,declares ,docstring) 63 | (parse-body ,body :documentation t) 64 | ,@own-body) 65 | `(multiple-value-bind (,body ,declares) (parse-body ,body) 66 | ,@own-body))) 67 | 68 | (declaim (inline to-boolean)) 69 | (defun to-boolean (x) 70 | (if x t nil)) 71 | 72 | (defun interact (&rest prompt) 73 | "Read from user and eval." 74 | (apply #'format *query-io* prompt) 75 | (finish-output *query-io*) 76 | (multiple-value-list (eval (read *query-io*)))) 77 | 78 | (defmacro repeat (n &body body) 79 | `(loop repeat ,n do (progn ,@body))) 80 | 81 | (defmacro dosequence ((var sequence &optional return) &body body) 82 | (with-gensyms (body-fn) 83 | `(block nil 84 | (flet ((,body-fn (,var) ,@body)) 85 | (declare (dynamic-extent #',body-fn)) 86 | (map nil #',body-fn ,sequence) 87 | ,@(unsplice (when return 88 | `(let ((,var nil)) 89 | (declare (ignorable ,var)) 90 | ,return))))))) 91 | 92 | (defmacro unwind-protect/ext (&key prepare main cleanup abort) 93 | "Extended `unwind-protect'. 94 | 95 | `prepare' : executed first, outside of `unwind-protect' 96 | `main' : protected form 97 | `cleanup' : cleanup form 98 | `abort' : executed if `main' does not finish 99 | " 100 | (with-gensyms (finishedp) 101 | `(progn 102 | ,@(unsplice prepare) 103 | ,(cond ((and main cleanup abort) 104 | `(let ((,finishedp nil)) 105 | (declare (type boolean ,finishedp)) 106 | (unwind-protect 107 | (prog1 ,main ; m-v-prog1 in real life 108 | (setf ,finishedp t)) 109 | (if ,finishedp 110 | ,cleanup 111 | (unwind-protect ,abort ,cleanup))))) 112 | ((and main cleanup) 113 | `(unwind-protect ,main ,cleanup)) 114 | ((and main abort) 115 | `(let ((,finishedp nil)) 116 | (declare (type boolean ,finishedp)) 117 | (unwind-protect 118 | (prog1 ,main 119 | (setf ,finishedp t)) 120 | (when (not ,finishedp) 121 | ,abort)))) 122 | (main main) 123 | (cleanup `(progn ,cleanup nil)) 124 | (abort nil) 125 | (t nil))))) 126 | 127 | (deftype index () 'array-index) 128 | 129 | (alias-function partial-apply curry) 130 | -------------------------------------------------------------------------------- /src/util/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defpackage #:lparallel.util 32 | (:documentation 33 | "(private) Miscellaneous utilities.") 34 | (:use #:cl) 35 | (:export #:with-gensyms 36 | #:defmacro/once 37 | #:unsplice 38 | #:symbolicate 39 | #:with-parsed-body) 40 | (:export #:repeat 41 | #:when-let 42 | #:dosequence 43 | #:alias-function 44 | #:alias-macro 45 | #:unwind-protect/ext) 46 | (:export #:defun/inline 47 | #:defun/type 48 | #:defun/type/inline) 49 | (:export #:defslots 50 | #:defpair) 51 | (:export #:interact 52 | #:ensure-function 53 | #:to-boolean 54 | #:partial-apply) 55 | (:export #:index) 56 | (:export #:*normal-optimize* 57 | #:*full-optimize*) 58 | (:import-from #:alexandria 59 | #:with-gensyms 60 | #:when-let 61 | #:symbolicate 62 | #:ensure-function 63 | #:once-only 64 | #:parse-body 65 | #:ensure-list 66 | #:format-symbol 67 | #:array-index 68 | #:curry)) 69 | 70 | (in-package #:lparallel.util) 71 | -------------------------------------------------------------------------------- /test/1am.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | ;;; See https://github.com/lmj/1am 32 | 33 | (defpackage #:lparallel-test.1am 34 | (:use #:cl) 35 | (:export #:test #:is #:signals #:run #:*tests*)) 36 | 37 | (in-package #:lparallel-test.1am) 38 | 39 | (defvar *tests* nil "A list of tests; the default argument to `run'.") 40 | (defvar *pass-count* nil) 41 | (defvar *running* nil) 42 | (defvar *failed-random-state* nil) 43 | 44 | (defun %shuffle (vector) 45 | (loop for i downfrom (- (length vector) 1) to 1 46 | do (rotatef (aref vector i) (aref vector (random (1+ i))))) 47 | vector) 48 | 49 | (defun shuffle (sequence) 50 | (%shuffle (map 'vector #'identity sequence))) 51 | 52 | (defun call-with-random-state (fn) 53 | (let ((*random-state* (or *failed-random-state* 54 | (load-time-value (make-random-state t))))) 55 | (setf *failed-random-state* (make-random-state nil)) 56 | (multiple-value-prog1 (funcall fn) 57 | (setf *failed-random-state* nil)))) 58 | 59 | (defun report (test-count pass-count) 60 | (format t "~&Success: ~s test~:p, ~s check~:p.~%" test-count pass-count)) 61 | 62 | (defun %run (fn test-count) 63 | (let ((*pass-count* 0)) 64 | (multiple-value-prog1 (call-with-random-state fn) 65 | (report test-count *pass-count*)))) 66 | 67 | (defun run (&optional (tests *tests*)) 68 | "Run each test in the sequence `tests'. Default is `*tests*'." 69 | (let ((*running* t)) 70 | (%run (lambda () (map nil #'funcall (shuffle tests))) 71 | (length tests))) 72 | (values)) 73 | 74 | (defun call-test (name fn) 75 | (format t "~&~s" name) 76 | (finish-output) 77 | (if *running* 78 | (funcall fn) 79 | (%run fn 1))) 80 | 81 | (defmacro test (name &body body) 82 | "Define a test function and add it to `*tests*'." 83 | `(progn 84 | (defun ,name () 85 | (call-test ',name (lambda () ,@body))) 86 | (pushnew ',name *tests*) 87 | ',name)) 88 | 89 | (defun passed () 90 | (write-char #\.) 91 | ;; Checks done outside a test run are not tallied. 92 | (when *pass-count* 93 | (incf *pass-count*)) 94 | (values)) 95 | 96 | (defmacro is (form) 97 | "Assert that `form' evaluates to non-nil." 98 | `(progn 99 | (assert ,form) 100 | (passed))) 101 | 102 | (defun %signals (expected fn) 103 | (flet ((handler (condition) 104 | (cond ((typep condition expected) 105 | (passed) 106 | (return-from %signals (values))) 107 | (t (error "Expected to signal ~s, but got ~s:~%~a" 108 | expected (type-of condition) condition))))) 109 | (handler-bind ((condition #'handler)) 110 | (funcall fn))) 111 | (error "Expected to signal ~s, but got nothing." expected)) 112 | 113 | (defmacro signals (condition &body body) 114 | "Assert that `body' signals a condition of type `condition'." 115 | `(%signals ',condition (lambda () ,@body))) 116 | -------------------------------------------------------------------------------- /test/base.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel-test) 32 | 33 | (define-condition client-error (error) ()) 34 | (define-condition foo-error (error) ()) 35 | 36 | (defparameter *memo* nil) 37 | (defparameter *nil* nil) 38 | 39 | (alias-function execute run) 40 | (alias-macro base-test test) 41 | 42 | (defun call-full-test (name body-fn) 43 | (dolist (n '(1 2 4 8 16)) 44 | (with-temp-kernel (n :spin-count 0) 45 | (funcall body-fn)) 46 | ;; kludge for checking :use-caller 47 | (when (search "defpun" (symbol-name name) :test #'equalp) 48 | (with-temp-kernel (n :spin-count (random 5000) :use-caller t) 49 | (funcall body-fn))) 50 | #+lparallel.with-stealing-scheduler 51 | (with-temp-kernel (n :spin-count (random 5000)) 52 | (funcall body-fn)))) 53 | 54 | (defmacro full-test (name &body body) 55 | `(base-test ,name 56 | (call-full-test ',name (lambda () ,@body)))) 57 | 58 | (defun extract-queue (queue) 59 | (loop until (queue-empty-p queue) 60 | collect (pop-queue queue))) 61 | 62 | (defun invoke-abort-thread () 63 | (flet ((fail () (error "Can't find an abort-like restart in this CL!"))) 64 | (let ((restarts (mapcar #'restart-name (compute-restarts)))) 65 | (if (find 'abort restarts) 66 | (invoke-restart 'abort) 67 | #-sbcl (fail) 68 | #+sbcl (let ((term (find-symbol (string '#:terminate-thread) 69 | 'sb-thread))) 70 | (if (and term (find term restarts)) 71 | (invoke-restart term) 72 | (fail))))))) 73 | 74 | (defun thread-count () 75 | ;; ccl can spontaneously lose the initial thread (issue #1042) 76 | #+ccl (count "Initial" 77 | (bordeaux-threads:all-threads) 78 | :key #'bordeaux-threads:thread-name 79 | :test-not #'string=) 80 | #-ccl (length (bordeaux-threads:all-threads))) 81 | 82 | (defun call-with-thread-count-check (body-fn) 83 | (sleep 0.2) 84 | (let ((old-thread-count (thread-count))) 85 | (funcall body-fn) 86 | (sleep 0.2) 87 | (is (eql old-thread-count (thread-count))))) 88 | 89 | (defmacro with-thread-count-check (&body body) 90 | `(call-with-thread-count-check (lambda () ,@body))) 91 | 92 | (defun infinite-loop () (loop until *nil*)) 93 | 94 | (defmacro collect-n (n &body body) 95 | "Execute `body' `n' times, collecting the results into a list." 96 | `(loop repeat ,n collect (progn ,@body))) 97 | 98 | (defun make-random-list (size) 99 | (collect-n size (random 1.0))) 100 | 101 | (defun make-random-vector (size) 102 | (map-into (make-array size) (lambda () (random 1.0)))) 103 | 104 | (defun compile/muffled (&rest args) 105 | (handler-bind (((or warning 106 | #+ecl c:compiler-note 107 | #+sbcl sb-ext:compiler-note) 108 | #'muffle-warning)) 109 | (apply #'compile args))) 110 | -------------------------------------------------------------------------------- /test/defpun-test.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel-test) 32 | 33 | ;;;; defpun 34 | 35 | (define-plet-test defpun-basic-test defpun-basic-test-fn defpun nil) 36 | 37 | (defun fib-let (n) 38 | (if (< n 2) 39 | n 40 | (let ((a (fib-let (- n 1))) 41 | (b (fib-let (- n 2)))) 42 | (+ a b)))) 43 | 44 | (defpun fib-plet (n) 45 | (if (< n 2) 46 | n 47 | (plet ((a (fib-plet (- n 1))) 48 | (b (fib-plet (- n 2)))) 49 | (+ a b)))) 50 | 51 | (defpun fib-plet-if (n) 52 | (if (< n 2) 53 | n 54 | (plet-if (> n 5) ((a (fib-plet-if (- n 1))) 55 | (b (fib-plet-if (- n 2)))) 56 | (+ a b)))) 57 | 58 | (full-test defpun-fib-test 59 | (loop for n from 1 to #+lparallel.with-green-threads 5 60 | #-lparallel.with-green-threads 15 61 | do (is (= (fib-let n) (fib-plet n) (fib-plet-if n))))) 62 | 63 | ;;; typed 64 | 65 | (defun/type fib-let/type (n) (fixnum) fixnum 66 | (if (< n 2) 67 | n 68 | (let ((a (fib-let/type (- n 1))) 69 | (b (fib-let/type (- n 2)))) 70 | (+ a b)))) 71 | 72 | (defpun/type fib-plet/type (n) (fixnum) fixnum 73 | (if (< n 2) 74 | n 75 | (plet ((a (fib-plet/type (- n 1))) 76 | (b (fib-plet/type (- n 2)))) 77 | (+ a b)))) 78 | 79 | (defpun/type fib-plet-if/type (n) (fixnum) fixnum 80 | (if (< n 2) 81 | n 82 | (plet-if (> n 5) ((a (fib-plet-if/type (- n 1))) 83 | (b (fib-plet-if/type (- n 2)))) 84 | (+ a b)))) 85 | 86 | (full-test defpun/type-fib-test 87 | (loop for n from 1 to #+lparallel.with-green-threads 5 88 | #-lparallel.with-green-threads 15 89 | do (is (= (fib-let/type n) (fib-plet/type n) (fib-plet-if/type n))))) 90 | 91 | ;;; redefinitions 92 | 93 | (base-test redefined-defpun-test 94 | (with-temp-kernel (2) 95 | (setf *memo* 'foo) 96 | (handler-bind ((warning #'muffle-warning)) 97 | (eval '(defpun foo (x) (* x x)))) 98 | (is (= 9 (funcall *memo* 3))) 99 | (handler-bind ((warning #'muffle-warning)) 100 | (eval '(defun foo (x) (* x x x)))) 101 | (is (= 27 (funcall *memo* 3))))) 102 | 103 | ;;; forward ref 104 | 105 | (declaim-defpun func1 func2) 106 | 107 | (defpun func2 (x) 108 | (plet ((y (func1 x))) 109 | (* x y))) 110 | 111 | (defpun func1 (x) 112 | (plet ((y (* x x))) 113 | (* x y))) 114 | 115 | (full-test declaim-defpun-test 116 | (is (= 81 (func2 3)))) 117 | 118 | ;;; lambda list keywords 119 | 120 | (defpun foo-append (&key left right) 121 | (if (null left) 122 | right 123 | (plet ((x (first left)) 124 | (y (foo-append :left (rest left) :right right))) 125 | (cons x y)))) 126 | 127 | (full-test defpun-lambda-list-keywords-test 128 | (is (equal '(1 2 3 4 5 6 7) 129 | (foo-append :left '(1 2 3) :right '(4 5 6 7)))) 130 | (is (equal '(1 2 3) 131 | (foo-append :left '(1 2 3) :right nil))) 132 | (is (equal '(1 2 3) 133 | (foo-append :left '(1 2 3)))) 134 | (is (equal '(4 5 6 7) 135 | (foo-append :right '(4 5 6 7)))) 136 | (is (equal nil 137 | (foo-append :right nil))) 138 | (is (equal nil 139 | (foo-append)))) 140 | 141 | ;;; multiple values 142 | 143 | (defpun mv-foo-1 (x y) 144 | (values x y)) 145 | 146 | (defpun/type mv-foo-2 (x y) (fixnum fixnum) (values fixnum fixnum) 147 | (values x y)) 148 | 149 | (defpun mv-foo-3 (x y) 150 | (mv-foo-1 x y)) 151 | 152 | (defpun/type mv-foo-4 (x y) (fixnum fixnum) (values fixnum fixnum) 153 | (mv-foo-2 x y)) 154 | 155 | (defpun/type mv-foo-5 (x y) (fixnum fixnum) (values fixnum fixnum) 156 | (mv-foo-3 x y)) 157 | 158 | (full-test defpun-mv-test 159 | (is (equal '(3 4) (multiple-value-list (mv-foo-1 3 4)))) 160 | (is (equal '(3 4) (multiple-value-list (mv-foo-2 3 4)))) 161 | (is (equal '(3 4) (multiple-value-list (mv-foo-3 3 4)))) 162 | (is (equal '(3 4) (multiple-value-list (mv-foo-4 3 4)))) 163 | (is (equal '(3 4) (multiple-value-list (mv-foo-5 3 4))))) 164 | 165 | (defpun defpun-mv-plet-1 () 166 | (plet (((a b) (floor 5 2)) 167 | (c 9) 168 | d 169 | (e) 170 | ((f g h) (values 6 7 8))) 171 | (declare (type fixnum b c g)) 172 | (list a b c d e f g h))) 173 | 174 | (defpun defpun-mv-plet-2 () 175 | (plet (a (b) ((c)) d (e)) 176 | (declare (type null d)) 177 | (declare (null c)) 178 | (list a b c d e))) 179 | 180 | (full-test defpun-mv-plet-test 181 | (is (equal '(2 1 9 nil nil 6 7 8) (defpun-mv-plet-1))) 182 | (is (equal '(nil nil nil nil nil) (defpun-mv-plet-2)))) 183 | 184 | (defpun defpun-handling-1 () 185 | (plet ((a 3) 186 | (b 4) 187 | (c (restart-case (error 'foo-error) 188 | (four () 5)))) 189 | (+ a b c))) 190 | 191 | (defpun defpun-handling-2 () 192 | (plet ((c (restart-case (error 'foo-error) 193 | (four () 5))) 194 | (a 3) 195 | (b 4)) 196 | (+ a b c))) 197 | 198 | (defpun defpun-handling-3 () 199 | (error 'foo-error)) 200 | 201 | (defpun defpun-handling-4 (n) 202 | (if (< n 2) 203 | (error 'foo-error) 204 | (plet ((a (defpun-handling-4 (- n 1))) 205 | (b (defpun-handling-4 (- n 2)))) 206 | (+ a b)))) 207 | 208 | (full-test defpun-handling-test 209 | (repeat 100 210 | (task-handler-bind ((foo-error (lambda (e) 211 | (declare (ignore e)) 212 | (invoke-restart 'four)))) 213 | (is (= 12 (defpun-handling-1))) 214 | (is (= 12 (defpun-handling-2)))) 215 | (task-handler-bind ((foo-error #'invoke-transfer-error)) 216 | (signals foo-error 217 | (defpun-handling-1)) 218 | (signals foo-error 219 | (defpun-handling-2)) 220 | (signals foo-error 221 | (defpun-handling-3)) 222 | (signals foo-error 223 | (defpun-handling-4 10))))) 224 | 225 | (full-test defpun-priority-test 226 | (let ((*task-priority* :low)) 227 | (repeat 10 228 | (let ((n #+lparallel.with-green-threads 5 229 | #-lparallel.with-green-threads 25)) 230 | (is (= (fib-let n) (fib-plet n))))))) 231 | -------------------------------------------------------------------------------- /test/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defpackage #:lparallel-test 32 | (:documentation 33 | "Test suite for lparallel.") 34 | (:use #:cl 35 | #:lparallel.util 36 | #:lparallel.thread-util 37 | #:lparallel.raw-queue 38 | #:lparallel.queue 39 | #:lparallel.vector-queue 40 | #:lparallel.kernel 41 | #:lparallel.cognate 42 | #:lparallel.defpun 43 | #:lparallel.promise 44 | #:lparallel.ptree 45 | #:lparallel-test.1am) 46 | (:import-from #:lparallel.kernel-util 47 | #:with-temp-kernel) 48 | (:export #:execute)) 49 | 50 | (in-package #:lparallel-test) 51 | -------------------------------------------------------------------------------- /test/thread-util-test.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lparallel-test) 32 | 33 | (base-test basic-threading-test 34 | (let ((num-threads 10) 35 | (num-objects 1000) 36 | (num-iterations 5) 37 | (from-workers (make-queue)) 38 | (to-workers (make-queue))) 39 | (repeat num-threads 40 | (with-thread () 41 | (loop (let ((object (pop-queue to-workers))) 42 | (if object 43 | (push-queue object from-workers) 44 | (return)))))) 45 | (repeat num-iterations 46 | (repeat num-objects 47 | (push-queue 99 to-workers)) 48 | (repeat num-objects 49 | (pop-queue from-workers))) 50 | (repeat num-threads 51 | (push-queue nil to-workers)) 52 | (sleep 0.5) 53 | (is (= 0 (queue-count from-workers))) 54 | (is (= 0 (queue-count to-workers))))) 55 | 56 | (base-test thread-bindings-test 57 | (setf *memo* :main) 58 | (with-thread () 59 | (setf *memo* :child)) 60 | (sleep 0.2) 61 | (is (eq :child *memo*)) 62 | 63 | (setf *memo* :main) 64 | (with-thread (:bindings (list (cons '*memo* *memo*))) 65 | (setf *memo* :child)) 66 | (sleep 0.2) 67 | (is (eq :main *memo*))) 68 | 69 | #-lparallel.without-kill 70 | (base-test destroy-thread-cleanup-test 71 | (let* ((cleanedp nil) 72 | (thread (with-thread () 73 | (unwind-protect (sleep 999999) 74 | (setf cleanedp t))))) 75 | (sleep 0.2) 76 | (destroy-thread thread) 77 | (sleep 0.2) 78 | (is (eq t cleanedp)))) 79 | --------------------------------------------------------------------------------