diff --git a/core/actor-legacy.lisp b/core/actor-legacy.lisp new file mode 100644 index 0000000..634c3f4 --- /dev/null +++ b/core/actor-legacy.lisp @@ -0,0 +1,111 @@ +;;;; cl-scopes/core/actor - basic actor definitions + +(defpackage :scopes/core/actor + (:use :common-lisp) + (:local-nicknames (:async :scopes/util/async) + (:util :scopes/util)) + (:export #:bg-actor #:fg-actor #:make-actor #:start #:stop + #:become #:create #:send + #:message #:content #:customer + #:*logger* #:*root* + #:echo #:inc #:lgi + #:calculator #:plus #:minus #:show #:send-value)) + +(in-package :scopes/core/actor) + +;;;; basic message and actor implementations + +(defclass message () + ((content :reader content :initarg :content :initform nil) + (customer :reader customer :initarg :customer :initform nil))) + +(defun message (content &optional customer) + (make-instance 'message :content content :customer customer)) + +(defclass actor () + ((behavior :accessor behavior :initarg :behavior :initform #'no-op))) + +(defclass bg-actor (actor) + ((task :accessor task :initform nil))) + +(defmethod initialize-instance :after ((ac bg-actor) &key &allow-other-keys) + (setf (task ac) (make-task ac))) + +(defclass fg-actor (bg-actor) ()) + +(defmethod initialize-instance :after ((ac fg-actor) &key &allow-other-keys) + (setf (task ac) (make-task ac 'async:fg-task))) + +(defgeneric start (ac) + (:method ((ac actor))) + (:method ((ac bg-actor)) + (async:start (task ac)))) + +(defgeneric stop (ac) + (:method ((ac actor))) + (:method ((ac bg-actor)) + (async:stop (task ac)))) + +(defun make-actor (bhv &optional (cls 'bg-actor) &rest args &key &allow-other-keys) + (apply #'make-instance cls :behavior bhv args)) + +(defun make-task (ac &optional (cls 'async:task)) + (async:make-task :cls cls + :handle-message + #'(lambda (ax msg) (funcall (behavior ac) ac msg)))) + +;;;; the core (classical, i.e. Hewitt) actor API + +(defun become (ac bhv) + (setf (behavior ac) bhv)) + +(defun create (bhv &optional (cls 'actor) &rest args &key &allow-other-keys) + (let ((ac (apply #'make-actor bhv cls args))) + (start ac) + ac)) + +(defgeneric send (addr content &key &allow-other-keys) + (:method ((addr t) (content t) &key customer &allow-other-keys) + (let ((ac addr) (msg (message content customer))) + (send ac msg))) + (:method ((ac actor) (msg message) &key &allow-other-keys) + (funcall (behavior ac) ac msg)) + (:method ((ac bg-actor) (msg message) &key &allow-other-keys) + (async:send (task ac) msg))) + +;;;; predefined behaviors + +(defun no-op (ac msg)) + +(defun lgi (ac msg) + (util:lgi (content msg))) + +(defun echo (ac msg) + (send (customer msg) msg)) + +;;;; predefined global actors + +(defvar *logger* (create #'lgi)) + +(defclass root (actor) ()) + +(defun root-bhv (ac msg) + (send *logger* msg)) + +(defvar *root* (create #'root-bhv 'root)) + + ;;;; example behavior: calculator + +(defun calculator (&optional (val 0)) + #'(lambda (ac msg) + (destructuring-bind (fn &optional param) (content msg) + (funcall fn ac msg val param)))) + +(defun plus (ac msg val param) + (become ac (calculator (+ val param)))) +(defun minus (ac msg val param) + (become ac (calculator (- val param)))) +(defun show (ac msg val param) + (send (or (customer msg) *logger*) val)) +(defun send-value (ac msg val param) + (send (customer msg) val)) diff --git a/core/actor-ng.lisp b/core/actor-ng.lisp deleted file mode 100644 index 6f84a5c..0000000 --- a/core/actor-ng.lisp +++ /dev/null @@ -1,100 +0,0 @@ -;;;; cl-scopes/core/actor - basic actor definitions - -(defpackage :scopes/core/actor-ng - (:use :common-lisp) - (:local-nicknames (:async :scopes/util/async) - (:lp :lparallel) - (:lpq :lparallel.queue) - (:shape :scopes/shape) - (:util :scopes/util)) - (:export #:start #:stop #:become #:create #:send - #:message #:content #:customer - #:*logger* #:*root* - #:echo #:inc #:lgi - #:calculator #:plus #:minus #:show #:send-value)) - -(in-package :scopes/core/actor-ng) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (async:init)) - -;;;; basic message implementation - -(defclass message () - ((content :reader content :initarg :content :initform nil) - (customer :reader customer :initarg :customer :initform nil))) - -(defmethod x-print-object ((msg message) stream) - (shape:print-slots msg stream 'content 'customer)) - -(defun message (content &optional customer) - (make-instance 'message :content content :customer customer)) - -;;;; actor loop (listener) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (when (not (boundp '+quit-message+)) - (defconstant +quit-message+ (gensym "QUIT")))) - -(defun start (mb bhv &key foreground) - (if foreground - (ac-loop mb bhv) - (let ((ch (lp:make-channel))) - (lp:submit-task ch (lambda () (ac-loop mb bhv))) - ch))) - -(defun stop (mb) - (send mb (message +quit-message+))) - -(defun ac-loop (mb bhv) - (let ((msg (lpq:pop-queue mb))) - (unless (eq (content msg) +quit-message+) - (ac-loop mb (or (funcall bhv msg) bhv))))) - -;;;; the core (classical, i.e. Hewitt) actor API -;;; there is no `become` operation: the behavior just returns the new behavior - -(defun create (bhv) - (let ((mb (lpq:make-queue))) - (values mb (start mb bhv)))) - -(defun send (mb msg) - ;(util:lgi msg) - (lpq:push-queue msg mb)) - -;;;; predefined behaviors - -(defun no-op (msg)) - -(defun lgi (msg) - (util:lgi (content msg))) - -(defun echo (msg) - (send (customer msg) msg)) - -;;;; predefined global actors - -(defvar *logger* (create #'lgi)) - -(defun root-bhv (ac msg) - (send *logger* msg)) - -(defvar *root* (create #'root-bhv)) - -;;;; example behavior: calculator - -(defun calculator (&optional (val 0)) - (lambda (msg) - ;(format t "calc ~a ~a~%" val (content msg)) - (destructuring-bind (fn &optional param) (content msg) - (funcall fn msg val param)))) - -(defun plus (msg val param) - (calculator (+ val param))) -(defun minus (msg val param) - (calculator (- val param))) -(defun show (msg val param) - (send (or (customer msg) *logger*) (message val))) -(defun send-value (msg val param) - (send (customer msg) (message val))) - diff --git a/core/actor.lisp b/core/actor.lisp index 634c3f4..83d17c8 100644 --- a/core/actor.lisp +++ b/core/actor.lisp @@ -2,10 +2,12 @@ (defpackage :scopes/core/actor (:use :common-lisp) - (:local-nicknames (:async :scopes/util/async) + (:local-nicknames (:async :scopes/util/async) + (:lp :lparallel) + (:lpq :lparallel.queue) + (:shape :scopes/shape) (:util :scopes/util)) - (:export #:bg-actor #:fg-actor #:make-actor #:start #:stop - #:become #:create #:send + (:export #:start #:stop #:become #:create #:send #:message #:content #:customer #:*logger* #:*root* #:echo #:inc #:lgi @@ -13,99 +15,86 @@ (in-package :scopes/core/actor) -;;;; basic message and actor implementations +(eval-when (:compile-toplevel :load-toplevel :execute) + (async:init)) + +;;;; basic message implementation (defclass message () ((content :reader content :initarg :content :initform nil) (customer :reader customer :initarg :customer :initform nil))) +(defmethod x-print-object ((msg message) stream) + (shape:print-slots msg stream 'content 'customer)) + (defun message (content &optional customer) (make-instance 'message :content content :customer customer)) -(defclass actor () - ((behavior :accessor behavior :initarg :behavior :initform #'no-op))) +;;;; actor loop (listener) -(defclass bg-actor (actor) - ((task :accessor task :initform nil))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (not (boundp '+quit-message+)) + (defconstant +quit-message+ (gensym "QUIT")))) -(defmethod initialize-instance :after ((ac bg-actor) &key &allow-other-keys) - (setf (task ac) (make-task ac))) +(defun start (mb bhv &key foreground) + (if foreground + (ac-loop mb bhv) + (let ((ch (lp:make-channel))) + (lp:submit-task ch (lambda () (ac-loop mb bhv))) + ch))) -(defclass fg-actor (bg-actor) ()) +(defun stop (mb) + (send mb (message +quit-message+))) -(defmethod initialize-instance :after ((ac fg-actor) &key &allow-other-keys) - (setf (task ac) (make-task ac 'async:fg-task))) - -(defgeneric start (ac) - (:method ((ac actor))) - (:method ((ac bg-actor)) - (async:start (task ac)))) - -(defgeneric stop (ac) - (:method ((ac actor))) - (:method ((ac bg-actor)) - (async:stop (task ac)))) - -(defun make-actor (bhv &optional (cls 'bg-actor) &rest args &key &allow-other-keys) - (apply #'make-instance cls :behavior bhv args)) - -(defun make-task (ac &optional (cls 'async:task)) - (async:make-task :cls cls - :handle-message - #'(lambda (ax msg) (funcall (behavior ac) ac msg)))) +(defun ac-loop (mb bhv) + (let ((msg (lpq:pop-queue mb))) + (unless (eq (content msg) +quit-message+) + (ac-loop mb (or (funcall bhv msg) bhv))))) ;;;; the core (classical, i.e. Hewitt) actor API +;;; there is no `become` operation: the behavior just returns the new behavior -(defun become (ac bhv) - (setf (behavior ac) bhv)) +(defun create (bhv) + (let ((mb (lpq:make-queue))) + (values mb (start mb bhv)))) -(defun create (bhv &optional (cls 'actor) &rest args &key &allow-other-keys) - (let ((ac (apply #'make-actor bhv cls args))) - (start ac) - ac)) - -(defgeneric send (addr content &key &allow-other-keys) - (:method ((addr t) (content t) &key customer &allow-other-keys) - (let ((ac addr) (msg (message content customer))) - (send ac msg))) - (:method ((ac actor) (msg message) &key &allow-other-keys) - (funcall (behavior ac) ac msg)) - (:method ((ac bg-actor) (msg message) &key &allow-other-keys) - (async:send (task ac) msg))) +(defun send (mb msg) + ;(util:lgi msg) + (lpq:push-queue msg mb)) ;;;; predefined behaviors -(defun no-op (ac msg)) +(defun no-op (msg)) -(defun lgi (ac msg) +(defun lgi (msg) (util:lgi (content msg))) -(defun echo (ac msg) +(defun echo (msg) (send (customer msg) msg)) ;;;; predefined global actors (defvar *logger* (create #'lgi)) -(defclass root (actor) ()) - (defun root-bhv (ac msg) (send *logger* msg)) -(defvar *root* (create #'root-bhv 'root)) +(defvar *root* (create #'root-bhv)) - ;;;; example behavior: calculator +;;;; example behavior: calculator (defun calculator (&optional (val 0)) - #'(lambda (ac msg) - (destructuring-bind (fn &optional param) (content msg) - (funcall fn ac msg val param)))) + (lambda (msg) + ;(format t "calc ~a ~a~%" val (content msg)) + (destructuring-bind (fn &optional param) (content msg) + (funcall fn msg val param)))) + +(defun plus (msg val param) + (calculator (+ val param))) +(defun minus (msg val param) + (calculator (- val param))) +(defun show (msg val param) + (send (or (customer msg) *logger*) (message val))) +(defun send-value (msg val param) + (send (customer msg) (message val))) -(defun plus (ac msg val param) - (become ac (calculator (+ val param)))) -(defun minus (ac msg val param) - (become ac (calculator (- val param)))) -(defun show (ac msg val param) - (send (or (customer msg) *logger*) val)) -(defun send-value (ac msg val param) - (send (customer msg) val)) diff --git a/core/core.lisp b/core/core.lisp index 93c124c..3e6717a 100644 --- a/core/core.lisp +++ b/core/core.lisp @@ -2,7 +2,7 @@ (defpackage :scopes/core (:use :common-lisp) - (:local-nicknames (:actor :scopes/core/actor-ng) + (:local-nicknames (:actor :scopes/core/actor) (:async :scopes/util/async) (:config :scopes/config) (:message :scopes/core/message) @@ -94,7 +94,7 @@ (unwind-protect (progn (setup-services cfg) - (actor:start (mailbox *root*))) + (actor:start (mailbox *root*) :foreground t)) (shutdown))) (defun shutdown () diff --git a/core/message.lisp b/core/message.lisp index d019257..e2282f3 100644 --- a/core/message.lisp +++ b/core/message.lisp @@ -2,7 +2,7 @@ (defpackage :scopes/core/message (:use :common-lisp) - (:local-nicknames (:actor :scopes/core/actor-ng) + (:local-nicknames (:actor :scopes/core/actor) (:shape :scopes/shape)) (:export #:message-meta #:message #:create #:head #:data)) diff --git a/scopes-core.asd b/scopes-core.asd index a6ce511..ac7f40e 100644 --- a/scopes-core.asd +++ b/scopes-core.asd @@ -10,14 +10,14 @@ :flexi-streams :ironclad :local-time :log4cl :lparallel :qbase64 :serapeum :str) :components ((:file "config" :depends-on ("util/util")) - (:file "core/actor-ng" + (:file "core/actor" :depends-on ("shape/shape" "util/async" "util/util")) (:file "core/core" :depends-on ("config" - "core/actor-ng" "core/message" + "core/actor" "core/message" "forge/forge" "logging" "util/async" "util/util")) - (:file "core/message" :depends-on ("core/actor-ng" "shape/shape")) + (:file "core/message" :depends-on ("core/actor" "shape/shape")) (:file "forge/forge" :depends-on ("util/iter" "util/util")) (:file "logging" :depends-on ("config" "util/util")) (:file "shape/shape") diff --git a/test/test-core.lisp b/test/test-core.lisp index 838b9b5..80406d7 100644 --- a/test/test-core.lisp +++ b/test/test-core.lisp @@ -3,7 +3,7 @@ (defpackage :scopes/test-core (:use :common-lisp) (:local-nicknames (:alx :alexandria) - (:actor :scopes/core/actor-ng) + (:actor :scopes/core/actor) (:async :scopes/util/async) (:config :scopes/config) (:core :scopes/core) @@ -66,8 +66,7 @@ (core:setup-services) (test-actor) (setf (receiver t:*test-suite*) (core:find-service :test-receiver)) - (test-send) - ) + (test-send)) (core:shutdown) (check-expected) (t:show-result)))) @@ -140,7 +139,7 @@ (actor:send calc (actor:message '(actor:show))) (actor:send calc (actor:message '(actor:show) collector)) (actor:stop calc) - (sleep 0.1) + (sleep 0.2) (== val -1) )) diff --git a/web/response.lisp b/web/response.lisp index eb4c7e3..ddb65d5 100644 --- a/web/response.lisp +++ b/web/response.lisp @@ -39,7 +39,7 @@ (defvar *html-response-class* nil) -(defclass response (core:base-context actor:fg-actor) +(defclass response (core:base-context) ((context :reader context :initarg :context) (core:actions :initform *default-actions*) (env :reader env :initarg :env) diff --git a/web/server.lisp b/web/server.lisp index 70e077c..c105c3b 100644 --- a/web/server.lisp +++ b/web/server.lisp @@ -2,8 +2,7 @@ (defpackage :scopes/web/server (:use :common-lisp) - (:local-nicknames (:actor :scopes/core/actor) - (:config :scopes/config) + (:local-nicknames (:config :scopes/config) (:core :scopes/core) (:message :scopes/core/message) (:response :scopes/web/response)