├── .github └── workflows │ └── CI.yml ├── .gitignore ├── LICENSE ├── README.md ├── bench-stripped.lisp ├── bench.lisp ├── docs ├── ask-timeout.org ├── disp_pinned.png ├── disp_shared.png ├── drawings.graffle ├── index.html ├── jquery.min.js ├── perf-M1Ultra.png ├── perf-x86_64.png ├── perf.numbers ├── perf.txt ├── style.css └── toc.min.js ├── documentation.lisp ├── queues-bench.lisp ├── sento.asd ├── src ├── actor-api.lisp ├── actor-cell.lisp ├── actor-context-api.lisp ├── actor-context.lisp ├── actor-system-api.lisp ├── actor-system.lisp ├── actor.lisp ├── agent-usecase │ ├── agent-usecase-commons.lisp │ ├── array-agent.lisp │ └── hash-agent.lisp ├── agent.lisp ├── atomic │ ├── atomic-abcl.lisp │ ├── atomic-api.lisp │ ├── atomic-clisp.lisp │ └── atomic.lisp ├── config.lisp ├── dispatcher-api.lisp ├── dispatcher.lisp ├── eventstream-api.lisp ├── eventstream.lisp ├── fasync-completed.lisp ├── fcomputation.lisp ├── fsm.lisp ├── mbox │ └── message-box.lisp ├── miscutils.lisp ├── package.lisp ├── queue │ ├── exp-tfifo.lisp │ ├── queue-cas.lisp │ ├── queue-locked.lisp │ ├── queue-sbcl.lisp │ └── queue.lisp ├── router.lisp ├── stash.lisp ├── tasks.lisp ├── timeutils.lisp └── wheel-timer.lisp └── tests ├── actor-cell-test.lisp ├── actor-context-test.lisp ├── actor-mp-test.lisp ├── actor-system-test.lisp ├── actor-test.lisp ├── actor-tree-test.lisp ├── agent-test.lisp ├── all-test.lisp ├── array-agent-test.lisp ├── atomic-test.lisp ├── bounded-queue-test.lisp ├── config-test.lisp ├── dispatcher-test.lisp ├── eventstream-test.lisp ├── fasync-completed-test.lisp ├── fcomputation-test.lisp ├── fsm-test.lisp ├── hash-agent-test.lisp ├── message-box-test.lisp ├── miscutils-test.lisp ├── router-test.lisp ├── spawn-in-receive-test.lisp ├── stash-test.lisp ├── tasks-test.lisp ├── test-utils.lisp ├── timeutils-test.lisp ├── unbounded-queue-test.lisp └── wheel-timer-test.lisp /.github/workflows/CI.yml: -------------------------------------------------------------------------------- 1 | # This is a basic workflow to help you get started with Actions 2 | 3 | name: CI 4 | 5 | # Controls when the workflow will run 6 | on: 7 | # Triggers the workflow on push or pull request events but only for the master branch 8 | push: 9 | branches: [ master ] 10 | pull_request: 11 | branches: [ master ] 12 | 13 | # Allows you to run this workflow manually from the Actions tab 14 | workflow_dispatch: 15 | 16 | # A workflow run is made up of one or more jobs that can run sequentially or in parallel 17 | jobs: 18 | test: 19 | name: ${{ matrix.lisp }} on ${{ matrix.os }} 20 | strategy: 21 | matrix: 22 | lisp: [sbcl-bin] #, ccl ] #, ecl, allegro] 23 | os: [ ubuntu-latest ] #, windows-latest, macos-latest] 24 | runs-on: ${{ matrix.os }} 25 | 26 | steps: 27 | # tell git not to convert line endings 28 | # change roswell install dir and add it to path 29 | 30 | # Check out your repository under $GITHUB_WORKSPACE, so your job can access it 31 | - uses: actions/checkout@v2 32 | 33 | - name: cache .roswell 34 | id: cache-dot-roswell 35 | uses: actions/cache@v3 36 | with: 37 | path: ~/.roswell 38 | key: ${{ runner.os }}-dot-roswell-${{ matrix.lisp }}-${{ hashFiles('**/*.asd') }} 39 | restore-keys: | 40 | ${{ runner.os }}-dot-roswell-${{ matrix.lisp }}- 41 | ${{ runner.os }}-dot-roswell- 42 | - name: install roswell 43 | shell: bash 44 | # always run install, since it does some global installs and setup that isn't cached 45 | env: 46 | LISP: ${{ matrix.lisp }} 47 | run: curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh -x 48 | - name: run lisp 49 | continue-on-error: true 50 | shell: bash 51 | run: | 52 | ros -e '(format t "~a:~a on ~a~%...~%~%" (lisp-implementation-type) (lisp-implementation-version) (machine-type))' 53 | ros -e '(format t " fixnum bits:~a~%" (integer-length most-positive-fixnum))' 54 | ros -e "(ql:quickload 'trivial-features)" -e '(format t "features = ~s~%" *features*)' 55 | - name: update ql dist if we have one cached 56 | shell: bash 57 | run: ros -e "(ql:update-all-dists :prompt nil)" 58 | 59 | - name: load code and run tests 60 | shell: bash 61 | run: | 62 | ros -e '(handler-bind (#+asdf3.2(asdf:bad-SYSTEM-NAME (function MUFFLE-WARNING))) (handler-case (ql:quickload :sento/tests) (error (a) (format t "caught error ~s~%~a~%" a a) (uiop:quit 1))))' -e "(unless (5am:run! 'sento.tests:test-suite) (uiop:quit 1))" 63 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | *.lx32fsl 5 | *.lx64fsl 6 | *.x86f 7 | *~ 8 | .#* 9 | *.abcl 10 | *.fas 11 | *.64yfasl 12 | /.idea/ 13 | /systems* 14 | -------------------------------------------------------------------------------- /bench-stripped.lisp: -------------------------------------------------------------------------------- 1 | ;;(ql:quickload "lparallel") 2 | ;;(ql:quickload "bordeaux-threads") 3 | 4 | (use-package :lparallel) 5 | 6 | (defparameter *msgbox-kernel* nil) 7 | (defparameter *msgbox-channel* nil) 8 | (defparameter *counter* 0) 9 | (defparameter *called* 0) 10 | (defparameter +threads+ 8) 11 | (defparameter +per-thread+ 50) 12 | 13 | (defun max-loop () (* +per-thread+ +threads+)) 14 | 15 | (format t "Times: ~a~%" (max-loop)) 16 | 17 | (defun submit-msg-sr () 18 | (let* ((lparallel:*kernel* *msgbox-kernel*) 19 | (channel *msgbox-channel*)) 20 | (lparallel:submit-task channel 21 | (lambda () 22 | (1+ *counter*))) 23 | (setf *counter* (lparallel:receive-result channel)))) 24 | 25 | (defun submit-msg-fut () 26 | (let* ((lparallel:*kernel* *msgbox-kernel*) 27 | (fut (lparallel:future 28 | (incf *counter*) 29 | *counter*))) 30 | (force fut))) 31 | 32 | (defun runner (submit-fun) 33 | (setf *msgbox-kernel* (lparallel:make-kernel 1)) 34 | (let ((lparallel:*kernel* *msgbox-kernel*)) 35 | (setf *msgbox-channel* (lparallel:make-channel))) 36 | (setf lparallel:*kernel* (lparallel:make-kernel +threads+)) 37 | (setf *counter* 0) 38 | 39 | (unwind-protect 40 | (time 41 | (map nil #'lparallel:force 42 | (mapcar (lambda (n) 43 | (lparallel:future 44 | (dotimes (n +per-thread+) 45 | (funcall submit-fun)))) 46 | (loop for n from 1 to +threads+ collect n)))) 47 | (format t "Counter: ~a~%" *counter*) 48 | (sleep 1) 49 | (format t "Counter: ~a~%" *counter*) 50 | 51 | (lparallel:end-kernel :wait t) 52 | (let ((lparallel:*kernel* *msgbox-kernel*)) 53 | (lparallel:end-kernel :wait t)))) 54 | 55 | (defun runner-sr () 56 | (runner #'submit-msg-sr)) 57 | (defun runner-fut () 58 | (runner #'submit-msg-fut)) 59 | 60 | -------------------------------------------------------------------------------- /docs/ask-timeout.org: -------------------------------------------------------------------------------- 1 | *** How is the ask timeout handled* 2 | 3 | Generally, the ~ask~ / ~async-ask~ timeout is resource intensive insofar that a separate thread is spawned 4 | which sleeps for the given timeout. If no result is there by when the thread awakes an =ask-timeout= condition is raised, and 5 | the message processing is cancelled, if possible. 6 | 7 | There are 4 scenarios: 8 | 9 | **** ask - =shared= dispatcher 10 | 11 | The ~ask~ message submit on the =shared= dispatcher is within the =current thread= until the message is put into 12 | the queue on one of the dispatcher actors by the dispatcher api. 13 | The call trace is (simplified): 14 | 15 | - ~ask~ (actor) 16 | - ~call~ (actor-cell) 17 | - ~submit~/~dispatch/reply/timeout~ (message-box/dp) => uses ~with-waitfor~ 18 | - ~dispatch~ (dispatcher) 19 | - ~ask~ (actor, worker) 20 | - ~call~ (actor-cell, worker) 21 | - ~submit/reply~ (message-box/bt, worker) 22 | 23 | The last step puts the message in a queue which is then handled by the queue thread of the =pinned= actor. 24 | Since the clock should start ticking almost immediately after calling ~ask~, 25 | we accept that the 'timer' thread is started at delivering the message to the dispatcher because it is still in the same local-thread. It is done at this place, because we still have access to the wrapped message object. 26 | This is needed to set the ~cancelled-p~ flag, even if the message object is already in the dispatcher processing queue. 27 | 28 | When the message already has been processed, but a reply couldn't be sent/received in time, then there is nothing we can do. An =ask-timeout= might have been issued at the calling side, but any state change or some other operation could still have happened. 29 | When the message has not been processed, then processing is bypassed due to the ~cancelled-p~ flag (see =dispatcher-exec-fun=). 30 | 31 | **** ask - =pinned= 32 | 33 | The call trace of the =pinned= ~ask~ process is a bit simpler: 34 | 35 | - ~ask~ (actor) 36 | - ~call~ (actor-cell) 37 | - ~submit/reply~ (message-box/bt) => uses ~sleep~ 38 | 39 | The last step puts the message in the queue of the same actor. 40 | This scenario is very efficient. Since an ~ask~ operation blocks anyway we can just use a loop here that blocks for the given timeout and check repeatedly for the arrival of a result. If after the =timeout= the message hasn't been processed yet (no result is produced) an =ask-timeout= condition is raised and the ~cancelled-p~ flag of the wrapping message object is set which bypasses the message processing when it is (would be) due. Setting the ~cancelled-p~ flag doesn't actually fully bypass the message processing. The message is still popped from queue and looked at, but it is not given into the message handler if it was cancelled. 41 | 42 | **** async-ask - =shared= dispatcher 43 | 44 | The ~async-ask~ generally works by spawning a separate actor which then sends the message to the target actor and waits for a result. This has the effect that ~async-ask~ doesn't block, but instead a future object is received which can be consulted for when a response has been received (~on-complete~, etc.). 45 | The call stack is as follows: 46 | 47 | - ~async-ask~ (actor, waiting-actor) -> uses ~with-waitfor~ 48 | - ~tell~ (target-actor, waiting-actor sends itself as sender as part of the 'tell' and waits until a response is returned) 49 | - ~cast~ (actor-cell, target-actor) 50 | - ~submit~/~dispatch/noreply~ (message-box/dp, target-actor) 51 | - ~dispatch-async~ (dispatcher) 52 | - ~tell~ (actor, worker) 53 | - ~cast~ (actor-cell, worker) 54 | - ~submit/no-reply~ (message-box/bt, worker) 55 | 56 | For this scenario the 'timer' (thread using ~with-waitfor~) really has to be spawned at ~async-ask~, because due to the fact that the message is passed through a waiting actor it is otherwise not possible to intercept a message processing on the dispatcher. 57 | (*Not any more because too resource intensive* Additionally, a special message object is used here (~delayed-cancellable-message~) which does the following things: it wraps the actual message, it takes a seconds delay number, it has a ~cancelled-p~ flag. The ~cancelled-p~ flag is checked prior to handling the message. In order to toggle the flag while in transit, or while sitting in the dispatcher workers queue a 'timer' thread is spawed as part of the message object that can toggle the ~cancelled-p~ flag no matter where it is. 58 | If the message was cancelled is it not processed. This will additionally raise an =ask-timeout= in ~async-ask~.) 59 | 60 | Clearly this is not very efficient. The 'waitor' actor uses a dipatcher, if a =system= exists so that it doesn't need a separate thread. But otherwise two additional threads are being spawed to allow cutting off this operation. 61 | 62 | The ~with-waitfor~ macro only wraps the =bt:with-timeout= macro. This created a separate thread. It would be good to have a thread-pool with a certain amount of threads that could do this instead. 63 | 64 | **** async-ask - =pinned= 65 | 66 | The call trace: 67 | 68 | - ~async-ask~ (actor, waiting-actor) -> uses ~with-waitfor~ 69 | - ~tell~ (target-actor, waiting-actor sends itself as 'sender' as part of the 'tell' and waits until a response is returned) 70 | - ~cast~ (actor-cell, target-actor) 71 | - ~submit/no-reply~ (message-box/bt, target-actor) 72 | 73 | As above, the 'timer' thread that waits and check for the delivered result is opened in ~async-ask~. (*Not any more because too resource intennsive* This scenario also uses the ~delayed-cancellable-message~ and with that a 'timer' thread that can toggle the ~cancelled-p~ flag.) 74 | As with the other =pinned= scenarios this is a bit more efficient than using the dispatcher, generally. 75 | -------------------------------------------------------------------------------- /docs/disp_pinned.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mdbergmann/cl-gserver/58aa887e751aa780d01f4a5e042767a0b5b609a9/docs/disp_pinned.png -------------------------------------------------------------------------------- /docs/disp_shared.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mdbergmann/cl-gserver/58aa887e751aa780d01f4a5e042767a0b5b609a9/docs/disp_shared.png -------------------------------------------------------------------------------- /docs/drawings.graffle: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mdbergmann/cl-gserver/58aa887e751aa780d01f4a5e042767a0b5b609a9/docs/drawings.graffle -------------------------------------------------------------------------------- /docs/perf-M1Ultra.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mdbergmann/cl-gserver/58aa887e751aa780d01f4a5e042767a0b5b609a9/docs/perf-M1Ultra.png -------------------------------------------------------------------------------- /docs/perf-x86_64.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mdbergmann/cl-gserver/58aa887e751aa780d01f4a5e042767a0b5b609a9/docs/perf-x86_64.png -------------------------------------------------------------------------------- /docs/perf.numbers: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mdbergmann/cl-gserver/58aa887e751aa780d01f4a5e042767a0b5b609a9/docs/perf.numbers -------------------------------------------------------------------------------- /docs/style.css: -------------------------------------------------------------------------------- 1 | :root { 2 | /* Use the default fonts with sans-serif as the main font. */ 3 | --font-family: sans-serif; 4 | --font-family-heading: serif; 5 | --font-family-monospace: monospace; 6 | --code-color: #333; 7 | 8 | --line-height: 1.35rem; 9 | --parsep: 0.3375rem; 10 | } 11 | 12 | @media (min-width: 70rem) { 13 | html { 14 | text-align: justify; 15 | } 16 | #content { 17 | margin-left: calc(min(40ex,33%)); 18 | } 19 | #toc { 20 | width: 40ex; 21 | max-width: 33%; 22 | } 23 | } 24 | 25 | @media (max-width: 70rem) { 26 | html { 27 | text-align: justify; 28 | } 29 | #toc { 30 | width: 0ex; 31 | } 32 | } 33 | 34 | @media (max-width: 40rem) { 35 | html { 36 | text-align: left; 37 | } 38 | } 39 | 40 | body { 41 | font-family: var(--font-family); 42 | font-feature-settings: var(--font-feature-settings); 43 | margin: auto; 44 | background-color: #faf9f6; 45 | color: #333; 46 | /* max-width: calc(73ch + 8*var(--line-height)); */ 47 | hyphens: auto; 48 | hyphenate-limit-chars: 4 2 2; 49 | min-height: 100vh; 50 | line-height: var(--line-height); 51 | } 52 | 53 | p { 54 | margin: var(--parsep) 0; 55 | } 56 | 57 | li { 58 | margin: calc(0.5*var(--parsep)) 0 0 0; 59 | } 60 | 61 | /* p + p { */ 62 | /* margin: 0; */ 63 | /* text-indent: var(--line-height); */ 64 | /* } */ 65 | 66 | ul + p, ol + p, dl + p { 67 | margin: calc(2*var(--parsep)) 0 0 0; 68 | text-indent: 0; 69 | } 70 | 71 | /* li > p { */ 72 | /* margin: 0; */ 73 | /* } */ 74 | 75 | h1 { 76 | font-family: var(--font-family-heading); 77 | font-feature-settings: var(--font-feature-settings-heading); 78 | font-weight: normal; 79 | text-transform: uppercase; 80 | letter-spacing: 0.18em; 81 | /* text-shadow: 0.05em 0.05em 0.02em #DDD; */ 82 | line-height: calc(2*var(--line-height)); 83 | font-size: 2.0rem; 84 | margin: calc(2*var(--line-height)) 0; 85 | /* margin: calc(3*var(--line-height)) 0 calc(2*var(--line-height)) 0; */ 86 | text-align: center; 87 | } 88 | 89 | h2 { 90 | font-size: 1.3rem; 91 | font-weight: bold; 92 | line-height: var(--line-height); 93 | margin: var(--line-height) 0; 94 | } 95 | 96 | h3 { 97 | font-size: 1.2rem; 98 | font-weight: bold; 99 | line-height: var(--line-height); 100 | margin: var(--line-height) 0; 101 | } 102 | 103 | h4 { 104 | font-size: 1.1rem; 105 | font-weight: bold; 106 | line-height: var(--line-height); 107 | margin: var(--line-height) 0; 108 | } 109 | 110 | h5 { 111 | font-size: 1rem; 112 | font-weight: bold; 113 | line-height: var(--line-height); 114 | margin: var(--line-height) 0; 115 | } 116 | 117 | h6 { 118 | font-size: 1rem; 119 | font-weight: normal; 120 | line-height: var(--line-height); 121 | margin: calc(0.75*var(--line-height)) 0; 122 | color: #666; 123 | } 124 | 125 | h1 a { 126 | text-decoration: none; 127 | color: #333; 128 | } 129 | h2 a { 130 | text-decoration: none; 131 | color: #333; 132 | } 133 | h3 a { 134 | text-decoration: none; 135 | color: #333; 136 | } 137 | h4 a { 138 | text-decoration: none; 139 | color: #333; 140 | } 141 | h5 a { 142 | text-decoration: none; 143 | color: #333; 144 | } 145 | h6 a { 146 | text-decoration: none; 147 | color: #333; 148 | } 149 | 150 | pre { 151 | font-family: var(--font-family-monospace); 152 | font-size: var(--font-size-monospace-in-pre); 153 | } 154 | 155 | code { 156 | font-family: var(--font-family-monospace); 157 | font-size: var(--font-size-monospace-in-code); 158 | color: var(--code-color); 159 | hyphens: none; 160 | } 161 | 162 | hr { 163 | height: 0.2em; 164 | border: 0; 165 | color: #CCCCCC; 166 | background-color: #CCCCCC; 167 | } 168 | 169 | blockquote, table, pre { 170 | line-height: var(--line-height); 171 | margin: var(--parsep) 0 0 0; 172 | } 173 | 174 | pre { 175 | background-color: #F5F3ED; 176 | color: #333; 177 | border: 0.1em solid #CCCCCC; 178 | line-height: 1.25em; 179 | overflow: auto; 180 | padding: 0 0 calc(0.5*var(--parsep)) 0; 181 | } 182 | 183 | ul, ol, dl { 184 | padding-left: var(--line-height); 185 | margin: 0; 186 | } 187 | 188 | a { 189 | /* text-decoration: none; */ 190 | /* color: #0233c8; */ 191 | color: #333; 192 | text-decoration-thickness: 0.04em; 193 | text-underline-offset: 0.1em; 194 | } 195 | 196 | a:hover { 197 | text-decoration: underline; 198 | } 199 | 200 | img { 201 | display: block; 202 | max-width: 90%; 203 | margin: auto; 204 | } 205 | 206 | .reference-bullet { 207 | display: block; 208 | text-align: left; 209 | margin-top: calc(2*var(--parsep)); 210 | hyphens: none; 211 | } 212 | 213 | .reference { 214 | /* padding: 0.3em 0; */ 215 | /* background-color: #EEEEEE; */ 216 | } 217 | 218 | .locative-type a { 219 | text-decoration: none; 220 | border-bottom: 0; 221 | font-weight: bold; 222 | color: #444; 223 | } 224 | 225 | .reference-object { 226 | background-color: #EBE8E2; 227 | /* The live browser does not lowercase. Balance the space around 228 | * uppercase characters manually. */ 229 | padding: 0.1em 0.22em 0.02em 0.22em; 230 | border: solid 1px #777; 231 | font-weight: bold; 232 | letter-spacing: 0.02em; 233 | /* Counter the effect of boldness by slightly reducing the size. */ 234 | font-size: 98%; 235 | } 236 | 237 | .reference-object a { 238 | text-decoration: none; 239 | border-bottom: none; 240 | } 241 | 242 | .locative-args { 243 | font-style: italic; 244 | } 245 | 246 | .locative-args code { 247 | font-family: sans-serif; 248 | } 249 | 250 | .navigation a { 251 | color: #CCCCCC; 252 | text-shadow: none; 253 | border-bottom: none; 254 | } 255 | 256 | /* Option 1 for navigation links: just hide the links in the previous 257 | line. Good because there is no jumping around of content as with 258 | the other otptions. */ 259 | 260 | .navigation { 261 | display: block; 262 | visibility: hidden; 263 | margin-bottom: -1.5em; 264 | } 265 | 266 | .outer-navigation:hover .navigation { 267 | visibility: visible; 268 | } 269 | 270 | /* Option 2 for navigation links: heading moves right to make room for 271 | the links. */ 272 | 273 | /* .navigation { */ 274 | /* display: none; */ 275 | /* } */ 276 | /* */ 277 | /* h1:hover .navigation, */ 278 | /* h2:hover .navigation, */ 279 | /* h3:hover .navigation, */ 280 | /* h4:hover .navigation, */ 281 | /* h5:hover .navigation, */ 282 | /* h6:hover .navigation { */ 283 | /* display: inline; */ 284 | /* } */ 285 | 286 | /* Option 3 for navigation links: heading moves down to make room for 287 | the links. */ 288 | 289 | /* .navigation { */ 290 | /* display: none; */ 291 | /* } */ 292 | /* */ 293 | /* h1:hover .navigation, */ 294 | /* h2:hover .navigation, */ 295 | /* h3:hover .navigation, */ 296 | /* h4:hover .navigation, */ 297 | /* h5:hover .navigation, */ 298 | /* h6:hover .navigation { */ 299 | /* display: block; */ 300 | /* } */ 301 | 302 | /* Syntax highlighting with Colorize */ 303 | 304 | .symbol { color : #770055; background-color : transparent; border: 0px; margin: 0px;} 305 | a.symbol:link { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } 306 | a.symbol:active { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } 307 | a.symbol:visited { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } 308 | a.symbol:hover { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } 309 | .special { color : #FF5000; background-color : inherit; } 310 | .keyword { color : #770000; background-color : inherit; } 311 | .comment { color : #007777; background-color : inherit; } 312 | .string { color : #777777; background-color : inherit; } 313 | .atom { color : #314F4F; background-color : inherit; } 314 | .macro { color : #FF5000; background-color : inherit; } 315 | .variable { color : #36648B; background-color : inherit; } 316 | .function { color : #8B4789; background-color : inherit; } 317 | .attribute { color : #FF5000; background-color : inherit; } 318 | .character { color : #0055AA; background-color : inherit; } 319 | .syntaxerror { color : #FF0000; background-color : inherit; } 320 | .diff-deleted { color : #5F2121; background-color : inherit; } 321 | .diff-added { color : #215F21; background-color : inherit; } 322 | 323 | /* Disable rainbow nesting on hover */ 324 | 325 | /* span.paren1 { background-color : inherit; -webkit-transition: background-color 0.2s linear; } */ 326 | /* span.paren1:hover { color : inherit; background-color : #BAFFFF; } */ 327 | /* span.paren2 { background-color : inherit; -webkit-transition: background-color 0.2s linear; } */ 328 | /* span.paren2:hover { color : inherit; background-color : #FFCACA; } */ 329 | /* span.paren3 { background-color : inherit; -webkit-transition: background-color 0.2s linear; } */ 330 | /* span.paren3:hover { color : inherit; background-color : #FFFFBA; } */ 331 | /* span.paren4 { background-color : inherit; -webkit-transition: background-color 0.2s linear; } */ 332 | /* span.paren4:hover { color : inherit; background-color : #CACAFF; } */ 333 | /* span.paren5 { background-color : inherit; -webkit-transition: background-color 0.2s linear; } */ 334 | /* span.paren5:hover { color : inherit; background-color : #CAFFCA; } */ 335 | /* span.paren6 { background-color : inherit; -webkit-transition: background-color 0.2s linear; } */ 336 | /* span.paren6:hover { color : inherit; background-color : #FFBAFF; } */ 337 | 338 | #content-container { 339 | margin: 0; 340 | padding: 0 0 var(--line-height) 0; 341 | } 342 | 343 | #content { 344 | max-width: 85ex; 345 | padding-left: 4ch; 346 | padding-right: 4ch; 347 | } 348 | 349 | #toc { 350 | top: 0px; 351 | left: 0px; 352 | height: 100%; 353 | position: fixed; 354 | overflow-y: auto; 355 | overflow-x: hidden; 356 | background: #333; 357 | box-shadow: inset -5px 0 5px 0px #000; 358 | color: #aaa; 359 | text-align: left; 360 | } 361 | 362 | #toc ul { 363 | font-family: sans-serif; 364 | font-size: 80%; 365 | } 366 | 367 | #toc li { 368 | line-height: 1.0; 369 | } 370 | 371 | #toc a { 372 | text-decoration: none; 373 | border-bottom: none; 374 | } 375 | 376 | #toc hr { 377 | height: 0.05em; 378 | border: 0; 379 | background: #777; 380 | } 381 | 382 | #toc ul { 383 | margin: 0; 384 | padding: 0; 385 | list-style: none; 386 | } 387 | 388 | #toc li { 389 | padding: 5px 10px; 390 | } 391 | 392 | #toc .toc-h2 { 393 | padding-left: 10px; 394 | } 395 | 396 | #toc .toc-h3 { 397 | padding-left: 20px; 398 | } 399 | 400 | #toc .toc-h4 { 401 | padding-left: 30px; 402 | } 403 | 404 | #toc .toc-active { 405 | background: #336699; 406 | box-shadow: inset -5px 0px 10px -5px #000; 407 | } 408 | 409 | #page-toc a { 410 | color: #fff; 411 | } 412 | 413 | .menu-block { 414 | padding-left: 10px; 415 | margin-bottom: 1em; 416 | } 417 | 418 | .menu-block-title { 419 | font-size: 90%; 420 | } 421 | 422 | .menu-block a { 423 | color: #fff; 424 | border-bottom: none; 425 | } 426 | 427 | #toc-header a { 428 | color: #777777; 429 | } 430 | 431 | #toc-footer a { 432 | font-size: 80%; 433 | color: #777777; 434 | } 435 | -------------------------------------------------------------------------------- /docs/toc.min.js: -------------------------------------------------------------------------------- 1 | /*! 2 | * toc - jQuery Table of Contents Plugin 3 | * v0.3.2 (modified for PAX) 4 | * http://projects.jga.me/toc/ 5 | * copyright Greg Allen 2014 6 | * MIT License 7 | */ 8 | !function(a){a.fn.smoothScroller=function(b){b=a.extend({},a.fn.smoothScroller.defaults,b);var c=a(this);return a(b.scrollEl).animate({scrollTop:c.offset().top-a(b.scrollEl).offset().top-b.offset},b.speed,b.ease,function(){var a=c.attr("id");a.length&&(history.pushState?history.pushState(null,null,"#"+a):document.location.hash=a),c.trigger("smoothScrollerComplete")}),this},a.fn.smoothScroller.defaults={speed:400,ease:"swing",scrollEl:"body,html",offset:0},a("body").on("click","[data-smoothscroller]",function(b){b.preventDefault();var c=a(this).attr("href");0===c.indexOf("#")&&a(c).smoothScroller()})}(jQuery),function(a){var b={};a.fn.toc=function(b){var c,d=this,e=a.extend({},jQuery.fn.toc.defaults,b),f=a(e.container),g=a(e.selectors,f),h=[],i=e.activeClass,j=function(b,c){if(e.smoothScrolling&&"function"==typeof e.smoothScrolling){b.preventDefault();var f=a(b.target).attr("href");e.smoothScrolling(f,e,c)}a("li",d).removeClass(i),a(b.target).parent().addClass(i)},k=function(){c&&clearTimeout(c),c=setTimeout(function(){for(var b,c=a(window).scrollTop(),f=Number.MAX_VALUE,g=0,j=0,k=h.length;k>j;j++){var l=Math.abs(h[j]-c);f>l&&(g=j,f=l)}a("li",d).removeClass(i),b=a("li:eq("+g+")",d).addClass(i),e.onHighlight(b)},50)};return e.highlightOnScroll&&(a(window).bind("scroll",k),k()),this.each(function(){var b=a(this),c=a(e.listType);g.each(function(d,f){var g=a(f);h.push(g.offset().top-e.highlightOffset);var i=e.anchorName(d,f,e.prefix);if(f.id!==i){a("").attr("id",i).insertBefore(g)}var l=a("").text(e.headerText(d,f,g)).attr("href","#"+i).bind("click",function(c){b.trigger("selected",a(this).attr("href"))}),m=a("
  • ").addClass(e.itemClass(d,f,g,e.prefix)).append(l);c.append(m)}),b.html(c)})},jQuery.fn.toc.defaults={container:"body",listType:"
      ",selectors:"h1,h2,h3",smoothScrolling:function(b,c,d){a(b).smoothScroller({offset:c.scrollToOffset}).on("smoothScrollerComplete",function(){d()})},scrollToOffset:0,prefix:"toc",activeClass:"toc-active",onHighlight:function(){},highlightOnScroll:!0,highlightOffset:100,anchorName:function(c,d,e) {try{return d.previousElementSibling.previousElementSibling.lastChild.id;}catch(err){return e + '-' + c;}},headerText:function(a,b,c){return c.text()},itemClass:function(a,b,c,d){return d+"-"+c[0].tagName.toLowerCase()}}}(jQuery); 9 | -------------------------------------------------------------------------------- /documentation.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :asys) 3 | (pax:defsection @actor-system (:title "Actor-System") 4 | (asys:actor-system class) 5 | (asys:make-actor-system function) 6 | (asys:*default-config* variable) 7 | (asys:register-dispatcher function) 8 | (asys:register-new-dispatcher function) 9 | (asys:evstream (pax:reader actor-system)) 10 | (asys:scheduler (pax:reader actor-system)) 11 | ;; ac protocol 12 | (ac:actor-of (method () (asys:actor-system))) 13 | (ac:find-actors (method () (asys:actor-system t))) 14 | (ac:all-actors (method () (asys:actor-system))) 15 | (ac:stop (method () (asys:actor-system t))) 16 | (ac:shutdown (method () (asys:actor-system))) 17 | ) 18 | 19 | (in-package :ac) 20 | (pax:defsection @ac-protocol (:title "Actor-Context protocol") 21 | (ac:actor-of generic-function) 22 | (ac:find-actors generic-function) 23 | (ac:all-actors generic-function) 24 | (ac:stop generic-function) 25 | (ac:shutdown generic-function)) 26 | 27 | (pax:defsection @actor-context (:title "Actor-Context") 28 | (ac:actor-context class) 29 | (ac:make-actor-context function) 30 | 31 | (ac:actor-of (method () (ac:actor-context))) 32 | (ac:find-actors (method () (ac:actor-context t))) 33 | (ac:all-actors (method () (ac:actor-context))) 34 | (ac:stop (method () (ac:actor-context t))) 35 | (ac:shutdown (method () (ac:actor-context))) 36 | 37 | (ac:notify generic-function) 38 | 39 | (ac:system (pax:reader actor-context)) 40 | (ac:id (pax:reader actor-context)) 41 | (ac:actor-name-exists condition) 42 | 43 | (@ac-protocol pax:section)) 44 | 45 | (in-package :act-cell) 46 | (pax:defsection @actor-cell (:title "Actor-Cell") 47 | (act-cell:actor-cell class) 48 | (act-cell:name (pax:reader actor-cell)) 49 | (act-cell:state (pax:reader actor-cell)) 50 | (act-cell:msgbox (pax:accessor actor-cell)) 51 | (act-cell:handle-call generic-function) 52 | (act-cell:handle-cast generic-function) 53 | (act-cell:stop generic-function) 54 | (act-cell:call function) 55 | (act-cell:cast function) 56 | (act-cell:running-p function)) 57 | 58 | (in-package :mesgb) 59 | (pax:defsection @message-box-base (:title "Message-box base class") 60 | (mesgb::message-box-base class) 61 | (mesgb::name (pax:reader mesgb::message-box-base)) 62 | (mesgb::max-queue-size (pax:reader mesgb::message-box-base)) 63 | (mesgb:submit generic-function) 64 | (mesgb:stop generic-function) 65 | (mesgb:stop (method () (mesgb::message-box-base)))) 66 | 67 | (pax:defsection @message-box/bt (:title "Message-box threaded") 68 | (mesgb:message-box/bt class) 69 | (mesgb:submit (method () (mesgb:message-box/bt t t t t)))) 70 | 71 | (pax:defsection @message-box/dp (:title "Message-box dispatched") 72 | (mesgb:message-box/dp class) 73 | (mesgb:submit (method () (mesgb:message-box/dp t t t t)))) 74 | 75 | (in-package :future) 76 | (pax:defsection @future (:title "Future (delayed-computation)") 77 | (future:future class) 78 | (future:with-fut pax:macro) 79 | (future:with-fut-resolve pax:macro) 80 | (future:make-future function) 81 | (future:complete-p function) 82 | (future:fcompleted pax:macro) 83 | (future:fresult function) 84 | (future:fmap pax:macro) 85 | (future:frecover pax:macro)) 86 | 87 | (in-package :async-future) 88 | (pax:defsection @async-future (:title "Async Future handling") 89 | (async-future:fasync-completed pax:macro)) 90 | 91 | (in-package :act) 92 | (pax:defsection @actor (:title "Actor") 93 | (act:actor class) 94 | (act:make-actor generic-function) 95 | (act:tell generic-function) 96 | (act:ask-s generic-function) 97 | (act:ask generic-function) 98 | (act:reply function) 99 | (act:become generic-function) 100 | (act:unbecome generic-function) 101 | (act:context generic-function) 102 | (act:path generic-function) 103 | (act:watch generic-function) 104 | (act:unwatch generic-function) 105 | (act:watchers generic-function) 106 | (act:pre-start generic-function) 107 | (act:after-stop generic-function) 108 | ;; event stream protocol 109 | (ev:subscribe (method () (act:actor act:actor))) 110 | (ev:unsubscribe (method () (act:actor act:actor))) 111 | (ev:publish (method () (act:actor t))) 112 | ;; actor-context protocol 113 | (ac:find-actors (method () (act:actor t))) 114 | (ac:all-actors (method () (act:actor))) 115 | (ac:actor-of (method () (act:actor))) 116 | (ac:system (method () (act:actor))) 117 | 118 | (act-cell::@actor-cell pax:section) 119 | (mesgb::@message-box-base pax:section) 120 | (mesgb::@message-box/bt pax:section) 121 | (mesgb::@message-box/dp pax:section)) 122 | 123 | (in-package :agthash) 124 | (pax:defsection @hash-agent (:title "Hash-table agent") 125 | (agthash:make-hash-agent function) 126 | (agthash:agent-gethash function) 127 | (agthash:agent-remhash function) 128 | (agthash:agent-clrhash function) 129 | (agthash:agent-dohash function)) 130 | 131 | (in-package :agtarray) 132 | (pax:defsection @array-agent (:title "Array/Vector agent") 133 | (agtarray:make-array-agent function) 134 | (agtarray:agent-elt function) 135 | (agtarray:agent-push function) 136 | (agtarray:agent-push-and-getidx function) 137 | (agtarray:agent-pop function) 138 | (agtarray:agent-delete function) 139 | (agtarray:agent-doarray function)) 140 | 141 | (in-package :agt) 142 | (pax:defsection @agent (:title "Agent") 143 | (agt:agent class) 144 | (agt:make-agent function) 145 | (agt:agent-get function) 146 | (agt:agent-update function) 147 | (agt:agent-update-and-get function) 148 | (agt:agent-stop function) 149 | 150 | (agthash::@hash-agent pax:section) 151 | (agtarray::@array-agent pax:section)) 152 | 153 | (in-package :fsm) 154 | (pax:defsection @fsm (:title "Finite state machine") 155 | (fsm:fsm class) 156 | (fsm:make-fsm function) 157 | (fsm:when-state pax:macro) 158 | (fsm:on-event pax:macro) 159 | (fsm:goto-state pax:macro) 160 | (fsm:stay-on-state pax:macro) 161 | (fsm:when-unhandled pax:macro) 162 | (fsm:on-transition pax:macro) 163 | (fsm:*received-event* variable) 164 | (fsm:*event-data* variable) 165 | (fsm:*state-data* variable) 166 | (fsm:*next-state-data* variable)) 167 | 168 | (in-package :disp) 169 | (pax:defsection @shared-dispatcher (:title "Shared dispatcher") 170 | (disp:shared-dispatcher class)) 171 | 172 | (pax:defsection @dispatcher (:title "Dispatcher") 173 | (disp:dispatcher-base class) 174 | (disp:identifier (pax:reader disp:dispatcher-base)) 175 | (disp:make-dispatcher function) 176 | (disp:dispatch generic-function) 177 | (disp:dispatch-async generic-function) 178 | (disp:stop generic-function) 179 | (disp:workers generic-function) 180 | (disp:dispatch-worker class) 181 | (disp:make-dispatcher-worker function) 182 | 183 | (disp::@shared-dispatcher pax:section)) 184 | 185 | (in-package :stash) 186 | (pax:defsection @stashing (:title "Stashing") 187 | (stash:stashing class) 188 | (stash:stash function) 189 | (stash:unstash-all function)) 190 | 191 | (in-package :router) 192 | (pax:defsection @router (:title "Router") 193 | (router:router class) 194 | (router:make-router function) 195 | (router:add-routee function) 196 | (router:stop function) 197 | (router:routees function) 198 | (router:tell (method () (router:router t))) 199 | (router:ask-s (method () (router:router t))) 200 | (router:ask (method () (router:router t)))) 201 | 202 | (in-package :ev) 203 | (pax:defsection @eventstream (:title "Eventstream") 204 | (ev:eventstream class) 205 | (ev:make-eventstream function) 206 | 207 | (ev:subscribe generic-function) 208 | (ev:unsubscribe generic-function) 209 | (ev:publish generic-function) 210 | 211 | (ev:subscribe (method () (ev:eventstream act:actor))) 212 | (ev:subscribe (method () (asys:actor-system act:actor))) 213 | (ev:subscribe (method () (act:actor act:actor))) 214 | (ev:unsubscribe (method () (ev:eventstream act:actor))) 215 | (ev:unsubscribe (method () (asys:actor-system act:actor))) 216 | (ev:unsubscribe (method () (act:actor act:actor))) 217 | (ev:publish (method () (ev:eventstream t))) 218 | (ev:publish (method () (asys:actor-system t))) 219 | (ev:publish (method () (act:actor t))) 220 | ) 221 | 222 | (in-package :tasks) 223 | (pax:defsection @tasks (:title "Tasks") 224 | (tasks:with-context pax:macro) 225 | (tasks:*task-context* variable) 226 | (tasks:*task-dispatcher* variable) 227 | (tasks:task-yield function) 228 | (tasks:task-start function) 229 | (tasks:task-async function) 230 | (tasks:task-await function) 231 | (tasks:task-shutdown function) 232 | (tasks:task-async-stream function)) 233 | 234 | (in-package :config) 235 | (pax:defsection @config (:title "Config") 236 | (config:config-from function) 237 | (config:retrieve-section function) 238 | (config:retrieve-value function) 239 | (config:retrieve-keys function) 240 | (config:merge-config function)) 241 | 242 | (in-package :wt) 243 | (pax:defsection @scheduler (:title "Scheduler") 244 | (wt:wheel-timer class) 245 | (wt:make-wheel-timer function) 246 | (wt:shutdown-wheel-timer function) 247 | (wt:schedule-once function) 248 | (wt:schedule-recurring function) 249 | (wt:cancel function)) 250 | 251 | (defpackage :sento.docs) 252 | (in-package :sento.docs) 253 | 254 | (pax:defsection @readme (:title "Introduction") 255 | (README.md (pax:include #.(asdf:system-relative-pathname :sento "README.md")))) 256 | 257 | (pax:defsection @api (:title "API documentation") 258 | (asys::@actor-system pax:section) 259 | (ac::@actor-context pax:section) 260 | (act::@actor pax:section) 261 | (agt::@agent pax:section) 262 | (fsm::@fsm pax:section) 263 | (stash::@stashing pax:section) 264 | (disp::@dispatcher pax:section) 265 | (router::@router pax:section) 266 | (ev::@eventstream pax:section) 267 | (future::@future pax:section) 268 | ;;(async-future::@async-future pax:section) 269 | (tasks::@tasks pax:section) 270 | (config::@config pax:section) 271 | (wt::@scheduler pax:section)) 272 | 273 | (pax:defsection @sento (:title "sento documentation") 274 | (@readme pax:section) 275 | (@api pax:section)) 276 | -------------------------------------------------------------------------------- /queues-bench.lisp: -------------------------------------------------------------------------------- 1 | (eval-when (:compile-toplevel) 2 | (ql:quickload '(:lparallel :jpl-queues :sento))) 3 | 4 | (defstruct queue-obj a b c) 5 | 6 | (defparameter *sync-unbounded-queue* 7 | (make-instance 'jpl-queues:synchronized-queue 8 | :queue 9 | (make-instance 'jpl-queues:unbounded-fifo-queue))) 10 | (defparameter *sync-bounded-queue* 11 | (make-instance 'jpl-queues:synchronized-queue 12 | :queue 13 | (make-instance 'jpl-queues:bounded-fifo-queue 14 | :capacity 1000000))) 15 | (defun queue-and-dequeue-jpl (queue) 16 | (loop :repeat 1000000 17 | :do 18 | (progn 19 | (jpl-queues:enqueue 20 | (make-queue-obj :a 1 :b 2 :c 3) 21 | queue) 22 | (jpl-queues:dequeue queue)))) 23 | 24 | (defparameter *sento-unbounded-queue* 25 | (make-instance 'queue:queue-unbounded)) 26 | (defparameter *speedy-queue* 27 | (make-instance 'queue:queue-bounded :max-items 2000000)) 28 | (defun queue-and-dequeue-sento (queue) 29 | (loop :repeat 1000000 30 | :do 31 | (progn 32 | (queue:pushq 33 | queue 34 | (make-queue-obj :a 1 :b 2 :c 3)) 35 | (queue:popq queue)))) 36 | 37 | (defparameter *cons-queue* (lparallel.cons-queue:make-cons-queue)) 38 | (defun queue-and-dequeue-cq (queue) 39 | (loop :repeat 1000000 40 | :do 41 | (progn 42 | (lparallel.cons-queue:push-cons-queue 43 | (make-queue-obj :a 1 :b 2 :c 3) 44 | queue) 45 | (lparallel.cons-queue:pop-cons-queue queue)))) 46 | 47 | (defun run-tests () 48 | (format t "jpl-unbounded:~%") 49 | (time (queue-and-dequeue-jpl *sync-unbounded-queue*)) 50 | (format t "jpl-bounded:~%") 51 | (time (queue-and-dequeue-jpl *sync-bounded-queue*)) 52 | (format t "mabe sento-unbounded queue:~%") 53 | (time (queue-and-dequeue-sento *sento-unbounded-queue*)) 54 | (format t "mabe speedy-queue:~%") 55 | (time (queue-and-dequeue-sento *speedy-queue*)) 56 | (format t "cons-queue unbounded:~%") 57 | (time (queue-and-dequeue-cq *cons-queue*))) 58 | -------------------------------------------------------------------------------- /sento.asd: -------------------------------------------------------------------------------- 1 | (defsystem "sento" 2 | :version "3.4.2" 3 | :author "Manfred Bergmann" 4 | :license "Apache-2" 5 | :description "Actor framework featuring actors and agents for easy access to state and asynchronous operations." 6 | :depends-on ("alexandria" 7 | "log4cl" 8 | "bordeaux-threads" 9 | "cl-speedy-queue" 10 | "str" 11 | "blackbird" 12 | "binding-arrows" 13 | "timer-wheel" 14 | "local-time-duration" 15 | #-abcl "atomics" 16 | ) 17 | :components ((:module "src" 18 | :serial t 19 | :components 20 | ((:module "atomic" 21 | :components 22 | ((:file "atomic-api") 23 | #-abcl (:file "atomic") 24 | #+abcl (:file "atomic-abcl"))) 25 | (:file "config") 26 | (:file "wheel-timer") 27 | (:file "timeutils") 28 | (:file "miscutils") 29 | (:file "fcomputation") 30 | (:file "dispatcher-api") 31 | (:module "queue" 32 | :components 33 | ((:file "queue") 34 | (:file "queue-locked") 35 | ;;#+sbcl (:file "queue-sbcl") 36 | )) 37 | (:module "mbox" 38 | :components 39 | ((:file "message-box"))) 40 | (:file "actor-cell") 41 | (:file "actor-api") 42 | (:file "eventstream-api") 43 | (:file "actor-system-api") 44 | (:file "actor-context-api") 45 | (:file "fasync-completed") 46 | (:file "actor") 47 | (:file "agent") 48 | (:file "eventstream") 49 | (:file "fsm") 50 | (:file "tasks") 51 | (:file "router") 52 | (:file "stash") 53 | (:file "dispatcher") 54 | (:file "actor-context") 55 | (:file "actor-system") 56 | (:module "agent-usecase" 57 | :components 58 | ((:file "agent-usecase-commons") 59 | (:file "hash-agent") 60 | (:file "array-agent"))) 61 | (:file "package")))) 62 | :in-order-to ((test-op (test-op "sento/tests")))) 63 | 64 | (defsystem "sento/tests" 65 | :author "Manfred Bergmann" 66 | :depends-on ("sento" 67 | "fiveam" 68 | "serapeum" 69 | "lparallel" 70 | "cl-mock") 71 | :components ((:module "tests" 72 | :serial t 73 | :components 74 | ((:file "all-test") 75 | (:file "miscutils-test") 76 | (:file "timeutils-test") 77 | (:file "atomic-test") 78 | (:file "config-test") 79 | (:file "wheel-timer-test") 80 | (:file "bounded-queue-test") 81 | (:file "unbounded-queue-test") 82 | (:file "actor-cell-test") 83 | (:file "actor-mp-test") 84 | (:file "agent-test") 85 | (:file "hash-agent-test") 86 | (:file "array-agent-test") 87 | (:file "actor-test") 88 | (:file "fsm-test") 89 | (:file "router-test") 90 | (:file "stash-test") 91 | (:file "tasks-test") 92 | (:file "eventstream-test") 93 | (:file "actor-context-test") 94 | (:file "fcomputation-test") 95 | (:file "fasync-completed-test") 96 | (:file "dispatcher-test") 97 | (:file "actor-system-test") 98 | (:file "actor-tree-test") 99 | (:file "spawn-in-receive-test") 100 | (:file "test-utils") 101 | (:file "message-box-test")))) 102 | :description "Test system for sento" 103 | :perform (test-op (op c) (symbol-call :fiveam :run! 104 | (uiop:find-symbol* '#:test-suite 105 | '#:sento.tests)))) 106 | 107 | ;; -------------------------------- 108 | ;; documentation 109 | ;; -------------------------------- 110 | 111 | (defsystem "sento/docs" 112 | :author "Manfred Bergmann" 113 | :description "Documentation for sento" 114 | :depends-on ("sento" 115 | "mgl-pax/full") 116 | :components ((:file "documentation"))) 117 | 118 | 119 | ;; -------------------------------- 120 | ;; benchmark 121 | ;; -------------------------------- 122 | 123 | (defsystem "sento/bench" 124 | :author "Manfred Bergmann" 125 | :description "Benchmark for Sento" 126 | :depends-on ("sento" 127 | "serapeum" 128 | "trivial-benchmark" 129 | "trivial-garbage") 130 | :components ((:file "bench"))) 131 | 132 | ;; load system 133 | ;; (asdf:load-system "sento") 134 | ;; 135 | ;; test system 136 | ;; (asdf:test-system "sento/tests") 137 | ;; 138 | ;; (hlp:document (asdf:find-system :sento) :only-exported t) 139 | ;; (pax:update-asdf-system-html-docs sento.docs::@sento :sento :target-dir #P"~/docs/") 140 | 141 | #| 142 | 143 | 144 | |# 145 | 146 | -------------------------------------------------------------------------------- /src/actor-api.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.actor 2 | (:use :cl) 3 | (:nicknames :act) 4 | (:export #:make-actor 5 | #:actor 6 | #:tell 7 | #:! 8 | #:ask 9 | #:? 10 | #:ask-s 11 | #:reply 12 | #:become 13 | #:unbecome 14 | #:context 15 | #:path 16 | #:watch 17 | #:unwatch 18 | #:watchers 19 | #:pre-start 20 | #:after-stop 21 | #:*self* 22 | #:*state* 23 | #:*sender*) 24 | (:import-from #:act-cell 25 | #:actor-cell)) 26 | 27 | (in-package :sento.actor) 28 | 29 | (defclass actor (actor-cell) 30 | ((receive :initarg :receive 31 | :initform (error "'receive' must be specified!") 32 | :reader receive 33 | :documentation 34 | "`receive` is a function that has to take 1 parameter: 35 | - `msg`: the received message 36 | The `sender` of the message (if available) accessible with `act:*sender*` from within the receive function or a behavior.") 37 | (behavior :initform nil 38 | :documentation 39 | "Behavior function applied via `act:become` and reverted via `act:unbecome` 40 | `act:behavior` function takes the same parameters as `act:receive`.") 41 | (init-fun :initarg :init 42 | :initform nil 43 | :documentation "Init hook. 44 | Function is called when actor was initialized. 45 | `act:context` is ready setup at that time. 46 | Parameter of the lambda is the actor itself.") 47 | (destroy-fun :initarg :destroy 48 | :initform nil 49 | :documentation "Destroy hook. 50 | Function is called when actor was stopped. 51 | Parameter of the lambda is the actor itself.") 52 | (context :initform nil 53 | :accessor context 54 | :documentation "The `ac:actor-context`") 55 | (watchers :initform '() 56 | :reader watchers 57 | :documentation "List of watchers of this actor.")) 58 | (:documentation 59 | "This is the `actor` class. 60 | 61 | The `actor` does its message handling using the `receive` function. 62 | 63 | The `receive` function takes one argument (the message). For backwards compatibility and for convenience it can still be used to provide an immediate return for `act:ask-s`. `act:tell` and `act:ask` ignore a return value. 64 | 65 | There is asynchronous `tell`, a synchronous `ask-s` and asynchronous `ask` which all can be used to send messages to the actor. `ask-s` provides a synchronous return taken from the `receive` functions return value. 'ask' provides a return wrapped in a future. But the actor has to explicitly use `*sender*` to formulate a response. `tell` is just fire and forget. 66 | 67 | To stop an actors message processing in order to cleanup resouces you should `tell` (or `ask-s`) the `:stop` message. It will respond with `:stopped` (in case of `ask(-s)`).")) 68 | 69 | (defgeneric make-actor (receive &key name state type init destroy &allow-other-keys) 70 | (:documentation 71 | "Constructs an `actor`. 72 | 73 | Arguments: 74 | 75 | - `receive`: message handling function taking one argument, the message. 76 | 77 | - `name`: give the actor a name. Must be unique within an `ac:actor-context`. 78 | 79 | - `type`: Specify a custom actor class as the `:type` key. Defaults to 'actor. 80 | Say you have a custom actor `custom-actor` and want `make-actor` create an instance of it. 81 | Then specify `:type 'custom-actor` on `make-actor` function. 82 | If you have additional initializations to make you can do so in `initialize-instance`. 83 | 84 | - `state`: initialize an actor with a state. (default is `nil`) 85 | 86 | - `init` and `destroy`: are functions that take one argument, the actor instance. 87 | Those hooks are called on (after) initialization and (after) stop respectively. 88 | ")) 89 | 90 | (defgeneric pre-start (actor) 91 | (:documentation 92 | "Generic function definition called after initialization but before messages are accepted. 93 | An `ac:actor-context` is available at this point as well as `act:*state*` variable definition. 94 | 95 | Under normal circumstances one would provide an `init` function at construction of the actor instead (see above). 96 | This generic function is more meant to create specialized actors by providing different implementations.")) 97 | 98 | (defgeneric after-stop (actor) 99 | (:documentation 100 | "Generic function definition that is called after the actor has stopped, that is after the message box is stopped. 101 | No more messages are being processed. 102 | 103 | Under normal circumstances one would provide an `destroy` function at construction of the actor instead (see above). 104 | This generic function is more meant to create specialized actors by providing different implementations.")) 105 | 106 | (defgeneric tell (actor message &optional sender) 107 | (:documentation 108 | "Sends a message to the `actor`. `tell` is asynchronous. 109 | `tell` does not expect a result. If a `sender` is specified the receiver will be able to send a response. 110 | 111 | Alternatively to the `tell` function one can equally use the `!` function designator.")) 112 | 113 | (defgeneric ask-s (actor message &key time-out) 114 | (:documentation 115 | "Sends a message to the `actor`. `ask-s` is synchronous and waits for a result. 116 | Specify `timeout` if a message is to be expected after a certain time. 117 | An `:handler-error` with `timeout` condition will be returned if the call timed out. 118 | 119 | `ask-s` assumes, no matter if `ask-s` is issued from outside or inside an actor, that the response is delivered back to the caller. That's why `ask-s` does block the execution until the result is available. The `receive` function return value will be used as the result of `receive`.")) 120 | 121 | (defgeneric ask (actor message &key time-out) 122 | (:documentation 123 | "Sends a message to the `actor`. A `future` is returned. 124 | Specify `timeout` if a message is to be expected after a certain time. 125 | An `:handler-error` with `timeout` condition will be returned is the call timed out. 126 | 127 | An `ask` is similar to a `ask-s` in that the caller gets back a result 128 | but it doesn't have to actively wait for it. Instead a `future` wraps the result. 129 | However, the internal message handling is based on `tell`. 130 | How this works is that the message to the target `actor` is not 'sent' using the callers thread but instead an anonymous `actor` is started behind the scenes. This anonymous actor can weit for a response from the target actor. The response then fulfills the future. 131 | 132 | Alternatively to the `ask` function one can equally use the `?` function designator.")) 133 | 134 | (defgeneric become (new-behavior) 135 | (:documentation 136 | "Changes the receive of the actor to the given `new-behavior` function. 137 | The `new-behavior` function must accept 3 parameters: the actor instance, the message and the current state. 138 | This function should be called from within the behavior receive function.")) 139 | 140 | (defgeneric unbecome () 141 | (:documentation 142 | "Reverts any behavior applied via `become` back to the default `receive` function. 143 | This function should be called from within the behavior receive function.")) 144 | 145 | (defgeneric context (actor) 146 | (:documentation 147 | "This is the `actor-context` every actor is composed of. 148 | When the actor is created from scratch it has no `actor-context`. 149 | When created through the `actor-context`s, or system's `actor-of` function an `actor-context` will be set.")) 150 | 151 | (defgeneric path (actor) 152 | (:documentation 153 | "The path of the actor, including the actor itself. 154 | The path denotes a tree which starts at the system context.")) 155 | 156 | (defgeneric watch (actor watcher) 157 | (:documentation 158 | "Registers `watcher` as a watcher of `actor`. 159 | Watching lets the watcher know about lifecycle changes of the actor being watched. 160 | I.e.: when it stopped. The message being sent in this case is: `(cons :stopped actor-instance)`")) 161 | 162 | (defgeneric unwatch (actor watcher) 163 | (:documentation 164 | "Unregisters `watcher` of `actor`.")) 165 | 166 | (defgeneric watchers (actor) 167 | (:documentation 168 | "Returns a list of watchers of `actor`.")) 169 | -------------------------------------------------------------------------------- /src/actor-cell.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.actor-cell 2 | (:use :cl) 3 | (:nicknames :act-cell) 4 | (:import-from #:mesgb 5 | #:inner-msg 6 | #:cancelled-p) 7 | (:export #:actor-cell 8 | #:cell 9 | #:name 10 | #:msgbox 11 | #:state 12 | #:*state* 13 | #:*self* 14 | #:*sender* 15 | ;; API 16 | #:handle-call 17 | #:handle-cast 18 | #:stop 19 | #:call 20 | #:cast 21 | #:running-p)) 22 | 23 | (in-package :sento.actor-cell) 24 | 25 | (defvar *self* nil 26 | "The 'own' actor instance. Dynamically bound and available upon calling `receive` function.") 27 | (defvar *state* nil 28 | "The 'state' of the actor. Dynamically bound and available in `receive` function.") 29 | (defvar *sender* nil 30 | "The `*sender*` is dynamically bound and available in `receive` function, when it is known.") 31 | 32 | (defstruct actor-cell-state (running t :type boolean)) 33 | 34 | (defclass actor-cell () 35 | ((name :initarg :name 36 | :initform (string (gensym "actor-")) 37 | :reader name 38 | :documentation 39 | "The name of the actor/actor-cell. If no name is specified a default one is applied.") 40 | (state :initarg :state 41 | :initform nil 42 | :reader state 43 | :documentation 44 | "The encapsulated state.") 45 | (internal-state :initform (make-actor-cell-state) 46 | :documentation 47 | "The internal state of the server.") 48 | (msgbox :initform nil 49 | :accessor msgbox 50 | :documentation 51 | "The `message-box`. By default the `actor`/`actor-cell` has no message-box. 52 | When the actor is created through the `actor-context` of an actor, or the `actor-system` 53 | then it will be populated with a message-box.")) 54 | (:documentation 55 | "`actor-cell` is the base of the `actor`. 56 | It encapsulates state and can executes async operations. 57 | State can be changed by `setf`ing `*state*` special variable from inside `receive` function, via calling `call` or `cast`. 58 | Where `call` is waiting for a result and `cast` does not. 59 | For each `call` and `cast` handlers must be implemented by subclasses. 60 | 61 | It uses a `message-box` to processes the received messages. 62 | When the `actor`/`actor-cell` was created ad-hoc (out of the `actor-system`/`actor-context`), 63 | it will not have a message-box and can't process messages. 64 | When the `actor` is created through the `actor-system` or `actor-context`, 65 | one can decide what kind of message-box/dispatcher should be used for the new `actor`. 66 | 67 | See `actor-context` `actor-of` method for more information on this. 68 | 69 | To stop an `actor` message handling and you can send the `:stop` message 70 | either via `call` (which will respond with `:stopped`) or `cast`. 71 | This is to cleanup thread resources when the actor is not needed anymore. 72 | 73 | Note: the `actor-cell` uses `call` and `cast` functions which translate to `ask-s` and `tell` on the `actor`.")) 74 | 75 | (defmethod print-object ((obj actor-cell) stream) 76 | (print-unreadable-object (obj stream :type t) 77 | (with-slots (name state internal-state msgbox) obj 78 | (format stream "~a, running: ~a, state: ~a, message-box: ~a" 79 | name 80 | (slot-value internal-state 'running) 81 | state 82 | msgbox)))) 83 | 84 | (defmethod initialize-instance :after ((obj actor-cell) &key) 85 | (with-slots (name) obj 86 | (unless name 87 | (setf name (string (gensym "actor-")))) 88 | (log:debug "~a initialized: ~a" name obj))) 89 | 90 | ;; ----------------------------------------------- 91 | ;; public functions / API 92 | ;; ----------------------------------------------- 93 | 94 | (defgeneric handle-call (actor-cell message) 95 | (:documentation 96 | "Handles calls to the server. Must be implemented by subclasses. 97 | The result of the last expression of this function is returned back to the 'caller'. 98 | State of the cell can be changed via `setf`ing `*state*` variable.")) 99 | 100 | (defgeneric handle-cast (actor-cell message) 101 | (:documentation 102 | "Handles casts to the server. Must be implemented by subclasses. 103 | State of the cell can be changed via `setf`ing `*state*` variable.")) 104 | 105 | (defgeneric stop (actor-cell &optional wait) 106 | (:documentation "Stops the actor-cells message processing. 107 | There are the following ways to stop an actor (cell). 108 | 109 | 1. by calling this function. 110 | The actor will finish processing the current message. 111 | All queued messages will be discarded. 112 | No new messages will be accepted. 113 | `wait`: waits until the cell is stopped (only applied to `:pinned` dispatcher). 114 | 115 | 2. by sending `:terminate` to actor. 116 | This is effectively the same as calling `stop` method. 117 | 118 | 3. by sending `:stop` to the actor (cell). 119 | This won't allow to wait when the actor is stopped, even not with `ask-s`. 120 | The `:stop` message (symbol) is normally processed by the actors message processing. 121 | The actor will not accept more messages.")) 122 | 123 | ;; --------------------------------- 124 | ;; Impl 125 | ;; --------------------------------- 126 | 127 | (defun call (actor-cell message &key (time-out nil)) 128 | "Send a message to a actor-cell instance and wait for a result. 129 | Specify a timeout in seconds if you require a result within a certain period of time. 130 | Be aware though that this is a resource intensive wait based on a waiting thread. 131 | The result can be of different types. 132 | Normal result: the last expression of `handle-call` (or `receive` in `act:actor`) implementation. 133 | Error result: `(cons :handler-error )' 134 | In case of time-out the error condition is a bt2:timeout." 135 | (when message 136 | (let ((result (submit-message actor-cell message t nil time-out))) 137 | (log:debug "~a: message process result: ~a" (name actor-cell) result) 138 | result))) 139 | 140 | (defun cast (actor-cell message &optional sender) 141 | "Sends a message to a actor-cell asynchronously. There is no result. 142 | If a `sender' is specified the result will be sent to the sender." 143 | (when message 144 | (let ((result (submit-message actor-cell message nil sender nil))) 145 | (log:debug "~a: message process result: ~a" (name actor-cell) result) 146 | result))) 147 | 148 | (defun running-p (actor-cell) 149 | "Returns true if this server is running. `nil` otherwise." 150 | (with-slots (internal-state) actor-cell 151 | (slot-value internal-state 'running))) 152 | 153 | (defmethod stop ((self actor-cell) &optional (wait nil)) 154 | (log:debug "~a: stopping on actor-cell: ~a" (name self) self) 155 | (with-slots (msgbox internal-state) self 156 | (when (slot-value internal-state 'running) 157 | (setf (slot-value internal-state 'running) nil) 158 | (when msgbox 159 | (mesgb:stop msgbox wait))))) 160 | 161 | ;; ----------------------------------------------- 162 | ;; internal functions 163 | ;; ----------------------------------------------- 164 | 165 | (defmacro with-sender (sender &rest body) 166 | `(let ((*sender* ,sender)) 167 | ,@body)) 168 | 169 | (defun submit-message (actor-cell message withreply-p sender time-out) 170 | "Submitting a message. 171 | In case of `withreply-p`, the `response` is filled because submitting to the message-box is synchronous. 172 | Otherwise submitting is asynchronous and `response` is just `t`. 173 | In case the actor-cell was stopped it will respond with just `:stopped`. 174 | In case no message-box is configured this function responds with `:no-message-handling`." 175 | (log:debug "~a: submitting message: ~a, withreply-p: ~a, sender: ~a, timeout: ~a" 176 | (name actor-cell) message withreply-p sender time-out) 177 | 178 | (when (eq message :terminate) 179 | (stop actor-cell) 180 | (return-from submit-message :terminated)) 181 | 182 | (with-slots (internal-state msgbox) actor-cell 183 | (unless (actor-cell-state-running internal-state) 184 | (return-from submit-message :stopped)) 185 | (unless msgbox 186 | (return-from submit-message :no-message-handling))) 187 | 188 | (handler-case 189 | (mesgb:submit 190 | (slot-value actor-cell 'msgbox) 191 | message 192 | withreply-p 193 | time-out 194 | (list #'act-cell::handle-message actor-cell sender withreply-p)) 195 | (timeutils:ask-timeout (c) 196 | (log:warn "~a: ask-s timeout: ~a" (name actor-cell) c) 197 | (cons :handler-error c)))) 198 | 199 | ;; ------------------------------------------------ 200 | ;; message handling --------------------- 201 | ;; ------------------------------------------------ 202 | 203 | (defun handle-message (message actor-cell sender withreply-p) 204 | "This function is submitted as `handler-fun` to message-box." 205 | (log:debug "~a: handling message: ~a" (name actor-cell) message) 206 | (with-sender sender 207 | (handler-case 208 | (let ((internal-handle-result (handle-message-internal actor-cell message))) 209 | (case internal-handle-result 210 | (:resume 211 | (with-slots (state) actor-cell 212 | (let* ((*self* actor-cell) 213 | (*state* state) 214 | (handle-result 215 | (handle-message-user actor-cell message withreply-p))) 216 | (setf state *state*) 217 | handle-result))) 218 | (t internal-handle-result))) 219 | (serious-condition (c) 220 | (log:error "~a: error condition was raised: ~%~a~%" 221 | (name actor-cell) 222 | c) 223 | (cons :handler-error c))))) 224 | 225 | (defun handle-message-internal (actor-cell message) 226 | "A `:stop` message will response with `:stopping` and the user handlers are not called. 227 | Otherwise the result is `:resume` to resume user message handling." 228 | (log:trace "~a: internal handle-message: ~a" (name actor-cell) message) 229 | (case message 230 | (:stop (progn 231 | (stop actor-cell) 232 | :stopped)) 233 | (t :resume))) 234 | 235 | (defun handle-message-user (actor-cell message withreply-p) 236 | "The user defined message handler. 237 | Effectively this calls the `handle-call` or `handle-cast` functions." 238 | (log:trace "~a: user handle message: ~a" (name actor-cell) message) 239 | (if withreply-p 240 | (handle-call actor-cell message) 241 | (handle-cast actor-cell message))) 242 | -------------------------------------------------------------------------------- /src/actor-context-api.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.actor-context 2 | (:use :cl) 3 | (:nicknames :ac) 4 | (:export #:actor-context 5 | #:make-actor-context 6 | ;; protocol 7 | #:actor-of 8 | #:find-actors 9 | #:all-actors 10 | #:stop 11 | #:notify 12 | #:shutdown 13 | ;; 14 | #:system 15 | #:id 16 | ;; conditions 17 | #:actor-name-exists)) 18 | (in-package :sento.actor-context) 19 | 20 | (defgeneric actor-of (context 21 | &key receive init destroy dispatcher state type name 22 | &allow-other-keys) 23 | (:documentation "Interface for creating an actor. 24 | 25 | **!!! Attention:** this factory function wraps the `act:make-actor` functionality to something more simple to use. 26 | Using this function there is no need to use `act:make-actor`. 27 | 28 | `context` is either an `asys:actor-system`, an `ac:actor-context`, or an `act:actor` (any type of actor). 29 | The new actor is created in the given context. 30 | 31 | - `:receive` is required and must be a 1-arity function where the arguments is received message object. 32 | The function can be just a lambda like `(lambda (msg) ...)`. 33 | - `:init`: is an optional initialization function with one argument: the actor instance (self). 34 | This represents a 'start' hook that is called after the actor was fully initialized. 35 | - `:destroy`: is an optional destroy function also with the actor instance as argument. 36 | This function allows to unsubsribe from event-stream or such. 37 | - `:state` key can be used to initialize with a state. 38 | - `:dispatcher` key can be used to define the message dispatcher manually. 39 | Options that are available by default are `:shared` (default) and `:pinned`. When you defined a custom dispatcher it can be specified here. 40 | - `:type` can specify a custom actor class. See `act:make-actor` for more info. 41 | - `:name` to set a specific name to the actor, otherwise a random name will be used. 42 | 43 | Additional options: 44 | 45 | - `:queue-size` limits the message-box's size. By default, it is unbounded. 46 | - `:mbox-type` specify a custom message-box type similar as can be done is dispatcher config. 47 | It must be a subtype of `mesgb:message-box/dp`. 48 | ")) 49 | 50 | (defgeneric find-actors (context path &key test key) 51 | (:documentation "Returns actors to be found by the criteria of: 52 | 53 | - `context`: an `AC:ACTOR-CONTEXT`, or an `ACT:ACTOR` or an `ASYS:ACTOR-SYSTEM` as all three implement `find-actors`. 54 | - `path`: a path designator to be found. This can be just an actor name, like 'foo', then `find-actors` will only look in the given context for the actor. It can also be: 'foo/bar', a relative path, in which case `find-actors` will traverse the path (here 'bar' is a child of 'foo') to the last context and will try to find the actor by name there, 'bar' in this case. Also possible is a root path like '/user/foo/bar' which will start traversing contexts started from the root context, which is the actor-system. 55 | - `test`: a 2-arity test function where the 1st argument is the `path`, the 2nd is the a result of the `key` function (which defaults to `ACT-CELL:NAME`, so the name of the actor). The default function for `test` is `STRING=`. However, in case of a multi-subpath `path` both `test` and `key` only apply to the last path component, which designates the actor name to be found. 56 | - `key`: a 1-arity function applied on an actor instance. Defaults to `ACT-CELL:NAME`. 57 | 58 | Depending on `test` function the last path component can be used as a wildcard when using a `test` function like `STR:STARTS-WITH-P` or `STR:CONTAINSP` for example.")) 59 | 60 | (defgeneric all-actors (context) 61 | (:documentation "Retrieves all actors of this context as a list")) 62 | 63 | (defgeneric stop (context actor &key wait) 64 | (:documentation 65 | "Stops the given actor on the context. 66 | The context may either be an `actor-context`, or an `actor-system`. 67 | The actor is then also removed from the context. 68 | Specify `wait` as `T` to block until the actor is stopped (default `NIL`).")) 69 | 70 | (defgeneric shutdown (context &key wait) 71 | (:documentation 72 | "Stops all actors in this context. 73 | When the context is an `actor-context` this still stop the actor context and all its actors. 74 | For the `actor-system` it will stop the whole system with all actors. 75 | Specify `wait` as `T` to block until all actors of the context are stopped (default `NIL`).")) 76 | 77 | (defgeneric notify (context actor notification) 78 | (:documentation 79 | "Notify the `actor-context` about something that happened to an actor. 80 | Current exists: 81 | 82 | - `:stopped`: this will remove the actor from the context.")) 83 | 84 | ;; ------------------------------------- 85 | ;; Conditions 86 | ;; ------------------------------------- 87 | 88 | (define-condition actor-name-exists (error) 89 | ((name :initarg :name 90 | :reader name)) 91 | (:report (lambda (condition stream) 92 | (format stream "Actor with name '~a' already exists!" (name condition))))) 93 | -------------------------------------------------------------------------------- /src/actor-context.lisp: -------------------------------------------------------------------------------- 1 | (in-package :sento.actor-context) 2 | 3 | (defclass actor-context () 4 | ((id :initarg :id 5 | :initform nil 6 | :reader id 7 | :documentation 8 | "The id of this actor-context. Usually a string.") 9 | (actors :initform (atomic:make-atomic-reference :value '()) 10 | :documentation 11 | "A list of actors. 12 | This is internal API. Use `all-actors` or `find-actors` instead.") 13 | (system :initform nil 14 | :reader system 15 | :documentation 16 | "A reference to the `actor-system`.")) 17 | (:documentation "`actor-context` deals with creating and maintaining actors. 18 | The `actor-system` and the `actor` itself are composed of an `actor-context`.")) 19 | 20 | ;; -------------------------------------- 21 | ;; private functions 22 | ;; -------------------------------------- 23 | 24 | (defmethod actors ((context actor-context)) 25 | (atomic:atomic-get (slot-value context 'actors))) 26 | 27 | (defun %get-shared-dispatcher (system identifier) 28 | (getf (asys:dispatchers system) identifier)) 29 | 30 | (defun %get-dispatcher-config (config dispatcher-id) 31 | (let* ((disp-config (config:retrieve-section config :dispatchers)) 32 | (dispatcher-keys (config:retrieve-keys disp-config))) 33 | (when (find dispatcher-id dispatcher-keys) 34 | (config:retrieve-section disp-config dispatcher-id)))) 35 | 36 | (defun %add-actor (context actor) 37 | (let ((atomic-actors (slot-value context 'actors))) 38 | (atomic:atomic-swap atomic-actors (lambda (old-actors) 39 | (cons actor old-actors))) 40 | actor)) 41 | 42 | (defun %remove-actor (context actor) 43 | (let ((atomic-actors (slot-value context 'actors))) 44 | (atomic:atomic-swap atomic-actors 45 | (lambda (old-actors) 46 | (remove-if (lambda (a) 47 | (or (eq a actor) 48 | (string= (act-cell:name a) 49 | (act-cell:name actor)))) 50 | old-actors))))) 51 | 52 | (defun %message-box-for-dispatcher-id (context dispatcher-id queue-size mbox-type) 53 | (case dispatcher-id 54 | (:pinned (make-instance 'mesgb:message-box/bt 55 | :max-queue-size queue-size)) 56 | (otherwise (let* ((asys (system context)) 57 | (sys-config (asys:config asys)) 58 | (disp-config (%get-dispatcher-config sys-config dispatcher-id)) 59 | (dispatcher (%get-shared-dispatcher asys dispatcher-id))) 60 | (unless dispatcher 61 | (error (format nil "No such dispatcher identifier '~a' exists!" dispatcher-id))) 62 | ;; if dispatcher exists, the config does, too. 63 | (let ((eff-mbox-type (if mbox-type 64 | mbox-type 65 | (getf disp-config :mbox-type 'mesgb:message-box/dp)))) 66 | (make-instance eff-mbox-type 67 | :dispatcher dispatcher 68 | :max-queue-size queue-size)))))) 69 | 70 | (defun %find-actor-by-name (context name) 71 | (find-if (lambda (a) 72 | (let ((seq-name (act-cell:name a))) 73 | (or (eq name seq-name) 74 | (string= name seq-name)))) 75 | (actors context))) 76 | 77 | (defun %find-actors (context path &key test key) 78 | (let ((actors-to-search (all-actors context))) 79 | (miscutils:filter (lambda (x) 80 | (funcall test path (funcall key x))) 81 | actors-to-search))) 82 | 83 | (defun %verify-actor (context actor) 84 | "Checks certain things on the actor before it is attached to the context." 85 | (let* ((actor-name (act-cell:name actor)) 86 | (exists-actor-p (%find-actor-by-name context actor-name))) 87 | (when exists-actor-p 88 | (log:error "Actor with name '~a' already exists!" actor-name) 89 | (error (make-condition 'actor-name-exists :name actor-name))))) 90 | 91 | (defun %create-actor (context create-fun dispatcher-id queue-size mbox-type) 92 | (let ((actor (funcall create-fun))) 93 | (when actor 94 | (%verify-actor context actor) 95 | (act::finalize-initialization actor 96 | (%message-box-for-dispatcher-id context dispatcher-id queue-size mbox-type) 97 | (make-actor-context (system context) 98 | (miscutils:mkstr (id context) "/" (act-cell:name actor))))) 99 | actor)) 100 | 101 | (defun %actor-of (context create-fun &key (dispatcher :shared) (queue-size 0) mbox-type) 102 | "See `ac:actor-of`" 103 | (let ((created (%create-actor context create-fun dispatcher queue-size mbox-type))) 104 | (when created 105 | (act:watch created context) 106 | (%add-actor context created)))) 107 | 108 | ;; -------------------------------------- 109 | ;; public interface 110 | ;; -------------------------------------- 111 | 112 | (defun make-actor-context (actor-system &optional (id nil)) 113 | "Creates an `actor-context`. Requires a reference to `actor-system` 114 | `id` is an optional value that can identify the `actor-context`. 115 | Creating an actor-context manually is usually not needed. 116 | An `asys:actor-system` implements the `actor-context` protocol. 117 | An `act:actor` contains an `actor-context`." 118 | (let ((context (make-instance 'actor-context :id id))) 119 | (with-slots (system) context 120 | (setf system actor-system)) 121 | context)) 122 | 123 | (defmethod actor-of ((context actor-context) 124 | &rest rest 125 | &key 126 | receive 127 | (init nil) 128 | (destroy nil) 129 | (dispatcher :shared) 130 | (state nil) 131 | (type 'act:actor) 132 | (name nil) 133 | (queue-size nil) 134 | &allow-other-keys) 135 | "See `ac:actor-of`." 136 | (check-type receive function "a function!") 137 | 138 | (let ((mbox-type (getf rest :mbox-type))) 139 | (alexandria:remove-from-plistf rest 140 | :queue-size 141 | :dispatcher 142 | :mbox-type) 143 | (%actor-of context 144 | (lambda () (apply #'act:make-actor receive 145 | :init init 146 | :destroy destroy 147 | :state state 148 | :type type 149 | :name name 150 | rest)) 151 | :dispatcher dispatcher 152 | :queue-size queue-size 153 | :mbox-type mbox-type))) 154 | 155 | 156 | ;; test 2-arity function with 'path' and 'act-cell-name' (default) 157 | (defmethod find-actors ((context actor-context) path &key (test #'string=) (key #'act-cell:name)) 158 | "See `ac:find-actors`" 159 | (if (str:starts-with-p "/" path) 160 | ;; root path, delegate to system 161 | (find-actors (system context) path :test test :key key) 162 | (let ((path-comps (str:split "/" path)) 163 | (context context)) 164 | (loop :for path-comp :in (butlast path-comps) 165 | :for actor = (find path-comp (all-actors context) 166 | :test #'string= 167 | :key #'act-cell:name) 168 | :do (if actor 169 | (setf context (act:context actor)) 170 | (error (format nil "Cannot find path component ~a" path-comp)))) 171 | (%find-actors context (car (last path-comps)) :test test :key key)))) 172 | 173 | (defmethod all-actors ((context actor-context)) 174 | "See `ac:all-actors`" 175 | (actors context)) 176 | 177 | (defmethod stop ((context actor-context) actor &key (wait nil)) 178 | "See `ac:stop`" 179 | (act-cell:stop actor wait)) 180 | 181 | (defmethod shutdown ((context actor-context) &key (wait nil)) 182 | "See `ac:shutdown`" 183 | (dolist (actor (all-actors context)) 184 | (act-cell:stop actor wait))) 185 | 186 | (defmethod notify ((context actor-context) actor notification) 187 | (case notification 188 | (:stopped 189 | (progn 190 | (%remove-actor context actor) 191 | (log:debug "Actor removed: ~a" (act-cell:name actor)))))) 192 | -------------------------------------------------------------------------------- /src/actor-system-api.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.actor-system 2 | (:use :cl) 3 | (:nicknames :asys) 4 | (:export #:make-actor-system 5 | #:actor-system 6 | #:dispatchers 7 | #:evstream 8 | #:scheduler 9 | #:config 10 | #:register-dispatcher 11 | #:register-new-dispatcher 12 | #:*default-config*)) 13 | 14 | (in-package :sento.actor-system) 15 | 16 | (defparameter *default-config* 17 | '(:dispatchers 18 | (:shared (:workers 4 :strategy :random :mbox-type mesgb:message-box/dp)) 19 | :timeout-timer 20 | (:resolution 100 :max-size 500) 21 | :eventstream 22 | (:dispatcher-id :shared) 23 | :scheduler 24 | (:enabled :true :resolution 100 :max-size 500)) 25 | "The default config used when creating an `asys:actor-system`. 26 | The actor-system constructor allows to provide custom config options that override the defaults. 27 | 28 | The constructor provided configuration does not need to specify all parts of the config, 29 | rather, what is provided is merged with `*default-config*`. 30 | That means e.g. specifying an additional dispatcher, one just has to provide this to the constructor: 31 | 32 | ``` 33 | '(:dispatchers 34 | (:my-disp (:workers 4))) 35 | ``` 36 | 37 | For all other parameters the defaults will be used, even `:workers` does not need to be there. 38 | The defaults, when omitted, are: 39 | - workers = 2 40 | - strategy = :random 41 | - mbox-type = 'mesgb:message-box/dp' 42 | 43 | If you want to just modify parts of the config, i.e. the strategy, then one can do: 44 | 45 | ``` 46 | '(:dispatchers 47 | (:shared (:strategy :round-robin))) 48 | ``` 49 | 50 | This will just change the strategy to `:round-robin`. 51 | 52 | Note that `mbox-type` must be a subtype of `mesgb:message-box/dp`. 53 | ") 54 | -------------------------------------------------------------------------------- /src/agent-usecase/agent-usecase-commons.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.agent.usecase-commons 2 | (:use :cl) 3 | (:nicknames :agent.usecase-commons) 4 | (:export #:model 5 | #:make-model 6 | #:model-object 7 | #:model-err-fun 8 | #:with-update-handler 9 | #:with-get-handler)) 10 | 11 | (in-package :sento.agent.usecase-commons) 12 | 13 | (defstruct model 14 | (object nil) 15 | (err-fun nil)) 16 | 17 | (defmacro with-update-handler (&body body) 18 | `(lambda (model) 19 | (handler-case 20 | ,@body 21 | (error (c) 22 | (when (model-err-fun model) 23 | (funcall (model-err-fun model) c)))) 24 | model)) 25 | 26 | (defmacro with-get-handler (&body body) 27 | `(lambda (model) 28 | (handler-case 29 | ,@body 30 | (error (c) c)))) 31 | 32 | -------------------------------------------------------------------------------- /src/agent-usecase/array-agent.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.agent.array 2 | (:use :cl :sento.agent.usecase-commons) 3 | (:nicknames :agtarray) 4 | (:export #:make-array-agent 5 | #:agent-elt 6 | #:agent-push 7 | #:agent-push-and-getidx 8 | #:agent-pop 9 | #:agent-delete 10 | #:agent-doarray)) 11 | 12 | (in-package :sento.agent.array) 13 | 14 | (defun make-array-agent (context &key 15 | initial-array 16 | (error-fun nil) 17 | (dispatcher-id :shared)) 18 | "Creates an agent that wraps a CL array/vector. 19 | 20 | - `context`: something implementing `ac:actor-context` protocol like `asys:actor-system`. Specifying `nil` here creates an agent outside of an actor system. The user has to take care of that himself. 21 | - `initial-array`: specify an initial array/vector. 22 | - `error-fun`: a 1-arrity function taking a condition that was raised. 23 | Use this to get notified of error when using the update functions of the agent. 24 | - `dispatcher-id`: a dispatcher. defaults to `:shared`." 25 | (check-type initial-array array) 26 | (agt:make-agent (lambda () (make-model :object initial-array 27 | :err-fun error-fun)) 28 | context dispatcher-id)) 29 | 30 | (defun agent-elt (index array-agent) 31 | "Retrieves the value of the specified index of the array. `agent-elt` allows `setf`ing like: 32 | 33 | ``` 34 | (setf (agent-elt 0 cut) 11) 35 | ``` 36 | 37 | - `index`: the index to retrieve. 38 | - `array-agent`: the array agent instance. 39 | 40 | In case of error `agent-elt` returns the error condition that `elt` raises. 41 | 42 | The `setf` functionality will call `err-fun` on error if it has been configured." 43 | (agt:agent-get array-agent 44 | (lambda (model) 45 | (handler-case 46 | (elt (model-object model) index) 47 | (error (c) c))))) 48 | 49 | (defun agent-set (index array-agent value) 50 | "Internal for `setf`." 51 | (agt:agent-update array-agent 52 | (with-update-handler 53 | (setf (elt (model-object model) index) value))) 54 | value) 55 | 56 | (defsetf agent-elt agent-set) 57 | 58 | (defun agent-push (item array-agent) 59 | "Pushes a value to the array/vector. Internally uses `vector-push-extend`, so the array must have a `fill-pointer`. 60 | 61 | `item`: item to push. 62 | `array-agent`: the array agent instance. 63 | 64 | On error it will call `err-fun` with the raised condition, if `err-fun` has been configured." 65 | (agt:agent-update array-agent 66 | (with-update-handler 67 | (vector-push-extend item (model-object model))))) 68 | 69 | (defun agent-push-and-getidx (item array-agent) 70 | "Pushes `item` to the array. This function is similar to `agent-push` but returns the index of the pushed value similar as `vector-push` does. Therefore it is based on the somewhat slower `ask-s` actor pattern. So if you don't care about the new index of the pushed item use `agent-push` instead. But this one is able to immediately return error conditions that may occur on `vector-push`. 71 | 72 | - `item`: item to push. 73 | - `array-agent`: the array agent instance." 74 | (agt:agent-get array-agent 75 | (with-get-handler 76 | (vector-push-extend item (model-object model))))) 77 | 78 | (defun agent-pop (array-agent) 79 | "Pops from array and returns the popped value. Internally uses `vector-pop`, so the array must have a `fill-pointer`. In case of error from using `vector-pop` the condition is returned. 80 | 81 | - `array-agent`: the array agent instance." 82 | (agt:agent-get array-agent 83 | (with-get-handler 84 | (vector-pop (model-object model))))) 85 | 86 | (defun agent-delete (item array-agent &rest delete-args) 87 | "Deletes item from array. Internally uses `delete`. Returns `T`. 88 | 89 | - `item`: the item to delete. 90 | - `array-agent`: the array agent instance. 91 | - `delete-args`: any arguments passed on to `delete`." 92 | (agt:agent-update array-agent 93 | (with-update-handler 94 | (let ((del-result (apply #'delete item (model-object model) delete-args))) 95 | (setf (model-object model) del-result) 96 | del-result)))) 97 | 98 | (defun agent-doarray (fun array-agent) 99 | "'Do' arbitrary atomic operation on the array. 100 | 101 | - `fun`: is a 1-arity function taking the array. This function can operate on the array without interference from other threads. The result of this function must be an array which will be the new agent state. 102 | - `array-agent`: is the `array-agent` instance. 103 | 104 | The result of `agent-doarray` is `T`." 105 | (agt:agent-update array-agent 106 | (lambda (model) 107 | (setf (model-object model) 108 | (funcall fun (model-object model))) 109 | model))) 110 | -------------------------------------------------------------------------------- /src/agent-usecase/hash-agent.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.agent.hash 2 | (:use :cl :sento.agent.usecase-commons) 3 | (:nicknames :agthash) 4 | (:export #:make-hash-agent 5 | #:agent-gethash 6 | #:agent-remhash 7 | #:agent-clrhash 8 | #:agent-dohash)) 9 | 10 | (in-package :sento.agent.hash) 11 | 12 | 13 | (defun make-hash-agent (context &key 14 | initial-hash-table 15 | (error-fun nil) 16 | (dispatcher-id :shared)) 17 | "Creates an agent that wraps a CL hash-table. 18 | 19 | - `context`: something implementing `ac:actor-context` protocol like `asys:actor-system`. Specifying `nil` here creates an agent outside of an actor system. The user has to take care of that himself. 20 | - `initial-hash-table`: specify an initial hash-table. 21 | - `error-fun`: a 1-arrity function taking a condition that was raised. 22 | Use this to get notified of error when using the update functions of the agent. 23 | - `dispatcher-id`: a dispatcher. defaults to `:shared`." 24 | (check-type initial-hash-table hash-table) 25 | (agt:make-agent (lambda () 26 | (make-model :object initial-hash-table 27 | :err-fun error-fun)) 28 | context dispatcher-id)) 29 | 30 | (defun agent-puthash (key hash-agent value) 31 | "Internal" 32 | (agt:agent-update hash-agent 33 | (with-update-handler 34 | (setf (gethash key (model-object model)) value))) 35 | value) 36 | 37 | (defun agent-gethash (key hash-agent) 38 | "Retrieves value from hash-table, or `nil` if it doesn't exist. 39 | See `cl:gethash` for more info. 40 | 41 | This supports setting a hash using `setf` in the same way as with `cl:hash-table`. 42 | 43 | Returns any raised condition or the value from `gethash`." 44 | (agt:agent-get hash-agent 45 | (with-get-handler 46 | (gethash key (model-object model))))) 47 | 48 | (defsetf agent-gethash agent-puthash) 49 | 50 | (defun agent-remhash (key hash-agent) 51 | "Delete a hash-table entry. See `cl:remhash`. 52 | Returns `T` if entry existed, `NIL` otherwise." 53 | (let ((hash-table (agt:agent-get-quick hash-agent 54 | (lambda (model) (model-object model))))) 55 | (if (gethash key hash-table) 56 | (agt:agent-update hash-agent 57 | (with-update-handler 58 | (remhash key (model-object model)))) 59 | nil))) 60 | 61 | (defun agent-clrhash (hash-agent) 62 | "Clears the hash-table. See `cl:clrhash`." 63 | (agt:agent-update hash-agent 64 | (with-update-handler 65 | (clrhash (model-object model))))) 66 | 67 | (defun agent-dohash (fun hash-agent) 68 | "'Do' arbitrary atomic operation on the hash-table. 69 | 70 | - `fun`: is a 1-arity function taking the hash-table. This function can operate on the hash-table without interference from other threads. The result of this function must be a hash-table. 71 | - `hash-agent`: is the `hash-agent` instance. 72 | 73 | The result of `agent-dohash` is `T`." 74 | (agt:agent-update hash-agent 75 | (lambda (model) 76 | (setf (model-object model) 77 | (funcall fun (model-object model))) 78 | model))) 79 | -------------------------------------------------------------------------------- /src/agent.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.agent 2 | (:use :cl :sento.actor) 3 | (:nicknames :agt) 4 | (:import-from #:sento.actor-cell 5 | #:running-p 6 | #:state 7 | #:msgbox) 8 | (:import-from #:mesgb 9 | #:message-box/bt) 10 | (:export #:make-agent 11 | #:agent-get 12 | #:agent-get-quick 13 | #:agent-update 14 | #:agent-update-and-get 15 | #:agent-stop 16 | #:agent)) 17 | 18 | (in-package :sento.agent) 19 | 20 | (defclass agent (actor) () 21 | (:documentation 22 | "Specialized `actor` class called `agent`. 23 | It is meant primarily to encapsulate state. 24 | To access state it provides `agent-get` and `agent-update` to update state. 25 | Stop an agent with `agent-stop` to free resources (threads).")) 26 | 27 | (defun receive (message) 28 | "This is the agents actor receive function implementation. 29 | This rarely (if at all) needs to change because the agent is very specific." 30 | (cond 31 | ((consp message) 32 | (case (car message) 33 | (:get (funcall (cdr message) *state*)) 34 | (:update (setf *state* (funcall (cdr message) *state*))) 35 | (:update-and-get 36 | (let ((new-state (funcall (cdr message) *state*))) 37 | (setf *state* new-state) 38 | new-state)))))) 39 | 40 | (defun make-agent (state-fun &optional actor-context (dispatcher-id :shared)) 41 | "Makes a new `agent` instance. 42 | 43 | - `state-fun` is a function that takes no parameter and provides the initial state of the `agent` as return value. 44 | - `actor-context`: optionally specify an `asys:actor-system` as `ac:actor-context`. If specified the agent will be registered in the system and destroyed with it should the `asys:actor-system` be destroyed. In addition the agent will use the systems shared message dispatcher and will _not_ create it's own. 45 | - `dispatcher-id`: the dispatcher is configurable. Default is `:shared`. But you may use also `:pinned` or a custom configured one. Be aware that `:shared` of a custom dispatcher only works if an `actor-context` was specified." 46 | (let* ((state (funcall state-fun)) 47 | (agent (if actor-context 48 | (ac:actor-of actor-context 49 | :receive #'receive 50 | :state state 51 | :name (string (gensym "agent-")) 52 | :dispatcher dispatcher-id) 53 | (make-instance 'agent :state state 54 | :name (string (gensym "agent-")) 55 | :receive #'receive)))) 56 | (unless actor-context 57 | (setf (msgbox agent) (make-instance 'message-box/bt))) 58 | agent)) 59 | 60 | (defun agent-get-quick (agent get-fun) 61 | "Gets the current state with bypassing the messaging. 62 | If you need consistent results this function should not be used." 63 | (with-slots (state) agent 64 | (if (running-p agent) 65 | (funcall get-fun state) 66 | :stopped))) 67 | 68 | (defun agent-get (agent get-fun) 69 | "Gets the current state of the `agent`. 70 | `get-fun` must accept one parameter. That is the current-state of the `agent`. 71 | To return the current state `get-fun` may be just the `identity` function." 72 | (ask-s agent (cons :get get-fun))) 73 | 74 | (defun agent-update (agent update-fun) 75 | "Updates the `agent` state. 76 | 77 | `update-fun` must accept one parameter. That is the current state of the `agent`. The return value of `update-fun` will be taken as the new state of the `agent`." 78 | (tell agent (cons :update update-fun))) 79 | 80 | (defun agent-update-and-get (agent update-fun) 81 | "Updates the `agent` state. 82 | 83 | `update-fun` must accept one parameter. That is the current state of the `agent`. The return value of `update-fun` will be taken as the new state of the `agent`. 84 | This function makes the update and returns the new value." 85 | (ask-s agent (cons :update-and-get update-fun))) 86 | 87 | (defun agent-stop (agent) 88 | "Stops the message handling of the agent." 89 | (tell agent :stop)) 90 | -------------------------------------------------------------------------------- /src/atomic/atomic-abcl.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | Code taken from bordeaux-threads-2 3 | @author: sionescu@cddr.org 4 | Atomic Reference added by: manfred@nnamgreb.de 5 | MIT License 6 | |# 7 | 8 | (in-package :sento.atomic) 9 | 10 | (defstruct (atomic-integer 11 | (:constructor %make-atomic-integer (cell))) 12 | "Wrapper for java.util.concurrent.atomic.AtomicLong." 13 | cell) 14 | 15 | (defmethod print-object ((aint atomic-integer) stream) 16 | (print-unreadable-object (aint stream :type t :identity t) 17 | (format stream "~S" (atomic-get aint)))) 18 | 19 | (deftype %atomic-integer-value () 20 | '(unsigned-byte 63)) 21 | 22 | (defun make-atomic-integer (&key (value 0)) 23 | (check-type value %atomic-integer-value) 24 | (%make-atomic-integer 25 | (java:jnew "java.util.concurrent.atomic.AtomicLong" value))) 26 | 27 | (defconstant +atomic-long-cas+ 28 | (java:jmethod "java.util.concurrent.atomic.AtomicLong" "compareAndSet" 29 | (java:jclass "long") (java:jclass "long"))) 30 | 31 | (defmethod atomic-cas ((int atomic-integer) old new) 32 | (declare (type %atomic-integer-value old new) 33 | (optimize (safety 0) (speed 3))) 34 | (java:jcall +atomic-long-cas+ (atomic-integer-cell int) 35 | old new)) 36 | 37 | (defmethod atomic-swap ((int atomic-integer) fn &rest args) 38 | (loop :for old = (atomic-get int) 39 | :for new = (apply fn old args) 40 | :until (atomic-cas int old new) 41 | :finally (return new))) 42 | 43 | (defconstant +atomic-long-incf+ 44 | (java:jmethod "java.util.concurrent.atomic.AtomicLong" "getAndAdd" 45 | (java:jclass "long"))) 46 | 47 | (defmethod atomic-incf ((int atomic-integer) &optional (diff 1)) 48 | "Atomically increments cell value of INT by DIFF, and returns the cell value of INT before the increment." 49 | (declare (type %atomic-integer-value diff)) 50 | (java:jcall +atomic-long-incf+ (atomic-integer-cell int) diff)) 51 | 52 | (defconstant +atomic-long-get+ 53 | (java:jmethod "java.util.concurrent.atomic.AtomicLong" "get")) 54 | 55 | (defmethod atomic-get ((int atomic-integer)) 56 | (declare (optimize (safety 0) (speed 3))) 57 | (java:jcall +atomic-long-get+ (atomic-integer-cell int))) 58 | 59 | ;; (defconstant +atomic-long-set+ 60 | ;; (java:jmethod "java.util.concurrent.atomic.AtomicLong" "set" 61 | ;; (java:jclass "long"))) 62 | 63 | ;; (defun (setf atomic-integer-value) (newval atomic-integer) 64 | ;; (declare (type atomic-integer atomic-integer) 65 | ;; (type %atomic-integer-value newval) 66 | ;; (optimize (safety 0) (speed 3))) 67 | ;; (jcall +atomic-long-set+ (atomic-integer-cell atomic-integer) 68 | ;; newval) 69 | ;; newval) 70 | 71 | 72 | ;; atomic reference 73 | 74 | (defstruct (atomic-reference 75 | (:constructor %make-atomic-reference (cell))) 76 | "Wrapper for java.util.concurrent.atomic.AtomicReference." 77 | cell) 78 | 79 | (defmethod print-object ((ref atomic-reference) stream) 80 | (print-unreadable-object (ref stream :type t :identity t) 81 | (format stream "~S" (atomic-get ref)))) 82 | 83 | (defun make-atomic-reference (&key (value nil)) 84 | (%make-atomic-reference 85 | (java:jnew "java.util.concurrent.atomic.AtomicReference" value))) 86 | 87 | (defconstant +atomic-reference-cas+ 88 | (java:jmethod "java.util.concurrent.atomic.AtomicReference" "compareAndSet" 89 | (java:jclass "java.lang.Object") (java:jclass "java.lang.Object"))) 90 | 91 | (defmethod atomic-cas ((ref atomic-reference) expected new) 92 | (declare (optimize (safety 0) (speed 3))) 93 | (java:jcall +atomic-reference-cas+ (atomic-reference-cell ref) 94 | expected new)) 95 | 96 | (defconstant +atomic-reference-get+ 97 | (java:jmethod "java.util.concurrent.atomic.AtomicReference" "get")) 98 | 99 | (defmethod atomic-get ((ref atomic-reference)) 100 | (declare (optimize (safety 0) (speed 3))) 101 | (java:jcall +atomic-reference-get+ (atomic-reference-cell ref))) 102 | 103 | (defmethod atomic-swap ((ref atomic-reference) fn &rest args) 104 | (loop :for old = (atomic-get ref) 105 | :for new = (apply fn old args) 106 | :until (atomic-cas ref old new) 107 | :finally (return new))) 108 | -------------------------------------------------------------------------------- /src/atomic/atomic-api.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.atomic 2 | (:use :cl) 3 | (:nicknames :atomic) 4 | (:export #:make-atomic-reference 5 | #:make-atomic-integer 6 | #:atomic-get 7 | #:atomic-cas 8 | #:atomic-swap)) 9 | 10 | (in-package :sento.atomic) 11 | 12 | (defgeneric atomic-get (atomic) 13 | (:documentation "Retrieve value from atomic object.")) 14 | 15 | (defgeneric atomic-cas (atomic expected new) 16 | (:documentation "Set `new` value. The current value must be `extented`.")) 17 | 18 | (defgeneric atomic-swap (atomic fn &rest args) 19 | (:documentation "Update the the atomic object to the value returned by calling function `fn` with the previous value of the atomic object and `args`.")) 20 | -------------------------------------------------------------------------------- /src/atomic/atomic-clisp.lisp: -------------------------------------------------------------------------------- 1 | (in-package :sento.atomic) 2 | 3 | ;; ---------- reference ------------- 4 | 5 | (defstruct (atomic-reference 6 | (:constructor %make-atomic-reference (cell lock))) 7 | "Wrapper atomics package." 8 | cell 9 | lock) 10 | 11 | (defun make-atomic-reference (&key (value nil)) 12 | (%make-atomic-reference value (bt2:make-lock))) 13 | 14 | (defmethod print-object ((ref atomic-reference) stream) 15 | (print-unreadable-object (ref stream :type t :identity t) 16 | (format stream "~S" (atomic-get ref)))) 17 | 18 | (defmacro atomic-place (ref) 19 | `(slot-value ,ref 'cell)) 20 | 21 | (defmethod atomic-cas ((ref atomic-reference) old new) 22 | (declare (ignore old)) 23 | (bt2:with-lock-held ((atomic-reference-lock ref)) 24 | (setf (atomic-place ref) new))) 25 | 26 | (defmethod atomic-get ((ref atomic-reference)) 27 | (atomic-place ref)) 28 | 29 | (defmethod atomic-swap ((ref atomic-reference) fn &rest args) 30 | (let ((old (atomic-get ref))) 31 | (atomic-cas ref old (apply fn old args)))) 32 | 33 | ;; --------------- integer/long -------------- 34 | 35 | (defstruct (atomic-integer 36 | (:constructor %make-atomic-integer (cell lock))) 37 | "Wrapper atomics package." 38 | cell 39 | lock) 40 | 41 | (defun make-atomic-integer (&key (value 0)) 42 | (%make-atomic-reference value (bt2:make-lock))) 43 | 44 | (defmethod print-object ((int atomic-integer) stream) 45 | (print-unreadable-object (int stream :type t :identity t) 46 | (format stream "~S" (atomic-get int)))) 47 | 48 | (defmethod atomic-get ((int atomic-integer)) 49 | (atomic-place int)) 50 | 51 | (defmethod atomic-cas ((int atomic-integer) old new) 52 | (declare (ignore old)) 53 | (bt2:with-lock-held ((atomic-reference-lock int)) 54 | (setf (atomic-place int) new))) 55 | 56 | (defmethod atomic-swap ((int atomic-integer) fn &rest args) 57 | (let ((old (atomic-get int))) 58 | (atomic-cas int old (apply fn old args)))) 59 | -------------------------------------------------------------------------------- /src/atomic/atomic.lisp: -------------------------------------------------------------------------------- 1 | (in-package :sento.atomic) 2 | 3 | ;; ---------- reference ------------- 4 | 5 | (defvar *the-ref* nil "special var used for CAS") 6 | 7 | (defstruct (atomic-reference 8 | (:constructor %make-atomic-reference (cell))) 9 | "Wrapper atomics package." 10 | cell) 11 | 12 | (defun make-atomic-reference (&key (value nil)) 13 | #+ccl (%make-atomic-reference (make-array 1 :initial-element value)) 14 | #-ccl (%make-atomic-reference (cons value nil))) 15 | 16 | (defmethod print-object ((ref atomic-reference) stream) 17 | (print-unreadable-object (ref stream :type t :identity t) 18 | (format stream "~S" (atomic-get ref)))) 19 | 20 | (defmacro atomic-place (ref) 21 | #+ccl 22 | `(svref (slot-value ,ref 'cell) 0) 23 | #-ccl 24 | `(car (slot-value ,ref 'cell))) 25 | 26 | (defmethod atomic-cas ((ref atomic-reference) old new) 27 | "Synonym for COMPARE-AND-SWAP. 28 | Atomically store NEW in the cell slot of REF if OLD is eq to the current value of cell slot. 29 | Return non-NIL if this atomic operaion succeeded, or return NIL if it failed." 30 | (atomics:cas (atomic-place ref) old new)) 31 | 32 | (defmethod atomic-get ((ref atomic-reference)) 33 | (atomic-place ref)) 34 | 35 | (defmethod atomic-swap ((ref atomic-reference) fn &rest args) 36 | "Updates the cell value of REF atomically to the value returned by calling function 37 | FN with ARGS and the previous cell value of REF. The first argument of FN should be 38 | the previous cell value of REF." 39 | (loop :for old := (atomic-get ref) 40 | :for new := (apply fn old args) 41 | :until (or (eq :end new) (atomic-cas ref old new)) 42 | :finally (return new))) 43 | 44 | ;; --------------- integer/long -------------- 45 | 46 | (defvar *the-int* nil "special var used for CAS") 47 | 48 | (defstruct (atomic-integer 49 | (:constructor %make-atomic-integer (cell))) 50 | "Wrapper atomics package." 51 | cell) 52 | 53 | (defun make-atomic-integer (&key (value 0)) 54 | #+ccl (%make-atomic-reference (make-array 1 :initial-element value)) 55 | #-ccl (%make-atomic-reference (cons value nil))) 56 | 57 | (defmethod print-object ((int atomic-integer) stream) 58 | (print-unreadable-object (int stream :type t :identity t) 59 | (format stream "~S" (atomic-get int)))) 60 | 61 | (defmethod atomic-get ((int atomic-integer)) 62 | (atomic-place int)) 63 | 64 | (defmethod atomic-cas ((int atomic-integer) expected new) 65 | (atomics:cas (atomic-place int) expected new)) 66 | 67 | (defmethod atomic-swap ((int atomic-integer) fn &rest args) 68 | (loop :for old = (atomic-get int) 69 | :for new = (apply fn old args) 70 | :until (atomic-cas int old new) 71 | :finally (return new))) 72 | -------------------------------------------------------------------------------- /src/config.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.config 2 | (:use :cl) 3 | (:nicknames :config) 4 | (:export #:config-from 5 | #:retrieve-section 6 | #:retrieve-value 7 | #:retrieve-keys 8 | #:merge-config)) 9 | 10 | (in-package :sento.config) 11 | 12 | (defun config-from (config-string) 13 | "Parses the given config-string, represented by common lisp s-expressions. 14 | The config is composed of plists in a hierarchy. 15 | 16 | This function parses (run through `cl:read`) the given config string. 17 | The config string can be generated by: 18 | 19 | ``` 20 | (let ((*print-case* :downcase)) 21 | (prin1-to-string '(defconfig 22 | (:foo 1 23 | :bar 2)))) 24 | ``` 25 | Or just be given by reading from a file. 26 | Notice the 'config' s-expr must start with the root `car` 'defconfig'. 27 | " 28 | (when config-string 29 | (let* ((stream (make-string-input-stream config-string)) 30 | (config (read stream))) 31 | (if (string= "defconfig" (string-downcase (symbol-name (car config)))) 32 | (cadr config) 33 | (error "Unrecognized config!"))))) 34 | 35 | (defun retrieve-section (config section) 36 | "Retrieves the given named section which should be a (global) `symbol` (a key). 37 | A section usually is a plist with additional configs or sub sections. 38 | This function looks only in the root hierarchy of the given config." 39 | (getf config section)) 40 | 41 | (defun retrieve-value (section key) 42 | "Retrieves the value for the given key and section." 43 | (getf section key)) 44 | 45 | (defun retrieve-keys (config) 46 | "Retrieves all section keys" 47 | (loop :for key :in config :by #'cddr 48 | :collect key)) 49 | 50 | (defun merge-config (config fallback-config) 51 | "Merges config. 52 | `config` specifies a config that overrides what exists in `fallback-config`. 53 | `fallback-config` is a default. If something doesn't exist in `config` it is taken from `fallback-config`. 54 | Both `config` and `fallback-config` must be plists, or a 'config' that was the output of `config-from`." 55 | (cond 56 | ((and config fallback-config) 57 | (%merge-config nil config fallback-config)) 58 | (t (if config config fallback-config)))) 59 | 60 | (defun %merge-config (key config fallback) 61 | (cond 62 | ((and (not (null config)) (listp config) (not (null fallback)) (listp fallback)) 63 | (let* ((keys (union (retrieve-keys config) (retrieve-keys fallback))) 64 | (result (loop :for key :in keys 65 | :append (%merge-config 66 | key 67 | (retrieve-value config key) 68 | (retrieve-value fallback key))))) 69 | (if key 70 | `(,key ,result) 71 | result))) 72 | ((and (listp config) (null fallback)) 73 | `(,key ,config)) 74 | ((and (or (null config) (not (listp config))) 75 | (and (not (null fallback)) (listp fallback))) 76 | `(,key ,fallback)) 77 | (t (if config 78 | `(,key ,config) 79 | `(,key ,fallback))))) 80 | -------------------------------------------------------------------------------- /src/dispatcher-api.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.dispatcher 2 | (:use :cl) 3 | (:nicknames :disp) 4 | (:export #:dispatcher-base 5 | #:shared-dispatcher 6 | #:make-dispatcher 7 | #:workers 8 | #:identifier 9 | #:dispatch 10 | #:dispatch-async 11 | #:dispatch-worker 12 | #:stop 13 | #:make-dispatcher-worker)) 14 | 15 | (in-package :sento.dispatcher) 16 | 17 | (defgeneric workers (dispatcher) 18 | (:documentation 19 | "Returns the workers of this dispatcher. 20 | But better do not touch them. 21 | Only use the defined interface here to talk to them.")) 22 | 23 | (defgeneric stop (dispatcher) 24 | (:documentation 25 | "Stops the dispatcher. Stops all workers.")) 26 | 27 | (defgeneric dispatch (dispatcher dispatcher-exec-fun) 28 | (:documentation 29 | "Dispatches a function (`dispatch-exec-fun`) to a worker of the dispatcher to execute there. 30 | `dispatch` does a `ask-s` to a `dispatcher` worker, which means this call will block. 31 | The parameter `dispatcher-exec-fun` if of the form: `(list (function ))`")) 32 | 33 | (defgeneric dispatch-async (dispatcher dispatcher-exec-fun) 34 | (:documentation 35 | "Dispatches a function to a worker of the dispatcher to execute there. 36 | `dispatch-async` does a `tell` to a `dispatcher` worker and is asynchronous.")) 37 | -------------------------------------------------------------------------------- /src/dispatcher.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :sento.dispatcher) 3 | 4 | (eval-when (:compile-toplevel) 5 | (shadowing-import '(mesgb:message-box/bt 6 | act:actor))) 7 | 8 | (defclass dispatcher-base () 9 | ((context :initform nil 10 | :initarg :context) 11 | (identifier :initform nil 12 | :initarg :identifier 13 | :reader identifier 14 | :documentation "Returns the identifier of the dispatcher.")) 15 | (:documentation 16 | "A `dispatcher` contains a pool of `actors` that operate as workers where work is dispatched to. 17 | However, the workers are created in the given `ac:actor-context`.")) 18 | 19 | ;; --------------------------------- 20 | ;; Shared dispatcher 21 | ;; --------------------------------- 22 | 23 | (defun make-dispatcher (actor-context identifier &rest config) 24 | "Default constructor. 25 | This creates a `disp:shared-dispatcher` with the given dispatcher config, see `asys:*default-config*`. 26 | Each worker is based on a `:pinned` actor meaning that it has its own thread. 27 | Specify an `ac:actor-context` where actors needed in the dispatcher are created in." 28 | (make-instance 'shared-dispatcher 29 | :context actor-context 30 | :identifier identifier 31 | :num-workers (getf config :workers 2) 32 | :strategy (getf config :strategy :random))) 33 | 34 | (defclass shared-dispatcher (dispatcher-base) 35 | ((router :initform nil)) 36 | (:documentation 37 | "A shared dispatcher. 38 | Internally it uses a `router:router` to drive the `dispatch-worker`s. 39 | The default strategy of choosing a worker is `:random`. 40 | 41 | A `shared-dispatcher` is automatically setup by an `asys:actor-system`.")) 42 | 43 | (defmethod initialize-instance :after ((self shared-dispatcher) &key (num-workers 1) (strategy :random)) 44 | (with-slots (router context identifier) self 45 | (setf router (router:make-router :strategy strategy)) 46 | (loop :for n :from 1 :to num-workers 47 | :do (router:add-routee router (make-dispatcher-worker n context identifier))))) 48 | 49 | (defmethod print-object ((obj shared-dispatcher) stream) 50 | (print-unreadable-object (obj stream :type t) 51 | (with-slots (router identifier) obj 52 | (format stream "ident: ~a, workers: ~a, strategy: ~a" 53 | identifier 54 | (length (router:routees router)) 55 | (router:strategy-fun router))))) 56 | 57 | (defmethod workers ((self shared-dispatcher)) 58 | (with-slots (router) self 59 | (router:routees router))) 60 | 61 | (defmethod stop ((self shared-dispatcher)) 62 | (with-slots (router) self 63 | (router:stop router))) 64 | 65 | (defmethod dispatch ((self shared-dispatcher) dispatch-exec-fun-args) 66 | (with-slots (router) self 67 | (router:ask-s router (cons :execute dispatch-exec-fun-args)))) 68 | 69 | (defmethod dispatch-async ((self shared-dispatcher) dispatch-exec-fun-args) 70 | (with-slots (router) self 71 | (router:tell router (cons :execute dispatch-exec-fun-args)))) 72 | 73 | 74 | ;; --------------------------------- 75 | ;; the worker 76 | ;; --------------------------------- 77 | 78 | (defclass dispatch-worker (actor) () 79 | (:documentation 80 | "Specialized `actor` used as `worker` is the message `dispatcher`.")) 81 | 82 | (defun make-dispatcher-worker (num actor-context dispatcher-ident) 83 | "Constructor for creating a worker. 84 | `num` only has the purpose to give the worker a name which includes a number. 85 | `dispatcher-ident is the dispatcher identifier." 86 | (ac:actor-of actor-context 87 | :receive #'receive 88 | :type 'dispatch-worker 89 | :name (format nil "dispatch(~a)-worker-~a" dispatcher-ident num) 90 | :dispatcher :pinned)) 91 | 92 | (defun receive (message) 93 | "The worker receive function." 94 | (assert (consp message) nil 95 | (format t "~a: Message must be a `cons'!" (act-cell:name act:*self*))) 96 | (case (car message) 97 | (:execute (apply (cadr message) (cddr message))))) 98 | -------------------------------------------------------------------------------- /src/eventstream-api.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.eventstream 2 | (:use :cl) 3 | (:nicknames :ev) 4 | (:import-from #:miscutils 5 | #:filter) 6 | (:import-from #:act 7 | #:tell) 8 | (:export #:eventstream 9 | #:make-eventstream 10 | #:subscribe 11 | #:unsubscribe 12 | #:publish)) 13 | 14 | (in-package :sento.eventstream) 15 | 16 | (defgeneric subscribe (eventstream subscriber &optional pattern) 17 | (:documentation 18 | "Subscribe to the eventstream to receive notifications of certain events or event types. 19 | 20 | `subscriber` must be an actor (or agent). 21 | 22 | The `pattern` can be: 23 | 24 | - nil: receive all events posted to the eventstream. 25 | - a type, class type: this allows to get notifications when an instance of this type, or class type is posted. 26 | I.e. if you want to listen to all string messages posted to the ev, thewn subscribe to `'string`. 27 | Or if you want to listen to all lists, subscribe with `'cons`. 28 | - a symbol or global symbol: if posted message is a symbol or global symbol then the symbols are compared (`eq`). 29 | - a string: in which case an exact string comparison is made for a string message that is posted to the eventstream (`string=`). 30 | - a list: if subscription if for a list structure, and the posted message is also a list structure, then a structure comparison (`equalp`) is made.")) 31 | 32 | (defgeneric unsubscribe (eventstream unsubscriber) 33 | (:documentation 34 | "Unsubscribe from the eventstream. No more events will be received then.")) 35 | 36 | (defgeneric publish (eventstream message) 37 | (:documentation 38 | "Publish an event/message to the eventstream. Subscribers may receive notification if they registered for the right message pattern.")) 39 | -------------------------------------------------------------------------------- /src/eventstream.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :sento.eventstream) 3 | 4 | (defclass eventstream () 5 | ((subscribers :initform '() 6 | :reader subscribers) 7 | (ev-actor :initform nil)) 8 | (:documentation "Eventstream facility allows to post/publish messages/events in the `asys:actor-system` and actors that did subscribe, to listen on those events. 9 | 10 | The eventstream is driven by an actor. The processing of the sent events is guaranteed to be as they arrive. 11 | 12 | Events can be posted as plain strings, as lists, or as objects of classes. 13 | The subscriber has a variaty of options to define what to listen for. 14 | 15 | For example: a subscriber wants to listen to events/messages with the string \"Foo\". 16 | The subscriber is then only notified when events are posted with the exact same string. 17 | 18 | See more information at the `ev:subscribe` function.")) 19 | 20 | (defun make-eventstream (actor-context &rest config) 21 | "Creating an eventstream is done by the `asys:actor-system` which is then available system wide. 22 | But in theory it can be created individually by just passing an `ac:actor-context` (though I don't know what would be the reason to create an eventstream for the context of a single actor. Maybe to address only a certain hierarchy in the actor tree.) 23 | 24 | - `actor-context`: the `ac:actor-context` where the eventstream actor should be created in. 25 | - `config`: is a plist with the `:dispatcher-id` key and a dispatcher id as value. Defaults to `:shared`. This dispatcher type should be used by the actor." 26 | (let ((ev (make-instance 'eventstream))) 27 | (with-slots (ev-actor) ev 28 | (setf ev-actor (ac:actor-of actor-context 29 | :name (gensym "eventstream-actor-") 30 | :dispatcher (getf config :dispatcher-id :shared) 31 | :receive (lambda (msg) 32 | (handler-case 33 | (ev-receive ev act:*self* msg) 34 | (t (c) 35 | (log:warn "Condition: ~a" c))))))) 36 | ev)) 37 | 38 | (defun ev-receive (ev listener msg) 39 | (declare (ignore listener)) 40 | (with-slots (subscribers) ev 41 | (let* ((msg-type (type-of msg)) 42 | (subs (subscribers-for subscribers msg-type msg))) 43 | (dolist (sub subs) 44 | (tell sub msg))))) 45 | 46 | (defun subscribers-for (subscribers msg-type msg) 47 | (flet ((no-type-registered-p (elem) (null elem)) 48 | (equal-string-p (elem) (and (stringp msg) 49 | (typep elem 'string) 50 | (string= elem msg))) 51 | (equal-list-p (elem) (and (listp msg) 52 | (typep elem 'cons) 53 | (equalp elem msg))) 54 | (equal-symbol-p (elem) (and (symbolp msg) 55 | (symbolp elem) 56 | (eq elem msg))) 57 | (equal-objecttype-p (elem) (and (symbolp elem) 58 | (not (symbolp msg)) 59 | (subtypep msg-type elem)))) 60 | (mapcar #'car 61 | (filter (lambda (sub) 62 | (let ((reg-type (second sub))) 63 | (or (no-type-registered-p reg-type) 64 | (or (equal-symbol-p reg-type) 65 | (equal-objecttype-p reg-type) 66 | (equal-string-p reg-type) 67 | (equal-list-p reg-type))))) 68 | subscribers)))) 69 | 70 | (defmethod subscribe ((ev-stream eventstream) (subscriber act:actor) &optional pattern) 71 | "Subscribe to `ev:eventstream`." 72 | (with-slots (subscribers) ev-stream 73 | (push `(,subscriber ,pattern) subscribers))) 74 | 75 | (defmethod unsubscribe ((ev-stream eventstream) (unsubscriber act:actor)) 76 | "Unsubscribe to `ev:eventstream`." 77 | (with-slots (subscribers) ev-stream 78 | (setf subscribers (remove-if (lambda (x) (eq x unsubscriber)) subscribers :key #'car))) 79 | t) 80 | 81 | (defmethod publish ((ev-stream eventstream) message) 82 | "Publish to `ev:eventstream`." 83 | (with-slots (ev-actor) ev-stream 84 | (tell ev-actor message))) 85 | -------------------------------------------------------------------------------- /src/fasync-completed.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.async-future 2 | (:use :cl :future) 3 | (:nicknames :async-future) 4 | (:export #:fasync-completed)) 5 | 6 | (in-package :sento.async-future) 7 | 8 | #| 9 | 10 | UNUSED/EXPERIMENT: See notes on `fcompleted'. 11 | 12 | |# 13 | 14 | (defmacro fasync-completed (future context dispatcher-id (result) &body body) 15 | "Asynchronous future completion handler. 16 | 17 | This works essentially the same as `future:fcompleted` except that the completion function executes in a different execution context. 18 | The 'execution-context' is a dispatcher (`disp:dispatcher`) registered in `asys:actor-system`. 19 | It is here identified using `dispatcher-id` (the default dispatcher identifier is `:shared`). 20 | The additional parameter `context` can be the actor-system itself, an `ac:actor-context` or an `act:actor` instance. 21 | 22 | If the completion handler should execute on the caller thread, then `future:fcompleted` should be used. 23 | 24 | If the `future` is already complete then the `body` executes immediately. 25 | `result` represents the future result. 26 | `body` is executed when future completed. 27 | Returns the future. 28 | 29 | Example: 30 | 31 | ``` 32 | (fasync-completed (with-fut (sleep .5) 1) asys :shared 33 | (result) 34 | (format t \"Future result ~a~%\" result)) 35 | ``` 36 | " 37 | (let ((disp (gensym "disp")) 38 | (sys (gensym "sys"))) 39 | `(progn 40 | (assert (typep ,future 'future) nil "Arg 'future' is not of required type!") 41 | (assert (or (typep ,context 'asys:actor-system) 42 | (typep ,context 'ac:actor-context) 43 | (typep ,context 'act:actor)) 44 | nil "Arg 'context' is not of required type!") 45 | (let* ((,sys (typecase ,context 46 | (asys:actor-system ,context) 47 | (otherwise (ac:system ,context)))) 48 | (,disp (getf (asys:dispatchers ,sys) ,dispatcher-id))) 49 | (assert (not (null ,disp)) nil "Dispatcher-id is not known!") 50 | (disp:dispatch-async 51 | ,disp 52 | (list 53 | (lambda () 54 | (future::%fcompleted ,future (lambda (,result) ,@body)))))) 55 | ,future))) 56 | 57 | -------------------------------------------------------------------------------- /src/miscutils.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.miscutils 2 | (:nicknames :miscutils) 3 | (:use :cl) 4 | (:export #:mkstr 5 | #:assert-cond 6 | #:await-cond 7 | #:filter 8 | #:collect-backtrace)) 9 | 10 | (in-package :sento.miscutils) 11 | 12 | (defun mkstr (&rest args) 13 | "Converts all parameters to string and concatenates them." 14 | (with-output-to-string (stream) 15 | (dolist (a args) (princ a stream)))) 16 | 17 | (defun filter (fun lst) 18 | (mapcan (lambda (x) (if (funcall fun x) (list x))) lst)) 19 | 20 | (defun collect-backtrace (condition) 21 | (let ((backtrace (make-string-output-stream))) 22 | (uiop:print-condition-backtrace condition :stream backtrace) 23 | (get-output-stream-string backtrace))) 24 | 25 | (defun assert-cond (assert-fun max-time &optional (sleep-time 0.05)) 26 | "Obsolete, use `await-cond' instead." 27 | (do ((wait-time sleep-time (+ wait-time sleep-time)) 28 | (fun-result nil (funcall assert-fun))) 29 | ((not (null fun-result)) (return t)) 30 | (if (> wait-time max-time) (return) 31 | (sleep sleep-time)))) 32 | 33 | (defmacro await-cond (max-time &body body) 34 | "Awaits condition. Probes repeatedly. 35 | If after `max-time' condition is not `t' it is considered failed." 36 | `(assert-cond (lambda () 37 | ,@body) 38 | ,max-time)) 39 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.user 2 | (:use :cl :asys :ac :act :agt :agthash :agtarray :ev :tasks :future) 3 | (:nicknames :sento-user)) 4 | (in-package :sento.user) 5 | -------------------------------------------------------------------------------- /src/queue/exp-tfifo.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.queue 2 | (:use :cl) 3 | (:nicknames :queue) 4 | (:export #:queue-tfifo 5 | #:queue-bounded 6 | #:queue-unbounded 7 | #:pushq 8 | #:popq)) 9 | 10 | (in-package :sento.queue) 11 | 12 | (defclass queue-tfifo (queue-base) 13 | ((queue :initform (stmx.util:tfifo)))) 14 | (defmethod pushq ((self queue-tfifo) element) 15 | (with-slots (queue) self 16 | (stmx.util:put queue element))) 17 | (defmethod popq ((self queue-tfifo)) 18 | (with-slots (queue) self 19 | (stmx.util:take queue))) 20 | -------------------------------------------------------------------------------- /src/queue/queue-cas.lisp: -------------------------------------------------------------------------------- 1 | (in-package :sento.queue) 2 | 3 | ;; WIP 4 | 5 | ;; ---------------------------------------- 6 | ;; - unbounded queue using cas (lock-free) 7 | ;; ---------------------------------------- 8 | 9 | #| 10 | Implementation copied and adapted from SBCL's queue.lisp 11 | |# 12 | 13 | (defconstant +dummy+ '.dummy.) 14 | (defconstant +dead-end+ '.dead-end.) 15 | 16 | (defstruct (queue 17 | (:constructor %make-queue (head tail)) 18 | (:copier nil) 19 | (:predicate queueq)) 20 | (head (error "No head")) 21 | (tail (error "No tail"))) 22 | 23 | (defun make-queue () 24 | (let* ((dummy (cons +dummy+ nil)) 25 | (queue (%make-queue 26 | (atomic:make-atomic-reference :value dummy) 27 | (atomic:make-atomic-reference :value dummy)))) 28 | (flet ((enc-1 (x) 29 | (enqueue x queue))) 30 | (declare (dynamic-extent #'enc-1)) 31 | (map nil #'enc-1 nil)) 32 | queue)) 33 | 34 | (defun enqueue (item queue) 35 | (declare (optimize speed)) 36 | (let ((new (cons item nil))) 37 | (atomic:atomic-swap (queue-tail queue) 38 | (lambda (old) 39 | (setf (cdr old) new) 40 | new)) 41 | (setf (queue-tail queue) (atomic:make-atomic-reference :value new)) 42 | item)) 43 | 44 | (defun dequeue (queue) 45 | (declare (optimize speed)) 46 | (let ((next (atomic:atomic-swap 47 | (queue-head queue) 48 | (lambda (head) 49 | (let ((next (cdr head))) 50 | ;;(print next) 51 | (typecase next 52 | (null :end) ;; break cas 53 | (cons next))))))) 54 | ;;(print next) 55 | (when (eq next :end) 56 | (return-from dequeue (values nil nil))) 57 | (let ((item (car next))) 58 | (setf ;;(cdr head) +dead-end+ 59 | (car next) +dummy+) 60 | (values item t)))) 61 | 62 | 63 | ;; (let* ((head (atomic:atomic-get (queue-head queue))) 64 | ;; (next (cdr head))) 65 | ;; (typecase next 66 | ;; (null (values nil nil)) 67 | ;; (cons 68 | ;; (atomic:atomic-swap 69 | ;; (queue-head queue) 70 | ;; (lambda () next)) 71 | ;; (let ((item (car next))) 72 | ;; (setf (cdr head) +dead-end+ 73 | ;; (car next) +dummy+) 74 | ;; (values item t)))))) 75 | 76 | (defun emptyp (queue) 77 | (null (cdr (atomic:atomic-get (queue-head queue))))) 78 | 79 | 80 | ;; ---------------------------------------- 81 | 82 | (defclass queue-unbounded (queue-base) 83 | ((queue :initform (make-queue))) 84 | (:documentation "Unbounded queue.")) 85 | 86 | (defmethod pushq ((self queue-unbounded) element) 87 | (with-slots (queue) self 88 | (enqueue element queue))) 89 | 90 | (defmethod popq ((self queue-unbounded)) 91 | (with-slots (queue) self 92 | (loop (multiple-value-bind (value presentp) 93 | (dequeue queue) 94 | (if presentp 95 | (return value)))))) 96 | 97 | (defmethod emptyq-p ((self queue-unbounded)) 98 | (with-slots (queue) self 99 | (emptyp queue))) 100 | -------------------------------------------------------------------------------- /src/queue/queue-locked.lisp: -------------------------------------------------------------------------------- 1 | (in-package :sento.queue) 2 | 3 | ;; ---------------------------------------- 4 | ;; - unbounded queue using locks 5 | ;; ---------------------------------------- 6 | 7 | #| 8 | The queue is a simple queue that is not thread-safe. 9 | It is based on 2 stacks, one for the head and one for the tail. 10 | When the tail is empty, the head is reversed and pushed to the tail. 11 | This is from the book "Programming Algorithms in Lisp" by Vsevolod Domkin. 12 | 13 | This queue is fast, but requires a lot of memory. Roughly 1/3 more 14 | than the 'queue' implementation of lparallel. 15 | |# 16 | 17 | (defstruct queue 18 | (head '() :type list) 19 | (tail '() :type list)) 20 | 21 | (defun enqueue (item queue) 22 | (push item (queue-head queue))) 23 | 24 | (defun dequeue (queue) 25 | (declare (optimize 26 | (speed 3) 27 | (safety 0) 28 | (debug 0) 29 | (compilation-speed 0))) 30 | (unless (queue-tail queue) 31 | (do () 32 | ((null (queue-head queue))) 33 | (push (pop (queue-head queue)) 34 | (queue-tail queue)))) 35 | (when (queue-tail queue) 36 | (values (pop (queue-tail queue)) 37 | t))) 38 | 39 | (defun emptyp (queue) 40 | (not (or (queue-head queue) 41 | (queue-tail queue)))) 42 | 43 | (defun size (queue) 44 | (let ((head (queue-head queue)) 45 | (tail (queue-tail queue))) 46 | (+ (length head) 47 | (length tail)))) 48 | 49 | 50 | #| 51 | queue implementation from lparallel. 52 | Copyright (c) 2011-2012, James M. Lawrence. All rights reserved. 53 | 54 | |# 55 | 56 | ;; (defstruct queue 57 | ;; (head '() :type list) 58 | ;; (tail '() :type list)) 59 | 60 | ;; (defun enqueue (item queue) 61 | ;; (declare (optimize 62 | ;; (speed 3) (safety 0) (debug 0) 63 | ;; (compilation-speed 0))) 64 | ;; (let ((new (cons item nil))) 65 | ;; (if (queue-head queue) 66 | ;; (setf (cdr (queue-tail queue)) new) 67 | ;; (setf (queue-head queue) new)) 68 | ;; (setf (queue-tail queue) new))) 69 | 70 | ;; (defun dequeue (queue) 71 | ;; (declare (optimize 72 | ;; (speed 3) (safety 0) (debug 0) 73 | ;; (compilation-speed 0))) 74 | ;; (let ((item (queue-head queue))) 75 | ;; (if item 76 | ;; (multiple-value-prog1 (values (car item) t) 77 | ;; (when (null (setf (queue-head queue) (cdr item))) 78 | ;; (setf (queue-tail queue) nil)) 79 | ;; ;; clear item for conservative gcs 80 | ;; (setf (car item) nil 81 | ;; (cdr item) nil)) 82 | ;; (values nil nil)))) 83 | 84 | ;; (defun emptyp (queue) 85 | ;; (not (queue-head queue))) 86 | 87 | ;; ------- thread-safe queue -------- 88 | 89 | (defclass queue-unbounded (queue-base) 90 | ((queue :initform (make-queue)) 91 | (lock :initform (bt2:make-lock)) 92 | (cvar :initform (bt2:make-condition-variable)) 93 | (fill-count :initform 0)) 94 | (:documentation "Unbounded queue.")) 95 | 96 | (defmethod pushq ((self queue-unbounded) element) 97 | (with-slots (queue lock cvar fill-count) self 98 | (bt2:with-lock-held (lock) 99 | (enqueue element queue) 100 | (incf fill-count) 101 | (bt2:condition-notify cvar)))) 102 | 103 | (defmethod popq ((self queue-unbounded)) 104 | (with-slots (queue lock cvar fill-count) self 105 | (bt2:with-lock-held (lock) 106 | (loop (multiple-value-bind (value presentp) 107 | (dequeue queue) 108 | (if presentp 109 | (progn 110 | (decf fill-count) 111 | (return value)) 112 | (bt2:condition-wait cvar lock))))))) 113 | 114 | (defmethod emptyq-p ((self queue-unbounded)) 115 | (with-slots (queue) self 116 | (emptyp queue))) 117 | 118 | (defmethod queued-count ((self queue-unbounded)) 119 | (slot-value self 'fill-count)) 120 | -------------------------------------------------------------------------------- /src/queue/queue-sbcl.lisp: -------------------------------------------------------------------------------- 1 | (in-package :sento.queue) 2 | 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (require :sb-concurrency)) 5 | 6 | ;; ---------------------------------------- 7 | ;; ---- unbounded queue - sbcl only ------- 8 | ;; uses the lock-free (based on cas) queue 9 | ;; ---------------------------------------- 10 | 11 | (defclass queue-unbounded (queue-base) 12 | ((queue :initform 13 | (sb-concurrency:make-queue))) 14 | (:documentation "Unbounded queue.")) 15 | 16 | (defmethod pushq ((self queue-unbounded) element) 17 | (with-slots (queue) self 18 | (sb-concurrency:enqueue element queue))) 19 | 20 | (defmethod popq ((self queue-unbounded)) 21 | (with-slots (queue) self 22 | (sb-concurrency:dequeue queue))) 23 | 24 | (defmethod emptyq-p ((self queue-unbounded)) 25 | (with-slots (queue) self 26 | (sb-concurrency:queue-empty-p queue))) 27 | -------------------------------------------------------------------------------- /src/queue/queue.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.queue 2 | (:use :cl) 3 | (:nicknames :queue) 4 | (:export #:queue-unbounded 5 | #:queue-bounded 6 | #:pushq 7 | #:popq 8 | #:emptyq-p 9 | #:queued-count 10 | ;; conditions 11 | #:queue-full-error)) 12 | 13 | (in-package :sento.queue) 14 | 15 | (defclass queue-base () 16 | () 17 | (:documentation "The base queue.")) 18 | 19 | (defgeneric pushq (queue-base element) 20 | (:documentation "Pushes an element to the queue.")) 21 | 22 | (defgeneric popq (queue-base) 23 | (:documentation "Pops the first element. Blocks until an element arrives.")) 24 | 25 | (defgeneric emptyq-p (queue-base) 26 | (:documentation "Returns `T' if there is no element in the queue.")) 27 | 28 | (defgeneric queued-count (queue-base) 29 | (:documentation "Returns the number of elements in the queue.")) 30 | 31 | ;; 32 | ;; unbounded queues in separate files 33 | ;; 34 | 35 | ;; ---------------------------------------- 36 | ;; --- Bounded-queue - cl-speedy-queue ---- 37 | ;; ---------------------------------------- 38 | 39 | (define-condition queue-full-error (error) 40 | ((queue :initarg :queue :reader queue)) 41 | (:report (lambda (condition stream) 42 | (format stream "Queue '~a' is full!" (queue condition))))) 43 | 44 | (defclass queue-bounded (queue-base) 45 | ((queue :initform nil) 46 | (lock :initform (bt2:make-lock)) 47 | (cvar :initform (bt2:make-condition-variable)) 48 | (max-items :initform 1000 :initarg :max-items) 49 | (fill-count :initform 0)) ; cl-speedy-queue has issues with queued items count 50 | (:documentation "Bounded queue.")) 51 | 52 | (defmethod initialize-instance :after ((self queue-bounded) &key) 53 | (with-slots (queue max-items) self 54 | (if (< max-items 0) (error "Max-items 0 or less is not allowed!")) 55 | (setf queue (cl-speedy-queue:make-queue max-items)))) 56 | 57 | (defmethod pushq ((self queue-bounded) element) 58 | (with-slots (queue lock cvar fill-count max-items) self 59 | (bt2:with-lock-held (lock) 60 | (when (>= fill-count max-items) 61 | (error 'queue-full-error :queue self)) 62 | (cl-speedy-queue:enqueue element queue) 63 | (incf fill-count) 64 | (bt2:condition-notify cvar)))) 65 | 66 | (defmethod popq ((self queue-bounded)) 67 | (with-slots (queue lock cvar) self 68 | (bt2:with-lock-held (lock) 69 | (loop :while (cl-speedy-queue:queue-empty-p queue) 70 | :do (bt2:condition-wait cvar lock) 71 | :finally (return 72 | (progn 73 | (decf (slot-value self 'fill-count)) 74 | (cl-speedy-queue:dequeue queue))))))) 75 | 76 | (defmethod emptyq-p ((self queue-bounded)) 77 | (with-slots (queue) self 78 | (cl-speedy-queue:queue-empty-p queue))) 79 | 80 | (defmethod queued-count ((self queue-bounded)) 81 | (slot-value self 'fill-count)) 82 | -------------------------------------------------------------------------------- /src/router.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.router 2 | (:use :cl) 3 | (:nicknames :router) 4 | (:import-from #:act 5 | #:tell 6 | #:ask-s 7 | #:ask) 8 | (:export #:router 9 | #:make-router 10 | #:add-routee 11 | #:routees 12 | #:strategy-fun 13 | #:stop 14 | #:tell 15 | #:ask-s 16 | #:ask)) 17 | 18 | (in-package :sento.router) 19 | 20 | (defun make-random-strategy () 21 | "The default, built-in strategy: random." 22 | (lambda (len) (random len))) 23 | 24 | (defun make-round-robin-strategy () 25 | "Returns a let-over-lambda that implements a round-robin strategy." 26 | (let ((index (atomic:make-atomic-integer))) 27 | (lambda (len) 28 | (atomic:atomic-swap index 29 | (lambda (old) 30 | (if (< old (1- len)) (1+ old) 0)))))) 31 | 32 | (defun get-strategy-fun (strategy) 33 | (cond 34 | ((eq :random strategy) (make-random-strategy)) 35 | ((eq :round-robin strategy) (make-round-robin-strategy)) 36 | ((functionp strategy) strategy) 37 | (t (error "Unknown strategy!")))) 38 | 39 | (defun make-router (&key (strategy :random) (routees nil)) 40 | "Default constructor of router. 41 | Built-in strategies: `:random`, `:round-robin`. 42 | Specify your own strategy by providing a function that takes a `fixnum` as parameter which represents the number of routees and returns a `fixnum` that represents the index of the routee to choose. 43 | 44 | Specify `routees` if you know them upfront." 45 | (let ((router (make-instance 'router 46 | :strategy-fun (get-strategy-fun strategy)))) 47 | (when routees 48 | (dolist (routee routees) 49 | (add-routee router routee))) 50 | router)) 51 | 52 | (defclass router () 53 | ((routees :initform (make-array 2 :adjustable t :fill-pointer 0) 54 | :documentation "The routees.") 55 | (strategy-fun :initform nil 56 | :initarg :strategy-fun 57 | :reader strategy-fun 58 | :documentation 59 | "The router strategy function. 60 | The `strategy` is a function with a `fixnum` as input and a `fixnum` as output. 61 | The input represents the number of routees. 62 | The output represents the index of the routee to choose by calling the function.")) 63 | (:documentation 64 | "A router combines a pool of actors and implements the actor-api protocol. 65 | So a `tell`, `ask-s` and `ask` is delegated to one of the routers routees. 66 | While a router implements parts of the actor protocol it doesn't implement all. 67 | I.e. a router cannot be `watch`ed. 68 | A router `strategy` defines how one of the actors is determined as the forwarding target of the message.")) 69 | 70 | (defun add-routee (router routee) 71 | "Adds a routee/actor to the router." 72 | (vector-push-extend routee (slot-value router 'routees)) 73 | routee) 74 | 75 | (defun stop (router) 76 | "Stops all routees." 77 | (mapcar #'act-cell:stop (coerce (routees router) 'list))) 78 | 79 | (defun get-strategy-index (router) 80 | (let* ((routees (slot-value router 'routees)) 81 | (strategy-fun (strategy-fun router)) 82 | (actor-index (funcall strategy-fun (length routees)))) 83 | (log:debug "Using index from strategy: ~a" actor-index) 84 | actor-index)) 85 | 86 | (defun routees (router) 87 | "Returns the routees as list." 88 | (copy-list (coerce (slot-value router 'routees) 'list))) 89 | 90 | (defmethod tell ((self router) message &optional sender) 91 | "Posts the message to one routee. The routee is chosen from the router `strategy`. 92 | Otherwise see: `act:tell`." 93 | (let ((routees (routees self))) 94 | (when (<= (length routees) 0) 95 | (log:info "No routees available!") 96 | (return-from tell nil)) 97 | (tell 98 | (elt routees (get-strategy-index self)) 99 | message 100 | sender))) 101 | 102 | (defmethod ask-s ((self router) message &key time-out) 103 | "Posts the message to one routee. The routee is chosen from the router `strategy`. 104 | Otherwise see: `act:ask-s`." 105 | (let ((routees (routees self))) 106 | (when (<= (length routees) 0) 107 | (log:info "No routees available!") 108 | (return-from ask-s nil)) 109 | (ask-s 110 | (elt routees (get-strategy-index self)) 111 | message 112 | :time-out time-out))) 113 | 114 | (defmethod ask ((self router) message &key time-out) 115 | "Posts the message to one routee. The routee is chosen from the router `strategy`. 116 | Otherwise see: `act:ask`." 117 | (let ((routees (routees self))) 118 | (when (<= (length routees) 0) 119 | (log:info "No routees available!") 120 | (return-from ask nil)) 121 | (ask 122 | (elt routees (get-strategy-index self)) 123 | message 124 | :time-out time-out))) 125 | -------------------------------------------------------------------------------- /src/stash.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.stash 2 | (:use :cl) 3 | (:nicknames :stash) 4 | (:import-from #:act-cell 5 | #:*sender* 6 | #:*self* 7 | #:submit-message) 8 | (:export #:stashing 9 | #:has-stashed-messages-p 10 | #:stash 11 | #:unstash-all) 12 | ) 13 | 14 | (in-package :sento.stash) 15 | 16 | (defclass stashing () 17 | ((stashed-messages :initform '() 18 | :reader stashed-messages 19 | :documentation "Stash is an unbounded list. 20 | Stash items are a tuple (alist) of `msg' and `sender'.")) 21 | (:documentation "`stashing` is a mixin class to `act:actor`. 22 | It can 'stash' away arriving messages which should not be handled now, but later, after the actor is 'able' to handle them. Create an actor class that can stash like this: 23 | 24 | ``` 25 | (defclass stash-actor (actor stashing) ()) 26 | ``` 27 | 28 | Then create an actor by specifying this type: 29 | 30 | ``` 31 | (actor-of system 32 | :type 'stash-actor 33 | :receive (lambda (msg) 34 | ...)) 35 | ``` 36 | 37 | For stash and unstash see function descriptions below. 38 | 39 | The main use-case is for `act:tell` and `act:ask`. `act:ask-s` will not work. 40 | timeouts are ignored because it is not clear how long stashed messages will reside in stash. 41 | However the `sender`, if given (on `act:tell`), is preserved.")) 42 | 43 | (defun has-stashed-messages-p (stashing) 44 | "Are there any stashed messages?" 45 | (with-slots (stashed-messages) stashing 46 | (not (null (car stashed-messages))))) 47 | 48 | (defun stash (msg) 49 | "Stash `msg` for later unstash. 50 | On stashing a message the actor should respond with: `(cons :no-reply state)` 51 | to avoid returning a response to sender (if given). 52 | 53 | This function is expected to be run from within 'receive' function." 54 | (check-type *self* act:actor "Not an actor!") 55 | (with-slots (stashed-messages) *self* 56 | (setf stashed-messages 57 | (cons `(,msg . ,*sender*) stashed-messages))) 58 | t) 59 | 60 | (defun unstash-all () 61 | "Unstash all messages. 62 | Messages are re-submitted to the actor in the order they were stashed. 63 | Resubmitting means they are added to the end of the queue like any ordinary message would. 64 | 65 | This function is expected to be run from within 'receive' function." 66 | (check-type *self* act:actor "Not an actor!") 67 | (with-slots (stashed-messages) *self* 68 | (loop :for amsg :in (reverse stashed-messages) 69 | :for msg = (car amsg) 70 | :for sender = (cdr amsg) 71 | :do 72 | ;; `submit-message' is internal API but can be used here 73 | ;; to implement this functionality 74 | (submit-message *self* msg nil sender nil)) 75 | (setf stashed-messages '())) 76 | t) 77 | -------------------------------------------------------------------------------- /src/tasks.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.tasks 2 | (:use :cl) 3 | (:nicknames :tasks) 4 | (:import-from #:binding-arrows 5 | #:->>) 6 | (:import-from #:act 7 | #:*state* 8 | #:*sender*) 9 | (:export #:with-context 10 | #:task 11 | #:task-yield 12 | #:task-start 13 | #:task-async 14 | #:task-await 15 | #:task-shutdown 16 | #:task-async-stream 17 | #:*task-context* 18 | #:*task-dispatcher*)) 19 | 20 | (in-package :sento.tasks) 21 | 22 | (defvar *task-context* nil "Optionally set this globally to use the API without using `with-context`.") 23 | (defvar *task-dispatcher* nil "Optionally set a dispatcher id. Same applies here as for `*task-context*`.") 24 | 25 | (defmacro with-context ((context &optional (dispatcher :shared)) &body body) 26 | "`with-context` creates an environment where the `tasks` package functions should be used in. 27 | `context` can be either an `asys:actor-system`, an `ac:actor-context`, or an `act:actor` (or subclass). 28 | `dispatcher` specifies the dispatcher where the tasks is executed in (like thread-pool). 29 | The tasks created using the `tasks` functions will then be created in the given context. 30 | 31 | Example: 32 | 33 | ```elisp 34 | ;; create actor-system 35 | (defparameter *sys* (make-actor-system)) 36 | 37 | (with-context (*sys*) 38 | (task-yield (lambda () (+ 1 1)))) 39 | 40 | => 2 (2 bits, #x2, #o2, #b10) 41 | 42 | ``` 43 | 44 | Since the default `:shared` dispatcher should mainly be used for the message dispatching, 45 | but not so much for longer running tasks it is possible to create an actor system with additional 46 | dispatchers. This additional dispatcher can be utilized for `tasks`. Be aware that the config as used below is merged with the `asys:*default-config*` which means that the dispatcher `:foo` here is really an additional dispatcher. 47 | 48 | ``` 49 | ;; create actor-system with additional (custom) dispatcher 50 | (defparameter *sys* (asys:make-actor-system '(:dispatchers (:foo (:workers 16))))) 51 | 52 | (with-context (*sys* :foo) 53 | (task-yield (lambda () (+ 1 1)))) 54 | 55 | ``` 56 | " 57 | `(let ((*task-context* ,context) 58 | (*task-dispatcher* ,dispatcher)) 59 | ,@body)) 60 | 61 | (defclass task (act:actor) () 62 | (:documentation 63 | "A dedicated `act:actor` subclass used for tasks.")) 64 | 65 | (defun make-task (context dispatcher) 66 | (ac:actor-of context 67 | :dispatcher dispatcher 68 | :type 'task 69 | :receive (lambda (msg) 70 | (cond 71 | ((eq :get msg) 72 | *state*) 73 | ((eq :exec (car msg)) 74 | (handler-case 75 | (let ((fun-result (funcall (cdr msg)))) 76 | (setf *state* fun-result) 77 | (when *sender* 78 | (act:tell *sender* fun-result)) 79 | fun-result) 80 | (error (c) 81 | (let ((err-result (cons :handler-error c))) 82 | (setf *state* err-result) 83 | (when *sender* 84 | (act:tell *sender* err-result)) 85 | err-result)))) 86 | (t :unrecognized-command))))) 87 | 88 | (defun task-yield (fun &optional time-out) 89 | "`task-yield` runs the given function `fun` by blocking and waiting for a response from the `task`, or until the given timeout was elapsed. 90 | `fun` must be a 0-arity function. 91 | 92 | A normal response from the actor is passed back as the response value. 93 | If the timeout elapsed the response is: `(values :handler-error miscutils:ask-timeout)`. 94 | 95 | Example: 96 | 97 | ```elisp 98 | ;; create actor-system 99 | (defparameter *sys* (make-actor-system)) 100 | 101 | (with-context (*sys*) 102 | (task-yield (lambda () (+ 1 1)))) 103 | 104 | => 2 (2 bits, #x2, #o2, #b10) 105 | ``` 106 | " 107 | (let ((task (make-task *task-context* *task-dispatcher*))) 108 | (unwind-protect 109 | (let ((ask-result (act:ask-s task (cons :exec fun) :time-out time-out))) 110 | (cond 111 | ((consp ask-result) 112 | (values (car ask-result) (cdr ask-result))) 113 | (t ask-result))) 114 | (ac:stop *task-context* task)))) 115 | 116 | (defun task-start (fun) 117 | "`task-start` runs the given function `fun` asynchronously. 118 | `fun` must be a 0-arity function. 119 | Use this if you don't care about any response or result, i.e. for I/O side-effects. 120 | It returns `(values :ok )`. ` is in fact an actor given back as reference. 121 | The task is automatically stopped and removed from the context and will not be able to handle requests." 122 | (let ((task (make-task *task-context* *task-dispatcher*))) 123 | (unwind-protect 124 | (progn 125 | (act:tell task (cons :exec fun)) 126 | (values :ok task)) 127 | (act:tell task :stop)))) 128 | 129 | (defun task-async (fun &key on-complete-fun) 130 | "`task-async` schedules the function `fun` for asynchronous execution. 131 | `fun` must be a 0-arity function. 132 | `on-complete-fun` is a 1-arity completion handler function. When called the result is delivered. 133 | The completion handler function parameter may also be a `(cons :handler-error condition)` construct in case an error happened within the message handling. 134 | 135 | Be aware about the execution of the completion function: 136 | The completion function is, by a very high chance, executed by the thread that executed `fun` function. 137 | Only in very rare cases it could be possible that the completion function is executed by the caller of `task-async`. See `future:fcompleted` for more info. 138 | 139 | Using `task-async` provides two alternatives: 140 | 141 | - together with `task-await` 142 | - or with completion handler 143 | 144 | In fact it is possible to call `task-await` as well, but then you probably don't need a completion handler. 145 | Using the completion handler makes the processing complete asynchronous. 146 | 147 | The result of `task-async` is a `task`. 148 | Store this `task` for a call to `task-async` (even with or without using `on-complete-fun`). 149 | When _not_ using `on-complete-fun` users must call either `task-await` or `task-shutdown` for the task to be cleaned up. 150 | When using `on-complete-fun` this is done for you. 151 | 152 | Example: 153 | 154 | ```elisp 155 | ;; create actor-system 156 | (defparameter *sys* (make-actor-system)) 157 | 158 | (with-context (*sys*) 159 | (let ((x (task-async (lambda () (some bigger computation)))) 160 | (y 1)) 161 | (+ (task-await x) y))) 162 | 163 | ;; use-case with `on-complete-fun` 164 | (defun my-task-completion (result) 165 | (do-something-with result)) 166 | 167 | (with-context (*sys*) 168 | (task-async (lambda () (some-bigger-computation)) 169 | :on-complete-fun #'my-task-completion)) 170 | ``` 171 | " 172 | (let ((task (make-task *task-context* *task-dispatcher*))) 173 | (if on-complete-fun 174 | (progn 175 | (future:fcompleted (act:ask task (cons :exec fun)) 176 | (result) 177 | (funcall on-complete-fun result) 178 | (ac:stop *task-context* task)) 179 | task) 180 | (progn 181 | (act:tell task (cons :exec fun)) 182 | task)))) 183 | 184 | (defun task-await (task &optional time-out) 185 | "`task-await` waits (by blocking) until a result has been generated for a previous `task-async` by passing the `task` result of `task-async` to `task-await`. 186 | Specify `time-out` in seconds. If `task-await` times out a `(cons :handler-error 'ask-timeout)` will be returned. 187 | `task-await` also stops the `task` that is the result of `task-async`, so it is of no further use." 188 | (let ((task-state (act-cell:state task))) 189 | (if task-state 190 | task-state 191 | (unwind-protect 192 | (act:ask-s task :get :time-out time-out) 193 | (ac:stop *task-context* task))))) 194 | 195 | (defun task-shutdown (task) 196 | "`task-shutdown` shuts down a task in order to clean up resources." 197 | (ac:stop *task-context* task)) 198 | 199 | (defun task-async-stream (fun lst) 200 | "`task-async-stream` concurrently applies `fun` on all elements of `lst`. 201 | `fun` must be a one-arity function taking an element of `lst`. 202 | 203 | The concurrency depends on the number of available `:shared` dispatcher workers. 204 | Each element of `lst` is processed by a worker of the `asys:actor-system`s `:shared` dispatcher. 205 | If all workers are busy then the computation of `fun` is queued. 206 | 207 | Example: 208 | 209 | ```elisp 210 | ;; create actor-system 211 | (defparameter *sys* (make-actor-system)) 212 | 213 | (with-context (*sys*) 214 | (->> 215 | '(1 2 3 4 5) 216 | (task-async-stream #'1+) 217 | (reduce #'+))) 218 | 219 | => 20 (5 bits, #x14, #o24, #b10100) 220 | ``` 221 | " 222 | (->> 223 | lst 224 | (mapcar (lambda (x) (task-async (lambda () (funcall fun x))))) 225 | (mapcar #'task-await))) 226 | -------------------------------------------------------------------------------- /src/timeutils.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.timeutils 2 | (:nicknames :timeutils) 3 | (:use :cl) 4 | (:import-from #:alexandria 5 | #:with-gensyms) 6 | (:export #:wait-cond 7 | #:ask-timeout 8 | #:with-waitfor 9 | #:cause 10 | #:make-timer 11 | #:get-current-millis)) 12 | 13 | (in-package :sento.timeutils) 14 | 15 | (defun wait-cond (cond-fun &optional (sleep-time 0.05) (max-time 12)) 16 | "Waits until `cond-fun' is not `nil' or `max-time' elapsed. 17 | This blocks the calling thread." 18 | (loop 19 | :for fun-result := (funcall cond-fun) 20 | :with wait-acc := 0 21 | :while (and (not fun-result) (< wait-acc max-time)) 22 | :do (progn 23 | (sleep sleep-time) 24 | (incf wait-acc sleep-time)) 25 | :finally (return fun-result))) 26 | 27 | (define-condition ask-timeout (serious-condition) 28 | ((wait-time :initform nil 29 | :initarg :wait-time 30 | :reader wait-time) 31 | (cause :initform nil 32 | :initarg :cause 33 | :reader cause)) 34 | (:report (lambda (c stream) 35 | (format stream "A timeout set to ~a seconds occurred. Cause: " 36 | (wait-time c)) 37 | (print (cause c) stream)))) 38 | 39 | (defmacro with-waitfor ((wait-time) &body body) 40 | "Spawns thread with timeout. Blocks until computation is done, or timeout elapsed." 41 | (with-gensyms (c) 42 | `(handler-case 43 | (bt2:with-timeout (,wait-time) 44 | ,@body) 45 | (bt2:timeout (,c) 46 | (error ,c)) 47 | ;; the below is not needed anymore with SBCL 2.1. Will keep it anyway for compatibility. 48 | #+sbcl 49 | (sb-ext:timeout (,c) 50 | (declare (ignore ,c)) 51 | (log:warn "sb-ext:timeout, wrapping to 'expired'.") 52 | (error 'bt2:timeout :seconds ,wait-time))))) 53 | 54 | (defun make-timer (delay run-fun) 55 | (bt2:make-thread (lambda () 56 | (sleep delay) 57 | (funcall run-fun)) 58 | :name (string (gensym "timer-")))) 59 | 60 | (defun get-current-millis () 61 | (let ((now (get-internal-real-time))) 62 | (if (> internal-time-units-per-second 1000) 63 | (truncate (/ now 1000)) 64 | now))) 65 | -------------------------------------------------------------------------------- /src/wheel-timer.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.wheel-timer 2 | (:use :cl) 3 | (:nicknames :wt) 4 | (:export #:wheel-timer 5 | #:make-wheel-timer 6 | #:schedule-once 7 | #:schedule-recurring 8 | #:cancel 9 | #:shutdown-wheel-timer)) 10 | 11 | (in-package :sento.wheel-timer) 12 | 13 | (defclass wheel-timer () 14 | ((wheel :initform nil 15 | :accessor wheel 16 | :documentation "The wheel timer.") 17 | (timer-hash :initform (make-hash-table :test 'equal) 18 | :accessor timer-hash 19 | :documentation "Hash table of timers. Primarily used to cancel recurring timers.")) 20 | (:documentation "Wheel timer class")) 21 | 22 | (defmethod print-object ((obj wheel-timer) stream) 23 | (print-unreadable-object (obj stream :type t) 24 | (with-slots (wheel) obj 25 | (format stream "wheel-timer resolution: ~a, size: ~a" 26 | (tw:wheel-resolution wheel) 27 | (length (tw::slots wheel)))))) 28 | 29 | (defun make-wheel-timer (&rest config) 30 | "Creates a new `wt:wheel-timer`. 31 | 32 | `config` is a parameter for a list of key parameters including: 33 | 34 | - `:resolution` the timer time resolution in milliseconds. 100 milliseconds is a good default. 35 | - `:max-size` the number of timer slots this wheel should have. 36 | 37 | Note that an `asys:actor-system` includes an instance as `asys:scheduler` that can be used within actors. 38 | But you can also create your own instance." 39 | (let ((instance (make-instance 'wheel-timer))) 40 | (setf (wheel instance) 41 | (tw:make-wheel (getf config :max-size 500) 42 | (getf config :resolution 100))) 43 | (tw:initialize-timer-wheel (wheel instance)) 44 | instance)) 45 | 46 | (defun schedule-once (wheel-timer delay timer-fun &key (sig nil) (reuse-sig nil)) 47 | "Schedule a function execution once: 48 | 49 | - `wheel-timer` is the `wt:wheel-timer` instance. 50 | - `delay` is the number of seconds (float) delay when `timer-fun` should be executed. 51 | - `timer-fun` is a 0-arity function that is executed after `delay`. BEWARE: the function is executed in the timer thread. Make sure that you off-load long running tasks to other threads, or to a custom dispatcher (i.e. `tasks`). 52 | - `sig` is an optional symbol or string that is used to identify the timer and is used for `cancel`. 53 | - `reuse-sig` is a boolean that indicates whether the signature should be cleaned up after the timer has been executed. 54 | 55 | Returns: signature (symbol) that represents the timer and can be used to cancel the timer." 56 | (let ((signature (or sig (gensym "timer-"))) 57 | (timer-hash (timer-hash wheel-timer))) 58 | (let ((timer (tw:make-timer (lambda (wheel timer) 59 | (declare (ignore wheel timer)) 60 | (ignore-errors 61 | (funcall timer-fun)) 62 | (unless reuse-sig 63 | (remhash signature timer-hash)))))) 64 | (setf (gethash signature timer-hash) timer) 65 | (tw:schedule-timer (wheel wheel-timer) 66 | timer 67 | :milliseconds (round (* delay 1000))) 68 | signature))) 69 | 70 | (defun schedule-recurring (wheel-timer initial-delay delay timer-fun &optional (sig nil)) 71 | "Schedule a recurring function execution: 72 | 73 | - `wheel-timer` is the `wt:wheel-timer` instance. 74 | - `initial-delay` is the number of seconds (float) delay when `timer-fun` is executed the first time. 75 | - `delay` is the number of seconds (float) delay when `timer-fun` should be executed. 76 | - `timer-fun` is a 0-arity function that is executed after `delay`. BEWARE: the function is executed in the timer thread. Make sure that you off-load long running tasks to other threads, or to a custom dispatcher (i.e. `tasks`). 77 | - `sig` is an optional symbol or string that is used to identify the timer and is used for `cancel-recurring`. 78 | 79 | Returns the signature that was either passed in via `sig` or a generated one. 80 | The signature can be used to cancel the timer via `cancel-recurring`." 81 | (let ((signature (or sig (gensym "recurring-timer-"))) 82 | (timer-hash (timer-hash wheel-timer)) 83 | (recurring-timer-fun)) 84 | (setf recurring-timer-fun 85 | (lambda () 86 | ;; only if signature still exists in hash-table. 87 | ;; the timer could have been cancelled. 88 | (when (gethash signature timer-hash) 89 | (funcall timer-fun) 90 | (schedule-once wheel-timer delay recurring-timer-fun :sig signature :reuse-sig t)))) 91 | (schedule-once wheel-timer initial-delay recurring-timer-fun :sig signature :reuse-sig t) 92 | signature)) 93 | 94 | (defun cancel (wheel-timer sig) 95 | "Cancels a timer with the given signature `sig`." 96 | (let ((timer (gethash sig (timer-hash wheel-timer)))) 97 | (remhash sig (timer-hash wheel-timer)) ;; can be removed anyway 98 | (when timer 99 | (tw:uninstall-timer (wheel wheel-timer) timer)))) 100 | 101 | (defun shutdown-wheel-timer (wheel-timer) 102 | "Shuts down the wheel timer and free resources." 103 | (when wheel-timer 104 | (clrhash (timer-hash wheel-timer)) 105 | (tw:shutdown-timer-wheel (wheel wheel-timer)))) 106 | -------------------------------------------------------------------------------- /tests/actor-mp-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.actor-mp-test 2 | (:use :cl :fiveam :act :future) 3 | (:shadow #:! #:?)) 4 | 5 | (in-package :sento.actor-mp-test) 6 | 7 | (def-suite actor-mp-tests 8 | :description "actor mp tests" 9 | :in sento.tests:test-suite) 10 | 11 | (in-suite actor-mp-tests) 12 | 13 | (log:config :warn) 14 | 15 | (defparameter *receive-fun* (lambda (message) 16 | (case message 17 | (:add 18 | (let ((new-state (1+ *state*))) 19 | (setf *state* new-state) 20 | (when *sender* 21 | (tell *sender* new-state)) 22 | new-state)) 23 | (:sub 24 | (let ((new-state (1- *state*))) 25 | (setf *state* new-state) 26 | (when *sender* 27 | (tell *sender* new-state)) 28 | new-state)) 29 | (:get 30 | (let ((state *state*)) 31 | (when *sender* 32 | (tell *sender* state)) 33 | state))))) 34 | 35 | (def-fixture mp-setup (queue-size pinned shared) 36 | (setf lparallel:*kernel* (lparallel:make-kernel 8)) 37 | 38 | (defclass counter-actor (actor) ()) 39 | 40 | (when pinned 41 | (run-pinned-test queue-size 42 | (&body))) 43 | 44 | (when shared 45 | (run-system-test :random 46 | (&body)) 47 | (run-system-test :round-robin 48 | (&body))) 49 | 50 | (lparallel:end-kernel)) 51 | 52 | (defmacro run-pinned-test (queue-size &body body) 53 | `(progn 54 | (format t "~%Running non-system tests (~a)...~%" ,queue-size) 55 | (let* ((cut (make-instance 'counter-actor 56 | :name "counter-actor" 57 | :state 0 58 | :receive *receive-fun*)) 59 | #-sbcl (max-loop 10000) 60 | #+sbcl (max-loop (* 8 25)) 61 | (per-thread (/ max-loop 8))) 62 | (setf (act-cell:msgbox cut) (make-instance 'mesgb:message-box/bt :max-queue-size ,queue-size)) 63 | ,@body 64 | (act-cell:stop cut)) 65 | (format t "Running non-system tests (~a)...done~%" ,queue-size))) 66 | 67 | (defmacro run-system-test (dispatcher-strategy &body body) 68 | `(progn 69 | (format t "Running system tests (~a)...~%" ,dispatcher-strategy) 70 | (let* ((system (asys:make-actor-system '(:dispatchers 71 | (:shared 72 | (:workers 4 73 | :strategy ,dispatcher-strategy))))) 74 | (cut (ac:actor-of system 75 | :receive *receive-fun* :type 'counter-actor :state 0)) 76 | #-sbcl (max-loop 10000) 77 | #+sbcl (max-loop (* 8 25)) 78 | (per-thread (/ max-loop 8))) 79 | (unwind-protect 80 | ,@body 81 | (act-cell:stop cut) 82 | (ac:shutdown system))) 83 | (format t "Running system tests (~a)...done~%" ,dispatcher-strategy))) 84 | 85 | (test counter-mp-unbounded 86 | "Counter server - multi processors - unbounded queue" 87 | (with-fixture mp-setup (nil t t) 88 | (map nil #'lparallel:force 89 | (mapcar (lambda (x) 90 | (declare (ignore x)) 91 | (lparallel:future 92 | (dotimes (n (1+ per-thread)) 93 | (ask-s cut :add)) 94 | (dotimes (n per-thread) 95 | (ask-s cut :sub)))) 96 | (loop :repeat 8 :collect "n"))) 97 | (is (= 8 (ask-s cut :get))))) 98 | 99 | (test counter-mp-unbounded--mixed 100 | "Counter server - multi processors - unbounded queue - mixed ask-s and ask" 101 | (with-fixture mp-setup (nil nil t) 102 | (mapcar (lambda (x) 103 | (declare (ignore x)) 104 | (bt2:make-thread 105 | (lambda () 106 | (loop :repeat (1+ per-thread) 107 | :for async = (random 2) 108 | :if (= async 1) 109 | :do (tell cut :add) 110 | :else 111 | :do (ask-s cut :add)) 112 | (loop :repeat per-thread 113 | :for async = (random 2) 114 | :if (= async 1) 115 | :do (tell cut :sub) 116 | :else 117 | :do (ask-s cut :sub))))) 118 | (loop :repeat 8 :collect "n")) 119 | (is (miscutils:assert-cond (lambda () (= 8 (ask-s cut :get))) 3 0.2)))) 120 | 121 | (test counter-mp-bounded 122 | "Counter server - multi processors - bounded queue" 123 | (with-fixture mp-setup (100 t t) 124 | (map nil #'lparallel:force 125 | (mapcar (lambda (x) 126 | (declare (ignore x)) 127 | (lparallel:future 128 | (dotimes (n (1+ per-thread)) 129 | (ask-s cut :add)) 130 | (dotimes (n per-thread) 131 | (ask-s cut :sub)))) 132 | (loop :repeat 8 :collect "n"))) 133 | (is (= 8 (ask-s cut :get))))) 134 | -------------------------------------------------------------------------------- /tests/actor-tree-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.actor-tree-test 2 | (:use :cl :fiveam) 3 | (:export #:run! 4 | #:all-tests 5 | #:nil)) 6 | (in-package :sento.actor-tree-test) 7 | 8 | (def-suite actor-tree-tests 9 | :description "Tests on actor trees." 10 | :in sento.tests:test-suite) 11 | 12 | (in-suite actor-tree-tests) 13 | 14 | (def-fixture test-system () 15 | (let ((system (asys:make-actor-system '(:dispatchers (:shared (:workers 0)))))) 16 | (unwind-protect 17 | (&body) 18 | (ac:shutdown system)))) 19 | 20 | (test actor-tree 21 | "Paths, etc. in a tree." 22 | 23 | (with-fixture test-system () 24 | (let* ((root (ac:actor-of system 25 | :receive (lambda (self msg state) 26 | (declare (ignore self msg state))) 27 | :name "1")) 28 | (first (ac:actor-of (act:context root) 29 | :receive (lambda (self msg state) 30 | (declare (ignore self msg state))) 31 | :name "2")) 32 | (second (ac:actor-of (act:context first) 33 | :receive (lambda (self msg state) 34 | (declare (ignore self msg state))) 35 | :name "3")) 36 | (third (ac:actor-of (act:context second) 37 | :receive (lambda (self msg state) 38 | (declare (ignore self msg state))) 39 | :name "4"))) 40 | 41 | (is (string= "/user/1" (act:path root))) 42 | (is (string= "/user/1/2" (act:path first))) 43 | (is (string= "/user/1/2/3" (act:path second))) 44 | (is (string= "/user/1/2/3/4" (act:path third)))))) 45 | -------------------------------------------------------------------------------- /tests/agent-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.agent-test 2 | (:use :cl :fiveam :sento.agent) 3 | (:import-from #:miscutils 4 | #:await-cond) 5 | (:export #:run! 6 | #:all-tests 7 | #:nil)) 8 | 9 | (in-package :sento.agent-test) 10 | 11 | (def-suite agent-tests 12 | :description "agent tests" 13 | :in sento.tests:test-suite) 14 | 15 | (in-suite agent-tests) 16 | 17 | (log:config :warn) 18 | 19 | (def-fixture agent-fixture (fun) 20 | (let ((agent (make-agent (lambda () (funcall fun))))) 21 | (&body) 22 | (agent-stop agent))) 23 | 24 | (def-fixture agent-asys-fixture (fun) 25 | (let ((asys (asys:make-actor-system '(:dispatchers (:shared (:workers 1)))))) 26 | (unwind-protect 27 | (let ((agent (make-agent (lambda () (funcall fun)) asys))) 28 | (&body)) 29 | (ac:shutdown asys)))) 30 | 31 | (test create-agent 32 | "Creates an agent" 33 | (with-fixture agent-fixture ((lambda () 0)) 34 | (is (not (null agent))))) 35 | 36 | (test create-agent--on-system 37 | "Creates an agent on a system, which implies using a shared dispatcher." 38 | (with-fixture agent-asys-fixture ((lambda () 0)) 39 | (is (not (null agent))) 40 | (is (typep (act-cell:msgbox agent) 'mesgb:message-box/dp)))) 41 | 42 | (test get-agent-state 43 | "Gets agent state" 44 | (with-fixture agent-fixture ((lambda () '(5 4 3))) 45 | (is (equalp '(5 4 3) (agent-get agent #'identity))))) 46 | 47 | (test get-agent-state--on-system 48 | "Gets agent state - with agent on system." 49 | (with-fixture agent-asys-fixture ((lambda () '(5 4 3))) 50 | (is (equalp '(5 4 3) (agent-get agent #'identity))))) 51 | 52 | (test update-agent-state 53 | "Updates agent state" 54 | (with-fixture agent-fixture ((lambda () '(5 4 3))) 55 | (is (equalp '(5 4 3) (agent-get agent #'identity))) 56 | (is (agent-update agent (lambda (state) (mapcar #'1+ state)))) 57 | (is-true (await-cond 1.0 58 | (equalp '(6 5 4) (agent-get agent #'identity)))))) 59 | 60 | (test update-and-get 61 | "Tests update and get function" 62 | (with-fixture agent-fixture ((lambda () 0)) 63 | (is (= 0 (agent-get agent #'identity))) 64 | (is (= 1 (agent-update-and-get agent #'1+))) 65 | (is (= 2 (agent-update-and-get agent #'1+))))) 66 | 67 | (test update-agent-state--on-system 68 | "Updates agent state - with agent on system." 69 | (with-fixture agent-asys-fixture ((lambda () '(5 4 3))) 70 | (is (equalp '(5 4 3) (agent-get agent #'identity))) 71 | (is (agent-update agent (lambda (state) (mapcar #'1+ state)))) 72 | (is-true (await-cond 1.0 73 | (equalp '(6 5 4) (agent-get agent #'identity)))))) 74 | 75 | (test stop-agent 76 | "Stop agent to cleanup resources." 77 | (let ((agent (make-agent (lambda () nil)))) 78 | (agent-stop agent) 79 | (is-true (await-cond 1.0 80 | (eq :stopped (agent-get agent #'identity)))))) 81 | 82 | (test stop-agent--on-system 83 | "Stop agent to cleanup resources - with agent on system." 84 | (with-fixture agent-asys-fixture ((lambda () '(5 4 3))) 85 | (agent-stop agent) 86 | (is-true (await-cond 1.0 87 | (eq :stopped (agent-get agent #'identity)))))) 88 | -------------------------------------------------------------------------------- /tests/all-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.tests 2 | (:use :cl :fiveam) 3 | (:export #:run! 4 | #:all-tests 5 | #:nil 6 | #:test-suite)) 7 | 8 | (in-package :sento.tests) 9 | 10 | (def-suite test-suite 11 | :description "All catching test suite.") 12 | 13 | (in-suite test-suite) 14 | 15 | (test foo 16 | "Trivial test" 17 | (is (= 1 1))) 18 | -------------------------------------------------------------------------------- /tests/array-agent-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.agent.array-test 2 | (:use :cl :fiveam :sento.agent.array) 3 | (:export #:run! 4 | #:all-tests 5 | #:nil)) 6 | (in-package :sento.agent.array-test) 7 | 8 | (def-suite agent.array-tests 9 | :description "Tests for array agent" 10 | :in sento.tests:test-suite) 11 | 12 | (in-suite agent.array-tests) 13 | 14 | (def-fixture asys-fixture () 15 | (let ((asys (asys:make-actor-system '(:dispatchers (:shared (:workers 1)))))) 16 | (unwind-protect 17 | (&body) 18 | (ac:shutdown asys)))) 19 | 20 | (def-fixture agt (arr err-fun) 21 | (let ((cut (make-array-agent nil :initial-array arr :error-fun err-fun))) 22 | (unwind-protect 23 | (&body) 24 | (agt:agent-stop cut)))) 25 | 26 | (test create 27 | "Tests creating a array agent." 28 | (let ((cut (make-array-agent nil :initial-array #()))) 29 | (is-true cut) 30 | (agt:agent-stop cut))) 31 | 32 | (test create--in-system 33 | "Tests creating a array agent with providing an actor-context." 34 | (with-fixture asys-fixture () 35 | (let ((cut (make-array-agent asys :initial-array #()))) 36 | (is-true cut)))) 37 | 38 | (test agent-elt 39 | "Tests retrieve element." 40 | (with-fixture agt (#(10 20) nil) 41 | (is (= 10 (agent-elt 0 cut))) 42 | (is (= 20 (agent-elt 1 cut))))) 43 | 44 | (test agent-setf 45 | "Tests setf'ing a value to array." 46 | (with-fixture agt (#(10 20) nil) 47 | (is (= 11 (setf (agent-elt 0 cut) 11))))) 48 | 49 | (test agent-setf--err-no-index 50 | "Tests setf'ing a value to array whos index doesn't exist. 51 | While the test succeeds, error-fun is called." 52 | (let* ((err-cond) 53 | (err-fun (lambda (err) 54 | (setf err-cond err)))) 55 | (with-fixture agt (#() err-fun) 56 | (is (= 11 (setf (agent-elt 0 cut) 11))) 57 | (is (miscutils:assert-cond (lambda () 58 | (not (null err-cond))) 0.5))))) 59 | 60 | (test agent-push 61 | "Tests pushing new value." 62 | (with-fixture agt ((make-array 0 :adjustable t :fill-pointer t) nil) 63 | (is-true (agent-push 1 cut)) 64 | (is-true (agent-push 2 cut)) 65 | (is (= 1 (agent-elt 0 cut))) 66 | (is (= 2 (agent-elt 1 cut))))) 67 | 68 | (test agent-push--err 69 | "Tests pushing new value with calling err-fun." 70 | (let* ((err-cond) 71 | (err-fun (lambda (err) 72 | (setf err-cond err)))) 73 | ;; no fill-pointer 74 | (with-fixture agt ((make-array 0 :adjustable t) err-fun) 75 | (agent-push 1 cut) 76 | (is (miscutils:assert-cond (lambda () (not (null err-cond))) 0.5))))) 77 | 78 | (test agent-push-and-getidx 79 | "Tests pushing with returning the new index." 80 | (with-fixture agt ((make-array 0 :adjustable t :fill-pointer t) nil) 81 | (is (= 0 (agent-push-and-getidx 1 cut))) 82 | (is (= 1 (agent-push-and-getidx 2 cut))))) 83 | 84 | (test agent-push-and-getidx--err 85 | "Tests pushing with returning an error. Missing fill-pointer here." 86 | (with-fixture agt ((make-array 0 :adjustable t) nil) 87 | (is (typep (agent-push-and-getidx 1 cut) 'error)))) 88 | 89 | (test agent-pop 90 | "Tests poping value." 91 | (with-fixture agt ((make-array 0 :adjustable t :fill-pointer t) nil) 92 | (is-true (agent-push 1 cut)) 93 | (is-true (agent-push 2 cut)) 94 | (is (= 2 (agent-pop cut))) 95 | (is (= 1 (agent-pop cut))))) 96 | 97 | (test agent-pop--err 98 | "Tests poping empty array." 99 | (with-fixture agt ((make-array 0 :adjustable t :fill-pointer t) nil) 100 | (is (typep (agent-pop cut) 'error)))) 101 | 102 | (test agent-delete 103 | "Tests deleting an item." 104 | (with-fixture agt ((make-array 0 :adjustable t :fill-pointer t) nil) 105 | (is-true (agent-push "foo" cut)) 106 | (is (string= "foo" (agent-elt 0 cut))) 107 | (is-true (agent-delete "foo" cut :test #'string=)) 108 | (is (typep (agent-elt 0 cut) 'error)))) 109 | 110 | (test agent-delete--err 111 | "Tests deleting an item with calling err-fun. 112 | `delete` does raise an error, at least not that I would know. 113 | So this test just does nothing really." 114 | (let* ((err-cond) 115 | (err-fun (lambda (err) 116 | (setf err-cond err)))) 117 | (with-fixture agt (#() err-fun) 118 | (is-true (agent-delete "foo" cut :test #'string=)) 119 | (is (miscutils:assert-cond (lambda () (null err-cond)) 0.5))))) 120 | 121 | (test agent-doarray 122 | "Tests running arbitrary array operations on the agent." 123 | (with-fixture agt (#() nil) 124 | (is-true (agent-doarray (lambda (array) 125 | (declare (ignore array)) 126 | (remove-if #'evenp #(1 2 3 4 5))) 127 | cut)) 128 | (is (= 1 (agent-elt 0 cut))) 129 | (is (= 3 (agent-elt 1 cut))) 130 | (is (= 5 (agent-elt 2 cut))))) 131 | -------------------------------------------------------------------------------- /tests/atomic-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.atomic-test 2 | (:use :cl :fiveam :sento.atomic) 3 | (:export #:run! 4 | #:all-tests 5 | #:nil)) 6 | (in-package :sento.atomic-test) 7 | 8 | (def-suite atomic-tests 9 | :description "Tests for atomic." 10 | :in sento.tests:test-suite) 11 | 12 | (in-suite atomic-tests) 13 | 14 | (test make-atomic-reference 15 | "Tests making an atomic reference" 16 | (is (make-atomic-reference :value '()))) 17 | 18 | (test swap-reference 19 | "Swap a reference." 20 | (let* ((ref (make-atomic-reference :value '(0))) 21 | (fn1 #'append) 22 | (args (list 1 2)) 23 | (fn2 (lambda (lst) (apply #'+ lst)))) 24 | (is (equal '(0 1 2) (atomic-swap ref fn1 args))) ; test with rest args 25 | (is (equal '(0 1 2) (atomic-get ref))) 26 | (is (= 3 (atomic-swap ref fn2))) ; test without rest args 27 | (is (= 3 (atomic-get ref))))) 28 | 29 | (test make-atomic-integer 30 | "Tests making an atomic integer" 31 | (is (make-atomic-integer :value 5))) 32 | 33 | (test swap-integer 34 | "Swap an intreger value." 35 | (let* ((value (make-atomic-integer :value 5)) 36 | (fn1 #'+) 37 | (fn2 #'1+)) 38 | (is (= 8 (atomic-swap value fn1 1 2))) 39 | (is (= 8 (atomic-get value))) 40 | (is (= 9 (atomic-swap value fn2))) 41 | (is (= 9 (atomic-get value))))) 42 | 43 | #+abcl 44 | (test abcl-atomic-swap-integer 45 | "ABCL atomic swap integer (as well as atomic-cas) test in threads." 46 | (let* ((n 100) 47 | (aint (make-atomic-integer :value 0)) 48 | (threads (loop repeat n 49 | collect (bt2:make-thread (lambda () 50 | (atomic-swap aint (lambda (int) (+ int 1000))) 51 | (atomic-swap aint (lambda (int) (- int 10000))) 52 | (atomic-swap aint (lambda (int) (+ int 10000))) 53 | (atomic-swap aint (lambda (int) (- int 1000)))))))) 54 | (mapc #'bt2:join-thread threads) 55 | (is (= 0 (atomic-get aint))))) 56 | 57 | #+abcl 58 | (test abcl-atomic-swap-reference 59 | "ABCL atomic swap reference (as well as atomic-cas) test in threads." 60 | (let* ((n 100) 61 | (a-ref (make-atomic-reference :value nil)) 62 | (threads (loop repeat n 63 | collect (bt2:make-thread (lambda () 64 | (atomic-swap a-ref (lambda (ref) (push 0 ref))) 65 | (atomic-swap a-ref (lambda (ref) (pop ref) nil)) 66 | (atomic-swap a-ref (lambda (ref) (push 1 ref))) 67 | (atomic-swap a-ref (lambda (ref) (pop ref) nil))))))) 68 | (mapc #'bt2:join-thread threads) 69 | (is (eql nil (atomic-get a-ref))))) 70 | 71 | #+abcl 72 | (test atomic-incf 73 | "Basic tests of increasing an atomic-integer object." 74 | (let ((aint (make-atomic-integer :value 0))) 75 | (is (= 0 (atomic::atomic-incf aint))) 76 | (is (= 1 (atomic-get aint))) 77 | (is (= 1 (atomic::atomic-incf aint 10))) 78 | (is (= 11 (atomic-get aint))) 79 | (is (= 11 (atomic::atomic-incf aint -10))) 80 | (is (= 1 (atomic-get aint))))) 81 | 82 | #+abcl 83 | (test atomic-incf-threads 84 | "Test increasing an atomic-integer object in threads." 85 | (let* ((n 100) 86 | (aint (make-atomic-integer :value 0)) 87 | (threads (loop repeat n 88 | collect (bt2:make-thread (lambda () 89 | (atomic::atomic-incf aint 100) 90 | (atomic::atomic-incf aint -1000) 91 | (atomic::atomic-incf aint +1000) 92 | (atomic::atomic-incf aint -100)))))) 93 | (mapc #'bt2:join-thread threads) 94 | (is (= 0 (atomic-get aint))))) 95 | -------------------------------------------------------------------------------- /tests/bounded-queue-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.bounded-queue-test 2 | (:use :cl :fiveam :sento.queue) 3 | (:export #:run! 4 | #:all-tests 5 | #:nil)) 6 | (in-package :sento.bounded-queue-test) 7 | 8 | (def-suite bounded-queue-tests 9 | :description "Tests bounded queue" 10 | :in sento.tests:test-suite) 11 | 12 | (in-suite bounded-queue-tests) 13 | 14 | (test bounded-queue--push-pop 15 | (let ((cut (make-instance 'queue-bounded :max-items 2))) 16 | (pushq cut 1) 17 | (is-false (emptyq-p cut)) 18 | (is (= 1 (popq cut))) 19 | (is-true (emptyq-p cut)))) 20 | 21 | (test bounded-queue--raise-condition-when-queue-full 22 | (let ((cut (make-instance 'queue-bounded :max-items 2))) 23 | (pushq cut 1) 24 | (pushq cut 2) 25 | (is (= 2 (queued-count cut))) 26 | (signals queue-full-error (pushq cut 3)) 27 | (is (= 1 (popq cut))) 28 | (is (= 1 (queued-count cut))) 29 | (pushq cut 3))) 30 | -------------------------------------------------------------------------------- /tests/config-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.config-test 2 | (:use :cl :fiveam :sento.config) 3 | (:export #:run! 4 | #:all-tests 5 | #:nil)) 6 | (in-package :sento.config-test) 7 | 8 | (def-suite config-tests 9 | :description "Tests for config parsing" 10 | :in sento.tests:test-suite) 11 | 12 | (in-suite config-tests) 13 | 14 | (test parse-empty-config 15 | "Parses empty config" 16 | (is (not (config-from nil)))) 17 | 18 | (test config-from 19 | "Parses config. `config-from' returns a plist where each key is a section." 20 | (let ((config (config-from 21 | (prin1-to-string 22 | '(defconfig 23 | (:foo 24 | (:one 1 25 | :two 2) 26 | :bar 27 | (:three "3" 28 | :four "4"))))))) 29 | (is (not (null config))) 30 | (is (listp config)) 31 | (is (equal '(:foo (:one 1 :two 2) :bar (:three "3" :four "4")) config)))) 32 | 33 | (test config-from--err 34 | "Parses config. Error, not correct CONFIG" 35 | (handler-case 36 | (config-from 37 | (prin1-to-string 38 | '(something))) 39 | (error (c) 40 | (is (string= "Unrecognized config!" (format nil "~a" c)))))) 41 | 42 | (test retrieve-section 43 | "Retrieves config section." 44 | (let ((config (config-from 45 | (prin1-to-string 46 | '(defconfig 47 | (:foo 48 | (:bar 5))))))) 49 | (is (not (null config))) 50 | (is (listp config)) 51 | (is (not (null (retrieve-section config :foo)))) 52 | (is (listp (retrieve-section config :foo))) 53 | (is (equal '(:bar 5) (retrieve-section config :foo))))) 54 | 55 | (test retrieve-keys 56 | "Retrieves all section keys" 57 | (is (equal nil 58 | (retrieve-keys (config-from (prin1-to-string '(defconfig)))))) 59 | (is (equal '(:foo :bar :buzz) 60 | (retrieve-keys (config-from (prin1-to-string '(defconfig (:foo 1 :bar 2 :buzz 3)))))))) 61 | 62 | (test retrieve-value 63 | "Retrieves a value from a section." 64 | (let ((config (config-from 65 | (prin1-to-string 66 | '(defconfig 67 | (:foo 68 | (:bar 5))))))) 69 | (is (= 5 (retrieve-value (retrieve-section config :foo) :bar))))) 70 | 71 | (test merge-config--no-fallback 72 | "Merges two configs, but fallback is nil." 73 | (let ((config '(:foo (:bar 1)))) 74 | (is (equal config (merge-config config nil))))) 75 | 76 | (test merge-config--only-fallback 77 | "Merges two configs, but only fallback exists." 78 | (let ((fallback-config '(:foo (:bar 1)))) 79 | (is (equal fallback-config (merge-config nil fallback-config))))) 80 | 81 | (test merge-config--overrides-in-fallback--flat 82 | "Merges two configs, config overrides a key in fallback." 83 | (let ((config '(:foo 1)) 84 | (fallback-config '(:foo 2))) 85 | (is (equal '(:foo 1) (merge-config config fallback-config))))) 86 | 87 | (test merge-config--takes-fallback--flat 88 | "Merges two configs, takes fallback." 89 | (let ((config nil) 90 | (fallback-config '(:foo 1))) 91 | (is (equal '(:foo 1) (merge-config config fallback-config))))) 92 | 93 | (test merge-config--config+fallback--flat 94 | "Merges two configs, takes from both" 95 | (let ((config '(:bar 1)) 96 | (fallback-config '(:foo 2 :buzz 3))) 97 | (is (= 1 (retrieve-value (merge-config config fallback-config) :bar))) 98 | (is (= 2 (retrieve-value (merge-config config fallback-config) :foo))) 99 | (is (= 3 (retrieve-value (merge-config config fallback-config) :buzz))))) 100 | 101 | (test merge-config--fallback-sets-structure 102 | "Merges two configs, takes from both" 103 | (let ((config '(:foo 1)) 104 | (fallback-config '(:foo (:bar 2)))) 105 | (is (equal '(:bar 2) (retrieve-value (merge-config config fallback-config) :foo))))) 106 | 107 | (test merge-config--deep 108 | "Merges two configs, merge deep." 109 | (let ((config '(:foo 1 :bar (:buzz 2))) 110 | (fallback-config '(:foo 2 :bar (:buzz 3 :foo2 4)))) 111 | (is (= 1 (retrieve-value (merge-config config fallback-config) :foo))) 112 | (is (listp (retrieve-value (merge-config config fallback-config) :bar))) 113 | (is (= 2 (retrieve-value (retrieve-value (merge-config config fallback-config) :bar) :buzz))) 114 | (is (= 4 (retrieve-value (retrieve-value (merge-config config fallback-config) :bar) :foo2))))) 115 | 116 | (test merge-config--config-but-no-fallback-takes-config 117 | "Merges two configs, when config exists as structure but not fallback then take fallback." 118 | (let ((config '(:foo 1 :bar (:buzz 2))) 119 | (fallback-config '(:foo 2))) 120 | (is (equal '(:buzz 2) (retrieve-value (merge-config config fallback-config) :bar))) 121 | (is (= 1 (retrieve-value (merge-config config fallback-config) :foo))))) 122 | 123 | (test merge-config--config-but-no-fallback-takes-config-2 124 | "Merges two configs, when config exists as structure but not fallback then take fallback." 125 | (let ((config '(:foo 1 :bar (:buzz 2))) 126 | (fallback-config nil)) 127 | (is (equal '(:buzz 2) (retrieve-value (merge-config config fallback-config) :bar))) 128 | (is (= 1 (retrieve-value (merge-config config fallback-config) :foo))))) 129 | -------------------------------------------------------------------------------- /tests/dispatcher-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.dispatcher-test 2 | (:use :cl :fiveam :sento.dispatcher :sento.actor) 3 | (:shadow #:! #:?) 4 | (:import-from #:miscutils 5 | #:assert-cond)) 6 | 7 | (in-package :sento.dispatcher-test) 8 | 9 | (def-suite dispatcher-tests 10 | :description "Tests for dispatcher" 11 | :in sento.tests:test-suite) 12 | 13 | (in-suite dispatcher-tests) 14 | 15 | (def-fixture test-context () 16 | (let ((context (asys:make-actor-system '(:dispatchers (:shared (:workers 0)))))) 17 | (unwind-protect 18 | (&body) 19 | (ac:shutdown context)))) 20 | 21 | 22 | (defun make-test-dispatcher (num-workers context ident) 23 | (make-dispatcher (ac:make-actor-context context) 24 | ident 25 | :workers num-workers)) 26 | 27 | (test create-dispatcher 28 | "Checks creating a dispatcher" 29 | (with-fixture test-context () 30 | (let ((cut (make-test-dispatcher 1 context "foo"))) 31 | (is (not (null cut))) 32 | (is (string= "foo" (identifier cut))) 33 | ;;(is (str:containsp "RANDOM-STRATEGY" (format nil "disp: ~a~%" cut))) 34 | (stop cut)))) 35 | 36 | (test create-dispatcher--with-config 37 | "Tests creating a dispatcher with a custom config." 38 | (with-fixture test-context () 39 | (let ((cut (apply #'make-dispatcher context :foo '(:workers 0 :strategy :round-robin)))) 40 | (is (eq :foo (identifier cut))) 41 | (is (= 0 (length (workers cut)))) 42 | ;;(is (str:containsp "ROUND-ROBIN" (format nil "disp: ~a~%" cut))) 43 | (stop cut)))) 44 | 45 | (test create-the-workers 46 | "Checks that the workers are created as actors" 47 | (with-fixture test-context () 48 | (let ((cut (make-test-dispatcher 4 context "foo"))) 49 | (is (= 4 (length (workers cut)))) 50 | (stop cut)))) 51 | 52 | (test dispatch-to-worker 53 | "Tests the dispatching to a worker" 54 | (defun looper () 55 | (loop :for i :from 1 :to 5 :sum i)) 56 | 57 | (with-fixture test-context () 58 | (let ((cut (make-test-dispatcher 1 context "foo"))) 59 | (is (= 15 (dispatch cut (list #'looper)))) 60 | (stop cut)))) 61 | -------------------------------------------------------------------------------- /tests/fasync-completed-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.async-future-test 2 | (:use :cl :fiveam :sento.future :sento.async-future :miscutils) 3 | (:export #:run! 4 | #:all-tests 5 | #:nil)) 6 | (in-package :sento.async-future-test) 7 | 8 | (def-suite async-future-tests 9 | :description "Tests for async future completion." 10 | :in sento.tests:test-suite) 11 | 12 | (in-suite async-future-tests) 13 | 14 | (def-fixture with-sys () 15 | (let ((asys (asys:make-actor-system))) 16 | (unwind-protect 17 | (progn (&body)) 18 | (ac:shutdown asys)))) 19 | 20 | (test future-completion-works-async 21 | "Async as in it's executed by a defined dispatcher." 22 | (with-fixture with-sys () 23 | (let ((completed-result nil) 24 | (fut (with-fut-resolve 25 | (Format t "~%Called on: ~a~%" (bt2:current-thread)) 26 | (fresolve (+ 1 2))))) 27 | (fasync-completed fut asys :shared 28 | (result) 29 | (format t "~%Completed in: ~a~%" (bt2:current-thread)) 30 | (setf completed-result result)) 31 | (is-true (await-cond 0.5 32 | (eql completed-result 3)))))) 33 | 34 | (test future-completion-async--error--no-future 35 | (with-fixture with-sys () 36 | (handler-case 37 | (fasync-completed nil nil :shared 38 | (result) 39 | (declare (ignore result))) 40 | (error (c) 41 | (is (string= "Arg 'future' is not of required type!" 42 | (simple-condition-format-control c)))) 43 | (:no-error () (fail "Should not be here!"))))) 44 | 45 | (test future-completion-async--error--no-context 46 | (with-fixture with-sys () 47 | (handler-case 48 | (fasync-completed (with-fut "foo") nil :shared 49 | (result) 50 | (declare (ignore result))) 51 | (error (c) 52 | (is (string= "Arg 'context' is not of required type!" 53 | (simple-condition-format-control c)))) 54 | (:no-error () (fail "Should not be here!"))))) 55 | 56 | (test future-completion-async--error--dispatcher-not-known 57 | (with-fixture with-sys () 58 | (handler-case 59 | (fasync-completed (with-fut "foo") asys :not-exists 60 | (result) 61 | (declare (ignore result))) 62 | (error (c) 63 | (is (string= "Dispatcher-id is not known!" 64 | (simple-condition-format-control c)))) 65 | (:no-error () (fail "Should not be here!"))))) 66 | 67 | (test future-completion-async--allow-more-context-types 68 | (with-fixture with-sys () 69 | (let ((act (ac:actor-of asys :receive (lambda (msg) msg))) 70 | (completed-result nil) 71 | (fut (with-fut (+ 1 2)))) 72 | (fasync-completed fut act :shared 73 | (result) 74 | (format t "~%Completed in: ~a~%" (bt2:current-thread)) 75 | (setf completed-result result)) 76 | (is-true (await-cond 0.5 77 | (eql completed-result 3)))))) 78 | -------------------------------------------------------------------------------- /tests/fcomputation-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.future-test 2 | (:use :cl :fiveam :binding-arrows :sento.future) 3 | (:import-from #:miscutils 4 | #:assert-cond) 5 | (:export #:run! 6 | #:all-tests 7 | #:nil)) 8 | (in-package :sento.future-test) 9 | 10 | (def-suite future-tests 11 | :description "Future tests" 12 | :in sento.tests:test-suite) 13 | 14 | (in-suite future-tests) 15 | 16 | (test create-future 17 | "Creates a future" 18 | 19 | (is (typep (make-future nil) 'future)) 20 | (is (typep (make-future (lambda (resolve-fun) 21 | (declare (ignore resolve-fun)) nil)) 22 | 'future)) 23 | (is (futurep (make-future nil)))) 24 | 25 | (test provide-promise 26 | "Executes future and provides promise" 27 | 28 | (let ((future (make-future (lambda (resolve-fun) 29 | (funcall resolve-fun "fulfilled"))))) 30 | (is (eq t (complete-p future))) 31 | (is (string= "fulfilled" (fresult future))))) 32 | 33 | (test on-complete-callback 34 | "Executes future and get result via on-complete callback." 35 | 36 | (let ((future (make-future (lambda (resolve-fun) 37 | (funcall resolve-fun "fulfilled")))) 38 | (completed-value nil)) 39 | (fcompleted future (value) (setf completed-value value)) 40 | (is (string= "fulfilled" completed-value)))) 41 | 42 | (test complete-with-delay 43 | "Test the completion with fcompleted callback with a delayed execution." 44 | 45 | (let ((future (make-future (lambda (resolve-fun) 46 | (bt2:make-thread 47 | (lambda () 48 | (sleep 0.5) 49 | (funcall resolve-fun "fulfilled")))))) 50 | (completed-value)) 51 | (is (eq :not-ready (fresult future))) 52 | (fcompleted future (value) (setf completed-value value)) 53 | (is (eq t (assert-cond (lambda () (string= "fulfilled" completed-value)) 1))))) 54 | 55 | (test complete-with-error 56 | "Test the completion with fcompleted callback with an error." 57 | 58 | (let ((future (make-future (lambda (resolve-fun) 59 | (declare (ignore resolve-fun)) 60 | (error "Some error"))))) 61 | (is (complete-p future)) 62 | (is (error-p future)) 63 | (is (typep (fresult future) 'simple-error)) 64 | (is (equal "Some error" (simple-condition-format-control (fresult future)))))) 65 | 66 | (test mapping-futures--with-fut-macro 67 | "Tests mapping futures" 68 | (flet ((future-generator (x) 69 | (with-fut (+ x 1)))) 70 | (let ((future (fmap (future-generator 0) (completed-value) 71 | (fmap (future-generator completed-value) (completed-value) 72 | (fmap (future-generator completed-value) (completed-value) 73 | completed-value))))) 74 | (is-true (assert-cond (lambda () 75 | (eql 3 (fresult future))) 76 | 1))))) 77 | 78 | (test mapping-using-arrows 79 | "Tests fmap using arrows aka threading with 80 | mixed future, normal and async-future map-fun result." 81 | (let ((completed-val)) 82 | (-> (with-fut 0) 83 | (fmap (value) 84 | (+ value 1)) 85 | (fmap (value) 86 | (with-fut-resolve 87 | (sleep 0.2) 88 | (fresolve (+ value 1)))) 89 | (fmap (value) 90 | (+ value 1)) 91 | (fcompleted (compl-value) 92 | (setf completed-val compl-value))) 93 | (is-true (assert-cond 94 | (lambda () (eq completed-val 3)) 1)))) 95 | 96 | (test mapping--fut-errors 97 | "Tests fmap but one future errors, catch it with `frecover'" 98 | (is (string= "foo" 99 | (fresult 100 | (frecover 101 | (-> (with-fut 0) 102 | (fmap (value) 103 | (with-fut (+ value 1))) 104 | (fmap (value) 105 | (declare (ignore value)) 106 | (error "foo")) 107 | (fmap (value) 108 | (+ value 1))) 109 | (error (c) (format nil "~a" c))))))) 110 | 111 | (test mapping-with-fcompleted 112 | (let ((completed-val)) 113 | (-> (with-fut 0) 114 | (fmap (value) 115 | (with-fut (+ value 1))) 116 | (fcompleted (value) 117 | (setf completed-val value))) 118 | (is-true (assert-cond (lambda () 119 | (= 1 completed-val)) 120 | 1)))) 121 | 122 | (test await-fut 123 | (multiple-value-bind (res fut) 124 | (fawait (with-fut 0) :timeout 1) 125 | (is (= 0 res)) 126 | (is (futurep fut)))) 127 | -------------------------------------------------------------------------------- /tests/hash-agent-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.agent.hash-test 2 | (:use :cl :fiveam :sento.agent.hash) 3 | (:export #:run! 4 | #:all-tests 5 | #:nil)) 6 | (in-package :sento.agent.hash-test) 7 | 8 | (def-suite agent.hash-tests 9 | :description "Tests for hash agent" 10 | :in sento.tests:test-suite) 11 | 12 | (in-suite agent.hash-tests) 13 | 14 | (def-fixture asys-fixture () 15 | (let ((asys (asys:make-actor-system '(:dispatchers (:shared (:workers 1)))))) 16 | (unwind-protect 17 | (&body) 18 | (ac:shutdown asys)))) 19 | 20 | (def-fixture agt (err-fun) 21 | (let ((cut (make-hash-agent nil :initial-hash-table (make-hash-table) 22 | :error-fun err-fun))) 23 | (unwind-protect 24 | (&body) 25 | (agt:agent-stop cut)))) 26 | 27 | (test create 28 | "Tests creating a hash agent." 29 | (let ((cut (make-hash-agent nil :initial-hash-table (make-hash-table)))) 30 | (is-true cut) 31 | (agt:agent-stop cut))) 32 | 33 | (test create--in-system 34 | "Tests creating a hash agent with providing an actor-context." 35 | (with-fixture asys-fixture () 36 | (let ((cut (make-hash-agent asys :initial-hash-table (make-hash-table)))) 37 | (is-true cut)))) 38 | 39 | (test create--with-initial-hash-table 40 | "Tests creating hash agent with initial provided hash-table." 41 | (let ((initial-hash-table (make-hash-table)) 42 | (cut)) 43 | (setf (gethash :foo initial-hash-table) "bar") 44 | (setf cut (make-hash-agent nil :initial-hash-table initial-hash-table)) 45 | (is (string= "bar" (agent-gethash :foo cut))) 46 | (agt:agent-stop cut))) 47 | 48 | (test agent-puthash 49 | "Tests putting a value to hash agent -- private" 50 | (with-fixture agt (nil) 51 | (is (agthash::agent-puthash :key cut "my-value")))) 52 | 53 | (test agent-gethash 54 | "Tests getting a key from hash-agent." 55 | (with-fixture agt (nil) 56 | (is (string= "my-value" (agthash::agent-puthash :key cut "my-value"))) 57 | (is (string= "my-value" (agent-gethash :key cut))))) 58 | 59 | (test agent-setf 60 | "Tests putting a value to hash agent." 61 | (with-fixture agt (nil) 62 | (is (string= "my-value" (setf (agent-gethash :key cut) "my-value"))) 63 | (is (string= "my-value" (agent-gethash :key cut))))) 64 | 65 | (test agent-remhash--exists 66 | "Tests removing a key. Returns T when the key existed." 67 | (with-fixture agt (nil) 68 | (setf (agent-gethash :foo cut) "my-value") 69 | (is (string= "my-value" (agent-gethash :foo cut))) 70 | (is-true (agent-remhash :foo cut)))) 71 | 72 | (test agent-remhash--not-exists 73 | "Tests removing a key. Returns NIL when the key not existed." 74 | (with-fixture agt (nil) 75 | (is-false (agent-remhash :foo cut)))) 76 | 77 | (test agent-clrhash 78 | "Tests clearing a hash table." 79 | (with-fixture agt (nil) 80 | (setf (agent-gethash :foo cut) "my-value") 81 | (is (string= "my-value" (agent-gethash :foo cut))) 82 | (is-true (agent-clrhash cut)) 83 | (is-false (agent-gethash :foo cut)))) 84 | 85 | (test agent-dohash 86 | "Tests 'do' on hash table." 87 | (with-fixture agt (nil) 88 | (setf (agent-gethash :foo cut) 1) 89 | (setf (agent-gethash :bar cut) 2) 90 | (is-true (agent-dohash (lambda (hash-table) 91 | (setf (gethash :foo hash-table) 10) 92 | (setf (gethash :bar hash-table) 20) 93 | (setf (gethash :buzz hash-table) 30) 94 | hash-table) 95 | cut)) 96 | (is (= 10 (agent-gethash :foo cut))) 97 | (is (= 20 (agent-gethash :bar cut))) 98 | (is (= 30 (agent-gethash :buzz cut))))) 99 | -------------------------------------------------------------------------------- /tests/message-box-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.message-box-test 2 | (:use :cl :fiveam :cl-mock :sento.actor :sento.future) 3 | (:shadow #:! #:?) 4 | (:import-from #:miscutils 5 | #:assert-cond 6 | #:await-cond 7 | #:filter) 8 | (:import-from #:timeutils 9 | #:ask-timeout) 10 | (:import-from #:sento.messageb 11 | #:message-box/bt 12 | #:submit 13 | #:no-result 14 | #:queue-thread 15 | #:stop) 16 | (:import-from #:sento.test-utils 17 | #:parametrized-test) 18 | (:import-from #:ac 19 | #:actor-of)) 20 | 21 | (in-package :sento.message-box-test) 22 | 23 | (def-suite message-box-tests 24 | :description "message-box tests" 25 | :in sento.tests:test-suite) 26 | 27 | (in-suite message-box-tests) 28 | 29 | 30 | (defun wait-while-thread-will-die (msgbox &key (timeout 10)) 31 | (let ((wait-until (+ (get-internal-real-time) (* timeout 32 | internal-time-units-per-second)))) 33 | (with-slots (queue-thread) 34 | msgbox 35 | (loop :while (bt2:thread-alive-p queue-thread) 36 | :do (sleep 0.1) 37 | (when (< wait-until 38 | (get-internal-real-time)) 39 | (error "Thread didn't die in ~A seconds." 40 | timeout)))))) 41 | 42 | 43 | (parametrized-test bt-box-resurrects-thread-after-abort-if-handler-catches-all-signals 44 | ((withreply-p timeout) 45 | (nil nil) 46 | (t 1) 47 | (t nil)) 48 | 49 | "Simulates a situation when error has happened during message processing, and ABORT restart was invoked. 50 | Usually this kill a thread, but here we ensure that the thread is resurrected when we submit a 51 | subsequent message." 52 | 53 | (flet ((kill-by-restart-invoke (msg) 54 | (declare (ignore msg)) 55 | (handler-case 56 | ;; This way we are simulating that the user choose 57 | ;; an ABORT restart in the IDE during debug session: 58 | (handler-bind ((serious-condition #'abort)) 59 | (error "Die, thread, die!")) 60 | ;; This part the same as error handling code in the 61 | ;; SENTO.ACTOR-CELL:HANDLE-MESSAGE function: 62 | ;; 63 | ;; TODO: t was used to check if it is able to 64 | ;; catch stack unwinding because of INVOKE-RESTART, 65 | ;; but it can't. 66 | (t (c) 67 | (log:error "error condition was raised: ~%~a~%" 68 | c) 69 | (cons :handler-error c))))) 70 | 71 | (let ((box (make-instance 'message-box/bt 72 | :name "foo"))) 73 | (unwind-protect 74 | (progn 75 | (let ((first-reply 76 | (submit box "The Message" 77 | t 78 | ;; Don't wait for result here, because we are 79 | ;; intentionally raise error here and will never 80 | ;; return a result: 81 | nil 82 | (list #'kill-by-restart-invoke)))) 83 | (is (equal first-reply 84 | 'no-result))) 85 | 86 | (wait-while-thread-will-die box) 87 | 88 | (is (not 89 | (bt2:thread-alive-p 90 | (slot-value box 'queue-thread)))) 91 | 92 | (let ((result (handler-case 93 | (submit box "The Message" 94 | withreply-p 95 | timeout 96 | (list (lambda (msg) 97 | (reverse msg)))) 98 | (ask-timeout () 99 | :timeout)))) 100 | 101 | (cond 102 | (withreply-p 103 | (is (string= "egasseM ehT" result))) 104 | (t 105 | (is (eql result t))))) 106 | 107 | (is (bt2:thread-alive-p 108 | (slot-value box 'queue-thread)))) 109 | 110 | ;; Cleanup a thread: 111 | (stop box t))))) 112 | -------------------------------------------------------------------------------- /tests/miscutils-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.miscutils-test 2 | (:use :cl :fiveam :sento.miscutils) 3 | (:export #:run! 4 | #:all-tests 5 | #:nil)) 6 | (in-package :sento.miscutils-test) 7 | 8 | (def-suite sento.miscutils-test 9 | :description "Suite for utils" 10 | :in sento.tests:test-suite) 11 | 12 | (in-suite sento.miscutils-test) 13 | 14 | (test print-condition-backtrace 15 | "Check printing condition backtrace" 16 | (is (> (length (collect-backtrace (make-condition 'error))) 0))) 17 | -------------------------------------------------------------------------------- /tests/router-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.router-test 2 | (:use :cl :fiveam :cl-mock :sento.router) 3 | (:export #:run! 4 | #:all-tests 5 | #:nil)) 6 | (in-package :sento.router-test) 7 | 8 | (def-suite router-tests 9 | :description "Tests for router" 10 | :in sento.tests:test-suite) 11 | 12 | (in-suite router-tests) 13 | 14 | (def-fixture system-fixture () 15 | (let ((system (asys:make-actor-system))) 16 | (unwind-protect 17 | (&body) 18 | (ac:shutdown system)))) 19 | 20 | (defun make-actor (context) 21 | (ac:actor-of context 22 | :receive (lambda (msg) msg))) ; just returns msg 23 | 24 | (test router--create 25 | "Creates a plain router" 26 | (with-fixture system-fixture () 27 | (is (not (null (make-router)))) 28 | (is (typep (make-router) 'router)) 29 | (is (functionp (strategy-fun (make-router)))))) 30 | 31 | (test router--add-routee 32 | "Tests adding routees (actors)" 33 | (with-fixture system-fixture () 34 | (let ((cut (make-router))) 35 | (dotimes (i 5) 36 | (add-routee cut (make-actor system))) 37 | (is (= 5 (length (routees cut))))))) 38 | 39 | (test router--provide-routees-at-contructor 40 | "Provide routees when constructing." 41 | (with-fixture system-fixture () 42 | (let ((cut (make-router :routees (list 43 | (make-actor system) 44 | (make-actor system) 45 | (make-actor system))))) 46 | (is (= 3 (length (routees cut))))))) 47 | 48 | (test router--stop 49 | "Stopping router stops routees." 50 | (with-fixture system-fixture () 51 | (with-mocks () 52 | (answer (ac:actor-of _ create-fun) (funcall create-fun)) 53 | (answer (act-cell:stop _) t) 54 | 55 | (let ((cut (make-router))) 56 | (dotimes (i 2) 57 | (add-routee cut (make-actor system))) 58 | (is (= 2 (length (routees cut)))) 59 | (is (equalp '(t t) (stop cut))) 60 | (is (= 2 (length (invocations 'act-cell:stop)))))))) 61 | 62 | (test router--tell 63 | "Tests 'tell' on the router which forwards to an actor chosen by the strategy." 64 | (with-fixture system-fixture () 65 | (let ((cut (make-router :routees (list 66 | (make-actor system) 67 | (make-actor system))))) 68 | (is (equalp (loop :repeat 5 69 | :collect t) 70 | (loop :repeat 5 71 | :collect (tell cut "Foo"))))))) 72 | 73 | (test router--ask-s 74 | "Tests 'ask-s' on the router which forwards to an actor chosen by the strategy." 75 | (with-fixture system-fixture () 76 | (let ((cut (make-router :routees (list 77 | (make-actor system) 78 | (make-actor system))))) 79 | (is (equalp (loop :repeat 5 80 | :collect "Foo") 81 | (loop :repeat 5 82 | :collect (ask-s cut "Foo"))))))) 83 | 84 | (test router--ask 85 | "Tests 'ask' on the router which forwards to an actor chosen by the strategy." 86 | (with-fixture system-fixture () 87 | (let* ((receive-fun (lambda (msg) 88 | (declare (ignore msg)))) 89 | (cut (make-router :routees (list 90 | (ac:actor-of system :receive receive-fun) 91 | (ac:actor-of system :receive receive-fun))))) 92 | (is (every (lambda (x) (typep x 'future:future)) 93 | (loop :repeat 5 94 | :collect (ask cut "Foo"))))))) 95 | 96 | (test router--round-robin-strategy 97 | "Tests the router round-robin strategy" 98 | (with-fixture system-fixture () 99 | (let ((rr-strategy (router::make-round-robin-strategy))) 100 | (is (= 1 (funcall rr-strategy 3))) 101 | (is (= 2 (funcall rr-strategy 3))) 102 | (is (= 0 (funcall rr-strategy 3))) 103 | (is (= 1 (funcall rr-strategy 3))) 104 | (is (= 2 (funcall rr-strategy 3))) 105 | (is (= 0 (funcall rr-strategy 3)))))) 106 | 107 | (test router--tell--with-round-robin-strategy 108 | "Tests 'tell' with round-robin strategy" 109 | (with-fixture system-fixture () 110 | (let ((cut (make-router :strategy :round-robin 111 | :routees (list 112 | (make-actor system) 113 | (make-actor system))))) 114 | (is (equalp (loop :repeat 5 115 | :collect t) 116 | (loop :repeat 5 117 | :collect (tell cut "Foo"))))))) 118 | -------------------------------------------------------------------------------- /tests/spawn-in-receive-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.spawn-in-receive-test 2 | (:use :cl :fiveam) 3 | (:import-from #:miscutils 4 | #:assert-cond) 5 | (:import-from #:act 6 | #:*sender* 7 | #:reply) 8 | (:export #:run! 9 | #:all-tests 10 | #:nil)) 11 | (in-package :sento.spawn-in-receive-test) 12 | 13 | (def-suite spawn-in-receive-tests 14 | :description "Tests doing the work in 'receive' in a separate thread" 15 | :in sento.tests:test-suite) 16 | 17 | (in-suite spawn-in-receive-tests) 18 | 19 | (defun receive-fun () 20 | (lambda (msg) 21 | (let ((sender *sender*)) ;; capture the sender 22 | (case msg 23 | (:do-spawn 24 | (progn 25 | ;; Delegating the work could also be done via a third-party thread-pool 26 | ;; or a library like lparallel 27 | (bt2:make-thread (lambda () 28 | (sleep 1.0) 29 | (reply :spawn-result sender))))))))) 30 | 31 | (test spawn-in-receive 32 | "Spawn a thread in `receive' which does the work. 33 | This requires sending the response via `*sender*'" 34 | (let ((system (asys:make-actor-system))) 35 | (unwind-protect 36 | (let* ((actor (ac:actor-of system :receive (receive-fun))) 37 | (spawn-fut (act:ask actor :do-spawn))) 38 | (setf *sender* :foo) ;; set something weird to *sender* to see if the capturing worked 39 | (is-true (assert-cond (lambda () (future:complete-p spawn-fut)) 1.5)) 40 | (is (eq :spawn-result (future:fresult spawn-fut)))) 41 | (ac:shutdown system)))) 42 | -------------------------------------------------------------------------------- /tests/stash-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.stash-test 2 | (:use :cl :fiveam :sento.stash) 3 | (:export #:run! 4 | #:all-tests 5 | #:nil)) 6 | (in-package :sento.stash-test) 7 | 8 | (def-suite stash-tests 9 | :description "Tests for stash mixin" 10 | :in sento.tests:test-suite) 11 | 12 | (in-suite stash-tests) 13 | 14 | (def-fixture test-context () 15 | (let ((system (asys:make-actor-system '(:dispatchers (:shared (:workers 1)))))) 16 | (unwind-protect 17 | (&body) 18 | (ac:shutdown system :wait t)))) 19 | 20 | (defclass stash-actor (act:actor stashing) ()) 21 | 22 | (test create-actor-with-stash 23 | (with-fixture test-context () 24 | (is (not (null (ac:actor-of system 25 | :type 'stash-actor 26 | :receive (lambda (msg) 27 | (declare (ignore msg))))))))) 28 | 29 | (test stash-actor-can-stash-messages 30 | (with-fixture test-context () 31 | (let ((cut (ac:actor-of system 32 | :type 'stash-actor 33 | :receive (lambda (msg) 34 | (stash:stash msg))))) 35 | (act:tell cut :to-be-stashed-msg) 36 | (is-true (miscutils:await-cond 0.5 37 | (has-stashed-messages-p cut)))))) 38 | 39 | (test stash-actor-can-unstash-messages-with-preserving-sender 40 | (with-fixture test-context () 41 | (let* ((do-stash-message t) 42 | (received-msg nil) 43 | (sender (ac:actor-of system 44 | :receive 45 | (lambda (msg) 46 | (setf received-msg msg)))) 47 | (cut (ac:actor-of system 48 | :type 'stash-actor 49 | :receive 50 | (lambda (msg) 51 | (if do-stash-message 52 | (stash:stash msg) 53 | (case msg 54 | (:unstash 55 | (progn 56 | (stash:unstash-all) 57 | :unstashed)) 58 | (:to-be-stashed-msg 59 | (progn 60 | (act:tell act:*sender* :stashed-msg-reply))))))))) 61 | (act:tell cut :to-be-stashed-msg sender) 62 | (miscutils:await-cond 0.5 (has-stashed-messages-p cut)) 63 | (setf do-stash-message nil) 64 | (is (eq :unstashed (act:ask-s cut :unstash))) 65 | (is-true (miscutils:await-cond 0.5 66 | (eq received-msg :stashed-msg-reply)))))) 67 | 68 | (test unstash-order-is-as-stash-order 69 | "Checks that `unstash-all' unstashes in the same order as messages were stashed." 70 | (with-fixture test-context () 71 | (let* ((do-stash-message t) 72 | (unstashed-recv '()) 73 | (cut (ac:actor-of system 74 | :type 'stash-actor 75 | :receive 76 | (lambda (msg) 77 | (if do-stash-message 78 | (stash:stash msg) 79 | (case msg 80 | (:unstash 81 | (progn 82 | (stash:unstash-all) 83 | :unstashed)) 84 | (otherwise 85 | (setf unstashed-recv (cons msg unstashed-recv)))))))) 86 | (msgs '(msg-1 msg-2 msg-3 msg-4 msg-5))) 87 | (loop :for msg in msgs 88 | :do (act:tell cut msg)) 89 | (miscutils:await-cond 0.5 (= (length (stash::stashed-messages cut)) 5)) 90 | (setf do-stash-message nil) 91 | (act:ask-s cut :unstash) 92 | (is-true (miscutils:await-cond 0.5 (= (length unstashed-recv) 5))) 93 | (is (equalp msgs (reverse unstashed-recv)))))) 94 | -------------------------------------------------------------------------------- /tests/tasks-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.tasks-test 2 | (:use :cl :fiveam :sento.tasks) 3 | (:import-from #:timeutils 4 | #:ask-timeout) 5 | (:import-from #:miscutils 6 | #:await-cond 7 | #:filter) 8 | (:export #:run! 9 | #:all-tests 10 | #:nil)) 11 | (in-package :sento.tasks-test) 12 | 13 | (def-fixture system-fixture () 14 | ;; creates an additional dispatcher called FOO 15 | (let ((system (asys:make-actor-system '(:dispatchers (:foo (:workers 1)))))) 16 | (unwind-protect 17 | (let ((initial-system-actors (ac:all-actors system))) 18 | (&body) 19 | (await-cond 0.5 20 | (= (length (ac:all-actors system)) 21 | (length initial-system-actors)))) 22 | (ac:shutdown system)))) 23 | 24 | (def-suite tasks-tests 25 | :description "Task tests" 26 | :in sento.tests:test-suite) 27 | 28 | (in-suite tasks-tests) 29 | 30 | (test task-yield 31 | "Tests for task-yield" 32 | (with-fixture system-fixture () 33 | (with-context (system) 34 | (is (eq :foo (task-yield (lambda () :foo)))) 35 | (is (= 10 (task-yield (lambda () (+ 5 5))))) 36 | (is (equal '(2 4 6 8) 37 | (mapcar (lambda (x) 38 | (task-yield (lambda () (* 2 x)))) 39 | '(1 2 3 4)))) 40 | (multiple-value-bind (result condition) 41 | (task-yield (lambda () (sleep .5)) 0.2) 42 | (format t "Cond: ~a~%" condition) 43 | (is (eq :handler-error result)) 44 | (is-true (typep condition 'ask-timeout)))))) 45 | 46 | (test task-start 47 | "Test for task-start" 48 | (with-fixture system-fixture () 49 | (with-context (system) 50 | (let ((my-var 0)) 51 | (multiple-value-bind (result task) 52 | (task-start (lambda () (setf my-var 10))) 53 | (is (eq :ok result)) 54 | (is-true (typep task 'tasks:task)) 55 | (is-true (await-cond 1 (= 10 my-var))) 56 | (is (eq :stopped (act:ask-s task :foo)))))))) 57 | 58 | (test task-async 59 | "Test for task-async." 60 | (with-fixture system-fixture () 61 | (with-context (system) 62 | (let ((task (task-async (lambda () (+ 1 2))))) 63 | (is-true (typep task 'tasks:task)) 64 | (task-shutdown task))))) 65 | 66 | (test task-async--completion-handler-and-await 67 | "Test for task-async passed result via completion halder." 68 | (with-fixture system-fixture () 69 | (with-context (system) 70 | (let* ((completion-result) 71 | (completion-handler (lambda (result) (setf completion-result result))) 72 | (task (task-async (lambda () (+ 1 2)) 73 | :on-complete-fun completion-handler))) 74 | (is-true (await-cond 0.5 75 | (and (not (null completion-result)) 76 | (= completion-result 3)))) 77 | (is (= 3 (task-await task))))))) 78 | 79 | (test task-async--completion-handler--err-cond 80 | "Test for task-async passed result via completion handler, error on handler." 81 | (with-fixture system-fixture () 82 | (with-context (system) 83 | (let* ((completion-result) 84 | (completion-handler (lambda (result) (setf completion-result result)))) 85 | (task-async (lambda () (error "Foo")) 86 | :on-complete-fun completion-handler) 87 | (is-true (await-cond 0.5 88 | (and (not (null completion-result)) 89 | (eq :handler-error (car completion-result))))))))) 90 | 91 | (test task-async--in-custom-dispatcher 92 | "Test for task-async in custom dispatcher." 93 | (with-fixture system-fixture () 94 | (with-context (system :foo) 95 | (let ((task (task-async (lambda () (+ 1 2))))) 96 | (is-true (typep task 'tasks:task)) 97 | (is (eq :foo (slot-value (mesgb::dispatcher (act-cell:msgbox task)) 'disp::identifier))) 98 | (task-shutdown task))))) 99 | 100 | (test task-async--with-await 101 | "Test for task-async followed by task-await." 102 | (with-fixture system-fixture () 103 | (with-context (system) 104 | (let ((task (task-async (lambda () (+ 1 2))))) 105 | (is (= 3 (task-await task))))))) 106 | 107 | (test task-async--with-await-err-cond 108 | "Test for task-async followed by task-await with error condition." 109 | (with-fixture system-fixture () 110 | (with-context (system) 111 | (let ((task (task-async (lambda () (error "Foo"))))) 112 | (is (eq :handler-error (car (task-await task)))))))) 113 | 114 | (test task-async--with-await--longer-wait 115 | "Test for task-async followed by task-await." 116 | (with-fixture system-fixture () 117 | (with-context (system) 118 | (let ((task (task-async (lambda () (sleep 1) (+ 1 2))))) 119 | (is (= 3 (task-await task))))))) 120 | 121 | (test task-async--with-await--timeout 122 | "Test for task-async followed by task-await, timeout raised." 123 | (with-fixture system-fixture () 124 | (with-context (system) 125 | (let* ((task (task-async (lambda () (sleep 1) (+ 1 2)))) 126 | (await-result (task-await task 0.5))) 127 | (is (eq :handler-error (car await-result))) 128 | (is (typep (cdr await-result) 'ask-timeout)))))) 129 | 130 | (test task-async-stream 131 | "Tests for task-async-stream" 132 | (with-fixture system-fixture () 133 | (with-context (system) 134 | (is (equal '(2 4 6 8 10) 135 | (task-async-stream (lambda (x) (* x 2)) 136 | '(1 2 3 4 5)))) 137 | (is (= 30 (reduce #'+ 138 | (task-async-stream (lambda (x) (* x 2)) 139 | '(1 2 3 4 5)))))))) 140 | 141 | (test task-async-stream--with-err-results 142 | "Tests for task-async-stream where computations contains errors." 143 | (with-fixture system-fixture () 144 | (with-context (system) 145 | (is (= 24 (reduce #'+ 146 | (filter (lambda (x) (not (consp x))) 147 | (task-async-stream (lambda (x) (* x 2)) 148 | '(1 2 "f" 4 5))))))))) 149 | -------------------------------------------------------------------------------- /tests/test-utils.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:sento.test-utils 2 | (:use #:cl) 3 | (:import-from #:serapeum 4 | #:eval-always) 5 | (:import-from #:alexandria 6 | #:parse-body) 7 | (:export #:parametrized-test)) 8 | (in-package #:sento.test-utils) 9 | 10 | 11 | 12 | (eval-always 13 | (defun generate-test-form (base-test-name parameter-names parameters docstring body-form) 14 | (let* ((test-name-str (format nil 15 | "~A-[~{~A=~S~^ ~}]" 16 | base-test-name 17 | (loop :for name :in parameter-names 18 | :for value :in parameters 19 | :appending (list name value)))) 20 | (test-name (intern test-name-str)) 21 | (bindings (loop :for name :in parameter-names 22 | :for value :in parameters 23 | :collect (list name value)))) 24 | `(5am:test ,test-name 25 | ,docstring 26 | (let ,bindings 27 | ,@body-form))))) 28 | 29 | 30 | (defmacro parametrized-test (name ((&rest parameter-names) &rest parameter-tuples) &body body) 31 | "Generates a separate tests for each parameter combination. 32 | 33 | - NAME is the prefix for all tests in the group. The rest of each test name consists of parameters and values. 34 | - PARAMETER-NAMES should be a list of symbolic names of variables to be bound during BODY execution. 35 | - PARAMETER-TUPLES should be a list of lists of values to be bound to variables given in PARAMETER-NAMES. 36 | 37 | Example: 38 | 39 | (parametrized-test bt-box-test 40 | ((withreply-p timeout) 41 | (nil nil) 42 | (t 1) 43 | (t nil)) 44 | 45 | (do-something with-reply-p timeout)) 46 | 47 | This form will be expanded to the code which will remove all 5AM tests starting with BT-BOX-TEST- 48 | and then will create 3 tests like this one: 49 | 50 | 51 | (test |BT-BOX-TEST-[WITHREPLY-P=T TIMEOUT=1]| 52 | (let ((withreply-p t) (timeout 1)) 53 | (do-something with-reply-p timeout))) 54 | 55 | As you can see, this test binds WITHREPLY-P and TIMEOUT variables to a values given in the second row of PARAMETER-TUPLES. 56 | 57 | Name of each test will include parameter variables for this test. This way it will be easy to tell which parameter combination 58 | fails. 59 | " 60 | (multiple-value-bind (forms decls docstring) 61 | (parse-body body :documentation t :whole name) 62 | (let* ((docstring (or docstring "")) 63 | (body-forms (append decls forms))) 64 | 65 | (let ((tests (loop :for parameters :in parameter-tuples 66 | :collect (generate-test-form name parameter-names parameters docstring body-forms)))) 67 | `(progn 68 | ;; If somebody has changed parameters, we need to remove obsolte tests from the 5AM test registry. 69 | (loop :with prefix-to-search := ,(format nil "~A-" name) 70 | :for candidate-name in (5am:test-names) 71 | :for candidate-name-str := (symbol-name candidate-name) 72 | :when (and (serapeum:length<= prefix-to-search candidate-name-str) 73 | (string= (subseq candidate-name-str 0 (length prefix-to-search)) 74 | prefix-to-search)) 75 | :do (5am:rem-test candidate-name)) 76 | ,@tests))))) 77 | 78 | -------------------------------------------------------------------------------- /tests/timeutils-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.timeutils-test 2 | (:use :cl :fiveam :sento.timeutils) 3 | (:import-from #:miscutils 4 | #:await-cond) 5 | (:export #:run! 6 | #:all-tests 7 | #:nil)) 8 | (in-package :sento.timeutils-test) 9 | 10 | (def-suite sento.timeutils-test 11 | :description "Suite for utils" 12 | :in sento.tests:test-suite) 13 | 14 | (in-suite sento.timeutils-test) 15 | 16 | (test timer--create 17 | "Test create timer" 18 | (is (typep (make-timer 0.1 (lambda ())) 'bt2:thread))) 19 | 20 | (test timer--run 21 | "Tests the timer run." 22 | (let ((run-ok nil)) 23 | (make-timer 0.1 (lambda () (setf run-ok t))) 24 | (is-true (await-cond 1 run-ok)))) 25 | -------------------------------------------------------------------------------- /tests/unbounded-queue-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.unbounded-queue-test 2 | (:use :cl :fiveam :sento.queue) 3 | (:export #:run! 4 | #:all-tests 5 | #:nil)) 6 | (in-package :sento.unbounded-queue-test) 7 | 8 | (def-suite unbounded-queue-tests 9 | :description "Tests unbounded queue" 10 | :in sento.tests:test-suite) 11 | 12 | (in-suite unbounded-queue-tests) 13 | 14 | (test unbounded-queue--push-pop 15 | (let ((cut (make-instance 'queue-unbounded))) 16 | (pushq cut 1) 17 | (is-false (emptyq-p cut)) 18 | (is (= (queued-count cut) 1)) 19 | (is (= 1 (popq cut))) 20 | (is (= (queued-count cut) 0)) 21 | (is-true (emptyq-p cut)) 22 | (pushq cut 1) 23 | (is (= (queued-count cut) 1)) 24 | )) 25 | -------------------------------------------------------------------------------- /tests/wheel-timer-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sento.wheel-timer-test 2 | (:use :cl :fiveam :sento.wheel-timer) 3 | (:export #:run! 4 | #:all-tests 5 | #:nil)) 6 | (in-package :sento.wheel-timer-test) 7 | 8 | (def-suite wheel-timer-tests 9 | :description "Tests for wheel timer" 10 | :in sento.tests:test-suite) 11 | 12 | (in-suite wheel-timer-tests) 13 | 14 | (test make-wheel-timer 15 | "Tests making a wheel timer with config" 16 | (let ((cut (make-wheel-timer :resolution 100 :max-size 100))) 17 | (unwind-protect 18 | (progn 19 | (is (not (null cut)))) 20 | (shutdown-wheel-timer cut)))) 21 | 22 | (test schedule-once--generated-sig 23 | "Tests executing a scheduled timer function, it returns the signature of the timer." 24 | (let ((cut (make-wheel-timer :resolution 100 :max-size 100)) 25 | (callback)) 26 | (unwind-protect 27 | (progn 28 | (is (symbolp (schedule-once cut 0.2 (lambda () (setf callback t))))) 29 | (is-true (miscutils:assert-cond (lambda () (eq t callback)) 0.25)) 30 | ;; any timer sig is to be removed after execution 31 | (is (= 0 (hash-table-count (wt::timer-hash cut))))) 32 | (shutdown-wheel-timer cut)))) 33 | 34 | (test schedule-recurring 35 | "Tests executing recurring timer functions." 36 | (let ((cut (make-wheel-timer)) 37 | (callbacks 0)) 38 | (unwind-protect 39 | (progn 40 | (schedule-recurring cut 0.1 0.1 (lambda () (incf callbacks)) 'foo) 41 | (is-true (miscutils:assert-cond (lambda () (>= callbacks 4)) 0.5 0.1)) 42 | (is (= 1 (hash-table-count (wt::timer-hash cut))))) 43 | (shutdown-wheel-timer cut)))) 44 | 45 | (test schedule-recurring--generated-sig 46 | "Tests executing recurring timer functions with generated sig." 47 | (let ((cut (make-wheel-timer))) 48 | (unwind-protect 49 | (let ((sig (schedule-recurring cut 0.1 0.1 (lambda ())))) 50 | (is (symbolp sig)) 51 | (is (str:starts-with-p "recurring-timer-" (symbol-name sig)))) 52 | (shutdown-wheel-timer cut)))) 53 | 54 | (test cancel-recurring-timer 55 | "Tests canceling a recurring timer function." 56 | (let ((cut (make-wheel-timer))) 57 | (unwind-protect 58 | (progn 59 | (schedule-recurring cut 0.1 0.1 (lambda ()) 'foo) 60 | (is-true (gethash 'foo (wt::timer-hash cut))) 61 | (cancel cut 'foo) 62 | (is-false (gethash 'foo (wt::timer-hash cut)))) 63 | (shutdown-wheel-timer cut)))) 64 | --------------------------------------------------------------------------------