You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
104 lines
3.7 KiB
Racket
104 lines
3.7 KiB
Racket
#lang racket/base
|
|
;; Breaking the infinite tower of nested dataspaces, connecting to Racket at the fracture line.
|
|
|
|
(provide current-ground-event-async-channel
|
|
ground-send!
|
|
ground-assert!
|
|
ground-retract!
|
|
signal-background-activity!
|
|
extend-ground-boot!
|
|
run-ground)
|
|
|
|
(define-logger syndicate/ground)
|
|
|
|
(require racket/async-channel)
|
|
(require racket/set)
|
|
(require racket/match)
|
|
(require racket/list)
|
|
(require "dataspace.rkt")
|
|
(require "syntax.rkt")
|
|
|
|
(define current-ground-event-async-channel (make-parameter #f))
|
|
(define *ground-boot-extensions* '())
|
|
|
|
(define (ground-enqueue! item)
|
|
(async-channel-put (current-ground-event-async-channel) item))
|
|
|
|
(define (ground-send! body)
|
|
(ground-enqueue! (lambda (ac) (enqueue-send! ac body))))
|
|
|
|
(define (ground-assert! assertion)
|
|
(ground-enqueue! (lambda (ac) (adhoc-assert! ac assertion))))
|
|
|
|
(define (ground-retract! assertion)
|
|
(ground-enqueue! (lambda (ac) (adhoc-retract! ac assertion))))
|
|
|
|
(define (signal-background-activity! delta)
|
|
(ground-enqueue! delta))
|
|
|
|
(define (extend-ground-boot! proc)
|
|
(set! *ground-boot-extensions* (cons proc *ground-boot-extensions*)))
|
|
|
|
(define (run-ground* boot-proc)
|
|
(define ch (make-async-channel))
|
|
(parameterize ((current-ground-event-async-channel ch))
|
|
(define ground-event-relay-actor #f)
|
|
(define background-activity-count 0)
|
|
|
|
(define (handle-ground-event-item item)
|
|
(match item
|
|
[(? procedure? proc)
|
|
(push-script! ground-event-relay-actor
|
|
(lambda () (proc ground-event-relay-actor)))]
|
|
[(? number? delta)
|
|
(set! background-activity-count (+ background-activity-count delta))]))
|
|
|
|
(define (drain-external-events)
|
|
(define item (async-channel-try-get ch))
|
|
(when item
|
|
(handle-ground-event-item item)
|
|
(drain-external-events)))
|
|
|
|
(define ground-event-relay-evt
|
|
(handle-evt ch (lambda (item)
|
|
(handle-ground-event-item item)
|
|
(drain-external-events))))
|
|
|
|
(define ds (make-dataspace
|
|
(lambda ()
|
|
(schedule-script! (current-actor)
|
|
(lambda ()
|
|
(spawn #:name 'ground-event-relay
|
|
(set! ground-event-relay-actor (current-actor))
|
|
;; v Adds a dummy endpoint to keep this actor alive
|
|
(begin/dataflow (void)))))
|
|
(schedule-script! (current-actor)
|
|
(lambda ()
|
|
(boot-proc)
|
|
(let ((extensions (reverse *ground-boot-extensions*)))
|
|
(set! *ground-boot-extensions* '())
|
|
(for [(p (in-list extensions))] (p))))))))
|
|
|
|
(let loop ()
|
|
(define work-remaining? (run-scripts! ds))
|
|
(define events-expected? (positive? background-activity-count))
|
|
(log-syndicate/ground-debug "GROUND: ~a; ~a background activities"
|
|
(if work-remaining? "busy" "idle")
|
|
background-activity-count)
|
|
(cond
|
|
[events-expected?
|
|
(sync ground-event-relay-evt (if work-remaining? (system-idle-evt) never-evt))
|
|
(loop)]
|
|
[work-remaining?
|
|
(sync ground-event-relay-evt (system-idle-evt))
|
|
(loop)]
|
|
[else
|
|
(sync (handle-evt ground-event-relay-evt (lambda _ (loop))) (system-idle-evt))]))))
|
|
|
|
(define (run-ground boot-proc)
|
|
(if (equal? (getenv "SYNDICATE_PROFILE") "ground")
|
|
(let ()
|
|
(local-require profile)
|
|
(profile (run-ground* boot-proc)))
|
|
(run-ground* boot-proc)))
|