95 lines
3.1 KiB
Racket
95 lines
3.1 KiB
Racket
#lang racket/base
|
|
|
|
(require (for-syntax syntax/parse))
|
|
(require (for-syntax racket/base))
|
|
|
|
(require racket/match)
|
|
(require "main.rkt")
|
|
(require "functional-queue.rkt")
|
|
|
|
(provide userland-thread
|
|
receive
|
|
do
|
|
next-event
|
|
all-queued-events
|
|
pushback-events!
|
|
wait-for-gestalt)
|
|
|
|
(struct do-command (actions k) #:transparent)
|
|
(struct receive-command (single? k) #:transparent)
|
|
(struct pushback-command (events k) #:transparent)
|
|
|
|
(define-syntax userland-thread
|
|
(lambda (stx)
|
|
(syntax-parse stx
|
|
[(_ (~or (~optional (~seq #:gestalt g) #:defaults ([g #'(gestalt-empty)]) #:name "#:gestalt")) ...
|
|
body ...)
|
|
#`(spawn-userland* (lambda () body ...) g)])))
|
|
|
|
(define (spawn-userland* main [initial-gestalt (gestalt-empty)])
|
|
(spawn (lambda (e k) (k e))
|
|
(lambda (first-event)
|
|
(interpret-command (make-queue)
|
|
(list->queue (list first-event))
|
|
((reply-to (lambda (dummy)
|
|
(main)
|
|
(do (quit))))
|
|
(void))))
|
|
initial-gestalt))
|
|
|
|
(define-syntax-rule (receive [pat clausebody ...] ...)
|
|
(receive* (lambda (e sentinel) (match e [pat clausebody ...] ... [_ sentinel]))))
|
|
|
|
(define sentinel (cons 'sentinel '()))
|
|
(define (receive* f)
|
|
(let loop ((events (all-queued-events)) (discarded-rev '()))
|
|
(match events
|
|
[(cons e rest)
|
|
(call-with-values (lambda () (f e sentinel))
|
|
(lambda vs
|
|
(if (equal? vs (list sentinel))
|
|
(loop rest (cons e discarded-rev))
|
|
(begin (pushback-events! (reverse discarded-rev))
|
|
(apply values vs)))))]
|
|
['()
|
|
(loop (all-queued-events) discarded-rev)])))
|
|
|
|
(define (wait-for-gestalt probe)
|
|
(receive [(routing-update g)
|
|
(if (gestalt-empty? (gestalt-filter g probe))
|
|
(wait-for-gestalt probe)
|
|
g)]))
|
|
|
|
(define (do . actions) (call-in-raw-context (lambda (k) (do-command actions k))))
|
|
(define (next-event) (call-in-raw-context (lambda (k) (receive-command #t k))))
|
|
(define (all-queued-events) (call-in-raw-context (lambda (k) (receive-command #f k))))
|
|
(define (pushback-events! events) (call-in-raw-context (lambda (k) (pushback-command events k))))
|
|
|
|
(define prompt (make-continuation-prompt-tag 'minimart-userland))
|
|
|
|
(define (reply-to k)
|
|
(lambda (reply)
|
|
(call-with-continuation-prompt (lambda () (k reply)) prompt)))
|
|
|
|
(define (call-in-raw-context proc)
|
|
(call-with-composable-continuation
|
|
(lambda (k) (abort-current-continuation prompt (lambda () (proc (reply-to k)))))
|
|
prompt))
|
|
|
|
(define (interpret-command actions events command)
|
|
(match command
|
|
[(do-command new-action-chunk k)
|
|
(interpret-command (enqueue actions new-action-chunk) events (k (void)))]
|
|
[(receive-command single? k)
|
|
(cond
|
|
[(queue-empty? events)
|
|
(transition (lambda (e) (and e (interpret-command (make-queue) (list->queue (list e)) command)))
|
|
(queue->list actions))]
|
|
[single?
|
|
(define-values (e rest) (dequeue events))
|
|
(interpret-command actions rest (k e))]
|
|
[else
|
|
(interpret-command actions (make-queue) (k (queue->list events)))])]
|
|
[(pushback-command events-to-push k)
|
|
(interpret-command actions (queue-append (list->queue events-to-push) events) (k (void)))]))
|