├── .distignore ├── .gitignore ├── LICENSE ├── README.md ├── cl-flow.asd ├── src ├── asynchronously.lisp ├── atomically.lisp ├── concurrently.lisp ├── context.lisp ├── dynamically.lisp ├── flow.lisp ├── packages.lisp ├── repeatedly.lisp ├── run.lisp ├── serially.lisp └── utils.lisp └── t ├── packages.lisp ├── pooled-dispatcher.lisp └── suite.lisp /.distignore: -------------------------------------------------------------------------------- 1 | ^\..* 2 | \/\..* -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # lisp junk 2 | *.FASL 3 | *.fasl 4 | *.lisp-temp 5 | 6 | # emacs junk 7 | \#* 8 | *~ 9 | .\#* 10 | 11 | # system dependent junk 12 | local/ 13 | 14 | # macOS crap 15 | **/.DS_Store -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Pavel Korolev 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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CL-FLOW 2 | 3 | Library for asynchonous non-blocking concurrency in Common Lisp. 4 | 5 | 6 | ## Documentation 7 | [Documentation](https://borodust.org/projects/cl-flow/) at [borodust.org](https://borodust.org) 8 | 9 | You can hear my lengthy-bad-english explanation of `cl-flow` operation in 10 | [Common Lisp Study Group: Concurrency in Common Lisp Part 11 | 2](https://youtu.be/nJ58pBCxdm8?t=548) video from `Atlanta Functional 12 | Programming` group. 13 | 14 | ## Tests 15 | 16 | ```lisp 17 | (ql:quickload :cl-flow/tests) 18 | (5am:run! :cl-flow-suite) 19 | ``` 20 | -------------------------------------------------------------------------------- /cl-flow.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem cl-flow 2 | :description "Data-flow driven concurrency model for Common Lisp" 3 | :version "1.0.0" 4 | :author "Pavel Korolev" 5 | :mailto "dev@borodust.org" 6 | :license "MIT" 7 | :depends-on (alexandria cl-muth) 8 | :serial t 9 | :pathname "src/" 10 | :components ((:file "packages") 11 | (:file "utils") 12 | (:file "context") 13 | (:file "flow") 14 | (:file "atomically") 15 | (:file "serially") 16 | (:file "concurrently") 17 | (:file "dynamically") 18 | (:file "asynchronously") 19 | (:file "repeatedly") 20 | (:file "run"))) 21 | 22 | 23 | (asdf:defsystem cl-flow/tests 24 | :description "Test suite for cl-flow" 25 | :version "1.0.0" 26 | :author "Pavel Korolev" 27 | :mailto "dev@borodust.org" 28 | :license "MIT" 29 | :depends-on (alexandria cl-flow fiveam cl-muth simple-flow-dispatcher) 30 | :pathname "t/" 31 | :serial t 32 | :components ((:file "packages") 33 | (:file "pooled-dispatcher") 34 | (:file "suite"))) 35 | -------------------------------------------------------------------------------- /src/asynchronously.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-flow) 2 | 3 | ;;; 4 | ;;; ASYNCHRONOUSLY 5 | ;;; 6 | (defun dispatch-asynchronously (flow-context body-fu) 7 | (funcall body-fu (flow-context-value flow-context))) 8 | 9 | 10 | (defun continue-flow (&optional value) 11 | "Invokes next flow block with provided value as an argument" 12 | (declare (ignore value)) 13 | (error "Function can be called inside asynchonous block only")) 14 | 15 | 16 | (defun interrupt-flow (&optional condition) 17 | "Interrupts flow with provided condition" 18 | (declare (ignore condition)) 19 | (error "Function can be called inside asynchonous block only")) 20 | 21 | 22 | (defmacro asynchronously (lambda-list &body body) 23 | "Splits current flow allowing manually managing its execution via #'continue-flow and 24 | #'interrupt-flow functions. Consing: ~32 bytes per invocation" 25 | (with-gensyms (continue-arg condi) 26 | (flow-lambda-macro (flow-context) 27 | (let ((fu-body `((flet ((continue-flow (&optional ,continue-arg) 28 | (capture-flow-value ,flow-context ,continue-arg) 29 | (dispatch-rest ,flow-context)) 30 | (interrupt-flow (&optional ,condi) 31 | (error ,condi))) 32 | (declare (ignorable (function continue-flow) 33 | (function interrupt-flow))) 34 | ,@body)))) 35 | (with-flow-function-macro (body-fu lambda-list fu-body) 36 | `(dispatch-asynchronously ,flow-context #',body-fu)))))) 37 | 38 | 39 | (defmacro %> (lambda-list &body body) 40 | "See flow:asynchronously" 41 | `(asynchronously ,lambda-list 42 | ,@body)) 43 | -------------------------------------------------------------------------------- /src/atomically.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-flow) 2 | 3 | 4 | ;;; 5 | ;;; ATOMICALLY 6 | ;;; 7 | (defun dispatch-atomically (context fu invariant 8 | &rest opts &key &allow-other-keys) 9 | (apply #'dispatch context fu invariant opts)) 10 | 11 | 12 | (defmacro atomically (invariant &body args) 13 | "Encloses atomic flow block of code that can be dispatched 14 | concurrently. Non-consing." 15 | (destructuring-bind (opts lambda-list body) (parse-atomic-block-args args) 16 | (flow-lambda-macro (flow-context) 17 | (with-flow-function-macro (body-fu lambda-list body) 18 | `(dispatch-atomically ,flow-context #',body-fu ,invariant ,@opts))))) 19 | 20 | 21 | (defmacro -> (invariant &body args) 22 | "See flow:atomically" 23 | `(atomically ,invariant ,@args)) 24 | -------------------------------------------------------------------------------- /src/concurrently.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-flow) 2 | 3 | 4 | ;;; 5 | ;;; CONCURRENTLY 6 | ;;; 7 | (defun %dispatch-concurrently (parent-context flow) 8 | (declare (type list flow) 9 | (type flow-context parent-context) 10 | #.+optimize-form+) 11 | (labels ((%leaf-count (tree) 12 | (loop for node in tree 13 | if (and node (listp node)) 14 | summing (%leaf-count node) into result 15 | else 16 | summing 1 into result 17 | finally (return result)))) 18 | (let* ((results (copy-tree flow)) 19 | (counter (mt:make-atomic-counter (%leaf-count results)))) 20 | (labels ((%countdown () 21 | (when (= (mt:decrement-atomic-counter counter) 0) 22 | (capture-flow-value parent-context results) 23 | (dispatch-rest parent-context))) 24 | (%make-context (child-flow cell) 25 | (flet ((%capture-result (child-context) 26 | (setf (car cell) (flow-context-value child-context)) 27 | (%countdown))) 28 | (let ((context (make-child-flow-context parent-context))) 29 | (push-flow-stack context #'%capture-result) 30 | (push-flow-stack context child-flow) 31 | context))) 32 | (%dispatch-flow (flow results) 33 | (loop for block in flow 34 | for cell on results 35 | if (listp block) 36 | do (if block 37 | (%dispatch-flow block (car cell)) 38 | (progn 39 | (setf (car cell) nil) 40 | (%countdown))) 41 | else 42 | do (dispatch-rest (%make-context block cell))))) 43 | (%dispatch-flow flow results))))) 44 | 45 | 46 | (defun dispatch-concurrently (parent-context flow) 47 | (declare (type list flow) 48 | (type flow-context parent-context) 49 | #.+optimize-form+) 50 | (if flow 51 | (%dispatch-concurrently parent-context flow) 52 | (dispatch-rest parent-context))) 53 | 54 | 55 | (defmacro concurrently (&body flow) 56 | "Executes child elements in parallel, returning a list of results for child 57 | blocks or flows in the same order they were specified. Heavy consing." 58 | (with-flow-let-macro (flow-list flow) 59 | (flow-lambda-macro (flow-context) 60 | `(dispatch-concurrently ,flow-context ,flow-list)))) 61 | 62 | 63 | (defmacro ~> (&rest body) 64 | "See flow:concurrently" 65 | `(concurrently ,@body)) 66 | -------------------------------------------------------------------------------- /src/context.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-flow) 2 | 3 | (defvar *current-context* nil) 4 | (defvar *continue* nil) 5 | (defvar *parent-context* nil) 6 | 7 | (define-constant +min-stack-extension+ 3) 8 | 9 | (defstruct flow-context 10 | (native-dispatcher nil 11 | :type (or null function) 12 | :read-only t) 13 | (dispatcher nil 14 | :type (or null function)) 15 | (value nil 16 | :type t) 17 | (function nil 18 | :type (or null function)) 19 | (stack (make-array +min-stack-extension+ :element-type 'list :initial-element nil 20 | :fill-pointer 0 :adjustable t) 21 | :type array 22 | :read-only t) 23 | (parent nil 24 | :type (or null flow-context) 25 | :read-only t)) 26 | 27 | 28 | (defun dispatch (context task invariant &rest args &key &allow-other-keys) 29 | (setf (flow-context-function context) task) 30 | (apply (flow-context-dispatcher context) invariant args)) 31 | 32 | 33 | (defun dispatch-rest (context) 34 | (declare (type flow-context context) 35 | #.+optimize-form+) 36 | (cond 37 | ((eq *current-context* context) (setf *continue* t)) 38 | ((eq *parent-context* context) 39 | ;; see catch in #'%dispatch-rest: 40 | ;; this is to unwind a stack 41 | ;; to avoid overflowing it 42 | ;; in case of single-threaded dispatch 43 | (throw *parent-context* t)) 44 | (t (%dispatch-rest context)))) 45 | 46 | 47 | (defun make-child-flow-context (parent-context) 48 | (init-context-dispatcher 49 | (make-flow-context :native-dispatcher (flow-context-native-dispatcher parent-context) 50 | :value (flow-context-value parent-context) 51 | :parent parent-context))) 52 | 53 | 54 | (defun %dispatch-rest (flow-context) 55 | (declare (type flow-context flow-context) 56 | #.+optimize-form+) 57 | (let ((*parent-context* *current-context*) 58 | (*current-context* flow-context) 59 | (*continue* nil)) 60 | (loop for block = (chop-head flow-context) 61 | do (setf *continue* nil) 62 | (when block 63 | (if (listp block) 64 | (progn 65 | (push-flow-stack flow-context block) 66 | (setf *continue* t)) 67 | (when (catch *current-context* 68 | (funcall block flow-context) 69 | nil) 70 | (setf *continue* t)))) 71 | while *continue*))) 72 | 73 | 74 | (defun capture-flow-value (context value) 75 | (setf (flow-context-value context) value)) 76 | 77 | 78 | (defun push-flow-stack (context flow) 79 | (vector-push-extend flow (flow-context-stack context) +min-stack-extension+)) 80 | 81 | 82 | (defun chop-head (context) 83 | (let ((stack (flow-context-stack context))) 84 | (symbol-macrolet ((current (aref stack (1- (length stack))))) 85 | (flet ((%chop-head () 86 | (let ((top current)) 87 | (if (listp top) 88 | (let ((head (first top)) 89 | (tail (rest top))) 90 | (prog1 head 91 | (if tail 92 | (setf current tail) 93 | (vector-pop stack)))) 94 | (vector-pop stack))))) 95 | (loop while (> (length stack) 0) 96 | thereis (%chop-head)))))) 97 | 98 | 99 | ;;; 100 | ;;; RESTARTS 101 | ;;; 102 | (defun try-restart (restart-name &optional (arg nil provided-p)) 103 | (if provided-p 104 | (invoke-restart restart-name arg) 105 | (invoke-restart restart-name))) 106 | 107 | 108 | (defun rerun-flow-block () 109 | (try-restart 'rerun-flow-block)) 110 | 111 | 112 | (defun skip-flow-block () 113 | (try-restart 'skip-flow-block)) 114 | 115 | 116 | (defun inject-flow (flow) 117 | (try-restart 'inject-flow flow)) 118 | 119 | 120 | (defun use-flow-block-value (value) 121 | (try-restart 'use-flow-block-value value)) 122 | 123 | 124 | (defun %%rerun-invoke () 125 | (throw 'begin (values nil t nil))) 126 | 127 | (defun %%rerun-invoke-text (stream) 128 | (format stream "Rerun current flow block")) 129 | 130 | (defun %%skip-invoke () 131 | (throw 'begin (values nil nil nil))) 132 | 133 | (defun %%skip-invoke-text (stream) 134 | (format stream "Skip flow block returning nil")) 135 | 136 | (defun %%use-invoke (value) 137 | (throw 'begin (values value nil nil))) 138 | 139 | (defun %%use-invoke-text (stream) 140 | (format stream "Skip flow block returning provided value")) 141 | 142 | (defun %%inject-invoke (flow) 143 | (throw 'begin (values nil nil flow))) 144 | 145 | (defun %%inject-invoke-text (stream) 146 | (format stream "Inject flow to run instead of current block")) 147 | 148 | (defun %invoke-with-restarts (fu arg) 149 | (declare (type (function (t) *) fu) 150 | #.+optimize-form+) 151 | ;; catch+restart-bind insead of tagbody+restart-case to avoid any consing 152 | (catch 'begin 153 | (restart-bind ((rerun-flow-block #'%%rerun-invoke 154 | :report-function #'%%rerun-invoke-text) 155 | (skip-flow-block #'%%skip-invoke 156 | :report-function #'%%skip-invoke-text) 157 | (use-flow-block-value #'%%use-invoke 158 | :report-function #'%%use-invoke-text) 159 | (inject-flow #'%%inject-invoke 160 | :report-function #'%%inject-invoke-text)) 161 | (values (funcall fu arg) nil nil)))) 162 | 163 | 164 | (defun invoke-with-restarts (flow-context fu arg) 165 | (declare (type (function (t) *) fu) 166 | #.+optimize-form+) 167 | ;; loop instead tagbody to avoid any consing 168 | (loop do (multiple-value-bind (result looping-p flow) 169 | (%invoke-with-restarts fu arg) 170 | (cond 171 | (flow (push-flow-stack flow-context flow) 172 | (dispatch-rest flow-context) 173 | (return)) 174 | ((not looping-p) (return result)))))) 175 | 176 | 177 | (defun invoke-flow-function (context) 178 | (capture-flow-value context (invoke-with-restarts context 179 | (flow-context-function context) 180 | (flow-context-value context))) 181 | (dispatch-rest context)) 182 | 183 | 184 | (defun init-context-dispatcher (context) 185 | (let ((dispatcher (flow-context-native-dispatcher context))) 186 | (labels ((%invoke () 187 | (invoke-flow-function context)) 188 | (%dispatcher (invariant &rest args &key &allow-other-keys) 189 | (apply dispatcher #'%invoke invariant args))) 190 | (setf (flow-context-dispatcher context) #'%dispatcher))) 191 | context) 192 | -------------------------------------------------------------------------------- /src/dynamically.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-flow) 2 | 3 | 4 | ;;; 5 | ;;; DYNAMICALLY 6 | ;;; 7 | (defun dispatch-dynamically (flow-context body-fu) 8 | (declare (type (function (t) *) body-fu) 9 | #.+optimize-form+) 10 | (push-flow-stack flow-context (funcall body-fu (flow-context-value flow-context))) 11 | (dispatch-rest flow-context)) 12 | 13 | 14 | (defmacro dynamically (lambda-list &body body) 15 | "Generates new flow dynamically during parent flow execution. In other words, 16 | injects new dynamically created flow into a current one. Non-consing." 17 | (flow-lambda-macro (flow-context) 18 | (with-flow-function-macro (body-fu lambda-list body) 19 | `(dispatch-dynamically ,flow-context #',body-fu)))) 20 | 21 | 22 | (defmacro ->> (lambda-list &body body) 23 | "See flow:dynamically" 24 | `(dynamically ,lambda-list 25 | ,@body)) 26 | -------------------------------------------------------------------------------- /src/flow.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-flow) 2 | 3 | 4 | (defun parse-atomic-block-args (args) 5 | (loop for (opt . body) on args by #'cddr 6 | until (listp opt) 7 | collecting opt into opts 8 | collecting (first body) into opts 9 | finally (return (list opts opt body)))) 10 | 11 | 12 | (defmacro %flow-lambda ((flow-context) &body body) 13 | `(lambda (,flow-context) 14 | (declare (type flow-context ,flow-context) 15 | #.+optimize-form+) 16 | ,@body)) 17 | 18 | 19 | (defmacro flow-lambda-macro ((flow-context) &body body) 20 | `(with-gensyms (,flow-context) 21 | `(%flow-lambda (,,flow-context) 22 | ,,@body))) 23 | 24 | 25 | (defmacro %with-flow-function ((fu-name fu-lambda-list &body fu-body) &body body) 26 | (let* ((destructuring-ll (car fu-lambda-list)) 27 | (destructured-p (and destructuring-ll (listp destructuring-ll))) 28 | (arg (gensym))) 29 | (unless (or destructured-p (null (cdr fu-lambda-list))) 30 | (error "Flow block can accept single argument only, but got ~A" fu-lambda-list)) 31 | `(flet ((,fu-name (,arg) 32 | (declare (ignorable ,arg)) 33 | (,@(cond 34 | (destructured-p 35 | `(destructuring-bind ,destructuring-ll ,arg)) 36 | ((not (null fu-lambda-list)) 37 | `(let ((,destructuring-ll ,arg)))) 38 | (t '(progn))) 39 | ,@fu-body))) 40 | ,@body))) 41 | 42 | 43 | (defmacro with-flow-function-macro ((fu-name fu-lambda-list fu-body) &body body) 44 | `(with-gensyms (,fu-name) 45 | `(%with-flow-function (,,fu-name ,,fu-lambda-list ,@,fu-body) 46 | ,,@body))) 47 | 48 | 49 | (defmacro with-flow-let-macro ((var flow) &body body) 50 | `(with-gensyms (,var) 51 | `(let ((,,var (list ,@,flow))) 52 | ,,@body))) 53 | -------------------------------------------------------------------------------- /src/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage :cl-flow 2 | (:nicknames :flow) 3 | (:use :cl :alexandria) 4 | (:export #:-> 5 | #:>> 6 | #:~> 7 | #:->> 8 | #:%> 9 | #:o> 10 | 11 | #:atomically 12 | #:serially 13 | #:concurrently 14 | #:dynamically 15 | #:repeatedly 16 | #:*flow-value* 17 | #:asynchronously 18 | #:continue-flow 19 | #:interrupt-flow 20 | #:run 21 | 22 | #:rerun-flow-block 23 | #:skip-flow-block 24 | #:use-flow-block-value 25 | #:inject-flow)) 26 | -------------------------------------------------------------------------------- /src/repeatedly.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-flow) 2 | 3 | (declaim (special *flow-value*)) 4 | 5 | ;;; 6 | ;;; REPEATEDLY 7 | ;;; 8 | (defun dispatch-repeatedly (flow-context test-fu flow) 9 | (declare (type (function () boolean) test-fu) 10 | (type flow-context flow-context) 11 | #.+optimize-form+) 12 | (labels ((%push-repeated-flow (flow-context) 13 | (when (let ((*flow-value* (flow-context-value flow-context))) 14 | (funcall test-fu)) 15 | (push-flow-stack flow-context #'%push-repeated-flow) 16 | (push-flow-stack flow-context flow)) 17 | (dispatch-rest flow-context))) 18 | (%push-repeated-flow flow-context))) 19 | 20 | 21 | (defmacro repeatedly (live-test-form &body flow) 22 | "Short-circuit the flow specified inside the block and executes it repeatedly 23 | in loop until LIVE-TEST-FORM evaluates to NIL. Result from the last iteration 24 | will be passed to the next block. Non-consing." 25 | (with-gensyms (test-fu) 26 | (with-flow-let-macro (flow-list flow) 27 | (flow-lambda-macro (flow-context) 28 | `(flet ((,test-fu () ,live-test-form)) 29 | (dispatch-repeatedly ,flow-context #',test-fu ,flow-list)))))) 30 | 31 | 32 | (defmacro o> (condition &body body) 33 | "See flow:repeatedly" 34 | `(repeatedly ,condition 35 | ,@body)) 36 | -------------------------------------------------------------------------------- /src/run.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-flow) 2 | 3 | (defun run (dispatcher flow) 4 | "Dispatcher must be a function with lambda-list congruent to (task arg 5 | invariant &key &allow-other-keys)" 6 | (declare (type (function ((function () *) t &rest t &key &allow-other-keys) *) 7 | dispatcher) 8 | (type (or list function) flow) 9 | #.+optimize-form+) 10 | (let ((context (make-flow-context :native-dispatcher dispatcher))) 11 | (init-context-dispatcher context) 12 | (dispatch-serially context (ensure-list flow)))) 13 | -------------------------------------------------------------------------------- /src/serially.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-flow) 2 | 3 | ;;; 4 | ;;; SERIALLY 5 | ;;; 6 | (defun dispatch-serially (flow-context flow) 7 | (declare (type flow-context flow-context) 8 | #.+optimize-form+) 9 | (push-flow-stack flow-context flow) 10 | (dispatch-rest flow-context)) 11 | 12 | 13 | (defmacro serially (&body flow) 14 | "Executes child elements serially (but possibly in different threads) 15 | returning a value of the last atomic block or flow. Non-consing." 16 | (with-flow-let-macro (flow-list flow) 17 | (flow-lambda-macro (flow-context) 18 | `(dispatch-serially ,flow-context ,flow-list)))) 19 | 20 | 21 | (defmacro >> (&rest flow) 22 | "See flow:serially" 23 | `(serially ,@flow)) 24 | -------------------------------------------------------------------------------- /src/utils.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-flow) 2 | 3 | 4 | #+flow-optimized 5 | (alexandria:define-constant +optimize-form+ '(optimize (speed 3) (safety 1) (debug 0)) 6 | :test #'equal) 7 | #-flow-optimized 8 | (alexandria:define-constant +optimize-form+ '(optimize) :test #'equal) 9 | -------------------------------------------------------------------------------- /t/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-user) 2 | 3 | (defpackage :cl-flow.tests 4 | (:use :cl :cl-flow)) 5 | -------------------------------------------------------------------------------- /t/pooled-dispatcher.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-flow.tests) 2 | 3 | 4 | (define-condition skipping-condition (simple-error) ()) 5 | 6 | (define-condition recoverable-condition (simple-error) ()) 7 | 8 | 9 | (defun invoke (fn) 10 | (handler-bind ((skipping-condition (lambda (e) 11 | (declare (ignore e)) 12 | (skip-flow-block))) 13 | (recoverable-condition (lambda (e) 14 | (declare (ignore e)) 15 | (use-flow-block-value -1)))) 16 | (funcall fn))) 17 | 18 | 19 | (defun run-it (flow) 20 | (let ((dispatcher (simple-flow-dispatcher:make-simple-dispatcher :threads 4 21 | :invoker #'invoke))) 22 | (run dispatcher flow))) 23 | 24 | 25 | (defun dispatch-immediately (task invariant &key &allow-other-keys) 26 | (declare (ignore invariant)) 27 | (funcall task)) 28 | 29 | 30 | (defun run-it-immediately (flow) 31 | (run #'dispatch-immediately flow)) 32 | -------------------------------------------------------------------------------- /t/suite.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-flow.tests) 2 | 3 | (5am:def-suite :cl-flow.tests) 4 | 5 | (5am:in-suite :cl-flow.tests) 6 | 7 | 8 | (defun serial-flow () 9 | (>> (loop repeat 5 10 | collecting (-> :p (a) 11 | (declare (type fixnum a)) 12 | (the fixnum (1+ a)))))) 13 | 14 | 15 | (defun parallel-flow () 16 | (~> (loop for i from 0 below 3 17 | collecting (let ((i i)) 18 | (-> :p (a) 19 | (declare (type fixnum a)) 20 | (the fixnum (+ a i))))))) 21 | 22 | 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 | 25 | (5am:test basic-flow 26 | (let ((result "")) 27 | (mt:wait-with-latch (latch) 28 | (run-it 29 | (>> (-> :p () 1) 30 | (-> :p (a) (+ a 1)) 31 | (-> :p (v) 32 | (setf result v) 33 | (mt:open-latch latch))))) 34 | (5am:is (equal 2 result)))) 35 | 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | 38 | (defun flow-gen (p) 39 | (if p 40 | (>> (-> :g () 1)) 41 | (list (-> :g () 2) (-> :g (v) v)))) 42 | 43 | (5am:test dynamic-flow 44 | (let ((result (list))) 45 | (flet ((put (v) 46 | (push v result))) 47 | (mt:wait-with-latch (latch) 48 | (run-it 49 | (>> (-> :g () 50 | (put 0) 51 | t) 52 | (->> (v) (flow-gen v)) 53 | (-> :g (v) 54 | (put v) 55 | nil) 56 | (flow:dynamically (v) (flow-gen v)) 57 | (-> :g (v) 58 | (put v)) 59 | (flow:dynamically () nil) ;; allow null result 60 | (-> :g () 61 | (put 3) 62 | (mt:open-latch latch)))))) 63 | (5am:is (equal '(0 1 2 3) (nreverse result))))) 64 | 65 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 66 | 67 | (5am:test concurrent-null-flow 68 | (let ((result (list))) 69 | (flet ((put (v) 70 | (push v result))) 71 | (mt:wait-with-latch (latch) 72 | (run-it 73 | (>> (~> nil 74 | (list nil)) 75 | (-> :g ((a (b))) 76 | (put a) 77 | (put b) 78 | (mt:open-latch latch)))))) 79 | (5am:is (equal '(nil nil) (nreverse result))))) 80 | 81 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 82 | 83 | (5am:test asynchronous-flow 84 | (let ((result (list))) 85 | (flet ((put (v) 86 | (push v result))) 87 | (mt:wait-with-latch (latch) 88 | (run-it 89 | (>> (-> :g () 90 | (put 1) 91 | 2) 92 | (asynchronously (val) 93 | (put 2) 94 | (flet ((%continue () 95 | (continue-flow (+ 1 val)))) 96 | (run-it (-> :heh () 97 | (funcall #'%continue))))) 98 | (%> (val) 99 | (put val) 100 | (flet ((%continue () 101 | (continue-flow (+ 2 val)))) 102 | (run-it (-> :heh () 103 | (funcall #'%continue))))) 104 | (-> :g (val) 105 | (put val) 106 | (mt:open-latch latch)))))) 107 | (5am:is (equal '(1 2 3 5) (nreverse result))))) 108 | 109 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 110 | 111 | (5am:test restarted-flow 112 | (let ((result (list))) 113 | (flet ((put (v) 114 | (push v result))) 115 | (mt:wait-with-latch (latch) 116 | (run-it 117 | (>> (-> :g () 118 | (error 'recoverable-condition)) 119 | (-> :g (value) 120 | (put value) 121 | (error 'skipping-condition)) 122 | (-> :g (value) 123 | (unless value 124 | (put 0))) 125 | (-> :g () 126 | (mt:open-latch latch)))))) 127 | (5am:is (equal '(-1 0) (nreverse result))))) 128 | 129 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 130 | 131 | (5am:test non-concurrent-flow 132 | (let ((ref (mt:make-guarded-reference 0))) 133 | (flet ((increment () 134 | (let ((v (mt:guarded-value-of ref))) 135 | (sleep 0.05) 136 | (setf (mt:guarded-value-of ref) (1+ v))))) 137 | (mt:wait-with-latch (latch) 138 | (run-it 139 | (>> (~> (-> :one () 140 | (increment)) 141 | (-> :one () 142 | (increment)) 143 | (-> :one () 144 | (increment))) 145 | (-> :p () 146 | (mt:open-latch latch)))))) 147 | (5am:is (= 3 (mt:guarded-value-of ref))))) 148 | 149 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 150 | 151 | (5am:test fully-concurrent-flow 152 | (let ((value 0)) 153 | (flet ((increment () 154 | (let ((v value)) 155 | (sleep 0.1) 156 | (setf value (1+ v))))) 157 | (mt:wait-with-latch (latch) 158 | (run-it 159 | (>> (~> (-> :one () 160 | (increment)) 161 | (-> :two () 162 | (increment)) 163 | (-> :three () 164 | (increment))) 165 | (-> :p () 166 | (mt:open-latch latch)))))) 167 | (5am:is (= 1 value)))) 168 | 169 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 170 | 171 | (5am:test dispatcher-args 172 | (let ((value 0)) 173 | (flet ((increment () 174 | (let ((v value)) 175 | (sleep 0.05) 176 | (setf value (1+ v)))) 177 | (one () :one)) 178 | (mt:wait-with-latch (latch) 179 | (run-it 180 | (>> (~> (-> (one) :ignore-invariant t () 181 | (increment)) 182 | (-> :one :ignore-invariant t () 183 | (increment)) 184 | (-> :one :ignore-invariant t () 185 | (increment))) 186 | (-> :p () 187 | (mt:open-latch latch)))))) 188 | (5am:is (= 1 value)))) 189 | 190 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 191 | 192 | (5am:test repeated-flow 193 | (let* ((iterations 100000) 194 | (test-calls-left (1+ iterations)) 195 | result) 196 | (mt:wait-with-latch (latch) 197 | (run-it 198 | (>> 199 | (-> nil () 0) 200 | (o> (progn 201 | (decf test-calls-left) 202 | (< *flow-value* iterations)) 203 | (-> nil (value) 204 | (1+ value))) 205 | (-> nil (value) 206 | (setf result value) 207 | (mt:open-latch latch))))) 208 | (5am:is (= iterations result)) 209 | (5am:is (= test-calls-left 0)))) 210 | 211 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 212 | 213 | (5am:test stack-overflowing 214 | (let ((counter 100000)) 215 | (run-it-immediately 216 | (repeatedly (> counter 0) 217 | (serially 218 | (atomically nil () 219 | (decf counter))) 220 | (concurrently () 221 | (atomically nil () 222 | (symbol-name 'this)) 223 | (atomically nil () 224 | (symbol-name 'is)) 225 | (atomically nil () 226 | (symbol-name 'meh))))) 227 | (5am:pass))) 228 | 229 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 230 | 231 | (5am:test simple-example 232 | (let ((result "")) 233 | (mt:wait-with-latch (latch) 234 | (run-it 235 | (>> (~> (flow:atomically :tag-0 () "Hello") 236 | (-> :tag-1 () ", concurrent")) 237 | (-> :tag-2 ((a b)) 238 | (concatenate 'string a b " World!")) 239 | (-> :tag-3 (text) 240 | (setf result text) 241 | (mt:open-latch latch))))) 242 | (5am:is (equal "Hello, concurrent World!" result)))) 243 | 244 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 245 | 246 | (5am:test complex-flow 247 | (let ((result (list))) 248 | (flet ((put (v) 249 | (push v result))) 250 | (mt:wait-with-latch (latch) 251 | (run-it 252 | (>> 253 | (-> :g () 254 | (put 0) 255 | 1) 256 | (~> (-> :g (a) 257 | (+ 1 a)) 258 | (list nil) 259 | (-> :g (a) 260 | (+ a 2)) 261 | (>> (-> :g (b) 262 | (+ b 6)) 263 | (-> :g (b) 264 | (+ b 7))) 265 | (list (-> :g (a) 266 | (+ a 3)) 267 | (-> :g (a) 268 | (+ a 4)) 269 | (-> :g (a) 270 | (values (+ a 5) -1)))) 271 | (-> :g ((a (n) b c (d e f))) 272 | (put (list a n b c d e f))) 273 | (list (-> :g () 3) 274 | (parallel-flow) 275 | (-> :g (r) 276 | (put r))) 277 | (flow:serially 278 | (-> :g () 1) 279 | (serial-flow) 280 | (-> :g (a) 281 | (put a))) 282 | (-> :g () 283 | (mt:open-latch latch)))))) 284 | (5am:is (equal '(0 (2 nil 3 14 4 5 6) ((3 4 5)) 6) (nreverse result))))) 285 | --------------------------------------------------------------------------------