From 68de150492b7fae5e54abb114e6ae7fa64633b75 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 19 Mar 2012 14:28:34 -0400 Subject: [PATCH] WIP --- os2.rkt | 298 +++++++++++++++++++++++++++++++++++++++++++++++++++ relation.rkt | 131 ++++++++++++++++++++++ 2 files changed, 429 insertions(+) create mode 100644 os2.rkt create mode 100644 relation.rkt diff --git a/os2.rkt b/os2.rkt new file mode 100644 index 0000000..c410b40 --- /dev/null +++ b/os2.rkt @@ -0,0 +1,298 @@ +#lang racket/base +;; Virtualized operating system, this time with presence. + +(require racket/match) + +;;--------------------------------------------------------------------------- +;; Data definitions + +;; A PID is an (arbitrary) VM-unique process identifier. +;; A SID is an (arbitrary) process-unique subscription identifier. + +;; A QuasiQueue is a list of Xs in *reversed* order. + +(struct vm (processes ;; PID -> Process + topics ;; Topic -> Set + flows ;; Flow -> Set + next-process-id ;; PID + pending-actions ;; QuasiQueue<(cons PID Action)> + ) #:transparent) + +;; (route PID SID Handlers) +(struct route (process-id sid handlers) #:transparent) + +(struct process (id ;; PID + state + interests ;; SID -> List + meta-interests ;; SID -> List + ) #:transparent) + +(struct topic (role pattern virtual?) #:prefab) + +;; A Flow is a Topic that comes from the intersection of two dual +;; topics. + +;; PresenceHandler = Topic -> State -> Transition +;; AbsenceHandler = Topic * Reason -> State -> Transition +;; MessageHandler = Topic * Message -> State -> Transition +(struct handlers (topic presence absence message) #:transparent) + +;; actions is a plain old List, not a QuasiQueue. +(struct transition (state actions) #:transparent) + +;; Preactions +(struct add-role (sid handlers) #:prefab) +(struct delete-roles (sid) #:prefab) +(struct send-message (topic body) #:prefab) +(struct spawn (thunk) #:prefab) + +;; An Action is either a Preaction or an (at-meta-level Preaction). +(struct at-meta-level (preaction) #:prefab) + +;;--------------------------------------------------------------------------- +;; Topics and roles + +(define (topic-publisher pattern #:virtual? [virtual? #f]) + (topic 'publisher pattern virtual?)) + +(define (topic-subscriber pattern #:virtual? [virtual? #f]) + (topic 'subscriber pattern virtual?)) + +(define (co-roles r) + (case r + [(publisher) '(subscriber)] + [(subscriber) '(publisher)] + [else #f])) + +(define (co-topics t) + (for/list ([role (co-roles (topic-role t))]) + (struct-copy topic t [topic-role role]))) + +;;--------------------------------------------------------------------------- + +;; QuasiQueue +(define empty-quasi-queue '()) + +;; X QuasiQueue -> QuasiQueue +(define (quasi-enqueue-one thing existing-quasi-queue) + (cons thing existing-quasi-queue)) + +;; List QuasiQueue -> QuasiQueue +(define (quasi-enqueue-many many-things-in-order existing-quasi-queue) + (append (reverse many-things-in-order) existing-quasi-queue)) + +;; QuasiQueue -> List +(define (quasi-queue->list quasi-queue) + (reverse quasi-queue)) + +;; List -> QuasiQueue +(define (list->quasi-queue xs) + (reverse xs)) + +;;--------------------------------------------------------------------------- + +(define (make-vm boot) + (vm (hash) + (hash) + (hash) + 0 + (list->quasi-queue (list (spawn boot))))) + +(define (run-vm state) + (let loop ((remaining-actions (quasi-queue->list (vm-pending-actions state))) + (state (struct-copy vm state [pending-actions empty-quasi-queue])) + (outbound-actions empty-quasi-queue)) + (match remaining-actions + ['() (transition state (quasi-queue->list outbound-actions))] + [(cons (cons pid action) rest) + (if (at-meta-level? action) + (let-values (((state new-actions) + (perform-meta-action pid (at-meta-level-preaction action) state))) + (loop rest state (quasi-enqueue-many new-actions outbound-actions))) + (loop rest (perform-action pid action state) outbound-actions))]))) + +(define (run-user-code v) + ;; TODO: use this hook to find all the bits of code that will need + ;; with-handlers and crash compensation. + v) + +(define (perform-action pid action state) + (match action + [(add-role sid handlers) ...] + [(delete-roles sid) ...] + [(send-message topic body) ...] + [(spawn thunk) + (match-define (transition initial-state initial-actions) (run-user-code (thunk))) + (define new-pid (vm-next-process-id state)) + (struct-copy vm (enqueue-actions state new-pid initial-actions) + [processes (hash-set (vm-processes state) new-pid (process new-pid + initial-state + (hash) + (hash)))] + [next-process-id (+ new-pid 1)])])) + +(define (enqueue-actions state pid actions) + (struct-copy vm state + [pending-actions (quasi-enqueue-many (for/list ([a actions]) (cons pid a)) + (vm-pending-actions state))])) + + +-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- + + (let* ((state (requeue-pollers state)) + (state (run-runnables state)) + (state (dispatch-messages state)) + (meta-messages (reverse (vm-pending-meta-messages state))) + (meta-handlers (append-map extract-downward-meta-message-handlers (vm-suspensions state))) + (poller-k (and (should-poll? state) run-vm)) ;; only block if there's nothing left to do + (state (struct-copy vm state [pending-meta-messages (list)]))) + (kernel-mode-transition (suspension state poller-k meta-handlers '()) + meta-messages + '() + '()))) + +(define (requeue-pollers state) + (foldl (lambda (susp state) + (if (suspension-polling? susp) + (enqueue-runnable (lambda () ((suspension-k susp) (suspension-state susp))) state) + (enqueue-suspension susp state))) + (struct-copy vm state [suspensions '()]) + (vm-suspensions state))) + +(define (run-runnables state) + (foldl (lambda (r state) (perform-transition (r) state)) + (struct-copy vm state [pending-processes (list)]) + (reverse (vm-pending-processes state)))) + +(define (dispatch-messages state) + (foldl dispatch-message + (struct-copy vm state [pending-messages (list)]) + (reverse (vm-pending-messages state)))) + +(define (extract-downward-meta-message-handlers susp) + (for/list ([mmh (suspension-meta-message-handlers susp)]) + (message-handler (message-handler-pattern mmh) dispatch-meta-message))) + +(define ((dispatch-meta-message message) state) + (run-vm + (foldl (match-suspension message + (vm-meta-pattern-predicate state) + suspension-meta-message-handlers) + (struct-copy vm state [suspensions '()]) + (vm-suspensions state)))) + +(define (perform-transition transition state) + (match transition + [(kernel-mode-transition new-suspension + messages + meta-messages + new-processes) + (let* ((state (foldl enqueue-message state messages)) + (state (foldl enqueue-runnable state new-processes)) + (state (enqueue-suspension new-suspension state)) + (state (foldl enqueue-meta-message state meta-messages))) + state)] + [other + (error 'vm "Processes must return a kernel-mode-transition struct; got ~v" other)])) + +(define (enqueue-message message state) + (struct-copy vm state [pending-messages (cons message (vm-pending-messages state))])) + +(define (enqueue-runnable r state) + (struct-copy vm state [pending-processes (cons r (vm-pending-processes state))])) + +(define (enqueue-suspension susp state) + (match susp + [(suspension _ #f '() '()) + ;; dead process because no continuations offered + state] + [(suspension _ _ _ _) + (struct-copy vm state [suspensions (cons susp (vm-suspensions state))])])) + +(define (enqueue-meta-message message state) + (struct-copy vm state [pending-meta-messages (cons message (vm-pending-meta-messages state))])) + +(define (dispatch-message message state) + (foldl (match-suspension message + (vm-pattern-predicate state) + suspension-message-handlers) + (struct-copy vm state [suspensions '()]) + (vm-suspensions state))) + +(define ((match-suspension message apply-pattern handlers-getter) susp state) + (let search-handlers ((message-handlers (handlers-getter susp))) + (cond + [(null? message-handlers) + ;; No handler matched this message. Put the suspension + ;; back on the list for some future message. + (enqueue-suspension susp state)] + [(apply-pattern (message-handler-pattern (car message-handlers)) message) + (define trapk (message-handler-k (car message-handlers))) + (define interruptk (trapk message)) + (perform-transition (interruptk (suspension-state susp)) state)] + [else + (search-handlers (cdr message-handlers))]))) + +(define (suspension-polling? susp) + (not (eq? (suspension-k susp) #f))) + +(define (should-poll? state) + (or (not (null? (vm-pending-processes state))) + (not (null? (vm-pending-messages state))) + (ormap suspension-polling? (vm-suspensions state)))) + +(define (nested-vm boot + #:pattern-predicate [pattern-predicate default-pattern-predicate] + #:meta-pattern-predicate [meta-pattern-predicate default-pattern-predicate]) + (lambda () (run-vm (make-vm boot + #:pattern-predicate pattern-predicate + #:meta-pattern-predicate meta-pattern-predicate)))) + +(define default-pattern-predicate + (lambda (p m) (p m))) + +;;--------------------------------------------------------------------------- + +(define (nested-vm-inert? susp) + (match susp + [(suspension (vm _ '() '() '() _ _) #f '() '()) + ;; Inert iff not waiting for any messages or metamessages, and + ;; with no internal work left to do. + #t] + [_ #f])) + +(struct ground-event-pattern (tag evt) #:transparent) +(struct ground-event-value (tag val) #:transparent) + +(define (match-ground-event p m) + (equal? (ground-event-pattern-tag p) (ground-event-value-tag m))) + +(define (ground-vm boot + #:pattern-predicate [pattern-predicate default-pattern-predicate]) + (let loop ((transition (run-vm (make-vm boot + #:pattern-predicate pattern-predicate + #:meta-pattern-predicate match-ground-event)))) + (for-each (lambda (thunk) (thunk)) (kernel-mode-transition-messages transition)) + (when (not (nested-vm-inert? (kernel-mode-transition-suspension transition))) + (match transition + [(kernel-mode-transition (suspension new-state + polling-k + message-handlers + '()) + _ + '() + '()) + (define inbound-messages + (map (match-lambda [(message-handler (ground-event-pattern tag evt) k) + (wrap-evt evt (lambda (v) (cons (ground-event-value tag v) k)))]) + message-handlers)) + (match-define (cons inbound-value inbound-continuation) + (apply sync + (wrap-evt (if polling-k always-evt never-evt) + (lambda (v) (cons (ground-event-value 'idle (void)) + (lambda (dummy) polling-k)))) + inbound-messages)) + (loop ((inbound-continuation inbound-value) new-state))] + [_ + (error 'ground-vm + "Outermost VM may not spawn new siblings or send or receive metamessages")])))) diff --git a/relation.rkt b/relation.rkt new file mode 100644 index 0000000..3300f26 --- /dev/null +++ b/relation.rkt @@ -0,0 +1,131 @@ +#lang racket/base +;; Relations are equivalent to Hash> and Set>. + +(require racket/set) + +(provide (rename-out [make-relation relation]) + relation? + relation->list + list->relation + + relation-empty? + relation-count + + relation-add + relation-add-all + relation-remove + relation-remove-all + relation-ref + relation-domain-member? + relation-member? + + relation-domain-eq? + relation-domain-eqv? + relation-domain-equal? + + relation-codomain-eq? + relation-codomain-eqv? + relation-codomain-equal? + + relation-for-each + relation-fold + relation-map + + ;; TODO: -subtract, -intersect, -symmetric-difference, -union + ) + +(struct relation (table set-constructor)) + +(define (make-relation #:domain [domain-comparator equal?] + #:codomain [codomain-comparator equal?]) + (relation ((cond + [(eq? domain-comparator equal?) hash] + [(eq? domain-comparator eqv?) hasheqv] + [(eq? domain-comparator eq?) hasheq])) + (cond + [(eq? codomain-comparator equal?) set] + [(eq? codomain-comparator eqv?) seteqv] + [(eq? codomain-comparator eq?) seteq]))) + +(define (relation->list r) + (for*/list ([(k vs) (in-hash (relation-table r))] + [v (in-set vs)]) + (cons k v))) + +(define (list->relation xs + #:domain [domain-comparator equal?] + #:codomain [codomain-comparator equal?]) + (let loop ((xs xs) + (r (relation #:domain domain-comparator #:codomain codomain-comparator))) + (match xs + ['() r] + [(cons (cons k v) rest) (loop rest (relation-add r k v))] + [_ (error 'list->relation "Expected list of key/value pairs")]))) + +(define (relation-empty? r) + (zero? (hash-count (relation-table r)))) + +(define (relation-count r) + (for*/sum ([(k vs) (in-hash (relation-table r))]) (set-count vs))) + +(define (relation-add r k v) + (struct-copy relation r + [relation-table (hash-update (relation-table r) + k + (lambda (old-vs) (set-add old-vs v)) + (relation-set-constructor r))])) + +(define (relation-add-all r k vs) + (struct-copy relation r + [relation-table (hash-update (relation-table r) + k + (lambda (old-vs) (set-union old-vs vs)) + (relation-set-constructor r))])) + +(define (relation-remove r k v) + (define old-vs (hash-ref (relation-table r) k (relation-set-constructor r))) + (define new-vs (set-remove old-vs v)) + (if (set-empty? new-vs) + (hash-remove (relation-table r) k) + (hash-set (relation-table r) k new-vs))) + +(define (relation-remove-all r k vs) + (define old-vs (hash-ref (relation-table r) k (relation-set-constructor r))) + (define new-vs (set-subtract old-vs vs)) + (if (set-empty? new-vs) + (hash-remove (relation-table r) k) + (hash-set (relation-table r) k new-vs))) + +(define (relation-ref r k + [failure-result (lambda () (error 'relation-ref "Key not present: ~v" k))]) + (hash-ref (relation-table r) k failure-result)) + +(define (relation-domain-member? r k) + (hash-has-key? (relation-table r) k)) + +(define (relation-member? r k v) + (and (relation-domain-member? r k) + (set-member? (hash-ref (relation-table r) k) v))) + +(define (relation-domain-eq? r) (hash-eq? (relation-table r))) +(define (relation-domain-eqv? r) (hash-eqv? (relation-table r))) +(define (relation-domain-equal? r) (hash-equal? (relation-table r))) + +(define (relation-codomain-eq? r) (eq? (relation-set-constructor r) seteq)) +(define (relation-codomain-eqv? r) (eqv? (relation-set-constructor r) seteqv)) +(define (relation-codomain-equal? r) (equal? (relation-set-constructor r) set)) + +(define (relation-for-each r proc) + (hash-for-each (relation-table r) + (lambda (k vs) + (set-for-each vs (lambda (v) (proc k v)))))) + +(define (relation-fold r seed0 proc) + (define seed seed0) + (relation-for-each r (lambda (k v) (set! seed (proc k v seed)))) + seed) + +(define (relation-map r proc) + (define results '()) + (relation-for-each r (lambda (k v) (cons (proc k v) results))) + results)