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

core: service: use lparall: start task, send: push-queue

Browse source
This commit is contained in:
Helmut Merz 2025-02-15 15:48:58 +01:00
parent c61d3bcfd3
commit c90d953f2b
1 changed files with 17 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
core/core.lisp
View file

@ -7,7 +7,8 @@
(:shape :scopes/shape) (:shape :scopes/shape)
(:util :scopes/util) (:util :scopes/util)
(:alx :alexandria) (:alx :alexandria)
(:q :lparallel.queue)) (:lp :lparallel)
(:lpq :lparallel.queue))
(:export #:action-spec #:define-actions (:export #:action-spec #:define-actions
#:*root* #:default-setup #:actions #:*root* #:default-setup #:actions
#:find-service #:run-services #:setup-services #:shutdown #:find-service #:run-services #:setup-services #:shutdown
@ -58,10 +59,10 @@
(defvar *root* nil) (defvar *root* nil)
;;; check / fix: ;;; check / fix:
(defvar *quit-queue* (q:make-queue :fixed-capacity 1)) (defvar *quit-queue* (lpq:make-queue :fixed-capacity 1))
(defun quit-handler (sig) (defun quit-handler (sig)
(format t "~%quit-handler: got signal ~s~%" sig) (format t "~%quit-handler: got signal ~s~%" sig)
(q:push-queue sig *quit-queue*)) (lpq:push-queue sig *quit-queue*))
(defclass base-context () (defclass base-context ()
((actions :accessor actions :initform nil))) ((actions :accessor actions :initform nil)))
@ -72,11 +73,13 @@
(services :reader services :initform (make-hash-table)))) (services :reader services :initform (make-hash-table))))
(defclass service (context) (defclass service (context)
((mailbox :reader mailbox :initform (lparallel.queue:make-queue)))) ((mailbox :reader mailbox :initform (lpq:make-queue))))
(defgeneric do-start (ctx) (defgeneric do-start (ctx)
(:method ((ctx context))) (:method ((ctx context)))
(:method ((ctx service)) (do-listen ctx))) (:method ((ctx service))
(let ((ch (lp:make-channel)))
(lp:submit-task ch (do-listen ctx)))))
(defgeneric do-listen (ctx) (defgeneric do-listen (ctx)
(:method ((ctx service)) (:method ((ctx service))
@ -85,9 +88,15 @@
(defgeneric do-step (ctx) (defgeneric do-step (ctx)
(:method ((ctx service)) (:method ((ctx service))
(let ((msg (q:pop-queue (mailbox ctx)))) (let ((msg (lpq:pop-queue (mailbox ctx))))
(handle-message ctx msg)))) (handle-message ctx msg))))
(defgeneric send (rcvr msg)
(:method ((rcvr base-context) msg)
(handle-message rcvr msg))
(:method ((rcvr service) msg)
(lpq:push-queue msg (mailbox rcvr))))
(defun default-setup (cfg &optional (cls 'context) &rest args &key &allow-other-keys) (defun default-setup (cfg &optional (cls 'context) &rest args &key &allow-other-keys)
(apply #'make-instance cls :config cfg :name (config:name cfg) args)) (apply #'make-instance cls :config cfg :name (config:name cfg) args))
@ -111,7 +120,7 @@
(progn (progn
(setup-services cfg) (setup-services cfg)
(do-listen *root*)) (do-listen *root*))
;(q:pop-queue *quit-queue*)) ;(lpq:pop-queue *quit-queue*))
(shutdown))) (shutdown)))
(defun add-action (ctx pat hdlr) (defun add-action (ctx pat hdlr)
@ -132,9 +141,6 @@
(do-start child) (do-start child)
)))) ))))
(defgeneric send (rcvr msg)
(:method ((rcvr base-context) msg)
(handle-message rcvr msg)))
(defgeneric handle-message (ctx msg) (defgeneric handle-message (ctx msg)
(:method ((ctx base-context) msg) (:method ((ctx base-context) msg)