diff --git a/core/core.lisp b/core/core.lisp index 83ad09a..3bc8c1c 100644 --- a/core/core.lisp +++ b/core/core.lisp @@ -76,21 +76,17 @@ (defclass service (context) ((task :accessor task :initform nil))) -(defgeneric do-start (ctx &key wait) - (:method ((ctx context) &key wait)) - (:method ((ctx service) &key wait) +(defclass root-service (service) ()) + +(defgeneric do-start (ctx) + (:method ((ctx context))) + (:method ((ctx service)) (setf (task ctx) (async:make-task :handle-message #'handle-message)) - (async:start (task ctx :wait wait)))) - -(defgeneric do-listen (ctx) - (:method ((ctx service)) - (do ((r (do-step ctx) (do-step ctx))) - ((eql r '(:quit)))))) - -(defgeneric do-step (ctx) - (:method ((ctx service)) - (let ((msg (lpq:pop-queue (mailbox ctx)))) - (handle-message ctx msg)))) + (async:start (task ctx))) + (:method ((ctx root-service)) + (setf (task ctx) + (async:make-task :cls 'async:async-task :handle-message #'handle-message)) + (async:start (task ctx :blocking t)))) (defgeneric send (rcvr msg) (:method ((rcvr base-context) msg) @@ -107,7 +103,7 @@ (gethash name services)))) (defun setup-services (&optional (cfg config:*root*)) - (setf *root* (make-instance 'service :config cfg)) + (setf *root* (make-instance 'root-service :config cfg)) ;(setf (trivial-signal:signal-handler :int) #'quit-handler) (dolist (c (reverse (config:children cfg))) (add-service *root* c))) @@ -122,8 +118,7 @@ (unwind-protect (progn (setup-services cfg) - ;(do-listen *root*) - (do-start *root* :wait t)) + (do-start *root*)) (shutdown))) (defun add-action (ctx pat hdlr) diff --git a/util/async.lisp b/util/async.lisp index 8219476..2382694 100644 --- a/util/async.lisp +++ b/util/async.lisp @@ -5,7 +5,8 @@ (:local-nicknames (:util :scopes/util) (:lp :lparallel) (:lpq :lparallel.queue)) - (:export #:task #:make-task #:start #:stop #:status #:data #:send)) + (:export #:task #:async-task + #:make-task #:start #:stop #:status #:data #:send)) (in-package :scopes/util/async) @@ -38,13 +39,16 @@ (defclass task () ((job :accessor job) (taskid :reader taskid :initform (gensym "TSK")) - (channel :reader channel :initform (lp:make-channel)) (mailbox :accessor mailbox :initform nil) (status :accessor status :initform :new) (data :accessor data :initform nil))) -(defun make-task (&key (startup #'noop) (teardown #'noop) handle-message) - (let ((tsk (make-instance 'task))) +(defclass async-task (task) + ((channel :reader channel :initform (lp:make-channel)))) + +(defun make-task (&key (startup #'noop) (teardown #'noop) handle-message + (cls 'async-task)) + (let ((tsk (make-instance cls))) (setf (job tsk) (lambda () (standard-job tsk :startup startup :teardown teardown :handle-message handle-message))) @@ -52,19 +56,28 @@ (setf (mailbox tsk) (lpq:make-queue))) tsk)) -(defun start (tsk &key (wait nil)) +(defun start (tsk) (when (eq (status tsk) :running) (util:lgw "task already running" (taskid tsk)) (return-from start)) (setf (status tsk) :running) - (if wait - (funcall (job tsk)) + (submit tsk)) + +(defgeneric submit (tsk) + (:method ((tsk task)) + (funcall (job tsk))) + (:method ((tsk async-task)) (lp:submit-task (channel tsk) (job tsk)))) (defun stop (tsk &key (wait t)) (when (mailbox tsk) (send tsk +quit-message+)) (when wait + (wait-result tsk))) + +(defgeneric wait-result (tsk) + (:method ((tsk task))) + (:method ((tsk async-task)) (lp:receive-result (channel tsk)))) (defun send (tsk msg)