pax_global_header00006660000000000000000000000064127437101120014510gustar00rootroot0000000000000052 comment=9c11f40018155a472c540b63684049acc9b36e15 lparallel-20160825-git/000077500000000000000000000000001274371011200145125ustar00rootroot00000000000000lparallel-20160825-git/CHANGES000066400000000000000000000262131274371011200155110ustar00rootroot00000000000000 lparallel Changes ================= = 2.8.4 * fix compilation error in lparallel-test with recent sbcl = 2.8.3 * handle new sbcl behavior for constant empty arrays in pmap's open coding = 2.8.2 * loop keywords no longer interned into cl-user = 2.8.1 * miscellaneous housekeeping * for ECL, version 16.0.0 or later is now required * fixed a couple tests that failed for ECL or when the compiler's signaling behavior is different (i.e. when the global optimization setting is high) = 2.8.0 * added broadcast-task -- executes a given task inside each worker * added kernel-worker-index -- determine if the current thread is a worker thread, and if so, obtain its assigned index = 2.7.4 * more syntax checking for task-handler-bind * minor housekeeping = 2.7.3 * when the stealing scheduler is enabled (default on SBCL), fixed compiling on non-x86oid SBCL (by Stas Boukarev) = 2.7.2 * deprecated `submit-timeout' and `cancel-timeout'; use the new `:timeout' option in `try-receive-result' which is enabled with the latest bordeaux-threads. * removed eos dependency in lparallel-test = 2.7.1 * when the stealing scheduler is enabled (default on SBCL only), fix stealing when *task-priority* is :low -- affected defpun and some cognates when called from inside a worker thread = 2.7.0 * added the ability to bind multiple values in `plet', e.g. (plet ((x 1) ((y z) (values 2 3))) (+ x y z)) ;=> 6 * added `slet' -- serial/non-parallel `let' with the same syntax as `plet' for binding multiple values * various optimizations = 2.6.2 * updated to the new bordeaux-threads timeout API -- fixes a hole in the new queue timeout feature * fixed a corner case in pmap-into (when no input sequences are passed and the result sequence has a fill pointer that is not at the end) = 2.6.1 * fixed multiple return values being discarded for functions defined by defpun (this is a recent regression only present in 2.6.0) = 2.6.0 * added :timeout option to try-pop-queue and try-receive-result; this requires the latest version of bordeaux-threads (older versions will work as long as :timeout is not used) = 2.5.0 [rescinded] * this added a now-rescinded compatibility layer for the :timeout option in try-pop-queue that caused a hard crash in ccl = 2.4.4 * fixed certain (probably rare) complex uses of task-handler-bind * optimizations from smaller generated code size = 2.4.3 * worked around ECL compiler bug (note the repository ECL is still needed for bordeaux-threads, and ECL still has threading bugs) * removed sbcl-1.1.6 workaround; this version is now prohibited * ptree-lambda-list-keyword-error now reports all lambda list keywords * fixed unbound slot error during ptree-undefined-function-error report when ptree-computed-p or call-ptree passed a nonexistent node = 2.4.2 * printed kernel now shows :use-caller status * various optimizations = 2.4.1 * fixed tests on abcl = 2.4.0 * plet now exploits type declarations * defpun*, defpun/type*, and psort* are now deprecated -- instead use the unstarred versions and pass `:use-caller t' to make-kernel * parallel compilation is now safer = 2.3.7 * fixed a warning on non-sbcl implementations = 2.3.6 * recent workaround for sbcl-1.0.53 now covers all cases = 2.3.5 * added workaround for compilation failure on sbcl-1.0.53 and older * fixed a test for older sbcl versions lacking an `abort' restart = 2.3.4 * improved defpun performance * added workaround for sbcl-1.1.6 issue = 2.3.3 * added support for sbcl-1.0.42 and older on x86 and x86-64 = 2.3.2 * improved stealing scheduler performance = 2.3.1 * issue a compile-time deprecation warning when make-queue or make-channel is called with one argument = 2.3.0 * make-queue and make-channel now accept a :fixed-capacity argument for limiting the number of elements stored * make-queue now accepts an :initial-contents argument * passing a single argument to make-queue or make-channel is deprecated; a &rest hack is present for backward compatibility * added function queue-full-p = 2.2.1 * added lockless queue support for LispWorks; enable it through feature :lparallel.with-stealing-scheduler = 2.2.0 * exported types: kernel, channel, ptree * added ptree-computed-p -- query the computed state of a ptree node * make-kernel now aborts cleanly when a worker fails to initialize, e.g. when make-thread fails or when a :context function aborts * check-kernel now returns a kernel instance * added a front-end lock to some ptree functions -- removes the requirement that some calls be exclusive * improved performance of functions defined by defpun = 2.1.4 * accept function symbols in pcount, pfind, premove * fixed pfind not accepting :test and :test-not = 2.1.3 * fixed image created by ccl:save-application * pnotany and pnotevery now accept a symbol as a predicate = 2.1.2 * The stealing scheduler is now lockless under Clozure CL. This is not enabled by default, as it uses a few unexported symbols in the CCL package. Enable it by adding :lparallel.with-stealing-scheduler to *features*. The latest CCL from svn is required. = 2.1.1 * minor documentation tweaks and other cleanup = 2.1.0 * added readers kernel-name and kernel-context * added restart kill-errors to workers -- removes debugger popups * attempting to submit a task to an ended kernel now signals an error * suicidal calls to kill-tasks inside a worker are now permitted = 2.0.2 * handle *read-default-float-format* in tests and benchmarks = 2.0.1 * improved pmap-into performance on sbcl = 2.0.0 * keyword arguments to psort besides :key have been replaced with a single :granularity argument; the old arguments are now ignored * removed deprecated aliases from 1.2.0 and 1.3.0 (you may not be aware of them since they haven't been listed in the documentation) * A function defined with defpun is now optimized for N worker threads where N is the number of cores. The old behavior is available with defpun*, which defines a function that is optimized for N-1 workers (and has less overhead). * added psort* -- like psort but targets N-1 workers * improved performance of psort * task categories are now compared with eql; same for ptree node ids = 1.7.1 * exiting CCL while a kernel exists no longer generates warnings * preserved lambda list info for a function defined with defpun when no lambda list keywords are present * nested chain calls no longer cause multiple values to be discarded * error for undefined ptree node now signals in the proper context * reduced overhead for promises and futures; other optimizations = 1.7.0 * added pdotimes * optimized cognate functions and macros when they are called inside worker threads; e.g. pmap in (future (pmap ...)) no longer blocks a worker = 1.6.3 * add CLISP support = 1.6.2 * fixed tests on abcl = 1.6.1 * update and clarify docs = 1.6.0 * added clear-ptree-errors -- for resuming after an error * added clear-ptree -- for recomputing from scratch * improved task handling for ptrees * :lparallel now in *features* after load * defpun no longer transforms pfuncall forms = 1.5.5 * in Allegro, end-kernel is no longer required before exit * ptree-fn now accepts non-symbol node identifiers = 1.5.4 * pmaps had sometimes rejected symbol as function = 1.5.3 * Allegro fixed = 1.5.2 * handle nil kernel in task-categories-running * kernel-bindings was returning superfluous bindings = 1.5.1 * disable the new open coding on ABCL, which fails to compile uses of it = 1.5.0 * pmap and pmap-into are now open-coded in the case of 1 vector being mapped to a vector -- allows a large performance boost in some CL implementations (like SBCL) when array types are known * SBCL is now able to terminate when live kernel(s) exist -- previously, end-kernel needed to be called on all kernels before exiting (which is good practice but is no longer required) * added try-receive-result -- non-blocking version of receive-result = 1.4.5 * include fix for sbcl map-into bug #1001043 = 1.4.3 * compensate for upcoming sbcl thread changes (only affects tests) * documentation updates = 1.4.2 * functions defined with defpun now report argument names in slime et al * added defpun/type, typed version of defpun = 1.4.1 * fixed defpun benchmarks = 1.4.0 * added function task-categories-running * new special variable *debug-tasks-p* -- setting it to false will transfer errors instead of invoking the debugger inside tasks; default is true * added convenience function invoke-transfer-error for local control over debugging tasks: (task-handler-bind ((error #'invoke-transfer-error)) ...) (task-handler-bind ((error #'invoke-debugger)) ...) = 1.3.3 * internal cleanup = 1.3.2 * add a few profile functions * doc tweak = 1.3.1 * fixed tests on abcl = 1.3.0 * new support for fine-grained parallelism with `defpun' * new work-stealing model with lockless queues and optional spinning; enabled by default on SBCL, others default to central queue * added pfind, pcount, plet-if, pfuncall * fixed redundant restart in `chain' * `fulfill' now accepts non-promises (never succeeds) * removed high optimizations exposed in some API functions * added shell script for unthrottling CPUs in Linux * renamed *kernel-task-category* -> *task-category* *kernel-task-priority* -> *task-priority* kernel-handler-bind -> task-handler-bind preduce/partial -> preduce-partial old names are still available = 1.2.3 * for promises created with (promise), fixed intermittent error during high contention on some SBCL Linux machines; fixes flood-test failure = 1.2.2 * (pmap nil ...) was accidentally pessimized in the many-parts case = 1.2.1 * more consistent end-kernel behavior -- ensured that no more tasks are executed once an idle state is detected = 1.2.0 * added function cancel-timeout; submit-timeout now returns a timeout object * renamed emergency-kill-tasks to kill-tasks; old name is still available * minor optimization to ptrees * added type checks to psort arguments * switched test framework to eos = 1.1.0 * added :wait option to end-kernel -- block until the kernel has shut down (please read the documentation for end-kernel before using) * bound *print-circle* to t when printing a kernel -- avoids SBCL + SLIME crash when evaluating the single form (setf *kernel* (make-kernel ...)) = 1.0.12 * improved some tests (pmap-into-test, flood-test) * minor cleanup = 1.0.11 * slightly smaller footprint for futures and speculations * better handling of edge cases in some tests = 1.0.10 * fixed a test (sleeping-worker-replacement-test) = 1.0.9 * non-error conditions now recognized during recursive handling = 1.0.8 * handle zero-arity special case for pmap-into and pmaplist-into = 1.0.7 * minor cleanup = 1.0.6 * removed needless kernel handler in delay * various minor cleanup = 1.0.5 * better README and .asd description = 1.0.4 * added description fields to .asd file and augment README * error for an invalid task priority is now correctable = 1.0.3 * benchmarks now working with ABCL * better handling of non-array/non-list result sequences in pmap-into = 1.0.2 * fix non-array/non-list result sequences in pmap-into = 1.0.1 * clarified docs * trivial cleanup = 1.0.0 * birthday lparallel-20160825-git/LICENSE000066400000000000000000000027721274371011200155270ustar00rootroot00000000000000Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the project nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. lparallel-20160825-git/README.md000066400000000000000000000021271274371011200157730ustar00rootroot00000000000000 # lparallel lparallel is a library for parallel programming in Common Lisp, featuring * a simple model of task submission with receiving queue * constructs for expressing fine-grained parallelism * asynchronous condition handling across thread boundaries * parallel versions of map, reduce, sort, remove, and many others * promises, futures, and delayed evaluation constructs * computation trees for parallelizing interconnected tasks * bounded and unbounded FIFO queues * high and low priority tasks * task killing by category * integrated timeouts See http://lparallel.org for documentation and examples. ### Running lparallel should run on any Common Lisp implementation supported by bordeaux-threads. The following implementations successfully pass the test suite: * ABCL * Allegro * Clozure * LispWorks * SBCL To run tests, load `lparallel-test.asd` and call `(lparallel-test:execute)`. To run benchmarks, load `lparallel-bench.asd` and call `(lparallel-bench:execute N)` where `N` is the number of worker threads. ### Author James M. Lawrence lparallel-20160825-git/bench/000077500000000000000000000000001274371011200155715ustar00rootroot00000000000000lparallel-20160825-git/bench/README.md000066400000000000000000000013371274371011200170540ustar00rootroot00000000000000 You may need to unthrottle your CPUs in order to see significant speedup. ### Unthrottling on Linux First run $ sh governor.sh to see a list of available governors along with the current status. A governor called "performance" will presumably be available. To switch to the performance governor, $ sudo sh governor.sh performance Each CPU should now report "performance". After benchmarking you may wish to switch back. If the original setting was "ondemand" then $ sudo sh governor.sh ondemand ### Hyperthreading Hyperthreading may or may not negatively impact benchmarks. If you have hyperthreading enabled, using twice as many workers as CPUs (or some intermediate value) may or may not improve benchmarks. lparallel-20160825-git/bench/bench.lisp000066400000000000000000000075101274371011200175440ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel-bench) ;;;; helpers (defmacro collecting1 (&body body) (with-gensyms (result value) `(let ((,result nil)) (flet ((collect (,value) (push ,value ,result))) ,@body) (nreverse ,result)))) (defun groups-of (n list) (loop for pos on list by (partial-apply 'nthcdr n) collect (subseq pos 0 n))) (defun riffle (groups deck) (apply #'mapcar #'list (groups-of (/ (length deck) groups) deck))) ;;;; wall time #-sbcl (progn (alias-function get-time get-internal-real-time) (defun time-interval (start end) (- end start))) #+sbcl (progn (defun get-time () (multiple-value-list (sb-ext:get-time-of-day))) (defun to-microseconds (time) (destructuring-bind (sec usec) time (+ (* 1000000 sec) usec))) (defun time-interval (start end) (- (to-microseconds end) (to-microseconds start)))) (defun wall-time (fn args) (let ((start (get-time))) (apply fn args) (let ((end (get-time))) (time-interval start end)))) ;;;; bench (defslots bench-spec () ((args-fn :reader args-fn) (exec-fn :reader exec-fn) (desc-fn :reader desc-fn)) (:documentation "A benchmark specification. `args-fn' creates the arguments to be passed to `exec-fn'. The execution time of `exec-fn' is passed to `desc-fn', which returns a descriptive string.")) (alias-function make-bench-spec make-bench-spec-instance) (defun print-chunk (chunk) (format t "~&") (mapc 'princ chunk) (format t "~%")) (defun ping (x) (format t ".") x) (defun bench (num-fns num-trials num-rehearsals specs) "Run bench specs. To minimize GC interactions, all arguments are generated at the outset and each benchmarked function is held constant while the generated argument lists are applied successively. When benchmarks are complete, the rehearsals are discarded and the results are riffled for comparison." (mapc 'print-chunk (mapcar 'flatten (riffle num-fns (mapcar (partial-apply 'nthcdr num-rehearsals) (groups-of num-trials (mapcar 'funcall (mapcar 'desc-fn specs) (mapcar (compose 'ping 'wall-time) (mapcar 'exec-fn specs) (mapcar (compose 'funcall 'args-fn) specs))))))))) lparallel-20160825-git/bench/governor.sh000066400000000000000000000012621274371011200177670ustar00rootroot00000000000000#!/bin/bash govs=`cat /sys/devices/system/cpu/cpu0/cpufreq/scaling_available_governors` echo "available governors:" echo $govs echo echo "current governor on each CPU:" cat /sys/devices/system/cpu/cpu*/cpufreq/scaling_governor echo valid="false" for gov in $govs ; do if [ "$1" = "$gov" ] ; then valid="true" fi done if [ "$valid" = "true" ] ; then echo "changing to $1..." echo for cpu in /sys/devices/system/cpu/cpu*/cpufreq/scaling_governor ; do [ -f $cpu ] || continue echo -n $1 > $cpu done echo "new governor on each CPU:" cat /sys/devices/system/cpu/cpu*/cpufreq/scaling_governor elif [ "$1" != "" ] ; then echo "invalid governor: $1" fi lparallel-20160825-git/bench/package.lisp000066400000000000000000000043131274371011200200560ustar00rootroot00000000000000;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defpackage #:lparallel-bench (:documentation "Benchmarks for lparallel.") (:use #:cl #:lparallel.util #:lparallel.cognate #:lparallel.defpun #:lparallel.kernel) (:import-from #:lparallel.kernel-util #:with-temp-kernel) (:export #:execute) #+sbcl (:export #:profile #:stat-profile) (:export #:with-temp-kernel #:with-wall-time) (:import-from #:trivial-garbage #:gc) (:import-from #:alexandria #:compose #:flatten)) #+sbcl (require :sb-sprof) (in-package #:lparallel-bench) lparallel-20160825-git/bench/profile.lisp000066400000000000000000000065461274371011200201350ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel-bench) ;;;; util (eval-when (:compile-toplevel :load-toplevel :execute) (defun home-symbols (pkg) (loop for sym being the present-symbols in pkg when (eq (find-package pkg) (symbol-package sym)) collect sym)) (defun home-functions (pkg) (remove-if-not #'fboundp (home-symbols pkg))) (defun packages-passing (predicate) (remove-if-not predicate (list-all-packages))) (defun home-functions-in-packages-passing (predicate) (reduce #'nconc (packages-passing predicate) :key #'home-functions)) (defun match-package-p (string pkg) (search string (package-name pkg) :test #'equalp))) (defmacro without-warnings (&body body) `(handler-bind ((warning #'muffle-warning)) ,@body)) ;;;; profile (defmacro profile-fns (syms) `(progn ,@(loop for sym in syms collect `(sb-profile:profile ,sym)))) (defun enable-profiling () (profile-fns #.(home-functions-in-packages-passing (lambda (pkg) (or (match-package-p "lparallel" pkg) (match-package-p "bordeaux-threads" pkg) #+(and sbcl lparallel.with-stealing-scheduler) (match-package-p "sb-concurrency" pkg)))))) (defun profile (&rest args) (without-warnings (enable-profiling)) (sb-profile:reset) (apply #'execute args) (sb-profile:report)) ;;;; stat-profile (defun stat-profile (&rest args) (sb-sprof:with-profiling (:max-samples 100000 :sample-interval (/ sb-sprof:*sample-interval* 2) :report :graph :loop nil :threads :all :show-progress nil) (apply #'execute args))) lparallel-20160825-git/bench/suite.lisp000066400000000000000000000243511274371011200176200ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel-bench) (defparameter *trials* 12) (defparameter *rehearsals* 8) (defparameter *repeat-gc* #-abcl 50 ;; (gc) hangs on abcl #+abcl 0) (defparameter *benches* `((bench-pmap (map pmap) (10 50 100 500 1000 5000 10000 50000 100000 500000) ,*trials* ,*rehearsals*) (bench-preduce (reduce preduce) (10 50 100 500 1000 5000 10000 50000 100000 500000) ;; needs more unthrottling ,(+ 10 *trials*) ,(+ 10 *rehearsals*)) (bench-psort (sort psort) (10 50 100 500 1000 5000 10000 50000 100000 200000) ,*trials* ,*rehearsals*) (bench-pfib (fib-let fib-plet fib-plet-if) (5 10 15 20 25 30 35) ,*trials* ,*rehearsals*) (bench-pmatrix-mul (matrix-mul pmatrix-mul) (5 10 50 100 200) ,*trials* ,*rehearsals*))) (defparameter *use-caller* '(bench-pfib bench-pmatrix-mul bench-psort)) (defparameter *spin-count* 20000) (defun data (name) (rest (find name *benches* :key #'first))) (defun desc-size-op (size op fn time) (format nil "~&size ~6d | op ~8,a | ~10,a ~10,d~%" size op fn time)) (defun desc-n (n fn time) (format nil "~&n ~6d | ~15,a ~8,d~%" n fn time)) (defmacro with-fns (fns &body body) `(let ,(loop for fn in fns collect `(,fn (symbol-function ,fn))) ,@body)) (defun reset () (sleep 0.2) (repeat *repeat-gc* (gc :full t))) (defmacro collect-trials (trials &body body) `(repeat ,trials (collect ,@body))) (defmacro defbench (name params &body body) `(defun ,name () (destructuring-bind ,params (data ',name) ,@body))) (defmacro rebind (vars &body body) `(let ,(mapcar #'list vars vars) ,@body)) (defun make-random-vector (size) (map-into (make-array size :element-type 'single-float) (lambda () (random 1.0f0)))) (defbench bench-pmap (fns inputs trials rehearsals) (bench (length fns) trials rehearsals (collecting1 (dolist (fn fns) (dolist (size inputs) (let ((source (make-random-vector size))) (dolist (op '(sin)) (rebind (fn size op) (collect-trials trials (make-bench-spec :args-fn (lambda () (list source)) :exec-fn (with-fns (op) (lambda (source) (funcall fn `(vector single-float ,size) op source))) :desc-fn (lambda (time) (desc-size-op size op fn time)))))))))))) (defbench bench-psort (fns inputs trials rehearsals) (bench (length fns) trials rehearsals (collecting1 (dolist (fn fns) (dolist (size inputs) (let ((source (make-random-vector size))) (dolist (op '(<)) (rebind (fn size op) (collect-trials trials (make-bench-spec :args-fn (lambda () (list (copy-seq source))) :exec-fn (with-fns (op) (lambda (source) (funcall fn source op))) :desc-fn (lambda (time) (desc-size-op size op fn time)))))))))))) (defbench bench-preduce (fns inputs trials rehearsals) (bench (length fns) trials rehearsals (collecting1 (dolist (fn fns) (dolist (size inputs) (let ((source (make-random-vector size))) (dolist (op '(+)) (rebind (fn size op) (collect-trials trials (make-bench-spec :args-fn (lambda () (list source)) :exec-fn (with-fns (op) (lambda (source) (funcall fn op source))) :desc-fn (lambda (time) (desc-size-op size op fn time)))))))))))) (defun fib-let (n) (declare (optimize (speed 3) (safety 0) (debug 0))) (if (< n 2) n (let ((a (fib-let (- n 1))) (b (fib-let (- n 2)))) (+ a b)))) (defpun fib-plet (n) (declare (optimize (speed 3) (safety 0) (debug 0))) (if (< n 2) n (plet ((a (fib-plet (- n 1))) (b (fib-plet (- n 2)))) (+ a b)))) (defpun fib-plet-if (n) (declare (optimize (speed 3) (safety 0) (debug 0))) (if (< n 2) n (plet-if (> n 15) ((a (fib-plet-if (- n 1))) (b (fib-plet-if (- n 2)))) (+ a b)))) (defbench bench-pfib (fns inputs trials rehearsals) (bench (length fns) trials rehearsals (collecting1 (dolist (fn fns) (dolist (n inputs) (rebind (fn n) (collect-trials trials (make-bench-spec :args-fn (lambda () (list n)) :exec-fn (lambda (n) (funcall fn n)) :desc-fn (lambda (time) (desc-n n fn time)))))))))) ;;; mm (matrix multiply) adapted from Vladimir Sedach's eager-future2, ;;; which in turn credits the following: ;;; ;;; benchmarks from Appendix A of Marc Feeley's PhD dissertation: ;;; Marc Feeley. An Efficient and General Implementation of Futures on ;;; Large Scale Shared-Memory Multiprocessors. PhD thesis, Brandeis ;;; University, April 1993. ;;; http://www.iro.umontreal.ca/~feeley/papers/FeeleyPhD.pdf (defmacro define-mm (name def xlet) `(,def ,name (n m1 m2 m3) ; m1 * m2 -> m3 (declare (optimize (speed 3) (debug 0) (safety 0))) (labels ((compute-entry (row col) ; loop to compute inner product (labels ((compute-loop (i j sum) (if (>= j 0) (compute-loop (- i 1) (- j n) (+ sum (* (aref m1 i) (aref m2 j)))) (setf (aref m3 (+ i 1 col)) sum)))) (compute-loop (+ row n -1) (+ (* n (1- n)) col) 0))) (compute-cols-between (row i j) ; DAC over columns (if (= i j) (compute-entry row i) (let ((mid (floor (+ i j) 2))) (,xlet ((half1 (compute-cols-between row i mid)) (half2 (compute-cols-between row (+ mid 1) j))) half1 half2)))) (compute-rows-between (i j) ; DAC over rows (if (= i j) (compute-cols-between (* i n) 0 (- n 1)) (let ((mid (floor (+ i j) 2))) (,xlet ((half1 (compute-rows-between i mid)) (half2 (compute-rows-between (+ mid 1) j))) half1 half2))))) (compute-rows-between 0 (1- n))))) (define-mm matrix-mul defun let) (define-mm pmatrix-mul defpun plet) (defun run-mm (fn n) (funcall fn n (make-array (* n n) :initial-element 2) (make-array (* n n) :initial-element 2) (make-array (* n n) :initial-element nil))) (defbench bench-pmatrix-mul (fns inputs trials rehearsals) (bench (length fns) trials rehearsals (collecting1 (dolist (fn fns) (dolist (n inputs) (rebind (fn n) (collect-trials trials (make-bench-spec :args-fn (lambda () (list n)) :exec-fn (lambda (n) (run-mm fn n)) :desc-fn (lambda (time) (desc-n n fn time)))))))))) (defun select-benches (fn-names) (mapcar (lambda (name) (assoc (intern (symbol-name name) :lparallel-bench) *benches*)) fn-names)) (defun call-with-temp-kernel (worker-count use-caller fn) (with-temp-kernel (worker-count :spin-count *spin-count* :use-caller use-caller) (funcall fn))) (defvar *last-random-state* nil) (defun execute (num-workers &rest fns) (format t "~%") (when (find :swank *features*) (format t "* Benchmarking with SLIME may produce inaccurate results!~%~%")) (format t "* Have you unthrottled your CPUs? See bench/README.~%~%") (format t "Running benchmarks with ~a workers.~%~%" num-workers) (let ((*random-state* (make-random-state t))) (setf *last-random-state* (make-random-state *random-state*)) (dolist (spec (if fns (select-benches fns) *benches*)) (let ((fn (first spec))) (if (member fn *use-caller*) (call-with-temp-kernel (- num-workers 1) t fn) (call-with-temp-kernel num-workers nil fn)) (reset))))) lparallel-20160825-git/lparallel-bench.asd000066400000000000000000000040711274371011200202320ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defsystem :lparallel-bench :description "Benchmarks for lparallel." :licence "BSD" :author "James M. Lawrence " :depends-on (:lparallel :trivial-garbage) :serial t :components ((:module "bench" :serial t :components ((:file "package") (:file "bench") (:file "suite") #+sbcl (:file "profile"))))) lparallel-20160825-git/lparallel-test.asd000066400000000000000000000047451274371011200201420ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defsystem :lparallel-test :description "Test suite for lparallel." :licence "BSD" :author "James M. Lawrence " :depends-on (:lparallel) :serial t :components ((:module "test" :serial t :components ((:file "1am") (:file "package") (:file "base") (:file "thread-util-test") (:file "queue-test") (:file "kernel-test") (:file "cognate-test") (:file "promise-test") (:file "defpun-test") (:file "ptree-test"))))) (defmethod perform ((o test-op) (c (eql (find-system :lparallel-test)))) (declare (ignore o c)) (funcall (intern (string '#:execute) :lparallel-test))) lparallel-20160825-git/lparallel.asd000066400000000000000000000165111274371011200171570ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (eval-when (:compile-toplevel :load-toplevel :execute) ;; unless otherwise requested, default to stealing scheduler on sbcl #+(and sbcl (not lparallel.without-stealing-scheduler)) (pushnew :lparallel.with-stealing-scheduler *features*) ;; unless otherwise requested, use compare-and-swap optimizations #+(and (or sbcl ccl lispworks) (not lparallel.without-cas) (not lparallel.with-debug)) (pushnew :lparallel.with-cas *features*) ;; plet uses a cltl2 feature #+(or sbcl ccl lispworks allegro) (progn (pushnew :lparallel.with-cltl2 *features*) #+sbcl (require :sb-cltl2)) ;; green threads need calls to yield #+(and allegro (not os-threads)) (pushnew :lparallel.with-green-threads *features*) ;; thread kill does not call unwind-protect cleanup forms #+abcl (pushnew :lparallel.without-kill *features*)) (defsystem :lparallel :version "2.8.4" :description "Parallelism for Common Lisp" :long-description " lparallel is a library for parallel programming in Common Lisp, featuring * a simple model of task submission with receiving queue * constructs for expressing fine-grained parallelism * asynchronous condition handling across thread boundaries * parallel versions of map, reduce, sort, remove, and many others * promises, futures, and delayed evaluation constructs * computation trees for parallelizing interconnected tasks * bounded and unbounded FIFO queues * high and low priority tasks * task killing by category * integrated timeouts See http://lparallel.org for documentation and examples. " :licence "BSD" :author "James M. Lawrence " :depends-on (:alexandria :bordeaux-threads) :serial t :components ((:module "src" :serial t :components ((:module "util" :serial t :components ((:file "package") (:file "config") (:file "misc") (:file "defmacro") (:file "defun") (:file "defslots") (:file "defpair"))) (:file "thread-util") (:file "raw-queue") (:file "cons-queue") (:file "vector-queue") (:file "queue") #-lparallel.with-stealing-scheduler (:file "biased-queue") #+lparallel.with-stealing-scheduler (:file "counter") #+lparallel.with-stealing-scheduler (:module "spin-queue" :serial t :components ((:file "package") #+lparallel.with-cas (:file "cas-spin-queue") #-lparallel.with-cas (:file "default-spin-queue"))) (:module "kernel" :serial t :components ((:file "package") (:file "specials") (:file "handling") (:file "classes") #-lparallel.with-stealing-scheduler (:file "central-scheduler") #+lparallel.with-stealing-scheduler (:file "stealing-scheduler") #-lparallel.without-kill (:file "kill") (:file "core") (:file "timeout"))) (:file "kernel-util") (:file "promise") (:file "ptree") (:file "slet") (:file "defpun") (:module "cognate" :serial t :components ((:file "package") (:file "util") (:file "option") (:file "subdivide") (:file "pandor") (:file "plet") (:file "pmap") #-abcl (:file "pmap-open-coded") (:file "pdotimes") (:file "pquantifier") (:file "preduce") (:file "premove") (:file "pfind") (:file "pcount") (:file "psort"))) (:file "package"))))) (defmethod perform ((o test-op) (c (eql (find-system :lparallel)))) (declare (ignore o c)) (load-system '#:lparallel-test) (test-system '#:lparallel-test)) (defmethod perform :after ((o load-op) (c (eql (find-system :lparallel)))) (declare (ignore o c)) (pushnew :lparallel *features*)) ;;; svref problem in sbcl-1.1.6 #+sbcl (when (string= "1.1.6" (lisp-implementation-version)) (error "Sorry, cannot use lparallel with SBCL 1.1.6; any version but that.")) lparallel-20160825-git/src/000077500000000000000000000000001274371011200153015ustar00rootroot00000000000000lparallel-20160825-git/src/biased-queue.lisp000066400000000000000000000107361274371011200205520ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; Similar to a priority queue but with only two tiers. O(1) ;;; insertion and removal. ;;; (defpackage #:lparallel.biased-queue (:documentation "(private) Blocking two-tiered priority queue.") (:use #:cl #:lparallel.util #:lparallel.thread-util #:lparallel.raw-queue) (:export #:biased-queue #:make-biased-queue #:push-biased-queue #:push-biased-queue/no-lock #:push-biased-queue/low #:push-biased-queue/low/no-lock #:pop-biased-queue #:pop-biased-queue/no-lock #:peek-biased-queue #:peek-biased-queue/no-lock #:biased-queue-empty-p #:biased-queue-empty-p/no-lock #:try-pop-biased-queue #:try-pop-biased-queue/no-lock #:pop-biased-queue #:pop-biased-queue/no-lock #:biased-queue-count #:biased-queue-count/no-lock #:with-locked-biased-queue) (:import-from #:lparallel.thread-util #:define-locking-fn #:define-simple-locking-fn)) (in-package #:lparallel.biased-queue) (defslots biased-queue () ((lock :reader lock :initform (make-lock)) (cvar :reader cvar :initform (make-condition-variable)) (high :reader high :type raw-queue) (low :reader low :type raw-queue))) (defun make-biased-queue (&optional (size 1)) (make-biased-queue-instance :high (make-raw-queue size) :low (make-raw-queue))) (defmacro define-push-fn (name slot) `(define-simple-locking-fn ,name (object queue) (t biased-queue) (values) lock (push-raw-queue object (,slot queue)) (condition-notify (cvar queue)) (values))) (define-push-fn push-biased-queue high) (define-push-fn push-biased-queue/low low) (defmacro define-high-low-fn (name operation) `(define-locking-fn ,name (queue) (biased-queue) (values t boolean) lock (with-biased-queue-slots (high low) queue (multiple-value-bind (object presentp) (,operation high) (if presentp (values object t) (,operation low)))))) (define-high-low-fn try-pop-biased-queue pop-raw-queue) (define-high-low-fn peek-biased-queue peek-raw-queue) (define-locking-fn pop-biased-queue (queue) (biased-queue) t lock (with-biased-queue-slots (lock cvar) queue (loop (multiple-value-bind (value presentp) (try-pop-biased-queue/no-lock queue) (if presentp (return value) (condition-wait cvar lock)))))) (define-simple-locking-fn biased-queue-empty-p (queue) (biased-queue) boolean lock (and (raw-queue-empty-p (high queue)) (raw-queue-empty-p (low queue)))) (define-simple-locking-fn biased-queue-count (queue) (biased-queue) (integer 0) lock (+ (raw-queue-count (high queue)) (raw-queue-count (low queue)))) (defmacro with-locked-biased-queue (queue &body body) `(with-lock-held ((lock ,queue)) ,@body)) lparallel-20160825-git/src/cognate/000077500000000000000000000000001274371011200167215ustar00rootroot00000000000000lparallel-20160825-git/src/cognate/option.lisp000066400000000000000000000047771274371011200211410ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.cognate) (defun get-parts-hint (parts-hint) (cond (parts-hint (check-type parts-hint (integer 1 #.most-positive-fixnum)) parts-hint) (t (kernel-worker-count)))) (defmacro pop-plist (list) `(loop while (keywordp (first ,list)) collect (pop ,list) collect (pop ,list))) (defun %parse-options (args) (destructuring-bind (&key size parts) (pop-plist args) (values args size parts))) (defun parse-options (args) (multiple-value-bind (seqs size parts) (%parse-options args) (unless seqs (error "Input sequence(s) for parallelization not found.")) (unless size (setf size (find-min-length seqs))) (setf parts (get-parts-hint parts)) (values seqs size parts))) (defmacro with-parsed-options ((args size parts) &body body) `(multiple-value-bind (,args ,size ,parts) (parse-options ,args) ,@body)) lparallel-20160825-git/src/cognate/package.lisp000066400000000000000000000054621274371011200212140ustar00rootroot00000000000000;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defpackage #:lparallel.cognate (:documentation "Parallelized versions of some Common Lisp functions.") (:use #:cl #:lparallel.util #:lparallel.kernel #:lparallel.kernel-util #:lparallel.promise #:lparallel.defpun #:lparallel.slet) (:export #:pand #:pcount #:pcount-if #:pcount-if-not #:pdotimes #:pevery #:pfind #:pfind-if #:pfind-if-not #:pfuncall #:plet #:plet-if #:pmap #:pmapc #:pmapcan #:pmapcar #:pmapcon #:pmap-into #:pmapl #:pmaplist #:pmaplist-into #:pmap-reduce #:pnotany #:pnotevery #:por #:preduce #:preduce-partial #:premove #:premove-if #:premove-if-not #:psome #:psort #:psort* #:slet) (:import-from #:alexandria #:remove-from-plist #:simple-style-warning) (:import-from #:lparallel.slet #:parse-bindings)) (in-package #:lparallel.cognate) lparallel-20160825-git/src/cognate/pandor.lisp000066400000000000000000000053261274371011200211030ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.cognate) (defmacro with-forms-submitted (forms &body body) `(with-submit-cancelable ,@(loop for form in forms collect `(submit-cancelable (lambda () ,form))) ,@body)) (defmacro pand (&rest forms) "Parallel version of `and'. Forms in `forms' may be executed in parallel, though not necessarily at the same time. If all forms evaluate to true, then the result of any form may be returned." (with-gensyms (done result next-result) `(block ,done (with-forms-submitted ,forms (let ((,result nil)) (receive-cancelables ,next-result (unless (setf ,result ,next-result) (return-from ,done nil))) ,result))))) (defmacro por (&rest forms) "Parallel version of `or'. Forms in `forms' may be executed in parallel, though not necessarily at the same time. Any form which evaluates to non-nil may be returned." (with-gensyms (done result) `(block ,done (with-forms-submitted ,forms (receive-cancelables ,result (when ,result (return-from ,done ,result))) nil)))) lparallel-20160825-git/src/cognate/pcount.lisp000066400000000000000000000070751274371011200211330ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.cognate) (defun pcount-if (predicate sequence &key from-end (start 0) end key parts) "Parallel version of `count-if'. The `parts' option divides `sequence' into `parts' number of parts. Default is (kernel-worker-count)." (let ((subsize (subsize sequence (length sequence) start end))) (if (zerop subsize) 0 (let ((predicate (ensure-function predicate))) (flet ((maybe-inc (acc x) (declare #.*normal-optimize* (fixnum acc)) (if (funcall predicate x) (the fixnum (1+ acc)) acc))) (declare (ftype (function (fixnum t) fixnum) maybe-inc)) (reduce #'+ (preduce/common #'maybe-inc sequence subsize :initial-value 0 :from-end from-end :start start :key key :parts parts :partial t))))))) (defun pcount-if-not (predicate sequence &rest args &key from-end start end key parts) "Parallel version of `count-if-not'. The `parts' option divides `sequence' into `parts' number of parts. Default is (kernel-worker-count)." (declare (dynamic-extent args) (ignore from-end start end key parts)) (apply #'pcount-if (complement (ensure-function predicate)) sequence args)) (defun pcount (item sequence &key from-end (start 0) end key test test-not parts) "Parallel version of `count'. The `parts' option divides `sequence' into `parts' number of parts. Default is (kernel-worker-count)." (pcount-if (item-predicate item test test-not) sequence :from-end from-end :start start :end end :key key :parts parts)) lparallel-20160825-git/src/cognate/pdotimes.lisp000066400000000000000000000061501274371011200214400ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.cognate) (defun %pdotimes (size parts fn) (declare #.*normal-optimize*) (check-type size fixnum) (when (plusp size) (let ((fn (ensure-function fn))) (flet ((compute-part (part-offset part-size) (declare (type fixnum part-offset part-size)) (let ((index part-offset) (end (+ part-offset part-size))) (declare (type fixnum index end)) (loop while (< index end) do (funcall fn index) (incf index))))) (let ((parts (get-parts-hint parts)) (channel (make-channel))) (with-parts size parts (loop while (next-part) do (submit-task channel #'compute-part (part-offset) (part-size))) (repeat (num-parts) (receive-result channel)))))))) (defmacro/once pdotimes ((var &once count &optional result parts) &body body) "Parallel version of `dotimes'. The `parts' option divides the integer range into `parts' number of parts. Default is (kernel-worker-count). Unlike `dotimes', `pdotimes' does not define an implicit block named nil." (with-parsed-body (body declares) `(progn (%pdotimes ,count ,parts (lambda (,var) ,@declares (tagbody ,@body))) (let ((,var (max ,count 0))) (declare (ignorable ,var)) ,result)))) lparallel-20160825-git/src/cognate/pfind.lisp000066400000000000000000000112521274371011200207130ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.cognate) (defmacro with-pfind-context (sequence start end parts &body body) (with-gensyms (top result) `(block ,top (with-parts (subsize ,sequence (length ,sequence) ,start ,end) (get-parts-hint ,parts) (with-submit-cancelable ,@body (receive-cancelables ,result (when ,result (return-from ,top ,result))) nil))))) (defun pfind-if/vector (predicate sequence &key from-end (start 0) end key parts) (with-pfind-context sequence start end parts (loop with index = start while (next-part) do (submit-cancelable #'find-if predicate sequence :from-end from-end :start index :end (+ index (part-size)) :key key) (incf index (part-size))))) (defun pfind-if/list (predicate sequence &key from-end (start 0) end key parts) (with-pfind-context sequence start end parts (loop with sublist = (nthcdr start sequence) while (next-part) do (submit-cancelable #'find-if predicate sublist :from-end from-end :end (part-size) :key key) (setf sublist (nthcdr (part-size) sublist))))) (defun pfind-if (predicate sequence &rest args &key from-end start end key parts) "Parallel version of `pfind-if'. The `parts' option divides `sequence' into `parts' number of parts. Default is (kernel-worker-count)." (declare (dynamic-extent args) (ignore from-end start end key parts)) (let ((predicate (ensure-function predicate))) (typecase sequence (vector (apply #'pfind-if/vector predicate sequence args)) (list (apply #'pfind-if/list predicate sequence args)) (otherwise (apply #'find-if predicate sequence (remove-from-plist args :parts)))))) (defun pfind-if-not (predicate sequence &rest args &key from-end start end key parts) "Parallel version of `pfind-if-not'. The `parts' option divides `sequence' into `parts' number of parts. Default is (kernel-worker-count)." (declare (dynamic-extent args) (ignore from-end start end key parts)) (apply #'pfind-if (complement (ensure-function predicate)) sequence args)) (defun pfind (item sequence &rest args &key from-end test test-not start end key parts) "Parallel version of `pfind'. The `parts' option divides `sequence' into `parts' number of parts. Default is (kernel-worker-count)." (declare (dynamic-extent args) (ignore from-end start end key parts)) (apply #'pfind-if (item-predicate item test test-not) sequence (remove-from-plist args :test :test-not))) lparallel-20160825-git/src/cognate/plet.lisp000066400000000000000000000250451274371011200205640ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; Future-based `plet'. ;;; Declaration types are allowed inside `plet', mainly for ;;; compatibility with the `plet' in `defpun'. Here they don't matter ;;; as much, but considering that we need to identify the type ;;; declarations anyway, we might as well use them. (in-package #:lparallel.cognate) ;;;; declarationp ;;; `declaration-information' resolves the ambiguity between types and ;;; custom declares -- (declare (type foo x)) may be abbreviated as ;;; (declare (foo x)). #+lparallel.with-cltl2 (progn #-(or sbcl ccl lispworks allegro) (eval-when (:compile-toplevel :load-toplevel :execute) (error "cltl2 not (yet?) enabled for this implementation.")) (defun declaration-information (decl env) (#+sbcl sb-cltl2:declaration-information #+ccl ccl:declaration-information #+lispworks hcl:declaration-information #+allegro sys:declaration-information decl env)) (defun custom-declaration-p (symbol env) (member symbol (declaration-information 'declaration env)))) ;;; When `declaration-information' is not available use `subtypep' ;;; instead. On implementations that have a weak `subtypep', a deftype ;;; that expands to a compound type might not be recognized as a type. ;;; There's no way to solve this portably. The user can avoid this ;;; problem by using the literal `type' declaration instead of ;;; omitting `type' as shortcut. #-lparallel.with-cltl2 (progn (defun known-type-p (symbol) (ignore-errors (nth-value 1 (subtypep symbol nil)))) (defun custom-declaration-p (form env) (declare (ignore env)) (typecase form (symbol (not (known-type-p form)))))) (defparameter *standard-declaration-identifiers* '(dynamic-extent ignore optimize ftype inline special ignorable notinline type)) (defun declarationp (symbol env) (or (member symbol *standard-declaration-identifiers*) (custom-declaration-p symbol env))) ;;;; plet ;;; Terminology: ;;; ;;; declares: ((DECLARE FOO BAR) (DECLARE BAZ)) ;;; corresponding declaration specifiers: (FOO BAR BAZ) (defun zip-repeat (fn list object) (mapcar (lambda (elem) (funcall fn elem object)) list)) (defun decl-spec->typed-vars (decl-spec env) (destructuring-bind (head &rest list) decl-spec (cond ((eq head 'type) (destructuring-bind (type &rest vars) list (zip-repeat #'cons vars type))) ((declarationp head env) nil) (t ;; (foo x) shorthand for (type foo x) (zip-repeat #'cons list head))))) (defun decl-specs->typed-vars (decl-specs env) (loop for decl-spec in decl-specs if (decl-spec->typed-vars decl-spec env) append it into typed-vars else collect decl-spec into non-type-decl-specs finally (return (values typed-vars non-type-decl-specs)))) (defun declares->decl-specs (declares) (loop for (first . rest) in declares do (assert (eq 'declare first)) append rest)) (defun declares->typed-vars (declares env) (decl-specs->typed-vars (declares->decl-specs declares) env)) (defslots binding-datum () (future-result future-var form (vars :reader binding-datum-vars))) (defun make-sv-binding-datum (sv-binding) (destructuring-bind ((var) form) sv-binding (make-binding-datum-instance :vars (list var) :form `(nth-value 0 ,form) :future-result var :future-var (gensym (symbol-name var))))) (defun make-mv-binding-datum (mv-binding) (destructuring-bind (vars form) mv-binding (flet ((sym (prefix) (gensym (format nil "~a/~{~a.~}" prefix vars)))) (make-binding-datum-instance :vars vars :form form :future-result (sym '#:future-result) :future-var (sym '#:future-var))))) (defun partition (predicate list) (loop for x in list if (funcall predicate x) collect x into pass else collect x into fail finally (return (values pass fail)))) (defun make-binding-data (bindings) (multiple-value-bind (normal-bindings null-bindings) (parse-bindings bindings) (multiple-value-bind (sv-bindings mv-bindings) (partition (lambda (binding) (= (length (first binding)) 1)) normal-bindings) (values (mapcar #'make-mv-binding-datum mv-bindings) (mapcar #'make-sv-binding-datum sv-bindings) null-bindings)))) (defun lookup-all (item alist &key (test #'eql)) (loop for (x . y) in alist when (funcall test x item) collect y)) (defun var-type (var typed-vars) `(and ,@(lookup-all var typed-vars))) (defun future-let-binding (binding-datum) (with-binding-datum-slots (future-var form) binding-datum `(,future-var (future ,form)))) (defun future-let-bindings (binding-data) (mapcar #'future-let-binding binding-data)) (defun future-macrolet-binding (typed-vars binding-datum) (with-binding-datum-slots (future-var future-result) binding-datum `(,future-result (the ,(var-type future-result typed-vars) (force ,future-var))))) (defun future-macrolet-bindings (typed-vars binding-data) (mapcar (partial-apply #'future-macrolet-binding typed-vars) binding-data)) (defun %mv-macrolet-bindings (typed-vars mv-binding-datum) (with-binding-datum-slots (vars future-result) mv-binding-datum (loop for var in vars for n from 0 collect `(,var (the ,(var-type var typed-vars) (nth-value ,n ,future-result)))))) (defun mv-macrolet-bindings (typed-vars mv-binding-data) (reduce #'append (mapcar (partial-apply #'%mv-macrolet-bindings typed-vars) mv-binding-data))) (defun binding-decl-spec (typed-vars var) `(type ,(var-type var typed-vars) ,var)) (defun binding-decl-specs (typed-vars vars) (mapcar (partial-apply #'binding-decl-spec typed-vars) vars)) (defun all-binding-vars (binding-data null-bindings) (append (reduce #'append (mapcar #'binding-datum-vars binding-data)) null-bindings)) (defun unknown-typed-vars (typed-vars binding-data null-bindings) (set-difference (mapcar #'car typed-vars) (all-binding-vars binding-data null-bindings))) (defmacro %plet (bindings body &environment env) (with-parsed-body (body declares) (multiple-value-bind (typed-vars non-type-decl-specs) (declares->typed-vars declares env) (multiple-value-bind (mv-binding-data sv-binding-data null-bindings) (make-binding-data bindings) (let ((binding-data (append sv-binding-data mv-binding-data))) (when-let (vars (unknown-typed-vars typed-vars binding-data null-bindings)) (warn "In type declaration for `plet', unrecognized: ~{~s ~^~}" vars)) `(let ,(future-let-bindings binding-data) (symbol-macrolet ,(future-macrolet-bindings typed-vars binding-data) (symbol-macrolet ,(mv-macrolet-bindings typed-vars mv-binding-data) (let ,null-bindings (declare ,@non-type-decl-specs ,@(binding-decl-specs typed-vars null-bindings)) ,@body))))))))) (defmacro plet (bindings &body body) "The syntax of `plet' matches that of `let'. plet ({var-no-init | (var [init-form]) | ((var1 var2 ...) [init-form])}*) declaration* form* For each (var init-form) pair, a future is created which executes `init-form'. Inside `body', `var' is a symbol macro which expands to a `force' form for the corresponding future. Likewise, each ((var1 var2 ...) init-form) pair creates a future where `var1', `var2',... are bound to the respective multiple return values of `init-form'. Each `var-no-init' is bound to nil and each variable without a corresponding `init-form' is bound to nil (no future is created). Type declarations for vars are recognized by `plet' and incorporated into the final expansion. The semantics of these declarations are the same as those of a regular `let' form. `plet' is subject to optimization inside `defpun'." `(%plet ,bindings ,body)) (defmacro plet-if (predicate bindings &body body) "The syntax of `plet-if' matches that of `plet' except for the addition of the `predicate' form. If `predicate' evaluates to true, the behavior is the same as `plet'. If `predicate' evaluates to false, the behavior is the same as `slet'. `plet-if' is subject to optimization inside `defpun'." `(if ,predicate (plet ,bindings ,@body) (slet ,bindings ,@body))) (alias-macro toplevel-plet plet) (defmacro pfuncall (function &rest args) "Parallel version of `funcall'. Arguments in `args' may be executed in parallel, though not necessarily at the same time." (let ((vars (loop for index below (length args) collect (gensym (format nil "~a-~a-" '#:pfuncall-arg index))))) `(toplevel-plet ,(mapcar #'list vars args) (funcall ,function ,@vars)))) lparallel-20160825-git/src/cognate/pmap-open-coded.lisp000066400000000000000000000143401274371011200225640ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.cognate) ;;;; util (defmacro check-symbols (&rest syms) `(progn ,@(loop for sym in syms collect `(check-type ,sym symbol)))) (defmacro defmacro/syms (name params &body body) "Like `defmacro' but requires all parameters to be symbols." (with-parsed-body (body declares docstring) `(defmacro ,name ,params ,@(unsplice docstring) ,@declares (check-symbols ,@params) ,@body))) (defun quotedp (form) (and (consp form) (eq (first form) 'quote))) (defun quoted-vector-type-p (form) (and (quotedp form) ;; I pity nil vector types. Don't you? (not (null (second form))) (subtypep (second form) 'vector))) ;;;; vector-into-vector mapping (defmacro/syms map-into/vector/1-vector/range (dst fn src start end) (with-gensyms (index) `(let ((,index ,start)) (declare (type index ,index)) (loop until (eql ,index ,end) do (setf (aref ,dst ,index) (funcall ,fn (aref ,src ,index))) (incf ,index))))) (defmacro/syms pmap-into/vector/1-vector (dst fn src size parts) (with-gensyms (start end) `(let ((,start 0)) (declare (type index ,start)) (with-parts ,size ,parts (with-submit-counted (loop while (next-part) do (submit-counted (let ((,start ,start) (,end (+ ,start (part-size)))) (declare (type index ,start ,end)) (lambda () (map-into/vector/1-vector/range ,dst ,fn ,src ,start ,end)))) (incf ,start (part-size))) (receive-counted))) (when (array-has-fill-pointer-p ,dst) (setf (fill-pointer ,dst) ,size)) ,dst))) ;;;; PMAP-INTO and PMAP (define-compiler-macro pmap-into (&whole whole result-sequence function &rest args) "Open-coding for 1 vector mapped to vector." (multiple-value-bind (sequences size-form parts-form) (%parse-options args) (if (eql 1 (length sequences)) (with-gensyms (dst fn src size parts) `(let* ((,src ,(first sequences)) (,dst ,result-sequence) (,size (or ,size-form (min (if (and (vectorp ,dst) (array-has-fill-pointer-p ,dst)) (array-total-size ,dst) (length ,dst)) (length ,src)))) (,fn (ensure-function ,function)) (,parts (get-parts-hint ,parts-form))) (if (and (vectorp ,dst) (vectorp ,src) (plusp ,size)) (pmap-into/vector/1-vector ,dst ,fn ,src ,size ,parts) (locally (declare (notinline pmap-into)) (pmap-into ,dst ,fn :size ,size :parts ,parts ,src))))) whole))) (define-compiler-macro pmap (&whole whole result-type function &rest args) "Open-coding for 1 vector mapped to vector." (multiple-value-bind (sequences size-form parts-form) (%parse-options args) (if (and (eql 1 (length sequences)) ;; reject literal result-type of nil, 'list, etc immediately (not (null result-type)) (or (not (quotedp result-type)) (quoted-vector-type-p result-type))) (with-gensyms (dst fn src size parts result-type-value) `(let* ((,src ,(first sequences)) (,size (or ,size-form (length ,src))) (,fn (ensure-function ,function)) (,parts (get-parts-hint ,parts-form)) (,result-type-value ,result-type)) (if ,result-type-value (let ((,dst (make-sequence ;; attempt to use the literal result-type ,(if (quoted-vector-type-p result-type) result-type result-type-value) ,size))) (if (and (vectorp ,dst) (vectorp ,src) (plusp ,size)) (pmap-into/vector/1-vector ,dst ,fn ,src ,size ,parts) (locally (declare (notinline pmap-into)) (pmap-into ,dst ,fn :size ,size :parts ,parts ,src)))) (locally (declare (notinline pmap)) (pmap nil ,fn :size ,size :parts ,parts ,src))))) whole))) lparallel-20160825-git/src/cognate/pmap.lisp000066400000000000000000000255671274371011200205660ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.cognate) (defun pmap-into/parts (map-into result-seq fn seqs size parts-hint) (let ((input-parts (make-input-parts seqs size parts-hint))) (multiple-value-bind (result-parts stitch) (make-result-parts result-seq size parts-hint) (unwind-protect (with-submit-counted (map nil (lambda (result-part subseqs) (submit-counted 'apply map-into result-part fn subseqs)) result-parts input-parts) (receive-counted)) (when stitch (funcall stitch)))))) (defun map-nil (&rest args) (declare (dynamic-extent args)) (apply #'map nil args)) (defun maplist-into (result-list fn &rest lists) "A variation of map-into." (let ((fn (ensure-function fn))) (apply #'mapl (lambda (result &rest args) ;; This is an inner loop. (declare #.*normal-optimize*) (declare (dynamic-extent args)) (setf (car result) (apply fn args))) result-list lists) result-list)) (defun map-iterate (map size fn seqs) "A variation of (map nil ...)/mapc/mapl with size constrained. Without a result to delineate sublist boundaries, we must enforce them manually." (check-type size (integer 0)) (let ((fn (ensure-function fn)) (index 0)) (apply map (lambda (&rest args) ;; This is an inner loop. (declare #.*normal-optimize*) (declare (dynamic-extent args)) (when (eql index size) (return-from map-iterate nil)) (apply fn args) (incf index)) seqs))) (defun pmap-into/powder/array (result-seq fn seqs size) "When a sequence of size N is divided into N parts, it becomes powder." (with-submit-indexed size result-seq (let ((index 0)) (map-iterate #'map-nil size (lambda (&rest args) (declare (dynamic-extent args)) (apply #'submit-indexed index fn args) (incf index)) seqs)) (receive-indexed))) (defun pmap-into/powder/list (map result-seq fn seqs size) (let ((result result-seq)) (with-submit-counted (map-iterate map size (lambda (&rest args) (submit-counted (let ((result result)) (lambda () (setf (car result) (apply fn args))))) (setf result (cdr result))) seqs) (receive-counted)))) (defun pmap-into/powder (map-into result-seq fn seqs size) (etypecase result-seq (array (pmap-into/powder/array result-seq fn seqs size)) (list (let ((map (if (eq map-into #'maplist-into) #'mapl #'map-nil))) (pmap-into/powder/list map result-seq fn seqs size))))) (defun pmap-into/parsed (map-into result-seq fn seqs size parts-hint) (when (plusp size) (if (eql size (find-num-parts size parts-hint)) (pmap-into/powder map-into result-seq fn seqs size) (pmap-into/parts map-into result-seq fn seqs size parts-hint))) result-seq) (defun pmap-into/unparsed (map-into result-seq fn seqs) (multiple-value-bind (seqs size parts-hint) (%parse-options seqs) (let* ((fn (ensure-function fn)) (initial-fill-pointer (and (arrayp result-seq) (array-has-fill-pointer-p result-seq) (fill-pointer result-seq))) (parts-hint (get-parts-hint parts-hint)) (size (or size (let ((limit (if initial-fill-pointer (array-total-size result-seq) (length result-seq)))) (if seqs (min limit (find-min-length seqs)) limit))))) (flet ((main () (if seqs (pmap-into/parsed map-into result-seq fn seqs size parts-hint) (pmap-into/parsed map-into result-seq (lambda (x) (declare #.*normal-optimize*) (declare (ignore x)) (funcall fn)) (list result-seq) size parts-hint)))) (declare (dynamic-extent #'main)) (if initial-fill-pointer (unwind-protect/ext :prepare (setf (fill-pointer result-seq) size) :main (main) :abort (setf (fill-pointer result-seq) initial-fill-pointer)) (main)))))) (defun pmap-into (result-sequence function &rest sequences) "Parallel version of `map-into'. Keyword arguments `parts' and `size' are also accepted (see `pmap')." (typecase result-sequence ((or array list) (pmap-into/unparsed #'map-into result-sequence function sequences)) (t (apply #'map-into result-sequence function sequences))) result-sequence) (defun pmap-iterate/parts (map fn seqs size parts-hint) (let ((input-parts (make-input-parts seqs size parts-hint))) (with-submit-counted (with-parts size parts-hint (dosequence (subseqs input-parts) (next-part) (submit-counted 'map-iterate map (part-size) fn subseqs))) (receive-counted)))) (defun pmap-iterate/powder (map fn seqs size) (with-submit-counted (map-iterate map size (lambda (&rest args) (declare (dynamic-extent args)) (apply #'submit-counted fn args)) seqs) (receive-counted))) (defun pmap-iterate (map fn seqs size parts-hint) (if (eql size (find-num-parts size parts-hint)) (pmap-iterate/powder map fn seqs size) (pmap-iterate/parts map fn seqs size parts-hint)) nil) (defun pmap/parsed (result-type function sequences size parts-hint) (if result-type (pmap-into/parsed #'map-into (make-sequence result-type size) function sequences size parts-hint) ;; (pmap nil ...) (pmap-iterate #'map-nil function sequences size parts-hint))) (defun pmap/unparsed (result-type function sequences) (with-parsed-options (sequences size parts-hint) (pmap/parsed result-type function sequences size parts-hint))) (defun pmap (result-type function &rest sequences) "Parallel version of `map'. Keyword arguments `parts' and `size' are also accepted. The `parts' option divides each sequence into `parts' number of parts. Default is (kernel-worker-count). The `size' option limits the number of elements mapped to `size'. When given, no `length' calls are made on the sequence(s) passed. Warning: `size' 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." (pmap/unparsed result-type function sequences)) (defun pmapcar (function &rest sequences) "Parallel version of `mapcar'. Keyword arguments `parts' and `size' are also accepted (see `pmap'). Unlike `mapcar', `pmapcar' also accepts vectors." (pmap/unparsed 'list function sequences)) (defun pmaplist-into (result-list function &rest lists) "Like `pmaplist' but results are stored in `result-list'. Keyword arguments `parts' and `size' are also accepted (see `pmap')." (pmap-into/unparsed #'maplist-into result-list function lists)) (defun pmaplist (function &rest lists) "Parallel version of `maplist'. Keyword arguments `parts' and `size' are also accepted (see `pmap')." (with-parsed-options (lists size parts-hint) (pmap-into/parsed #'maplist-into (make-list size) function lists size parts-hint))) (defun pmapl (function &rest lists) "Parallel version of `mapl'. Keyword arguments `parts' and `size' are also accepted (see `pmap')." (with-parsed-options (lists size parts-hint) (pmap-iterate #'mapl function lists size parts-hint) (first lists))) (defun pmapc (function &rest lists) "Parallel version of `mapc'. Keyword arguments `parts' and `size' are also accepted (see `pmap')." (with-parsed-options (lists size parts-hint) (pmap-iterate #'mapc function lists size parts-hint) (first lists))) (defun pmapcan (function &rest lists) "Parallel version of `mapcan'. Keyword arguments `parts' and `size' are also accepted (see `pmap')." (declare (dynamic-extent lists)) (apply #'nconc (apply #'pmapcar function lists))) (defun pmapcon (function &rest lists) "Parallel version of `mapcon'. Keyword arguments `parts' and `size' are also accepted (see `pmap')." (declare (dynamic-extent lists)) (apply #'nconc (apply #'pmaplist function lists))) (defun pmap-reduce (map-function reduce-function sequence &rest args &key start end initial-value parts recurse) "Equivalent to (preduce reduce-function sequence :key map-function ...)." (declare (ignore start end initial-value parts recurse)) (declare (dynamic-extent args)) (apply #'preduce reduce-function sequence :key map-function args)) lparallel-20160825-git/src/cognate/pquantifier.lisp000066400000000000000000000071041274371011200221430ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.cognate) (defun pquantifier (quantifier predicate sequences bail) (with-parsed-options (sequences size parts-hint) (let ((input-parts (make-input-parts sequences size parts-hint))) (with-submit-cancelable (dosequence (subseqs input-parts) (submit-cancelable 'apply quantifier predicate subseqs)) (receive-cancelables result (when (eq bail (to-boolean result)) (return-from pquantifier result)))))) (not bail)) (defun pevery (predicate &rest sequences) "Parallel version of `every'. Calls to `predicate' are done in parallel, though not necessarily at the same time. Behavior is otherwise indistinguishable from `every'. Keyword arguments `parts' and `size' are also accepted (see `pmap')." (pquantifier #'every (ensure-function predicate) sequences nil)) (defun psome (predicate &rest sequences) "Parallel version of `some'. Calls to `predicate' are done in parallel, though not necessarily at the same time. Behavior is otherwise indistinguishable from `some' except that any non-nil predicate comparison result may be returned. Keyword arguments `parts' and `size' are also accepted (see `pmap')." (pquantifier #'some (ensure-function predicate) sequences t)) (defun pnotevery (predicate &rest sequences) "Parallel version of `notevery'. Calls to `predicate' are done in parallel, though not necessarily at the same time. Behavior is otherwise indistinguishable from `notevery'. Keyword arguments `parts' and `size' are also accepted (see `pmap')." (declare (dynamic-extent sequences)) (not (apply #'pevery predicate sequences))) (defun pnotany (predicate &rest sequences) "Parallel version of `notany'. Calls to `predicate' are done in parallel, though not necessarily at the same time. Behavior is otherwise indistinguishable from `notany'. Keyword arguments `parts' and `size' are also accepted (see `pmap')." (declare (dynamic-extent sequences)) (not (apply #'psome predicate sequences))) lparallel-20160825-git/src/cognate/preduce.lisp000066400000000000000000000151721274371011200212470ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.cognate) (defmacro with-preduce-context (size parts &body body) (with-gensyms (results) `(with-parts ,size ,parts (let ((,results (make-array (num-parts)))) (with-submit-indexed (num-parts) ,results ,@body (receive-indexed)))))) (defun preduce-partial/vector (function sequence start size parts &rest keyword-args) (declare (dynamic-extent keyword-args)) (with-preduce-context size parts (loop for result-index from 0 while (next-part) do (apply #'submit-indexed result-index #'reduce function sequence :start (+ start (part-offset)) :end (+ start (part-offset) (part-size)) keyword-args)))) (defun preduce-partial/list (function sequence start size parts &rest keyword-args) (declare (dynamic-extent keyword-args)) (with-preduce-context size parts (loop with subseq = (nthcdr start sequence) for result-index from 0 while (next-part) do (apply #'submit-indexed result-index #'reduce function subseq :end (part-size) keyword-args) (setf subseq (nthcdr (part-size) subseq))))) (defun %preduce-partial (function sequence start size parts &rest keyword-args) (declare (dynamic-extent keyword-args)) (etypecase sequence (vector (apply #'preduce-partial/vector function sequence start size parts keyword-args)) (list (apply #'preduce-partial/list function sequence start size parts keyword-args)))) (defun preduce/common (function sequence subsize &key key from-end (start 0) end (initial-value nil initial-value-given-p) parts recurse partial) (declare (ignore end)) (cond ((zerop subsize) (when partial (error "PREDUCE-PARTIAL given zero-length sequence")) (if initial-value-given-p initial-value (funcall function))) (t (let* ((parts-hint (get-parts-hint parts)) (results (apply #'%preduce-partial function sequence start subsize parts-hint :key key :from-end from-end (when initial-value-given-p (list :initial-value initial-value))))) (if partial results (let ((new-size (length results))) (if (and recurse (>= new-size 4)) (apply #'preduce/common function results new-size :from-end from-end :parts (min parts-hint (floor new-size 2)) :recurse recurse (when initial-value-given-p (list :initial-value initial-value))) (reduce function results)))))))) (defun preduce (function sequence &rest args &key key from-end (start 0) end initial-value parts recurse) "Parallel version of `reduce'. `preduce' subdivides the input sequence into `parts' number of parts and, in parallel, calls `reduce' on each part. The partial results are then reduced again, either by `reduce' (the default) or, if `recurse' is non-nil, by `preduce'. `parts' defaults to (kernel-worker-count). `key' is thrown out while reducing the partial results. It applies to the first pass only. `start' and `end' have the same meaning as in `reduce'. `from-end' means \"from the end of each part\". `initial-value' means \"initial value of each part\"." (declare (ignore key from-end initial-value parts recurse)) (declare (dynamic-extent args)) (typecase sequence ((or vector list) (apply #'preduce/common function sequence (subsize sequence (length sequence) start end) args)) (otherwise (apply #'reduce function sequence (remove-from-plist args :parts :recurse))))) (defun preduce-partial (function sequence &rest args &key key from-end (start 0) end initial-value parts) "Like `preduce' but only does a single reducing pass. The length of `sequence' must not be zero. Returns the partial results as a vector." (declare (ignore key from-end initial-value parts)) (declare (dynamic-extent args)) (apply #'preduce/common function sequence (subsize sequence (length sequence) start end) :partial t args)) lparallel-20160825-git/src/cognate/premove.lisp000066400000000000000000000112741274371011200212740ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.cognate) (defun premove-if-not/list (test list from-end start end key parts) (let* ((size (length list)) (subsize (subsize list size start end))) (if (zerop subsize) nil (let ((test (ensure-function test)) (leading (subseq list 0 start)) (trailing (if (or (null end) (eql subsize (- size start))) nil (copy-list (nthcdr end list))))) (nconc leading (reduce #'nreconc (preduce/common (lambda (acc x) (declare #.*normal-optimize*) (if (funcall test x) (cons x acc) acc)) (nthcdr start list) subsize :initial-value nil :key key :parts parts :from-end from-end :partial t) :initial-value trailing :from-end t)))))) (defun premove-if-not (test sequence &rest args &key from-end (start 0) end key parts) "Parallel version of `remove-if-not'. Note the `count' option is not supported. The `parts' option divides `sequence' into `parts' number of parts. Default is (kernel-worker-count)." (declare (dynamic-extent args)) (typecase sequence (list (premove-if-not/list test sequence from-end start end key parts)) (otherwise (apply #'remove-if-not test sequence args)))) (defun premove-if (test sequence &rest args &key from-end (start 0) end key parts) "Parallel version of `remove-if'. Note the `count' option is not supported. The `parts' option divides `sequence' into `parts' number of parts. Default is (kernel-worker-count)." (declare (dynamic-extent args)) (typecase sequence (list (premove-if-not/list (complement (ensure-function test)) sequence from-end start end key parts)) (otherwise (apply #'remove-if test sequence (remove-from-plist args :parts))))) (defun premove (item sequence &rest args &key test test-not from-end (start 0) end key parts) "Parallel version of `remove'. Note the `count' option is not supported. The `parts' option divides `sequence' into `parts' number of parts. Default is (kernel-worker-count)." (declare (dynamic-extent args)) (typecase sequence (list (premove-if-not/list (complement (item-predicate item test test-not)) sequence from-end start end key parts)) (otherwise (apply #'remove item sequence (remove-from-plist args :parts))))) lparallel-20160825-git/src/cognate/psort.lisp000066400000000000000000000152561274371011200207720ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.cognate) (defun/type/inline midpoint (a b) (fixnum fixnum) fixnum (declare #.*full-optimize*) (+ a (the fixnum (ash (the fixnum (- b a)) -1)))) ;;; ;;; Adapted from Roger Corman's usenet post. Free license. ;;; (defmacro define-quicksort-fn (name call-key key key-type gran gran-type) `(defpun/type ,name (vec lo hi compare ,@(unsplice gran) ,@(unsplice key)) (vector fixnum fixnum function ,@(unsplice gran-type) ,@(unsplice key-type)) (values) (declare #.*full-optimize*) #+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) (when (> hi lo) (let* ((mid (the fixnum (midpoint lo hi))) (i lo) (j (the fixnum (1+ hi))) (p (,call-key (aref vec mid)))) (declare (type fixnum mid i j)) (rotatef (aref vec mid) (aref vec lo)) (loop (loop do (incf i) until (or (> i hi) (funcall compare p (,call-key (aref vec i))))) (loop do (decf j) until (or (<= j lo) (funcall compare (,call-key (aref vec j)) p))) (when (< j i) (return)) (rotatef (aref vec i) (aref vec j))) (rotatef (aref vec lo) (aref vec j)) ,(let ((left `(,name vec lo (the fixnum (1- j)) compare ,@(unsplice gran) ,@(unsplice key))) (right `(,name vec i hi compare ,@(unsplice gran) ,@(unsplice key)))) (if gran `(let ((left-size (the fixnum (- j lo)))) (declare (type fixnum left-size)) (if (> left-size ,gran) (plet ((left-result ,left) (right-result ,right)) (declare (ignore left-result right-result))) (let ((right-size (the fixnum (1+ (the fixnum (- hi i)))))) (declare (type fixnum right-size)) (if (> right-size ,gran) (plet ((right-result ,right) (left-result ,left)) (declare (ignore left-result right-result))) (cond ((< left-size right-size) ,left ,right) (t ,right ,left)))))) `(plet ((right-result ,right) (left-result ,left)) (declare (ignore right-result left-result))))))) (values))) (defmacro define-quicksort-fns () (with-gensyms (iden call-key key gran) `(macrolet ((,iden (x) x) (,call-key (x) `(funcall ,',key ,x))) (define-quicksort-fn quicksort/no-key/no-gran ,iden nil nil nil nil) (define-quicksort-fn quicksort/no-key/gran ,iden nil nil ,gran fixnum) (define-quicksort-fn quicksort/key/no-gran ,call-key ,key function nil nil) (define-quicksort-fn quicksort/key/gran ,call-key ,key function ,gran fixnum)))) (define-quicksort-fns) ;;; reduce some clutter in defpun expansions; it's safe to remove ;;; these because users should not call them directly (lparallel.defpun::delete-registered-names '(quicksort/no-key/no-gran quicksort/no-key/gran quicksort/key/no-gran quicksort/key/gran)) (defun call-quicksort (vec lo hi compare granularity key) (if key (if granularity (quicksort/key/gran vec lo hi compare granularity key) (quicksort/key/no-gran vec lo hi compare key)) (if granularity (quicksort/no-key/gran vec lo hi compare granularity) (quicksort/no-key/no-gran vec lo hi compare)))) (defun psort (sequence predicate &key key granularity &allow-other-keys) (typecase sequence (vector (when granularity (check-type granularity fixnum)) (call-quicksort sequence 0 (1- (length sequence)) (ensure-function predicate) granularity (and key (ensure-function key))) sequence) (otherwise (sort sequence predicate :key key)))) (setf (documentation 'psort 'function) "Parallel version of `sort'. If `granularity' is provided then parallel tasks are created only for segments larger than `granularity'. This may or may not result in better performance. At present `psort' is only parallelized for vectors; other types are given to `cl:sort'.") (defun psort* (&rest args) "Deprecated. Instead use `psort' and pass `:use-caller t' to `make-kernel'." (apply #'psort args)) (define-compiler-macro psort* (&whole whole &rest args) (declare (ignore args)) (simple-style-warning "`psort*' is deprecated. Instead use `psort' and pass ~ `:use-caller t' to `make-kernel'.") whole) lparallel-20160825-git/src/cognate/subdivide.lisp000066400000000000000000000112411274371011200215670ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.cognate) (defun find-num-parts (size parts-hint) (multiple-value-bind (quo rem) (floor size parts-hint) (values (if (zerop quo) rem parts-hint) quo rem))) (defmacro with-parts (seq-size parts-hint &body body) (with-gensyms (quo rem index num-parts part-offset part-size) `(multiple-value-bind (,num-parts ,quo ,rem) (find-num-parts ,seq-size ,parts-hint) (declare (fixnum ,num-parts ,quo ,rem)) (let ((,index 0) (,part-offset 0) (,part-size 0)) (declare (fixnum ,index ,part-offset ,part-size)) (flet ((next-part () (when (< ,index ,num-parts) (unless (zerop ,index) (incf ,part-offset ,part-size)) (setf ,part-size (if (< ,index ,rem) (1+ ,quo) ,quo)) (incf ,index))) (part-size () ,part-size) (part-offset () ,part-offset) (num-parts () ,num-parts)) (declare (inline part-size part-offset num-parts) (ignorable #'part-size #'part-offset #'num-parts)) ,@body))))) (defun subdivide-array (array size parts-hint) (with-parts size parts-hint (map-into (make-array (num-parts)) (lambda () (next-part) (make-array (part-size) :displaced-to array :displaced-index-offset (part-offset) :element-type (array-element-type array)))))) (defun subdivide-list (list size parts-hint) (with-parts size parts-hint (loop with p = list while (next-part) collect p do (setf p (nthcdr (part-size) p))))) (defun subdivide-list/slice (list size parts-hint) (with-parts size parts-hint (loop with p = list while (next-part) collect p into firsts collect (prog1 (setf p (nthcdr (1- (part-size)) p)) (setf p (prog1 (cdr p) (setf (cdr p) nil)))) into lasts finally (return (values firsts (lambda () ;; stitch it back together (loop for last in lasts for first in (cdr firsts) do (setf (cdr last) first) finally (setf (cdr last) p)))))))) (defun make-parts (result size parts-hint &key slicep) (if (listp result) (funcall (if slicep #'subdivide-list/slice #'subdivide-list) result size parts-hint) (subdivide-array result size parts-hint))) (defun make-result-parts (result size parts-hint) "Subdivide the result sequence. For a list, delineate boundaries by slicing." (make-parts result size parts-hint :slicep t)) (defun make-input-parts (sequences size parts-hint) "Subdivide and interleave sequences for parallel mapping." (zip/vector (mapcar (lambda (seq) (make-parts seq size parts-hint)) sequences))) lparallel-20160825-git/src/cognate/util.lisp000066400000000000000000000051521274371011200205720ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.cognate) (defun zip/vector (seqs) (apply #'map 'vector #'list seqs)) (defun find-min-length (seqs) (reduce #'min seqs :key #'length)) (defun item-predicate (item test test-not) (when (and test test-not) (error "Both :TEST and :TEST-NOT options given.")) (when test-not (setf test (complement (ensure-function test-not))) (setf test-not nil)) (if test (let ((test (ensure-function test))) (lambda (x) (declare #.*normal-optimize*) (funcall test item x))) (typecase item ((or number character) (lambda (x) (declare #.*full-optimize*) (eql item x))) (otherwise (lambda (x) (declare #.*full-optimize*) (eq item x)))))) (defun subsize (seq size start end) (let ((result (- (or end size) start))) (when (or (minusp result) (> result size)) (error "Bad interval for sequence operation on ~a: start=~a end=~a" seq start end)) result)) lparallel-20160825-git/src/cons-queue.lisp000066400000000000000000000132521274371011200202610ustar00rootroot00000000000000;;; Copyright (c) 2011-2013, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defpackage #:lparallel.cons-queue (:documentation "(private) Blocking infinite-capacity queue.") (:use #:cl #:lparallel.util #:lparallel.thread-util #:lparallel.raw-queue) (:export #:cons-queue #:make-cons-queue #:push-cons-queue #:push-cons-queue/no-lock #:pop-cons-queue #:pop-cons-queue/no-lock #:peek-cons-queue #:peek-cons-queue/no-lock #:cons-queue-count #:cons-queue-count/no-lock #:cons-queue-empty-p #:cons-queue-empty-p/no-lock #:try-pop-cons-queue #:try-pop-cons-queue/no-lock #:with-locked-cons-queue) (:import-from #:lparallel.thread-util #:define-locking-fn #:define-simple-locking-fn #:with-countdown #:time-remaining)) (in-package #:lparallel.cons-queue) (defslots cons-queue () ((impl :reader impl :type raw-queue) (lock :reader lock :initform (make-lock)) (cvar :initform nil))) (defun %make-cons-queue () (make-cons-queue-instance :impl (make-raw-queue))) (defmacro with-locked-cons-queue (queue &body body) `(with-lock-held ((lock ,queue)) ,@body)) (define-locking-fn push-cons-queue (object queue) (t cons-queue) (values) lock (with-cons-queue-slots (impl cvar) queue (push-raw-queue object impl) (when cvar (condition-notify cvar))) (values)) (define-locking-fn pop-cons-queue (queue) (cons-queue) t lock (with-cons-queue-slots (impl lock cvar) queue (loop (multiple-value-bind (value presentp) (pop-raw-queue impl) (if presentp (return value) (condition-wait (or cvar (setf cvar (make-condition-variable))) lock)))))) (defun %try-pop-cons-queue/no-lock/timeout (queue timeout) ;; queue is empty and timeout is positive (declare #.*full-optimize*) (with-countdown (timeout) (with-cons-queue-slots (impl lock cvar) queue (loop (multiple-value-bind (value presentp) (pop-raw-queue impl) (when presentp (return (values value t))) (let ((time-remaining (time-remaining))) (when (or (not (plusp time-remaining)) (null (condition-wait (or cvar (setf cvar (make-condition-variable))) lock :timeout time-remaining))) (return (values nil nil))))))))) (defun try-pop-cons-queue/no-lock/timeout (queue timeout) (declare #.*full-optimize*) (with-cons-queue-slots (impl) queue (if (raw-queue-empty-p impl) (%try-pop-cons-queue/no-lock/timeout queue timeout) (pop-raw-queue impl)))) (defun try-pop-cons-queue (queue timeout) (declare #.*full-optimize*) (with-cons-queue-slots (impl lock) queue (cond ((plusp timeout) (with-lock-held (lock) (try-pop-cons-queue/no-lock/timeout queue timeout))) (t ;; optimization: don't lock if nothing is there (with-lock-predicate/wait lock (not (raw-queue-empty-p impl)) (return-from try-pop-cons-queue (pop-raw-queue impl))) (values nil nil))))) (defun try-pop-cons-queue/no-lock (queue timeout) (declare #.*full-optimize*) (if (plusp timeout) (try-pop-cons-queue/no-lock/timeout queue timeout) (pop-raw-queue (impl queue)))) (defmacro define-queue-fn (name arg-types raw return-type) `(define-simple-locking-fn ,name (queue) ,arg-types ,return-type lock (,raw (impl queue)))) (define-queue-fn cons-queue-count (cons-queue) raw-queue-count raw-queue-count) (define-queue-fn cons-queue-empty-p (cons-queue) raw-queue-empty-p boolean) (define-queue-fn peek-cons-queue (cons-queue) peek-raw-queue (values t boolean)) (defun make-cons-queue (&key initial-contents) (let ((queue (%make-cons-queue))) (when initial-contents (flet ((push-elem (elem) (push-cons-queue/no-lock elem queue))) (declare (dynamic-extent #'push-elem)) (map nil #'push-elem initial-contents))) queue)) lparallel-20160825-git/src/counter.lisp000066400000000000000000000073601274371011200176570ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defpackage #:lparallel.counter (:documentation "(private) Atomic counter.") (:use #:cl #:lparallel.util #:lparallel.thread-util) (:export #:counter #:make-counter #:inc-counter #:dec-counter #:counter-value)) (in-package #:lparallel.counter) ;;; Atomic counters modeled after SBCL, i.e., operations return the ;;; original value. #+sbcl (progn ;; try to avoid using sb-ext:word since it is newish (deftype counter-value () #+(or x86-64 x86) '(unsigned-byte #+x86-64 64 #+x86 32) #-(or x86-64 x86) 'sb-ext:word) (defstruct (counter (:constructor make-counter (&optional value))) (value 0 :type counter-value)) (defmacro define-counter-fn (name op) `(defun/inline ,name (counter) (,op (counter-value counter)))) (define-counter-fn inc-counter sb-ext:atomic-incf) (define-counter-fn dec-counter sb-ext:atomic-decf)) #+(or ccl lispworks) (progn (deftype counter () 'cons) (defun make-counter (&optional (value 0)) (cons value nil)) (alias-function counter-value car) (defmacro define-counter-fn (name op adjust) `(defun/inline ,name (counter) (,adjust (,op (car counter))))) ;;; Strangely, Clozure does advertise these atomic operations but does ;;; not export the symbols. (define-counter-fn inc-counter #+ccl ccl::atomic-incf #+lispworks system:atomic-incf 1-) (define-counter-fn dec-counter #+ccl ccl::atomic-decf #+lispworks system:atomic-decf 1+)) #-(or sbcl ccl lispworks) (progn (defslots counter () ((value :reader counter-value) (lock :reader lock :initform (make-lock)))) (defun make-counter (&optional (value 0)) (make-counter-instance :value value)) (defmacro define-counter-fn (name op adjust) `(defun/inline ,name (counter) (with-counter-slots (value lock) counter (,adjust (with-lock-held (lock) (,op value)))))) (define-counter-fn inc-counter incf 1-) (define-counter-fn dec-counter decf 1+)) lparallel-20160825-git/src/defpun.lisp000066400000000000000000000375341274371011200174670ustar00rootroot00000000000000;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defpackage #:lparallel.defpun (:documentation "Fine-grained parallelism.") (:use #:cl #:lparallel.util #:lparallel.kernel #:lparallel.thread-util #:lparallel.slet) (:export #:defpun #:defpun* #:defpun/type #:defpun/type* #:declaim-defpun #:plet #:plet-if #:slet) (:import-from #:alexandria #:simple-style-warning) (:import-from #:lparallel.util #:symbolicate/package) (:import-from #:lparallel.slet #:make-binding-data #:parse-bindings) (:import-from #:lparallel.kernel #:*worker* #:*make-limiter-data* #:kernel #:use-caller-p #:unwrap-result #:call-with-task-handler #:limiter-accept-task-p #:limiter-count #:limiter-lock #:submit-raw-task #:make-task #:task-lambda #:wrapped-error #:with-task-context #:steal-work)) (in-package #:lparallel.defpun) ;;;; function registration ;;; defpun relies upon the inlined accept-task-p call in order to ;;; achieve speedup, which means that *kernel* must exist before the ;;; call takes place. If *kernel* is nil, the error may be confusing ;;; due to inlining and optimizations. Inserting `check-kernel' into ;;; the body of defpun functions negates the speedup for small ;;; functions. ;;; ;;; Thus for user-friendliness we define checked and unchecked ;;; functions for each defpun form. The user calls the checked ;;; version; defpun calls the unchecked one via a macrolet. ;;; ;;; The macrolets also have the happy side-effect of preventing ;;; reference to the checked (slower) function via #'. ;;; ;;; We store references to the checked and unchecked functions in ;;; order to detect redefinitions with defun or otherwise. (defconstant +checked-key+ 'checked-key) (defconstant +unchecked-key+ 'unchecked-key) (defvar *registered-names* nil) (defvar *registration-lock* (make-lock)) (defun unchecked-name (name) ;; We could intern this into a private package and maintain an alist ;; of (public . private) package pairs, but that seems ;; over-engineered. Anonymous packages don't exist anyway. (symbolicate/package (symbol-package name) '#:%%%%.defpun. name) ) (defun register-name (name) (pushnew name *registered-names*)) (defun register-fn (name) (setf (get name +checked-key+) (symbol-function name)) (setf (get name +unchecked-key+) (symbol-function (unchecked-name name)))) (defun registered-fn-p (name) (get name +checked-key+)) (defun valid-registered-fn-p (name) (and (fboundp name) (eq (symbol-function name) (get name +checked-key+)) (fboundp (unchecked-name name)) (eq (symbol-function (unchecked-name name)) (get name +unchecked-key+)))) ;;; a name may be registered without having a corresponding function (defun valid-registered-name-p (name) (and (symbol-package name) (or (not (registered-fn-p name)) (valid-registered-fn-p name)))) (defun delete-stale-registrations () (setf *registered-names* (remove-if-not #'valid-registered-name-p *registered-names*))) (defun registered-macrolets (kernel) (loop for name in *registered-names* collect `(,name (&rest args) `(,',(unchecked-name name) ,',kernel ,@args)))) (defmacro declaim-defpun (&rest names) "See `defpun'." ;; This is used outside of the defpun macro. `(eval-when (:compile-toplevel :load-toplevel :execute) (with-lock-held (*registration-lock*) ,@(loop for name in names collect `(register-name ',name))))) (defun delete-registered-names (names) ;; This is used outside of the defpun macro. (with-lock-held (*registration-lock*) (setf *registered-names* (set-difference *registered-names* names)))) ;;;; limiter ;;; New tasks are accepted when limiter-count is positive. Creating a ;;; task decrements limiter-count; finishing a task increments it. (defun initial-limiter-count (thread-count) (+ thread-count 1)) (defun make-limiter-data (thread-count) (list :limiter-accept-task-p t :limiter-count (initial-limiter-count thread-count) :limiter-lock (make-spin-lock))) (setf *make-limiter-data* 'make-limiter-data) (defmacro accept-task-p (kernel) (check-type kernel symbol) `(locally (declare #.*full-optimize*) (limiter-accept-task-p (the kernel ,kernel)))) (defun/type update-limiter-count/no-lock (kernel delta) (kernel fixnum) (values) (declare #.*full-optimize*) (incf (limiter-count kernel) delta) (setf (limiter-accept-task-p kernel) (to-boolean (plusp (the fixnum (limiter-count kernel))))) (values)) (defun/type update-limiter-count (kernel delta) (kernel fixnum) (values) (declare #.*full-optimize*) (with-spin-lock-held ((limiter-lock kernel)) (update-limiter-count/no-lock kernel delta)) (values)) ;;;; plet (defconstant +no-result+ 'no-result) (defmacro msetq (vars form) (if (= 1 (length vars)) `(setq ,(first vars) ,form) `(multiple-value-setq ,vars ,form))) (defun client-vars (binding-data) (reduce #'append binding-data :key #'first)) (defun temp-vars (binding-data) (reduce #'append binding-data :key #'second)) (defun primary-temp-vars (binding-data) (loop for (nil temp-vars nil) in binding-data collect (first temp-vars))) (defmacro with-temp-bindings (here-binding-datum spawn-binding-data &body body) `(let (,@(temp-vars (list here-binding-datum)) ,@(loop for var in (temp-vars spawn-binding-data) collect `(,var +no-result+))) ,@body)) (defmacro with-client-bindings (binding-data null-bindings &body body) `(let (,@null-bindings ,@(mapcar #'list (client-vars binding-data) (temp-vars binding-data))) ,@body)) (defmacro spawn (kernel temp-vars form) (check-type kernel symbol) `(submit-raw-task (make-task (task-lambda ;; task handler already established (unwind-protect (msetq ,temp-vars (with-task-context ,form)) (locally (declare #.*full-optimize*) (update-limiter-count (the kernel ,kernel) 1))) (values))) ,kernel)) (defmacro spawn-tasks (kernel spawn-binding-data) (check-type kernel symbol) `(progn ,@(loop for (nil temp-vars form) in spawn-binding-data collect `(spawn ,kernel ,temp-vars ,form)))) (defmacro exec-task (here-binding-datum) (destructuring-bind (client-vars temp-vars form) here-binding-datum (declare (ignore client-vars)) `(msetq ,temp-vars ,form))) (defmacro sync (kernel spawn-binding-data) (check-type kernel symbol) ;; reverse to check last spawn first (let ((temp-vars (reverse (temp-vars spawn-binding-data)))) `(locally (declare #.*full-optimize*) (loop with worker = *worker* while (or ,@(loop for temp-var in temp-vars collect `(eq ,temp-var +no-result+))) do #+lparallel.with-green-threads (thread-yield) (steal-work (the kernel ,kernel) worker))))) (defmacro scan-for-errors (binding-data) ;; a wrapped error would only appear as the primary return value `(locally (declare #.*full-optimize*) ,@(loop for temp-var in (primary-temp-vars binding-data) collect `(when (typep ,temp-var 'wrapped-error) (unwrap-result ,temp-var))))) (defmacro %%%%plet (kernel bindings body) (multiple-value-bind (binding-data null-bindings) (make-binding-data bindings) (destructuring-bind (here-binding-datum &rest spawn-binding-data) binding-data `(with-temp-bindings ,here-binding-datum ,spawn-binding-data (spawn-tasks ,kernel ,spawn-binding-data) (exec-task ,here-binding-datum) (sync ,kernel ,spawn-binding-data) (scan-for-errors ,spawn-binding-data) (with-client-bindings ,binding-data ,null-bindings ,@body))))) (defmacro with-lock-predicates (&key lock predicate1 predicate2 succeed/lock succeed/no-lock fail) (with-gensyms (top fail-tag) `(block ,top (tagbody (when ,predicate1 (with-spin-lock-held (,lock) (if ,predicate2 ,succeed/lock (go ,fail-tag))) (return-from ,top ,succeed/no-lock)) ,fail-tag (return-from ,top ,fail))))) (defmacro %%%plet (kernel predicate spawn-count bindings body) ;; Putting the body code into a shared dynamic-extent function ;; caused some slowdown, so reluctantly duplicate the body. `(with-lock-predicates :lock (limiter-lock (the kernel ,kernel)) :predicate1 ,predicate :predicate2 (accept-task-p ,kernel) :succeed/lock (update-limiter-count/no-lock ,kernel ,(- spawn-count)) :succeed/no-lock (%%%%plet ,kernel ,bindings ,body) :fail (slet ,bindings ,@body))) (defmacro %%plet (kernel predicate bindings body) (let ((spawn-count (- (length (parse-bindings bindings)) 1))) (if (plusp spawn-count) `(%%%plet ,kernel ,predicate ,spawn-count ,bindings ,body) `(slet ,bindings ,@body)))) (defmacro %plet (kernel bindings &body body) `(%%plet ,kernel (accept-task-p ,kernel) ,bindings ,body)) (defmacro %plet-if (kernel predicate bindings &body body) `(%%plet ,kernel (and (accept-task-p ,kernel) ,predicate) ,bindings ,body)) ;;;; defpun (defmacro defun/wrapper (wrapper-name impl-name lambda-list &body body) (with-gensyms (args kernel) (multiple-value-bind (wrapper-lambda-list expansion) (if (intersection lambda-list lambda-list-keywords) (values `(&rest ,args) ``(apply (function ,',impl-name) ,,kernel ,',args)) (values lambda-list ``(,',impl-name ,,kernel ,@',lambda-list))) `(defun ,wrapper-name ,wrapper-lambda-list (macrolet ((call-impl (,kernel) ,expansion)) ,@body))))) (defun call-with-toplevel-handler (fn) (declare #.*full-optimize*) (declare (type function fn)) (let* ((results (multiple-value-list (call-with-task-handler fn))) (first (first results))) (when (typep first 'wrapped-error) (unwrap-result first)) (values-list results))) (defun call-inside-worker (kernel fn) (declare #.*full-optimize*) (declare (type function fn)) (let ((channel (let ((*kernel* kernel)) (make-channel)))) (submit-task channel (lambda () (multiple-value-list (funcall fn)))) (values-list (receive-result channel)))) (defun call-impl-fn (kernel impl) (declare #.*full-optimize*) (declare (type function impl)) (if (or *worker* (use-caller-p kernel)) (call-with-toplevel-handler impl) (call-inside-worker kernel impl))) (defmacro define-defpun (defpun doc defun &rest types) `(defmacro ,defpun (name lambda-list ,@types &body body) ,doc (with-parsed-body (body declares docstring) (with-lock-held (*registration-lock*) ;; these two calls may affect the registered macrolets in the ;; return form below (delete-stale-registrations) (register-name name) (with-gensyms (kernel) `(progn (,',defun ,(unchecked-name name) (,kernel ,@lambda-list) ,,@(unsplice (when types ``(kernel ,@,(first types)))) ,,@(unsplice (when types (second types))) ,@declares (declare (ignorable ,kernel)) (macrolet ((plet (bindings &body body) `(%plet ,',kernel ,bindings ,@body)) (plet-if (predicate bindings &body body) `(%plet-if ,',kernel ,predicate ,bindings ,@body)) ,@(registered-macrolets kernel)) ,@body)) (defun/wrapper ,name ,(unchecked-name name) ,lambda-list ,@(unsplice docstring) (let ((,kernel (check-kernel))) (call-impl-fn ,kernel (lambda () (call-impl ,kernel))))) (eval-when (:load-toplevel :execute) (with-lock-held (*registration-lock*) (register-fn ',name))) ',name)))))) (define-defpun defpun "`defpun' defines a function which is specially geared for fine-grained parallelism. If you have many small tasks which bog down the system, `defpun' may help. The syntax of `defpun' matches that of `defun'. The difference is that `plet' and `plet-if' take on new meaning inside `defpun'. The symbols in the binding positions of `plet' and `plet-if' should be viewed as lazily evaluated immutable references. Inside a `defpun' form the name of the function being defined is a macrolet, as are the names of other functions which were defined by `defpun'. Thus using #' on them is an error. Calls to functions defined by `defpun' entail more overhead when the caller lies outside a `defpun' form. A `defpun' function must exist before it is referenced inside another `defpun' function. If this is not possible--for example if func1 and func2 reference each other--then use `declaim-defpun' to specify intent: (declaim-defpun func1 func2) " defun) (define-defpun defpun/type "Typed version of `defpun'. `arg-types' is an unevaluated list of argument types. `return-type' is an unevaluated form of the return type, possibly indicating multiple values as in (values fixnum float). \(As a technical point, if `return-type' contains no lambda list keywords then the return type given to ftype will be additionally constrained to match the number of return values specified.)" defun/type arg-types return-type) (defmacro defpun* (&rest args) "Deprecated. Instead use `defpun' and pass `:use-caller t' to `make-kernel'." (simple-style-warning "`defpun*' is deprecated. Instead use `defpun' and pass ~ `:use-caller t' to `make-kernel'.") `(defpun ,@args)) (defmacro defpun/type* (&rest args) "Deprecated. Instead use `defpun/type' and pass `:use-caller t' to `make-kernel'." (simple-style-warning "`defpun/type*' is deprecated. Instead use `defpun/type' and pass ~ `:use-caller t' to `make-kernel'.") `(defpun/type ,@args)) lparallel-20160825-git/src/kernel-util.lisp000066400000000000000000000143361274371011200204340ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defpackage #:lparallel.kernel-util (:documentation "(semi-private) Abstracts some common patterns for submitting and receiving tasks. This probably won't change, but no guarantees.") (:use #:cl #:lparallel.util #:lparallel.kernel #:lparallel.queue) (:export #:with-submit-counted #:submit-counted #:receive-counted) (:export #:with-submit-indexed #:submit-indexed #:receive-indexed) (:export #:with-submit-cancelable #:submit-cancelable #:receive-cancelables) (:export #:with-temp-kernel) (:import-from #:lparallel.kernel #:*worker* #:steal-work #:channel-kernel)) (in-package #:lparallel.kernel-util) (defun steal-until-receive-result (channel worker fn) (declare #.*normal-optimize*) (loop (multiple-value-bind (result presentp) (try-receive-result channel) (when presentp (when fn (locally (declare (type function fn)) (funcall fn result))) (return))) (steal-work (channel-kernel channel) worker))) (defun receive-results (channel count fn) (declare #.*normal-optimize*) (let ((worker *worker*)) (if worker (repeat count (steal-until-receive-result channel worker fn)) (if fn (do-fast-receives (result channel count) (locally (declare (type function fn)) (funcall fn result))) (do-fast-receives (result channel count) (declare (ignore result))))))) (defmacro with-submit-counted (&body body) (with-gensyms (count channel) `(let ((,count 0) (,channel (make-channel))) (declare (fixnum ,count)) (flet ((submit-counted (&rest args) (declare (dynamic-extent args)) (apply #'submit-task ,channel args) (incf ,count)) (receive-counted () (receive-results ,channel ,count nil))) (declare (inline submit-counted receive-counted)) ,@body)))) (defun indexing-wrapper (array index function args) (setf (aref array index) (apply function args))) (defmacro/once with-submit-indexed (&once count &once array &body body) (with-gensyms (channel) `(let ((,channel (make-channel))) (flet ((submit-indexed (index function &rest args) (submit-task ,channel #'indexing-wrapper ,array index function args)) (receive-indexed () (receive-results ,channel ,count nil) ,array)) (declare (inline submit-indexed receive-indexed)) ,@body)))) (defmacro with-submit-cancelable (&body body) (with-gensyms (canceledp channel count) `(let ((,canceledp nil) (,count 0) (,channel (make-channel))) (flet ((submit-cancelable (fn &rest args) (submit-task ,channel (lambda () (if ,canceledp 'task-canceled (apply fn args)))) (incf ,count))) (macrolet ((receive-cancelables (result &body body) `(receive-results ,',channel ,',count (lambda (,result) ,@body)))) (unwind-protect (progn ,@body) (setf ,canceledp t))))))) (defun call-with-temp-kernel (fn &rest args) ;; ensure that we end the same kernel we create (let ((kernel (apply #'make-kernel args))) (unwind-protect (let ((*kernel* kernel)) (funcall fn)) (let ((*kernel* kernel)) (end-kernel :wait t))))) (defmacro with-temp-kernel ((&rest make-kernel-args) &body body) "Create a temporary kernel for the duration of `body', ensuring that `end-kernel' is eventually called. `make-kernel' is given the arguments `make-kernel-args'. **NOTE**: Use this only if you understand its implications. Since `*kernel*' is unaffected outside `body', the REPL will be useless with respect to the temporary kernel. For instance calling `kill-tasks' from the REPL will not affect tasks that are running in the temporary kernel. Multiple uses of `with-temp-kernel' within the same application are prone to defeat the purpose and benefits of having a thread pool. This is an especial risk if `with-temp-kernel' appears inside a library, which is likely to be a suboptimal situation. While using `with-temp-kernel' is generally a bad idea, there are a few valid uses, such as for testing, where the code is non-critical or where convenience trumps other concerns." `(call-with-temp-kernel (lambda () ,@body) ,@make-kernel-args)) lparallel-20160825-git/src/kernel/000077500000000000000000000000001274371011200165615ustar00rootroot00000000000000lparallel-20160825-git/src/kernel/central-scheduler.lisp000066400000000000000000000047231274371011200230640ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.kernel) (defun make-scheduler (workers spin-count) (declare (ignore workers spin-count)) (make-biased-queue)) (defun/type schedule-task (scheduler task priority) (scheduler (or task null) t) (values) (declare #.*normal-optimize*) (ccase priority (:default (push-biased-queue task scheduler)) (:low (push-biased-queue/low task scheduler))) (values)) (defun/inline next-task (scheduler worker) (declare (ignore worker)) (pop-biased-queue scheduler)) (defun/type steal-task (scheduler) (scheduler) (or task null) (declare #.*normal-optimize*) (with-lock-predicate/wait (lparallel.biased-queue::lock scheduler) (not (biased-queue-empty-p/no-lock scheduler)) ;; don't steal nil, the end condition flag (when (peek-biased-queue/no-lock scheduler) (pop-biased-queue/no-lock scheduler)))) lparallel-20160825-git/src/kernel/classes.lisp000066400000000000000000000146711274371011200211200ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.kernel) (defslots worker-info () ((bindings :type list) (context :type function) (name :type string)) (:documentation "Information common to all workers. See `make-kernel'.")) (defslots worker-notifications () ((handshake/from-worker :initform (make-queue)) (handshake/to-worker :initform (make-queue)) (exit-notification :initform (make-queue))) (:documentation "Communication with workers. A handshake takes place when a worker is created in order to verify its existence and to ensure all data is initialized. A worker sends a notification just before it exits.")) (defslots worker (worker-notifications) ((thread :reader thread) (running-category :reader running-category :initform nil) (index :reader worker-index :type index) #+lparallel.with-stealing-scheduler (tasks :reader tasks :type spin-queue)) (:documentation "A worker represents a thread dedicated to executing tasks. See `kill-tasks' for an explanation of `running-category'. `index' is the location of the worker in the kernel's vector of workers. When the stealing scheduler is enabled, each worker has its own lockless task queue.")) #+lparallel.with-stealing-scheduler (defslots scheduler () ((workers :type simple-vector) (wait-cvar :initform (make-condition-variable)) (wait-lock :initform (make-lock)) (wait-count :initform (make-counter) :type counter) (notify-count :initform 0 :type (integer 0)) (spin-count :type index) (random-index :initform 0 :type index) (low-priority-tasks :initform (make-spin-queue) :type spin-queue)) (:documentation "A scheduler is responsible for storing tasks and finding the next task to execute. A task may also be stolen from the scheduler. `workers' -- vector of workers; kernel has the same reference. `wait-cvar', `wait-lock', `wait-count', `notify-count' -- these coordinate waking/sleeping of workers. `spin-count' -- see `make-kernel'. `random-index' -- some random index to the vector of workers. `low-priority-tasks' -- tasks submitted when `*task-priority*' is `:low'.")) #-lparallel.with-stealing-scheduler (progn ;;; The central queue scheduler. All tasks are submitted to a single ;;; queue and all workers pull from the same. (deftype scheduler () 'biased-queue) (defun tasks (scheduler) (declare (ignore scheduler)))) ;;; The limiter, if in use, places a limit on the number of queued ;;; tasks. This must be a struct for CAS. The `limiter-accept-task-p' ;;; flag must be fast/inlined in order to be useful, which is why the ;;; kernel subclasses directly from this." #-lparallel.with-debug (locally (declare #.*full-optimize*) (defstruct (limiter (:conc-name nil)) (limiter-accept-task-p (error "no init") :type boolean) (limiter-lock (error "no init")) (limiter-count (error "no init") :type fixnum))) ;;; Debug version of limiter can't be a struct since in this case ;;; `defslots' expands to `defclass'. #+lparallel.with-debug (defclass limiter () ((limiter-accept-task-p :accessor limiter-accept-task-p :initarg :limiter-accept-task-p :type boolean) (limiter-lock :accessor limiter-lock :initarg :limiter-lock) (limiter-count :accessor limiter-count :initarg :limiter-count :type fixnum))) (locally (declare #.*full-optimize*) (defslots kernel (limiter) ((scheduler :reader scheduler :type scheduler) (workers :reader workers :type simple-vector) (workers-lock) (worker-info :type worker-info) (use-caller-p :reader use-caller-p :type boolean) (alivep :reader alivep :type boolean)) (:documentation "The kernel encompasses the scheduling and execution of parallel tasks using a pool of worker threads. All parallelism in lparallel is done on top of the kernel."))) (defslots channel () ((queue :reader channel-queue :type queue) (kernel :reader channel-kernel :type kernel)) (:documentation "A task is submitted to the kernel using a channel. A channel always points to the same kernel, which is the value of `*kernel*' when the channel is created.")) #-lparallel.without-task-categories (locally (declare #.*full-optimize*) (defpair task () ((fn :reader task-fn :type function) (category :reader task-category)) (:documentation "A task consists of a function and a category. See `kill-tasks' for and explanation of task categories."))) #+lparallel.without-task-categories (progn (deftype task () 'function) (defmacro make-task (fn) fn) (defmacro task-fn (x) x)) lparallel-20160825-git/src/kernel/core.lisp000066400000000000000000000506351274371011200204130ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.kernel) #-lparallel.without-task-categories (defun/type exec-task/worker (task worker) (task worker) t ;; already inside call-with-task-handler (declare #.*full-optimize*) (with-worker-slots (running-category) worker (let ((prev-category running-category)) (unwind-protect/ext :prepare (setf running-category (task-category task)) :main (funcall (task-fn task)) :cleanup (setf running-category prev-category))))) #+lparallel.without-task-categories (defun/type/inline exec-task/worker (task worker) (task worker) t (declare #.*full-optimize*) (declare (ignore worker)) (funcall (task-fn task))) (defun/type/inline exec-task/non-worker (task) (task) t ;; not inside call-with-task-handler (declare #.*full-optimize*) (call-with-task-handler (task-fn task))) (defun/type steal-work (kernel worker) (kernel (or worker null)) boolean (declare #.*full-optimize*) (when-let (task (steal-task (scheduler kernel))) (if worker (exec-task/worker task worker) (exec-task/non-worker task)) t)) (defun handshake/to-worker/start (worker) (with-worker-slots (handshake/to-worker) worker (push-queue 'proceed handshake/to-worker))) (defun handshake/to-worker/finish (worker) (with-worker-slots (handshake/from-worker) worker (ecase (pop-queue handshake/from-worker) (ok) (error (error 'kernel-creation-error))))) (defun handshake/from-worker/start (worker) (with-worker-slots (handshake/to-worker) worker (assert (eq 'proceed (pop-queue handshake/to-worker))))) (defun handshake/from-worker/finish (worker status) (check-type status (member ok error)) (with-worker-slots (handshake/from-worker) worker (push-queue status handshake/from-worker))) (defun notify-exit (worker) (with-worker-slots (exit-notification) worker (push-queue 'exit exit-notification))) (defun wait-for-worker (worker) (with-worker-slots (exit-notification) worker (assert (eq 'exit (pop-queue exit-notification))))) (defun replace-worker (kernel worker) (with-kernel-slots (workers workers-lock) kernel (with-lock-held (workers-lock) (let ((index (position worker workers :test #'eq))) (assert index) (assert (eql index (worker-index worker))) (unwind-protect/ext :prepare (warn "lparallel: Replacing lost or dead worker.") :main (let ((new-worker (make-worker kernel index (tasks worker)))) (setf (svref workers index) new-worker) (handshake/to-worker/start new-worker) (handshake/to-worker/finish new-worker)) :abort (warn "lparallel: Worker replacement failed! ~ Kernel is defunct.")))))) (defun/type worker-loop (kernel worker) (kernel worker) t ;; All implementations tested so far execute unwind-protect clauses ;; when the ABORT restart is invoked (TERMINATE-THREAD in SBCL), ;; including ABCL. ;; ;; All but ABCL execute unwind-protect for destroy-thread. ;; ;; This function is inside `call-with-task-handler' (or ;; equivalent). Jumping out means a thread abort. (declare #.*full-optimize*) (let ((scheduler (scheduler kernel))) (unwind-protect/ext :main (loop (let ((task (next-task scheduler worker))) (if task (exec-task/worker (the task task) worker) (return)))) :abort (unless *lisp-exiting-p* (replace-worker kernel worker))))) #+lparallel.without-kill (defmacro with-worker-restarts (&body body) `(progn ,@body)) (defun call-with-worker-context (fn worker-context kernel worker) (handshake/from-worker/start worker) (unwind-protect (funcall worker-context (lambda () (let ((*worker* (find (current-thread) (workers kernel) :key #'thread))) (assert *worker*) (handshake/from-worker/finish worker 'ok) (with-worker-restarts (%call-with-task-handler fn))))) ;; This error notification is seen when `worker-context' does not ;; call its worker-loop parameter, otherwise it's ignored. (handshake/from-worker/finish worker 'error))) (defun enter-worker-loop (kernel worker) (with-kernel-slots (worker-info) kernel (with-worker-info-slots (context) worker-info (call-with-worker-context (lambda () (worker-loop kernel worker)) context kernel worker)))) (defun make-all-bindings (kernel bindings) (append bindings (list (cons '*kernel* kernel)))) #+lparallel.with-stealing-scheduler (defun %make-worker (index tasks) (make-worker-instance :thread nil :index index :tasks tasks)) #-lparallel.with-stealing-scheduler (defun %make-worker (index tasks) (declare (ignore tasks)) (make-worker-instance :thread nil :index index)) (defun make-worker-thread (kernel worker name bindings) (with-thread (:name name :bindings bindings) (unwind-protect/ext :main (enter-worker-loop kernel worker) :cleanup (notify-exit worker)))) (defun make-worker (kernel index tasks) (with-kernel-slots (worker-info) kernel (with-worker-info-slots (bindings name) worker-info (let* ((worker (%make-worker index tasks)) (bindings (make-all-bindings kernel bindings)) (worker-thread (make-worker-thread kernel worker name bindings))) (with-worker-slots (thread) worker (setf thread worker-thread)) worker)))) (defmacro with-fill-workers-handler (workers &body body) `(unwind-protect/ext :main (progn ,@body) :abort (dosequence (worker ,workers) (when (typep worker 'worker) (ignore-errors (destroy-thread (thread worker))))))) (defun %fill-workers (workers kernel) (dotimes (index (length workers)) (setf (aref workers index) (make-worker kernel index #+lparallel.with-stealing-scheduler (make-spin-queue) #-lparallel.with-stealing-scheduler nil)))) (defun fill-workers (workers kernel) ;; Start/finish calls are separated for parallel initialization. ;; ;; Ensure that each worker calls its worker-loop parameter, ;; otherwise an error is signaled, whereupon all workers are killed. ;; ;; If a `make-thread' call fails (e.g. too many threads) then all ;; workers are killed. (with-fill-workers-handler workers (%fill-workers workers kernel) (map nil #'handshake/to-worker/start workers) (map nil #'handshake/to-worker/finish workers))) (defun make-kernel (worker-count &key (name "lparallel") (bindings `((*standard-output* . ,*standard-output*) (*error-output* . ,*error-output*))) (context #'funcall) (spin-count *kernel-spin-count*) (use-caller nil)) "Create a kernel with `worker-count' number of worker threads. `name' is a string identifier for this kernel which is reported by `print-object'. Worker threads will also be given this name, shown in `bordeaux-threads:all-threads'. `bindings' is an alist for establishing thread-local variables inside worker threads. By default workers will have *standard-output* and *error-output* bindings. Dynamic context for each worker may be established with the function `context'. The argument passed to `context' is a function which must be funcalled. It begins the worker loop and will not return until the worker exits. The default value of `context' is #'funcall. The special variables in `bindings' are available inside the `context' function. When a worker discovers that no tasks are available, `spin-count' is the number of task-searching iterations done by the worker before sleeping. If `use-caller' is true (default is false) then in certain situations the calling thread may be enlisted to steal work from worker threads. This is an optimization strategy that currently applies only during the execution of functions defined by `defpun' and `defpun/type'. Typically in this case the number of workers will be one less than the number of cores/CPUs. A kernel will not be garbage collected until `end-kernel' is called." (check-type worker-count (integer 1 #.most-positive-fixnum)) (check-type spin-count index) (let* ((workers (make-array worker-count)) (thread-count (if use-caller (1+ worker-count) worker-count)) (kernel (apply #'make-kernel-instance :scheduler (make-scheduler workers spin-count) :workers workers :workers-lock (make-lock) :worker-info (make-worker-info-instance :bindings bindings :context (ensure-function context) :name name) :use-caller-p (to-boolean use-caller) :alivep t (funcall *make-limiter-data* thread-count)))) (fill-workers workers kernel) kernel)) (defun check-kernel () "Ensures the value of `*kernel*' is a kernel instance. Provides the MAKE-KERNEL and STORE-VALUE restarts. Returns `*kernel*'." (or *kernel* (restart-case (error 'no-kernel-error) (make-kernel (worker-count) :report "Make a kernel now (prompt for number of workers)." :interactive (lambda () (interact "Enter number of workers: ")) (setf *kernel* (make-kernel worker-count))) (store-value (value) :report "Assign a value to lparallel:*kernel*." :interactive (lambda () (interact "Value for lparallel:*kernel*: ")) (check-type value kernel) (setf *kernel* value))))) (defmacro define-worker-info-reader (name slot &optional (result slot)) `(defun ,name () ,(format nil "Return the ~a passed to `make-kernel'." (string-downcase slot)) (with-kernel-slots (worker-info) (check-kernel) (with-worker-info-slots (,slot) worker-info ,result)))) (define-worker-info-reader kernel-bindings bindings (copy-alist bindings)) (define-worker-info-reader kernel-name name) (define-worker-info-reader kernel-context context) (defun/type/inline %kernel-worker-count (kernel) (kernel) index (declare #.*full-optimize*) (length (workers kernel))) (defun kernel-worker-count () "Return the number of workers in the current kernel." (%kernel-worker-count (check-kernel))) (defun kernel-worker-index () "If called from inside a worker, return the worker's assigned index, ranging from 0 to one less than (kernel-worker-count). If not called from inside a worker, return nil." (let ((worker *worker*)) (if worker (worker-index worker) nil))) (defun %make-channel (&key fixed-capacity) (make-channel-instance :kernel (check-kernel) :queue (make-queue :fixed-capacity fixed-capacity))) (defun make-channel (&rest args) "Create a channel for submitting and receiving tasks. The current value of `*kernel*' is stored for use in `submit-task'. By default there is no limit on the channel capacity. Passing a `fixed-capacity' keyword argument limits the capacity to the value passed. Note that a fixed capacity channel may cause a deadlocked kernel if `receive-result' is not called a sufficient number of times." (apply #'%make-channel (if (= 1 (length args)) nil args))) (define-compiler-macro make-channel (&whole whole &rest args) (when (= 1 (length args)) (simple-style-warning "Calling `make-channel' with one argument is deprecated.~%~ Pass no arguments instead.")) whole) #-lparallel.without-task-handling (defmacro task-lambda (&body body) (with-gensyms (body-fn client-handlers) `(flet ((,body-fn () ,@body)) (declare #.*full-optimize*) (let ((,client-handlers *client-handlers*)) (if ,client-handlers (lambda () (let ((*client-handlers* ,client-handlers)) (,body-fn))) #',body-fn))))) #+lparallel.without-task-handling (defmacro task-lambda (&body body) `(lambda () ,@body)) #-lparallel.without-task-categories (defun/type/inline make-task (fn) (function) task (declare #.*full-optimize*) (make-task-instance fn *task-category*)) (defun/type make-channeled-task (channel fn args) (channel function list) t ;; avoid allocation from extent checks with safety 0 (sbcl) (declare #.*full-optimize*) (let ((queue (channel-queue channel))) (make-task (task-lambda (unwind-protect/ext ;; task handler already established inside worker threads :main (push-queue (with-task-context (apply fn args)) queue) ;; the task handler handles everything; unwind means thread kill :abort (push-queue (wrap-error 'task-killed-error) queue)))))) (defun/type/inline submit-raw-task (task kernel) (task kernel) (values) (declare #.*normal-optimize*) (unless (alivep kernel) (error "Attempted to submit a task to an ended kernel.")) (schedule-task (scheduler kernel) task *task-priority*) (values)) (defun submit-task (channel function &rest args) "Submit a task through `channel' to the kernel stored in `channel'." (declare #.*normal-optimize*) (check-type channel channel) (submit-raw-task (make-channeled-task channel (ensure-function function) args) (channel-kernel channel))) (defun receive-result (channel) "Remove a result from `channel'. If nothing is available the call will block until a result is received." (unwrap-result (pop-queue (channel-queue channel)))) (defun try-receive-result (channel &key timeout) "If `channel' has a result then remove it and return (values result t). If no result is available and `timeout' is given, then wait up to `timeout' seconds for a result. If the channel is empty and the timeout has expired, or if the channel is empty and no timeout was given, return (values nil nil). Providing a nil or non-positive value of `timeout' is equivalent to providing no timeout." (multiple-value-bind (result presentp) (try-pop-queue (channel-queue channel) :timeout timeout) (if presentp (values (unwrap-result result) t) (values nil nil)))) (defmacro/once do-fast-receives ((result &once channel count) &body body) "Receive `count' number of results from `channel', executing `body' each time with the result bound to `result'. `body' should be a trivial operation such as an aref call." `(repeat ,count (let ((,result (receive-result ,channel))) ,@body))) (defun shutdown (channel kernel) (let ((*task-priority* :low)) (submit-task channel (lambda ()))) (receive-result channel) (with-kernel-slots (scheduler workers alivep) kernel (repeat (length workers) (schedule-task scheduler nil :low)) (map nil #'wait-for-worker workers) (setf alivep nil))) (defun end-kernel (&key wait) "Sets `*kernel*' to nil and ends all workers gracefully. `end-kernel' should not be used as a substitute for properly waiting on tasks with `receive-result' or otherwise. If `wait' is nil (the default) then `end-kernel' returns immediately. Workers are waited upon by a separate shutdown manager thread. If `wait' is non-nil then `end-kernel' blocks until all workers are finished. No shutdown manager thread is created. A list of the implementation-defined worker thread objects is returned. If `wait' is nil then the shutdown manager thread is also returned as the first element in the list. Note that creating and destroying kernels is relatively expensive. A kernel typically exists for lifetime of the Lisp process. Having more than one kernel is fine -- simply use `let' to bind a kernel instance to `*kernel*' when you need it. Use `kill-tasks' to terminate deadlocked or infinite looping tasks." (let ((kernel *kernel*)) (when kernel (setf *kernel* nil) (when (alivep kernel) (let ((channel (let ((*kernel* kernel)) (make-channel))) (threads (map 'list #'thread (workers kernel)))) (cond (wait (shutdown channel kernel) threads) (t (cons (with-thread (:name "lparallel kernel shutdown manager") (shutdown channel kernel)) threads)))))))) (defun task-categories-running () "Return a vector containing the task category currently running for each worker." (let ((kernel *kernel*)) (if kernel (map 'vector #'running-category (workers kernel)) #()))) (defun kernel-info (kernel) (with-kernel-slots (worker-info alivep use-caller-p) kernel (with-worker-info-slots (name) worker-info (nconc (list :name name :worker-count (%kernel-worker-count kernel) :use-caller use-caller-p :alive alivep) #+lparallel.with-stealing-scheduler (with-scheduler-slots (spin-count) (scheduler kernel) (list :spin-count spin-count)))))) (defmethod print-object ((kernel kernel) stream) (print-unreadable-object (kernel stream :type t :identity t) (format stream "~{~s~^ ~}" (kernel-info kernel)))) (defun broadcast-task (function &rest args) "Wait for current and pending tasks to complete, if any, then simultaneously execute the given task inside each worker. Wait until these tasks finish, then return the results in a vector. Calling `broadcast-task' from inside a worker is an error." (when *worker* (error "Cannot call `broadcast-task' from inside a worker.")) (let* ((function (ensure-function function)) (*kernel* (check-kernel)) (worker-count (kernel-worker-count)) (channel (make-channel)) ;; TODO: replace queues with semaphores (from-workers (make-queue)) (to-workers (make-queue))) (repeat worker-count (submit-task channel (lambda () (push-queue t from-workers) (pop-queue to-workers) (apply function args)))) (repeat worker-count (pop-queue from-workers)) (repeat worker-count (push-queue t to-workers)) (map-into (make-array worker-count) (lambda () (receive-result channel))))) (defun track-exit () (setf *lisp-exiting-p* t)) #+sbcl (pushnew 'track-exit sb-ext:*exit-hooks*) #+ccl (pushnew 'track-exit ccl:*lisp-cleanup-functions*) #+allegro (pushnew '(track-exit) sys:*exit-cleanup-forms* :test #'equal) ;;; ccl:save-application calls ccl:*lisp-cleanup-functions* before ;;; saving. Adjust with a save hook. #+ccl (progn (defun save-hook () (setf *lisp-exiting-p* nil)) (pushnew 'save-hook ccl:*save-exit-functions*)) lparallel-20160825-git/src/kernel/handling.lisp000066400000000000000000000155531274371011200212470ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.kernel) (defslots wrapped-error () ((value :type condition :reader wrapped-error-value)) (:documentation "This is a container for transferring an error that occurs inside `call-with-task-handler' to the calling thread.")) (defun wrap-error (condition) "Wrap an error. A non-error condition may also be wrapped, though it will still be signaled with `error'." (make-wrapped-error-instance :value (ctypecase condition (symbol (make-condition condition)) (condition condition)))) (defun unwrap-result (result) "In `receive-result', this is called on the stored task result. The user receives the return value of this function." (declare #.*full-optimize*) (typecase result (wrapped-error ;; A `wrapped-error' signals an error upon being unwrapped. (error (wrapped-error-value result))) (otherwise ;; Most objects unwrap to themselves. result))) (defmacro task-handler-bind (clauses &body body) "Like `handler-bind' but handles conditions signaled inside tasks that were created in `body'." (let ((forms (loop for clause in clauses for (name fn . more) = clause do (unless (and name (symbolp name) fn (not more)) (error "Ill-formed binding in `task-handler-bind': ~a" clause)) collect `(cons ',name ,fn)))) `(let ((*client-handlers* (list* ,@forms *client-handlers*))) ,@body))) (defun invoke-transfer-error (error) "Equivalent to (invoke-restart 'transfer-error error). This is a convenience function for use in `task-handler-bind'." (invoke-restart 'transfer-error error)) (defun condition-handler (condition) "Mimic the CL handling mechanism, calling handlers until one assumes control (or not)." (loop for ((condition-type . handler) . rest) on *client-handlers* do (when (typep condition condition-type) (let ((*client-handlers* rest)) (handler-bind ((condition #'condition-handler)) (funcall handler condition))))) (when (and (typep condition 'error) (not *debug-tasks-p*)) (invoke-transfer-error condition))) (defun call-with-tracked-error (condition body-fn) (unwind-protect/ext :prepare (when *worker* (with-lock-held (*erroring-workers-lock*) (push *worker* *erroring-workers*))) :main (let ((*debugger-error* condition)) (funcall body-fn)) :cleanup (when *worker* (with-lock-held (*erroring-workers-lock*) (setf *erroring-workers* (delete *worker* *erroring-workers*)))))) (defmacro with-tracked-error (condition &body body) `(call-with-tracked-error ,condition (lambda () ,@body))) (defun make-debugger-hook () "Record `*debugger-error*' for the `transfer-error' restart." (if *debugger-hook* (let ((previous-hook *debugger-hook*)) (lambda (condition self) (with-tracked-error condition (funcall previous-hook condition self)))) (lambda (condition self) (declare (ignore self)) (with-tracked-error condition (invoke-debugger condition))))) (defun transfer-error-report (stream) (format stream "Transfer this error to a dependent thread, if one exists.")) (defconstant +current-task+ 'current-task) (defun transfer-error-restart (&optional (err *debugger-error*)) (when err (throw +current-task+ (wrap-error err)))) #-lparallel.without-task-handling (progn (defmacro with-task-context (&body body) `(catch +current-task+ ,@body)) (defun %call-with-task-handler (fn) (declare #.*full-optimize*) (declare (type function fn)) (let ((*handler-active-p* t) (*debugger-hook* (make-debugger-hook))) (handler-bind ((condition #'condition-handler)) (restart-bind ((transfer-error #'transfer-error-restart :report-function #'transfer-error-report)) (funcall fn))))) (defun call-with-task-handler (fn) (declare #.*full-optimize*) (declare (type function fn)) (with-task-context (if *handler-active-p* (funcall fn) (%call-with-task-handler fn))))) #+lparallel.without-task-handling (progn (defmacro with-task-context (&body body) `(progn ,@body)) (alias-function %call-with-task-handler funcall) (alias-function call-with-task-handler funcall)) (define-condition task-killed-error (error) () (:report "The task was killed.") (:documentation "Error signaled when attempting to obtain the result of a killed task.")) (define-condition no-kernel-error (error) () (:report "Welcome to lparallel. To get started, you need to create some worker threads. Choose the MAKE-KERNEL restart to create them now. Worker threads are asleep when not in use. They are typically created once per Lisp session. Adding the following line to your startup code will prevent this message from appearing in the future (N is the number of workers): (setf lparallel:*kernel* (lparallel:make-kernel N)) ") (:documentation "Error signaled when `*kernel*' is nil.")) (define-condition kernel-creation-error (error) () (:report "Failed to create a kernel.") (:documentation "Error signaled when `make-kernel' fails.")) lparallel-20160825-git/src/kernel/kill.lisp000066400000000000000000000104731274371011200204120ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.kernel) (defconstant +worker-suicide-tag+ 'worker-suicide-tag) (defun kill (kernel category) (assert kernel) (let ((kill-count 0)) (with-kernel-slots (workers-lock workers) kernel (with-lock-held (workers-lock) (dosequence (worker workers) (when (and (not (eq (thread worker) (current-thread))) (eql category (running-category worker))) (destroy-thread (thread worker)) (incf kill-count))) (when *worker* (assert (eq (thread *worker*) (current-thread))) (when (eql category (running-category *worker*)) (throw +worker-suicide-tag+ nil))))) kill-count)) (defun kill-errors () (let ((suicide nil)) (with-lock-held (*erroring-workers-lock*) (dolist (worker *erroring-workers*) (if (and *worker* (eq worker *worker*)) (setf suicide t) ;; user could possibly (though unlikely) destroy the ;; thread simultaneously, so ignore double-destroy error (ignore-errors (destroy-thread (thread worker))))) (when suicide (assert (eq (thread *worker*) (current-thread))) (throw +worker-suicide-tag+ nil))))) (defun kill-errors-report (stream) (format stream "Kill errors in workers (remove debugger instances).")) (defmacro with-worker-restarts (&body body) `(catch +worker-suicide-tag+ (restart-bind ((kill-errors #'kill-errors :report-function #'kill-errors-report)) ,@body))) (defun kill-tasks (task-category &key dry-run) "This is an expensive function which should only be used in exceptional circumstances. Every task has an associated task category. When a task is submitted, it is assigned the category of `*task-category*' which has a default value of `:default'. `kill-tasks' interrupts running tasks whose category is `eql' to `task-category'. The corresponding worker threads are killed and replaced. Pending tasks are not affected. If you don't know what to pass for `task-category' then you should probably pass `:default', though this may kill more tasks than you wish. Binding `*task-category*' around `submit-task' enables targeted task killing. If `dry-run' is nil, the function returns the number of tasks killed. If `dry-run' is non-nil then no tasks are killed. In this case the return value is the number of tasks that would have been killed if `dry-run' were nil. `kill-tasks' is not available in ABCL." (let ((kernel *kernel*)) (when kernel (unless task-category (error "Task category cannot be nil in `kill-tasks'.")) (if dry-run (count task-category (workers kernel) :key #'running-category) (kill kernel task-category))))) lparallel-20160825-git/src/kernel/package.lisp000066400000000000000000000060751274371011200210550ustar00rootroot00000000000000;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defpackage #:lparallel.kernel (:documentation "Encompasses the scheduling and execution of parallel tasks using a pool of worker threads. All parallelism in lparallel is done on top of the kernel.") (:use #:cl #:lparallel.util #:lparallel.thread-util #:lparallel.queue #-lparallel.with-stealing-scheduler #:lparallel.biased-queue #+lparallel.with-stealing-scheduler #:lparallel.counter #+lparallel.with-stealing-scheduler #:lparallel.spin-queue) (:export #:make-kernel #:check-kernel #:end-kernel #:kernel-worker-count #:kernel-worker-index #:kernel-bindings #:kernel-name #:kernel-context) (:export #:make-channel #:submit-task #:broadcast-task #:submit-timeout #:cancel-timeout #:receive-result #:try-receive-result #:do-fast-receives #:kill-tasks #:task-handler-bind #:task-categories-running #:invoke-transfer-error) (:export #:*kernel* #:*kernel-spin-count* #:*task-category* #:*task-priority* #:*debug-tasks-p*) (:export #:kernel #:channel #:transfer-error #:no-kernel-error #:kernel-creation-error #:task-killed-error) (:import-from #:alexandria #:simple-style-warning)) (in-package #:lparallel.kernel) lparallel-20160825-git/src/kernel/specials.lisp000066400000000000000000000070401274371011200212560ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.kernel) (defvar *debugger-error* nil "Track the error inside the debugger for the `transfer-error' restart.") (defvar *handler-active-p* nil "Non-nil when handlers have been established via `call-with-task-handler'.") (defvar *client-handlers* nil "Records handlers established with `task-handler-bind' in the calling thread.") (defvar *task-category* :default "See `kill-tasks'. Default value is `:default'.") (defvar *task-priority* :default "When bound to `:low', the kernel schedules submitted tasks at low priority. Default value is `:default'.") (defvar *worker* nil "The worker instance if inside a worker thread, otherwise nil.") (defvar *kernel* nil "The current kernel, or nil.") ;;; This is set by the only limiter client, defpun.lisp. (defvar *make-limiter-data*) ;;; On a Core-i7 3.4GHz, a single spin takes about 2.5 microseconds. (defvar *kernel-spin-count* 2000 "Default value of the `spin-count' argument to `make-kernel'.") (defvar *debug-tasks-p* t "If true (the default), the debugger is invoked when an error goes unhandled inside a task, i.e. when the handlers established by `task-handler-bind' (if any) do not handle it. If false, unhandled errors from tasks are automatically transferred to their parent thread (and/or any dependent threads) via the `transfer-error' restart. This is for convenience -- sometimes you wish to avoid N debugger popups arising from N errors in N worker threads. For local control over debugger invocation, bind a task handler: (task-handler-bind ((error #'invoke-debugger)) ...) (task-handler-bind ((error #'invoke-transfer-error)) ...)") (defvar *lisp-exiting-p* nil "True if the Lisp process is exiting; for skipping auto-replacement of killed workers during exit.") (defvar *erroring-workers* nil "Track debugger popups in order to kill them.") (defvar *erroring-workers-lock* (make-lock) "Lock for *erroring-workers*.") lparallel-20160825-git/src/kernel/stealing-scheduler.lisp000066400000000000000000000164611274371011200232440ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.kernel) ;;;; util (defmacro define-mod-inc-dec (name op op-result-type) `(defmacro ,name (k n) `(the index (mod (the ,',op-result-type (,',op (the index ,k))) (the index ,n))))) (define-mod-inc-dec mod-inc 1+ index) (define-mod-inc-dec mod-dec 1- fixnum) (defmacro define-mod-incf-decf (name op) `(defmacro ,name (place n) `(the index (setf ,place (,',op ,place ,n))))) (define-mod-incf-decf mod-incf mod-inc) (define-mod-incf-decf mod-decf mod-dec) (defmacro with-pop-success (var queue &body body) (with-gensyms (presentp) `(multiple-value-bind (,var ,presentp) (pop-spin-queue ,queue) (when ,presentp ,@body)))) (defmacro repeat/fixnum (count &body body) (with-gensyms (left) `(let ((,left (the fixnum ,count))) (declare (type fixnum ,left)) (loop (when (zerop ,left) (return (values))) (decf ,left) ,@body)))) (defmacro do-indexes ((index-var size home-index from-home-index-p) &body body) ;; size is positive (with-gensyms (size-var home-index-var) `(let ((,index-var (the index ,home-index)) (,size-var (the index ,size)) (,home-index-var (the index ,home-index))) (declare (type index ,index-var ,size-var ,home-index-var)) (loop ,(let ((next `(mod-incf ,index-var ,size-var))) (if from-home-index-p `(progn ,@body ,next) `(progn ,next ,@body))) (when (= ,index-var ,home-index-var) (return (values))))))) ;;;; scheduler (defun make-scheduler (workers spin-count) (make-scheduler-instance :workers workers :spin-count spin-count)) (defun/type/inline push-to-random-worker (task scheduler) (task scheduler) (values) ;; Decrease random-index without caring about simultaneous changes. ;; The actual value of random-index does not matter as long as it ;; remains somewhat well-distributed. (declare #.*full-optimize*) (with-scheduler-slots (workers random-index) scheduler (push-spin-queue task (tasks (svref workers (mod-decf random-index (length workers)))))) (values)) (defun/type maybe-wake-a-worker (scheduler) (scheduler) (values) (declare #.*full-optimize*) (with-scheduler-slots (wait-lock wait-cvar wait-count notify-count) scheduler (with-lock-predicate/wait wait-lock (plusp (counter-value wait-count)) (incf notify-count) (condition-notify wait-cvar))) (values)) (defun/type schedule-task (scheduler task priority) (scheduler (or task null) t) (values) (declare #.*full-optimize*) (ccase priority (:low (with-scheduler-slots (low-priority-tasks) scheduler (push-spin-queue task low-priority-tasks))) (:default (push-to-random-worker task scheduler))) (maybe-wake-a-worker scheduler) (values)) (defmacro do-workers ((worker-var workers home-index from-home-index-p) &body body) (with-gensyms (workers-var index-var) `(let ((,workers-var ,workers)) (declare (type simple-vector ,workers-var)) (do-indexes (,index-var (length (the simple-vector ,workers-var)) ,home-index ,from-home-index-p) (let ((,worker-var (svref (the simple-vector ,workers-var) ,index-var))) (declare (type worker ,worker-var)) ,@body))))) (defun/type next-task (scheduler worker) (scheduler worker) (or task null) (declare #.*full-optimize*) (labels ((try-pop (queue) (declare (type spin-queue queue)) (with-pop-success task queue (return-from next-task task)) (values)) (try-pop-all () (with-scheduler-slots (workers) scheduler (do-workers (worker workers (worker-index worker) nil) (try-pop (tasks worker)))) (values)) (maybe-sleep () (with-scheduler-slots (wait-cvar wait-lock wait-count notify-count low-priority-tasks) scheduler (unwind-protect/ext :prepare (inc-counter wait-count) :main (with-lock-held (wait-lock) (try-pop (tasks worker)) (try-pop low-priority-tasks) (loop until (plusp notify-count) do (condition-wait wait-cvar wait-lock) finally (decf notify-count))) :cleanup (dec-counter wait-count))) (values))) (declare (dynamic-extent #'try-pop #'try-pop-all #'maybe-sleep)) (with-scheduler-slots (spin-count) scheduler (loop (try-pop (tasks worker)) (try-pop-all) (repeat/fixnum spin-count (try-pop-all)) (maybe-sleep))))) (defun/type steal-task (scheduler) (scheduler) (or task null) (declare #.*full-optimize*) (with-scheduler-slots (workers random-index low-priority-tasks) scheduler (let ((low-priority-tasks low-priority-tasks)) (flet ((try-pop (tasks) (declare (type spin-queue tasks low-priority-tasks)) (with-pop-success task tasks (when task (return-from steal-task task)) ;; don't steal nil, the end condition flag (push-spin-queue task low-priority-tasks)) (values))) (declare (dynamic-extent #'try-pop)) ;; Start with the worker that has the most recently submitted ;; task (approximately) and advance rightward. (do-workers (worker workers random-index t) (try-pop (tasks worker))) (try-pop low-priority-tasks)))) nil) lparallel-20160825-git/src/kernel/timeout.lisp000066400000000000000000000106301274371011200211400ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.kernel) (defslots timeout () ((canceled-result) (thread) (lock :initform (make-lock)))) (defun submit-timeout (channel timeout-seconds timeout-result) "Effectively equivalent to (submit-task channel (lambda () (sleep timeout-seconds) timeout-result)) The difference is that `submit-timeout' does not occupy a worker thread. A timeout object is returned, which may be passed to `cancel-timeout'. `submit-timeout' and `cancel-timeout' are deprecated; use the new `:timeout' option in `try-receive-result'." (let ((timeout (make-timeout-instance :canceled-result 'not-canceled :thread nil)) (pushedp nil)) (with-channel-slots (queue) channel (with-timeout-slots (canceled-result thread lock) timeout (macrolet ((push-result (form) ;; Ensure that only one result is pushed. ;; ;; We must check the canceled result inside the ;; lock, so delay evaluation via macrolet. `(with-lock-predicate/wait lock (not pushedp) (push-queue ,form queue) (setf pushedp t)))) (setf thread (with-thread (:name "lparallel-timeout") (unwind-protect/ext :main (sleep timeout-seconds) :abort (push-result (if (eq canceled-result 'not-canceled) (wrap-error 'task-killed-error) canceled-result))) (push-result timeout-result)))))) timeout)) #-lparallel.without-kill (defun cancel-timeout (timeout timeout-result) "Attempt to cancel a timeout. If successful, the channel passed to `submit-timeout' will receive `timeout-result'. At most one call to `cancel-timeout' will succeed; others will be ignored. If the timeout has expired on its own then `cancel-timeout' will have no effect. `cancel-timeout' is not available in ABCL. `submit-timeout' and `cancel-timeout' are deprecated; use the new `:timeout' option in `try-receive-result'." (with-timeout-slots (canceled-result thread lock) timeout ;; ensure that only one cancel succeeds (with-lock-predicate/wait lock (eq canceled-result 'not-canceled) (setf canceled-result timeout-result) (destroy-thread thread))) nil) (defun deprecated-timeout () (simple-style-warning "`submit-timeout' and `cancel-timeout' are deprecated; use the new~%~ `:timeout' option in `try-receive-result'.")) (define-compiler-macro submit-timeout (&whole whole &rest args) (declare (ignore args)) (deprecated-timeout) whole) (define-compiler-macro cancel-timeout (&whole whole &rest args) (declare (ignore args)) (deprecated-timeout) whole) lparallel-20160825-git/src/package.lisp000066400000000000000000000044771274371011200176010ustar00rootroot00000000000000;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.kernel) (macrolet ((package (package-name documentation &rest list) `(defpackage ,package-name (:documentation ,documentation) (:use #:cl ,@list) (:export ,@(loop for package in list append (loop for symbol being the external-symbols in package collect (make-symbol (string symbol)))))))) (package #:lparallel "This is a convenience package which exports the external symbols of: lparallel.kernel lparallel.promise lparallel.defpun lparallel.cognate lparallel.ptree" #:lparallel.kernel #:lparallel.promise #:lparallel.defpun #:lparallel.cognate #:lparallel.ptree)) lparallel-20160825-git/src/promise.lisp000066400000000000000000000247331274371011200176610ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defpackage #:lparallel.promise (:documentation "Promises and futures.") (:use #:cl #:lparallel.util #:lparallel.thread-util #:lparallel.kernel) (:export #:promise #:future #:speculate #:delay #:force #:fulfill #:fulfilledp #:chain) (:import-from #:lparallel.kernel #:unwrap-result #:task-lambda #:make-task #:task #:call-with-task-handler #:submit-raw-task #:wrap-error #:wrapped-error)) (in-package #:lparallel.promise) ;;;; classes ;;; ;;; promise-base ;;; / \ ;;; %promise plan ;;; / \ ;;; speculation = %future %delay ;;; ;;; some class names are prefixed with % to avoid being exported (defconstant +no-result+ 'no-result) (defslots promise-base () ((result :reader result :initform +no-result+) (lock :initform (make-lock)))) (defslots %promise (promise-base) ((cvar :initform nil) (availablep :initform t :type boolean))) ;;; A plan does not need an availablep flag because any failure to ;;; acquire the lock implies the plan is unavailable. (defslots plan (promise-base) ((fn :reader plan-fn :type (or null function)))) (defslots %future (plan) ((canceledp :initform nil :type boolean))) (defslots %delay (plan) ()) (defslots %chain () ((object :reader chain-object))) ;;;; macros (defmacro with-lock-operation (operation promise &body body) (with-gensyms (lock result) `(with-promise-base-slots ((,lock lock) (,result result)) ,promise (,operation ,lock (eq ,result +no-result+) ,@body)))) (defmacro with-unfulfilled/no-wait (promise &body body) `(with-lock-operation with-lock-predicate/no-wait ,promise ,@body)) (defmacro with-unfulfilled/wait (promise &body body) `(with-lock-operation with-lock-predicate/wait ,promise ,@body)) ;;;; promise (defun promise () "Create a promise. A promise is a receptacle for a result which is unknown at the time it is created." (make-%promise-instance)) (defun fulfill-promise (promise client-fn) (with-%promise-slots (result lock cvar availablep) promise ;; spin until it is claimed (loop while availablep do (with-unfulfilled/no-wait promise ;; client-fn could be expensive; set availablep in the meantime (unwind-protect/ext :prepare (setf availablep nil) :main (setf result (multiple-value-list (funcall client-fn))) :abort (setf availablep t)) (when cvar (condition-notify cvar)) (return t))))) (defun force-promise (promise) (with-%promise-slots (result lock cvar) promise (unless cvar (setf cvar (make-condition-variable))) (loop while (eq result +no-result+) do (condition-wait cvar lock)) (condition-notify cvar))) ;;;; plan (defun/inline fulfill-plan/values (plan values) (with-plan-slots (result fn) plan (setf result values fn nil))) (defun/inline fulfill-plan/call (plan) (fulfill-plan/values plan (multiple-value-list (call-with-task-handler (plan-fn plan))))) (defun fulfill-plan/error (plan err) (fulfill-plan/values plan (list (wrap-error err)))) ;;;; delay (defmacro delay (&body body) "Create a delay. A delay is a promise which is fulfilled when `force' is called upon it." `(make-%delay-instance :fn (lambda () ,@body))) (defun fulfill-delay (delay client-fn) (with-unfulfilled/no-wait delay (fulfill-plan/values delay (multiple-value-list (funcall client-fn))) t)) (defun force-delay (delay) ;; do not use task handler (fulfill-plan/values delay (multiple-value-list (funcall (plan-fn delay))))) ;;;; future (defun fulfill-future (future client-fn) (with-unfulfilled/no-wait future ;; If we are here then we've stolen the task from the kernel. (with-%future-slots (canceledp) future (setf canceledp t) (fulfill-plan/values future (multiple-value-list (funcall client-fn)))) t)) (defun force-future (future) ;; If we are here then we've stolen the task from the kernel. (with-%future-slots (canceledp) future (setf canceledp t) (fulfill-plan/call future))) (defmacro with-unfulfilled-future/no-wait (future &body body) (with-gensyms (lock canceledp result) `(with-%future-slots ((,lock lock) (,canceledp canceledp) (,result result)) ,future (with-lock-predicate/no-wait ,lock (and (not ,canceledp) (eq ,result +no-result+)) ,@body)))) (defun/type make-future-task (future) (%future) task (declare #.*full-optimize*) (make-task (lambda () (with-unfulfilled-future/no-wait future (unwind-protect/ext :main (fulfill-plan/call future) ;; the task handler handles everything; unwind means thread kill :abort (fulfill-plan/error future 'task-killed-error)))))) (defun/type make-future (fn) (function) %future (declare #.*normal-optimize*) (let ((kernel (check-kernel)) (future (make-%future-instance :fn fn))) (submit-raw-task (make-future-task future) kernel) future)) (defmacro future (&body body) "Create a future. A future is a promise which is fulfilled in parallel by the implicit progn `body'." `(make-future (task-lambda ,@body))) ;;;; speculate (defmacro speculate (&body body) "Create a speculation. A speculation is a low-priority future." `(let ((*task-priority* :low)) (future ,@body))) ;;;; chain (defun chain (object) "Create a chain. A chain links objects together by relaying `force' and `fulfilledp' calls." (make-%chain-instance :object object)) ;;;; fulfill, fulfilledp, force (defun fulfill-object (object client-fn) (typecase object (%future (fulfill-future object client-fn)) (%promise (fulfill-promise object client-fn)) (%delay (fulfill-delay object client-fn)) (%chain (fulfill-object (chain-object object) client-fn)) (otherwise nil))) (defmacro fulfill (object &body body) "Attempt to give `object' a value. If `object' is a promise which is not fulfilled and not currently being fulfilled, then the implicit progn `body' will be executed and the promise will store the result. In this case `fulfill' returns true. If `object' is a promise that is either already fulfilled or actively being fulfilled, then `body' will not be executed and `fulfill' returns false. If `object' is a chain, call `fulfill' on the chained object. If `object' is not a promise and not a chain then false is returned immediately, with `body' being ignored." `(fulfill-object ,object (lambda () ,@body))) (defun fulfilledp (object) "If `object' is a promise, return a boolean indicating whether the promise is fulfilled. If `object' is a chain, call `fulfilledp' on the chained object. If `object' is not a promise and not a chain, return true." (declare #.*normal-optimize*) (typecase object (promise-base (not (eq (result object) +no-result+))) (%chain (fulfilledp (chain-object object))) (otherwise t))) (defun replace-error (promise) ;; It is not possible to return from `force' while the promise ;; contains an error. Therefore we do not violate the ;; one-result-only constraint by replacing a wrapped error result ;; with value(s). ;; ;; If a successful store-value invocation happens concurrently then ;; skip. (with-promise-base-slots (result lock) promise (with-lock-predicate/wait lock (typep (first result) 'wrapped-error) (restart-case (unwrap-result (first result)) (store-value (&rest values) :report "Set promise value(s)." :interactive (lambda () (interact "Promise value(s): ")) (setf result values)))))) (defun force (object) "If `object' is a promise and the promise is fulfilled, return the fulfilled value (possibly multiple values). If the promise is unfulfilled then the call blocks until the promise is fulfilled. If `object' is a chain, call `force' on the chained object. If `object' is not a promise and not a chain, return the identical object passed. Note if `force' is called on an unfulfilled future then the future is fulfilled by the caller of `force'." (declare #.*normal-optimize*) (typecase object (promise-base (with-unfulfilled/wait object (etypecase object (%future (force-future object)) (%promise (force-promise object)) (%delay (force-delay object)))) ;; result must now be a list (let ((result (result object))) (typecase (first result) (wrapped-error (replace-error object) (force object)) (%chain (force (chain-object (first result)))) (otherwise (values-list result))))) (%chain (force (chain-object object))) (otherwise object))) lparallel-20160825-git/src/ptree.lisp000066400000000000000000000331301274371011200173110ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defpackage #:lparallel.ptree (:documentation "A ptree is a computation represented by a tree together with functionality to execute the tree in parallel.") (:use #:cl #:lparallel.util #:lparallel.thread-util #:lparallel.kernel #:lparallel.queue) (:export #:ptree #:ptree-fn #:make-ptree #:check-ptree #:call-ptree #:ptree-computed-p #:clear-ptree #:clear-ptree-errors #:*ptree-node-kernel*) (:export #:ptree-undefined-function-error #:ptree-lambda-list-keyword-error #:ptree-redefinition-error) (:import-from #:lparallel.kernel #:kernel #:submit-raw-task #:with-task-context #:make-task #:task-lambda #:wrapped-error #:wrap-error #:unwrap-result)) (in-package #:lparallel.ptree) ;;;; errors (define-condition ptree-error (error) ((id :initarg :id :reader ptree-error-id))) (define-condition ptree-redefinition-error (ptree-error) () (:report (lambda (err stream) (format stream "ptree function redefined: ~a" (ptree-error-id err)))) (:documentation "Attempted to redefine a node's function.")) (define-condition ptree-undefined-function-error (ptree-error) ((refs :initarg :refs :initform nil :reader ptree-error-refs)) (:report (lambda (err stream) (format stream "Function not found in ptree: ~a" (ptree-error-id err)) (when-let (refs (ptree-error-refs err)) (format stream "~%Referenced by: ~{~a~^ ~}" refs)))) (:documentation "Attempted to execute a node which had no function.")) (define-condition ptree-lambda-list-keyword-error (ptree-error) ((llks :initarg :llks :reader ptree-error-llks)) (:report (lambda (err stream) (format stream "Function arguments in `ptree' cannot contain lambda list ~ keywords.~%In definition of ~a found: ~{~s~^ ~}" (ptree-error-id err) (ptree-error-llks err)))) (:documentation "Lambda list keywords found in function definition.")) ;;;; node (defconstant +no-result+ 'no-result) (defslots node () ((id :reader id) (function :initform nil :type (or function null)) (children :initform nil :type list) (parents :initform nil :type list) (lock-level :reader lock-level :initform 0 :type fixnum) (children-done-p :initform nil :type boolean) (result :reader result :initform +no-result+))) (defun clear-node (node) (with-node-slots (lock-level children-done-p result) node (setf lock-level 0 children-done-p nil result +no-result+))) (defun clear-node-error (node) (with-node-slots (lock-level children-done-p result) node (setf lock-level 0 children-done-p nil) (when (typep result 'wrapped-error) (setf result +no-result+)))) (defun check-node (node) (with-node-slots (id function parents) node (unless function (error 'ptree-undefined-function-error :id id :refs (mapcar #'id parents))))) (defun/type/inline computedp (node) (node) boolean (declare #.*full-optimize*) (not (eq (result node) +no-result+))) (defun/type compute-node (node) (node) t (declare #.*normal-optimize*) (with-node-slots (function children result) node (unwind-protect/ext :main (setf result (with-task-context (let ((function function)) (typecase function (function (apply (the function function) (mapcar #'result children))) (otherwise (check-node node)))))) :abort (setf result (wrap-error 'task-killed-error))))) (defun/type/inline freep (node) (node) t (declare #.*full-optimize*) (zerop (lock-level node))) (defun/type propagate-error (node error-result) (node wrapped-error) (values) (declare #.*full-optimize*) (with-node-slots (result parents) node (setf result error-result) (dolist (parent parents) (propagate-error parent error-result))) (values)) (defun/type lock-node (node) (node) (values) (declare #.*full-optimize*) (with-node-slots (lock-level parents) node (incf lock-level) (dolist (parent parents) (lock-node parent))) (values)) (defun/type unlock-node (node) (node) (values) (declare #.*full-optimize*) (with-node-slots (lock-level parents) node (decf lock-level) (dolist (parent parents) (unlock-node parent))) (values)) (defun/type/inline children-done-p (node) (node) boolean (declare #.*full-optimize*) (with-node-slots (children children-done-p) node (or children-done-p (null children) (progn (dolist (child children) (unless (computedp child) (return-from children-done-p nil))) (setf children-done-p t))))) (defvar *ptree-node-kernel* nil "When non-nil, `*kernel*' is bound to this value during the call of a node function.") (defun/type make-node-task (queue node) (queue node) t (declare #.*normal-optimize*) (let ((compute (task-lambda ;; avoid allocation from extent checks with safety 0 (sbcl) (declare #.*full-optimize*) (unwind-protect (compute-node node) (push-queue node queue))))) (make-task (if *ptree-node-kernel* (let ((node-kernel *ptree-node-kernel*)) (lambda () (let ((*kernel* node-kernel)) (funcall compute)))) compute)))) (defun/type submit-node (node queue kernel) (node queue kernel) (values) (declare #.*normal-optimize*) (let ((task (make-node-task queue node))) (submit-raw-task task kernel)) (values)) (defun/type find-node (node) (node) (or node null) (declare #.*full-optimize*) (with-node-slots (children) node (cond ((computedp node) ;; already computed nil) ((and (freep node) (children-done-p node)) ;; not computed, not locked, and its children are computed; ;; ready to compute node) (t ;; not computed and either locked or children not computed; ;; recurse to children (dolist (child children) (when-let (found (find-node child)) (return found))))))) ;;;; ptree (defslots ptree () ((nodes :initform (make-hash-table :test #'eql) :type hash-table :reader nodes) (queue :initform (make-queue) :type queue) (pending :initform 0 :type integer) (lock :initform (make-lock) :reader lock)) (:documentation "A ptree is a computation represented by a tree together with functionality to execute the tree in parallel.")) (defun make-ptree () "Create a ptree instance." (make-ptree-instance)) (defun/type compute-ptree (root ptree kernel) (node ptree kernel) node (declare #.*normal-optimize*) (with-ptree-slots (queue pending) ptree (loop (let ((node (find-node root))) (cond (node (lock-node node) (incf pending) (submit-node node queue kernel)) (t (setf node (pop-queue queue)) (decf pending) (unlock-node node) (when (typep (result node) 'wrapped-error) (propagate-error node (result node)) (return node)) (when (eq node root) (return node)))))))) (defun wait-for-compute (ptree) (with-ptree-slots (lock queue pending) ptree (loop while (plusp pending) do (pop-queue queue) (decf pending)))) (defun each-node (ptree fn) (maphash (lambda (id node) (declare (ignore id)) (funcall fn node)) (nodes ptree))) (defun check-ptree (ptree) "Verify that all nodes have been defined with an associated function. If not, `ptree-undefined-function-error' is signaled." (with-lock-held ((lock ptree)) (each-node ptree #'check-node))) (defun clear-ptree (ptree) "Clear all node results in `ptree', restoring the tree to its uncomputed state." (with-lock-held ((lock ptree)) (wait-for-compute ptree) (each-node ptree #'clear-node))) (defun clear-ptree-errors (ptree) "Clear all error results in `ptree', allowing the computation to resume from its latest pre-error state." (with-lock-held ((lock ptree)) (wait-for-compute ptree) (each-node ptree #'clear-node-error))) (defun ptree-fn (id args function ptree) "Define a ptree node with identifier `id', which is some unique object suitable for `eql' comparison such as symbol. The ids of its child nodes are elements of the list `args'. `function' is the function associated with this node. The arguments passed to `function' are the respective results of the child node computations. `ptree' is the ptree instance in which the node is being defined." (with-ptree-slots (lock nodes) ptree (with-lock-held (lock) (flet ((fetch-node (id) (or (gethash id nodes) (setf (gethash id nodes) (make-node-instance :id id))))) (let ((node (fetch-node id))) (with-node-slots ((node-function function) (node-children children)) node (when node-function (error 'ptree-redefinition-error :id id)) (setf node-function function) (let ((children (mapcar #'fetch-node args))) (dolist (child children) (with-node-slots (parents) child (push node parents))) (setf node-children children))))))) id) (defun ptree-computed-p (id ptree) "Return true if the node with identifier `id' in `ptree' has finished computing, otherwise return false." (multiple-value-bind (node presentp) (gethash id (nodes ptree)) (if presentp (computedp node) (error 'ptree-undefined-function-error :id id)))) (defun call-ptree (id ptree) "Return the computation result of the node with identifier `id' in `ptree'. If the node is uncomputed, compute the result. If the node is already computed, return the computed result." (let ((root (gethash id (nodes ptree)))) (unless root (error 'ptree-undefined-function-error :id id)) (unwrap-result (result (if (computedp root) root (with-lock-held ((lock ptree)) (wait-for-compute ptree) (if (computedp root) root (compute-ptree root ptree (check-kernel))))))))) (defmacro ptree (defs &body body) "Create a ptree using `flet' syntax. ptree ((node-name child-names function-body)*) form* Each `node-name' form corresponds to the definition of a ptree node. `node-name' is the name of the node being defined (a symbol). `child-names' is a list of the names of child nodes (symbols). The function associated with the node being defined is `(lambda ,child-names ,@function-body) `child-names' cannot contain lambda list keywords. For each `node-name', a symbol macro is defined which expands to a `call-ptree' form for that node." (dolist (def defs) (destructuring-bind (id args &rest forms) def (declare (ignore forms)) (check-type id symbol) (check-type args list) (when-let (llks (intersection args lambda-list-keywords)) (error 'ptree-lambda-list-keyword-error :id id :llks llks)))) (with-gensyms (tree) `(let ((,tree (make-ptree))) ,@(loop for def in defs collect (destructuring-bind (id args &rest forms) def `(ptree-fn ',id ',args (lambda ,args ,@forms) ,tree))) (symbol-macrolet ,(loop for (id nil nil) in defs collect `(,id (call-ptree ',id ,tree))) ,@body)))) lparallel-20160825-git/src/queue.lisp000066400000000000000000000177021274371011200173250ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; This yearns for defmethod, however there are outstanding issues ;;; with highly concurrent defmethod calls. ;;; ;;; The `queue' type is a chimera because a cons-based queue was ;;; measurably faster than a resizable vector queue even with ;;; pre-allocation. (defpackage #:lparallel.queue (:documentation "Blocking FIFO queue for communication between threads.") (:use #:cl #:lparallel.util #:lparallel.thread-util #:lparallel.cons-queue #:lparallel.vector-queue) (:export #:queue #:make-queue #:push-queue #:push-queue/no-lock #:pop-queue #:pop-queue/no-lock #:peek-queue #:peek-queue/no-lock #:queue-count #:queue-count/no-lock #:queue-empty-p #:queue-empty-p/no-lock #:queue-full-p #:queue-full-p/no-lock #:try-pop-queue #:try-pop-queue/no-lock #:with-locked-queue) (:import-from #:alexandria #:simple-style-warning)) (in-package #:lparallel.queue) (deftype queue () '(or cons-queue vector-queue)) (defun %make-queue (&key fixed-capacity initial-contents) (if fixed-capacity (make-vector-queue fixed-capacity :initial-contents initial-contents) (make-cons-queue :initial-contents initial-contents))) (defun make-queue (&rest args) (apply #'%make-queue (if (= 1 (length args)) nil args))) (define-compiler-macro make-queue (&whole whole &rest args) (when (= 1 (length args)) (simple-style-warning "Calling `make-queue' with one argument is deprecated.~%~ Pass no arguments instead.")) whole) (defun call-with-locked-cons-queue (fn queue) (with-locked-cons-queue queue (funcall fn))) (defun call-with-locked-vector-queue (fn queue) (with-locked-vector-queue queue (funcall fn))) (defmacro with-locked-queue (queue &body body) `(call-with-locked-queue (lambda () ,@body) ,queue)) (defun/inline cons-queue-full-p (queue) (declare (ignore queue)) nil) (defun/inline cons-queue-full-p/no-lock (queue) (declare (ignore queue)) nil) (defmacro define-queue-fn (name params cons-name vector-name) `(defun ,name ,params (declare #.*normal-optimize*) (typecase ,(car (last params)) (cons-queue (,cons-name ,@params)) (vector-queue (,vector-name ,@params)) (otherwise (error 'type-error :datum ,(car (last params)) :expected-type 'queue))))) (define-queue-fn push-queue (object queue) push-cons-queue push-vector-queue) (define-queue-fn push-queue/no-lock (object queue) push-cons-queue/no-lock push-vector-queue/no-lock) (define-queue-fn pop-queue (queue) pop-cons-queue pop-vector-queue) (define-queue-fn pop-queue/no-lock (queue) pop-cons-queue/no-lock pop-vector-queue/no-lock) (define-queue-fn peek-queue (queue) peek-cons-queue peek-vector-queue) (define-queue-fn peek-queue/no-lock (queue) peek-cons-queue/no-lock peek-vector-queue/no-lock) (define-queue-fn queue-count (queue) cons-queue-count vector-queue-count) (define-queue-fn queue-count/no-lock (queue) cons-queue-count/no-lock vector-queue-count/no-lock) (define-queue-fn queue-empty-p (queue) cons-queue-empty-p vector-queue-empty-p) (define-queue-fn queue-empty-p/no-lock (queue) cons-queue-empty-p/no-lock vector-queue-empty-p/no-lock) (define-queue-fn queue-full-p (queue) cons-queue-full-p vector-queue-full-p) (define-queue-fn queue-full-p/no-lock (queue) cons-queue-full-p/no-lock vector-queue-full-p/no-lock) (defmacro define-try-pop-queue (name cons-name vector-name) `(defun ,name (queue &key timeout) (declare #.*normal-optimize*) (unless timeout (setf timeout 0)) (typecase queue (cons-queue (,cons-name queue timeout)) (vector-queue (,vector-name queue timeout)) (otherwise (error 'type-error :datum queue :expected-type 'queue))))) (define-try-pop-queue try-pop-queue try-pop-cons-queue try-pop-vector-queue) (define-try-pop-queue try-pop-queue/no-lock try-pop-cons-queue/no-lock try-pop-vector-queue/no-lock) (define-queue-fn call-with-locked-queue (fn queue) call-with-locked-cons-queue call-with-locked-vector-queue) ;;;; doc (setf (documentation 'make-queue 'function) "Create a queue. The queue contents may be initialized with the keyword argument `initial-contents'. 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.") (setf (documentation 'peek-queue 'function) "If `queue' is non-empty, return (values element t) where `element' is the frontmost element of `queue'. If `queue' is empty, return (values nil nil).") (setf (documentation 'push-queue 'function) "Push `object' onto the back of `queue'.") (setf (documentation 'pop-queue 'function) "Remove the frontmost element from `queue' and return it. If `queue' is empty, block until an element is available.") (setf (documentation 'try-pop-queue 'function) "If `queue' is non-empty, remove the frontmost element from `queue' and return (values element t) where `element' is the element removed. If `queue' is empty and `timeout' is given, then wait up to `timeout' seconds for the queue to become non-empty. If `queue' is empty and the timeout has expired, or if `queue' is empty and no `timeout' was given, return (values nil nil). Providing a nil or non-positive value of `timeout' is equivalent to providing no timeout.") (setf (documentation 'queue-count 'function) "Return the number of elements in `queue'.") (setf (documentation 'queue-empty-p 'function) "Return true if `queue' is empty, otherwise return false.") (setf (documentation 'queue-full-p 'function) "Return true if `queue' is full, otherwise return false.") (setf (documentation 'with-locked-queue 'function) "Execute `body' with the queue lock held. Use the `/no-lock' functions inside `body'.") (do-external-symbols (sym *package*) (let ((name (string-downcase (string sym)))) (when (search "/no-lock" name) (setf (documentation sym 'function) (format nil "Like `~a' but does not acquire the lock. ~ Use inside~%`with-locked-queue'." (subseq name 0 (position #\/ name :from-end t))))))) lparallel-20160825-git/src/raw-queue.lisp000066400000000000000000000065621274371011200201160ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; raw-queue -- raw data structure ;;; (defpackage #:lparallel.raw-queue (:documentation "(private) Raw queue data structure.") (:use #:cl #:lparallel.util) (:export #:raw-queue #:make-raw-queue #:push-raw-queue #:pop-raw-queue #:peek-raw-queue #:raw-queue-count #:raw-queue-empty-p)) (in-package #:lparallel.raw-queue) (deftype raw-queue-count () '(integer 0)) (locally (declare #.*full-optimize*) (defstruct (raw-queue (:conc-name nil) (:constructor %make-raw-queue (head tail))) (head (error "no head") :type list) (tail (error "no tail") :type list))) (defun/inline make-raw-queue (&optional initial-capacity) (declare (ignore initial-capacity)) (%make-raw-queue nil nil)) (defun/type push-raw-queue (value queue) (t raw-queue) t (declare #.*full-optimize*) (let ((new (cons value nil))) (if (head queue) (setf (cdr (tail queue)) new) (setf (head queue) new)) (setf (tail queue) new))) (defun/type pop-raw-queue (queue) (raw-queue) (values t boolean) (declare #.*full-optimize*) (let ((node (head queue))) (if node (multiple-value-prog1 (values (car node) t) (when (null (setf (head queue) (cdr node))) (setf (tail queue) nil)) ;; clear node for conservative gcs (setf (car node) nil (cdr node) nil)) (values nil nil)))) (defun/inline raw-queue-count (queue) (length (the list (head queue)))) (defun/inline raw-queue-empty-p (queue) (not (head queue))) (defun/inline peek-raw-queue (queue) (let ((node (head queue))) (values (car node) (if node t nil)))) lparallel-20160825-git/src/slet.lisp000066400000000000000000000076151274371011200171520ustar00rootroot00000000000000;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defpackage #:lparallel.slet (:documentation "(private) Serial let.") (:use #:cl #:lparallel.util) (:export #:slet) (:import-from #:alexandria #:ensure-list)) (in-package #:lparallel.slet) (defun parse-bindings (bindings) (let ((mv-bindings nil) (null-bindings nil)) (dolist (binding bindings) (etypecase binding (cons (if (= 1 (length binding)) (dolist (var (ensure-list (first binding))) (push var null-bindings)) (destructuring-bind (var-or-vars form) binding (push `(,(ensure-list var-or-vars) ,form) mv-bindings)))) (symbol (push binding null-bindings)))) (values (reverse mv-bindings) (reverse null-bindings)))) ;;; To ensure that `slet' is interchangeable with `plet', use ;;; temporaries to avoid `let*'-like behavior. (defun make-temp-var (var) (gensym (symbol-name var))) (defun make-binding-datum (mv-binding) (destructuring-bind (vars form) mv-binding `(,vars ,(mapcar #'make-temp-var vars) ,form))) (defun make-binding-data (bindings) (multiple-value-bind (mv-bindings null-bindings) (parse-bindings bindings) (values (mapcar #'make-binding-datum mv-bindings) null-bindings))) (defmacro bind ((vars form) &body body) (if (= 1 (length vars)) `(let ((,(first vars) ,form)) ,@body) `(multiple-value-bind ,vars ,form ,@body))) (defmacro %slet (binding-data full-binding-data null-bindings body) (if binding-data (destructuring-bind ((vars temp-vars form) &rest more-binding-data) binding-data (declare (ignore vars)) `(bind (,temp-vars ,form) (%slet ,more-binding-data ,full-binding-data ,null-bindings ,body))) `(let (,@null-bindings ,@(loop for (vars temp-vars nil) in full-binding-data append (mapcar #'list vars temp-vars))) ,@body))) (defmacro slet (bindings &body body) "`slet' (serial let) is the non-parallel counterpart to `plet'. The syntax of `slet' matches that of `plet', which includes the ability to bind multiple values." (multiple-value-bind (binding-data null-bindings) (make-binding-data bindings) `(%slet ,binding-data ,binding-data ,null-bindings ,body))) lparallel-20160825-git/src/spin-queue/000077500000000000000000000000001274371011200173745ustar00rootroot00000000000000lparallel-20160825-git/src/spin-queue/cas-spin-queue.lisp000066400000000000000000000121021274371011200231200ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; Singly-linked queue with compare-and-swap operations. ;;; ;;; The following invariants hold except during updates: ;;; ;;; (node-car (spin-queue-head queue)) == +dummy+ ;;; ;;; (node-cdr (spin-queue-tail queue)) == nil ;;; ;;; If the queue is empty, (spin-queue-head queue) == (queue-tail queue). ;;; ;;; If the queue is non-empty, ;;; (node-car (node-cdr (spin-queue-head queue))) is the next value ;;; to be dequeued and (node-car (spin-queue-tail queue)) is the ;;; most recently enqueued value. ;;; ;;; The CDR of a discarded node is set to +DEAD-END+. This flag must ;;; be checked at each traversal. (in-package #:lparallel.spin-queue) ;;;; node #+(or sbcl lispworks) (progn (deftype node () 'cons) (alias-function make-node cons) (defmacro node-car (node) `(car ,node)) (defmacro node-cdr (node) `(cdr ,node))) ;;; CCL cannot compare-and-swap on a cons. Slots for defstruct must be ;;; untyped for ccl::conditional-store. #+ccl (progn (declaim (inline make-node)) (defstruct (node (:constructor make-node (car cdr))) (car (error "no car")) (cdr (error "no cdr")))) ;;;; spin-queue (defconstant +dummy+ 'dummy) (defconstant +dead-end+ 'dead-end) (defstruct (spin-queue (:constructor %make-spin-queue (head tail))) (head (error "no head") #-ccl :type #-ccl node) (tail (error "no tail") #-ccl :type #-ccl node)) (defun make-spin-queue () (let ((dummy (make-node +dummy+ nil))) (%make-spin-queue dummy dummy))) (defun/type push-spin-queue (value queue) (t spin-queue) (values) ;; Attempt CAS, repeat upon failure. Upon success update QUEUE-TAIL. (declare #.*full-optimize*) (let ((new (make-node value nil))) (loop (when (cas (node-cdr (spin-queue-tail queue)) nil new) (setf (spin-queue-tail queue) new) (return (values)))))) (defun/type pop-spin-queue (queue) (spin-queue) (values t boolean) ;; Attempt to CAS QUEUE-HEAD with the next node, repeat upon ;; failure. Upon success, clear the discarded node and set the CAR ;; of QUEUE-HEAD to +DUMMY+. (declare #.*full-optimize*) (loop (let* ((head (spin-queue-head queue)) (next (node-cdr head))) ;; NEXT could be +DEAD-END+, whereupon we try again. (typecase next (null (return (values nil nil))) (node (when (cas (spin-queue-head queue) head next) (let ((value (node-car next))) (setf (node-cdr head) +dead-end+ (node-car next) +dummy+) (return (values value t))))))))) (defun spin-queue-empty-p (queue) (null (node-cdr (spin-queue-head queue)))) (defun try-each-elem (fun queue) (let ((node (spin-queue-head queue))) (loop (let ((value (node-car node))) (unless (eq value +dummy+) (funcall fun value))) (setf node (node-cdr node)) (cond ((eq node +dead-end+) (return nil)) ((null node) (return t)))))) (defun spin-queue-count (queue) (tagbody :retry (let ((count 0)) (unless (try-each-elem (lambda (elem) (declare (ignore elem)) (incf count)) queue) (go :retry)) (return-from spin-queue-count count)))) (defun peek-spin-queue (queue) (loop until (try-each-elem (lambda (elem) (return-from peek-spin-queue (values elem t))) queue)) (values nil nil)) lparallel-20160825-git/src/spin-queue/default-spin-queue.lisp000066400000000000000000000041001274371011200237750ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.spin-queue) (deftype spin-queue () 'lparallel.queue:queue) (alias-function make-spin-queue lparallel.queue:make-queue) (alias-function push-spin-queue lparallel.queue:push-queue) (alias-function pop-spin-queue lparallel.queue:try-pop-queue) (alias-function peek-spin-queue lparallel.queue:peek-queue) (alias-function spin-queue-count lparallel.queue:queue-count) (alias-function spin-queue-empty-p lparallel.queue:queue-empty-p) lparallel-20160825-git/src/spin-queue/package.lisp000066400000000000000000000040261274371011200216620ustar00rootroot00000000000000;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defpackage #:lparallel.spin-queue (:documentation "(private) Thread-safe FIFO queue which spins instead of locks.") (:use #:cl #:lparallel.util #:lparallel.thread-util) (:export #:spin-queue #:make-spin-queue #:push-spin-queue #:pop-spin-queue #:peek-spin-queue #:spin-queue-count #:spin-queue-empty-p)) (in-package #:lparallel.spin-queue) lparallel-20160825-git/src/thread-util.lisp000066400000000000000000000175441274371011200204270ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defpackage #:lparallel.thread-util (:documentation "(private) Thread utilities.") (:use #:cl #:lparallel.util) (:export #:with-thread #:with-lock-predicate/wait #:with-lock-predicate/no-wait #:condition-notify #:cas #:make-spin-lock #:with-spin-lock-held) (:export #:make-lock #:make-condition-variable #:with-lock-held #:condition-wait #:destroy-thread #:current-thread) #+lparallel.with-green-threads (:export #:thread-yield) (:import-from #:bordeaux-threads #:*default-special-bindings* #:make-thread #:make-condition-variable #:current-thread #:destroy-thread #:make-lock #:acquire-lock #:release-lock #:with-lock-held) #+lparallel.with-green-threads (:import-from #:bordeaux-threads #:thread-yield)) (in-package #:lparallel.thread-util) ;;;; condition-wait ;;; Check for timeout parameter in bordeaux-threads:condition-wait. (eval-when (:compile-toplevel :execute) ;; use special to defeat compiler analysis (defparameter *condition-wait* #'bordeaux-threads:condition-wait) (flet ((has-condition-wait-timeout-p () (let* ((lock (bordeaux-threads:make-lock)) (cvar (bordeaux-threads:make-condition-variable)) (args `(,cvar ,lock :timeout 0.001))) (bordeaux-threads:with-lock-held (lock) (ignore-errors (apply *condition-wait* args) t))))) (unless (has-condition-wait-timeout-p) (pushnew :lparallel.without-bordeaux-threads-condition-wait-timeout *features*)))) #+lparallel.without-bordeaux-threads-condition-wait-timeout (progn (eval-when (:load-toplevel) (pushnew :lparallel.without-bordeaux-threads-condition-wait-timeout *features*)) (defun condition-wait (cvar lock &key timeout) (if timeout (error "Timeout option is not available in this version of ~ bordeaux-threads.") (bordeaux-threads:condition-wait cvar lock)))) #-lparallel.without-bordeaux-threads-condition-wait-timeout (alias-function condition-wait bordeaux-threads:condition-wait) ;;;; condition-notify #+lparallel.with-green-threads (defun condition-notify (cvar) (bordeaux-threads:condition-notify cvar) (thread-yield)) #-lparallel.with-green-threads (alias-function condition-notify bordeaux-threads:condition-notify) ;;;; cas and spin-lock #+lparallel.with-cas (progn (defmacro cas (place old new &environment env) (declare (ignorable env)) (check-type old symbol) ;; macroexpand is needed for sbcl-1.0.53 and older #+sbcl `(eq ,old (sb-ext:compare-and-swap ,(macroexpand place env) ,old ,new)) #+ccl `(ccl::conditional-store ,place ,old ,new) #+lispworks `(sys:compare-and-swap ,place ,old ,new)) #-(or sbcl ccl lispworks) (error "cas not defined") (defun make-spin-lock () nil) (defmacro/once with-spin-lock-held (((access &once container)) &body body) `(locally (declare #.*full-optimize*) (unwind-protect/ext :prepare (loop until (cas (,access ,container) nil t)) :main (progn ,@body) :cleanup (setf (,access ,container) nil))))) #-lparallel.with-cas (progn (defun make-spin-lock () (make-lock)) (defmacro with-spin-lock-held (((access container)) &body body) `(with-lock-held ((,access ,container)) ,@body))) ;;;; general-purpose utilities #+clisp (defmacro with-abort-restart (&body body) `(restart-case (progn ,@body) (abort () :report "Abort thread."))) #-clisp (defmacro with-abort-restart (&body body) `(progn ,@body)) (defmacro with-thread ((&key bindings name) &body body) `(let ((*default-special-bindings* ,bindings)) (make-thread (lambda () (with-abort-restart ,@body)) :name ,name))) (defmacro with-lock-predicate/no-wait (lock predicate &body body) ;; predicate intentionally evaluated twice (with-gensyms (lock-var) `(when ,predicate (let ((,lock-var ,lock)) (when (acquire-lock ,lock-var nil) (unwind-protect (when ,predicate ,@body) (release-lock ,lock-var))))))) (defmacro with-lock-predicate/wait (lock predicate &body body) ;; predicate intentionally evaluated twice `(when ,predicate (with-lock-held (,lock) (when ,predicate ,@body)))) ;;;; special-purpose utilities (defun/inline get-real-time-in-seconds () (/ (get-internal-real-time) internal-time-units-per-second)) (defun %time-remaining (start timeout) (- timeout (- (get-real-time-in-seconds) start))) (defmacro/once with-countdown ((&once time) &body body) (with-gensyms (start) `(let ((,start (get-real-time-in-seconds))) (flet ((time-remaining () (%time-remaining ,start ,time))) (declare (inline time-remaining)) ,@body)))) (defmacro define-locking-fn/base (name args arg-types return-type lock-reader defun/no-lock arg-types/no-lock return-type/no-lock &body body) (let ((name/no-lock (symbolicate name '#:/no-lock))) `(progn (,defun/no-lock ,name/no-lock ,args ,@(unsplice arg-types/no-lock) ,@(unsplice return-type/no-lock) ,@body) (defun/type ,name ,args ,arg-types ,return-type (declare #.*full-optimize*) (with-lock-held ((,lock-reader ,(car (last args)))) (,name/no-lock ,@args)))))) (defmacro define-locking-fn (name args arg-types return-type lock &body body) `(define-locking-fn/base ,name ,args ,arg-types ,return-type ,lock defun/type ,arg-types ,return-type (declare #.*full-optimize*) ,@body)) (defmacro define-simple-locking-fn (name args arg-types return-type lock &body body) `(define-locking-fn/base ,name ,args ,arg-types ,return-type ,lock defun/inline nil nil (declare #.*full-optimize*) ,@body)) lparallel-20160825-git/src/util/000077500000000000000000000000001274371011200162565ustar00rootroot00000000000000lparallel-20160825-git/src/util/config.lisp000066400000000000000000000043161274371011200204200ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.util) #-lparallel.with-debug (progn (defvar *normal-optimize* '(optimize (speed 3) (safety 1) (debug 1) (compilation-speed 0))) (defvar *full-optimize* '(optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0)))) #+lparallel.with-debug (progn (defvar *normal-optimize* '(optimize (speed 0) (safety 3) (debug 3) (space 0) (compilation-speed 0))) (defvar *full-optimize* '(optimize (speed 0) (safety 3) (debug 3) (space 0) (compilation-speed 0)))) lparallel-20160825-git/src/util/defmacro.lisp000066400000000000000000000061541274371011200207350ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.util) (defmacro defmacro/once (name params &body body) "Like `defmacro' except that params which are immediately preceded by `&once' are passed to a `once-only' call which surrounds `body'." (labels ((once-keyword-p (obj) (and (symbolp obj) (equalp (symbol-name obj) "&once"))) (remove-once-keywords (params) (mapcar (lambda (x) (if (consp x) (remove-once-keywords x) x)) (remove-if #'once-keyword-p params))) (grab-once-param (list) (let ((target (first list))) (when (or (null list) (consp target) (find target lambda-list-keywords) (once-keyword-p target)) (error "`&once' without parameter in ~a" name)) target)) (find-once-params (params) (mapcon (lambda (cell) (destructuring-bind (elem &rest rest) cell (cond ((consp elem) (find-once-params elem)) ((once-keyword-p elem) (list (grab-once-param rest))) (t nil)))) params))) (with-parsed-body (body declares docstring) `(defmacro ,name ,(remove-once-keywords params) ,@(unsplice docstring) ,@declares (once-only ,(find-once-params params) ,@body))))) lparallel-20160825-git/src/util/defpair.lisp000066400000000000000000000070711274371011200205660ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.util) (defmacro defpair (name supers (a b) &optional doc) "Define a cons type using defclass syntax. Exactly two slots and zero superclasses must be given. Available slot options are: `:initform', `:type', `:reader'. A deftype for `name' is defined. `(defpair foo ...)' defines the function `make-foo-instance' which takes keyword arguments corresponding to slots of the same name. All slots must be initialized when an instance is created, else an error will be signaled." (unless (null supers) (error "Non-empty superclass list ~a in DEFPAIR ~a" supers name)) (when doc (unless (and (consp doc) (eq :documentation (car doc))) (error "Expected `:documentation' option in DEFPAIR, got ~a" doc))) (setf a (ensure-list a)) (setf b (ensure-list b)) (labels ((slot-name (slot) (car slot)) (slot-props (slot) (cdr slot)) (slot-type (slot) (or (getf (slot-props slot) :type) t))) (when (eq (slot-name a) (slot-name b)) (error "Multiple slots named ~a in DEFPAIR ~a" (slot-name a) name)) (dolist (slot (list a b)) (unless (slot-name slot) (error "empty slot in ~a" name)) (when (slot-props slot) (let ((diff (set-difference (plist-keys (slot-props slot)) '(:initform :type :reader)))) (unless (null diff) (error "Invalid slot option~p in DEFPAIR: ~{~a^ ~}" (length diff) diff))))) `(progn (deftype ,name () `(cons ,',(slot-type a) ,',(slot-type b))) (alias-function ,(symbolicate '#:make- name '#:-instance) cons) ,@(loop for slot in `(,a ,b) for fn in '(car cdr) for readers = (plist-values-for-key (slot-props slot) :reader) when readers collect `(progn ,@(loop for reader in readers collect `(alias-function ,reader ,fn))))))) lparallel-20160825-git/src/util/defslots.lisp000066400000000000000000000151731274371011200210010ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.util) (defun plist-keys (plist) (loop for x in plist by #'cddr collect x)) (defun plist-values-for-key (plist target-key) (loop for (key value) on plist by #'cddr when (eq key target-key) collect value)) (defun parse-defslots (supers slots options) (unless (<= (length supers) 1) (error "More than one superclass specified in DEFSLOTS: ~s" supers)) (unless (<= (length options) 1) (error "Too many options in DEFSLOTS: ~{~s ~}" options)) (unless (or (null options) (eq (caar options) :documentation)) (error "Option ~s in DEFSLOTS is not :DOCUMENTATION" (caar options))) (loop with allowed = '(:initform :type :reader) for (nil . plist) in slots for keys = (plist-keys plist) do (let ((diff (set-difference keys allowed))) (unless (null diff) (error "Slot option ~s in DEFSLOTS is not one of ~s" (first diff) allowed))))) (defun defslots-names (name) (values (symbolicate '#:make- name '#:-instance) (symbolicate '#:with- name '#:-slots) (symbolicate/no-intern '#:%%%%. name '#:.) (make-symbol (package-name *package*)))) #-lparallel.with-debug (progn (defmacro define-slots-macrolet (package conc-name entries instance &body body) `(symbol-macrolet ,(loop for entry in entries for (name slot) = (if (consp entry) entry `(,entry ,entry)) for accessor = (symbolicate/package package conc-name slot) collect `(,name (,accessor ,instance))) ,@body)) (defmacro define-with-slots-macro (name package conc-name) `(defmacro/once ,name (slots &once instance &body body) `(define-slots-macrolet ,',package ,',conc-name ,slots ,instance ,@body))) (defmacro define-struct (name supers slots options conc-name constructor) `(defstruct (,name (:conc-name ,conc-name) (:constructor ,constructor) ,@(unsplice (when supers `(:include ,(first supers))))) ,@(unsplice (getf (first options) :documentation)) ,@(loop for (slot-name . plist) in slots for initform = (getf plist :initform `(error "slot ~a in ~a not initialized" ',slot-name ',name)) for type = (getf plist :type) collect `(,slot-name ,initform ,@(when type `(:type ,type)))))) (defmacro define-reader (public private type struct) `(progn (declaim (ftype (function (,struct) (values ,(or type t) &optional)) ,public)) (alias-function ,public ,private))) (defmacro define-readers (struct conc-name slots) `(progn ,@(loop for (slot-name . plist) in slots for private = (symbolicate conc-name slot-name) for type = (getf plist :type) append (loop for public in (plist-values-for-key plist :reader) collect `(define-reader ,public ,private ,type ,struct))))) (defmacro %defslots (name supers slots options) (multiple-value-bind (constructor slots-macro-name conc-name package) (defslots-names name) `(progn (define-struct ,name ,supers ,slots ,options ,conc-name ,constructor) (define-with-slots-macro ,slots-macro-name ,package ,conc-name) (define-readers ,name ,conc-name ,slots) ',name)))) #+lparallel.with-debug (defmacro %defslots (name supers slots options) (multiple-value-bind (constructor slots-macro-name) (defslots-names name) `(progn (defclass ,name ,supers ,(loop for slot in (copy-list slots) for slot-name = (first slot) for initarg = (intern (symbol-name slot-name) 'keyword) collect `(,@slot :initarg ,initarg)) ,@options) (defmacro ,slots-macro-name (slot-names instance &body body) `(with-slots ,slot-names ,instance ,@body)) (defun ,constructor (&rest args) (apply #'make-instance ',name args)) ',name))) (defmacro defslots (name supers slots &rest options) "Define a thing with slots. A `defslots' form may expand to either a `defclass' form or a `defstruct' form. Thou art foolish to depend upon either. The syntax of `defslots' matches that of `defclass' with the following restrictions: at most one superclass is permitted; `:initform', `:type', and `:reader', are the only slot options allowed; `:documentation' is the only class option allowed. `(defslots foo ...)' defines the functions `make-foo-instance' and `with-foo-slots' which are like `make-instance' and `with-slots' respectively. `make-foo-instance' takes keyword arguments corresponding to slots of the same name. All slots must be initialized when an instance is created, else an error will be signaled." (setf slots (mapcar #'ensure-list slots)) (parse-defslots supers slots options) `(%defslots ,name ,supers ,slots ,options)) lparallel-20160825-git/src/util/defun.lisp000066400000000000000000000120071274371011200202500ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.util) (defun constrain-return-type (return-type) (if (and (consp return-type) (eq 'values (first return-type))) (if (intersection return-type lambda-list-keywords) return-type (append return-type '(&optional))) `(values ,return-type &optional))) #-lparallel.with-debug (progn (defmacro defun/inline (name lambda-list &body body) "Shortcut for (declaim (inline foo)) (defun foo ...)." `(progn (declaim (inline ,name)) (defun ,name ,lambda-list ,@body))) (defmacro defun/type (name lambda-list arg-types return-type &body body) "Shortcut for (declaim (ftype (function arg-types return-type) foo) (defun foo ...). Additionally constrains return-type to the number of values provided." (setf return-type (constrain-return-type return-type)) (with-parsed-body (body declares docstring) `(progn (declaim (ftype (function ,arg-types ,return-type) ,name)) (defun ,name ,lambda-list ,@(unsplice docstring) ,@declares ;; for a simple arg list, also declare types ,@(when (not (intersection lambda-list lambda-list-keywords)) (loop for type in arg-types for param in lambda-list collect `(declare (type ,type ,param)))) (the ,return-type (progn ,@body)))))) (defmacro defun/type/inline (name lambda-list arg-types return-type &body body) `(progn (declaim (inline ,name)) (defun/type ,name ,lambda-list ,arg-types ,return-type ,@body)))) ;;; Since return types are not always checked, check manually. #+lparallel.with-debug (progn (defmacro defun/type (name lambda-list arg-types return-type &body body) (setf return-type (constrain-return-type return-type)) (with-parsed-body (body declares docstring) `(progn (declaim (ftype (function ,arg-types ,return-type) ,name)) (defun ,name ,lambda-list ,@(unsplice docstring) ,@declares ;; for a simple arg list, check types ,@(when (not (intersection lambda-list lambda-list-keywords)) (loop for type in arg-types for param in lambda-list collect `(check-type ,param ,type))) ;; for a simple values list, check types ,(if (intersection (ensure-list return-type) lambda-list-keywords) `(progn ,@body) (let* ((return-types (if (and (consp return-type) (eq 'values (car return-type))) (cdr return-type) (list return-type))) (return-vars (mapcar (lambda (x) (if (symbolp x) (gensym (symbol-name x)) (gensym))) return-types))) `(multiple-value-bind ,return-vars (progn ,@body) ,@(loop for type in return-types for var in return-vars collect `(check-type ,var ,type)) (values ,@return-vars)))))))) (alias-macro defun/inline defun) (alias-macro defun/type/inline defun/type)) lparallel-20160825-git/src/util/misc.lisp000066400000000000000000000115511274371011200201050ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel.util) (defmacro alias-function (alias orig) `(progn (setf (symbol-function ',alias) #',orig) (define-compiler-macro ,alias (&rest args) `(,',orig ,@args)) ',alias)) (defmacro alias-macro (alias orig) `(progn (setf (macro-function ',alias) (macro-function ',orig)) ',alias)) (defun unsplice (form) (if form (list form) nil)) (defun symbolicate/package (package &rest string-designators) "Concatenate `string-designators' then intern the result into `package'." (let ((*package* (find-package package))) (apply #'symbolicate string-designators))) (defun symbolicate/no-intern (&rest string-designators) "Concatenate `string-designators' then make-symbol the result." (format-symbol nil "~{~a~}" string-designators)) (defmacro with-parsed-body ((body declares &optional docstring) &body own-body) "Pop docstring and declarations off `body' and assign them to the variables `docstring' and `declares' respectively. If `docstring' is not present then no docstring is parsed." (if docstring `(multiple-value-bind (,body ,declares ,docstring) (parse-body ,body :documentation t) ,@own-body) `(multiple-value-bind (,body ,declares) (parse-body ,body) ,@own-body))) (declaim (inline to-boolean)) (defun to-boolean (x) (if x t nil)) (defun interact (&rest prompt) "Read from user and eval." (apply #'format *query-io* prompt) (finish-output *query-io*) (multiple-value-list (eval (read *query-io*)))) (defmacro repeat (n &body body) `(loop repeat ,n do (progn ,@body))) (defmacro dosequence ((var sequence &optional return) &body body) (with-gensyms (body-fn) `(block nil (flet ((,body-fn (,var) ,@body)) (declare (dynamic-extent #',body-fn)) (map nil #',body-fn ,sequence) ,@(unsplice (when return `(let ((,var nil)) (declare (ignorable ,var)) ,return))))))) (defmacro unwind-protect/ext (&key prepare main cleanup abort) "Extended `unwind-protect'. `prepare' : executed first, outside of `unwind-protect' `main' : protected form `cleanup' : cleanup form `abort' : executed if `main' does not finish " (with-gensyms (finishedp) `(progn ,@(unsplice prepare) ,(cond ((and main cleanup abort) `(let ((,finishedp nil)) (declare (type boolean ,finishedp)) (unwind-protect (prog1 ,main ; m-v-prog1 in real life (setf ,finishedp t)) (if ,finishedp ,cleanup (unwind-protect ,abort ,cleanup))))) ((and main cleanup) `(unwind-protect ,main ,cleanup)) ((and main abort) `(let ((,finishedp nil)) (declare (type boolean ,finishedp)) (unwind-protect (prog1 ,main (setf ,finishedp t)) (when (not ,finishedp) ,abort)))) (main main) (cleanup `(progn ,cleanup nil)) (abort nil) (t nil))))) (deftype index () 'array-index) (alias-function partial-apply curry) lparallel-20160825-git/src/util/package.lisp000066400000000000000000000052011274371011200205400ustar00rootroot00000000000000;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defpackage #:lparallel.util (:documentation "(private) Miscellaneous utilities.") (:use #:cl) (:export #:with-gensyms #:defmacro/once #:unsplice #:symbolicate #:with-parsed-body) (:export #:repeat #:when-let #:dosequence #:alias-function #:alias-macro #:unwind-protect/ext) (:export #:defun/inline #:defun/type #:defun/type/inline) (:export #:defslots #:defpair) (:export #:interact #:ensure-function #:to-boolean #:partial-apply) (:export #:index) (:export #:*normal-optimize* #:*full-optimize*) (:import-from #:alexandria #:with-gensyms #:when-let #:symbolicate #:ensure-function #:once-only #:parse-body #:ensure-list #:format-symbol #:array-index #:curry)) (in-package #:lparallel.util) lparallel-20160825-git/src/vector-queue.lisp000066400000000000000000000220241274371011200206160ustar00rootroot00000000000000;;; Copyright (c) 2011-2013, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defpackage #:lparallel.vector-queue (:documentation "(private) Blocking fixed-capacity queue.") (:use #:cl #:lparallel.util #:lparallel.thread-util) (:export #:vector-queue #:make-vector-queue #:push-vector-queue #:push-vector-queue/no-lock #:pop-vector-queue #:pop-vector-queue/no-lock #:peek-vector-queue #:peek-vector-queue/no-lock #:vector-queue-count #:vector-queue-count/no-lock #:vector-queue-empty-p #:vector-queue-empty-p/no-lock #:vector-queue-full-p #:vector-queue-full-p/no-lock #:try-pop-vector-queue #:try-pop-vector-queue/no-lock #:with-locked-vector-queue #:vector-queue-capacity) (:import-from #:lparallel.thread-util #:define-locking-fn #:define-simple-locking-fn #:with-countdown #:time-remaining) (:import-from #:alexandria #:array-length)) (in-package #:lparallel.vector-queue) ;;;; raw-queue (deftype raw-queue-count () 'array-length) (defslots raw-queue () ((data :reader data :type simple-array) (start :initform 0 :type index) (count :initform 0 :reader raw-queue-count :type raw-queue-count))) (defun make-raw-queue (capacity) (make-raw-queue-instance :data (make-array capacity))) (defun/type push-raw-queue (value queue) (t raw-queue) (values) (declare #.*full-optimize*) (with-raw-queue-slots (data start count) queue (setf (svref data (mod (+ start count) (length data))) value) (incf count)) (values)) (defun/type pop-raw-queue (queue) (raw-queue) (values t boolean) (declare #.*full-optimize*) (with-raw-queue-slots (data start count) queue (let ((data data)) (if (plusp count) (multiple-value-prog1 (values (svref data start) t) (setf (svref data start) nil start (mod (1+ start) (length data))) (decf count)) (values nil nil))))) (defun/type peek-raw-queue (queue) (raw-queue) (values t boolean) (declare #.*full-optimize*) (with-raw-queue-slots (data start count) queue (if (plusp count) (values (svref data start) t) (values nil nil)))) (defun/type/inline raw-queue-empty-p (queue) (raw-queue) t (declare #.*full-optimize*) (zerop (raw-queue-count queue))) (defun/type/inline raw-queue-full-p (queue) (raw-queue) t (declare #.*full-optimize*) (eql (raw-queue-count queue) (length (data queue)))) (defun/type/inline raw-queue-capacity (queue) (raw-queue) raw-queue-count (declare #.*full-optimize*) (length (data queue))) ;;;; vector-queue (defslots vector-queue () ((impl :reader impl :type raw-queue) (lock :reader lock :initform (make-lock)) (notify-push :initform nil) (notify-pop :initform nil))) (defun %make-vector-queue (capacity) (make-vector-queue-instance :impl (make-raw-queue capacity))) (defmacro with-locked-vector-queue (queue &body body) `(with-lock-held ((lock ,queue)) ,@body)) (define-locking-fn push-vector-queue (object queue) (t vector-queue) (values) lock (with-vector-queue-slots (impl lock notify-push notify-pop) queue (loop (cond ((< (raw-queue-count impl) (raw-queue-capacity impl)) (push-raw-queue object impl) (when notify-push (condition-notify notify-push)) (return)) (t (condition-wait (or notify-pop (setf notify-pop (make-condition-variable))) lock))))) (values)) (define-locking-fn pop-vector-queue (queue) (vector-queue) t lock (with-vector-queue-slots (impl lock notify-push notify-pop) queue (loop (multiple-value-bind (value presentp) (pop-raw-queue impl) (cond (presentp (when notify-pop (condition-notify notify-pop)) (return value)) (t (condition-wait (or notify-push (setf notify-push (make-condition-variable))) lock))))))) (defun %try-pop-vector-queue/no-lock/timeout (queue timeout) ;; queue is empty and timeout is positive (declare #.*full-optimize*) (with-countdown (timeout) (with-vector-queue-slots (impl lock notify-push notify-pop) queue (loop (multiple-value-bind (value presentp) (pop-raw-queue impl) (when presentp (when notify-pop (condition-notify notify-pop)) (return (values value t))) (let ((time-remaining (time-remaining))) (when (or (not (plusp time-remaining)) (null (condition-wait (or notify-push (setf notify-push (make-condition-variable))) lock :timeout time-remaining))) (return (values nil nil))))))))) (defun try-pop-vector-queue/no-lock/no-timeout (queue) (declare #.*full-optimize*) (with-vector-queue-slots (impl notify-pop) queue (multiple-value-bind (value presentp) (pop-raw-queue impl) (cond (presentp (when notify-pop (condition-notify notify-pop)) (values value t)) (t (values nil nil)))))) (defun try-pop-vector-queue/no-lock/timeout (queue timeout) (declare #.*full-optimize*) (with-vector-queue-slots (impl) queue (if (raw-queue-empty-p impl) (%try-pop-vector-queue/no-lock/timeout queue timeout) (try-pop-vector-queue/no-lock/no-timeout queue)))) (defun try-pop-vector-queue (queue timeout) (declare #.*full-optimize*) (with-vector-queue-slots (impl lock) queue (cond ((plusp timeout) (with-lock-held (lock) (try-pop-vector-queue/no-lock/timeout queue timeout))) (t ;; optimization: don't lock if nothing is there (with-lock-predicate/wait lock (not (raw-queue-empty-p impl)) (return-from try-pop-vector-queue (try-pop-vector-queue/no-lock/no-timeout queue))) (values nil nil))))) (defun try-pop-vector-queue/no-lock (queue timeout) (declare #.*full-optimize*) (if (plusp timeout) (try-pop-vector-queue/no-lock/timeout queue timeout) (try-pop-vector-queue/no-lock/no-timeout queue))) (defmacro define-queue-fn (name arg-types raw return-type) `(define-simple-locking-fn ,name (queue) ,arg-types ,return-type lock (,raw (impl queue)))) (define-queue-fn vector-queue-count (vector-queue) raw-queue-count raw-queue-count) (define-queue-fn vector-queue-capacity (vector-queue) raw-queue-capacity raw-queue-count) (define-queue-fn vector-queue-empty-p (vector-queue) raw-queue-empty-p boolean) (define-queue-fn vector-queue-full-p (vector-queue) raw-queue-full-p boolean) (define-queue-fn peek-vector-queue (vector-queue) peek-raw-queue (values t boolean)) (defun make-vector-queue (capacity &key initial-contents) (let ((queue (%make-vector-queue capacity))) (when initial-contents (block done (flet ((push-elem (elem) (when (vector-queue-full-p/no-lock queue) (return-from done)) (push-vector-queue/no-lock elem queue))) (declare (dynamic-extent #'push-elem)) (map nil #'push-elem initial-contents)))) queue)) lparallel-20160825-git/test/000077500000000000000000000000001274371011200154715ustar00rootroot00000000000000lparallel-20160825-git/test/1am.lisp000066400000000000000000000101121274371011200170330ustar00rootroot00000000000000;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; See https://github.com/lmj/1am (defpackage #:lparallel-test.1am (:use #:cl) (:export #:test #:is #:signals #:run #:*tests*)) (in-package #:lparallel-test.1am) (defvar *tests* nil "A list of tests; the default argument to `run'.") (defvar *pass-count* nil) (defvar *running* nil) (defvar *failed-random-state* nil) (defun %shuffle (vector) (loop for i downfrom (- (length vector) 1) to 1 do (rotatef (aref vector i) (aref vector (random (1+ i))))) vector) (defun shuffle (sequence) (%shuffle (map 'vector #'identity sequence))) (defun call-with-random-state (fn) (let ((*random-state* (or *failed-random-state* (load-time-value (make-random-state t))))) (setf *failed-random-state* (make-random-state nil)) (multiple-value-prog1 (funcall fn) (setf *failed-random-state* nil)))) (defun report (test-count pass-count) (format t "~&Success: ~s test~:p, ~s check~:p.~%" test-count pass-count)) (defun %run (fn test-count) (let ((*pass-count* 0)) (multiple-value-prog1 (call-with-random-state fn) (report test-count *pass-count*)))) (defun run (&optional (tests *tests*)) "Run each test in the sequence `tests'. Default is `*tests*'." (let ((*running* t)) (%run (lambda () (map nil #'funcall (shuffle tests))) (length tests))) (values)) (defun call-test (name fn) (format t "~&~s" name) (finish-output) (if *running* (funcall fn) (%run fn 1))) (defmacro test (name &body body) "Define a test function and add it to `*tests*'." `(progn (defun ,name () (call-test ',name (lambda () ,@body))) (pushnew ',name *tests*) ',name)) (defun passed () (write-char #\.) ;; Checks done outside a test run are not tallied. (when *pass-count* (incf *pass-count*)) (values)) (defmacro is (form) "Assert that `form' evaluates to non-nil." `(progn (assert ,form) (passed))) (defun %signals (expected fn) (flet ((handler (condition) (cond ((typep condition expected) (passed) (return-from %signals (values))) (t (error "Expected to signal ~s, but got ~s:~%~a" expected (type-of condition) condition))))) (handler-bind ((condition #'handler)) (funcall fn))) (error "Expected to signal ~s, but got nothing." expected)) (defmacro signals (condition &body body) "Assert that `body' signals a condition of type `condition'." `(%signals ',condition (lambda () ,@body))) lparallel-20160825-git/test/base.lisp000066400000000000000000000101661274371011200173000ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel-test) (define-condition client-error (error) ()) (define-condition foo-error (error) ()) (defparameter *memo* nil) (defparameter *nil* nil) (alias-function execute run) (alias-macro base-test test) (defun call-full-test (name body-fn) (dolist (n '(1 2 4 8 16)) (with-temp-kernel (n :spin-count 0) (funcall body-fn)) ;; kludge for checking :use-caller (when (search "defpun" (symbol-name name) :test #'equalp) (with-temp-kernel (n :spin-count (random 5000) :use-caller t) (funcall body-fn))) #+lparallel.with-stealing-scheduler (with-temp-kernel (n :spin-count (random 5000)) (funcall body-fn)))) (defmacro full-test (name &body body) `(base-test ,name (call-full-test ',name (lambda () ,@body)))) (defun extract-queue (queue) (loop until (queue-empty-p queue) collect (pop-queue queue))) (defun invoke-abort-thread () (flet ((fail () (error "Can't find an abort-like restart in this CL!"))) (let ((restarts (mapcar #'restart-name (compute-restarts)))) (if (find 'abort restarts) (invoke-restart 'abort) #-sbcl (fail) #+sbcl (let ((term (find-symbol (string '#:terminate-thread) 'sb-thread))) (if (and term (find term restarts)) (invoke-restart term) (fail))))))) (defun thread-count () ;; ccl can spontaneously lose the initial thread (issue #1042) #+ccl (count "Initial" (bordeaux-threads:all-threads) :key #'bordeaux-threads:thread-name :test-not #'string=) #-ccl (length (bordeaux-threads:all-threads))) (defun call-with-thread-count-check (body-fn) (sleep 0.2) (let ((old-thread-count (thread-count))) (funcall body-fn) (sleep 0.2) (is (eql old-thread-count (thread-count))))) (defmacro with-thread-count-check (&body body) `(call-with-thread-count-check (lambda () ,@body))) (defun infinite-loop () (loop until *nil*)) (defmacro collect-n (n &body body) "Execute `body' `n' times, collecting the results into a list." `(loop repeat ,n collect (progn ,@body))) (defun make-random-list (size) (collect-n size (random 1.0))) (defun make-random-vector (size) (map-into (make-array size) (lambda () (random 1.0)))) (defun compile/muffled (&rest args) (handler-bind (((or warning #+ecl c:compiler-note #+sbcl sb-ext:compiler-note) #'muffle-warning)) (apply #'compile args))) lparallel-20160825-git/test/cognate-test.lisp000066400000000000000000001477411274371011200207750ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel-test) (full-test pmap-into-test (let ((a (list nil nil nil))) (pmap-into a '+ '(5 6 7) '(10 11 12)) (is (equal '(15 17 19) a)) (pmap-into a '+ :parts 2 '(5 6 7) '(10 11 12)) (is (equal '(15 17 19) a)) (pmap-into a '+ :parts 3 '(5 6 7) '(10 11 12)) (is (equal '(15 17 19) a))) (let ((a (list nil))) (pmap-into a '+ '(5 6 7) '(10 11 12)) (is (equal '(15) a)) (pmap-into a '+ :parts 2 '(5 6 7) '(10 11 12)) (is (equal '(15) a)) (pmap-into a '+ :parts 3 '(5 6 7) '(10 11 12)) (is (equal '(15) a))) (let ((a (vector nil nil nil))) (pmap-into a '+ '(5 6 7) '(10 11 12)) (is (equalp #(15 17 19) a)) (pmap-into a '+ :parts 2 '(5 6 7) '(10 11 12)) (is (equalp #(15 17 19) a)) (pmap-into a '+ :parts 3 '(5 6 7) '(10 11 12)) (is (equalp #(15 17 19) a))) (let ((a (vector nil))) (pmap-into a '+ '(5 6 7) '(10 11 12)) (is (equalp #(15) a)) (pmap-into a '+ :parts 2 '(5 6 7) '(10 11 12)) (is (equalp #(15) a)) (pmap-into a '+ :parts 3 '(5 6 7) '(10 11 12)) (is (equalp #(15) a)))) (full-test degenerate-pmaps-test (is (eq (map nil #'identity '(0 1 2 3)) (pmap nil #'identity '(0 1 2 3)))) (is (eq (map nil 'identity '(0 1 2 3)) (pmap nil 'identity '(0 1 2 3)))) (is (eq (map-into nil '+ '(2 3) '(4 5)) (pmap-into nil '+ '(2 3) '(4 5)))) (is (equalp (map 'vector #'identity '(0 1 2 3)) (pmap 'vector #'identity '(0 1 2 3)))) (is (equalp (map 'vector 'identity '(0 1 2 3)) (pmap 'vector 'identity '(0 1 2 3)))) (is (equalp (map-into nil '+ '(2 3) '(4 5)) (pmap-into nil '+ '(2 3) '(4 5)))) (is (equal (mapc #'identity '(0 1 2 3)) (pmapc #'identity '(0 1 2 3)))) (is (equal (mapc 'identity '(0 1 2 3)) (pmapc 'identity '(0 1 2 3)))) (is (equal (mapc #'identity '(0 1 2 3)) (pmapc #'identity :parts 4 '(0 1 2 3)))) (is (equal (mapc 'identity '(0 1 2 3)) (pmapc 'identity :parts 4 '(0 1 2 3)))) (is (equal (mapl #'identity '(0 1 2 3)) (pmapl #'identity '(0 1 2 3)))) (is (equal (mapl 'identity '(0 1 2 3)) (pmapl 'identity '(0 1 2 3)))) (is (equal (mapl #'identity '(0 1 2 3)) (pmapl #'identity :parts 4 '(0 1 2 3)))) (is (equal (mapl 'identity '(0 1 2 3)) (pmapl 'identity :parts 4 '(0 1 2 3))))) (full-test pmap-nil-test (loop for n in '(0 1 2 3 4 5 6 7 8 9 10 100 1000) do (let ((a (loop for x from 0 repeat n collect x)) (b (loop for x from 0 repeat n collect (* 2 x))) (q (make-queue))) (pmap nil (lambda (x y) (push-queue (+ x y) q)) a b) (is (equal (sort (extract-queue q) #'<) (loop for x from 0 repeat n collect (* 3 x))))))) (full-test pmapcar-test (is (equal '(15 17 19) (pmapcar '+ '(5 6 7) '(10 11 12)))) (is (equal '(15 17 19) (pmapcar '+ :parts 3 '(5 6 7) '(10 11 12))))) (full-test pmapcar-handles-sequences-test (is (equal (mapcar '+ '(1 2 3) '(4 5 6)) (pmapcar '+ '(1 2 3) #(4 5 6)))) (is (equal (mapcar '+ '(1 2 3) '(4 5 6)) (pmapcar '+ :parts 3 '(1 2 3) #(4 5 6))))) (full-test grind-pmap-test (flet ((f (x y z) (* x y z))) (let* ((lists (collect-n 3 (collect-n 500 (random 1000)))) (args (cons #'f lists)) (expected (apply #'mapcar args))) (is (equal expected (apply #'pmapcar args))) (is (equal expected (apply #'pmapcar #'f :parts 500 lists))) (is (equalp (map 'simple-vector #'identity expected) (apply #'pmap 'simple-vector args))) (is (equalp (map 'simple-vector #'identity expected) (apply #'pmap 'simple-vector #'f :parts 500 lists))) (let ((result (make-list 500))) (is (equal expected (apply #'pmap-into result args))) (is (equal expected result))) (let ((result (make-list 500))) (is (equal expected (apply #'pmap-into result #'f :parts 500 lists))) (is (equal expected result))) (dolist (parts '(nil 1000)) (setf *memo* (make-queue)) (apply #'pmapc (lambda (i x y z) (push-queue (cons i (f x y z)) *memo*)) :parts parts (loop for i from 0 below (apply #'min (mapcar #'length lists)) collect i) lists) (is (= (length expected) (queue-count *memo*))) (is (equal expected (map 'list #'cdr (sort (extract-queue *memo*) '< :key #'car))))) (flet ((join (x y z) (list x y z))) (is (equal (apply #'mapcan #'join lists) (apply #'pmapcan #'join lists))) (is (equal (apply #'mapcon #'join lists) (apply #'pmapcon #'join lists)))) (is (equal (mapcan 'list (list 3 4 5 6 7 8)) (pmapcan 'list (list 3 4 5 6 7 8)))) (is (equal (mapcon (lambda (x) (list (car x))) (list 3 4 5 6 7 8)) (pmapcon (lambda (x) (list (car x))) (list 3 4 5 6 7 8))))))) (full-test pmaplist-test (is (equalp (maplist #'vector '(a b c) '(1 2 3)) (pmaplist #'vector '(a b c) '(1 2 3))))) (full-test grind-pmaplist-test (let* ((lists (collect-n 2 (collect-n 100 (random 100)))) (expected (apply #'maplist #'vector lists))) (is (equalp expected (apply #'pmaplist #'vector lists))) (is (equalp expected (apply #'pmaplist #'vector :parts 100 lists))) (setf *memo* (make-queue)) (apply #'pmapl (lambda (i x y) (push-queue (list i (vector x y)) *memo*)) (loop for i from 0 below (apply #'min (mapcar #'length lists)) collect i) lists) (is (equalp expected (map 'list #'cadr (sort (extract-queue *memo*) '< :key #'caar)))))) (full-test preduce-partial-test (signals simple-error (preduce-partial #'+ #() :initial-value 0)) (signals simple-error (preduce-partial #'+ '() :initial-value 0)) (signals simple-error (preduce-partial #'+ '())) (is (equalp (preduce-partial #'+ '(3 4 5 6 7 8 9 10) :parts 1) #(52))) (is (equalp (preduce-partial #'+ '(3 4 5 6 7 8 9 10) :parts 2) #(18 34))) (is (equalp (preduce-partial #'+ '(3 4 5 6 7 8 9 10) :parts 2 :from-end t) #(18 34))) (is (equalp (preduce-partial #'+ #(3 4 5 6 7 8) :parts 3 :from-end t) #(7 11 15))) (is (equalp (preduce-partial #'+ #(3 4 5 6 7 8) :parts 3) #(7 11 15)))) (full-test grind-preduce-test (is (= 3 (reduce (constantly 3) nil) (preduce (constantly 3) nil))) (is (= 3 (reduce (constantly 5) nil :initial-value 3) (preduce (constantly 5) nil :initial-value 3))) (flet ((non-associative/non-commutative (x y) (+ (* 2 x) y)) (associative/non-commutative (a b) (vector (+ (* (aref a 0) (aref b 0)) (* (aref a 1) (aref b 2))) (+ (* (aref a 0) (aref b 1)) (* (aref a 1) (aref b 3))) (+ (* (aref a 2) (aref b 0)) (* (aref a 3) (aref b 2))) (+ (* (aref a 2) (aref b 1)) (* (aref a 3) (aref b 3))))) (verify (test &rest args) (loop for parts from 1 to 10 do (is (funcall test (apply #'reduce args) (apply #'preduce args))) (is (funcall test (apply #'reduce args) (apply #'preduce (append args (list :parts parts))))) (is (funcall test (apply #'reduce args) (apply #'preduce (append args (list :from-end t))))) (is (funcall test (apply #'reduce args) (apply #'preduce (append args (list :recurse t))))) (is (funcall test (apply #'reduce args) (apply #'preduce (append args (list :recurse t :parts parts))))) (is (funcall test (apply #'reduce args) (apply #'preduce (append args (list :recurse t :parts parts :from-end t)))))))) (let ((a '(0 1 2 3 4 5 6 7)) (b '((9 . 0) (9 . 1) (9 . 2) (9 . 3))) (c (collect-n 100 (random 100))) (d (collect-n 100 (vector (random 10) (random 10) (random 10) (random 10))))) (verify #'= #'+ a) (verify #'= #'+ a :initial-value 0) (verify #'= #'+ b :key #'cdr) (verify #'= #'+ c) (verify #'= #'+ c :initial-value 0) (verify #'= #'+ c :start 42) (verify #'= #'+ c :end 42) (verify #'= #'+ c :start 42 :end 77) (verify #'= #'+ c :start 42 :end 77 :from-end t) (verify #'= #'+ c :start 42 :end 77 :initial-value 0) (verify #'= #'* c :start 42 :end 77 :initial-value 1) (verify #'= #'* c :start 42 :end 77 :initial-value 1 :from-end t) (verify #'equalp #'associative/non-commutative d) (verify #'equalp #'associative/non-commutative d :start 42) (verify #'equalp #'associative/non-commutative d :end 42) (verify #'equalp #'associative/non-commutative d :start 42 :end 77) (verify #'equalp #'associative/non-commutative d :start 42 :end 77 :initial-value (vector 1 0 0 1)) (verify #'equalp #'associative/non-commutative d :start 42 :end 77 :initial-value (vector 1 0 0 1) :from-end t) (let ((serial (reduce #'non-associative/non-commutative c))) (is (= serial (preduce #'non-associative/non-commutative c :parts 1) (preduce #'non-associative/non-commutative c :parts (length c)))) (is (/= serial (preduce #'non-associative/non-commutative c :parts 3) (preduce #'non-associative/non-commutative c :parts 3 :from-end t) (preduce #'non-associative/non-commutative c :parts 4) (preduce #'non-associative/non-commutative c :parts 4 :from-end t) (preduce #'non-associative/non-commutative c :parts 5)))) (is (equal (preduce #'+ c :key (lambda (x) (* x x))) (pmap-reduce (lambda (x) (* x x)) #'+ c))) (is (equal (+ 9 16 25) (pmap-reduce (lambda (x) (* x x)) #'+ '(3 4 5))))))) (full-test grind-pevery-test (flet ((verify (&rest args) (loop for (regular parallel) in '((some psome) (every pevery) (notany pnotany) (notevery pnotevery)) do (is (eql (apply regular args) (apply parallel args)))))) (let ((a (collect-n 200 (random 100))) (b (collect-n 200 (random 100)))) (verify (lambda (x) (< x 100)) a) (verify (lambda (x) (> x 100)) a) (verify (lambda (x) (> x 50)) a) (verify (lambda (x) (< x 50)) a) (verify (lambda (x) (> x 0)) a) (verify (lambda (x) (< x 0)) a) (verify (lambda (x y) (< (+ x y) 200)) a b) (verify (lambda (x y) (> (+ x y) 200)) a b) (verify (lambda (x y) (< (+ x y) 100)) a b) (verify (lambda (x y) (> (+ x y) 100)) a b) (verify (lambda (x y) (< (+ x y) 0)) a b) (verify (lambda (x y) (> (+ x y) 0)) a b)))) (full-test parts-arg-test (flet ((sq (x) (* x x))) (loop for parts from 1 to 8 do (loop for n from 1 to 6 do (let ((a (collect-n n (random n)))) (is (equalp ( map-into (make-array n) #'sq a) (pmap-into (make-array n) #'sq :parts parts a))) (is (equal ( map-into (make-list n) #'sq a) (pmap-into (make-list n) #'sq :parts parts a))) (is (equalp ( map 'vector #'sq a) (pmap 'vector #'sq :parts parts a))) (is (equal ( map 'list #'sq a) (pmap 'list #'sq :parts parts a))) (is (equal ( mapcar #'sq a) (pmapcar #'sq :parts parts a))) (is (equal ( maplist #'car a) (pmaplist #'car :parts parts a))) (is (equal ( mapcan #'list a) (pmapcan #'list :parts parts a))) (is (equal ( mapcon #'list a) (pmapcon #'list :parts parts a))) (pmapc #'sq :parts parts a) (pmapl #'cdr :parts parts a)))))) (defmacro define-plet-test (test-name fn-name defun store-value-p) ;; use assert since this may execute in another thread `(progn (,defun ,fn-name () (plet ((a 3) (b 4)) (assert (= 7 (+ a b)))) (let ((handledp nil)) (block done (handler-bind ((client-error (lambda (e) (declare (ignore e)) (setf handledp t) (return-from done)))) (task-handler-bind ((error (lambda (e) (invoke-restart 'transfer-error e)))) (plet ((a (error 'client-error))) a)))) (assert handledp)) ,(when store-value-p `(task-handler-bind ((error (lambda (e) (invoke-restart 'transfer-error e)))) (handler-bind ((error (lambda (e) (declare (ignore e)) (invoke-restart 'store-value 4)))) (setf *memo* (lambda () (error "foo"))) (plet ((a 3) (b (funcall *memo*))) (assert (= 7 (+ a b)))))))) (full-test ,test-name (,fn-name) (is (= 1 1))))) (define-plet-test plet-test plet-test-fn defun t) (base-test plet-if-test (setf *memo* 0) (plet-if (plusp *memo*) ((a 3)) (is (= 3 a))) (signals no-kernel-error (plet-if (zerop *memo*) ((a 3)) (is (= 3 a))))) (full-test plet-type-declaration-test (plet ((x 3)) (declare (type t x)) (is (= 3 x))) (plet ((x 3)) (declare (fixnum x)) (is (= 3 x))) (plet (((x) 3)) (declare (fixnum x)) (is (= 3 x))) (plet (((x y) (values 3 4))) (declare (type fixnum x y)) (is (= 3 x)) (is (= 4 y))) (plet ((x 3)) (declare (fixnum x)) (declare (integer x)) (is (= 3 x))) (plet ((x 3)) (declare (type fixnum x)) (declare (type t x)) (declare (integer x)) (is (= 3 x))) (plet ((x 3) y) (declare (fixnum x)) (is (equal '(3 nil) (list x y)))) (plet ((x 3) (y)) (declare (fixnum x)) (is (equal '(3 nil) (list x y)))) (plet ((x 3) y) (declare (fixnum x) (type null y)) (is (equal '(3 nil) (list x y)))) (plet ((x 3) (y)) (declare (fixnum x) (type null y)) (is (equal '(3 nil) (list x y))))) (full-test pand-por-test (is (null (pand 3 4 5 6 nil))) (is (null (pand 3 4 nil 5 6))) (is (null (pand nil 3 4 5 6))) (is (member (pand 3 4 5 6) '(3 4 5 6))) (is (member (por 3 4 5 6 nil) '(3 4 5 6))) (is (member (por 3 4 nil 5 6) '(3 4 5 6))) (is (member (por nil 3 4 5 6) '(3 4 5 6))) (when (> (kernel-worker-count) 2) (sleep 0.4) (is (eql 4 (por (progn (sleep 0.2) 3) 4))) (sleep 0.4) (is (eql 3 (pand (progn (sleep 0.2) 3) 4))) (sleep 0.4) (is (eql 4 (por nil (progn (sleep 0.2) 3) 4))) (sleep 0.4) (is (eql 4 (por (progn (sleep 0.2) 3) nil 4))) (sleep 0.4) (is (null (pand nil (progn (sleep 0.2) 3) 4))) (sleep 0.4) (is (null (pand (progn (sleep 0.2) 3) nil 4))))) (full-test psort-test ;; abcl workarounds for worse-case sort bug (dolist (granularity '(nil 1 5 100)) (dolist (size #-lparallel.with-green-threads '(1 5 10 100 10000) #+lparallel.with-green-threads '(1 5 10)) (let ((source (make-random-vector size))) (let ((a (copy-seq source)) (b (copy-seq source))) (is (equalp ( sort a #'<) (psort b #'< :granularity granularity))) #-abcl (is (equalp ( sort a #'<) (psort b #'< :granularity granularity))) #-abcl (is (equalp ( sort a #'>) (psort b #'> :granularity granularity))) #-abcl (is (equalp ( sort a #'>) (psort b #'> :granularity granularity))))) (let ((source (make-random-vector size))) (let ((a (copy-seq source)) (b (copy-seq source))) (is (equalp ( sort a '< :key '-) (psort b '< :key '- :granularity granularity))) #-abcl (is (equalp ( sort a '< :key #'-) (psort b '< :key #'- :granularity granularity))) #-abcl (is (equalp ( sort a #'> :key '-) (psort b #'> :key '- :granularity granularity))) #-abcl (is (equalp ( sort a #'> :key #'-) (psort b #'> :key #'- :granularity granularity)))))) (let ((source (vector 5 1 9 3 6 0 1 9))) (let ((a (copy-seq source)) (b (copy-seq source))) (is (equalp ( sort a #'<) (psort b #'< :granularity granularity))) #-abcl (is (equalp ( sort a #'<) (psort b #'< :granularity granularity))) #-abcl (is (equalp ( sort a #'>) (psort b #'> :granularity granularity))) #-abcl (is (equalp ( sort a #'>) (psort b #'> :granularity granularity))))) (let ((source (vector 5 1 9 3 6 0 1 9))) (let ((a (copy-seq source)) (b (copy-seq source))) (is (equalp ( sort a #'< :key (lambda (x) (* -1 x))) (psort b #'< :key (lambda (x) (* -1 x)) :granularity granularity))) #-abcl (is (equalp ( sort a #'< :key (lambda (x) (* -1 x))) (psort b #'< :key (lambda (x) (* -1 x)) :granularity granularity))) #-abcl (is (equalp ( sort a #'> :key (lambda (x) (* -1 x))) (psort b #'> :key (lambda (x) (* -1 x)) :granularity granularity))) #-abcl (is (equalp ( sort a #'> :key (lambda (x) (* -1 x))) (psort b #'> :key (lambda (x) (* -1 x)) :granularity granularity))))) (let ((source (make-array 50 :initial-element 5))) (let ((a (copy-seq source)) (b (copy-seq source))) (is (equalp ( sort a #'<) (psort b #'< :granularity granularity))) #-abcl (is (equalp ( sort a #'<) (psort b #'< :granularity granularity))) #-abcl (is (equalp ( sort a #'>) (psort b #'> :granularity granularity))) #-abcl (is (equalp ( sort a #'>) (psort b #'> :granularity granularity))))))) (full-test premove-if-test (loop for size below 100 for where = (random 1.0) for source = (collect-n size (random 1.0)) do (is (equal (remove-if (partial-apply #'< where) source) (premove-if (partial-apply #'< where) source))))) (full-test second-premove-if-test (loop for (std par) in '((remove-if-not premove-if-not) (remove-if premove-if)) do (loop for size below 100 for where = (random 1.0) for a = (make-random-list size) for b = (make-random-vector size) do (is (equal (funcall std (partial-apply #'< where) a) (funcall par (partial-apply #'< where) a))) (is (equalp (funcall std (partial-apply #'< where) b) (funcall par (partial-apply #'< where) b))) (when (>= size 77) (is (equal (funcall std (partial-apply #'< where) a :start 20) (funcall par (partial-apply #'< where) a :start 20))) (is (equal (funcall std (partial-apply #'< where) a :start 20 :end 77) (funcall par (partial-apply #'< where) a :start 20 :end 77))))))) (full-test premove-test (loop for size below 100 for where = (random 1.0) for a = (make-random-list size) for b = (make-random-vector size) do (is (equal (remove where a :test #'<) (premove where a :test #'<))) (is (equal (remove where a :test-not #'>=) (premove where a :test-not #'>=))) (is (equalp (remove where b :test #'<) (premove where b :test #'<))) (is (equalp (remove where b :test-not (complement #'<)) (premove where b :test-not (complement #'<))))) (is (equal (remove 3 (list 0 1 2 3 4 9 3 2 3 9 1)) (premove 3 (list 0 1 2 3 4 9 3 2 3 9 1)))) (is (equalp (remove 3 (make-array 11 :adjustable t :initial-contents (list 0 1 2 3 4 9 3 2 3 9 1))) (premove 3 (make-array 11 :adjustable t :initial-contents (list 0 1 2 3 4 9 3 2 3 9 1))))) (let ((x (cons nil nil))) (is (equal (remove x (list 3 4 x 4 9 x 2)) (premove x (list 3 4 x 4 9 x 2))))) (let ((x (cons nil nil))) (is (equalp (remove x (make-array 7 :adjustable t :initial-contents (list 3 4 x 4 9 x 2))) (premove x (make-array 7 :adjustable t :initial-contents (list 3 4 x 4 9 x 2))))))) (define-condition foo-warning (warning) ()) (base-test worker-context-test (flet ((my-worker-context (fn) (handler-bind ((warning (lambda (e) (declare (ignore e)) (invoke-restart 'double-me 3)))) (funcall fn)))) (dolist (n '(1 2 3 4 5 6 10)) (let ((result (with-temp-kernel (n :context #'my-worker-context) (pmapcar (lambda (x) (declare (ignore x)) (restart-case (warn 'foo-warning) (double-me (z) ;; clisp warns unless interactive is given :interactive (lambda ()) (* 2 z)))) '(3 3))))) (is (equal '(6 6) result)))))) (full-test cognate-handler-test (task-handler-bind ((foo-error (lambda (e) (declare (ignore e)) (invoke-restart 'something-else 3)))) (is (equal '(3 3) (pmapcar (lambda (x) (declare (ignore x)) (restart-case (error 'foo-error) (something-else (z) ;; clisp warns unless interactive is given :interactive (lambda ()) z))) '(0 1)))))) (full-test pmap-handler-test (task-handler-bind ((foo-error (lambda (e) (invoke-restart 'transfer-error e)))) (signals foo-error (pmapcar (lambda (x) (declare (ignore x)) (error 'foo-error)) '(3 4 5 6))))) (full-test pmap-restart-test (task-handler-bind ((foo-error (lambda (e) (declare (ignore e)) (invoke-restart 'thirty-three)))) (is (equal '(3 3) (pmapcar (lambda (x) (declare (ignore x)) (restart-case (error 'foo-error) (thirty-three () 3))) '(0 0)))))) (full-test pmap-into-bounds-test (dotimes (i 3) (dotimes (j (1+ i)) (let ((contents (collect-n i (random 1000)))) (destructuring-bind (a b) (collect-n 2 (make-array i :fill-pointer j :initial-contents contents)) (dotimes (k 6) (let ((source (collect-n k (random 1000)))) (let ((c (pmap-into b #'identity source)) (d (map-into a #'identity source))) (is (equalp a b)) (is (equalp c d)))))))))) (full-test pmap-with-size-constraint-test (is (equal '(2 11) (pmapcar '1+ :size 2 '(1 10 100 1000)))) (is (equal '(2 11) (pmap 'list '1+ :size 2 '(1 10 100 1000)))) (is (equalp #(2 11) (pmap 'vector '1+ :size 2 '(1 10 100 1000)))) (is (equalp #(2 11) (pmap 'vector '1+ :size 2 #(1 10 100 1000)))) (is (equalp #(2 11 99 99) (pmap-into (vector 99 99 99 99) '1+ :size 2 #(1 10 100 1000)))) (is (equal '(2 11) (pmap-into (list 'a 'b) '1+ :size 2 '(1 10 100 1000)))) (is (equal '(2 11) (pmaplist-into (list 'a 'b) (lambda (x) (1+ (car x))) :size 2 '(1 10 100 1000)))) (is (equal '(2 11 c d) (pmap-into (list 'a 'b 'c 'd) '1+ :size 2 '(1 10 100 1000)))) (is (equal '(2 11 c d) (pmaplist-into (list 'a 'b 'c 'd) (lambda (x) (1+ (car x))) :size 2 '(1 10 100 1000))))) (full-test pmap-into-list-test (dotimes (m 10) (dotimes (n 10) (let* ((src (make-list m :initial-element 'src)) (dst (make-list n :initial-element 'dst)) (a (copy-list dst)) (b (copy-list dst)) (res-a (map-into a #'identity src)) (res-b (pmap-into b #'identity src))) (is (eq a res-a)) (is (eq b res-b)) (is (equal a b)))))) (full-test pmap-into-degenerate-input-test (is (equalp #() (map-into (vector) (constantly 99)))) (is (equalp #() (pmap-into (vector) (constantly 99)))) (is (equalp #(99 99) (map-into (vector 1 2) (constantly 99)))) (is (equalp #(99 99) (pmap-into (vector 1 2) (constantly 99)))) (is (equalp #(1 2 3 4) (pmap-into (vector 1 2 3 4) (constantly 99) :size 0))) (is (equalp #(99 99 3 4) (pmap-into (vector 1 2 3 4) (constantly 99) :size 2))) (is (equalp #(99 99 99 99) (pmap-into (vector 1 2 3 4) (constantly 99) :size 4))) (is (equal '() (map-into (list) (constantly 99)))) (is (equal '() (pmap-into (list) (constantly 99)))) (is (equal '(99 99) (map-into (list 1 2) (constantly 99)))) (is (equal '(99 99) (pmap-into (list 1 2) (constantly 99)))) (is (equal '(1 2 3 4) (pmap-into (list 1 2 3 4) (constantly 99) :size 0))) (is (equal '(99 99 3 4) (pmap-into (list 1 2 3 4) (constantly 99) :size 2))) (is (equal '(99 99 99 99) (pmap-into (list 1 2 3 4) (constantly 99) :size 4)))) (full-test pmaplist-into-degenerate-input-test (is (equal '() (pmaplist-into (list) (constantly 99)))) (is (equal '(99 99) (pmaplist-into (list 1 2) (constantly 99)))) (is (equal '(1 2 3 4) (pmaplist-into (list 1 2 3 4) (constantly 99) :size 0))) (is (equal '(99 99 3 4) (pmaplist-into (list 1 2 3 4) (constantly 99) :size 2))) (is (equal '(99 99 99 99) (pmaplist-into (list 1 2 3 4) (constantly 99) :size 4)))) (full-test pfuncall-test (is (= 7 (pfuncall '+ 3 4))) (let ((memo (make-queue))) (is (= 7 (pfuncall #'+ (progn (sleep 0.2) (push-queue 3 memo) 3) (progn (sleep 0.2) (push-queue 4 memo) 4)))) (sleep 0.3) (is (= 2 (queue-count memo))))) (full-test pcount-if-test (is (zerop (pcount-if 'non-function '()))) (is (zerop (pcount-if 'non-function #()))) (signals error (pcount-if 'non-function '() :start 2)) (loop for size from 1 below 100 for where = (random 1.0) for source = (collect-n size (random 1.0)) do (is (equal (count-if (partial-apply #'< where) source) (pcount-if (partial-apply #'< where) source))))) (full-test second-pcount-if-test (loop for (std par) in '((count-if-not pcount-if-not) (count-if pcount-if)) do (loop for size from 1 below 100 for where = (random 1.0) for a = (make-random-list size) for b = (make-random-vector size) do (is (equal (funcall std (partial-apply #'< where) a) (funcall par (partial-apply #'< where) a))) (is (equalp (funcall std (partial-apply #'< where) b) (funcall par (partial-apply #'< where) b))) (when (>= size 77) (is (equal (funcall std (partial-apply #'< where) a :start 20) (funcall par (partial-apply #'< where) a :start 20))) (is (equal (funcall std (partial-apply #'< where) a :start 20 :end 77) (funcall par (partial-apply #'< where) a :start 20 :end 77))))))) (full-test pcount-test (loop for size from 1 below 100 for where = (random 1.0) for a = (make-random-list size) for b = (make-random-vector size) do (is (equal (count where a :test #'<) (pcount where a :test #'<))) (is (equal (count where a :test-not (complement #'<)) (pcount where a :test-not (complement #'<)))) (is (equalp (count where b :test #'<) (pcount where b :test #'<))) (is (equalp (count where b :test-not (complement #'<)) (pcount where b :test-not (complement #'<))))) (is (equal (count 3 (list 0 1 2 3 4 9 3 2 3 9 1)) (pcount 3 (list 0 1 2 3 4 9 3 2 3 9 1)))) (is (equalp (count 3 (make-array 11 :adjustable t :initial-contents (list 0 1 2 3 4 9 3 2 3 9 1))) (pcount 3 (make-array 11 :adjustable t :initial-contents (list 0 1 2 3 4 9 3 2 3 9 1))))) (let ((x (cons nil nil))) (is (equal (count x (list 3 4 x 4 9 x 2)) (pcount x (list 3 4 x 4 9 x 2))))) (let ((x (cons nil nil))) (is (equalp (count x (make-array 7 :adjustable t :initial-contents (list 3 4 x 4 9 x 2))) (pcount x (make-array 7 :adjustable t :initial-contents (list 3 4 x 4 9 x 2))))))) (full-test pfind-if-test (signals error (pfind-if 'non-function '())) (signals error (pfind-if 'non-function #())) (signals error (pfind-if 'non-function '() :start 2)) (signals error (pfind-if 'non-function #() :start 2)) (is (= 3 (find-if (lambda (x) (< x 5)) '(9 9 6 7 3 9 6)) (pfind-if (lambda (x) (< x 5)) '(9 9 6 7 3 9 6)) (find-if (lambda (x) (< x 5)) #(9 9 6 7 3 9 6)) (pfind-if (lambda (x) (< x 5)) #(9 9 6 7 3 9 6)))) (is (= 3 (find-if-not (lambda (x) (>= x 5)) '(9 9 6 7 3 9 6)) (pfind-if-not (lambda (x) (>= x 5)) '(9 9 6 7 3 9 6)) (find-if-not (lambda (x) (>= x 5)) #(9 9 6 7 3 9 6)) (pfind-if-not (lambda (x) (>= x 5)) #(9 9 6 7 3 9 6)))) (loop for size from 1 below 100 for source = (collect-n size (random 1.0)) do (setf (elt source (random size)) 999) (is (eql (find-if (partial-apply #'eql 999) source) (pfind-if (partial-apply #'eql 999) source))))) (full-test second-pfind-if-test (loop for (std par) in '((find-if pfind-if)) do (loop for size from 1 below 100 for a = (make-random-list size) for b = (make-random-vector size) for target = (let ((index (random size))) (setf (elt a index) 99.0 (elt b index) 99.0)) do (is (equal (funcall std (partial-apply #'eql target) a) (funcall par (partial-apply #'eql target) a))) (is (equalp (funcall std (partial-apply #'eql target) b) (funcall par (partial-apply #'eql target) b))) (when (>= size 77) (is (equal (funcall std (partial-apply #'eql target) a :start 20) (funcall par (partial-apply #'eql target) a :start 20))) (is (equal (funcall std (partial-apply #'eql target) a :start 20 :end 77) (funcall par (partial-apply #'eql target) a :start 20 :end 77))))))) (full-test pfind-test (signals error (pfind 3 '(3 3 3) :test #'eql :test-not #'eql)) (loop for size from 1 below 100 for a = (make-random-list size) for b = (make-random-vector size) for target = (let ((index (random size))) (setf (elt a index) 99.0 (elt b index) 99.0)) do (is (equal (find target a) (pfind target a))) (is (equalp (find target b) (pfind target b)))) (is (equal (find 3 (list 0 1 2 3 4 9 3 2 3 9 1)) (pfind 3 (list 0 1 2 3 4 9 3 2 3 9 1)))) (is (equalp (find 3 (make-array 11 :adjustable t :initial-contents (list 0 1 2 3 4 9 3 2 3 9 1))) (pfind 3 (make-array 11 :adjustable t :initial-contents (list 0 1 2 3 4 9 3 2 3 9 1))))) (let ((x (cons nil nil))) (is (equal (find x (list 3 4 x 4 9 x 2)) (pfind x (list 3 4 x 4 9 x 2))))) (let ((x (cons nil nil))) (is (equalp (find x (make-array 7 :adjustable t :initial-contents (list 3 4 x 4 9 x 2))) (pfind x (make-array 7 :adjustable t :initial-contents (list 3 4 x 4 9 x 2))))))) (defmacro define-pmap-into-edge-test (name decl) `(full-test ,name ,@(unsplice decl) (is (equalp #(1 2 3) (pmap-into (vector 9 9 9) 'identity (vector 1 2 3)))) (is (equalp #(1 2 3) (pmap-into (vector 9 9 9) 'identity :size 3 (vector 1 2 3)))) (is (equalp #(1 2 9) (pmap-into (vector 9 9 9) 'identity :size 2 (vector 1 2 3)))) (is (equalp #(9 9 9) (pmap-into (vector 9 9 9) 'identity :size 0 (vector 1 2 3)))) (is (equalp #(9 9 9) (pmap-into (vector 9 9 9) 'identity (vector)))) (is (equalp #() (pmap-into (vector) 'identity (vector 1 2 3)))) (let ((v (make-array 3 :fill-pointer 0))) (is (equalp #(1 2 3) (pmap-into v 'identity (vector 1 2 3)))) (is (equalp #(1 2 3) v))) (let ((v (make-array 3 :fill-pointer 0))) (is (equalp #(1 2) (pmap-into v 'identity (vector 1 2)))) (is (equalp #(1 2) v))) (let ((v (make-array 3 :fill-pointer 0))) (is (equalp #(9 9 9) (pmap-into v (constantly 9)))) (is (equalp #(9 9 9) v))) (let ((v (make-array 3 :fill-pointer 1))) (is (equalp #(9 9 9) (pmap-into v (constantly 9)))) (is (equalp #(9 9 9) v))) (let ((v (make-array 3 :fill-pointer 2))) (is (equalp #(9 9 9) (pmap-into v (constantly 9)))) (is (equalp #(9 9 9) v))) (let ((v (make-array 3 :fill-pointer 3))) (is (equalp #(9 9 9) (pmap-into v (constantly 9)))) (is (equalp #(9 9 9) v))) (let ((v (make-array 3 :fill-pointer 3))) (is (equalp #(1 2) (pmap-into v 'identity (vector 1 2)))) (is (equalp #(1 2) v))) (let ((v (make-array 3 :fill-pointer 3))) (is (equalp #(1) (pmap-into v 'identity :size 1 (vector 1 2)))) (is (equalp #(1) v))))) (define-pmap-into-edge-test pmap-into-open-edge-test nil) (define-pmap-into-edge-test pmap-into-closed-edge-test (declare (notinline pmap-into))) (full-test pmap-compiler-macro-test (is (equalp #(1 2 3) (pmap 'vector 'identity (vector 1 2 3)))) (is (equalp #(1 2 3) (pmap 'vector 'identity :size 3 (vector 1 2 3)))) (is (equalp #(1 2) (pmap 'vector 'identity :size 2 (vector 1 2 3)))) (is (equalp #() (pmap 'vector 'identity :size 0 (vector 1 2 3)))) (is (equalp #() (pmap 'vector 'identity (vector)))) (is (equalp #(1 2 3) (pmap '(array fixnum (*)) 'identity (vector 1 2 3))))) (full-test pmap-compiler-macro-parts-test (dotimes (parts 25) (let ((src (make-array 20 :initial-contents (loop for i below 20 collect i))) (dst (make-array 20))) (is (equalp src (pmap 'vector 'identity src))) (is (equalp src (pmap-into dst 'identity src))) (is (equalp src dst))))) (full-test pmap-notinline-test (declare (notinline pmap)) (is (equalp #(1 2 3) (pmap 'vector 'identity (vector 1 2 3)))) (is (equalp #(1 2 3) (pmap 'vector 'identity :size 3 (vector 1 2 3)))) (is (equalp #(1 2) (pmap 'vector 'identity :size 2 (vector 1 2 3)))) (is (equalp #() (pmap 'vector 'identity :size 0 (vector 1 2 3)))) (is (equalp #() (pmap 'vector 'identity (vector)))) (is (equalp #(1 2 3) (pmap '(array fixnum (*)) 'identity (vector 1 2 3))))) (full-test cognate-steal-test (let ((channel (make-channel))) (submit-task channel (lambda () (pmap 'vector 'identity '(1 2 3 4 5)))) (is (equalp #(1 2 3 4 5) (receive-result channel)))) (let ((channel (make-channel))) (submit-task channel (lambda () (pmap-reduce 'identity '+ '(1 2 3 4 5)))) (is (eql 15 (receive-result channel)))) (let ((channel (make-channel))) (submit-task channel (lambda () (por nil nil 5))) (is (eql 5 (receive-result channel)))) (is (not (null (pand 9 (por nil 3))))) (is (eql 3 (por nil nil (por nil 3) (por nil nil 3)))) (let ((channel (make-channel))) (submit-task channel (lambda () (let* ((a (make-random-vector 1000)) (b (copy-seq a))) (list (sort a #'<) (psort b #'<))))) (is (apply #'equalp (receive-result channel))))) (base-test cognate-steal-priority-test (with-temp-kernel (2) (let ((channel (make-channel)) (flag nil)) (with-thread () (sleep 1.5) (setf flag t)) (submit-task channel (lambda () (pmap nil #'sleep '(1 1)))) (receive-result channel) (is (eq nil flag)) (sleep 1) (is (eq t flag)))) (with-temp-kernel (2) (let ((channel (make-channel)) (flag nil)) (with-thread () (sleep 1.5) (setf flag t)) (submit-task channel (lambda () (let ((*task-priority* :low)) (pmap nil #'sleep '(1 1))))) (receive-result channel) (is (eq nil flag)) (sleep 1) (is (eq t flag))))) (full-test pdotimes-test (dotimes (n 100) (flet ((f (x) (* x x))) (let ((a (make-array n)) (b (make-array n))) (dotimes (i n) (setf (aref a i) (f i))) (pdotimes (i n) (setf (aref b i) (f i))) (is (equalp a b))))) (dotimes (parts 100) (flet ((f (x) (* x x))) (let ((a (make-array 100)) (b (make-array 100))) (dotimes (i 100) (setf (aref a i) (f i))) (pdotimes (i 100 :discard (1+ parts)) (setf (aref b i) (f i))) (is (equalp a b))))) (dotimes (n 2) (is (eq (dotimes (i n :foo) (declare (ignorable i))) (pdotimes (i n :foo) (declare (ignorable i)))))) (dotimes (n 4) (is (eq (dotimes (i n (* i i)) (declare (ignorable i))) (pdotimes (i n (* i i)) (declare (ignorable i))))))) (full-test pdotimes-second-test (signals error (pdotimes (i 4.0) (declare (ignore i)))) (pdotimes (i 0) (declare (ignore i)) (error "oops")) (pdotimes (i -1) (declare (ignore i)) (error "oops")) (setf *memo* 1) (is (= (dotimes (i *memo* i) (declare (ignorable i))) (pdotimes (i *memo* i) (declare (ignorable i))))) (setf *memo* 0) (is (= (dotimes (i *memo* i) (declare (ignorable i))) (pdotimes (i *memo* i) (declare (ignorable i))))) (setf *memo* -1) (is (= (dotimes (i *memo* i) (declare (ignorable i))) (pdotimes (i *memo* i) (declare (ignorable i))))) (setf *memo* t) (let ((q (make-queue))) (dotimes (i 4) (when *memo* (go :end)) (error "skip me") :end (push-queue i q)) (is (equal '(0 1 2 3) (sort (extract-queue q) '<)))) (let ((q (make-queue))) (pdotimes (i 4) (when *memo* (go :end)) (error "skip me") :end (push-queue i q)) (is (equal '(0 1 2 3) (sort (extract-queue q) '<))))) (full-test function-designators-test (is (eql (pcount 3 '(1 2 3) :test 'eql :key 'identity) ( count 3 '(1 2 3) :test 'eql :key 'identity))) (is (eql (pcount 3 '(1 2 3) :test #'eql :key #'identity) ( count 3 '(1 2 3) :test #'eql :key #'identity))) (is (eql (pcount 3 '(1 2 3) :test-not 'eql :key 'identity) ( count 3 '(1 2 3) :test-not 'eql :key 'identity))) (is (eql (pcount 3 '(1 2 3) :test-not #'eql :key #'identity) ( count 3 '(1 2 3) :test-not #'eql :key #'identity))) (is (eql (pcount-if 'oddp '(1 2 3) :key 'identity) ( count-if 'oddp '(1 2 3) :key 'identity))) (is (eql (pcount-if #'oddp '(1 2 3) :key #'identity) ( count-if #'oddp '(1 2 3) :key #'identity))) (is (eql (pcount-if-not 'oddp '(1 2 3) :key 'identity) ( count-if-not 'oddp '(1 2 3) :key 'identity))) (is (eql (pcount-if-not #'oddp '(1 2 3) :key #'identity) ( count-if-not #'oddp '(1 2 3) :key #'identity))) (is (eql (pevery 'oddp '(1 2 3)) ( every 'oddp '(1 2 3)))) (is (eql (pevery #'oddp '(1 2 3)) ( every #'oddp '(1 2 3)))) (is (eql (psome 'oddp '(1 2 3)) ( some 'oddp '(1 2 3)))) (is (eql (psome #'oddp '(1 2 3)) ( some #'oddp '(1 2 3)))) (is (eql (pnotany 'oddp '(1 2 3)) ( notany 'oddp '(1 2 3)))) (is (eql (pnotany #'oddp '(1 2 3)) ( notany #'oddp '(1 2 3)))) (is (eql (pnotevery 'oddp '(1 2 3)) ( notevery 'oddp '(1 2 3)))) (is (eql (pnotevery #'oddp '(1 2 3)) ( notevery #'oddp '(1 2 3)))) (is (eql (pfind 2 '(1 2) :test 'eql :key 'identity) ( find 2 '(1 2) :test 'eql :key 'identity))) (is (eql (pfind 2 '(1 2) :test #'eql :key #'identity) ( find 2 '(1 2) :test #'eql :key #'identity))) (is (eql (pfind 2 '(1 2) :test-not 'eql :key 'identity) ( find 2 '(1 2) :test-not 'eql :key 'identity))) (is (eql (pfind 2 '(1 2) :test-not #'eql :key #'identity) ( find 2 '(1 2) :test-not #'eql :key #'identity))) (is (eql (pfind-if 'oddp '(1 2) :key 'identity) ( find-if 'oddp '(1 2) :key 'identity))) (is (eql (pfind-if #'oddp '(1 2) :key #'identity) ( find-if #'oddp '(1 2) :key #'identity))) (is (eql (pfind-if-not 'oddp '(1 2) :key 'identity) ( find-if-not 'oddp '(1 2) :key 'identity))) (is (eql (pfind-if-not #'oddp '(1 2) :key #'identity) ( find-if-not #'oddp '(1 2) :key #'identity))) (is (eql (pfuncall '+ 1 2) ( funcall '+ 1 2))) (is (eql (pfuncall #'+ 1 2) ( funcall #'+ 1 2))) (is (equal (pmap 'list 'identity '(1 2)) ( map 'list 'identity '(1 2)))) (is (equal (pmap 'list #'identity '(1 2)) ( map 'list #'identity '(1 2)))) (is (equalp (pmap 'vector 'identity '(1 2)) ( map 'vector 'identity '(1 2)))) (is (equalp (pmap 'vector #'identity '(1 2)) ( map 'vector #'identity '(1 2)))) (is (equalp (apply #'pmap 'vector 'identity '((1 2))) (apply #'map 'vector 'identity '((1 2))))) (is (equalp (apply #'pmap 'vector #'identity '((1 2))) (apply #'map 'vector #'identity '((1 2))))) (is (equal (pmapc 'identity '(1 2)) ( mapc 'identity '(1 2)))) (is (equal (pmapc #'identity '(1 2)) ( mapc #'identity '(1 2)))) (is (equal (pmapcan 'list '(1 2)) ( mapcan 'list '(1 2)))) (is (equal (pmapcan #'list '(1 2)) ( mapcan #'list '(1 2)))) (is (equal (pmapcar 'identity '(1 2)) ( mapcar 'identity '(1 2)))) (is (equal (pmapcar #'identity '(1 2)) ( mapcar #'identity '(1 2)))) (is (equal (pmapcon 'list '(1 2)) ( mapcon 'list '(1 2)))) (is (equal (pmapcon #'list '(1 2)) ( mapcon #'list '(1 2)))) (is (equal (pmap-into (list 0 0) 'identity '(1 2)) ( map-into (list 0 0) 'identity '(1 2)))) (is (equal (pmap-into (list 0 0) #'identity '(1 2)) ( map-into (list 0 0) #'identity '(1 2)))) (is (equal (pmapl 'identity '(1 2)) ( mapl 'identity '(1 2)))) (is (equal (pmapl #'identity '(1 2)) ( mapl #'identity '(1 2)))) (is (equal (pmaplist 'identity '(1 2)) ( maplist 'identity '(1 2)))) (is (equal (pmaplist #'identity '(1 2)) ( maplist #'identity '(1 2)))) (is (equal (pmaplist-into (list 0 0) 'identity '(1 2)) ( maplist 'identity '(1 2)))) (is (equal (pmaplist-into (list 0 0) #'identity '(1 2)) ( maplist #'identity '(1 2)))) (is (eql (preduce '+ '(1 2 3) :key 'identity) ( reduce '+ '(1 2 3) :key 'identity))) (is (eql (preduce #'+ '(1 2 3) :key #'identity) ( reduce #'+ '(1 2 3) :key #'identity))) (is (equalp (preduce-partial '+ '(1 2 3) :key 'identity :parts 1) #(6))) (is (equalp (preduce-partial #'+ '(1 2 3) :key #'identity :parts 1) #(6))) (is (equal (premove 2 '(1 2) :test 'eql :key 'identity) ( remove 2 '(1 2) :test 'eql :key 'identity))) (is (equal (premove 2 '(1 2) :test #'eql :key #'identity) ( remove 2 '(1 2) :test #'eql :key #'identity))) (is (equal (premove-if 'oddp '(1 2) :key 'identity) ( remove-if 'oddp '(1 2) :key 'identity))) (is (equal (premove-if #'oddp '(1 2) :key #'identity) ( remove-if #'oddp '(1 2) :key #'identity))) (is (equalp (psort (vector 1 3 2) '<) ( sort (vector 1 3 2) '<))) (is (equalp (psort (vector 1 3 2) #'<) ( sort (vector 1 3 2) #'<)))) (base-test slet-test (let ((z 0)) (slet ((a (incf z)) (b (incf z))) (is (= 1 a)) (is (= 2 b)))) (let ((z 0)) (slet (((a) (incf z)) (b (incf z))) (is (= 1 a)) (is (= 2 b)))) (let ((z 0)) (slet ((a (incf z)) ((b c) (values (incf z) (incf z))) (d (incf z)) ((e f g) (values (incf z) (incf z) (incf z)))) (is (equal '(1 2 3 4 5 6 7) (list a b c d e f g))))) (slet (a (b) ((c)) d (e)) (declare (type null d c)) (is (equal '(nil nil nil nil nil) (list a b c d e))))) (base-test slet-unbound-test (signals error (funcall (compile/muffled nil '(lambda () (slet ((a 3) (b (1+ a))) (list a b))))))) (full-test plet-multiple-value-test (plet ((a 1) (b 2)) (is (= 1 a)) (is (= 2 b))) (plet (((a) 1) (b 2)) (is (= 1 a)) (is (= 2 b))) (plet ((a 1) ((b c) (values 2 3)) (d 4) ((e f g) (values 5 6 7))) (is (equal '(1 2 3 4 5 6 7) (list a b c d e f g)))) (plet ((a) b) (is (null a)) (is (null b))) (plet (((a b))) (is (null a)) (is (null b)))) (base-test plet-unbound-test (signals error (task-handler-bind ((error #'invoke-transfer-error)) (funcall (compile/muffled nil '(lambda () (plet ((a 3) (b (1+ a))) (list a b)))))))) lparallel-20160825-git/test/defpun-test.lisp000066400000000000000000000153361274371011200206300ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel-test) ;;;; defpun (define-plet-test defpun-basic-test defpun-basic-test-fn defpun nil) (defun fib-let (n) (if (< n 2) n (let ((a (fib-let (- n 1))) (b (fib-let (- n 2)))) (+ a b)))) (defpun fib-plet (n) (if (< n 2) n (plet ((a (fib-plet (- n 1))) (b (fib-plet (- n 2)))) (+ a b)))) (defpun fib-plet-if (n) (if (< n 2) n (plet-if (> n 5) ((a (fib-plet-if (- n 1))) (b (fib-plet-if (- n 2)))) (+ a b)))) (full-test defpun-fib-test (loop for n from 1 to #+lparallel.with-green-threads 5 #-lparallel.with-green-threads 15 do (is (= (fib-let n) (fib-plet n) (fib-plet-if n))))) ;;; typed (defun/type fib-let/type (n) (fixnum) fixnum (if (< n 2) n (let ((a (fib-let/type (- n 1))) (b (fib-let/type (- n 2)))) (+ a b)))) (defpun/type fib-plet/type (n) (fixnum) fixnum (if (< n 2) n (plet ((a (fib-plet/type (- n 1))) (b (fib-plet/type (- n 2)))) (+ a b)))) (defpun/type fib-plet-if/type (n) (fixnum) fixnum (if (< n 2) n (plet-if (> n 5) ((a (fib-plet-if/type (- n 1))) (b (fib-plet-if/type (- n 2)))) (+ a b)))) (full-test defpun/type-fib-test (loop for n from 1 to #+lparallel.with-green-threads 5 #-lparallel.with-green-threads 15 do (is (= (fib-let/type n) (fib-plet/type n) (fib-plet-if/type n))))) ;;; redefinitions (base-test redefined-defpun-test (with-temp-kernel (2) (setf *memo* 'foo) (handler-bind ((warning #'muffle-warning)) (eval '(defpun foo (x) (* x x)))) (is (= 9 (funcall *memo* 3))) (handler-bind ((warning #'muffle-warning)) (eval '(defun foo (x) (* x x x)))) (is (= 27 (funcall *memo* 3))))) ;;; forward ref (declaim-defpun func1 func2) (defpun func2 (x) (plet ((y (func1 x))) (* x y))) (defpun func1 (x) (plet ((y (* x x))) (* x y))) (full-test declaim-defpun-test (is (= 81 (func2 3)))) ;;; lambda list keywords (defpun foo-append (&key left right) (if (null left) right (plet ((x (first left)) (y (foo-append :left (rest left) :right right))) (cons x y)))) (full-test defpun-lambda-list-keywords-test (is (equal '(1 2 3 4 5 6 7) (foo-append :left '(1 2 3) :right '(4 5 6 7)))) (is (equal '(1 2 3) (foo-append :left '(1 2 3) :right nil))) (is (equal '(1 2 3) (foo-append :left '(1 2 3)))) (is (equal '(4 5 6 7) (foo-append :right '(4 5 6 7)))) (is (equal nil (foo-append :right nil))) (is (equal nil (foo-append)))) ;;; multiple values (defpun mv-foo-1 (x y) (values x y)) (defpun/type mv-foo-2 (x y) (fixnum fixnum) (values fixnum fixnum) (values x y)) (defpun mv-foo-3 (x y) (mv-foo-1 x y)) (defpun/type mv-foo-4 (x y) (fixnum fixnum) (values fixnum fixnum) (mv-foo-2 x y)) (defpun/type mv-foo-5 (x y) (fixnum fixnum) (values fixnum fixnum) (mv-foo-3 x y)) (full-test defpun-mv-test (is (equal '(3 4) (multiple-value-list (mv-foo-1 3 4)))) (is (equal '(3 4) (multiple-value-list (mv-foo-2 3 4)))) (is (equal '(3 4) (multiple-value-list (mv-foo-3 3 4)))) (is (equal '(3 4) (multiple-value-list (mv-foo-4 3 4)))) (is (equal '(3 4) (multiple-value-list (mv-foo-5 3 4))))) (defpun defpun-mv-plet-1 () (plet (((a b) (floor 5 2)) (c 9) d (e) ((f g h) (values 6 7 8))) (declare (type fixnum b c g)) (list a b c d e f g h))) (defpun defpun-mv-plet-2 () (plet (a (b) ((c)) d (e)) (declare (type null d)) (declare (null c)) (list a b c d e))) (full-test defpun-mv-plet-test (is (equal '(2 1 9 nil nil 6 7 8) (defpun-mv-plet-1))) (is (equal '(nil nil nil nil nil) (defpun-mv-plet-2)))) (defpun defpun-handling-1 () (plet ((a 3) (b 4) (c (restart-case (error 'foo-error) (four () 5)))) (+ a b c))) (defpun defpun-handling-2 () (plet ((c (restart-case (error 'foo-error) (four () 5))) (a 3) (b 4)) (+ a b c))) (defpun defpun-handling-3 () (error 'foo-error)) (defpun defpun-handling-4 (n) (if (< n 2) (error 'foo-error) (plet ((a (defpun-handling-4 (- n 1))) (b (defpun-handling-4 (- n 2)))) (+ a b)))) (full-test defpun-handling-test (repeat 100 (task-handler-bind ((foo-error (lambda (e) (declare (ignore e)) (invoke-restart 'four)))) (is (= 12 (defpun-handling-1))) (is (= 12 (defpun-handling-2)))) (task-handler-bind ((foo-error #'invoke-transfer-error)) (signals foo-error (defpun-handling-1)) (signals foo-error (defpun-handling-2)) (signals foo-error (defpun-handling-3)) (signals foo-error (defpun-handling-4 10))))) (full-test defpun-priority-test (let ((*task-priority* :low)) (repeat 10 (let ((n #+lparallel.with-green-threads 5 #-lparallel.with-green-threads 25)) (is (= (fib-let n) (fib-plet n))))))) lparallel-20160825-git/test/kernel-test.lisp000066400000000000000000000666551274371011200206410ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel-test) (full-test kernel-test (let ((channel (make-channel))) (mapcar (lambda (x) (submit-task channel (lambda () (* x x)))) (list 5 6 7 8)) (is (equal (list 25 36 49 64) (sort (collect-n 4 (receive-result channel)) '<))))) (full-test no-kernel-test (let ((*kernel* nil)) (signals no-kernel-error (submit-task (make-channel) (lambda ()))))) (base-test end-kernel-test (repeat 10 (loop for n from 1 below 32 do (with-temp-kernel (n) (is (= 1 1)))))) (full-test many-task-test (let ((channel (make-channel))) (repeat 1000 (submit-task channel (lambda ())) (is (null (receive-result channel)))) (repeat 1000 (submit-task channel (lambda ()))) (repeat 1000 (is (null (receive-result channel)))) (repeat 1000 (let ((*task-priority* :low)) (submit-task channel (lambda ()))) (is (null (receive-result channel)))) (repeat 1000 (let ((*task-priority* :low)) (submit-task channel (lambda ())))) (repeat 1000 (is (null (receive-result channel)))))) #-lparallel.without-kill (base-test kill-during-end-kernel-test (let* ((*kernel* (make-kernel 2)) (kernel *kernel*) (out *standard-output*) (channel (make-channel)) (handled (make-queue)) (finished (make-queue))) (task-handler-bind ((error #'invoke-transfer-error)) (submit-task channel (lambda () (setf *error-output* (make-broadcast-stream)) (infinite-loop)))) (with-thread () (block top (handler-bind ((task-killed-error (lambda (e) (declare (ignore e)) (push-queue t handled) (return-from top)))) (receive-result channel)))) (sleep 0.2) (let ((thread (with-thread () (let ((*standard-output* out)) (let ((*kernel* kernel)) (end-kernel :wait t) (push-queue t finished)))))) (sleep 0.2) (is (null (peek-queue finished))) (is (eql 1 (kill-tasks :default))) (sleep 0.2) (is (eq t (peek-queue handled))) (is (eq t (peek-queue finished))) (is (not (null thread)))))) (full-test channel-capacity-test (let ((channel (make-channel :fixed-capacity 1))) (submit-task channel (lambda () 3)) (submit-task channel (lambda () 4)) (submit-task channel (lambda () 5)) (is (equal '(3 4 5) ;; avoid sbcl warning (locally (declare (notinline sort)) (sort (list (receive-result channel) (receive-result channel) (receive-result channel)) #'<)))))) (full-test try-receive-test (let ((channel (make-channel))) (multiple-value-bind (a b) (try-receive-result channel) (is (null a)) (is (null b))) (submit-task channel (lambda () 3)) (sleep 0.1) (multiple-value-bind (a b) (try-receive-result channel) (is (= 3 a)) (is (eq t b))) (multiple-value-bind (a b) (try-receive-result channel) (is (null a)) (is (null b))))) #-lparallel.without-bordeaux-threads-condition-wait-timeout (full-test try-receive-timeout-test (let ((channel (make-channel))) (multiple-value-bind (a b) (try-receive-result channel :timeout 0.1) (is (null a)) (is (null b))) (submit-task channel (lambda () 3)) (sleep 0.1) (multiple-value-bind (a b) (try-receive-result channel :timeout 0.1) (is (= 3 a)) (is (eq t b))) (multiple-value-bind (a b) (try-receive-result channel :timeout 0.1) (is (null a)) (is (null b))))) (full-test kernel-client-error-test (task-handler-bind ((client-error #'invoke-transfer-error)) (let ((channel (make-channel))) (submit-task channel (lambda () (error 'client-error))) (signals client-error (receive-result channel)))) (task-handler-bind ((error (lambda (e) (declare (ignore e)) (invoke-restart 'transfer-error (make-condition 'foo-error))))) (let ((channel (make-channel))) (submit-task channel (lambda () (error 'client-error))) (signals foo-error (receive-result channel)))) (task-handler-bind ((error (lambda (e) (declare (ignore e)) (invoke-restart 'transfer-error 'foo-error)))) (let ((channel (make-channel))) (submit-task channel (lambda () (error 'client-error))) (signals foo-error (receive-result channel))))) (full-test user-restart-test (task-handler-bind ((foo-error (lambda (e) (declare (ignore e)) (invoke-restart 'eleven)))) (let ((channel (make-channel))) (submit-task channel (lambda () (restart-case (error 'foo-error) (eleven () 11)))) (is (eql 11 (receive-result channel))))) (task-handler-bind ((error (lambda (e) (declare (ignore e)) (invoke-restart 'eleven)))) (let ((channel (make-channel))) (submit-task channel (lambda () (restart-case (error 'foo-error) (eleven () 11)))) (is (eql 11 (receive-result channel)))))) (full-test error-cascade-test (task-handler-bind ((error (lambda (e) (invoke-restart 'transfer-error e)))) (task-handler-bind ((error (lambda (e) (declare (ignore e)) (error 'foo-error)))) (let ((channel (make-channel))) (submit-task channel (lambda () (error 'client-error))) (signals foo-error (receive-result channel)))))) (base-test complex-handler-test (flet ((estr (e) (with-output-to-string (out) (write e :escape nil :stream out)))) (let ((queue (make-queue))) (ignore-errors (handler-bind ((error (lambda (e) (push-queue (cons 'a (estr e)) queue)))) (handler-bind ((error (lambda (e) (push-queue (cons 'b (estr e)) queue) (error "Z")))) (handler-bind ((error (lambda (e) (push-queue (cons 'c (estr e)) queue) (error "Y")))) (handler-bind ((error (lambda (e) (push-queue (cons 'd (estr e)) queue)))) (error "X")))))) (is (equal '((D . "X") (C . "X") (B . "Y") (A . "Z")) (extract-queue queue)))) (with-temp-kernel (2) (let ((queue (make-queue))) (task-handler-bind ((error #'invoke-transfer-error)) (task-handler-bind ((error (lambda (e) (push-queue (cons 'a (estr e)) queue)))) (task-handler-bind ((error (lambda (e) (push-queue (cons 'b (estr e)) queue) (error "Z")))) (task-handler-bind ((error (lambda (e) (push-queue (cons 'c (estr e)) queue) (error "Y")))) (task-handler-bind ((error (lambda (e) (push-queue (cons 'd (estr e)) queue)))) (submit-task (make-channel) #'error "X")))))) (is (equal '((D . "X") (C . "X") (B . "Y") (A . "Z")) (loop repeat 4 collect (pop-queue queue)))))))) (base-test kernel-worker-context-test (with-temp-kernel (2 :context (lambda (run) (let ((*memo* 9)) (funcall run)))) (let ((channel (make-channel))) (setf *memo* 7) (submit-task channel (lambda () *memo*)) (is (eql 9 (receive-result channel))) (is (eql 7 *memo*))))) (base-test kernel-binding-test (unwind-protect (progn (end-kernel) (setf *kernel* (make-kernel 4)) (let ((channel (make-channel))) (setf *memo* :main) (submit-task channel (lambda () (setf *memo* :worker) *memo*)) (is (eq :worker (receive-result channel))) (is (eq :worker *memo*)))) (end-kernel)) (with-temp-kernel (4 :bindings (acons '*memo* :worker nil)) (let ((node (assoc '*memo* (kernel-bindings)))) (is (eq (cdr node) :worker))) (let ((channel (make-channel))) (setf *memo* :main) (submit-task channel (lambda () *memo*)) (is (eq :worker (receive-result channel))) (is (eq :main *memo*))))) (full-test kernel-var-test (let ((channel (make-channel))) (submit-task channel (lambda () *kernel*)) (is (eq *kernel* (receive-result channel))))) (base-test task-categories-test (with-temp-kernel (2) (is (notany #'identity (task-categories-running))) (let ((channel (make-channel))) (submit-task channel (lambda () (sleep 0.4))) (sleep 0.2) (is (eql 1 (count :default (task-categories-running)))))) (with-temp-kernel (2) (let ((channel (make-channel))) (let ((*task-category* :foo)) (submit-task channel (lambda () (sleep 0.4)))) (sleep 0.2) (is (eql 1 (count :foo (task-categories-running)))))) (with-temp-kernel (2) (let ((channel (make-channel))) (let ((*task-category* 999)) (submit-task channel (lambda () (sleep 0.4)))) (sleep 0.2) (is (eql 1 (count 999 (task-categories-running)))))) (with-temp-kernel (2) (let ((channel (make-channel))) (let ((*task-category* :foo)) (submit-task channel (lambda () (sleep 0.4))) (submit-task channel (lambda () (sleep 0.4)))) (sleep 0.2) (is (eql 2 (count :foo (task-categories-running))))))) (base-test no-kernel-restart-test (let ((*kernel* nil)) (unwind-protect (let ((flag nil)) (handler-bind ((no-kernel-error (lambda (c) (setf flag :called) (invoke-restart (find-restart 'make-kernel c) 3)))) (let ((channel (make-channel))) (submit-task channel (lambda (x) (* x x)) 3) (is (= 9 (receive-result channel)))) (is (= 3 (kernel-worker-count))) (is (eq :called flag)))) (end-kernel)))) (base-test kernel-warnings-test (let ((*error-output* (make-string-output-stream))) (with-temp-kernel (3) (is (zerop (length (get-output-stream-string *error-output*)))) (let ((channel (make-channel))) (submit-task channel (lambda () (warn "blah"))) (receive-result channel)) (is (search "blah" (get-output-stream-string *error-output*)))))) (full-test handler-bind-test (task-handler-bind ((foo-error (lambda (e) (declare (ignore e)) (invoke-restart 'double-me 3)))) (let ((channel (make-channel))) (repeat 3 (submit-task channel (lambda () (restart-case (error 'foo-error) (double-me (x) ;; clisp warns unless interactive is given :interactive (lambda ()) (* 2 x)))))) (is (equal '(6 6 6) (collect-n 3 (receive-result channel))))))) (full-test aborted-worker-test (task-handler-bind ((foo-error (lambda (e) (declare (ignore e)) (invoke-abort-thread)))) (let ((channel (make-channel))) (submit-task channel (lambda () (setf *error-output* (make-broadcast-stream)) (restart-case (error 'foo-error) (eleven () 11)))) (signals task-killed-error (receive-result channel))))) (defun all-workers-alive-p () (sleep 0.2) (every #'bordeaux-threads:thread-alive-p (map 'list #'lparallel.kernel::thread (lparallel.kernel::workers *kernel*)))) (base-test active-worker-replacement-test (with-thread-count-check (with-temp-kernel (2) (is (all-workers-alive-p)) (task-handler-bind ((foo-error (lambda (e) (declare (ignore e)) (invoke-abort-thread)))) (let ((channel (make-channel))) (submit-task channel (lambda () (setf *error-output* (make-broadcast-stream)) (error 'foo-error))) (signals task-killed-error (receive-result channel)))) (is (all-workers-alive-p))))) #-lparallel.without-kill (base-test sleeping-worker-replacement-test (with-thread-count-check (with-temp-kernel (2 :bindings (list (cons '*error-output* (make-broadcast-stream)))) (is (all-workers-alive-p)) (destroy-thread (lparallel.kernel::thread (aref (lparallel.kernel::workers *kernel*) 0))) (is (all-workers-alive-p)) (destroy-thread (lparallel.kernel::thread (aref (lparallel.kernel::workers *kernel*) 0))) (destroy-thread (lparallel.kernel::thread (aref (lparallel.kernel::workers *kernel*) 1))) (is (all-workers-alive-p))))) (define-condition foo-condition () ()) (full-test non-error-condition-test (let ((result nil)) (task-handler-bind ((foo-condition (lambda (c) (declare (ignore c)) (setf result :called)))) (let ((channel (make-channel))) (submit-task channel (lambda () (signal 'foo-condition))) (receive-result channel))) (is (eq :called result)))) #-lparallel.without-kill (base-test custom-kill-task-test (with-thread-count-check (with-temp-kernel (2) (let ((channel (make-channel))) (let ((*task-category* 'blah)) (submit-task channel (lambda () (setf *error-output* (make-broadcast-stream)) (infinite-loop))) (submit-task channel (lambda () (setf *error-output* (make-broadcast-stream)) (infinite-loop)))) (sleep 0.2) (submit-task channel (lambda () 'survived)) (sleep 0.2) (kill-tasks 'blah) (sleep 0.2) (let ((errors nil) (regulars nil)) (repeat 3 (handler-case (push (receive-result channel) regulars) (task-killed-error (e) (push e errors)))) (is (= 2 (length errors))) (is (equal '(survived) regulars))))))) #-lparallel.without-kill (base-test default-kill-task-test (with-thread-count-check (with-temp-kernel (2) (let ((channel (make-channel))) (submit-task channel (lambda () (setf *error-output* (make-broadcast-stream)) (infinite-loop))) (submit-task channel (lambda () (setf *error-output* (make-broadcast-stream)) (infinite-loop))) (sleep 0.2) (submit-task channel (lambda () 'survived)) (sleep 0.2) (kill-tasks *task-category*) (sleep 0.2) (let ((errors nil) (regulars nil)) (repeat 3 (handler-case (push (receive-result channel) regulars) (task-killed-error (e) (push e errors)))) (is (= 2 (length errors))) (is (equal '(survived) regulars))))))) (base-test submit-timeout-test (with-temp-kernel (2) (let ((channel (make-channel))) (declare (notinline submit-timeout)) (submit-timeout channel 0.1 'timeout) (submit-task channel (lambda () 3)) (is (eql 3 (receive-result channel))) (is (eq 'timeout (receive-result channel)))))) #-lparallel.without-kill (base-test cancel-timeout-test (with-temp-kernel (2) (locally (declare (notinline submit-timeout cancel-timeout)) (let* ((channel (make-channel)) (timeout (submit-timeout channel 999 'timeout))) (sleep 0.2) (cancel-timeout timeout 'a) (is (eq 'a (receive-result channel))))))) #-lparallel.without-kill (base-test kill-timeout-test (with-temp-kernel (2) (locally (declare (notinline submit-timeout)) (let* ((channel (make-channel)) (timeout (submit-timeout channel 999 'timeout))) (sleep 0.2) (lparallel.kernel::with-timeout-slots (lparallel.kernel::thread) timeout (destroy-thread lparallel.kernel::thread)) (signals task-killed-error (receive-result channel)))))) (define-condition foo-condition-2 (condition) ()) (full-test signaling-after-signal-test (let ((q (make-queue))) (task-handler-bind ((foo-condition-2 (lambda (c) (declare (ignore c)) (push-queue 'outer q)))) (task-handler-bind ((foo-condition (lambda (c) (declare (ignore c)) (push-queue 'inner q) (signal 'foo-condition-2)))) (let ((channel (make-channel))) (submit-task channel (lambda () (signal 'foo-condition))) (receive-result channel)))) (is (equal '(inner outer) (extract-queue q))))) (base-test task-handler-bind-syntax-test (signals error (macroexpand '(task-handler-bind ((()))))) (signals error (macroexpand '(task-handler-bind (())))) (signals error (macroexpand '(task-handler-bind ((x))))) (signals error (macroexpand '(task-handler-bind ((x y z)))))) (full-test print-kernel-test (is (plusp (length (with-output-to-string (s) (print *kernel* s)))))) (base-test end-kernel-wait-test (with-thread-count-check (let ((*kernel* (make-kernel 3))) (unwind-protect (let ((channel (make-channel))) (submit-task channel (lambda () (sleep 1)))) (is (eql 3 (length (end-kernel :wait t)))))))) (base-test steal-work-test (with-temp-kernel (2) (let ((channel (make-channel))) (submit-task channel (lambda () (sleep 0.4))) (submit-task channel (lambda () (sleep 0.4))) (sleep 0.1) (let ((execp nil)) (submit-task channel (lambda () (setf execp t))) (sleep 0.1) (is (eq t (lparallel.kernel::steal-work *kernel* lparallel.kernel::*worker*))) (is (eq t execp)) (is (eq nil (lparallel.kernel::steal-work *kernel* lparallel.kernel::*worker*)))))) (with-temp-kernel (2) (let ((channel (make-channel))) (submit-task channel (lambda () (sleep 0.2))) (submit-task channel (lambda () (sleep 0.2))) (sleep 0.1) (is (eq nil (lparallel.kernel::steal-work *kernel* lparallel.kernel::*worker*)))))) (base-test kernel-store-value-test (unwind-protect (handler-bind ((no-kernel-error (lambda (e) (declare (ignore e)) (invoke-restart 'store-value (make-kernel 2))))) (let ((channel (make-channel))) (submit-task channel 'identity 3) (is (= 3 (receive-result channel))))) (end-kernel))) #-lparallel.without-kill (base-test reject-kill-nil-test (with-temp-kernel (2) (let ((channel (make-channel))) (submit-task channel (lambda () (setf *error-output* (make-broadcast-stream)) (sleep 999))) (sleep 0.2) (signals error (kill-tasks nil)) (= 1 (kill-tasks :default))))) #-lparallel.without-kill (full-test worker-suicide-test (let ((channel (make-channel))) (submit-task channel (lambda () (setf *error-output* (make-broadcast-stream)) (kill-tasks :default))) (signals task-killed-error (receive-result channel))) (let ((channel (make-channel)) (*task-category* 'foo)) (submit-task channel (lambda () (setf *error-output* (make-broadcast-stream)) (kill-tasks 'foo))) (signals task-killed-error (receive-result channel)))) (full-test submit-after-end-kernel-test (let ((channel (make-channel))) (end-kernel :wait t) (signals error (submit-task channel (lambda ()))))) (base-test double-end-kernel-test (let* ((kernel (make-kernel 2)) (*kernel* kernel)) (end-kernel :wait t) (let ((*kernel* kernel)) (end-kernel :wait t))) ;; got here without an error (is (= 1 1))) (base-test kernel-reader-test (setf *memo* nil) (let ((context (lambda (worker-loop) (let ((*memo* 3)) (funcall worker-loop))))) (with-temp-kernel (2 :name "foo" :bindings `((*blah* . 99)) :context context) (let ((channel (make-channel))) (submit-task channel (lambda () (declare (special *blah*)) (list *memo* *blah*))) (is (equal '(3 99) (receive-result channel)))) (is (string-equal "foo" (kernel-name))) (is (equal '((*blah* . 99)) (kernel-bindings))) (is (eq context (kernel-context)))))) (defun aborting-context (worker-loop) (declare (ignore worker-loop)) (invoke-abort-thread)) (defun non-funcalling-context (worker-loop) (declare (ignore worker-loop))) (base-test context-error-test (dolist (n '(1 2 4 8)) (with-thread-count-check (signals kernel-creation-error (make-kernel n :context #'aborting-context))))) (base-test non-funcalling-context-test (dolist (n '(1 2 4 8)) (with-thread-count-check (signals kernel-creation-error (make-kernel n :context 'non-funcalling-context))))) (base-test nonexistent-context-test (with-thread-count-check (signals error (make-kernel 1 :context 'nonexistent-function)))) (base-test broadcast-test (setf *memo* 0) (dolist (n '(1 2 3 4 7 8 15 16)) (with-temp-kernel (n :bindings '((*memo* . 1))) (is (= 0 *memo*)) (let ((channel (make-channel))) (repeat 100 (submit-task channel (lambda () *memo*))) (repeat 100 (is (= 1 (receive-result channel))))) (is (every (lambda (x) (= x 1)) (broadcast-task (lambda () *memo*)))) (let ((channel (make-channel))) (repeat (kernel-worker-count) (submit-task channel #'sleep 0.2))) (is (every (lambda (x) (= x 99)) (broadcast-task (lambda () (setf *memo* 99))))) (let ((channel (make-channel))) (repeat 1000 (submit-task channel (lambda ())))) (is (every (lambda (x) (= x 99)) (broadcast-task (lambda () (setf *memo* 99))))) (is (every (lambda (x) (= x 99)) (broadcast-task (lambda () (setf *memo* 99))))) (is (= 0 *memo*)) (let ((channel (make-channel))) (repeat 100 (submit-task channel (lambda () *memo*))) (repeat 100 (is (= 99 (receive-result channel))))) (let ((channel (make-channel))) (repeat 1000 (submit-task channel (lambda ())))) (is (every (lambda (x) (= x 99)) (broadcast-task (lambda () *memo*)))) (is (every (lambda (x) (= x 99)) (broadcast-task (lambda () *memo*)))) (is (every (lambda (x) (= x 5)) (broadcast-task #'+ 2 3)))))) (full-test broadcast-error-test (let ((*kernel* nil)) (signals no-kernel-error (broadcast-task (lambda ())))) (signals error (broadcast-task 3)) (signals error (broadcast-task "foo")) (task-handler-bind ((error #'invoke-transfer-error)) (signals foo-error (broadcast-task #'error 'foo-error)) (let ((channel (make-channel))) (submit-task channel (lambda () (broadcast-task (lambda ())))) (signals error (receive-result channel))) (signals error (broadcast-task (lambda () (broadcast-task (lambda ()))))))) (full-test worker-index-test (is (null (kernel-worker-index))) (let ((channel (make-channel))) (repeat 1000 (submit-task channel #'kernel-worker-index)) (repeat 1000 (let ((x (receive-result channel))) (is (and (>= x 0) (< x (kernel-worker-count))))))) (loop for i across (sort (broadcast-task #'kernel-worker-index) #'<) for j from 0 do (is (= i j)))) ;;;; check for messed up imports (defun packages-matching (string) (remove-if-not (lambda (package) (search string (package-name package) :test #'equalp)) (list-all-packages))) (defun assert-internal-symbols-not-imported (&key own-packages third-party-packages) (let ((third-party-packages (mapcar #'find-package third-party-packages))) (dolist (own-package own-packages) (do-symbols (symbol own-package) (when-let (third-party-package (find (symbol-package symbol) third-party-packages)) (when (eq :internal (nth-value 1 (find-symbol (symbol-name symbol) third-party-package))) (error "Internal symbol ~s was imported into ~a." symbol (package-name own-package)))))))) (base-test package-test (assert-internal-symbols-not-imported :own-packages (packages-matching "lparallel") :third-party-packages '(#:alexandria #:bordeaux-threads)) (is t)) lparallel-20160825-git/test/package.lisp000066400000000000000000000042001274371011200177510ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (defpackage #:lparallel-test (:documentation "Test suite for lparallel.") (:use #:cl #:lparallel.util #:lparallel.thread-util #:lparallel.raw-queue #:lparallel.queue #:lparallel.vector-queue #:lparallel.kernel #:lparallel.cognate #:lparallel.defpun #:lparallel.promise #:lparallel.ptree #:lparallel-test.1am) (:import-from #:lparallel.kernel-util #:with-temp-kernel) (:export #:execute)) (in-package #:lparallel-test) lparallel-20160825-git/test/promise-test.lisp000066400000000000000000000311251274371011200210170ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel-test) (full-test futures-test (let ((a (future 3)) (b (future 4))) (is (= 7 (+ (force a) (force b))))) (let ((a (future 5))) (sleep 0.2) (is (fulfilledp a)) (is (= 5 (force a)))) (let ((a (future (sleep 0.4) 3))) (is (not (fulfilledp a))) (sleep 0.2) (is (eq nil (fulfill a 4))) (is (not (fulfilledp a))) (is (= 3 (force a)))) (let ((a (future 3))) (sleep 0.2) (is (eq nil (fulfill a 9))) (is (= 3 (force a))))) (full-test promises-test (let ((a (promise)) (b (promise))) (fulfill a 3) (fulfill b 4) (is (= 12 (* (force a) (force b))))) (let ((a (promise))) (is (eq t (fulfill a 3))) (is (eq nil (fulfill a 4))) (is (= 3 (force a))))) (full-test fulfill-chain-test (let ((a (promise)) (b (promise))) (fulfill a (chain (future 5))) (fulfill b (chain (future 6))) (is (= 30 (* (force a) (force b))))) (let ((a (promise)) (b (promise))) (fulfill a (chain (delay 7))) (fulfill b (chain (delay 8))) (is (= 56 (* (force a) (force b))))) (let* ((a (promise)) (b (chain a))) (fulfill b 3) (is (eql 3 (force b))) (is (eql 3 (force a))))) (full-test force-chain-test (let ((f (delay (chain (delay 3))))) (is (= 3 (force f)))) (let ((f (delay (chain (delay (chain (delay 3))))))) (is (= 3 (force f))))) (full-test nested-chain-test (is (equal '(3 4 5) (multiple-value-list (force (chain (speculate (chain (speculate (values 3 4 5))))))))) (is (equal '(3 4 5) (multiple-value-list (force (chain (future (chain (future (values 3 4 5))))))))) (is (equal '(3 4 5) (multiple-value-list (force (chain (delay (chain (delay (values 3 4 5))))))))) (let ((f (future (values 3 4 5)))) (sleep 0.1) (is (equal '(3 4 5) (multiple-value-list (force (chain (delay (chain f))))))) (is (equal '(3 4 5) (multiple-value-list (force (chain (future (chain f))))))))) (base-test speculations-test (setf *memo* (make-queue)) (with-temp-kernel (2) (sleep 0.2) (future (sleep 0.25)) (future (sleep 0.50)) (sleep 0.125) (speculate (push-queue 3 *memo*)) (future (push-queue 4 *memo*)) (sleep 0.5) (is (eql 4 (pop-queue *memo*))) (is (eql 3 (pop-queue *memo*))))) (full-test flood-test (let* ((a (promise)) (futures (collect-n 100 (future (force a))))) (is (notany #'fulfilledp futures)) (sleep 0.5) (is (notany #'fulfilledp futures)) (fulfill a 4) (sleep 1.0) (is (every #'fulfilledp futures)) (is (every (lambda (x) (= x 4)) (mapcar #'force futures))))) (defmacro define-force-test (defer) `(full-test ,(intern (concatenate 'string (string defer) (string '#:-force-test))) (let ((a (,defer (+ 3 4)))) (is (= 7 (force a)))) (setf *memo* 0) (let ((a (,defer (progn (incf *memo*) 9)))) (sleep 0.1) (is (= 9 (force a))) (is (= 1 *memo*)) (is (= 9 (force a))) (is (= 1 *memo*))) (let ((a (mapcar (lambda (x) (,defer (* x x))) '(3 4 5)))) (is (equal '(9 16 25) (mapcar #'force a)))) (task-handler-bind ((foo-error (lambda (e) (invoke-restart 'transfer-error e)))) (let ((a (,defer (error 'foo-error)))) (signals foo-error (force a)) (signals foo-error (force a)))))) (define-force-test future) (define-force-test speculate) (define-force-test delay) (full-test sequential-force-test (repeat 100 (let* ((a (future 3)) (b (future (force a))) (c (future (force b))) (d (future (force c))) (e (future (force d)))) (is (= 3 (force e)))))) (defmacro define-big-sequential () `(full-test big-sequential-test ,(loop with vars = (collect-n 100 (gensym)) for (a b) on vars when b collect `(,b (future (force ,a))) into binds finally (return `(let* ((,(car vars) (future 4)) ,@binds) (is (= 4 (force ,(car (last vars)))))))))) (define-big-sequential) (full-test future-recursion-test (labels ((fib (n) (if (< n 2) n (let* ((f1 (future (fib (- n 1)))) (f2 (fib (- n 2)))) (+ (force f1) f2))))) (is (= 144 (fib 12))))) (full-test multiple-value-test (let ((x (promise))) (fulfill x (values 3 4 5)) (multiple-value-bind (p q r) (force x) (is (= 3 p)) (is (= 4 q)) (is (= 5 r)))) (let ((x (future (values 3 4 5)))) (multiple-value-bind (p q r) (force x) (is (= 3 p)) (is (not (null q))) (is (= 4 q)) (is (= 5 r)))) (let ((x (delay (values 3 4 5)))) (multiple-value-bind (p q r) (force x) (is (= 3 p)) (is (not (null q))) (is (= 4 q)) (is (= 5 r))))) (full-test future-restart-test (task-handler-bind ((foo-error (lambda (e) (declare (ignore e)) (invoke-restart 'eleven)))) (let ((x (future (restart-case (error 'foo-error) (eleven () 11))))) (is (eql 11 (force x))))) (task-handler-bind ((foo-error (lambda (e) (declare (ignore e)) (invoke-restart 'eleven)))) (let* ((x (future (restart-case (error 'foo-error) (eleven () 11)))) (y (future (force x)))) (is (eql 11 (force y)))))) (full-test speculation-restart-test (task-handler-bind ((foo-error (lambda (e) (declare (ignore e)) (invoke-restart 'eleven)))) (let ((x (speculate (restart-case (error 'foo-error) (eleven () 11))))) (is (eql 11 (force x))))) (task-handler-bind ((foo-error (lambda (e) (declare (ignore e)) (invoke-restart 'eleven)))) (let* ((x (speculate (restart-case (error 'foo-error) (eleven () 11)))) (y (force x))) (is (eql 11 (force y)))))) (full-test future-store-value-test (task-handler-bind ((error (lambda (e) (invoke-restart 'transfer-error e)))) (handler-bind ((foo-error (lambda (e) (declare (ignore e)) (invoke-restart 'store-value 3 4)))) (let ((x (future (error 'foo-error)))) (sleep 0.1) (is (equal '(3 4) (multiple-value-list (force x)))))))) (base-test multi-future-store-value-test ;; verify STORE-VALUE is thread-safe (loop for n from 1 to 64 do (with-temp-kernel (n) (let* ((channel (make-channel)) (counter (make-queue)) (future (task-handler-bind ((foo-error #'invoke-transfer-error)) (future (error 'foo-error))))) (sleep 0.1) (repeat n (submit-task channel (lambda () (handler-bind ((foo-error (lambda (e) (declare (ignore e)) (push-queue nil counter) (invoke-restart 'store-value (queue-count counter))))) (force future))))) (let ((results (loop repeat n collect (receive-result channel)))) (is (every #'= results (rest results)))))))) (base-test abort-future-test (handler-bind ((warning (lambda (w) (when-let (r (find-restart 'muffle-warning w)) (invoke-restart r))))) (with-temp-kernel (2) (sleep 0.2) (let ((main-thread (current-thread))) (task-handler-bind ((foo-error (lambda (e) (declare (ignore e)) ;; don't kill main thread (unless (eq (current-thread) main-thread) (invoke-abort-thread))))) (let ((future (future (unless (eq (current-thread) main-thread) (setf *error-output* (make-broadcast-stream))) (error 'foo-error)))) (sleep 0.1) (signals task-killed-error (force future)))))))) (base-test canceling-test (with-temp-kernel (2) (sleep 0.1) (let* ((a (promise)) (filler1 (future (sleep 0.2))) (filler2 (future (sleep 0.2)))) (declare (ignore filler1 filler2)) (sleep 0.1) (let ((b (future (fulfill a 'foo)))) (declare (ignore b)) (sleep 0.2) (is (fulfilledp a)))) (let* ((a (promise)) (filler1 (future (sleep 0.6))) (filler2 (future (sleep 0.6)))) (declare (ignore filler1 filler2)) (sleep 0.1) (let ((b (future (fulfill a 'foo)))) (sleep 0.2) (fulfill b 'nevermind) (sleep 0.2) (is (not (fulfilledp a))))))) (base-test error-during-stealing-force-test (with-temp-kernel (2) ;; occupy workers (future (sleep 0.4)) (future (sleep 0.4)) (sleep 0.2) (let* ((call-count 0) (handle-count 0) (f (task-handler-bind ((foo-error (lambda (e) (invoke-restart 'transfer-error e)))) (future (incf call-count) (error 'foo-error))))) (repeat 3 (block top (handler-bind ((foo-error (lambda (e) (declare (ignore e)) (incf handle-count) (return-from top)))) (force f)))) (is (= 1 call-count)) (is (= 3 handle-count))))) (base-test error-during-stealing-force-2-test (with-temp-kernel (2) ;; occupy workers (future (sleep 0.4)) (future (sleep 0.4)) (sleep 0.2) (let ((f (task-handler-bind ((foo-error (lambda (e) (declare (ignore e)) (invoke-restart 'nine)))) (future (restart-case (error 'foo-error) (nine () 9)))))) (is (eql 9 (force f)))))) (base-test non-promise-test (dolist (obj (list 3 4.0 'foo (cons nil nil))) (is (fulfilledp obj)) (is (eql obj (force obj))) (setf *memo* 11) (is (eql nil (fulfill obj (setf *memo* 22)))) (is (eql 11 *memo*))) (let ((obj (chain 3))) (is (fulfilledp obj)) (setf *memo* 11) (is (eql nil (fulfill obj (setf *memo* 22)))) (is (eql 11 *memo*)))) lparallel-20160825-git/test/ptree-test.lisp000066400000000000000000000376611274371011200204730ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel-test) (full-test basic-ptree-test (ptree ((a (b c) (- b c)) (b () 3) (c () 4)) (is (= a (- 3 4))) (is (= b 3)) (is (= c 4)))) (full-test basic-ptree-2-test (ptree ((area (width height) (* width height)) (width (border) (+ 7 (* 2 border))) (height (border) (+ 5 (* 2 border))) (border () 1)) (is (= (* (+ 7 (* 2 1)) (+ 5 (* 2 1))) area)) (is (= (+ 7 (* 2 1)) width)) (is (= (+ 5 (* 2 1)) height)) (is (= 1 border)))) (full-test basic-ptree-fn-test (let ((tree (make-ptree))) (ptree-fn 'area '(width height) (lambda (w h) (* w h)) tree) (ptree-fn 'width '(border) (lambda (b) (+ 7 (* 2 b))) tree) (ptree-fn 'height '(border) (lambda (b) (+ 5 (* 2 b))) tree) (ptree-fn 'border '() (lambda () 1) tree) (is (= (* (+ 7 (* 2 1)) (+ 5 (* 2 1))) (call-ptree 'area tree))) (is (= (+ 7 (* 2 1)) (call-ptree 'width tree))) (is (= (+ 5 (* 2 1)) (call-ptree 'height tree))) (is (= 1 (call-ptree 'border tree))))) (full-test ptree-no-double-compute-test (let ((tree (make-ptree))) (setf *memo* 0) (ptree-fn 'f '(x) (lambda (x) (* x x)) tree) (ptree-fn 'x '() (lambda () (incf *memo*) 5) tree) (is (= 25 (call-ptree 'f tree))) (is (= 1 *memo*)) (is (= 25 (call-ptree 'f tree))) (is (= 1 *memo*)) (is (= 5 (call-ptree 'x tree))) (is (= 1 *memo*)))) (full-test ptree-lone-fn-test (ptree ((lone () 7)) (is (= 7 lone)))) (full-test ptree-missing-node-test (let ((tree (make-ptree))) (ptree-fn 'f '(x) (lambda (x) (* x x)) tree) (signals ptree-undefined-function-error (call-ptree 'g tree)))) (full-test ptree-unknown-node-test (let ((signaledp nil)) (handler-case (task-handler-bind ((error #'invoke-transfer-error)) (ptree ((x () 3) (y () 4) (z (x h) (* x h))) (list x y z))) (error (err) (setf signaledp t) (is (eq 'ptree-undefined-function-error (type-of err))) (let ((id (lparallel.ptree::ptree-error-id err)) (refs (lparallel.ptree::ptree-error-refs err))) (is (equal 'h id)) (is (equal '(z) ;; avoid sbcl warning (locally (declare (notinline sort)) (sort (copy-list refs) #'string<))))))) (is (not (null signaledp))))) (full-test missing-ptree-function-test (let ((tree (make-ptree))) (ptree-fn 'area '(width height) (lambda (w h) (* w h)) tree) (ptree-fn 'width '(border) (lambda (b) (+ 7 (* 2 b))) tree) (ptree-fn 'height '(border) (lambda (b) (+ 5 (* 2 b))) tree) (handler-case (check-ptree tree) (error (err) (is (eq 'ptree-undefined-function-error (type-of err))) (let ((id (lparallel.ptree::ptree-error-id err)) (refs (lparallel.ptree::ptree-error-refs err))) (is (equal 'border id)) (is (equal '(height width) ;; avoid sbcl warning (locally (declare (notinline sort)) (sort (copy-list refs) #'string<))))))))) (full-test ptree-redefinition-test (signals ptree-redefinition-error (let ((tree (make-ptree))) (ptree-fn 'foo () (lambda () 3) tree) (ptree-fn 'foo () (lambda () 4) tree)))) (full-test lambda-list-keywords-in-ptree-test (signals ptree-lambda-list-keyword-error (eval '(ptree ((foo (x &optional y) (list x y)))))) (signals ptree-lambda-list-keyword-error (eval '(ptree ((foo (x &REST y) (list x y))))))) (full-test error-inside-ptree-function-test (let ((memo (make-queue))) (task-handler-bind ((foo-error (lambda (e) (push-queue e memo) (invoke-restart 'transfer-error e)))) (let ((tree (make-ptree))) (ptree-fn 'root '(child) (lambda (x) x) tree) (ptree-fn 'child () (lambda () (error 'foo-error)) tree) (let ((err nil)) (handler-case (call-ptree 'root tree) (error (result) (setf err result))) (is (not (null err))) (is (eq 'foo-error (type-of err)))))) (is (= 1 (queue-count memo))) (is (typep (pop-queue memo) 'foo-error)))) (defmacro/once for-range ((var &once pair) &body body) `(loop for ,var from (first ,pair) to (second ,pair) do (progn ,@body))) (full-test grind-ptree-test (let ((level-range '(1 5)) (children-range '(1 5)) (main-iterations 3) (root (gensym)) (count nil)) (flet ((generate-ptree (num-levels num-children tree) (labels ((pick-names () (collect-n (1+ (random num-children)) (gensym))) (build-tree (parent children level) (ptree-fn parent children #'+ tree) (dolist (child children) (cond ((< level num-levels) (build-tree child (pick-names) (1+ level))) (t (incf count) (ptree-fn child () (lambda () 1) tree)))))) (build-tree root (pick-names) 0)))) (for-range (num-levels level-range) (for-range (num-children children-range) (repeat main-iterations (let ((tree (make-ptree))) (setf count 0) (generate-ptree num-levels num-children tree) (is (eql count (call-ptree root tree)))))))))) (base-test ptree-node-kernel-test (let ((*ptree-node-kernel* (make-kernel 2))) (unwind-protect (with-temp-kernel (1) (is (equal '(63 9 7 1) (ptree ((area (width height) (* width height)) (width (border) (+ 7 (* 2 border))) (height (border) (+ 5 (* 2 border))) (border () (let ((channel (make-channel))) (submit-task channel (lambda () 1)) (receive-result channel)))) ;; will hang without separate node kernel (list area width height border))))) (let ((*kernel* *ptree-node-kernel*)) (end-kernel))))) (full-test ptree-node-id-test (let ((tree (make-ptree)) (area (cons nil nil)) (width 9999) (height 'height) (border (cons nil nil))) (ptree-fn area (list width height) (lambda (w h) (* w h)) tree) (ptree-fn width (list border) (lambda (b) (+ 7 (* 2 b))) tree) (ptree-fn height (list border) (lambda (b) (+ 5 (* 2 b))) tree) (ptree-fn border '() (lambda () 1) tree) (is (= 63 (call-ptree area tree))) (is (= 9 (call-ptree width tree))) (is (= 7 (call-ptree height tree))) (is (= 1 (call-ptree border tree))))) (full-test ptree-basic-restart-test (task-handler-bind ((foo-error (lambda (e) (declare (ignore e)) (invoke-restart 'nine)))) (ptree ((result () (restart-case (error 'foo-error) (nine () 9)))) (is (= 9 result))))) (full-test ptree-restart-test (task-handler-bind ((foo-error (lambda (e) (declare (ignore e)) (invoke-restart 'nine)))) (ptree ((area (width height) (* width height)) (width () 3) (height () (restart-case (error 'foo-error) (nine () 9)))) (is (= 27 area)) (is (= 3 width)) (is (= 9 height))) (ptree ((area (width height) (* width height)) (height () (restart-case (error 'foo-error) (nine () 9))) (width () 3)) (is (= 27 area)) (is (= 3 width)) (is (= 9 height))))) (full-test ptree-transfer-error-test (task-handler-bind ((foo-error #'invoke-transfer-error)) (ptree ((area (width height) (* width height)) (width () 3) (height () (restart-case (error 'foo-error) (nine () 9)))) (signals foo-error area) (signals foo-error height) (is (= 3 width))) (ptree ((area (width height) (* width height)) (width () 3) (height () (restart-case (error 'foo-error) (nine () 9)))) (signals foo-error height) (signals foo-error area) (is (= 3 width))))) #-lparallel.without-kill (base-test ptree-kill-test (let ((memo (make-queue)) (tree (make-ptree))) (ptree-fn 'inf '() #'infinite-loop tree) (with-temp-kernel (2 :bindings `((*error-output* . (make-broadcast-stream)))) (with-thread (:bindings `((*kernel* . ,*kernel*))) (handler-case (call-ptree 'inf tree) (error (e) (push-queue e memo)))) (sleep 0.2) (is (= 1 (kill-tasks :default))) (sleep 0.2) (is (= 1 (queue-count memo))) (is (typep (pop-queue memo) 'task-killed-error)) (signals task-killed-error (call-ptree 'inf tree)) (signals task-killed-error (call-ptree 'inf tree))))) #-lparallel.without-kill (base-test second-ptree-kill-test (let ((memo (make-queue)) (tree (make-ptree))) (ptree-fn 'area '(width height) (lambda (w h) (* w h)) tree) (ptree-fn 'height '() #'infinite-loop tree) (ptree-fn 'width '() (constantly 9) tree) (with-temp-kernel (2 :bindings `((*error-output* . (make-broadcast-stream)))) (with-thread (:bindings `((*kernel* . ,*kernel*))) (handler-case (call-ptree 'area tree) (error (e) (push-queue e memo)))) (sleep 0.2) (is (= 1 (kill-tasks :default))) (sleep 0.2) (is (= 1 (queue-count memo))) (is (typep (pop-queue memo) 'task-killed-error)) (signals task-killed-error (call-ptree 'area tree)) (signals task-killed-error (call-ptree 'height tree)) (is (= 9 (call-ptree 'width tree)))))) #-lparallel.without-kill (base-test third-ptree-kill-test (let ((memo (make-queue)) (tree (make-ptree))) (ptree-fn 'inf '(five) (lambda (x) (declare (ignore x)) (infinite-loop)) tree) (ptree-fn 'five '() (constantly 5) tree) (with-temp-kernel (2 :bindings `((*error-output* . (make-broadcast-stream)))) (with-thread (:bindings `((*kernel* . ,*kernel*))) (handler-case (call-ptree 'inf tree) (error (e) (push-queue e memo)))) (sleep 0.2) (is (= 1 (kill-tasks :default))) (sleep 0.2) (is (= 1 (queue-count memo))) (is (typep (pop-queue memo) 'task-killed-error)) (signals task-killed-error (call-ptree 'inf tree)) (signals task-killed-error (call-ptree 'inf tree)) (is (= 5 (call-ptree 'five tree)))))) (full-test clear-ptree-test (let ((tree (make-ptree)) (count 0)) (ptree-fn 'area '(width height) (lambda (w h) (* w h)) tree) (ptree-fn 'height '() (constantly 3) tree) (ptree-fn 'width '() (lambda () (incf count) 9) tree) (is (= 27 (call-ptree 'area tree))) (is (= 1 count)) (is (= 27 (call-ptree 'area tree))) (is (= 1 count)) (clear-ptree tree) (is (= 27 (call-ptree 'area tree))) (is (= 2 count)))) (full-test clear-ptree-errors-test (task-handler-bind ((foo-error #'invoke-transfer-error)) (let ((tree (make-ptree)) (count 0) (ready nil)) (ptree-fn 'area '(width height) (lambda (w h) (* w h)) tree) (ptree-fn 'height '() (constantly 3) tree) (ptree-fn 'width '() (lambda () (incf count) (if ready 9 (error 'foo-error))) tree) (signals foo-error (call-ptree 'area tree)) (is (= 1 count)) (signals foo-error (call-ptree 'area tree)) (is (= 1 count)) (clear-ptree-errors tree) (setf ready t) (is (= 27 (call-ptree 'area tree))) (is (= 2 count)) (is (= 27 (call-ptree 'area tree))) (is (= 2 count))))) (base-test ptree-multi-error-test (with-temp-kernel (2) (task-handler-bind ((foo-error #'invoke-transfer-error)) (let ((timer-finish-p nil)) (with-thread () (sleep 0.25) (setf timer-finish-p t)) (ptree ((area (width height) (* width height)) (width () (sleep 0.5) 99) (height () (error 'foo-error))) (signals foo-error height) (is (not timer-finish-p)) (signals foo-error area) (is (not timer-finish-p)) (= 99 width) (is (not (null timer-finish-p))))) (let ((timer-finish-p nil)) (with-thread () (sleep 0.25) (setf timer-finish-p t)) (ptree ((area (width height) (* width height)) (width () (sleep 0.5) 99) (height () (error 'foo-error))) (signals foo-error area) (is (not timer-finish-p)) (signals foo-error height) (is (not timer-finish-p)) (= 99 width) (is (identity timer-finish-p))))))) (full-test ptree-query-test (let ((tree (make-ptree))) (signals ptree-undefined-function-error (ptree-computed-p 'foo tree)) (ptree-fn 'z '(x y) #'+ tree) (ptree-fn 'x () (lambda () 3) tree) (ptree-fn 'y () (lambda () 4) tree) (is (not (ptree-computed-p 'x tree))) (is (not (ptree-computed-p 'y tree))) (is (not (ptree-computed-p 'z tree))) (is (= 3 (call-ptree 'x tree))) (is (ptree-computed-p 'x tree)) (is (not (ptree-computed-p 'y tree))) (is (not (ptree-computed-p 'z tree))) (is (= 7 (call-ptree 'z tree))) (is (ptree-computed-p 'x tree)) (is (ptree-computed-p 'y tree)) (is (ptree-computed-p 'z tree)))) lparallel-20160825-git/test/queue-test.lisp000066400000000000000000000332311274371011200204650ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel-test) (defmacro define-queue-test (name &key make-queue push-queue pop-queue try-pop-queue queue-empty-p queue-count peek-queue) `(base-test ,name (let ((q (,make-queue))) (is (eq t (,queue-empty-p q))) (multiple-value-bind (a b) (,try-pop-queue q) (is (null a)) (is (null b))) (multiple-value-bind (a b) (,peek-queue q) (is (null a)) (is (null b))) (,push-queue 3 q) (is (eq nil (,queue-empty-p q))) (,push-queue 4 q) (is (eq nil (,queue-empty-p q))) (multiple-value-bind (a b) (,peek-queue q) (is (= 3 a)) (is (not (null b)))) (,push-queue 5 q) (,push-queue 6 q) (,push-queue 7 q) (is (eql 5 (,queue-count q))) (is (eql 3 (,pop-queue q))) (multiple-value-bind (a b) (,try-pop-queue q) (is (= 4 a)) (is (not (null b)))) (is (equal '(5 6 7) (loop repeat 3 collect (,pop-queue q)))) (is (eq t (,queue-empty-p q))) (multiple-value-bind (a b) (,try-pop-queue q) (is (null a)) (is (null b))) (multiple-value-bind (a b) (,peek-queue q) (is (null a)) (is (null b))) (,push-queue 88 q) (is (eq nil (,queue-empty-p q))) (is (eq 1 (,queue-count q))) (,pop-queue q) (is (eq t (,queue-empty-p q))) (is (eq 0 (,queue-count q)))))) (defun make-fixed-capacity-queue () (make-queue :fixed-capacity 20)) (define-queue-test raw-queue-test :make-queue make-raw-queue :push-queue push-raw-queue :pop-queue pop-raw-queue :try-pop-queue pop-raw-queue :queue-empty-p raw-queue-empty-p :queue-count raw-queue-count :peek-queue peek-raw-queue) (define-queue-test queue-test :make-queue make-queue :push-queue push-queue :pop-queue pop-queue :try-pop-queue try-pop-queue :queue-empty-p queue-empty-p :queue-count queue-count :peek-queue peek-queue) #+lparallel.with-stealing-scheduler (define-queue-test spin-queue-test :make-queue lparallel.spin-queue:make-spin-queue :push-queue lparallel.spin-queue:push-spin-queue :pop-queue lparallel.spin-queue:pop-spin-queue :try-pop-queue lparallel.spin-queue:pop-spin-queue :queue-empty-p lparallel.spin-queue:spin-queue-empty-p :queue-count lparallel.spin-queue:spin-queue-count :peek-queue lparallel.spin-queue:peek-spin-queue) (define-queue-test fixed-capacity-queue-test :make-queue make-fixed-capacity-queue :push-queue push-queue :pop-queue pop-queue :try-pop-queue try-pop-queue :queue-empty-p queue-empty-p :queue-count queue-count :peek-queue peek-queue) #-lparallel.with-stealing-scheduler (define-queue-test biased-queue-test :make-queue lparallel.biased-queue:make-biased-queue :push-queue lparallel.biased-queue:push-biased-queue :pop-queue lparallel.biased-queue:pop-biased-queue :try-pop-queue lparallel.biased-queue:try-pop-biased-queue :queue-empty-p lparallel.biased-queue:biased-queue-empty-p :queue-count lparallel.biased-queue:biased-queue-count :peek-queue lparallel.biased-queue:peek-biased-queue) #-lparallel.with-stealing-scheduler (define-queue-test biased-queue-low-test :make-queue lparallel.biased-queue:make-biased-queue :push-queue lparallel.biased-queue:push-biased-queue/low :pop-queue lparallel.biased-queue:pop-biased-queue :try-pop-queue lparallel.biased-queue:try-pop-biased-queue :queue-empty-p lparallel.biased-queue:biased-queue-empty-p :queue-count lparallel.biased-queue:biased-queue-count :peek-queue lparallel.biased-queue:peek-biased-queue) (defmacro define-grind-queue (name &key make-queue push-queue pop-queue queue-count) `(base-test ,name (flet ((grind (producer-count consumer-count objects-per-producer) (let ((data-queue (,make-queue)) (done-queue (,make-queue))) (repeat producer-count (with-thread () (repeat objects-per-producer (,push-queue 'hello data-queue)) (,push-queue t done-queue))) (repeat consumer-count (with-thread () (loop until (eq :end (,pop-queue data-queue))) (,push-queue t done-queue))) (repeat producer-count (,pop-queue done-queue)) (repeat consumer-count (,push-queue :end data-queue)) (repeat consumer-count (,pop-queue done-queue)) (is (= 0 (,queue-count data-queue)))))) (with-thread-count-check (let ((n 100000)) (grind 4 1 n) (grind 1 4 n) (grind 1 1 n) (grind 4 4 n)) (sleep 0.5))))) (defun try-pop-queue/wait/no-timeout (queue) (loop (multiple-value-bind (value presentp) (try-pop-queue queue) (when presentp (return value))))) #-lparallel.without-bordeaux-threads-condition-wait-timeout (defun try-pop-queue/wait/timeout (queue) (multiple-value-bind (value presentp) (try-pop-queue queue :timeout 9999) (assert presentp) value)) (define-grind-queue grind-queue-test :make-queue make-queue :push-queue push-queue :pop-queue pop-queue :queue-count queue-count) #-lparallel.with-green-threads (define-grind-queue grind-queue-no-timeout-test :make-queue make-queue :push-queue push-queue :pop-queue try-pop-queue/wait/no-timeout :queue-count queue-count) #-lparallel.without-bordeaux-threads-condition-wait-timeout (define-grind-queue grind-queue-timeout-test :make-queue make-queue :push-queue push-queue :pop-queue try-pop-queue/wait/timeout :queue-count queue-count) (define-grind-queue grind-fixed-capacity-queue-test :make-queue make-fixed-capacity-queue :push-queue push-queue :pop-queue pop-queue :queue-count queue-count) #-lparallel.with-green-threads (define-grind-queue grind-fixed-capacity-queue-no-timeout-test :make-queue make-fixed-capacity-queue :push-queue push-queue :pop-queue try-pop-queue/wait/no-timeout :queue-count queue-count) #-lparallel.without-bordeaux-threads-condition-wait-timeout (define-grind-queue grind-fixed-capacity-queue-timeout-test :make-queue make-fixed-capacity-queue :push-queue push-queue :pop-queue try-pop-queue/wait/timeout :queue-count queue-count) #+lparallel.with-stealing-scheduler (defun pop-spin-queue/wait (queue) (loop (multiple-value-bind (item presentp) (lparallel.spin-queue:pop-spin-queue queue) (when presentp (return item))))) #+lparallel.with-stealing-scheduler (define-grind-queue grind-spin-queue-test :make-queue lparallel.spin-queue:make-spin-queue :push-queue lparallel.spin-queue:push-spin-queue :pop-queue pop-spin-queue/wait :queue-count lparallel.spin-queue:spin-queue-count) #-lparallel.with-stealing-scheduler (define-grind-queue grind-biased-queue-test :make-queue lparallel.biased-queue:make-biased-queue :push-queue lparallel.biased-queue:push-biased-queue :pop-queue lparallel.biased-queue:pop-biased-queue :queue-count lparallel.biased-queue:biased-queue-count) #-lparallel.with-stealing-scheduler (define-grind-queue grind-biased-queue-low-test :make-queue lparallel.biased-queue:make-biased-queue :push-queue lparallel.biased-queue:push-biased-queue/low :pop-queue lparallel.biased-queue:pop-biased-queue :queue-count lparallel.biased-queue:biased-queue-count) (base-test filled-queue-test (loop for n from 1 to 3 do (let ((queue (make-queue :fixed-capacity n))) (repeat n (is (not (queue-full-p queue))) (push-queue :x queue)) (repeat 3 (is (queue-full-p queue)) (let ((pushedp nil)) (with-thread () (push-queue :x queue) (setf pushedp t)) (sleep 0.2) (is (null pushedp)) (is (eq :x (pop-queue queue))) (sleep 0.2) (is (eq t pushedp)))))) (loop for n from 1 to 3 do (let ((queue (make-queue :fixed-capacity n))) (repeat n (is (not (queue-full-p queue))) (push-queue :x queue)) (repeat 3 (is (queue-full-p queue)) (let ((pushedp nil)) (with-thread () (push-queue :x queue) (setf pushedp t)) (sleep 0.2) (is (null pushedp)) (is (equal '(:x t) (multiple-value-list (try-pop-queue queue)))) (sleep 0.2) (is (eq t pushedp))))))) (base-test queue-initial-contents-test (let ((q (make-queue :initial-contents '(3 4 5)))) (is (= 3 (pop-queue q))) (is (= 4 (pop-queue q))) (is (= 5 (pop-queue q))) (is (queue-empty-p q))) (let ((q (make-queue :initial-contents #(3 4 5)))) (is (= 3 (pop-queue q))) (is (= 4 (pop-queue q))) (is (= 5 (pop-queue q))) (is (queue-empty-p q))) (let ((q (make-queue :fixed-capacity 10 :initial-contents '(3 4 5)))) (is (= 3 (pop-queue q))) (is (= 4 (pop-queue q))) (is (= 5 (pop-queue q))) (is (queue-empty-p q))) (let ((q (make-queue :fixed-capacity 3 :initial-contents #(3 4 5)))) (is (queue-full-p q)) (is (= 3 (pop-queue q))) (is (= 4 (pop-queue q))) (is (= 5 (pop-queue q))) (is (queue-empty-p q))) (let ((q (make-queue :fixed-capacity 2 :initial-contents #(3 4 5)))) (is (queue-full-p q)) (is (= 3 (pop-queue q))) (is (= 4 (pop-queue q))) (is (queue-empty-p q)))) #-lparallel.without-bordeaux-threads-condition-wait-timeout (base-test queue-timeout-test (dolist (q (list (make-queue) (make-queue :fixed-capacity 10))) (multiple-value-bind (a b) (try-pop-queue q :timeout nil) (is (null a)) (is (null b))) (multiple-value-bind (a b) (try-pop-queue q :timeout 0) (is (null a)) (is (null b))) (multiple-value-bind (a b) (try-pop-queue q :timeout -999999) (is (null a)) (is (null b))) (multiple-value-bind (a b) (try-pop-queue q :timeout 0.2) (is (null a)) (is (null b))) (signals type-error (try-pop-queue q :timeout "foo")) (let ((flag nil)) (with-thread () (sleep 0.4) (setf flag t)) (multiple-value-bind (a b) (try-pop-queue q :timeout 0.2) (is (null a)) (is (null b)) (is (queue-empty-p q)) (is (null flag)) (sleep 0.4) (is (eq t flag)))) (with-thread () (sleep 0.2) (push-queue 99 q)) (multiple-value-bind (a b) (try-pop-queue q :timeout 0.4) (is (= 99 a)) (is (identity b)) (is (queue-empty-p q))) (push-queue 3 q) (multiple-value-bind (a b) (try-pop-queue q :timeout -99999) (is (= 3 a)) (is (identity b))) (push-queue 4 q) (multiple-value-bind (a b) (try-pop-queue q :timeout 0) (is (= 4 a)) (is (identity b))) (push-queue 5 q) (multiple-value-bind (a b) (try-pop-queue q :timeout 0.2) (is (= 5 a)) (is (identity b))) (is (queue-empty-p q)))) #-lparallel.without-bordeaux-threads-condition-wait-timeout (base-test queue-small-timeout-test (dolist (q (list (make-queue) (make-queue :fixed-capacity 1))) (dolist (use-float-p '(nil t)) (loop for e from -3 downto -20 for timeout = (let ((value (expt 10 e))) (if use-float-p (float value) value)) do (repeat 10 (multiple-value-bind (a b) (try-pop-queue q :timeout timeout) (is (null a)) (is (null b)))))))) lparallel-20160825-git/test/thread-util-test.lisp000066400000000000000000000056231274371011200215670ustar00rootroot00000000000000;;; Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials provided ;;; with the distribution. ;;; ;;; * Neither the name of the project nor the names of its ;;; contributors may be used to endorse or promote products derived ;;; from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package #:lparallel-test) (base-test basic-threading-test (let ((num-threads 10) (num-objects 1000) (num-iterations 5) (from-workers (make-queue)) (to-workers (make-queue))) (repeat num-threads (with-thread () (loop (let ((object (pop-queue to-workers))) (if object (push-queue object from-workers) (return)))))) (repeat num-iterations (repeat num-objects (push-queue 99 to-workers)) (repeat num-objects (pop-queue from-workers))) (repeat num-threads (push-queue nil to-workers)) (sleep 0.5) (is (= 0 (queue-count from-workers))) (is (= 0 (queue-count to-workers))))) (base-test thread-bindings-test (setf *memo* :main) (with-thread () (setf *memo* :child)) (sleep 0.2) (is (eq :child *memo*)) (setf *memo* :main) (with-thread (:bindings (list (cons '*memo* *memo*))) (setf *memo* :child)) (sleep 0.2) (is (eq :main *memo*))) #-lparallel.without-kill (base-test destroy-thread-cleanup-test (let* ((cleanedp nil) (thread (with-thread () (unwind-protect (sleep 999999) (setf cleanedp t))))) (sleep 0.2) (destroy-thread thread) (sleep 0.2) (is (eq t cleanedp))))