You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
103 lines
3.7 KiB
103 lines
3.7 KiB
#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)))
|
|
|