├── Screenshot_20210621_205249.png ├── .gitignore ├── clj-con-test.asd ├── package.lisp ├── clj-con.asd ├── LICENSE ├── atom.lisp ├── clj-con-test.lisp ├── README.md └── clj-con.lisp /Screenshot_20210621_205249.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dtenny/clj-con/HEAD/Screenshot_20210621_205249.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.FASL 2 | *.fasl 3 | *.lisp-temp 4 | *.dfsl 5 | *.pfsl 6 | *.d64fsl 7 | *.p64fsl 8 | *.lx64fsl 9 | *.lx32fsl 10 | *.dx64fsl 11 | *.dx32fsl 12 | *.fx64fsl 13 | *.fx32fsl 14 | *.sx64fsl 15 | *.sx32fsl 16 | *.wx64fsl 17 | *.wx32fsl 18 | *.*~ 19 | -------------------------------------------------------------------------------- /clj-con-test.asd: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :clj-con-test-asd 4 | (:use :cl :asdf)) 5 | 6 | (in-package :clj-con-test-asd) 7 | 8 | (defsystem :clj-con-test 9 | :version "0.1.0" 10 | :license "MIT" 11 | :author "Dave Tenny" 12 | :description "Tests for the :clj-con package." 13 | :depends-on (:clj-con :fiveam) 14 | :components ((:file "clj-con-test"))) 15 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :clj-con 4 | (:use :cl) 5 | (:shadow atom) 6 | 7 | (:export 8 | 9 | ;; From clj-con.lisp 10 | #:deliver 11 | #:deref 12 | #:future 13 | #:future-call 14 | #:future-cancel 15 | #:future-cancelled? 16 | #:future-done? 17 | #:future? 18 | #:promise 19 | #:realized? 20 | 21 | ;; From atom.lisp 22 | #:atom 23 | #:atom? 24 | #:reset! 25 | #:reset-vals! 26 | #:swap! 27 | #:swap-vals! 28 | #:compare-and-set! 29 | ) 30 | 31 | (:documentation 32 | "Functions and macros that implement concurrency operations styled after 33 | Clojure operators such as `future` and `promise`. Note that timeouts in this 34 | module are also similar to those found in Clojure and/or the JVM and are 35 | expressed as millisecond values, even though Common Lisp normally specifies 36 | timeouts as seconds (or fractions thereof). 37 | ")) 38 | 39 | -------------------------------------------------------------------------------- /clj-con.asd: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :clj-con-asd 4 | (:use :cl :asdf)) 5 | 6 | (in-package :clj-con-asd) 7 | 8 | (eval-when (:compile-toplevel :load-toplevel :execute) 9 | ;; *TBD* Is there a way to do this without hard coding assumptions 10 | ;; about the atomics package support? Unfortunately, listing it 11 | ;; as an unconditional :depends-on signals an error on unsupported platforms. 12 | #+(or allegro ccl clasp ecl lispworks mezzano sbcl cmucl) 13 | (pushnew :clj-con-use-atomics *features*)) 14 | 15 | (defsystem :clj-con 16 | :version "1.0.0" 17 | :license "MIT" 18 | :author "Dave Tenny" 19 | :description "Clojure-style concurrency operations like `future`, `promise`, and `atom`." 20 | :bug-tracker "https://github.com/dtenny/clj-con/issues" 21 | :source-control (:git "https://github.com/dtenny/clj-con") 22 | :depends-on (:bordeaux-threads 23 | #+clj-con-use-atomics :atomics) 24 | :serial t 25 | :components ((:file "package") 26 | (:file "clj-con") 27 | (:file "atom"))) 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Jeffrey D. Tenny 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /atom.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clj-con) 2 | 3 | ;;;; Clojure-styled 'atoms' and related functions. 4 | ;;;; Metadata and validator-fn is not supported. 5 | 6 | ;;; SVREF is the only CAS place supported by all Atomics-supported lisps 7 | ;;; as of Dec-2023. So we use that. 8 | 9 | #-:atomics-cas-svref 10 | (defstruct (atom (:predicate atom?)) 11 | lock ;using locks, not compare-and-swap 12 | value) 13 | 14 | #+:atomics-cas-svref 15 | (defstruct (atom (:predicate atom?)) 16 | (cas-vector #(nil) :type (array t 1))) ;initval just for type conformance, unused 17 | 18 | (defun atom (&optional x) 19 | "Creates and returns an Atom with an initial value of x. 20 | Does not support validator and metadata arguments of the Clojure equivalent." 21 | #+:atomics-cas-svref 22 | (make-atom :cas-vector (make-array 1 :initial-element x)) 23 | #-:atomics-cas-svref 24 | (make-atom :lock (bt2:make-lock) :value x)) 25 | 26 | (defmethod deref ((atom atom) &optional timeout-ms timeout-val) 27 | (declare (ignore timeout-ms timeout-val)) 28 | #+:atomics-cas-svref 29 | (svref (atom-cas-vector atom) 0) 30 | #-:atomics-cas-svref 31 | (atom-value atom)) 32 | 33 | #-:atomics-cas-svref 34 | (defun reset! (atom newval) 35 | "Sets the value of atom to newval without regard for the 36 | current value. Returns newval." 37 | (declare (type atom atom)) 38 | (bt2:with-lock-held ((atom-lock atom)) 39 | (setf (atom-value atom) newval))) 40 | 41 | #+:atomics-cas-svref 42 | (defun reset! (atom newval) 43 | "Sets the value of atom to newval without regard for the 44 | current value. Returns newval." 45 | (declare (type atom atom)) 46 | (let ((v (atom-cas-vector atom))) 47 | (atomics:atomic-update (svref v 0) (constantly newval))) 48 | newval) 49 | 50 | (defun reset-vals! (atom newval) 51 | "Sets the value of atom to newval. 52 | Returns the value of the atom before and after the reset as multiple values. 53 | (Note difference from Clojure which does not have multiple value returns)." 54 | (declare (type atom atom)) 55 | #-:atomics-cas-svref 56 | (bt2:with-lock-held ((atom-lock atom)) 57 | (let ((oldval (atom-value atom))) 58 | (setf (atom-value atom) newval) 59 | (values oldval newval))) 60 | #+:atomics-cas-svref 61 | (let ((v (atom-cas-vector atom))) 62 | (loop with swapped-p = nil 63 | until swapped-p 64 | as oldval = (svref v 0) 65 | do (setf swapped-p (atomics:cas (svref v 0) oldval newval)) 66 | finally (return (values oldval newval))))) 67 | 68 | (defun swap! (atom f &rest args) 69 | "Atomically swaps the value of atom to be: 70 | (apply f current-value-of-atom args). Note that f may be called 71 | multiple times, and thus should be free of side effects. Returns 72 | the value that was swapped in." 73 | (declare (type atom atom)) 74 | #-:atomics-cas-svref 75 | (bt2:with-lock-held ((atom-lock atom)) 76 | (setf (atom-value atom) 77 | (apply f (atom-value atom) args))) 78 | #+:atomics-cas-svref 79 | (let ((v (atom-cas-vector atom)) 80 | (new nil)) 81 | (flet ((updater (old-val) 82 | (setf new (apply f old-val args)))) 83 | (atomics:atomic-update (svref v 0) #'updater) 84 | new))) 85 | 86 | (defun swap-vals! (atom f &rest args) 87 | "Atomically swaps the value of atom to be: 88 | (apply f current-value-of-atom args). Note that f may be called 89 | multiple times, and thus should be free of side effects. Returns un-Clojure-y 90 | multiple values `(old new)`, the value of the atom before and after the swap." 91 | (declare (type atom atom)) 92 | #-:atomics-cas-svref 93 | (bt2:with-lock-held ((atom-lock atom)) 94 | (let* ((oldval (atom-value atom)) 95 | (newval (apply f oldval args))) 96 | (setf (atom-value atom) newval) 97 | (values oldval newval))) 98 | #+:atomics-cas-svref 99 | (let ((v (atom-cas-vector atom)) 100 | (old nil) 101 | (new nil)) 102 | (flet ((updater (old-val) 103 | (setf old old-val) 104 | (setf new (apply f old-val args)))) 105 | (atomics:atomic-update (svref v 0) #'updater) 106 | (values old new)))) 107 | 108 | (defun compare-and-set! (atom oldval newval) 109 | "Atomically sets the value of atom to newval if and only if the 110 | current value of the atom is identical (EQ) to oldval. 111 | Returns non-NIL if the set happened, NIL if it did not." 112 | (declare (type atom atom)) 113 | #-:atomics-cas-svref 114 | (bt2:with-lock-held ((atom-lock atom)) 115 | (when (eq (atom-value atom) oldval) 116 | (setf (atom-value atom) newval) 117 | t)) 118 | #+:atomics-cas-svref 119 | (let ((v (atom-cas-vector atom))) 120 | (atomics:cas (svref v 0) oldval newval))) 121 | 122 | -------------------------------------------------------------------------------- /clj-con-test.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :clj-con-test 4 | (:use :cl :bt2 :clj-con :fiveam) 5 | (:shadowing-import-from #:clj-con #:atom) 6 | (:export #:run-tests) 7 | (:documentation "Tests for the :clj-con package.")) 8 | 9 | (in-package :clj-con-test) 10 | 11 | (def-suite test-suite :description ":clj-con tests") 12 | (in-suite test-suite) 13 | 14 | (test promise-delivery 15 | "Test promise delivery" 16 | (let ((p (promise)) 17 | (result "Hello World")) 18 | (is (eq p (deliver p result))) 19 | (is (realized? p)) 20 | (is (string= result (deref p))) 21 | (is (null (deliver p result))))) 22 | 23 | (test no-timeout-waits 24 | (let* ((p (promise)) 25 | (f1 (future (deref p))) 26 | (f2 (future (deref p)))) 27 | (deliver p 123) 28 | (is (= 123 (deref f1))) 29 | (is (= 123 (deref f2))))) 30 | 31 | (test timeouts 32 | (let* ((p (promise)) 33 | (f1 (future (deref p)))) 34 | (is (= 666 (deref p 10 666))) ;V1.0.0 hangs in ABCL 1.9.0 35 | (is (not (realized? p))) 36 | (is (not (realized? f1))) 37 | (is (= 667 (deref f1 10 667))) 38 | (is (not (realized? f1))) 39 | (deliver p t) 40 | (is (eq t (deref p 10 nil))) 41 | ;; Just because we've delivered the value does NOT mean the future 42 | ;; completed and delivered to its own result promise. 43 | ;; We could easily get the timeout value here. Allegro was pretty 44 | ;; consistent about revealing my previously flawed assumption here. 45 | ;; Hopefully 1000 msecs is enough for it to complete. Allegro has a funny 46 | ;; sense of sleep too, it may be a NO-OP for <= 75 msecs, I'm not sure. 47 | ;; https://franz.com/support/documentation/11.0/multiprocessing.html#90-clsleep-and-minimum-sleeping-time 48 | ;; 1000 ms should not timeout given that we've already delivered to the promise 49 | ;; blocking the future. If we must we could have the future set 50 | ;; another variable synchronization+test purposes. 51 | (is (eq t (deref f1 1000 nil))))) 52 | 53 | (defun running-future () 54 | "Return a future that is running long enough to do tests (or cancellations) on it." 55 | (let* ((p (promise)) 56 | (f (future (deliver p :started) (sleep 123)))) 57 | (is (eql :started (deref p))) 58 | f)) 59 | 60 | (defun completed-future () 61 | "Return a future that has completed." 62 | (let ((f (future t))) 63 | (deref f) 64 | f)) 65 | 66 | (defun cancelled-future () 67 | (let* ((p (promise)) 68 | (f (future (deliver p :started) (sleep 123)))) 69 | (is (eql :started (deref p))) 70 | (is (eql t (future-cancel f))) 71 | f)) 72 | 73 | (defun thrown-future () 74 | "Return a future that unwound abnormally." 75 | (let ((f (future (error "unwinding")))) 76 | (signals clj-con::execution-exception ; requires 5am test context 77 | (eql :x (deref f 10000 :x))) ; deref on unwound future will signal condition 78 | f)) 79 | 80 | ;;; 81 | ;;; Here we test the matrix in clj-con.lisp for behavior of futures in various states. 82 | ;;; 83 | 84 | (test future-cancel 85 | (is (eql t (future-cancel (running-future)))) 86 | (is (eql nil (future-cancel (completed-future)))) 87 | (is (eql nil (future-cancel (cancelled-future)))) 88 | (is (eql nil (future-cancel (thrown-future))))) 89 | 90 | (test future-cancelled? 91 | (is (eql nil (future-cancelled? (running-future)))) 92 | (is (eql nil (future-cancelled? (completed-future)))) 93 | (is (eql t (future-cancelled? (cancelled-future)))) 94 | (is (eql nil (future-cancelled? (thrown-future))))) 95 | 96 | (test realized? 97 | (is (eql nil (realized? (running-future)))) 98 | (is (eql t (realized? (completed-future)))) 99 | (is (eql t (realized? (cancelled-future)))) 100 | (is (eql t (realized? (thrown-future))))) 101 | 102 | (test future-done? 103 | (is (eql nil (realized? (running-future)))) 104 | (is (eql t (realized? (completed-future)))) 105 | (is (eql t (realized? (cancelled-future)))) 106 | (is (eql t (realized? (thrown-future))))) 107 | 108 | (test future-deref 109 | (is (eql :x (deref (running-future) 10 :x))) 110 | (is (eql t (deref (completed-future)))) 111 | (signals clj-con::cancellation-exception (deref (cancelled-future))) 112 | (signals clj-con::execution-exception (deref (thrown-future)))) 113 | 114 | (test atoms 115 | (let ((a (atom 0))) 116 | (is (eql nil (reset! a nil))) 117 | (is (eql nil (deref a))) 118 | (is (equal '(nil 1) (multiple-value-list (reset-vals! a 1)))) 119 | (is (equal '(1 2) (multiple-value-list (swap-vals! a #'1+))))) 120 | 121 | (let ((a (atom 0)) 122 | (b (atom ()))) 123 | (is (atom? a)) 124 | (is (= 0 (deref a))) 125 | (let ((f1 (future 126 | (loop repeat 20 127 | as x = (swap! a #'1+) 128 | do (swap! b (lambda (old) (cons x old)))) 129 | 123)) 130 | (f2 (future 131 | (loop repeat 20 132 | as x = (swap! a #'1+) 133 | do (swap! b (lambda (old) (cons x old)))) 134 | 456))) 135 | ;; Some extra diagnostics for sporadic failures, now fixed. 136 | (let ((result (deref f1 10000 nil))) 137 | (unless (eql 123 result) 138 | (format t "~%Oops: ~s != 123: ~s~%" result f1)) 139 | (is (eql 123 result))) 140 | (let ((result (deref f2 10000 nil))) 141 | (unless (eql 456 result) 142 | (format t "~%Oops: ~s != 456: ~s~%" result f2)) 143 | (is (eql 456 result))) 144 | (is (= 40 (deref a))) 145 | (let ((expected (loop for x from 40 downto 1 collecting x)) 146 | (actual (deref b))) 147 | (is (null (set-exclusive-or expected actual))))))) 148 | 149 | (test future-chain 150 | ;; Each future waiting on promises bound by another thread. 151 | ;; Delivering to one promise creates a domino effect. 152 | (let* ((n 20) 153 | (promises (loop repeat (+ n 1) collect (promise))) 154 | (futures (make-array n :initial-element nil))) 155 | ;; CAUTION closing over bindings for mutable data (i.e. 'i'), 156 | (dotimes (i2 n) 157 | (let ((i i2)) ;bind i2 to a non-mutating value 158 | (setf (aref futures i) 159 | (future 160 | ;; future[i] => (range i n) inclusive 161 | (let ((result (cons i (deref (elt promises (+ i 1)))))) 162 | (deliver (elt promises i) result) 163 | result))))) 164 | (is (every (complement #'future-done?) futures)) 165 | (is (every (complement #'realized?) futures)) 166 | (is (every (complement #'realized?) promises)) 167 | (deliver (elt promises n) (list n)) 168 | (let ((expected (loop for i upto n collect i)) ;(0 1 2 3 ... 20) 169 | (future-vals (map 'list #'deref futures))) 170 | (is (equalp expected (deref (elt promises 0)))) 171 | (is (every #'realized? promises)) 172 | (is (every #'future-done? futures)) 173 | (is (every #'realized? futures)) 174 | (loop for val in future-vals 175 | for i from 0 176 | do (is (equalp val (nthcdr i expected)) 177 | "Future ~d value ~s was not equalp ~s" 178 | i val (nthcdr i expected)))))) 179 | 180 | (defun run-tests () 181 | "Run all :clj-con tests. 182 | (dotimes (i 30) (debug! 'test-suite)) (or larger iteration values) 183 | can also be useful when debugging sporadic bugs." 184 | (let ((n 50)) 185 | (when (explain! (run 'test-suite)) 186 | (format t "First run of tests passed, running ~d more in silent mode.~%" n) 187 | (let ((failures 0) 188 | (*print-names* nil)) 189 | (dotimes (i n) 190 | (unless (run-all-tests :summary nil) 191 | (incf failures))) 192 | (format t "~%Test suite run ~d times, ~d test suite failure~:P.~%" 193 | n failures))))) 194 | 195 | 196 | ;; Test what happens if we call future-cancel on a pending wait/lock? 197 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # About 2 | 3 | `clj-con` defines a set of concurrency operations modeled after their Clojure 4 | counterparts. Sample operators include `future`, `promise`, `deref`, 5 | `deliver`, and `atom`. See the exported symbols in package.lisp for the full list. 6 | 7 | Or, if you're familiar with the Clojure Cheatsheet, the project implements the following: 8 | 9 | ![Cheatsheet Screenshot](https://github.com/dtenny/clj-con/blob/main/Screenshot_20210621_205249.png?raw=true) 10 | 11 | along with `promise` and `deliver`. 12 | 13 | ## Usage 14 | 15 | Mar-03-2024: Added to Ultralisp because quicklisp hasn't been updated in 5 16 | months and there are updates I really wanted to get out. 17 | 18 | If you didn't get this via quickload using a quicklisp/ultralisp repo, add it to 19 | your `~/quicklisp/localprojects/` directory and update/wipe the 20 | `system-index.txt` file accordingly, and then you can quickload it. 21 | 22 | ;; See 'local-projects' note in preceding paragraph 23 | (ql:quickload :clj-con) ; to use the code 24 | 25 | or 26 | 27 | ;; To run the tests 28 | (ql:quickload :clj-con-test) 29 | (clj-con-test:run-tests) 30 | 31 | ## Supported Lisps 32 | 33 | This package will wishfully run on any lisp supporting `bordeaux-threads`, 34 | which is most of them. 35 | 36 | Lisps supporting the `atomics` package will use `compare-and-swap` behavior 37 | via `atomics:cas` for the `atom` implementation. At the time 38 | of this writing (DEC 2023), that includes: 39 | 40 | - Allegro 41 | - CCL 42 | - ECL 43 | - LispWorks 44 | - Mezzano 45 | - SBCL 46 | - CMUCL 47 | - CLASP (*) 48 | 49 | *CLASP isn't on the atomics README but does seem to be supported in the code. 50 | 51 | If the atomics-provided `:atomics-cas-svref` isn't in `*features*` then the 52 | implementation defaults to a locking behavior to emulate compare-and-swap 53 | in the various `atom` functions that require it. 54 | 55 | ## Tested Lisps 56 | 57 | Here are my experiences so far with Fedora 38 running on an Intel machine 58 | and tests run on some of the lisps. Note that I am primarily an SBCL user 59 | and am not particularly familiar with the other lisps, their heap 60 | configurations, or even how to debug them since I didn't bother to enable 61 | them for SLIME, I just ran them from the command line. 62 | 63 | All tests were run with default memory configurations. I have no explanation 64 | for why some of them seem to be running out of memory, though some may be 65 | running with overly conservative heap sizes by default. 66 | The test suite allocates fewer than 50 threads, but the CLJ-CON package 67 | does expect threads to be (eventually) reclaimed when the lisp code running 68 | on them returns. 69 | 70 | Given that the test suite does deliberately signal conditions in the bodies 71 | of many thread tests I suppose it's possible threads are hung and locks 72 | are not being released. There are caveats about unpredicable unwind 73 | behavior w.r.t. locks in some of the tools used. 74 | 75 | All locking is done via `bt2:with-lock-held`. If you want lisps that seem 76 | to keep chugging along even with many allocations, look for the ones I've 77 | labelled "GOOD". 78 | 79 | - SBCL GOOD 80 | 81 | RUN-TESTS passes. 82 | `(dotimes (i 1000) (debug! 'test-suite))` passes. 83 | 84 | - CCL GOOD 85 | 86 | RUN-TESTS passes. 87 | `(dotimes (i 1000) (debug! 'test-suite))` passes. 88 | 89 | The test seemed to slow a bit toward the end of the 1000 iterations, as 90 | if perhaps a lot of gc activity were happening, but it did finish. 91 | 92 | - ABCL 1.9.0, OpenJDK 17.0.9 GOOD (No CAS) 93 | 94 | RUN-TESTS passes. 95 | `(dotimes (i 1000) (debug! 'test-suite))` passes. 96 | 97 | This now works but required special timeout logic because 98 | BT2:CONDITION-WAIT _always_ returns T on ABCL. Unfortunatey the logic 99 | which fixes ABCL breaks tests on CCL, and perhaps others. 100 | 101 | - LispWorks 8.0.1 Personal Edition. UNRELIABLE 102 | 103 | RUN-TESTS passes. 104 | `(dotimes (i 1000) (debug! 'test-suite))` runs out of memory. 105 | Lots of messages on the console "Hanging Unknown thread 5612" 106 | 107 | On a personal note. No init file with personal edition. Really? 108 | 109 | - Allegro CL Express 11.0 (`alisp` executable) UNRELIABLE 110 | 111 | RUN-TESTS passes. 112 | `(dotimes (i 1000) (debug! 'test-suite))` gets the following 113 | error after a number of iterations: 114 | 115 | Running test suite TEST-SUITE 116 | Running test PROMISE-DELIVERY .... 117 | Running test NO-TIMEOUT-WAITS Allegro CL(pid 1082089): System Error (gsgc) Object already pointing to target newspace half: 0x1000c8a1a68 118 | The internal data structures in the running Lisp image have been 119 | corrupted and execution cannot continue. Check all foreign functions 120 | and any Lisp code that was compiled with high speed and/or low safety, 121 | as these are two common sources of this failure. If you cannot find 122 | anything incorrect in your code you should contact technical support 123 | for Allegro Common Lisp, and we will try to help determine whether 124 | this is a coding error or an internal bug. 125 | 126 | The message suggests a gc bug, but maybe that's just a symptom of running 127 | out of memory. 128 | 129 | - ECL 21.2.1 UNRELIABLE 130 | 131 | Works for the minimal (run once) `clj-con-test:run-tests` case, but 132 | runs out of memory if the test suite is run repeatedly. 133 | 134 | 135 | ## V1.0.0, possible breaking changes 136 | 137 | 1. `compare-and-set!` now returns NIL and non-NIL, instead of 138 | strict NIL and T values. 139 | 2. `deliver` no longer returns the value delivered, it returns the input promise 140 | or nil according to clojure semantics, see the doc string for `deliver`. 141 | 142 | ## Changelog 143 | 144 | ### v1.0.0 145 | 146 | #### Tested and fixed for multiple platforms. 147 | 148 | See "Tested Lisps" above. 149 | 150 | #### Add support for compare-and-swap 151 | 152 | Added conditional use of the `atomics` package for a real compare-and-swap 153 | behavior in the `atom` implementation. 154 | 155 | #### Eliminate use of recursive locks used with condition-variables (ECL fix) 156 | 157 | Recent testing with ECL found that ECL doesn't like condition broadcasts with 158 | recursive locks. The recursive locks were changed to non-recursive locks, 159 | hopefully without loss of functionality or introduction of bugs. 160 | 161 | #### Migration to Bordeaux-Threads APIV2 162 | 163 | The motiviation was to use `CONDITION-BROADCAST` which is not in APIV1 164 | and was forcing CLJ-CON code to loop on `CONDITION-NOTIFY`. 165 | 166 | ### v0.1.0 - initial bordeaux-threads implementation 167 | 168 | Only tested with SBCL and ABCL, known to be broken on ECL. 169 | 170 | ## Differences from Clojure 171 | 172 | ### Uses of multiple value return 173 | 174 | `reset-vals!` and `swap-vals!` return vectors in Clojure but return 175 | multiple values here. I couldn't see the point of returning vectors when CL 176 | has no destructuring bind that works on vectors. At least you can use 177 | multiple-value-bind if you want, though it doesn't destructure either. 178 | 179 | Tip: [metabang-bind](https://github.com/hraban/metabang-bind) (available in 180 | quicklisp) provides a nice destructuring tool that also handles multiple 181 | values. 182 | 183 | ### Character/number EQ is not identical to Java's `==` used by Clojure 184 | 185 | YMMV if you use the atomics-enabled `compare-and-swap` behavior on Common 186 | Lisp characters and numbers, because it uses `EQ` semantics, not `EQL`, and 187 | EQ is not necessarily true for numbers and characters. 188 | 189 | In SBCL, fixnums are usually EQ, and `(eq #\a #\a)` will likely return 190 | true, but have a care. 191 | 192 | ## `atom` package conflict 193 | 194 | If you're going to `(use :clj-con)` note that `atom` requires a 195 | `(:shadowing-import-from #:clj-con #:atom)`. 196 | 197 | ## Use of `interrupt-thread` by `future-cancel` 198 | 199 | The Java Virtual Machine's threading tools are really a marvelous thing. If 200 | you've been in that ecosystem a long time, going back to pthreads with some of 201 | its limitations (or lisp oddities built on them), will feel fragile, and 202 | reading the various SBCL source comments on `interrupt-thread` doesn't do much 203 | to prevent that feeling. 204 | 205 | The test suite does test `future-cancel` and other ways of unwinding the 206 | thread stack, and seems to work on all tested platforms. But it may still be a 207 | source of bugs, such as the memory problems noted on some lisps. 208 | 209 | Have a care if you are repeatedly interrupting threads or using complicated mission 210 | critical handlers in the threads unless you have taken to heart the use of 211 | SBCL's WITHOUT-INTERRUPTS and other appropriate implementation dependent 212 | tools. I didn't hit any problems with my simple tests but that isn't saying 213 | much. 214 | 215 | ## Non-Goals 216 | 217 | There is no attempt here to bring clojure syntax or persistent data structures to 218 | Common Lisp. Fortunately neither of those things is particularly prevalent in 219 | Clojure's concurrency operator model, at least not in the clojure.core 220 | namespace. 221 | 222 | Some enterprising person might want to make a readtable that maps `@` to 223 | `deref`, assuming it doesn't conflict with `,@`, but that hasn't been done 224 | here so you'll just have to call `deref`. 225 | 226 | ## Blocking Queues? 227 | 228 | If you're missing clojure.core.async and want some blocking queues for producer/consumer 229 | situations, take a look at the `lparallel.queue` package `(ql:quickload 230 | :lparallel)`. Unlike clojure.core.async it has a `peek` operator which I find useful 231 | when I need to speculatively try something on a queue element without losing FIFO ordering. 232 | 233 | The Atomics maintainers were considering adding some queue capabilities in 234 | 2023, so you may wish to check there as well. It isn't in the quicklisp 235 | distribution as of June 2023 though. 236 | 237 | ## Cautionary note for Clojure devs new to Common Lisp 238 | 239 | I recommend reading documentation on the bordeaux-threads 240 | [make-thread](https://sionescu.github.io/bordeaux-threads/threads/make-thread/) 241 | function for cautions about interactions between threads and dynamic variables. 242 | 243 | You also need to mentally prepare yourself for how values you've closed 244 | over in the body of your `future` can mutate. Consider this example: 245 | 246 | (dotimes (i 20) 247 | (future ... (print i) ...)) 248 | 249 | You may be expecting the first value of `i` printed by the first future created 250 | would be zero because dotimes starts at zero. However depending on your lisp 251 | implementation it may actually print one, or some other value, depending on 252 | time of evaluation and whether the reference to the location/register 253 | holding 'i' has been incremented or not by the time the future body is 254 | executed on the new thread. 255 | 256 | The `clj-con-test` package has a test case where this exact issue was encountered on 257 | SBCL, and the workaround was to use something like this: 258 | 259 | (dotimes (i 20) 260 | (let ((i2 i)) ;of course I could have rebound 'i' as well 261 | (future ... (print i2) ...))) 262 | 263 | This way the future is referencing a binding that won't change. 264 | 265 | Binding semantics such as the above may vary by lisp implementation and has 266 | nothing to do with parallelism. E.g., you _might_ get this: 267 | 268 | (let ((funs nil)) 269 | (dotimes (i 3) (push (lambda () i) funs)) 270 | (dotimes (j 3) (print (funcall (elt funs j))))) 271 | 3 272 | 3 273 | 3 274 | 275 | The behavior is related to closing over bindings for mutable data. 276 | The CL spec for [dotimes](http://clhs.lisp.se/Body/m_dotime.htm) says this: 277 | 278 | "It is implementation-dependent whether dotimes establishes a new binding 279 | of var on each iteration or whether it establishes a binding for var once 280 | at the beginning and then assigns it on any subsequent iterations." 281 | 282 | When in doubt, add a binding that won't change for use in your closed over 283 | `future` (or other) bodies. 284 | 285 | ## Feedback welcome 286 | 287 | `(reverse "moc.liamg@ynnet.evad")` 288 | 289 | This is a secondary address that isn't monitored every day. 290 | Feel free to submit Github issues if appropriate. 291 | -------------------------------------------------------------------------------- /clj-con.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clj-con) 2 | 3 | ;;; Assumption: threads that have exited are reclaimed by GC. (Correct?) 4 | 5 | ;;; Behavior of futures with respect to the following functions and future states. 6 | ;;; 7 | ;;; Operation | Active | Success | Cancelled (by future-cancel) | Throws 8 | ;;; ------------------------------------------------------------------------------------------ 9 | ;;; deref blocks value Throws CancellationException Throws ExecutionException 10 | ;;; realized? false true true (*) true (*) 11 | ;;; future-done? false true true true 12 | ;;; future-cancel true false false false 13 | ;;; future-cancelled? false false true false 14 | ;;; 15 | ;;; (*) The behavior for realized? seems off because realized? being true suggest you can 16 | ;;; get a value, which you cannot. The doc string for realized? "a value has been produced". 17 | ;;; Maybe it should instead say "the future will not block". 18 | ;;; 19 | ;;; Behavior implemented matches the above clojure behaviors 20 | ;;; (with conditions rather than exceptions), and T/NIL instead of true/false. 21 | 22 | ;;; CAUTION: Note that the bordeaux-threads `condition-wait` semantics differ 23 | ;;; from SBCL's `sb-thread:condition-wait` semantics. 24 | ;;; - SBCL's will not re-aquire the lock when it returns nil. 25 | ;;; - BT _will_ re-aquire the lock when it return nil. 26 | 27 | (defstruct promise 28 | "A promise object as created by the `promise` function." 29 | condition-variable ;nil when realized 30 | lock 31 | value) ;== cv until realized 32 | 33 | (defmethod print-object ((promise promise) stream) 34 | (print-unreadable-object (promise stream :type t :identity t) 35 | ;; Using `promise-realized?` here without a lock, contrary to other code. 36 | (format stream "~S" (promise-realized? promise)))) 37 | 38 | (defstruct (future (:predicate future?)) 39 | "A future object returned by the `future` macro." 40 | thread ;thread executing the function 41 | lock ;synchronized future state mgmt 42 | 43 | ;; :ready if not started or executing 44 | ;; :success if the future will have meaningful value 45 | ;; :unwound if the future had an unhandled condition. 46 | ;; :cancelled if the future was successfully cancelled with `future-cancel`. 47 | status 48 | 49 | ;; If :status isn't :success, then the promise may be delivered, but with the condition 50 | ;; that caused future failure. 51 | promise ;promise notified with function result 52 | ) 53 | 54 | (defmethod print-object ((future future) stream) 55 | (print-unreadable-object (future stream :type t :identity t) 56 | (format stream "~S" (future-status future)))) 57 | 58 | (define-condition thread-interrupted () () 59 | (:documentation 60 | "The thread-interrupted condition is signalled in `future` threads when `future-cancel` is called.")) 61 | 62 | (define-condition cancellation-exception (error) () 63 | (:report (lambda (condition stream) 64 | (declare (ignore condition)) 65 | (format stream "Invalid attempt to obtain a future value, via `deref`, on a cancelled future."))) 66 | (:documentation 67 | "Signalled by deref (in the calling thread) when a a `future` thread was cancelled. 68 | Named for similarity to clojure/java behavior on deref.")) 69 | 70 | (define-condition execution-exception (error) () 71 | (:report (lambda (condition stream) 72 | (declare (ignore condition)) 73 | (format stream "Invalid attempt to obtain a future value, via `deref`, on an abnormally unwound future."))) 74 | (:documentation 75 | "Signalled by deref (in the calling thread) when a `future` thread unwound its stack with an unhandled signal. 76 | Named for similarity to clojure/java behavior on deref.")) 77 | 78 | (defmacro with-future-lock (future &body body) 79 | "Execute body with the future locked." 80 | `(bt2:with-lock-held ((future-lock ,future)) 81 | ,@body)) 82 | 83 | (defun promise-realized? (p) 84 | "True if value has been supplied, caller must lock before calling." 85 | (not (eql (promise-value p) (promise-condition-variable p)))) 86 | 87 | (defun promise () 88 | "Returns a promise object that can be read with `deref` and set, 89 | once only, with `deliver`. Calls to deref prior to delivery will 90 | block unless the variant of deref with timeout is used. All 91 | subsequent derefs will return the same delivered value without 92 | blocking. See also - `realized?`." 93 | (let ((cv (bt2:make-condition-variable))) 94 | (make-promise 95 | :lock (bt2:make-lock) 96 | :value cv ; 97 | :condition-variable cv))) 98 | 99 | (defun deliver (promise val) 100 | "Delivers the supplied value to the promise, allowing the return of any blocked derefs. 101 | A subsequent call to deliver on a promise will have no effect. 102 | 103 | The first deliver call will return the promise. 104 | Subsequent calls to deliver return NIL. 105 | This is compatible with Clojure, though note that 106 | `(deliver p 123) (deliver p true)` in clojure causes a ClassCastException, 107 | whereas here the second call returns false." 108 | (declare (promise promise)) 109 | (bt2:with-lock-held ((promise-lock promise)) 110 | (if (eql (promise-value promise) (promise-condition-variable promise)) 111 | (progn 112 | (setf (promise-value promise) val) 113 | (let ((cvar (promise-condition-variable promise))) 114 | (setf (promise-condition-variable promise) nil) 115 | (bt2:condition-broadcast cvar)) 116 | promise) 117 | nil))) 118 | 119 | (defgeneric realized? (x) 120 | (:documentation "Returns true if a value has been produced for a promise or future, nil otherwise.") 121 | (:method ((f future)) 122 | (realized? (future-promise f))) 123 | (:method ((p promise)) 124 | (bt2:with-lock-held ((promise-lock p)) 125 | (promise-realized? p)))) 126 | 127 | (defgeneric deref (thing &optional timeout-ms timeout-val) 128 | ;;([ref] [ref timeout-ms timeout-val]) 129 | ;; Note that our call signature permits timeout-ms without timeout-val, unlike clojure 130 | (:documentation 131 | "Used on various objects to obtain a value from an asynchronous construct. 132 | 133 | When applied to an atom, yields the current value of the atom. 134 | 135 | When applied to a future, will block if computation not complete. 136 | If the future completed unsuccessfully, deref will signal either cancellation-exception 137 | or execution-exception depending on whether it was cancelled or unwound due to unhandled conditions. 138 | 139 | When applied to a promise, will block until a value is delivered. 140 | 141 | When called with timeout options (valid only for promises and futures), 142 | can be used for blocking and will return 143 | timeout-val if the timeout (in milliseconds) is reached before a 144 | value is available. See also - realized?. 145 | 146 | Note that a call to `deref` with a timeout the returns the timeout value 147 | does not force the promise/future to be `realized?`, it may remain unrealized. 148 | 149 | Note that if timeout-ms is supplied, timeout-val is also required, to maintain 150 | parity with Clojure's arity-1 and arity-3 (but no arity-2) calls.") 151 | 152 | (:method ((f future) &optional (timeout-ms nil timeout-supplied-p) 153 | (timeout-val nil timeout-val-supplied-p)) 154 | (when (and timeout-supplied-p (not timeout-val-supplied-p)) 155 | (error "TIMEOUT-VAL is required if TIMEOUT-MS is supplied")) 156 | (with-future-lock f 157 | (let ((s (future-status f))) 158 | (case s 159 | (:success (deref (future-promise f))) ; timeout data not needed 160 | ;; TBD: I have seen weasel words about lock release being unpredictable 161 | ;; when conditions are signalled. Not sure what to do yet. 162 | (:cancelled (error (make-condition 'cancellation-exception))) 163 | (:unwound (error (make-condition 'execution-exception))) 164 | ;; Still executing, release the future lock so it can post success 165 | ;; to the future. 166 | (t (unless (eq s :ready) 167 | (error "Unexpected future-status ~s in future ~s" s f)))))) 168 | ;; Future was still executing (in :ready state), wait on the promise 169 | (let ((v (if timeout-supplied-p 170 | (deref (future-promise f) timeout-ms timeout-val) 171 | (deref (future-promise f))))) 172 | ;; If we didn't timeout, the future _must_ have completed, because 173 | ;; deref on the promise without a timeout should not be spurious 174 | ;; (unlike the condition variable it uses under the hood). 175 | ;; However the future could still have encountered a condition 176 | ;; and so whatever the above deref gave us takes a back seat 177 | ;; if :cancelled or :unwound apply. This is consistent with clojure, see chart 178 | ;; at top of module. 179 | 180 | ;; Not locking here. If we get "ready" but it transitioned to success 181 | ;; while we're looking, we don't care. If we got the timeout value 182 | ;; before thread cancellation or unwinding, we return the timeout value 183 | (if (eql v timeout-val) 184 | v 185 | (let ((s (future-status f))) 186 | (case s 187 | (:ready (error "Unexpected status ~s in future ~s after promise deref." s f)) 188 | (:cancelled (error (make-condition 'cancellation-exception))) 189 | (:unwound (error (make-condition 'execution-exception))) 190 | (:success v) 191 | (t (error "Unexpected future-status ~s in future ~s" s f))))))) 192 | 193 | ;; Note that CL expects timeouts in terms of seconds, which may be real values 194 | ;; expressing fractions of seconds. That's true of `sleep` and also the condition 195 | ;; variable timeout specifications. 196 | (:method ((p promise) &optional (timeout-ms nil timeout-supplied-p) timeout-val) 197 | (let ((timeout-secs (and timeout-supplied-p (/ timeout-ms 1000))) 198 | (cv (promise-condition-variable p)) 199 | (lock (promise-lock p))) 200 | (when timeout-secs 201 | (assert (> timeout-secs 0))) 202 | (bt2:with-lock-held (lock) 203 | (loop until (promise-realized? p) 204 | do (unless (bt2:condition-wait cv lock :timeout timeout-secs) 205 | (return timeout-val)) ;NIL waitval == timeout 206 | ;; ABCL _always_ returns true on CONDITION-WAIT 207 | ;; Avoid infinite loop looking for NIL timeout value from wait 208 | ;; and try to provide deref timeout semantics. 209 | ;; Unfortunately, this breaks timeout tests on CCL and perhaps 210 | ;; others, so we are picky about when we enable it. 211 | #+ABCL 212 | (when timeout-secs 213 | (if (promise-realized? p) 214 | (return (promise-value p)) 215 | (return timeout-val))) 216 | finally (return (promise-value p))))))) 217 | 218 | (defun future-call (thunk) 219 | "Takes a function of no args and yields a future object that will 220 | invoke the function in another thread, and will cache the result and 221 | return it on all subsequent calls to deref. If the computation has 222 | not yet finished, calls to deref will block, unless the variant 223 | of deref with timeout is used. See also - realized?." 224 | (let* ((result-promise (promise)) 225 | (future (make-future :status :ready 226 | :promise result-promise 227 | :lock (bt2:make-lock))) 228 | (thread (bt2:make-thread 229 | (lambda () 230 | (handler-case (let ((result (funcall thunk))) 231 | ;; Want future lock to span future and 232 | ;; promize updates, so no `update-future-status` 233 | (with-future-lock future 234 | (setf (future-status future) :success) 235 | (deliver result-promise result))) 236 | (thread-interrupted (c) 237 | (declare (ignore c)) 238 | ;; Assuming the thread interrupt came only from 239 | ;; `future-cancel`, which may not be a good idea. TBD. 240 | 241 | ;; The cancelling thread already set the future status to 242 | ;; :cancelled. And delivered to promise since it was already 243 | ;; holding the lock. So the important thing is that we've 244 | ;; interrupted the thunk(?) and are about to return from the 245 | ;; thread. If assertion below fails, we may need to do this: 246 | ;; (deliver result-promise c) 247 | 248 | ;; If the future isn't in cancelled state, then 249 | ;; this interrupt was received from some source 250 | ;; other than future-cancel and we want to know about it. 251 | (assert (eql :cancelled (future-status future)))) 252 | (t (condition) 253 | (assert condition) 254 | ;; future lock to span future _and_ promise updates 255 | (with-future-lock future 256 | (setf (future-status future) :unwound) 257 | (deliver result-promise condition)))))))) 258 | ;; Retaining this thread for debugging. Hopefully not a GC issue 259 | ;; We shouldn't actually *need* the thread attached to the future object 260 | ;; for anything other than debugging 261 | (setf (future-thread future) thread) 262 | future)) 263 | 264 | (defmacro future (&body body) 265 | "Takes a body of expressions and yields a future object that will 266 | invoke the body in another thread, and will cache the result and 267 | return it on all subsequent calls to deref. If the computation has 268 | not yet finished, calls to deref will block, unless the variant of 269 | deref with timeout is used. See also - realized?. 270 | 271 | Note that multiple-value returns are lost, only the first (assumed) value is returned." 272 | `(future-call (lambda () ,@body))) 273 | 274 | (defun future-cancel (future) 275 | "Cancels the future, if possible. 276 | Returns T if the cancellation request is successful, NIL if it is not. 277 | Note that interrupting threads in CL is not as tidy as clojure See SB-THREAD::INTERRUPT-THREAD. 278 | Unless threads are carefully using sb-sys:without-interrupts, 279 | their unwind handlers may not work right. Don't expect something as robust as the JVM's 280 | InterruptedException." 281 | (declare (future future)) 282 | (let ((old-status)) 283 | (with-future-lock future 284 | (setf old-status (future-status future)) 285 | ;; TODO? get our return code based on what the thread signal handler at top level 286 | (when (eql :ready old-status) 287 | (setf (future-status future) :cancelled) 288 | (deliver (future-promise future) (make-condition 'thread-interrupted)) 289 | (bt2:interrupt-thread (future-thread future) 290 | ;; sb-thread:return-from-thread? 291 | (lambda () (signal 'thread-interrupted))))) 292 | ;; `future-cancel` is successful only if we successfully cancelled the future. 293 | ;; If it was already cancelled or otherwise problematic, we didn't do that. 294 | (eql old-status :ready))) 295 | 296 | (defun future-cancelled? (future) 297 | "Return T if the future was explicitly (and successfully) cancelled, NIL otherwise." 298 | (declare (future future)) 299 | (eql :cancelled (with-future-lock future (future-status future)))) 300 | 301 | (defun future-done? (future) 302 | "Return T if future is done, NIL otherwise. 303 | It is 'done' if it is in any state other than :ready 304 | (thus hasn't started, or is executing the supplied forms)." 305 | (declare (future future)) 306 | ;; If I know more about what constituted safe/atomic/volatile operations in CL 307 | ;; I'd skip the lock. Right new CL & BT tool nuances are new to me. 308 | ;; I'm guessing an SBCL barrier would be enough, BT doesn't supply barriers. 309 | (not (eql :ready (with-future-lock future (future-status future))))) 310 | 311 | ;; *TBD*: what happens if we unwind when waiting on a condition varaible? 312 | ;; i.e. (future (deref p)) (future-cancel *) 313 | 314 | ;;; *TBD*: can we safely eliminate some locking used just for reads? 315 | --------------------------------------------------------------------------------