92 lines
3.2 KiB
Racket
92 lines
3.2 KiB
Racket
#lang racket/base
|
|
|
|
(provide spawn-threaded-actor
|
|
spawn/thread ;; \__ once dataspace is split into mux and relay, these three
|
|
spawn*/thread ;; | will be very thin convenience macros over a common impl.
|
|
dataspace/thread) ;; /
|
|
|
|
(require racket/match)
|
|
(require (for-syntax racket/base))
|
|
|
|
(require (except-in syndicate dataspace))
|
|
(require (only-in syndicate/actor spawn spawn* dataspace schedule-action!))
|
|
(require (only-in (submod syndicate/actor implementation-details) capture-actor-actions))
|
|
(require syndicate/hierarchy)
|
|
(require syndicate/store)
|
|
|
|
(struct proxy-state (thd) #:prefab)
|
|
(struct thread-quit (exn actions) #:prefab)
|
|
(struct thread-transition (actions) #:prefab)
|
|
|
|
(define (proxy-behaviour e s)
|
|
(match-define (proxy-state thd) s)
|
|
(match e
|
|
[(message (thread-transition acs)) (transition s acs)]
|
|
[(message (thread-quit exn acs)) (<quit> exn acs)]
|
|
[_
|
|
(when e
|
|
(signal-background-activity! #t)
|
|
(thread-send thd e #f))
|
|
#f]))
|
|
|
|
(define (spawn-threaded-actor spawn-action-thunk)
|
|
(match-define (list (<actor> boot-proc initial-assertions))
|
|
(clean-actions (capture-actor-actions spawn-action-thunk)))
|
|
(make-actor (lambda ()
|
|
(define path (current-actor-path))
|
|
(define thd (thread (lambda () (run-thread path boot-proc))))
|
|
(thread (lambda ()
|
|
(sync (thread-dead-evt thd))
|
|
(send-ground-message (thread-quit #f '()) #:path path)
|
|
(signal-background-activity! #f)))
|
|
(signal-background-activity! #t)
|
|
(list proxy-behaviour
|
|
(transition (proxy-state thd) '())
|
|
'threaded-proxy))
|
|
initial-assertions))
|
|
|
|
(define (run-thread actor-path boot-proc)
|
|
(define actor-path-rev (reverse actor-path))
|
|
|
|
(define (process-transition proc t)
|
|
(match t
|
|
[(<quit> exn acs)
|
|
(send-ground-message (thread-quit exn acs) #:path actor-path)]
|
|
[(transition new-state acs)
|
|
(when (not (or (null? acs) (eq? acs #f) (void? acs)))
|
|
(send-ground-message (thread-transition acs) #:path actor-path))
|
|
(deliver-event #f (update-process-state proc new-state))]
|
|
[_
|
|
(await-event proc)]))
|
|
|
|
(define (deliver-event e proc)
|
|
(process-transition proc
|
|
(with-store ((current-actor-path-rev actor-path-rev))
|
|
(with-handlers [((lambda (exn) #t) (lambda (exn) (<quit> exn '())))]
|
|
((process-behavior proc) e (process-state proc))))))
|
|
|
|
(define (await-event proc)
|
|
(signal-background-activity! #f)
|
|
(deliver-event (thread-receive) proc))
|
|
|
|
(call-with-values (lambda () (boot->process+transition boot-proc))
|
|
process-transition))
|
|
|
|
(define-syntax spawn/thread
|
|
(syntax-rules ()
|
|
[(_ body ...)
|
|
(schedule-action!
|
|
(spawn-threaded-actor (lambda () (spawn body ...))))]))
|
|
|
|
(define-syntax spawn*/thread
|
|
(syntax-rules ()
|
|
[(_ body ...)
|
|
(schedule-action!
|
|
(spawn-threaded-actor (lambda () (spawn* body ...))))]))
|
|
|
|
(define-syntax dataspace/thread
|
|
(syntax-rules ()
|
|
[(_ body ...)
|
|
(schedule-action!
|
|
(spawn-threaded-actor (lambda () (dataspace body ...))))]))
|