syndicate-rkt/syndicate/ground.rkt

107 lines
3.9 KiB
Racket

;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)))