8sync/actors.scm

   1 ;;; 8sync --- Asynchronous programming for Guile
   2 ;;; Copyright © 2016, 2017 Christopher Allan Webber <cwebber@dustycloud.org>
   3 ;;;
   4 ;;; This file is part of 8sync.
   5 ;;;
   6 ;;; 8sync is free software: you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU Lesser General Public License as
   8 ;;; published by the Free Software Foundation, either version 3 of the
   9 ;;; License, or (at your option) any later version.
  10 ;;;
  11 ;;; 8sync is distributed in the hope that it will be useful,
  12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU Lesser General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU Lesser General Public
  17 ;;; License along with 8sync.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (8sync actors)
  20   #:use-module (oop goops)
  21   #:use-module (srfi srfi-9)
  22   #:use-module (ice-9 control)
  23   #:use-module (ice-9 format)
  24   #:use-module (ice-9 match)
  25   #:use-module (ice-9 atomic)
  26   #:use-module ((ice-9 ports internal)
  27                 #:select (port-read-wait-fd port-write-wait-fd))
  28   #:use-module (ice-9 pretty-print)
  29   #:use-module (ice-9 receive)
  30   #:use-module (ice-9 suspendable-ports)
  31   #:use-module (fibers)
  32   #:use-module (fibers channels)
  33   #:use-module (fibers conditions)
  34   #:use-module (fibers operations)
  35   #:use-module (fibers internal)
  36   #:use-module (8sync inbox)
  37   #:use-module (8sync rmeta-slot)
  38
  39   #:export (;; utilities... ought to go in their own module
  40             big-random-number
  41             big-random-number-string
  42
  43             <actor>
  44             actor-id
  45             actor-message-handler
  46
  47             ;;; Commenting out the <address> type for now;
  48             ;;; it may be back when we have better serializers
  49             ;; <address>
  50             make-address
  51             address-actor-id address-hive-id
  52
  53             address->string
  54             actor-id-actor
  55             actor-id-hive
  56             actor-id-string
  57
  58             actor-init! actor-cleanup!
  59
  60             actor-alive?
  61
  62             build-actions
  63
  64             define-actor
  65
  66             actor-spawn-fiber
  67             with-actor-nonblocking-ports
  68
  69             ;; <hive>
  70             ;; make-hive
  71             ;; ;; There are more methods for the hive, but there's
  72             ;; ;; no reason for the outside world to look at them maybe?
  73             ;; hive-id
  74             bootstrap-actor bootstrap-actor*
  75
  76             create-actor create-actor*
  77             self-destruct
  78
  79             <message>
  80             make-message message?
  81             message-to message-action message-from
  82             message-id message-body message-in-reply-to
  83             message-wants-reply
  84
  85             <- <-wait
  86
  87             spawn-hive run-hive))
  88
  89 ;; For ids
  90 (set! *random-state* (random-state-from-platform))
  91
  92 ;; Same size as a uuid4 I think...
  93 (define random-number-size (expt 2 128))
  94
  95 (define (big-random-number)
  96   (random random-number-size))
  97
  98 ;; Would be great to get this base64 encoded instead.
  99 (define (big-random-number-string)
 100   ;; @@: This is slow.  Using format here is wasteful.
 101   (format #f "~x" (big-random-number)))
 102
 103 ;; @@: This is slow-ish.  A mere ~275k / second on my (old) machine.
 104 ;;   The main cost seems to be in number->string.
 105 (define (simple-message-id-generator)
 106   ;; Prepending this cookie makes message ids unique per hive
 107   (let ((prefix (format #f "~x:" (big-random-number)))
 108         (counter 0))
 109     (lambda ()
 110       (set! counter (1+ counter))
 111       (string-append prefix (number->string counter)))))
 112
 113
 114 \f
 115 ;;; Messages
 116 ;;; ========
 117
 118 (define-record-type <message>
 119   (make-message-intern id to from action
 120                        body in-reply-to wants-reply)
 121   message?
 122   ;; @@: message-ids are removed.  They could be re-enabled
 123   ;;   if we had thread-safe promises...
 124   (id message-id)                    ; id of this message
 125   (to message-to)                    ; actor id this is going to
 126   (from message-from)                ; actor id of sender
 127   (action message-action)            ; action (a symbol) to be handled
 128   (body message-body)                ; argument list "body" of message
 129   (in-reply-to message-in-reply-to)  ; message id this is in reply to, if any
 130   (wants-reply message-wants-reply)) ; whether caller is waiting for reply
 131
 132
 133 (define* (make-message id to from action body
 134                        #:key in-reply-to wants-reply)
 135   (make-message-intern id to from action body
 136                        in-reply-to wants-reply))
 137
 138 (define (kwarg-list-to-alist args)
 139   (let loop ((remaining args)
 140              (result '()))
 141     (match remaining
 142       (((? keyword? key) val rest ...)
 143        (loop rest
 144              (cons (cons (keyword->symbol key) val)
 145                    result)))
 146       (() result)
 147       (_ (throw 'invalid-kwarg-list
 148                 "Invalid keyword argument list"
 149                 args)))))
 150
 151
 152 ;;; See: https://web.archive.org/web/20081223021934/http://mumble.net/~jar/articles/oo-moon-weinreb.html
 153 ;;;   (also worth seeing: http://mumble.net/~jar/articles/oo.html )
 154
 155 ;; This is the internal, generalized message sending method.
 156 ;; Users shouldn't use it!  Use the <-foo forms instead.
 157
 158 (define-inlinable (%<- wants-reply from-actor to action args message-id in-reply-to)
 159   ;; Okay, we need to deal with message ids.
 160   ;; Could we get rid of them? :\
 161   ;; It seems if we can use eq? and have messages be immutable then
 162   ;; it should be possible to identify follow-up replies.
 163   ;; If we need to track replies across hive boundaries we could
 164   ;; register unique ids across the ambassador barrier.
 165   (match to
 166     (#(_ _ (? channel? channel) dead?)
 167      (let ((message (make-message message-id to
 168                                   (and from-actor (actor-id from-actor))
 169                                   action args
 170                                   #:wants-reply wants-reply
 171                                   #:in-reply-to in-reply-to)))
 172        (perform-operation
 173         (choice-operation
 174          (put-operation channel message)
 175          (wait-operation dead?)))))
 176     ;; TODO: put remote addresses here.
 177     (#(actor-id hive-id #f #f)
 178      ;; Here we'd make a call to our hive...
 179      'TODO)
 180     ;; A message sent to nobody goes nowhere.
 181     ;; TODO: Should we display a warning here, probably?
 182     (#f #f)))
 183
 184 (define (<- to action . args)
 185   (define from-actor (*current-actor*))
 186   (%<- #f from-actor to action args
 187        (or (and from-actor
 188                 ((actor-msg-id-generator from-actor)))
 189            (big-random-number-string))
 190        #f))
 191
 192 ;; TODO: this should abort to the prompt, then check for errors
 193 ;;   when resuming.
 194
 195 (define (<-wait to action . args)
 196   (define prompt (*actor-prompt*))
 197   (when (not prompt)
 198     (error "Tried to <-wait without being in an actor's context..."))
 199
 200   (let ((reply (abort-to-prompt prompt '<-wait to action args)))
 201     (cond ((eq? action '*error*)
 202            (throw 'hive-unresumable-coroutine
 203                   "Won't resume coroutine; got an *error* as a reply"
 204                   #:message reply))
 205           (else (apply values (message-body reply))))))
 206
 207 \f
 208 ;;; Main actor implementation
 209 ;;; =========================
 210
 211 (define (actor-inheritable-message-handler actor message)
 212   (define action (message-action message))
 213   (define method
 214     (class-rmeta-ref (class-of actor) 'actions action
 215                      #:equals? eq? #:cache-set! hashq-set!
 216                      #:cache-ref hashq-ref))
 217   (unless method
 218     (throw 'action-not-found
 219            "No appropriate action handler found for actor"
 220            #:action action
 221            #:actor actor
 222            #:message message))
 223   (apply method actor message (message-body message)))
 224
 225 (define-syntax-rule (wrap-apply body)
 226   "Wrap possibly multi-value function in a procedure, applies all arguments"
 227   (lambda args
 228     (apply body args)))
 229
 230 (define-syntax-rule (build-actions (symbol method) ...)
 231   "Construct an alist of (symbol . method), where the method is wrapped
 232 with wrap-apply to facilitate live hacking and allow the method definition
 233 to come after class definition."
 234   (build-rmeta-slot
 235    (list (cons (quote symbol)
 236                (wrap-apply method)) ...)))
 237
 238 (define-class <actor> ()
 239   ;; An address object... a vector of #(actor-id hive-id inbox-channel dead?)
 240   ;;  - inbox-channel is the receiving channel (as opposed to actor-inbox-deq)
 241   ;;  - dead? is a fibers condition variable which is set once this actor
 242   ;;    kicks the bucket
 243   (id #:init-keyword #:address
 244       #:getter actor-id)
 245   ;; The connection to the hive we're connected to.
 246   (hive-channel #:init-keyword #:hive-channel
 247                 #:accessor actor-hive-channel)
 248
 249   ;; Our queue to send/receive messages on
 250   (inbox-deq #:init-thunk make-channel
 251              #:accessor actor-inbox-deq)
 252
 253   (msg-id-generator #:init-thunk simple-message-id-generator
 254                     #:getter actor-msg-id-generator)
 255
 256   ;; How we receive and process new messages
 257   (message-handler #:init-value actor-inheritable-message-handler
 258                    ;; @@: There's no reason not to use #:class instead of
 259                    ;;   #:each-subclass anywhere in this file, except for
 260                    ;;   Guile bug #25211 (#:class is broken in Guile 2.2)
 261                    #:allocation #:each-subclass
 262                    #:getter actor-message-handler)
 263
 264   ;; valid values are:
 265   ;;  - #t as in, send the init message, but don't wait (default)
 266   ;;  - 'wait, as in wait on the init message
 267   ;;  - #f as in don't bother to init
 268   (should-init #:init-value #t
 269                #:getter actor-should-init
 270                #:allocation #:each-subclass)
 271
 272   ;; This is the default, "simple" way to inherit and process messages.
 273   (actions #:init-thunk (build-actions)
 274            #:allocation #:each-subclass))
 275
 276 ;;; Actors may specify an "init" action that occurs before the actor
 277 ;;; actually begins to run.
 278 ;;; During actor-init!, an actor may send a message to itself or others
 279 ;;; via <- but *may not* use <-wait.
 280 (define-method (actor-init! (actor <actor>))
 281   'no-op)
 282
 283 (define-method (actor-cleanup! (actor <actor>))
 284   'no-op)
 285
 286 ;;; Addresses are vectors where the first part is the actor-id and
 287 ;;; the second part is the hive-id.  This works well enough... they
 288 ;;; look decent being pretty-printed.
 289
 290 (define (make-address actor-id hive-id channel dead?)
 291   (vector actor-id hive-id channel dead?))
 292
 293 (define (address-actor-id address)
 294   (vector-ref address 0))
 295
 296 (define (address-hive-id address)
 297   (vector-ref address 1))
 298
 299 (define (address-channel address)
 300   (vector-ref address 2))
 301
 302 (define (address-dead? address)
 303   (vector-ref address 3))
 304
 305 (define (address->string address)
 306   (string-append (address-actor-id address) "@"
 307                  (address-hive-id address)))
 308
 309 (define (address-equal? address1 address2)
 310   "Check whether or not the two addresses are equal.
 311
 312 This compares the actor-id and hive-id but ignores the channel and
 313 dead? condition."
 314   (match address1
 315     (#(actor-id-1 hive-id-1 _ _)
 316      (match address2
 317        (#(actor-id-2 hive-id-2)
 318         (and (equal? actor-id-1 actor-id-2)
 319              (and (equal? hive-id-1 hive-id-2))))
 320        (_ #f)))
 321     (_ #f)))
 322
 323 (define (actor-id-actor actor)
 324   "Get the actor id component of the actor-id"
 325   (address-actor-id (actor-id actor)))
 326
 327 (define (actor-id-hive actor)
 328   "Get the hive id component of the actor-id"
 329   (address-hive-id (actor-id actor)))
 330
 331 (define (actor-id-string actor)
 332   "Render the full actor id as a human-readable string"
 333   (address->string (actor-id actor)))
 334
 335 (define (actor-inbox-enq actor)
 336   (address-channel (actor-id actor)))
 337
 338 (define *current-actor*
 339   (make-parameter #f))
 340
 341 (define *actor-prompt*
 342   (make-parameter #f))
 343
 344 (define *resume-io-channel*
 345   (make-parameter #f))
 346
 347 (define (actor-main-loop actor)
 348   "Main loop of the actor.  Loops around, pulling messages off its queue
 349 and handling them."
 350   ;; @@: Maybe establish some sort of garbage collection routine for these...
 351   (define waiting
 352     (make-hash-table))
 353   (define message-handler
 354     (actor-message-handler actor))
 355   (define dead?
 356     (address-dead? (actor-id actor)))
 357   (define prompt (make-prompt-tag (actor-id-actor actor)))
 358   ;; Not always used, only if with-actor-nonblocking-ports is used
 359   (define resume-io-channel
 360     (make-channel))
 361
 362   (define (handle-message message)
 363     (catch #t
 364       (lambda ()
 365         (call-with-values
 366             (lambda ()
 367               (message-handler actor message))
 368           (lambda vals
 369             ;; Return reply if necessary
 370             (when (message-wants-reply message)
 371               (when (message-wants-reply message)
 372                 (%<- #f actor (message-from message) '*reply*
 373                      vals ((actor-msg-id-generator actor))
 374                      (message-id message)))))))
 375       (const #t)
 376       (let ((err (current-error-port)))
 377         (lambda (key . args)
 378           (false-if-exception
 379            (let ((stack (make-stack #t 4)))
 380              (format err "Uncaught exception when handling message ~a:\n"
 381                      message)
 382              (display-backtrace stack err)
 383              (print-exception err (stack-ref stack 0)
 384                               key args)
 385              (newline err)
 386              ;; If the other actor is waiting on a reply, let's let them
 387              ;; know there was an error...
 388              (when (message-wants-reply message)
 389                (%<- #f actor (message-from message) '*error*
 390                     (list key) ((actor-msg-id-generator actor))
 391                     (message-id message)))))))))
 392
 393   (define (resume-handler message)
 394     (define in-reply-to (message-in-reply-to message))
 395     (cond
 396      ((hash-ref waiting in-reply-to) =>
 397       (lambda (kont)
 398         (hash-remove! waiting in-reply-to)
 399         (kont message)))
 400      (else
 401       (format (current-error-port)
 402               "Tried to resume nonexistant message: ~a\n"
 403               (message-id message)))))
 404
 405   (define halt-or-handle-message
 406     ;; It would be nice if we could give priorities to certain operations.
 407     ;; halt should always win over getting a message...
 408     (choice-operation
 409      (wrap-operation (wait-operation dead?)
 410                      (const #f))  ; halt and return
 411      (wrap-operation (get-operation (actor-inbox-deq actor))
 412                      (lambda (message)
 413                        (call-with-prompt prompt
 414                          (lambda ()
 415                            (if (message-in-reply-to message)
 416                                ;; resume a continuation which was waiting on a reply
 417                                (resume-handler message)
 418                                ;; start handling a new message
 419                                (handle-message message)))
 420                          ;; Here's where we abort to if we're doing <-wait
 421                          ;; @@: maybe use match-lambda if we're going to end up
 422                          ;;   handling multiple ~commands
 423                          (match-lambda*
 424                            ((kont '<-wait to action message-args)
 425                             (define message-id
 426                               ((actor-msg-id-generator actor)))
 427                             (hash-set! waiting message-id kont)
 428                             (%<- #t actor to action message-args message-id #f))
 429                            ((kont 'run-me proc)
 430                             (proc kont))))
 431                        #t))   ; loop again
 432      (wrap-operation (get-operation resume-io-channel)
 433                      (lambda (thunk)
 434                        (thunk
 435                         #t)))))
 436
 437   ;; Mutate the parameter; this should be fine since each fiber
 438   ;; runs in its own dynamic state with with-dynamic-state.
 439   ;; See with-dynamic-state discussion in
 440   ;;   https://wingolog.org/archives/2017/06/27/growing-fibers
 441   (*current-actor* actor)
 442   (*resume-io-channel* resume-io-channel)
 443
 444   ;; We temporarily set the *actor-prompt* to #f to make sure that
 445   ;; actor-init! doesn't try to do a <-wait message (and not accidentally use
 446   ;; the parent fiber's *actor-prompt* either.)
 447   (*actor-prompt* #f)
 448   (actor-init! actor)
 449   (*actor-prompt* prompt)
 450
 451   (let loop ()
 452     (and (perform-operation halt-or-handle-message)
 453          (loop))))
 454
 455
 456 ;; @@: So in order for this to work, we're going to have to add
 457 ;; another channel to actors, which is resumable i/o.  We'll have to
 458 ;; spawn a fiber that wakes up a thunk on the actor when its port is
 459 ;; available.  Funky...
 460
 461 (define (%suspend-io-to-actor resume-method get-wait-fd-method)
 462   (lambda (port)
 463     (define prompt (*actor-prompt*))
 464     (define resume-channel (*resume-io-channel*))
 465     (define (run-at-prompt k)
 466       (spawn-fiber
 467        (lambda ()
 468          (suspend-current-fiber
 469           (lambda (fiber)
 470             (resume-on-readable-fd (port-read-wait-fd port) fiber)))
 471          ;; okay, we're awake again, tell the actor to resume this
 472          ;; continuation
 473          (put-message resume-channel k))
 474        #:parallel? #f))
 475     (when (not prompt)
 476       (error "Attempt to abort to actor prompt outside of actor"))
 477     (abort-to-prompt (*actor-prompt*)
 478                      'run-me run-at-prompt)))
 479
 480 (define suspend-read-to-actor
 481   (%suspend-io-to-actor resume-on-readable-fd port-read-wait-fd))
 482
 483 (define suspend-write-to-actor
 484   (%suspend-io-to-actor resume-on-writable-fd port-write-wait-fd))
 485
 486 (define (with-actor-nonblocking-ports thunk)
 487   "Runs THUNK in dynamic context in which attempting to read/write
 488 from a port that would otherwise block an actor's correspondence with
 489 other actors (note that reading from a nonblocking port should never
 490 block other fibers) will instead permit reading other messages while
 491 I/O is waiting to complete.
 492
 493 Note that currently "
 494   (parameterize ((current-read-waiter suspend-read-to-actor)
 495                  (current-write-waiter suspend-write-to-actor))
 496     (thunk)))
 497
 498 (define (actor-spawn-fiber thunk . args)
 499   "Spawn a fiber from an actor but unset actor-machinery-specific
 500 dynamic context."
 501   (apply spawn-fiber
 502          (lambda ()
 503            (*current-actor* #f)
 504            (*resume-io-channel* #f)
 505            (*actor-prompt* #f)
 506            (thunk))
 507          args))
 508
 509
 510 \f
 511 ;;; Actor utilities
 512 ;;; ===============
 513
 514 (define-syntax-rule (define-actor class inherits
 515                       (action ...)
 516                       slots ...)
 517   (define-class class inherits
 518     (actions #:init-thunk (build-actions action ...)
 519              #:allocation #:each-subclass)
 520     slots ...))
 521
 522 \f
 523 ;;; The Hive
 524 ;;; ========
 525 ;;;   Every actor has a hive, which keeps track of other actors, manages
 526 ;;;   cleanup, and performs inter-hive communication.
 527
 528 (define-class <hive> ()
 529   (id #:init-keyword #:id
 530       #:getter hive-id)
 531   (actor-registry #:init-thunk make-hash-table
 532                   #:getter hive-actor-registry)
 533   ;; TODO: Rename "ambassadors" to "relays"
 534   ;; Ambassadors are used (or will be) for inter-hive communication.
 535   ;; These are special actors that know how to route messages to other
 536   ;; hives.
 537   (ambassadors #:init-thunk make-weak-key-hash-table
 538                #:getter hive-ambassadors)
 539   (channel #:init-thunk make-channel
 540            #:getter hive-channel)
 541   (halt? #:init-thunk make-condition
 542          #:getter hive-halt?))
 543
 544 (define* (make-hive #:key hive-id)
 545   (make <hive> #:id (or hive-id
 546                         (big-random-number-string))))
 547
 548 (define (gen-actor-id cookie)
 549   (if cookie
 550       (string-append cookie ":" (big-random-number-string))
 551       (big-random-number-string)))
 552
 553 (define (hive-main-loop hive)
 554   "The main loop of the hive.  This listens for messages on the hive-channel
 555 for certain actions to perform.
 556
 557 `messages' here is not the same as a <message> object; these are a list of
 558 values, the first value being a symbol"
 559   (define channel (hive-channel hive))
 560   (define halt? (hive-halt? hive))
 561   (define registry (hive-actor-registry hive))
 562
 563   ;; not the same as a <message> ;P
 564   (define handle-message
 565     (match-lambda
 566       (('register-actor actor-id address actor)
 567        (hash-set! registry actor-id (vector address actor)))
 568       ;; Remove the actor from hive
 569       (('remove-actor actor-id)
 570        (hash-remove! (hive-actor-registry hive) actor-id))
 571       (('register-ambassador hive-id ambassador-actor-id)
 572        'TODO)
 573       (('unregister-ambassador hive-id ambassador-actor-id)
 574        'TODO)
 575       (('forward-message from-actor-id message)
 576        'TODO)))
 577
 578   (define halt-or-handle
 579     (choice-operation
 580      (wrap-operation (get-operation channel)
 581                      (lambda (msg)
 582                        (handle-message msg)
 583                        #t))
 584      (wrap-operation (wait-operation halt?)
 585                      (const #f))))
 586
 587   (let lp ()
 588     (and (perform-operation halt-or-handle)
 589          (lp))))
 590
 591 (define *current-hive* (make-parameter #f))
 592
 593 (define* (spawn-hive proc #:key (hive (make-hive)))
 594   "Spawn a hive in a fiber running PROC, passing it the fresh hive"
 595   (spawn-fiber (lambda () (hive-main-loop hive)))
 596   (proc hive))
 597
 598 (define (run-hive proc . args)
 599   "Spawn a hive and run it in run-fibers.  Takes a PROC as would be passed
 600 to spawn-hive... all remaining arguments passed to run-fibers."
 601   (apply run-fibers
 602          (lambda ()
 603            (spawn-hive proc))
 604          args))
 605
 606 (define (%create-actor hive-channel hive-id
 607                        actor-class init-args id-cookie send-init?)
 608   (let* ((actor-id (gen-actor-id id-cookie))
 609          (dead? (make-condition))
 610          (inbox-enq (make-channel))
 611          (address (make-address actor-id hive-id
 612                                 inbox-enq dead?))
 613          (actor (apply make actor-class
 614                        #:hive-channel hive-channel
 615                        #:address address
 616                        init-args))
 617          (should-init (actor-should-init actor)))
 618
 619     ;; start the main loop
 620     (spawn-fiber (lambda ()
 621                    ;; start the inbox loop
 622                    (spawn-fiber
 623                     (lambda ()
 624                       (delivery-agent inbox-enq (actor-inbox-deq actor)
 625                                       dead?))
 626                     ;; this one is decidedly non-parallel, because we want
 627                     ;; the delivery agent to be in the same thread as its actor
 628                     #:parallel? #f)
 629
 630                    (actor-main-loop actor))
 631                  #:parallel? #t)
 632
 633     (put-message hive-channel (list 'register-actor actor-id address actor))
 634
 635     ;; return the address
 636     address))
 637
 638 (define* (bootstrap-actor hive actor-class #:rest init-args)
 639   "Create an actor on HIVE using ACTOR-CLASS passing in INIT-ARGS args"
 640   (%create-actor (hive-channel hive) (hive-id hive) actor-class
 641                  init-args (symbol->string (class-name actor-class))
 642                  #f))
 643
 644 (define* (bootstrap-actor* hive actor-class id-cookie #:rest init-args)
 645   "Create an actor, but also allow customizing a 'cookie' added to the id
 646 for debugging"
 647   (%create-actor (hive-channel hive) (hive-id hive) actor-class
 648                  init-args id-cookie
 649                  #f))
 650
 651 (define* (create-actor from-actor actor-class #:rest init-args)
 652   "Create an instance of actor-class.  Return the new actor's id.
 653
 654 This is the method actors should call directly (unless they want
 655 to supply an id-cookie, in which case they should use
 656 create-actor*)."
 657   (%create-actor (actor-hive-channel from-actor) (actor-id-hive from-actor)
 658                  actor-class init-args #f #t))
 659
 660
 661 (define* (create-actor* from-actor actor-class id-cookie #:rest init-args)
 662   "Create an instance of actor-class.  Return the new actor's id.
 663
 664 Like create-actor, but permits supplying an id-cookie."
 665   (%create-actor (actor-hive-channel from-actor) (actor-id-hive from-actor)
 666                  actor-class init-args id-cookie #t))
 667
 668 (define* (self-destruct actor #:key (cleanup #t))
 669   "Remove an actor from the hive.
 670
 671 Unless #:cleanup is set to #f, this will first have the actor handle
 672 its '*cleanup* action handler."
 673   (signal-condition! (address-dead? (actor-id actor)))
 674   (put-message (actor-hive-channel actor) (list 'remove-actor (actor-id-actor actor)))
 675   ;; Set *actor-prompt* to nothing to prevent actor-cleanup! from sending
 676   ;; a message with <-wait
 677   (*actor-prompt* #f)
 678   (actor-cleanup! actor))
 679
 680 ;; From a patch I sent to Fibers...
 681 (define (condition-signalled? cvar)
 682   "Return @code{#t} if @var{cvar} has already been signalled.
 683
 684 In general you will want to use @code{wait} or @code{wait-operation} to
 685 wait on a condition.  However, sometimes it is useful to see whether or
 686 not a condition has already been signalled without blocking."
 687   (atomic-box-ref ((@@ (fibers conditions) condition-signalled?) cvar)))
 688
 689 (define (actor-alive? actor)
 690   (condition-signalled? (address-dead? (actor-id actor))))