├── CHANGES ├── LICENSE ├── README.md ├── bench ├── README.md ├── bench.lisp ├── governor.sh ├── package.lisp ├── profile.lisp └── suite.lisp ├── docs ├── API.md ├── Benchmarks.md ├── CHANGES.md ├── Cognates.md ├── Handling.md ├── Kernel.md ├── Promises.md ├── Ptrees.md ├── Queues.md ├── defpun.md ├── pmap.md └── preduce.md ├── lparallel.asd ├── src ├── 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 ├── defpun.lisp ├── kernel-util.lisp ├── kernel │ ├── 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.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 | * Allegro 26 | * Clozure 27 | * LispWorks 28 | * SBCL 29 | 30 | To run tests, call `(asdf:test-system :lparallel/test)`. 31 | 32 | To run benchmarks, load `:lparallel/bench` and call 33 | `(lparallel/bench:execute N)` where `N` is the number of worker threads. 34 | 35 | ### Author 36 | 37 | James M. Lawrence 38 | -------------------------------------------------------------------------------- /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 | (in-package :lparallel/bench) 54 | -------------------------------------------------------------------------------- /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-2" pkg) 69 | #+sbcl (match-package-p "sb-concurrency" pkg)))))) 70 | 71 | (defun profile (&rest args) 72 | (without-warnings 73 | (enable-profiling)) 74 | (sb-profile:reset) 75 | (apply #'execute args) 76 | (sb-profile:report)) 77 | 78 | ;;;; stat-profile 79 | 80 | (defun stat-profile (&rest args) 81 | (sb-sprof:with-profiling (:max-samples 100000 82 | :sample-interval (/ sb-sprof:*sample-interval* 2) 83 | :report :graph 84 | :loop nil 85 | :threads :all 86 | :show-progress nil) 87 | (apply #'execute args))) 88 | -------------------------------------------------------------------------------- /docs/API.md: -------------------------------------------------------------------------------- 1 | API 2 | 3 | The lparallel API is divided into five packages: 4 | 5 | lparallel.kernel 6 | lparallel.promise 7 | lparallel.cognate 8 | lparallel.ptree 9 | lparallel.defpun 10 | 11 | For convenience, the exported symbols of each package are also exported by the lparallel package. 12 | 13 | The lparallel.queue package provides a queue for inter-thread communication. It is not included in the lparallel package. 14 | -------------------------------------------------------------------------------- /docs/Cognates.md: -------------------------------------------------------------------------------- 1 | Cognates 2 | 3 | lparallel provides parallel versions of many Common Lisp functions and macros, each prefixed by ‘p’. They are the pmap family, preduce, and the following. 4 | 5 | pand 6 | pcount 7 | pcount-if 8 | pcount-if-not 9 | pdotimes 10 | pevery 11 | pfind 12 | pfind-if 13 | pfind-if-not 14 | pfuncall 15 | plet 16 | pnotany 17 | pnotevery 18 | por 19 | premove 20 | premove-if 21 | premove-if-not 22 | psome 23 | psort 24 | 25 | They return the same results as their CL counterparts except in cases where parallelism must play a role. For instance premove behaves essentially like its CL version, but por is slightly different. or returns the result of the first form that evaluates to something non-nil, while por may return the result of any such non-nil-evaluating form. 26 | 27 | plet is best explained in terms of its macroexpansion. 28 | 29 | (defpackage :example (:use :cl :lparallel)) 30 | (in-package :example) 31 | 32 | (plet ((a (+ 3 4)) 33 | (b (+ 5 6))) 34 | (list a b)) 35 | 36 | ; => (7 11) 37 | 38 | The plet form expands to 39 | 40 | (LET ((#:A725 (FUTURE (+ 3 4))) 41 | (#:B726 (FUTURE (+ 5 6)))) 42 | (SYMBOL-MACROLET ((A (FORCE #:A725)) 43 | (B (FORCE #:B726))) 44 | (LIST A B))) 45 | 46 | See Promises for an explanation of future and force. Since a future’s result is cached (a feature all promises share), references to a and b incur little overhead once their corresponding futures have finished computing. 47 | 48 | There are four cognates which have no direct CL counterpart: 49 | 50 | plet-if 51 | pmaplist-into 52 | pmap-reduce 53 | preduce-partial 54 | -------------------------------------------------------------------------------- /docs/Handling.md: -------------------------------------------------------------------------------- 1 | Handling 2 | 3 | Handling conditions in lparallel is done with task-handler-bind. It is just like handler-bind except that it handles conditions signaled from inside parallel tasks. 4 | 5 | (defpackage :example (:use :cl :lparallel)) 6 | (in-package :example) 7 | 8 | (define-condition foo-error (error) ()) 9 | 10 | (task-handler-bind ((foo-error (lambda (e) 11 | (declare (ignore e)) 12 | (invoke-restart 'number-nine)))) 13 | (pmapcar (lambda (x) 14 | (declare (ignore x)) 15 | (restart-case (error 'foo-error) 16 | (number-nine () "number nine"))) 17 | '(1 2 3))) 18 | 19 | ; => ("number nine" "number nine" "number nine") 20 | 21 | Though one may be tempted to merge handler-bind and task-handler-bind with some shadowing magic, in general the handlers which need to reach inside tasks will not always match the handlers that are suitable for the current thread. It is also useful to explicitly flag asynchronous handlers that require thread-safe behavior. 22 | 23 | In Common Lisp, the debugger is invoked when an error goes unhandled. By default lparallel mirrors this behavior with regard to tasks: when an error is signaled inside a task, and the error is not handled by one of the task handlers established by task-handler-bind, then the debugger is invoked. 24 | 25 | However there is an alternate behavior which may be more appropriate depending upon the situation: automatically transferring errors. Setting *debug-tasks-p* to false will transfer task errors to threads which attempt to obtain the failed results. Suppose you have several parallel tasks running and each task signals an error. If *debug-tasks-p* is false then the debugger will be invoked just once (typically in the parent thread) instead of several times (once for each task). 26 | 27 | If *debug-tasks-p* is true then you may still elect to transfer the error yourself. Inside each task there is a restart called TRANSFER-ERROR, which you will see in the debugger. (When *debug-tasks-p* is false the restart is simply invoked for you.) The following shows the Clozure + SLIME environment. 28 | 29 | (pmapcar (lambda (x) 30 | (when (evenp x) 31 | (restart-case (error 'foo-error) 32 | (number-nine () 33 | :report "Who was to know?" 34 | "number nine")))) 35 | '(1 2 3)) 36 | => 37 | Error EXAMPLE::FOO-ERROR 38 | [Condition of type EXAMPLE::FOO-ERROR] 39 | 40 | Restarts: 41 | 0: [NUMBER-NINE] Who was to know? 42 | 1: [TRANSFER-ERROR] Transfer this error to a dependent thread, if one exists 43 | 2: [ABORT-BREAK] Reset this thread 44 | 3: [ABORT] Kill this thread 45 | 46 | The presence of the TRANSFER-ERROR restart indicates that we are inside a task. After inspecting the backtrace to our satisfaction, it’s time to hit TRANSFER-ERROR. In our example the top-level thread is already waiting for the result, so the debugger will appear again after we transfer. 47 | 48 | => 49 | Error FOO-ERROR 50 | [Condition of type FOO-ERROR] 51 | 52 | Restarts: 53 | 0: [RETRY] Retry SLIME interactive evaluation request. 54 | 1: [*ABORT] Return to SLIME's top level. 55 | 2: [ABORT-BREAK] Reset this thread 56 | 3: [ABORT] Kill this thread 57 | 58 | The familiar SLIME restarts are there again. We are back in the top-level thread. 59 | 60 | The behavior specified by *debug-tasks-p* may be locally overridden with task-handler-bind. To always transfer errors, 61 | 62 | (task-handler-bind ((error #'invoke-transfer-error)) ...) 63 | 64 | Likewise to always invoke the debugger for unhandled errors, 65 | 66 | (task-handler-bind ((error #'invoke-debugger)) ...) 67 | 68 | More on threads 69 | 70 | In the second example, what if we selected the ABORT restart (“Kill this thread”) instead of transferring the error? This would not be dangerous—the killed worker would be automatically replaced with a new one—but it would be a little rude. The top-level thread would signal TASK-KILLED-ERROR instead of FOO-ERROR. In our example this does not matter, but by signaling TASK-KILLED-ERROR we potentially spoil a handler’s lifelong dream of handling a FOO-ERROR. 71 | Killing tasks 72 | 73 | Occasionally there may be a task which has entered a deadlock (which can happen with circular references) or an infinite loop. Don’t panic! Try 74 | 75 | (kill-tasks :default) 76 | 77 | This is a blunt weapon, however, because passing :default may cause unrelated tasks to be killed. 78 | 79 | Each task is given a task category identifier. When a task is submitted, it is assigned the category of *task-category* which has a default value of :default. The argument to kill-tasks is a task category. Any running task whose category is eql to the argument passed will be killed. Pending tasks are not affected. 80 | 81 | To avoid killing unrelated tasks, bind *task-category* around submit-task calls. 82 | 83 | (let ((channel (make-channel))) 84 | ;; ... 85 | (let ((*task-category* 'my-stuff)) 86 | (submit-task channel (lambda () (loop)))) ; oops! 87 | (receive-result channel)) 88 | 89 | This is hung at receive-result. We can recover by calling 90 | 91 | (kill-tasks 'my-stuff) 92 | 93 | which will only kill our looping task, assuming my-stuff is not used as a task category elsewhere in the same package. 94 | 95 | Keep in mind that killing tasks is expensive and should only be done in exceptional circumstances. Not only is thread creation expensive (for the worker replacements), but heavy locking is required as well. 96 | -------------------------------------------------------------------------------- /docs/Kernel.md: -------------------------------------------------------------------------------- 1 | Kernel 2 | 3 | In the context of lparallel, a kernel is an abstract entity that schedules and executes tasks. The lparallel kernel API is meant to describe parallelism in a generic manner. 4 | 5 | The implementation uses a group of worker threads. It is intended to be efficiency-wise comparable to (or faster than) similar hand-rolled solutions while also providing full condition handling and consistency checks. All higher-level constructs in lparallel are implemented on top of the kernel. 6 | 7 | (For an implementation of the kernel API that distributes across machines, see lfarm.) 8 | 9 | Kernel-related operations are applied to the current kernel, stored in *kernel*. A kernel is typically created with 10 | 11 | ```lisp 12 | (setf lparallel:*kernel* (lparallel:make-kernel N)) 13 | ``` 14 | 15 | where N is the number of worker threads (more options are available). In most circumstances a kernel should exist for the lifetime of the Lisp process. Multiple kernels are possible, and setting the current kernel is done in the expected manner by dynamically binding *kernel*. 16 | 17 | A task is a function designator together with arguments to the function. To execute a task, (1) create a channel, (2) submit the task through the channel, and (3) receive the result from the channel. 18 | 19 | ```lisp 20 | (defpackage :example (:use :cl :lparallel)) 21 | (in-package :example) 22 | 23 | (let ((channel (make-channel))) 24 | (submit-task channel '+ 3 4) 25 | (receive-result channel)) 26 | 27 | ; => 7 28 | ``` 29 | 30 | If you have not created a kernel (if *kernel* is nil) then upon evaluating the above you will receive an error along with a restart offering to make a kernel for you. Evaluation commences once a kernel is created. 31 | 32 | Multiple tasks may be submitted on the same channel, though the results are not necessarily received in the order in which they were submitted. receive-result receives one result per call. 33 | 34 | ```lisp 35 | (let ((channel (make-channel))) 36 | (submit-task channel '+ 3 4) 37 | (submit-task channel (lambda () (+ 5 6))) 38 | (list (receive-result channel) 39 | (receive-result channel))) 40 | 41 | ; => (7 11) or (11 7) 42 | ``` 43 | 44 | To set the priority of tasks, bind *task-priority* around calls to submit-task. 45 | 46 | ```lisp 47 | (let ((*task-priority* :low)) 48 | (submit-task channel '+ 3 4)) 49 | ``` 50 | 51 | The kernel executes a :low priority task only when there are no default priority tasks pending. The task priorities recognized are :default (the default priority) and :low. 52 | 53 | Handlers may be established for conditions that are signaled by a task (see Handling). When an error from a task goes unhandled, an error-info object is placed in the channel. After receive-result removes such an object from the channel, the corresponding error is signaled. 54 | 55 | Note that a kernel will not be garbage collected until end-kernel is called. 56 | Message passing 57 | 58 | For situations where submit-task and receive-result are too simplistic, a blocking queue is available for arbitrary message passing between threads. 59 | 60 | ```lisp 61 | (defpackage :queue-example (:use :cl :lparallel :lparallel.queue)) 62 | (in-package :queue-example) 63 | 64 | (let ((queue (make-queue)) 65 | (channel (make-channel))) 66 | (submit-task channel (lambda () (list (pop-queue queue) 67 | (pop-queue queue)))) 68 | (push-queue "hello" queue) 69 | (push-queue "world" queue) 70 | (receive-result channel)) 71 | ;; => ("hello" "world") 72 | ``` 73 | 74 | Of course messages may also be passed between workers. 75 | Dynamic variables and worker context 76 | 77 | When a dynamic variable is dynamically bound (for example with let or progv), the binding becomes local to that thread. Otherwise, the global (default) value of a dynamic variable is shared among all threads that access it. 78 | 79 | Binding dynamic variables for use inside tasks may be done on either a per-task basis or a per-worker basis. An example of the former is 80 | 81 | ```lisp 82 | (submit-task channel (let ((foo *foo*)) 83 | (lambda () 84 | (let ((*foo* foo)) 85 | (bar))))) 86 | ``` 87 | 88 | This saves the current value of *foo* and, inside the task, binds *foo* to that value for the duration of (bar). You may wish to write a submit-with-my-bindings function to suit your particular needs. 89 | 90 | To establish permanent dynamic bindings inside workers (thread-local variables), use the :bindings argument to make-kernel, which is an alist of (var-name . value-form) pairs. Each value-form is evaluated inside each worker when it is created. (So if you have two workers, each value-form will be evaluated twice.) 91 | 92 | For more complex scenarios of establishing worker context, a :context function may be provided. This function is called by lparallel inside each worker and is responsible for entering the worker loop by funcalling its only parameter. The variables from :bindings are available inside the function. 93 | 94 | ```lisp 95 | (defvar *foo* 0) 96 | (defvar *bar* 1) 97 | 98 | (defun my-worker-context (worker-loop) 99 | (let ((*bar* (1+ *foo*))) 100 | ;; enter the worker loop; return when the worker shuts down 101 | (funcall worker-loop))) 102 | 103 | (defvar *my-kernel* (make-kernel 2 104 | :bindings '((*foo* . (1+ 98))) 105 | :context #'my-worker-context)) 106 | 107 | (list *foo* *bar*) 108 | ; => (0 1) 109 | 110 | (let* ((*kernel* *my-kernel*) 111 | (channel (make-channel))) 112 | (submit-task channel (lambda () (list *foo* *bar*))) 113 | (receive-result channel)) 114 | ; => (99 100) 115 | 116 | ``` 117 | -------------------------------------------------------------------------------- /docs/Promises.md: -------------------------------------------------------------------------------- 1 | Promises 2 | 3 | A promise is a receptacle for a result which is unknown at the time it is created. To fulfill a promise is to give it a result. The value of a promise is obtained by forcing it. 4 | 5 | (defpackage :example (:use :cl :lparallel)) 6 | (in-package :example) 7 | 8 | (let ((p (promise))) 9 | (fulfilledp p) ; => nil 10 | (fulfill p 3) 11 | (fulfilledp p) ; => t 12 | (force p)) 13 | 14 | ; => 3 15 | 16 | A promise may be successfully fulfilled only once, after which force will forever return the same result. If fulfill is successful it returns true, otherwise it returns false indicating the promise is already fulfilled (or in the process of being fulfilled). When force is called on an unfulfilled promise, the call will block until the promise is fulfilled. 17 | 18 | A future is a promise which is fulfilled in parallel. When a future is created, a parallel task is made from the code passed. 19 | 20 | (let ((f (future 21 | (sleep 0.2) 22 | (+ 3 4)))) 23 | (fulfilledp f) ; => nil 24 | (sleep 0.4) 25 | (fulfilledp f) ; => t 26 | (force f)) 27 | 28 | ; => 7 29 | 30 | Here are two futures competing to fulfill a promise: 31 | 32 | (let* ((p (promise)) 33 | (f (future 34 | (sleep 0.05) 35 | (fulfill p 'f-was-here))) 36 | (g (future 37 | (sleep 0.049999) 38 | (fulfill p 'g-was-here)))) 39 | (list (force p) (force f) (force g))) 40 | 41 | ; => (F-WAS-HERE T NIL) or (G-WAS-HERE NIL T) 42 | 43 | Whichever result appears is dependent upon your system. Note the return value of fulfill indicating success or failure. 44 | 45 | Importantly, fulfill is a macro. When we consider giving fulfill an actual calculation to perform instead of an immediate value like 3, the reason for fulfill being a macro should be clear. If a promise is already fulfilled then we do not want the code passed to fulfill to be needlessly executed. 46 | 47 | A speculation—created by speculate—is a low-priority future whose associated task is executed only when those of regular futures are not pending. 48 | 49 | Like futures and speculations, a delay is also a promise associated with some code. However instead of being fulfilled in parallel, a delay is fulfilled when force is called upon it. 50 | 51 | Futures, speculations, and delays are thus types of promises, and they only differ in how they are fulfilled. In fact they hardly differ in that regard since all must obey fulfill which, if successful, overrides any “fulfillment plan” that may be in place. 52 | 53 | (let ((f (future (+ 1 2))) 54 | (g (delay (+ 3 4))) 55 | (h (delay (+ 5 6)))) 56 | (fulfill f 'nevermind) ; may or may not cancel f's computation 57 | (fulfill g (+ 7 8)) ; 'force' will no longer compute (+ 3 4) 58 | (mapcar 'force (list f g h))) 59 | 60 | ; => (3 15 11) or (NEVERMIND 15 11) 61 | 62 | f‘s planned computation is canceled if the first fulfill happens to grab the future before a worker thread gets it. 63 | 64 | For an object which is not a promise, force behaves like identity, returning the object passed. We may imagine that non-promise objects are like promises that are always fulfilled. fulfilledp returns true for any non-promise argument passed. Attempting to fulfill a non-promise is not an error, though of course it never succeeds. 65 | 66 | Lastly there is chain, which links objects together by relaying force and fulfilledp calls. 67 | 68 | (force (future (delay 3))) ; => a delay object 69 | (force (future (chain (delay 3)))) ; => 3 70 | 71 | Suppose we wish to cancel a speculation and also signal an error if the speculation is forced after being canceled. This may be accomplished by giving a chained delay to fulfill. 72 | 73 | (let ((f (speculate (+ 3 4)))) 74 | (fulfill f (chain (delay (error "speculation canceled!")))) 75 | (force f)) 76 | 77 | ; => 7 or # 78 | 79 | If chain were not present then force would return a delay object if fulfill succeeded, on which force would have to be called again in order to obtain the error. 80 | -------------------------------------------------------------------------------- /docs/Ptrees.md: -------------------------------------------------------------------------------- 1 | Ptrees 2 | 3 | In cases where futures must wait upon the results of other futures, it may be more suitable to use a ptree instead. A ptree also has built-in support for retrying failed computations. 4 | 5 | A ptree is a computation represented by a tree together with functionality to execute the tree in parallel. The simplest way to build and execute a ptree is with the ptree macro. Its syntax matches that of flet. 6 | 7 | (defpackage :example (:use :cl :lparallel)) 8 | (in-package :example) 9 | 10 | (ptree ((area (width height) (* width height)) 11 | (width (border) (+ 7 (* 2 border))) 12 | (height (border) (+ 5 (* 2 border))) 13 | (border () 1)) 14 | area) 15 | 16 | ; => 63 17 | 18 | This performs a parallelized version of the computation 19 | 20 | (* (+ 7 (* 2 1)) 21 | (+ 5 (* 2 1))) 22 | 23 | ; => 63 24 | 25 | Each function in the ptree macro corresponds to a node in the generated tree. The relationships between the nodes are determined by the parameter names. In this example the area node has two child nodes labeled width and height; the width and height nodes share the same child node named border; and the border node has no children. 26 | 27 | Each node contains a function and a result. The arguments passed to a node’s function are the respective results of its child nodes. The function result is stored in the node. 28 | 29 | The function associated with a ptree node should be a pure function with regard to that ptree. It should depend only on its parameters and should not produce side-effects that impact other functions in the ptree. Otherwise, the result of the ptree computation is not well-defined. 30 | 31 | Futures could also be used parallelize our example computation. 32 | 33 | (let* ((border (future 1)) 34 | (width (future (+ 7 (* 2 (force border))))) 35 | (height (future (+ 5 (* 2 (force border))))) 36 | (area (future (* (force width) (force height))))) 37 | (force area)) 38 | 39 | ; => 63 40 | 41 | What is the purpose of ptrees if futures can do the same thing? Futures are inadequate for large trees with interconnected relationships. A worker thread is effectively hijacked whenever a future waits on another future. A new temporary worker could be spawned to compensate for each worker that enters a waiting state, however in general that is an expensive solution which does not scale well. 42 | 43 | The underlying issue is that futures have no knowledge of the computation tree in which they participate. Futures are simple and stupid; they work fine on their own but not in the context of interconnected futures. The solution is to describe the computation explicitly with a ptree. By examining the node relationships, a ptree is able to avoid the problem of blocked workers caused by futures. 44 | 45 | Ptrees may be built dynamically as follows. 46 | 47 | (let ((tree (make-ptree))) 48 | (ptree-fn 'area '(width height) (lambda (w h) (* w h)) tree) 49 | (ptree-fn 'width '(border) (lambda (b) (+ 7 (* 2 b))) tree) 50 | (ptree-fn 'height '(border) (lambda (b) (+ 5 (* 2 b))) tree) 51 | (ptree-fn 'border '() (lambda () 1) tree) 52 | (call-ptree 'area tree)) 53 | 54 | ; => 63 55 | 56 | This code resembles the expansion of the ptree macro example above. Note that a node identifier need not be a symbol; any object suitable for eql comparison will do. 57 | 58 | clear-ptree restores the tree to its original uncomputed state. clear-ptree-errors restores to the last pre-error state. 59 | 60 | If the functions in a ptree themselves make use of parallelism—for instance if a node function calls pmap—then consider using a separate kernel for node computations by binding *ptree-node-kernel* to a kernel instance. 61 | -------------------------------------------------------------------------------- /docs/Queues.md: -------------------------------------------------------------------------------- 1 | Queues 2 | 3 | The following symbols are exported by the lparallel.queue package. They are not included in the lparallel package. 4 | 5 | [function] 6 | make-queue &key fixed-capacity initial-contents 7 | 8 | Create a queue. 9 | 10 | The queue contents may be initialized with the keyword argument `initial-contents’. 11 | 12 | By default there is no limit on the queue capacity. Passing a `fixed-capacity’ keyword argument limits the capacity to the value passed. `push-queue’ will block for a full fixed-capacity queue. 13 | 14 | [function] 15 | peek-queue queue 16 | 17 | If `queue’ is non-empty, return (values element t) where `element’ is the frontmost element of `queue’. 18 | 19 | If `queue’ is empty, return (values nil nil). 20 | 21 | [function] 22 | pop-queue queue 23 | 24 | Remove the frontmost element from `queue’ and return it. 25 | 26 | If `queue’ is empty, block until an element is available. 27 | 28 | [function] 29 | push-queue object queue 30 | 31 | Push `object’ onto the back of `queue’. 32 | 33 | [function] 34 | queue-count queue 35 | 36 | Return the number of elements in `queue’. 37 | 38 | [function] 39 | queue-empty-p queue 40 | 41 | Return true if `queue’ is empty, otherwise return false. 42 | 43 | [function] 44 | queue-full-p queue 45 | 46 | Return true if `queue’ is full, otherwise return false. 47 | 48 | [function] 49 | try-pop-queue queue &key timeout 50 | 51 | If `queue’ is non-empty, remove the frontmost element from `queue’ and return (values element t) where `element’ is the element removed. 52 | 53 | If `queue’ is empty and `timeout’ is given, then wait up to `timeout’ seconds for the queue to become non-empty. 54 | 55 | If `queue’ is empty and the timeout has expired, or if `queue’ is empty and no `timeout’ was given, return (values nil nil). 56 | 57 | Providing a nil or non-positive value of `timeout’ is equivalent to providing no timeout. 58 | 59 | [macro] 60 | with-locked-queue queue &body body 61 | 62 | Execute `body’ with the queue lock held. Use the `/no-lock’ functions inside `body’. 63 | 64 | -------------------------------------------------------------------------------- /docs/defpun.md: -------------------------------------------------------------------------------- 1 | defpun 2 | 3 | Using plet is often a natural way to add parallelism to an algorithm. The result of doing so may be disappointing, however. Consider the classic Fibonacci example: 4 | 5 | (defpackage :example (:use :cl :lparallel)) 6 | (in-package :example) 7 | 8 | (defun fib (n) 9 | (if (< n 2) 10 | n 11 | (let ((a (fib (- n 1))) 12 | (b (fib (- n 2)))) 13 | (+ a b)))) 14 | 15 | (defun pfib-slow (n) 16 | (if (< n 2) 17 | n 18 | (plet ((a (pfib-slow (- n 1))) 19 | (b (pfib-slow (- n 2)))) 20 | (+ a b)))) 21 | 22 | Living up to its name, pfib-slow is slow. Since plet spawns parallel tasks each time, and since addition is cheap, the overhead of task creation, scheduling, and execution will dominate. 23 | 24 | (time (fib 25)) 25 | => 75025 26 | Evaluation took: 27 | 0.002 seconds of real time 28 | 0.000000 seconds of total run time (0.000000 user, 0.000000 system) 29 | 0.00% CPU 30 | 6,912,680 processor cycles 31 | 0 bytes consed 32 | 33 | (time (pfib-slow 25)) 34 | => 75025 35 | Evaluation took: 36 | 0.028 seconds of real time 37 | 0.096006 seconds of total run time (0.096006 user, 0.000000 system) 38 | 342.86% CPU 39 | 93,778,257 processor cycles 40 | 29,136,576 bytes consed 41 | 42 | How do we fix this? One way is to create fewer tasks by partitioning the computation into larger chunks. 43 | 44 | (time (pmap-reduce 'fib '+ #(21 22 22 23))) 45 | => 75025 46 | Evaluation took: 47 | 0.001 seconds of real time 48 | 0.000000 seconds of total run time (0.000000 user, 0.000000 system) 49 | 0.00% CPU 50 | 2,771,120 processor cycles 51 | 96 bytes consed 52 | 53 | In general it may not be easy to subdivide a computation and then glue the results together, as we have done here. The purpose of defpun is to handle this for us. defpun has the syntax and semantics of defun. 54 | 55 | (defpun pfib (n) 56 | (if (< n 2) 57 | n 58 | (plet ((a (pfib (- n 1))) 59 | (b (pfib (- n 2)))) 60 | (+ a b)))) 61 | 62 | The above code defines the pfib function. 63 | 64 | (time (pfib 25)) 65 | => 75025 66 | Evaluation took: 67 | 0.001 seconds of real time 68 | 0.004000 seconds of total run time (0.004000 user, 0.000000 system) 69 | 400.00% CPU 70 | 2,601,638 processor cycles 71 | 16,560 bytes consed 72 | 73 | See benchmarks for more accurate measurements. Note that a high optimization level inside the defpun form may be required in order to obtain significant speedup. 74 | 75 | How does defpun work? The plet macro has a local definition inside defpun. It expands into two distinct versions of its input: one version is a regular let form and the other is similar to the global plet but with logic added. The strategy resembles Cilk, where a “fast clone” and a “slow clone” are created from the input code. If we imagine a computation as one large tree, the fast clone is responsible for efficiently computing a given subtree while the slow clone is responsible for passing subtrees to the fast clone as parallel tasks and combining the results. 76 | -------------------------------------------------------------------------------- /docs/pmap.md: -------------------------------------------------------------------------------- 1 | pmap 2 | 3 | The pmap family consists of parallelized versions of the Common Lisp mapping functions, each denoted by a ‘p’ prefix. They are: 4 | 5 | pmap 6 | pmap-into 7 | pmapc 8 | pmapcan 9 | pmapcar 10 | pmapcon 11 | pmapl 12 | pmaplist 13 | pmaplist-into 14 | 15 | All take the same arguments and produce the same results as their respective Common Lisp counterparts. pmaplist-into does not actually have a CL counterpart, but it does what you think it does. 16 | 17 | By default pmaps operate on their input sequence(s) in chunks. That is, subsequences of the input sequence(s) are mapped in parallel rather than on a per-element basis. This strategy allows pmaps to be faster than their CL counterparts even in the realm of worst case scenarios (see benchmarks). 18 | 19 | The default number of parallel-mapped parts is the number of worker threads (the number given to make-kernel). All pmaps accept a :parts keyword argument for specifying the number of parts explicitly. 20 | 21 | (defpackage :example (:use :cl :lparallel)) 22 | (in-package :example) 23 | 24 | (pmap 'vector (lambda (x) (* x x)) :parts 2 '(3 4 5)) 25 | ; => #(9 16 25) 26 | 27 | (There is no ambiguity in the arguments because the :parts symbol is not a sequence.) When the number of parts is greater than or equal to the number of elements in the result sequence, the subdividing stage is elided and per-element parallelism is performed directly (an optimization). 28 | 29 | In addition to :parts, all pmaps accept a :size option for specifying the number of elements to be mapped. 30 | 31 | (pmapcar 'identity :size 2 '(a b c d)) ; => (A B) 32 | 33 | (map-into (vector 1 2 3 4) 'identity '(a b)) ; => #(A B 3 4) 34 | (pmap-into (vector 1 2 3 4) 'identity '(a b)) ; => #(A B 3 4) 35 | (pmap-into (vector 1 2 3 4) 'identity :size 2 '(a b c d)) ; => #(A B 3 4) 36 | 37 | As you probably know, map-into disregards the fill pointer (if one exists) of the result sequence when determining the result size. pmap-into behaves the same way, but also allows the result size to be determined by the :size argument. Like map-into, pmap-into will adjust the fill pointer of the result sequence after mapping is complete. 38 | 39 | (let ((vec (make-array 4 :fill-pointer 4 :initial-contents '(1 2 3 4)))) 40 | ;; same as map-into 41 | (pmap-into vec 'identity '(a b))) ; => #(A B) 42 | 43 | (let ((vec (make-array 4 :fill-pointer 4 :initial-contents '(1 2 3 4)))) 44 | (pmap-into vec 'identity :size 2 '(a b c d))) ; => #(A B) 45 | 46 | The :size argument also acts as an optimization for lists. Lists are not an ideal structure for parallel mapping because the subdivision process requires lengths to be known. When :size is given, all length calls are skipped. 47 | 48 | Warning: the value of the :size option must be less than or equal to the length of the smallest sequence passed. It is unspecified what happens when that condition is not met. 49 | 50 | As a rule of thumb, prefer arrays to lists where possible when using the pmap family of functions. In order to make array usage slightly more convenient, pmapcar accepts sequences. That is, (pmapcar ...) is an abbreviation for (pmap 'list ...). 51 | -------------------------------------------------------------------------------- /docs/preduce.md: -------------------------------------------------------------------------------- 1 | preduce 2 | 3 | preduce function sequence &key key from-end start end initial-value parts recurse 4 | 5 | preduce (pronounced pee-reduce) is a parallel version of reduce. It chops up the input sequence into N parts and, in parallel, calls reduce on each part. The N partial results are then reduced again, either by reduce (the default) or, if the :recurse argument is non-nil, by preduce. The default value of N is the number of worker threads (the number given to make-kernel) which may be overridden by the :parts option. 6 | 7 | (defpackage :example (:use :cl :lparallel)) 8 | (in-package :example) 9 | 10 | (preduce '+ #(1 2 3 4 5 6) :parts 2) 11 | 12 | is hand-wavingly similar to 13 | 14 | (reduce '+ (vector (reduce '+ #(1 2 3)) 15 | (reduce '+ #(4 5 6)))) 16 | 17 | This code is misleading, of course: the two inner reduces are done in parallel, and the two inner arrays are displaced versions of the input array (no copying is done). 18 | 19 | In order for the outcome of preduce to be independent of the choice of parts, the function passed must be associative with respect to the sequence elements and must produce an identity-like function when the :initial-value argument (if given) is partially applied. The latter condition is a consequence of :initial-value really meaning initial value per part. 20 | 21 | (preduce '+ #(1 2 3 4 5 6) :parts 1 :initial-value 1) ; => 22 22 | (preduce '+ #(1 2 3 4 5 6) :parts 2 :initial-value 1) ; => 23 23 | (preduce '+ #(1 2 3 4 5 6) :parts 3 :initial-value 1) ; => 24 24 | 25 | In similar fashion, the :from-end option means from the end of each part. 26 | 27 | The :start and :end arguments remain as they are in reduce, referring to the original input sequence. 28 | 29 | The :key argument is thrown out while reducing the partial results. It applies to the first pass only. 30 | 31 | preduce-partial is a variant of preduce which returns the unmolested partial results. 32 | 33 | (preduce-partial '+ #(1 2 3 4 5 6) :parts 2) ; => #(6 15) 34 | (preduce-partial '+ #(1 2 3 4 5 6) :parts 3) ; => #(3 7 11) 35 | 36 | We can use preduce-partial to write premove-if for lists. 37 | 38 | (defun premove-if* (test list) 39 | (reduce 'nreconc 40 | (preduce-partial (lambda (acc x) 41 | (if (funcall test x) 42 | acc 43 | (cons x acc))) 44 | list 45 | :initial-value nil) 46 | :initial-value nil 47 | :from-end t)) 48 | 49 | It works as follows: after the partial results are returned by preduce-partial, each being a list in the reverse order of what we wish, we then walk backwards through the results, reversing and concatenating as we go. 50 | -------------------------------------------------------------------------------- /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 | (defsystem :lparallel 32 | :version "2.8.4" 33 | :description "Parallelism for Common Lisp" 34 | :long-description 35 | " 36 | lparallel is a library for parallel programming in Common Lisp, featuring 37 | 38 | * a simple model of task submission with receiving queue 39 | * constructs for expressing fine-grained parallelism 40 | * asynchronous condition handling across thread boundaries 41 | * parallel versions of map, reduce, sort, remove, and many others 42 | * promises, futures, and delayed evaluation constructs 43 | * computation trees for parallelizing interconnected tasks 44 | * bounded and unbounded FIFO queues 45 | * high and low priority tasks 46 | * task killing by category 47 | * integrated timeouts 48 | 49 | See http://lparallel.org for documentation and examples. 50 | " 51 | :licence "BSD" 52 | :author "James M. Lawrence " 53 | :depends-on (:alexandria 54 | :atomics 55 | :bordeaux-threads 56 | :trivial-cltl2) 57 | :serial t 58 | :components ((:module "src" 59 | :serial t 60 | :components 61 | ((:module "util" 62 | :serial t 63 | :components 64 | ((:file "package") 65 | (:file "config") 66 | (:file "misc") 67 | (:file "defmacro") 68 | (:file "defun") 69 | (:file "defslots") 70 | (:file "defpair"))) 71 | (:file "thread-util") 72 | (:file "raw-queue") 73 | (:file "cons-queue") 74 | (:file "vector-queue") 75 | (:file "queue") 76 | (:file "spin-queue") 77 | (:module "kernel" 78 | :serial t 79 | :components 80 | ((:file "package") 81 | (:file "specials") 82 | (:file "handling") 83 | (:file "classes") 84 | (:file "stealing-scheduler") 85 | (:file "kill") 86 | (:file "core") 87 | (:file "timeout"))) 88 | (:file "kernel-util") 89 | (:file "promise") 90 | (:file "ptree") 91 | (:file "slet") 92 | (:file "defpun") 93 | (:module "cognate" 94 | :serial t 95 | :components 96 | ((:file "package") 97 | (:file "util") 98 | (:file "option") 99 | (:file "subdivide") 100 | (:file "pandor") 101 | (:file "plet") 102 | (:file "pmap") 103 | (:file "pmap-open-coded") 104 | (:file "pdotimes") 105 | (:file "pquantifier") 106 | (:file "preduce") 107 | (:file "premove") 108 | (:file "pfind") 109 | (:file "pcount") 110 | (:file "psort"))) 111 | (:file "package")))) 112 | :in-order-to ((test-op (test-op :lparallel/test)))) 113 | 114 | (defmethod perform :after ((o load-op) (c (eql (find-system :lparallel)))) 115 | (declare (ignore o c)) 116 | (pushnew :lparallel *features*)) 117 | 118 | (defsystem :lparallel/test 119 | :description "Test suite for lparallel." 120 | :licence "BSD" 121 | :author "James M. Lawrence " 122 | :depends-on (:lparallel) 123 | :serial t 124 | :components ((:module "test" 125 | :serial t 126 | :components ((:file "1am") 127 | (:file "package") 128 | (:file "base") 129 | (:file "thread-util-test") 130 | (:file "queue-test") 131 | (:file "kernel-test") 132 | (:file "cognate-test") 133 | (:file "promise-test") 134 | (:file "defpun-test") 135 | (:file "ptree-test")))) 136 | :perform (test-op (o c) (symbol-call :lparallel/test '#:execute))) 137 | 138 | (defsystem :lparallel/bench 139 | :description "Benchmarks for lparallel." 140 | :licence "BSD" 141 | :author "James M. Lawrence " 142 | :depends-on (:lparallel 143 | :trivial-garbage 144 | #+sbcl (:require :sb-sprof)) 145 | :serial t 146 | :components ((:module "bench" 147 | :serial t 148 | :components ((:file "package") 149 | (:file "bench") 150 | (:file "suite") 151 | (:file "profile" :if-feature :sbcl))))) 152 | -------------------------------------------------------------------------------- /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 | (:import-from #:alexandria 42 | #:remove-from-plist 43 | #:simple-style-warning) 44 | (:import-from #:lparallel.slet 45 | #:parse-bindings) 46 | (:import-from #:trivial-cltl2 47 | #:declaration-information) 48 | (:export #:pand 49 | #:pcount 50 | #:pcount-if 51 | #:pcount-if-not 52 | #:pdotimes 53 | #:pevery 54 | #:pfind 55 | #:pfind-if 56 | #:pfind-if-not 57 | #:pfuncall 58 | #:plet 59 | #:plet-if 60 | #:pmap 61 | #:pmapc 62 | #:pmapcan 63 | #:pmapcar 64 | #:pmapcon 65 | #:pmap-into 66 | #:pmapl 67 | #:pmaplist 68 | #:pmaplist-into 69 | #:pmap-reduce 70 | #:pnotany 71 | #:pnotevery 72 | #:por 73 | #:preduce 74 | #:preduce-partial 75 | #:premove 76 | #:premove-if 77 | #:premove-if-not 78 | #:psome 79 | #:psort 80 | #:psort* 81 | #:slet)) 82 | 83 | (in-package #:lparallel.cognate) 84 | -------------------------------------------------------------------------------- /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/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/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 | (tasks :reader tasks :type spin-queue)) 54 | (:documentation 55 | "A worker represents a thread dedicated to executing tasks. See 56 | `kill-tasks' for an explanation of `running-category'. `index' is 57 | the location of the worker in the kernel's vector of workers. 58 | Each worker has its own lockless task queue.")) 59 | 60 | (defslots scheduler () 61 | ((workers :type simple-vector) 62 | (wait-cvar :initform (make-condition-variable)) 63 | (wait-lock :initform (make-lock)) 64 | (wait-count :initform (make-atomic-integer)) 65 | (notify-count :initform 0 :type (integer 0)) 66 | (spin-count :type index) 67 | (random-index :initform 0 :type index) 68 | (low-priority-tasks :initform (make-spin-queue) :type spin-queue)) 69 | (:documentation 70 | "A scheduler is responsible for storing tasks and finding the next 71 | task to execute. A task may also be stolen from the scheduler. 72 | 73 | `workers' -- vector of workers; kernel has the same reference. 74 | 75 | `wait-cvar', `wait-lock', `wait-count', `notify-count' -- these 76 | coordinate waking/sleeping of workers. 77 | 78 | `spin-count' -- see `make-kernel'. 79 | 80 | `random-index' -- some random index to the vector of workers. 81 | 82 | `low-priority-tasks' -- tasks submitted when `*task-priority*' is `:low'.")) 83 | 84 | ;;; The limiter, if in use, places a limit on the number of queued 85 | ;;; tasks. This must be a struct for CAS. The `limiter-accept-task-p' 86 | ;;; flag must be fast/inlined in order to be useful, which is why the 87 | ;;; kernel subclasses directly from this." 88 | #-lparallel.with-debug 89 | (locally (declare #.*full-optimize*) 90 | (atomics:defstruct (limiter (:conc-name nil)) 91 | (limiter-accept-task-p (error "no init") :type boolean) 92 | (limiter-lock (error "no init")) 93 | (limiter-count (error "no init") :type fixnum))) 94 | 95 | ;;; Debug version of limiter can't be a struct since in this case 96 | ;;; `defslots' expands to `defclass'. 97 | #+lparallel.with-debug 98 | (defclass limiter () 99 | ((limiter-accept-task-p :accessor limiter-accept-task-p 100 | :initarg :limiter-accept-task-p 101 | :type boolean) 102 | (limiter-lock :accessor limiter-lock 103 | :initarg :limiter-lock) 104 | (limiter-count :accessor limiter-count 105 | :initarg :limiter-count 106 | :type fixnum))) 107 | 108 | (locally (declare #.*full-optimize*) 109 | (defslots kernel (limiter) 110 | ((scheduler :reader scheduler :type scheduler) 111 | (workers :reader workers :type simple-vector) 112 | (workers-lock) 113 | (worker-info :type worker-info) 114 | (use-caller-p :reader use-caller-p :type boolean) 115 | (alivep :reader alivep :type boolean)) 116 | (:documentation 117 | "The kernel encompasses the scheduling and execution of parallel 118 | tasks using a pool of worker threads. All parallelism in lparallel 119 | is done on top of the kernel."))) 120 | 121 | (defslots channel () 122 | ((queue :reader channel-queue :type queue) 123 | (kernel :reader channel-kernel :type kernel)) 124 | (:documentation 125 | "A task is submitted to the kernel using a channel. A channel 126 | always points to the same kernel, which is the value of `*kernel*' 127 | when the channel is created.")) 128 | 129 | #-lparallel.without-task-categories 130 | (locally (declare #.*full-optimize*) 131 | (defpair task () 132 | ((fn :reader task-fn :type function) 133 | (category :reader task-category)) 134 | (:documentation 135 | "A task consists of a function and a category. See `kill-tasks' for 136 | and explanation of task categories."))) 137 | 138 | #+lparallel.without-task-categories 139 | (progn 140 | (deftype task () 'function) 141 | (defmacro make-task (fn) fn) 142 | (defmacro task-fn (x) x)) 143 | -------------------------------------------------------------------------------- /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 | (let ((kernel *kernel*)) 96 | (when kernel 97 | (unless task-category 98 | (error "Task category cannot be nil in `kill-tasks'.")) 99 | (if dry-run 100 | (count task-category (workers kernel) :key #'running-category) 101 | (kill kernel task-category))))) 102 | -------------------------------------------------------------------------------- /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.spin-queue) 41 | (:import-from #:alexandria 42 | #:simple-style-warning) 43 | (:import-from #:bordeaux-threads-2 44 | #:make-atomic-integer 45 | #:atomic-integer-decf 46 | #:atomic-integer-incf 47 | #:atomic-integer-value) 48 | (:export #:make-kernel 49 | #:check-kernel 50 | #:end-kernel 51 | #:kernel-worker-count 52 | #:kernel-worker-index 53 | #:kernel-bindings 54 | #:kernel-name 55 | #:kernel-context) 56 | (:export #:make-channel 57 | #:submit-task 58 | #:broadcast-task 59 | #:submit-timeout 60 | #:cancel-timeout 61 | #:receive-result 62 | #:try-receive-result 63 | #:do-fast-receives 64 | #:kill-tasks 65 | #:task-handler-bind 66 | #:task-categories-running 67 | #:invoke-transfer-error) 68 | (:export #:*kernel* 69 | #:*kernel-spin-count* 70 | #:*task-category* 71 | #:*task-priority* 72 | #:*debug-tasks-p*) 73 | (:export #:kernel 74 | #:channel 75 | #:transfer-error 76 | #:no-kernel-error 77 | #:kernel-creation-error 78 | #:task-killed-error)) 79 | 80 | (in-package #:lparallel.kernel) 81 | -------------------------------------------------------------------------------- /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/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 | (defun cancel-timeout (timeout timeout-result) 74 | "Attempt to cancel a timeout. If successful, the channel passed to 75 | `submit-timeout' will receive `timeout-result'. 76 | 77 | At most one call to `cancel-timeout' will succeed; others will be 78 | ignored. If the timeout has expired on its own then `cancel-timeout' 79 | will have no effect. 80 | 81 | `submit-timeout' and `cancel-timeout' are deprecated; use the new 82 | `:timeout' option in `try-receive-result'." 83 | (with-timeout-slots (canceled-result thread lock) timeout 84 | ;; ensure that only one cancel succeeds 85 | (with-lock-predicate/wait lock (eq canceled-result 'not-canceled) 86 | (setf canceled-result timeout-result) 87 | (destroy-thread thread))) 88 | nil) 89 | 90 | (defun deprecated-timeout () 91 | (simple-style-warning 92 | "`submit-timeout' and `cancel-timeout' are deprecated; use the new~%~ 93 | `:timeout' option in `try-receive-result'.")) 94 | 95 | (define-compiler-macro submit-timeout (&whole whole &rest args) 96 | (declare (ignore args)) 97 | (deprecated-timeout) 98 | whole) 99 | 100 | (define-compiler-macro cancel-timeout (&whole whole &rest args) 101 | (declare (ignore args)) 102 | (deprecated-timeout) 103 | whole) 104 | -------------------------------------------------------------------------------- /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.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 | (defpackage #:lparallel.spin-queue 50 | (:documentation 51 | "(private) Thread-safe FIFO queue which spins instead of locks.") 52 | (:use #:cl 53 | #:lparallel.util 54 | #:lparallel.thread-util) 55 | (:export #:spin-queue 56 | #:make-spin-queue 57 | #:push-spin-queue 58 | #:pop-spin-queue 59 | #:peek-spin-queue 60 | #:spin-queue-count 61 | #:spin-queue-empty-p)) 62 | 63 | (in-package #:lparallel.spin-queue) 64 | 65 | ;;;; node 66 | 67 | (declaim (inline make-node)) 68 | (defstruct (node (:constructor make-node (car cdr))) 69 | (car (error "no car")) 70 | (cdr (error "no cdr"))) 71 | 72 | ;;;; spin-queue 73 | 74 | (defconstant +dummy+ 'dummy) 75 | (defconstant +dead-end+ 'dead-end) 76 | 77 | (atomics:defstruct (spin-queue (:constructor %make-spin-queue (head tail))) 78 | (head (error "no head")) 79 | (tail (error "no tail"))) 80 | 81 | (defun make-spin-queue () 82 | (let ((dummy (make-node +dummy+ nil))) 83 | (%make-spin-queue dummy dummy))) 84 | 85 | (defun/type push-spin-queue (value queue) (t spin-queue) (values) 86 | ;; Attempt CAS, repeat upon failure. Upon success update QUEUE-TAIL. 87 | (declare #.*full-optimize*) 88 | (let ((new (make-node value nil))) 89 | (loop (when (cas (node-cdr (spin-queue-tail queue)) nil new) 90 | (setf (spin-queue-tail queue) new) 91 | (return (values)))))) 92 | 93 | (defun/type pop-spin-queue (queue) (spin-queue) (values t boolean) 94 | ;; Attempt to CAS QUEUE-HEAD with the next node, repeat upon 95 | ;; failure. Upon success, clear the discarded node and set the CAR 96 | ;; of QUEUE-HEAD to +DUMMY+. 97 | (declare #.*full-optimize*) 98 | (loop (let* ((head (spin-queue-head queue)) 99 | (next (node-cdr head))) 100 | ;; NEXT could be +DEAD-END+, whereupon we try again. 101 | (typecase next 102 | (null (return (values nil nil))) 103 | (node (when (cas (spin-queue-head queue) head next) 104 | (let ((value (node-car next))) 105 | (setf (node-cdr head) +dead-end+ 106 | (node-car next) +dummy+) 107 | (return (values value t))))))))) 108 | 109 | (defun spin-queue-empty-p (queue) 110 | (null (node-cdr (spin-queue-head queue)))) 111 | 112 | (defun try-each-elem (fun queue) 113 | (let ((node (spin-queue-head queue))) 114 | (loop 115 | (let ((value (node-car node))) 116 | (unless (eq value +dummy+) 117 | (funcall fun value))) 118 | (setf node (node-cdr node)) 119 | (cond ((eq node +dead-end+) 120 | (return nil)) 121 | ((null node) 122 | (return t)))))) 123 | 124 | (defun spin-queue-count (queue) 125 | (tagbody 126 | :retry 127 | (let ((count 0)) 128 | (unless (try-each-elem (lambda (elem) 129 | (declare (ignore elem)) 130 | (incf count)) 131 | queue) 132 | (go :retry)) 133 | (return-from spin-queue-count count)))) 134 | 135 | (defun peek-spin-queue (queue) 136 | (loop until (try-each-elem (lambda (elem) 137 | (return-from peek-spin-queue (values elem t))) 138 | queue)) 139 | (values nil nil)) 140 | -------------------------------------------------------------------------------- /src/thread-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.thread-util 32 | (:documentation 33 | "(private) Thread utilities.") 34 | (:use #:cl 35 | #:lparallel.util) 36 | (:import-from #:atomics 37 | #:cas) 38 | (:import-from #:bordeaux-threads-2 39 | #:*default-special-bindings* 40 | #:make-thread 41 | #:make-condition-variable 42 | #:condition-wait 43 | #:condition-notify 44 | #:current-thread 45 | #:destroy-thread 46 | #:make-lock 47 | #:acquire-lock 48 | #:release-lock 49 | #:with-lock-held) 50 | (:export #:with-thread 51 | #:with-lock-predicate/wait 52 | #:with-lock-predicate/no-wait 53 | #:condition-notify 54 | #:cas 55 | #:make-spin-lock 56 | #:with-spin-lock-held) 57 | (:export #:make-lock 58 | #:make-condition-variable 59 | #:with-lock-held 60 | #:condition-wait 61 | #:destroy-thread 62 | #:current-thread)) 63 | 64 | (in-package #:lparallel.thread-util) 65 | 66 | ;;;; spin-lock 67 | 68 | (defun make-spin-lock () 69 | nil) 70 | 71 | (defmacro/once with-spin-lock-held (((access &once container)) &body body) 72 | `(locally (declare #.*full-optimize*) 73 | (unwind-protect/ext 74 | :prepare (loop until (cas (,access ,container) nil t)) 75 | :main (progn ,@body) 76 | :cleanup (setf (,access ,container) nil)))) 77 | 78 | ;;;; general-purpose utilities 79 | 80 | #+clisp 81 | (defmacro with-abort-restart (&body body) 82 | `(restart-case 83 | (progn ,@body) 84 | (abort () 85 | :report "Abort thread."))) 86 | 87 | #-clisp 88 | (defmacro with-abort-restart (&body body) 89 | `(progn ,@body)) 90 | 91 | (defmacro with-thread ((&key bindings name) &body body) 92 | `(let ((*default-special-bindings* (append ,bindings *default-special-bindings*))) 93 | (make-thread (lambda () 94 | (with-abort-restart 95 | ,@body)) 96 | :name ,name))) 97 | 98 | (defmacro with-lock-predicate/no-wait (lock predicate &body body) 99 | ;; predicate intentionally evaluated twice 100 | (with-gensyms (lock-var) 101 | `(when ,predicate 102 | (let ((,lock-var ,lock)) 103 | (when (acquire-lock ,lock-var :wait nil) 104 | (unwind-protect 105 | (when ,predicate 106 | ,@body) 107 | (release-lock ,lock-var))))))) 108 | 109 | (defmacro with-lock-predicate/wait (lock predicate &body body) 110 | ;; predicate intentionally evaluated twice 111 | `(when ,predicate 112 | (with-lock-held (,lock) 113 | (when ,predicate 114 | ,@body)))) 115 | 116 | ;;;; special-purpose utilities 117 | 118 | (defun/inline get-real-time-in-seconds () 119 | (/ (get-internal-real-time) internal-time-units-per-second)) 120 | 121 | (defun %time-remaining (start timeout) 122 | (- timeout 123 | (- (get-real-time-in-seconds) start))) 124 | 125 | (defmacro/once with-countdown ((&once time) &body body) 126 | (with-gensyms (start) 127 | `(let ((,start (get-real-time-in-seconds))) 128 | (flet ((time-remaining () (%time-remaining ,start ,time))) 129 | (declare (inline time-remaining)) 130 | ,@body)))) 131 | 132 | (defmacro define-locking-fn/base (name args arg-types return-type 133 | lock-reader 134 | defun/no-lock 135 | arg-types/no-lock return-type/no-lock 136 | &body body) 137 | (let ((name/no-lock (symbolicate name '#:/no-lock))) 138 | `(progn 139 | (,defun/no-lock ,name/no-lock ,args 140 | ,@(unsplice arg-types/no-lock) 141 | ,@(unsplice return-type/no-lock) 142 | ,@body) 143 | (defun/type ,name ,args ,arg-types ,return-type 144 | (declare #.*full-optimize*) 145 | (with-lock-held ((,lock-reader ,(car (last args)))) 146 | (,name/no-lock ,@args)))))) 147 | 148 | (defmacro define-locking-fn (name args arg-types return-type lock &body body) 149 | `(define-locking-fn/base 150 | ,name ,args ,arg-types ,return-type ,lock 151 | defun/type ,arg-types ,return-type 152 | (declare #.*full-optimize*) 153 | ,@body)) 154 | 155 | (defmacro define-simple-locking-fn (name args arg-types return-type lock 156 | &body body) 157 | `(define-locking-fn/base 158 | ,name ,args ,arg-types ,return-type ,lock 159 | defun/inline nil nil 160 | (declare #.*full-optimize*) 161 | ,@body)) 162 | -------------------------------------------------------------------------------- /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 | (pprint-logical-block (*standard-output* '()) 65 | (multiple-value-prog1 (call-with-random-state fn) 66 | (report test-count *pass-count*))))) 67 | 68 | (defun run (&optional (tests *tests*)) 69 | "Run each test in the sequence `tests'. Default is `*tests*'." 70 | (let ((*running* t)) 71 | (%run (lambda () (map nil #'funcall (shuffle tests))) 72 | (length tests))) 73 | (values)) 74 | 75 | (defun call-test (name fn) 76 | (format t "~@:_~s" name) 77 | (finish-output) 78 | (if *running* 79 | (funcall fn) 80 | (%run fn 1))) 81 | 82 | (defmacro test (name &body body) 83 | "Define a test function and add it to `*tests*'." 84 | `(progn 85 | (defun ,name () 86 | (call-test ',name (lambda () ,@body))) 87 | (pushnew ',name *tests*) 88 | ',name)) 89 | 90 | (defun passed () 91 | (format t "~:_.") 92 | ;; Checks done outside a test run are not tallied. 93 | (when *pass-count* 94 | (incf *pass-count*)) 95 | (values)) 96 | 97 | (defmacro is (form) 98 | "Assert that `form' evaluates to non-nil." 99 | `(progn 100 | (assert ,form) 101 | (passed))) 102 | 103 | (defun %signals (expected fn) 104 | (flet ((handler (condition) 105 | (cond ((typep condition expected) 106 | (passed) 107 | (return-from %signals (values))) 108 | (t (error "Expected to signal ~s, but got ~s:~%~a" 109 | expected (type-of condition) condition))))) 110 | (handler-bind ((condition #'handler)) 111 | (funcall fn))) 112 | (error "Expected to signal ~s, but got nothing." expected)) 113 | 114 | (defmacro signals (condition &body body) 115 | "Assert that `body' signals a condition of type `condition'." 116 | `(%signals ',condition (lambda () ,@body))) 117 | -------------------------------------------------------------------------------- /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 | (with-temp-kernel (n :spin-count (random 5000)) 51 | (funcall body-fn)))) 52 | 53 | (defmacro full-test (name &body body) 54 | `(base-test ,name 55 | (call-full-test ',name (lambda () ,@body)))) 56 | 57 | (defun extract-queue (queue) 58 | (loop until (queue-empty-p queue) 59 | collect (pop-queue queue))) 60 | 61 | (defun invoke-abort-thread () 62 | (flet ((fail () (error "Can't find an abort-like restart in this CL!"))) 63 | (let ((restarts (mapcar #'restart-name (compute-restarts)))) 64 | (if (find 'abort restarts) 65 | (invoke-restart 'abort) 66 | #-sbcl (fail) 67 | #+sbcl (let ((term (find-symbol (string '#:terminate-thread) 68 | 'sb-thread))) 69 | (if (and term (find term restarts)) 70 | (invoke-restart term) 71 | (fail))))))) 72 | 73 | (defun thread-count () 74 | ;; ccl can spontaneously lose the initial thread (issue #1042) 75 | #+ccl (count "Initial" 76 | (bt2:all-threads) 77 | :key #'bt2:thread-name 78 | :test-not #'string=) 79 | #-ccl (length (bt2:all-threads))) 80 | 81 | (defun call-with-thread-count-check (body-fn) 82 | (sleep 0.2) 83 | (let ((old-thread-count (thread-count))) 84 | (funcall body-fn) 85 | (sleep 0.2) 86 | (is (eql old-thread-count (thread-count))))) 87 | 88 | (defmacro with-thread-count-check (&body body) 89 | `(call-with-thread-count-check (lambda () ,@body))) 90 | 91 | (defun infinite-loop () (loop until *nil*)) 92 | 93 | (defmacro collect-n (n &body body) 94 | "Execute `body' `n' times, collecting the results into a list." 95 | `(loop repeat ,n collect (progn ,@body))) 96 | 97 | (defun make-random-list (size) 98 | (collect-n size (random 1.0))) 99 | 100 | (defun make-random-vector (size) 101 | (map-into (make-array size) (lambda () (random 1.0)))) 102 | 103 | (defun compile/muffled (&rest args) 104 | (handler-bind (((or warning 105 | #+ecl c:compiler-note 106 | #+sbcl sb-ext:compiler-note) 107 | #'muffle-warning)) 108 | (with-compilation-unit (:override t) 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 15 60 | do (is (= (fib-let n) (fib-plet n) (fib-plet-if n))))) 61 | 62 | ;;; typed 63 | 64 | (defun/type fib-let/type (n) (fixnum) fixnum 65 | (if (< n 2) 66 | n 67 | (let ((a (fib-let/type (- n 1))) 68 | (b (fib-let/type (- n 2)))) 69 | (+ a b)))) 70 | 71 | (defpun/type fib-plet/type (n) (fixnum) fixnum 72 | (if (< n 2) 73 | n 74 | (plet ((a (fib-plet/type (- n 1))) 75 | (b (fib-plet/type (- n 2)))) 76 | (+ a b)))) 77 | 78 | (defpun/type fib-plet-if/type (n) (fixnum) fixnum 79 | (if (< n 2) 80 | n 81 | (plet-if (> n 5) ((a (fib-plet-if/type (- n 1))) 82 | (b (fib-plet-if/type (- n 2)))) 83 | (+ a b)))) 84 | 85 | (full-test defpun/type-fib-test 86 | (loop for n from 1 to 15 87 | do (is (= (fib-let/type n) (fib-plet/type n) (fib-plet-if/type n))))) 88 | 89 | ;;; redefinitions 90 | 91 | (base-test redefined-defpun-test 92 | (with-temp-kernel (2) 93 | (setf *memo* 'foo) 94 | (handler-bind ((warning #'muffle-warning)) 95 | (eval '(defpun foo (x) (* x x)))) 96 | (is (= 9 (funcall *memo* 3))) 97 | (handler-bind ((warning #'muffle-warning)) 98 | (eval '(defun foo (x) (* x x x)))) 99 | (is (= 27 (funcall *memo* 3))))) 100 | 101 | ;;; forward ref 102 | 103 | (declaim-defpun func1 func2) 104 | 105 | (defpun func2 (x) 106 | (plet ((y (func1 x))) 107 | (* x y))) 108 | 109 | (defpun func1 (x) 110 | (plet ((y (* x x))) 111 | (* x y))) 112 | 113 | (full-test declaim-defpun-test 114 | (is (= 81 (func2 3)))) 115 | 116 | ;;; lambda list keywords 117 | 118 | (defpun foo-append (&key left right) 119 | (if (null left) 120 | right 121 | (plet ((x (first left)) 122 | (y (foo-append :left (rest left) :right right))) 123 | (cons x y)))) 124 | 125 | (full-test defpun-lambda-list-keywords-test 126 | (is (equal '(1 2 3 4 5 6 7) 127 | (foo-append :left '(1 2 3) :right '(4 5 6 7)))) 128 | (is (equal '(1 2 3) 129 | (foo-append :left '(1 2 3) :right nil))) 130 | (is (equal '(1 2 3) 131 | (foo-append :left '(1 2 3)))) 132 | (is (equal '(4 5 6 7) 133 | (foo-append :right '(4 5 6 7)))) 134 | (is (equal nil 135 | (foo-append :right nil))) 136 | (is (equal nil 137 | (foo-append)))) 138 | 139 | ;;; multiple values 140 | 141 | (defpun mv-foo-1 (x y) 142 | (values x y)) 143 | 144 | (defpun/type mv-foo-2 (x y) (fixnum fixnum) (values fixnum fixnum) 145 | (values x y)) 146 | 147 | (defpun mv-foo-3 (x y) 148 | (mv-foo-1 x y)) 149 | 150 | (defpun/type mv-foo-4 (x y) (fixnum fixnum) (values fixnum fixnum) 151 | (mv-foo-2 x y)) 152 | 153 | (defpun/type mv-foo-5 (x y) (fixnum fixnum) (values fixnum fixnum) 154 | (mv-foo-3 x y)) 155 | 156 | (full-test defpun-mv-test 157 | (is (equal '(3 4) (multiple-value-list (mv-foo-1 3 4)))) 158 | (is (equal '(3 4) (multiple-value-list (mv-foo-2 3 4)))) 159 | (is (equal '(3 4) (multiple-value-list (mv-foo-3 3 4)))) 160 | (is (equal '(3 4) (multiple-value-list (mv-foo-4 3 4)))) 161 | (is (equal '(3 4) (multiple-value-list (mv-foo-5 3 4))))) 162 | 163 | (defpun defpun-mv-plet-1 () 164 | (plet (((a b) (floor 5 2)) 165 | (c 9) 166 | d 167 | (e) 168 | ((f g h) (values 6 7 8))) 169 | (declare (type fixnum b c g)) 170 | (list a b c d e f g h))) 171 | 172 | (defpun defpun-mv-plet-2 () 173 | (plet (a (b) ((c)) d (e)) 174 | (declare (type null d)) 175 | (declare (null c)) 176 | (list a b c d e))) 177 | 178 | (full-test defpun-mv-plet-test 179 | (is (equal '(2 1 9 nil nil 6 7 8) (defpun-mv-plet-1))) 180 | (is (equal '(nil nil nil nil nil) (defpun-mv-plet-2)))) 181 | 182 | (defpun defpun-handling-1 () 183 | (plet ((a 3) 184 | (b 4) 185 | (c (restart-case (error 'foo-error) 186 | (four () 5)))) 187 | (+ a b c))) 188 | 189 | (defpun defpun-handling-2 () 190 | (plet ((c (restart-case (error 'foo-error) 191 | (four () 5))) 192 | (a 3) 193 | (b 4)) 194 | (+ a b c))) 195 | 196 | (defpun defpun-handling-3 () 197 | (error 'foo-error)) 198 | 199 | (defpun defpun-handling-4 (n) 200 | (if (< n 2) 201 | (error 'foo-error) 202 | (plet ((a (defpun-handling-4 (- n 1))) 203 | (b (defpun-handling-4 (- n 2)))) 204 | (+ a b)))) 205 | 206 | (full-test defpun-handling-test 207 | (repeat 100 208 | (task-handler-bind ((foo-error (lambda (e) 209 | (declare (ignore e)) 210 | (invoke-restart 'four)))) 211 | (is (= 12 (defpun-handling-1))) 212 | (is (= 12 (defpun-handling-2)))) 213 | (task-handler-bind ((foo-error #'invoke-transfer-error)) 214 | (signals foo-error 215 | (defpun-handling-1)) 216 | (signals foo-error 217 | (defpun-handling-2)) 218 | (signals foo-error 219 | (defpun-handling-3)) 220 | (signals foo-error 221 | (defpun-handling-4 10))))) 222 | 223 | (full-test defpun-priority-test 224 | (let ((*task-priority* :low)) 225 | (repeat 10 226 | (let ((n 25)) 227 | (is (= (fib-let n) (fib-plet n))))))) 228 | -------------------------------------------------------------------------------- /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 | (base-test destroy-thread-cleanup-test 70 | (let* ((cleanedp nil) 71 | (thread (with-thread () 72 | (unwind-protect (sleep 999999) 73 | (setf cleanedp t))))) 74 | (sleep 0.2) 75 | (destroy-thread thread) 76 | (sleep 0.2) 77 | (is (eq t cleanedp)))) 78 | --------------------------------------------------------------------------------