cco/cl-scopes
3
0
Fork 0
Code Issues 1 Pull requests Releases Wiki Activity Actions

first try with virtual (restartable) actor loop

Browse source
This commit is contained in:
Helmut Merz 2025-06-12 15:42:51 +02:00
parent 20fb3acec5
commit 0d73c7d39e
3 changed files with 28 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
core/actor.lisp
View file

@ -39,10 +39,10 @@
(when (not (boundp '+quit-message+)) (when (not (boundp '+quit-message+))
(defconstant +quit-message+ (gensym "QUIT")))) (defconstant +quit-message+ (gensym "QUIT"))))
(defun start (mb bhv &key foreground) (defun start (mb bhv &key foreground (listener #'ac-loop))
(if foreground (if foreground
(ac-loop mb bhv) (ac-loop mb bhv)
(async:submit-task mb (lambda () (ac-loop mb bhv))))) (async:submit-task mb listener mb bhv)))
(defun stop (mb) (defun stop (mb)
(send mb +quit-message+)) (send mb +quit-message+))
@ -52,17 +52,30 @@
(unless (eq (content msg) +quit-message+) (unless (eq (content msg) +quit-message+)
(ac-loop mb (or (funcall bhv msg) bhv))))) (ac-loop mb (or (funcall bhv msg) bhv)))))
(defun ac-vloop (mb bhv)
(multiple-value-bind (msg ok) (async:try-rcv mb)
(if ok
(if (eq (content msg) +quit-message+)
nil
(ac-vloop mb (or (funcall bhv msg) bhv)))
bhv)))
;;;; the core (classical, i.e. Hewitt) actor API ;;;; the core (classical, i.e. Hewitt) actor API
;;; there is no `become` operation: the behavior just returns the new behavior ;;; there is no `become` operation: the behavior just returns the new behavior
(defun create (bhv) (defun create (bhv)
(let ((mb (async:make-mb))) (let ((mb (async:make-mb)))
(start mb bhv) (start mb bhv)
(start mb bhv :listener #'ac-vloop)
mb)) mb))
(defun send (mb msg) (defun send (mb msg)
;(util:lgi msg) ;(util:lgi msg)
(async:snd mb msg)) (async:snd mb msg)
(multiple-value-bind (bhv done) (async:try-receive-result mb)
(util:lgi done)
(if (and done bhv)
(async:submit-task mb (lambda () (ac-vloop mb bhv))))))
;;;; predefined behaviors ;;;; predefined behaviors

15
test/test-core.lisp
View file

@ -59,11 +59,11 @@
(unwind-protect (unwind-protect
(progn (progn
(test-util) (test-util)
(test-util-async)
(test-util-crypt) (test-util-crypt)
(test-util-iter) (test-util-iter)
(test-shape) (test-shape)
(core:setup-services) (core:setup-services)
(test-util-async)
(test-actor) (test-actor)
(setf (receiver t:*test-suite*) (core:find-service :test-receiver)) (setf (receiver t:*test-suite*) (core:find-service :test-receiver))
(test-send)) (test-send))
@ -87,11 +87,6 @@
(== (util:plist-add pl :b 1) '(:b 1 :a 0)) (== (util:plist-add pl :b 1) '(:b 1 :a 0))
(== pl '(:b 1 :a 0)))) (== pl '(:b 1 :a 0))))
(deftest test-util-async ()
(let ((mb (async:make-mb)))
(async:submit-task mb (lambda () (sleep 0.1) :done))
))
(deftest test-util-crypt () (deftest test-util-crypt ()
(let ((s1 (crypt:create-secret)) (let ((s1 (crypt:create-secret))
(s2 (crypt:create-secret))) (s2 (crypt:create-secret)))
@ -114,6 +109,14 @@
(setf (shape:head-value rec :username) :u1) (setf (shape:head-value rec :username) :u1)
(== (shape:head-value rec :username) :u1))) (== (shape:head-value rec :username) :u1)))
(deftest test-util-async ()
(let ((mb (async:make-mb)))
(async:submit-task mb (lambda () (sleep 0.1) :done))
(== (async:try-receive-result mb) nil)
(== (async:receive-result mb) :done)
(== (async:try-receive-result mb) nil)
))
(deftest test-actor () (deftest test-actor ()
(let* ((calc (actor:create (actor:calculator))) (let* ((calc (actor:create (actor:calculator)))
val val

6
util/async.lisp
View file

@ -33,13 +33,13 @@
(lpq:pop-queue (queue mb))) (lpq:pop-queue (queue mb)))
(defun try-rcv (mb) (defun try-rcv (mb)
(lpq:peek-queue (queue mb))) (lpq:try-pop-queue (queue mb)))
(defun snd (mb msg) (defun snd (mb msg)
(lpq:push-queue msg (queue mb))) (lpq:push-queue msg (queue mb)))
(defun submit-task (mb job) (defun submit-task (mb job &rest args)
(lp:submit-task (channel mb) job)) (apply #'lp:submit-task (channel mb) job args))
(defun receive-result (mb) (defun receive-result (mb)
(lp:receive-result (channel mb))) (lp:receive-result (channel mb)))