actors: Cleanup on signals.

[8sync.git] / 8sync / actors.scm

diff --git a/8sync/actors.scm b/8sync/actors.scm
index 1f5bd3c1cb38c6a3c834e8a0e5ef1b04ffd2e04a..0c50446d8c1a4ac9b8aaec5328247edd9ef8f4da 100644 (file)
--- a/8sync/actors.scm
+++ b/8sync/actors.scm
@@ -51,7 +51,7 @@
 
             build-actions
 
-            define-simple-actor
+            define-actor
 
             <hive>
             make-hive
@@ -73,7 +73,7 @@
 
             <- <-* <-wait <-wait* <-reply <-reply* <-reply-wait <-reply-wait*
 
-            call-with-message msg-receive msg-val
+            call-with-message mbody-receive mbody-val
 
             run-hive
             bootstrap-message
@@ -395,10 +395,13 @@ to come after class definition."
 ;;; Actor utilities
 ;;; ===============
 
-(define-syntax-rule (define-simple-actor class action ...)
-  (define-class class (<actor>)
+(define-syntax-rule (define-actor class inherits
+                      (action ...)
+                      slots ...)
+  (define-class class inherits
     (actions #:init-value (build-actions action ...)
-             #:allocation #:each-subclass)))
+             #:allocation #:each-subclass)
+    slots ...))
 
 \f
 ;;; The Hive
@@ -715,21 +718,21 @@ for debugging"
 argument.  Similar to call-with-values in concept."
   (apply proc message (message-body message)))
 
-;; (msg-receive (<- bar baz)
+;; (mbody-receive (<- bar baz)
 ;;     (baz)
 ;;   basil)
 
-;; Emacs: (put 'msg-receive 'scheme-indent-function 2)
+;; Emacs: (put 'mbody-receive 'scheme-indent-function 2)
 
 ;; @@: Or receive-msg or receieve-message or??
-(define-syntax-rule (msg-receive arglist message body ...)
+(define-syntax-rule (mbody-receive arglist message body ...)
   "Call body with arglist (which can accept arguments like lambda*)
 applied from the message-body of message."
   (call-with-message message
                      (lambda* arglist
                        body ...)))
 
-(define (msg-val message)
+(define (mbody-val message)
   "Retrieve the first value from the message-body of message.
 Like single value return from a procedure call.  Probably the most
 common case when waiting on a reply from some action invocation."
@@ -776,17 +779,32 @@ its '*cleanup* action handler."
 ;;; =========================
 
 (define* (run-hive hive initial-tasks
-                   #:key (cleanup #t))
-  "Start up an agenda and run HIVE in it with INITIAL-TASKS."
+                   #:key (cleanup #t)
+                   (handle-signals (list SIGINT SIGTERM)))
+  "Start up an agenda and run HIVE in it with INITIAL-TASKS.
+
+Keyword arguments:
+ - #:cleanup: Whether to run *cleanup* on all actors.
+ - #:handle-sigactions: a list of signals to set up interrupt
+   handlers for, so cleanup sill still happen as expected.
+   Defaults to a list of SIGINT and SIGTERM."
   (dynamic-wind
     (const #f)
     (lambda ()
-      (let* ((queue (list->q
-                     (cons (bootstrap-message hive (actor-id hive) '*init-all*)
-                           initial-tasks)))
-             (agenda (make-agenda #:pre-unwind-handler print-error-and-continue
-                                  #:queue queue)))
-        (run-agenda agenda)))
+      (define (run-it escape)
+        (define (handle-signal signum)
+          (restore-signals)
+          (escape signum))
+        (for-each (lambda (signum)
+                    (sigaction signum handle-signal))
+                  handle-signals)
+        (let* ((queue (list->q
+                       (cons (bootstrap-message hive (actor-id hive) '*init-all*)
+                             initial-tasks)))
+               (agenda (make-agenda #:pre-unwind-handler print-error-and-continue
+                                    #:queue queue)))
+          (run-agenda agenda)))
+      (call/ec run-it))
     ;; Run cleanup
     (lambda ()
       (when cleanup