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

fix actor, async: correctly handle interactive interrupt

Browse source
This commit is contained in:
Helmut Merz 2025-06-22 15:44:11 +02:00
parent 87afabd467
commit e7eb71a840
2 changed files with 16 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
core/actor.lisp
View file

@ -35,10 +35,6 @@
;;;; actor loop (listener) ;;;; actor loop (listener)
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (not (boundp '+quit-message+))
(defconstant +quit-message+ (gensym "QUIT"))))
(defun start (tsk bhv &key foreground) (defun start (tsk bhv &key foreground)
(setf (async:behavior tsk) bhv) (setf (async:behavior tsk) bhv)
(if foreground (if foreground
@ -46,28 +42,24 @@
(async:submit-task tsk #'ac-loop tsk bhv))) (async:submit-task tsk #'ac-loop tsk bhv)))
(defun stop (mb) (defun stop (mb)
(send mb +quit-message+)) (send mb async:+quit-message+))
(defvar *self* nil) (defvar *self* nil)
(defgeneric ac-loop (tsk bhv) (defgeneric ac-loop (tsk bhv)
(:method ((tsk async:task) bhv) (:method ((tsk async:task) bhv)
(let ((msg (async:rcv tsk))) (let ((msg (async:rcv tsk)))
(unless (eq (ac-step tsk bhv msg) +quit-message+) (unless (eq (content msg) async:+quit-message+)
(ac-step tsk bhv msg)
(ac-loop tsk (async:behavior tsk)))))) (ac-loop tsk (async:behavior tsk))))))
(defun ac-step (tsk bhv msg) (defun ac-step (tsk bhv msg)
(when (eq (content msg) +quit-message+)
(return-from ac-step +quit-message+))
(let ((*self* tsk)) (let ((*self* tsk))
(handler-case (funcall bhv msg) (handler-case (funcall bhv msg)
(condition (err)
(util:lg :error "behavior" msg err)
+quit-message+)
(error (err) (error (err)
(invoke-debugger err) (util:lg :error "behavior" msg err))
;(util:lg :error "behavior" msg err) ;(invoke-debugger err))
)))) )))
;;;; the core (classical, i.e. Hewitt) actor API ;;;; the core (classical, i.e. Hewitt) actor API

13
util/async.lisp
View file

@ -3,13 +3,16 @@
(defpackage :scopes/util/async (defpackage :scopes/util/async
(:use :common-lisp) (:use :common-lisp)
(:local-nicknames (:lp :lparallel) (:local-nicknames (:lp :lparallel)
(:lpq :lparallel.queue)) (:lpq :lparallel.queue)
(:export #:init #:finish #:make-mb #:make-task #:rcv #:try-rcv #:snd (:util :scopes/util))
(:export #:+quit-message+ #:init #:finish #:make-mb #:make-task #:rcv #:try-rcv #:snd
#:mailbox #:task #:restartable-task #:behavior #:get-status #:set-status #:mailbox #:task #:restartable-task #:behavior #:get-status #:set-status
#:submit-task #:receive-result #:try-receive-result)) #:submit-task #:receive-result #:try-receive-result))
(in-package :scopes/util/async) (in-package :scopes/util/async)
(defconstant +quit-message+ :quit)
;;;; general definitions (lparallel wrappers) ;;;; general definitions (lparallel wrappers)
(defun init () (defun init ()
@ -31,7 +34,11 @@
(make-instance 'mailbox)) (make-instance 'mailbox))
(defun rcv (mb) (defun rcv (mb)
(lpq:pop-queue (queue mb))) (handler-case
(lpq:pop-queue (queue mb))
(condition (cnd)
(util:lg :info "condition on pop-queue" cnd)
+quit-message+)))
(defun try-rcv (mb) (defun try-rcv (mb)
(lpq:try-pop-queue (queue mb))) (lpq:try-pop-queue (queue mb)))