Switch from one ad-hoc ground language to another, but eliminate HIDs.

This removes a bug in the design: metamessages wouldn't have been
dispatched properly in more general types of metanetwork than the
Racket CMLish framework.

TODO

@@ -1,3 +1,5 @@
+## DNS
+
 Make RData and RRType the same thing so it becomes impossible to make
 a mistake.
 
@@ -16,3 +18,14 @@ Tests needed:
     - looping domain-name (using compressed format)
     - compressed domain-name pointing into hyperspace
     - txt record with rdata filled with a list of empty byte-strings
+
+## os.rkt and friends
+
+ - move from quasiquoted to prefab structs
+ - define a prefab struct for every evt? that we want to use
+ - define lowest-level drivers for each prefab struct
+
+It feels like those lowest-level drivers are listening for *demand*
+i.e. they're listening for presence and are then acting to supply such
+demand. Think about the relationships between presence (both positive
+and negative), and interfacing to ad-hoc sources and sinks.

os-big-bang-example.rkt

@@ -18,7 +18,9 @@
     (transition w
 		(subscribe sid
 			   (ground-message-handler w
-			    [((read-line-evt (current-input-port) 'any) => l)
+			    [((list 'read-line reply-addr)
+			      (read-line-evt (current-input-port) 'any)
+			      => l)
 			     (transition w
 					 (unsubscribe sid)
 					 (send-message `(reply ,reply-addr ,l)))])))]))
@@ -29,9 +31,12 @@
 
 (define (tick-driver self-sid interval)
   (let loop ((last-tick-time 0) (counter 0))
+    (define next-time (+ last-tick-time interval))
     (subscribe self-sid
 	       (ground-message-handler w
-		[((time-evt (+ last-tick-time interval)) => now)
+		[((list 'timer-alarm next-time)
+		  (time-evt next-time)
+		  => now)
 		 (transition w
 			     (unsubscribe self-sid)
 			     (send-message `(tick ,counter ,now))

os-big-bang.rkt

@@ -80,26 +80,26 @@
 
 (define-syntax ground-message-handler
   (syntax-rules (=>)
-    ((_ old-state-pattern [(raw-pattern => pattern) body ...])
+    ((_ old-state-pattern [(tag-expr evt-expr => pattern) body ...])
-     (on-meta-message raw-pattern
+     (on-meta-message (ground-event-pattern tag-expr evt-expr)
 		      (lambda (meta-message old-state)
 			(match-define old-state-pattern old-state)
 			(match meta-message
-			  [pattern body ...]))))))
+			  [(ground-event-value _ pattern) body ...]))))))
 
-(define (world->os-subscription w)
+(define (world->os-suspension w)
-  (subscription w
+  (suspension w
-		#f
+	      #f
-		(for*/list ([(sid vs) (world-subscriptions w)]
+	      (for*/list ([(sid vs) (world-subscriptions w)]
-			    [v vs]
+			  [v vs]
-			    #:when (on-message? v))
+			  #:when (on-message? v))
-		  (match-define (on-message pattern handler) v)
+		(match-define (on-message pattern handler) v)
-		  (message-handler pattern (wrap-handler handler)))
+		(message-handler pattern (wrap-handler handler)))
-		(for*/list ([(sid vs) (world-subscriptions w)]
+	      (for*/list ([(sid vs) (world-subscriptions w)]
-			    [v vs]
+			  [v vs]
-			    #:when (on-meta-message? v))
+			  #:when (on-meta-message? v))
-		  (match-define (on-meta-message pattern handler) v)
+		(match-define (on-meta-message pattern handler) v)
-		  (message-handler pattern (wrap-handler handler)))))
+		(message-handler pattern (wrap-handler handler)))))
 
 (define (((wrap-handler handler) message) w)
   (maybe-transition->os-transition w (handler message (world-state w))))
@@ -111,7 +111,7 @@
 
 (define (transition->os-transition w t)
   (match-define (transition state actions) t)
-  (kernel-mode-transition (world->os-subscription (update-world w state actions))
+  (kernel-mode-transition (world->os-suspension (update-world w state actions))
 			  (for/list [(a actions) #:when (send-message? a)]
 			    (send-message-body a))
 			  (for/list [(a actions) #:when (send-meta-message? a)]

os-example.rkt

@@ -4,19 +4,19 @@
 (require racket/pretty)
 
 (define (yield k)
-  (kernel-mode-transition (subscription 'none (lambda (_) (k)) '() '())
+  (kernel-mode-transition (suspension 'none (lambda (_) (k)) '() '())
 			  '()
 			  '()
 			  '()))
 
 (define (quit)
-  (kernel-mode-transition (subscription 'none #f '() '())
+  (kernel-mode-transition (suspension 'none #f '() '())
 			  '()
 			  '()
 			  '()))
 
 (define (print x k)
-  (kernel-mode-transition (subscription 'none (lambda (_) (k)) '() '())
+  (kernel-mode-transition (suspension 'none (lambda (_) (k)) '() '())
 			  '()
 			  (list (lambda () (pretty-print x)))
 			  '()))
@@ -25,33 +25,37 @@
   (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds))))
 
 (define (sleep n k)
-  (kernel-mode-transition (subscription 'none
+  (kernel-mode-transition (suspension 'none
-					#f
+				      #f
-					'()
+				      '()
-					(list (message-handler
+				      (list (message-handler
-					       (super-alarm (+ (current-inexact-milliseconds) n))
+					     (let ((wakeup-time
-					       (lambda (_message)
+						    (+ (current-inexact-milliseconds) n)))
-						 (lambda (_state)
+					       (ground-event-pattern
-						   (k))))))
+						(list 'alarm wakeup-time)
+						(super-alarm wakeup-time)))
+					     (lambda (_message)
+					       (lambda (_state)
+						 (k))))))
 			  '()
 			  '()
 			  '()))
 
 (define (spawn thunk k)
-  (kernel-mode-transition (subscription 'none (lambda (_) (k)) '() '())
+  (kernel-mode-transition (suspension 'none (lambda (_) (k)) '() '())
 			  '()
 			  '()
 			  (list thunk)))
 
 (define (example-process delay)
   (print "SLEEPING"
-		    (lambda ()
+	 (lambda ()
-		      (sleep delay
+	   (sleep delay
-			     (lambda ()
+		  (lambda ()
-			       (yield
+		    (yield
-				(lambda ()
+		     (lambda ()
-				  (print "HELLO"
+		       (print "HELLO"
-					 quit))))))))
+			      quit))))))))
 
 (ground-vm (lambda ()
 	     (spawn (lambda ()

os-udp.rkt

@@ -58,7 +58,9 @@
 	   [`(close ,(== sname))
 	    (void)])
 	  (meta-message-handlers
-	   [((udp-receive!-evt s buffer) => (list packet-length host port))
+	   [((list 'udp-receive sname)
+	     (udp-receive!-evt s buffer)
+	     => (list packet-length host port))
 	    (define packet (subbytes buffer 0 packet-length))
 	    (printf ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>~n~v~n" packet)
 	    (dump-bytes! buffer packet-length)

os-userland-stdlib.rkt

@@ -41,9 +41,9 @@
 
 (define-syntax meta-message-handlers
   (syntax-rules (=>)
-    ((_ [(raw-pattern => pattern) body ...] ...)
+    ((_ [(tag-expr evt-expr => pattern) body ...] ...)
-     (list (wait-clause raw-pattern
+     (list (wait-clause (ground-event-pattern tag-expr evt-expr)
-			(match-lambda (pattern body ...)))
+			(match-lambda ((ground-event-value _ pattern) body ...)))
 	   ...))))
 
 (define (rpc req)
@@ -84,7 +84,9 @@
      (rpc-service
       [`read-line (wait (message-handlers)
 			(meta-message-handlers
-			 [((read-line-evt (current-input-port) 'any) => line)
+			 [('read-line
+			   (read-line-evt (current-input-port) 'any)
+			   => line)
 			  line]))]))))
 
 (define (read-line)
@@ -95,7 +97,9 @@
 
 (define (wait-mmh msecs)
   (meta-message-handlers
-   [((time-evt msecs) => current-time)
+   [((list 'time-evt msecs)
+     (time-evt msecs)
+     => current-time)
     current-time]))
 
 (define (wait-until-time msecs)

os-userland.rkt

@@ -9,6 +9,8 @@
 (provide (struct-out wait-clause)
 
 	 ground-vm ;; convenience re-export
+	 (struct-out ground-event-pattern) ;; convenience re-export
+	 (struct-out ground-event-value) ;; convenience re-export
 
 	 userland
 
@@ -55,12 +57,12 @@
 			     (append (reverse thrs) new-threads)
 			     (k void))]
     [`(wait ,polling? ,mhs ,mmhs ,k)
-     (syscall (subscription k
+     (syscall (suspension k
-			    (and polling? (lambda (k) (start-transaction (k void))))
+			  (and polling? (lambda (k) (start-transaction (k void))))
-			    (wrap-handlers mhs)
+			  (wrap-handlers mhs)
-			    (wrap-handlers mmhs)))]
+			  (wrap-handlers mmhs)))]
     [`finish
-     (syscall (subscription 'finished #f '() '()))]))
+     (syscall (suspension 'finished #f '() '()))]))
 
 (define (((invoke-handler proc) v) k)
   (start-transaction (k (lambda () (proc v)))))

os.rkt

@@ -7,7 +7,7 @@
 
 (provide
  ;; Waiting for messages
- (struct-out subscription)
+ (struct-out suspension)
  (struct-out message-handler)
 
  ;; Kernel requests
@@ -18,9 +18,11 @@
  vm?
  run-vm
  nested-vm
+ default-pattern-predicate
 
  ;; Grounding out the infinite tower of VMs
- default-pattern-predicate
+ (struct-out ground-event-pattern)
+ (struct-out ground-event-value)
  ground-vm
  )
 
@@ -76,7 +78,8 @@
 	    pending-messages
 	    pending-meta-messages
 	    pending-processes
-	    pattern-predicate) #:transparent)
+	    pattern-predicate
+	    meta-pattern-predicate) #:transparent)
 
 ;; A TrapK<X> is a X -> InterruptK, representing a suspended process
 ;; waiting for some information from the VM before it can continue.
@@ -92,22 +95,12 @@
 ;; fresh process or a previously-suspended process just about to
 ;; resume.
 
-;; A Subscription is a
-;; (subscription ProcessState
-;;               Maybe<InterruptK>
-;;               ListBagOf<MessageHandler>
-;;               ListBagOf<MetaMessageHandler>).
-;; To poll the kernel, include a non-#f InterruptK.
-(struct subscription (state
-		      k
-		      message-handlers
-		      meta-message-handlers) #:transparent)
-
 ;; A Suspension is a
 ;; (suspension ProcessState
 ;;             Maybe<InterruptK>
 ;;             ListBagOf<MessageHandler>
-;;             Map<HID,MetaMessageHandler>).
+;;             ListBagOf<MetaMessageHandler>).
+;; To poll the kernel, include a non-#f InterruptK.
 (struct suspension (state
 		    k
 		    message-handlers
@@ -123,14 +116,14 @@
 (struct message-handler (pattern k) #:transparent)
 
 ;; A KernelModeTransition is a
-;; (kernel-mode-transition Subscription
+;; (kernel-mode-transition Suspension
 ;;                         ListBagOf<Message>
 ;;			   ListBagOf<MetaMessage>
 ;;                         ListBagOf<BootK>)
-;; representing the subscription for the transitioning process, a list
+;; representing the suspension of the transitioning process, a list of
-;; of messages to emit at both this VM's and its container's level,
+;; messages to emit at both this VM's and its container's level, and a
-;; and a list of new processes to create and schedule.
+;; list of new processes to create and schedule.
-(struct kernel-mode-transition (subscription
+(struct kernel-mode-transition (suspension
 				messages
 				meta-messages
 				new-processes) #:transparent)
@@ -145,12 +138,15 @@
 ;; TODO: timeouts
 
 ;; BootK -> VM
-(define (make-vm boot #:pattern-predicate [pattern-predicate default-pattern-predicate])
+(define (make-vm boot
+		 #:pattern-predicate [pattern-predicate default-pattern-predicate]
+		 #:meta-pattern-predicate [meta-pattern-predicate default-pattern-predicate])
   (vm (list)
       (list)
       (list)
       (cons boot (list))
-      pattern-predicate))
+      pattern-predicate
+      meta-pattern-predicate))
 
 ;; VM -> KernelModeTransition
 ;; (A kind of Meta-InterruptK)
@@ -162,7 +158,7 @@
 	 (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 (subscription state poller-k meta-handlers '())
+    (kernel-mode-transition (suspension state poller-k meta-handlers '())
 			    meta-messages
 			    '()
 			    '())))
@@ -186,40 +182,32 @@
 	 (reverse (vm-pending-messages state))))
 
 (define (extract-downward-meta-message-handlers susp)
-  (for/list ([(hid mmh) (in-hash (suspension-meta-message-handlers susp))])
+  (for/list ([mmh (suspension-meta-message-handlers susp)])
-    (message-handler (message-handler-pattern mmh) (dispatch-meta-message hid))))
+    (message-handler (message-handler-pattern mmh) (dispatch-meta-message mmh))))
 
-(define (extract-upward-meta-message-handlers susp)
+(define (((dispatch-meta-message mmh) message) state)
-  (for/list ([(hid mmh) (in-hash (suspension-meta-message-handlers susp))])
-    (message-handler hid (message-handler-k mmh))))
-
-(define (((dispatch-meta-message hid) message) state)
   (run-vm
    (foldl (match-suspension message
-			    (lambda (handler-hid message) (equal? hid handler-hid))
+			    (vm-meta-pattern-predicate state)
-			    extract-upward-meta-message-handlers)
+			    suspension-meta-message-handlers)
 	  (struct-copy vm state [suspensions '()])
 	  (vm-suspensions state))))
 
 ;; KernelModeTransition VM -> VM
 (define (perform-transition transition state)
   (match transition
-    [(kernel-mode-transition new-subscription
+    [(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 (subscription->suspension new-subscription) state))
+	    (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 (subscription->suspension sub)
-  (match-define (subscription ps k mhs mmhs) sub)
-  (suspension ps k mhs (for/hash ([mmh mmhs]) (values (gensym 'hid) mmh))))
-
 (define (enqueue-message message state)
   (struct-copy vm state [pending-messages (cons message (vm-pending-messages state))]))
 
@@ -228,7 +216,7 @@
 
 (define (enqueue-suspension susp state)
   (match susp
-    [(suspension _ #f '() (? (lambda (h) (zero? (hash-count h)))))
+    [(suspension _ #f '() '())
      ;; dead process because no continuations offered
      state]
     [(suspension _ _ _ _)
@@ -269,21 +257,31 @@
       (not (null? (vm-pending-messages state)))
       (ormap suspension-polling? (vm-suspensions state))))
 
-(define (nested-vm boot #:pattern-predicate [pattern-predicate default-pattern-predicate])
+(define (nested-vm boot
-  (lambda () (run-vm (make-vm boot #:pattern-predicate pattern-predicate))))
+		   #: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? sub)
   (match sub
-    [(subscription (vm _ '() '() '() _) #f '() '())
+    [(suspension (vm _ '() '() '() _ _) #f '() '())
      ;; Inert iff not waiting for any messages or metamessages, and
      ;; with no internal work left to do.
      #t]
     [_ #f]))
 
-(define default-pattern-predicate
+(struct ground-event-pattern (tag evt) #:transparent)
-  (lambda (p m) (p m)))
+(struct ground-event-value (tag val) #:transparent)
+
+(define (match-ground-event p m)
+  (equal? (ground-event-pattern-tag p) (ground-event-value-tag m)))
 
 ;; PatternPredicate ( -> KernelModeTransition ) -> Void
 ;; In this context,
@@ -291,25 +289,29 @@
 ;;   MessagePattern = evt?
 ;;   MetaMessage, MetaMessagePattern = not defined because there's no outer level
 ;; Runs its argument VM until it becomes (provably) inert.
-(define (ground-vm boot #:pattern-predicate [pattern-predicate default-pattern-predicate])
+(define (ground-vm boot
-  (let loop ((transition (run-vm (make-vm boot #:pattern-predicate pattern-predicate))))
+		   #: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-subscription transition)))
+    (when (not (nested-vm-inert? (kernel-mode-transition-suspension transition)))
       (match transition
-	[(kernel-mode-transition (subscription new-state
+	[(kernel-mode-transition (suspension new-state
-					       polling-k
+					     polling-k
-					       message-handlers
+					     message-handlers
-					       '())
+					     '())
 				 _
 				 '()
 				 '())
 	 (define inbound-messages
-	   (map (match-lambda [(message-handler e k) (wrap-evt e (lambda (v) (cons v k)))])
+	   (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 (void)
+			    (lambda (v) (cons (ground-event-value 'idle (void))
 					      (lambda (dummy) polling-k))))
 		  inbound-messages))
 	 (loop ((inbound-continuation inbound-value) new-state))]

universe.rkt

@@ -59,7 +59,9 @@
 			    (subscribe 'ticker
 				       (ground-message-handler
 					(and w (ticker-state counter interval limit))
-					[((time-evt next-alarm-time) => now)
+					[((list 'timer-alarm next-alarm-time)
+					  (time-evt next-alarm-time)
+					  => now)
 					 (if (and (positive? limit) (>= counter limit))
 					     (transition w (unsubscribe 'ticker))
 					     (transition (ticker-state (+ counter 1) interval limit)
@@ -106,7 +108,9 @@
    (spawn (os-big-bang 'none
 		       (subscribe 'inbound-relay
 				  (ground-message-handler w
-				   [(c:ui->world => message)
+				   [('communication-from-ui
+				     c:ui->world
+				     => message)
 				    (transition w (send-message message))]))
 		       (subscribe 'stopper
 				  (message-handlers w