Move over to explicit per-actor "bcom" (become)

This removes a "zombie fungus" takeover attack
parent 5366b038
......@@ -17,9 +17,6 @@
(raart:blank 0 0)))
0 0)))
(define-syntax-rule (become-thunk body ...)
(become (thunk body ...)))
(struct game
(;; actormap of participants
actormap
......@@ -115,7 +112,7 @@
(random -1 2))
(max -1 (min 1 (+ drift drift-it))))
(define raise-delay (random 10 30))
(define (lp x y time-till-raise drift)
(define ((lp x y time-till-raise drift) bcom)
(define time-to-live
(- bubble-lifetime y))
(define bubble-shape
......@@ -139,7 +136,7 @@
;; o/~ I tried so hard... and went so far... o/~
'die
;; Time to move and adjust
(become-thunk
(bcom
(lp (max 0 ; drift, but stay within confines
(min (+ x drift)
(sub1 cauldron-width)))
......@@ -148,10 +145,10 @@
(modify-drift drift))))]
;; stay the same..
[else
(become-thunk
(bcom
(lp x y (sub1 time-till-raise) drift))]))
(thunk (lp (random 2 (- cauldron-width 2))
0 raise-delay 0)))
(lp (random 2 (- cauldron-width 2))
0 raise-delay 0))
(define (cauldron spawn-ticked display-cell env)
(define bubble-display-key
......@@ -160,35 +157,36 @@
(raart:blank cauldron-width bubble-max-height))
(define (new-bubble-cooldown)
(random 15 40))
(thunk
(let lp ([bubble-cooldown (new-bubble-cooldown)])
(define bubble-time? (eqv? bubble-cooldown 0))
(when bubble-time?
(spawn-ticked (make-bubble env bubble-display-key)))
(define (do-display)
(define all-bubbles
(env 'read bubble-display-key))
(define bubbled-canvas
(for/fold ([canvas bubble-canvas])
([bubble-info all-bubbles])
(match bubble-info
[(list col row char)
(raart:place-at canvas
(sub1 (- bubble-max-height row))
col (raart:char char))])))
(raart:vappend
#:halign 'center
;; green
(raart:fg 'green
bubbled-canvas)
;; yellow
(raart:fg 'yellow
cauldron-raart)))
(display-cell do-display)
(become-thunk
(lp (if bubble-time?
(new-bubble-cooldown)
(sub1 bubble-cooldown)))))))
(lambda (bcom)
(let lp ([bubble-cooldown (new-bubble-cooldown)])
(define bubble-time? (eqv? bubble-cooldown 0))
(when bubble-time?
(spawn-ticked (make-bubble env bubble-display-key)))
(define (do-display)
(define all-bubbles
(env 'read bubble-display-key))
(define bubbled-canvas
(for/fold ([canvas bubble-canvas])
([bubble-info all-bubbles])
(match bubble-info
[(list col row char)
(raart:place-at canvas
(sub1 (- bubble-max-height row))
col (raart:char char))])))
(raart:vappend
#:halign 'center
;; green
(raart:fg 'green
bubbled-canvas)
;; yellow
(raart:fg 'yellow
cauldron-raart)))
(display-cell do-display)
(bcom
(lambda _
(lp (if bubble-time?
(new-bubble-cooldown)
(sub1 bubble-cooldown))))))))
(define (val->raart val)
(match val
......
......@@ -9,6 +9,7 @@
(require "../utils/simple-sealers.rkt"
"../core.rkt"
"facet.rkt"
"match-methods.rkt"
racket/match)
(define (rw->read-key rw-key)
......@@ -66,8 +67,9 @@
id])]))
(define (env ht)
(match-lambda*
[(list 'new-key)
(match-methods
bcom
[(new-key)
;; unique by eq?
(define id
(cons 'tick 'key))
......@@ -78,11 +80,11 @@
(define rw-key
`(rw-key ,read-key ,write-key))
rw-key]
[(list 'read readable-key)
[(read readable-key)
(define id
(extract/verify-read-id readable-key))
(hash-ref ht id '())]
[(list 'write writeable-key val)
[(write writeable-key val)
(define id
(extract/verify-write-id writeable-key))
(define updated-ht
......@@ -90,11 +92,11 @@
(cons val (hash-ref ht id '()))))
(define new-env
(env updated-ht))
(become new-env)]
[(list 'reset)
(bcom new-env)]
[(reset)
(define new-env
(env #hasheq()))
(become new-env)]))
(bcom new-env)]))
(env #hasheq()))
......@@ -104,7 +106,7 @@
(define rw-facet
(spawn (facet this-env 'new-key 'read 'write)))
(define reset-facet
(spawn (lambda ()
(spawn (lambda (bcom)
(call this-env 'reset))))
(list rw-facet reset-facet))
......
......@@ -14,7 +14,7 @@
any/c)
(define facet
(make-keyword-procedure
(lambda (kws kw-args . args)
(lambda (kws kw-args become . args)
(match args
[(list (? symbol? method) args ...)
(unless (set-member? methods method)
......@@ -28,19 +28,21 @@
(module+ test
(require rackunit
"../core.rkt")
"../core.rkt"
"match-methods.rkt")
(define am (make-actormap))
(define all-powerful-wizard
(actormap-spawn! am (match-lambda*
[(list 'magic-missile level)
(format "Casts magic missile level ~a!"
level)]
[(list 'flame-tongue level)
(format "Casts flame tongue level ~a!"
level)]
[(list 'world-ender level)
(format "Casts world ender level ~a!"
level)])))
(actormap-spawn! am (match-methods
become
[(magic-missile level)
(format "Casts magic missile level ~a!"
level)]
[(flame-tongue level)
(format "Casts flame tongue level ~a!"
level)]
[(world-ender level)
(format "Casts world ender level ~a!"
level)])))
(define faceted-wizard
(actormap-spawn! am
(facet all-powerful-wizard
......
......@@ -18,20 +18,20 @@
(define-syntax method-defn-sym
(syntax-rules ()
[(_ [(method-name method-args ...) body ...])
[(_ [(method-name bcom method-args ...) body ...])
(quote method-name)]
[(_ [(method-name method-args ... . rest) body ...])
[(_ [(method-name bcom method-args ... . rest) body ...])
(quote method-name)]
[(_ [method-name proc])
(quote method-name)]))
(define-syntax method-defn-proc
(syntax-rules ()
[(_ [(method-name method-args ...) body ...])
(lambda (method-args ...)
[(_ [(method-name bcom method-args ...) body ...])
(lambda (bcom method-args ...)
body ...)]
[(_ [(method-name method-args ... . rest) body ...])
(lambda (method-args ... . rest)
[(_ [(method-name bcom method-args ... . rest) body ...])
(lambda (bcom method-args ... . rest)
body ...)]
[(_ [method-name proc])
proc]))
......@@ -40,14 +40,14 @@
(syntax-rules ()
[(masyme method-defn ...)
(make-keyword-procedure
(lambda (kws kw-args method . args)
(lambda (kws kw-args become method . args)
(define method-proc
(cond
[(eq? method (method-defn-sym method-defn))
(method-defn-proc method-defn)] ...
[else
(error (format "No such method ~a" method))]))
(keyword-apply method-proc kws kw-args args)))]))
(keyword-apply method-proc kws kw-args become args)))]))
(define-syntax-rule (define-masyme id rest ...)
(define id (masyme rest ...)))
......@@ -59,35 +59,35 @@
(require rackunit
racket/contract)
(define-masyme objekt
[(beep)
[(beep _)
'beep-boop]
[(hello name)
[(hello _ name)
(format "hello ~a!" name)]
[(sing singer [lyric "once upon a bonnie moon..."]
[(sing _ singer [lyric "once upon a bonnie moon..."]
#:note-str [note-str "o/~"])
(format "<~a> ~a ~a ~a"
singer note-str lyric note-str)])
(check-eq?
(objekt 'beep)
(objekt 'become-goes-here 'beep)
'beep-boop)
(check-equal?
(objekt 'hello "george")
(objekt 'become-goes-here 'hello "george")
"hello george!")
(check-equal?
(objekt 'sing "frank")
(objekt 'become-goes-here 'sing "frank")
"<frank> o/~ once upon a bonnie moon... o/~")
(check-equal?
(objekt 'sing "george"
(objekt 'become-goes-here 'sing "george"
"once upon a swingin' star..."
#:note-str "♫")
"<george> ♫ once upon a swingin' star... ♫")
(check-exn
any/c
(lambda ()
(objekt 'nope)))
(objekt 'become-goes-here 'nope)))
(check-equal?
((masyme [(foo . bar) bar])
'foo 'bar 'baz)
((masyme [(foo bcom . bar) bar])
'become-goes-here 'foo 'bar 'baz)
'(bar baz)))
......@@ -6,17 +6,17 @@
(define (spawn-revokeable target)
(define revoked?
(make-cell #f))
(spawn-cell #f))
(define forwarder
(spawn
(make-keyword-procedure
(lambda (kws kw-args . args)
(lambda (kws kw-args become . args)
(when (revoked?)
(error "Access revoked!"))
(keyword-apply target kws kw-args args)))))
(keyword-apply call kws kw-args target args)))))
(define revoker
(spawn
(lambda ()
(lambda (bcom)
(revoked? #t))))
(list forwarder revoker))
......@@ -27,7 +27,7 @@
(define am (make-actormap))
(define royal-admission
(actormap-spawn!
am (lambda ()
am (lambda (bcom)
"The Queen will see you now.")))
(match-define (list royal-forwarder royal-revoker)
(actormap-run! am (lambda ()
......
......@@ -13,10 +13,10 @@
(define new-ticked
(spawn (make-cell '())))
;; This registers new ticked objects
(define (tick-register . entries)
(define (tick-register bcom . entries)
(new-ticked (append entries (new-ticked))))
;; This runs all ticked objects
(define ((make-ticker current-ticked))
(define ((make-ticker current-ticked) bcom)
;; Update set of tickers with any that have been
;; added since when we last ran
(define updated-ticked
......@@ -32,7 +32,7 @@
'()
updated-ticked))
;; update ourself
(become (make-ticker next-tickers)))
(bcom (make-ticker next-tickers)))
(list (spawn tick-register)
(spawn (make-ticker '()))))
......@@ -48,7 +48,7 @@
(actormap-spawn! am (make-cell)))
(define (malaise-sufferer name speaking-cell
[maximum-suffering 3])
(define ((loop n))
(define ((loop n) bcom)
(if (> n maximum-suffering)
(begin
(speaking-cell
......@@ -59,7 +59,7 @@
(speaking-cell
(format "<~a> sigh number ~a"
name n))
(become (loop (add1 n))))))
(bcom (loop (add1 n))))))
(loop 1))
(define joe
(actormap-spawn! am (malaise-sufferer "joe"
......
......@@ -63,8 +63,6 @@
[(or/c #f symbol? string?)]
any/c)])
become
call
(contract-out
[spawn
......@@ -147,7 +145,8 @@
;;; Resolved things
;; once a near refr, always a near refr.
(struct mactor:near mactor (handler))
(struct mactor:near mactor (handler
become become-unsealer become?))
;; Once encased, always encased.
;; TODO: Maybe we don't need mactors for this. Maybe anything that's
;; not a mactor is basically "encased"? But having an official
......@@ -163,6 +162,23 @@
(struct mactor:far-promise mactor (vat-connid))
;;; "Become" special sealers
;;; ========================
(define (make-become-sealer-triplet)
(define-values (struct:seal make-seal sealed? seal-ref seal-set!)
(make-struct-type 'become #f 2 0))
(define (become handler [return-val (void)])
(make-seal handler return-val))
(define unseal-handler
(make-struct-field-accessor seal-ref 0))
(define unseal-return-val
(make-struct-field-accessor seal-ref 1))
(define (unseal sealed-become)
(values (unseal-handler sealed-become)
(unseal-return-val sealed-become)))
(values become unseal sealed?))
;;; Actormaps, whactormaps and transactormaps
;;; =========================================
......@@ -436,23 +452,26 @@
(define actor-handler
(mactor:near-handler mactor))
(define result
(keyword-apply actor-handler kws kw-args args))
(keyword-apply actor-handler kws kw-args
(mactor:near-become mactor) args))
;; I guess watching for this guarantees that an immediate call
;; against a local actor will not be tail recursive.
;; TODO: We need to document that.
(define-values (return-val new-handler)
(define-values (new-handler return-val)
(match result
[(? becoming?)
(values (becoming-return-val result)
(becoming-handler result))]
[_ (values result #f)]))
[(? (mactor:near-become? mactor))
((mactor:near-become-unsealer mactor) result)]
[_ (values #f result)]))
;; if a new handler for this actor was specified,
;; let's replace it
(when new-handler
(transactormap-set! actormap update-refr
(mactor:near new-handler)))
(mactor:near new-handler
(mactor:near-become mactor)
(mactor:near-become-unsealer mactor)
(mactor:near-become? mactor))))
return-val]
[(? mactor:encased?)
......@@ -604,7 +623,7 @@
;; ones because they'll be in a new syscaller
(_spawn
(match-lambda*
[(list 'fulfill val)
[(list bcom 'fulfill val)
(define fulfilled-response-val
(call-on-fulfilled val))
(when return-promise?
......@@ -613,7 +632,7 @@
;; return this, or if we should just return void.
;; I don't think it hurts?
fulfilled-response-val]
[(list 'break problem)
[(list bcom 'break problem)
(when return-promise?
(<- return-p-resolver 'break problem))
(call-on-broken problem)])))
......@@ -651,21 +670,6 @@
(values this-syscaller get-internals close-up!))
;;; setting up become handler
;;; =======================
(struct becoming (handler return-val)
#:constructor-name _make-becoming)
(define/contract (become handler [return-val (void)])
(->* [(and/c procedure? (not/c refr?))]
[(not/c becoming?)]
any/c)
(_make-becoming handler return-val))
(module+ extra-becoming
(provide becoming becoming? becoming-handler becoming-return-val))
;;; syscall external functions
;;; ==========================
......@@ -822,7 +826,7 @@
;; like actormap-run but also returns the new actormap, to-local, to-remote
(define (actormap-run* actormap thunk)
(define-values (actor-refr new-actormap)
(actormap-spawn actormap thunk))
(actormap-spawn actormap (lambda (become) (thunk))))
(define-values (returned-val new-actormap2 to-local to-remote)
(actormap-turn* new-actormap actor-refr '() '() '()))
(values returned-val new-actormap2 to-local to-remote))
......@@ -831,7 +835,7 @@
;; Run, and also commit the results of, the code in the thunk
(define (actormap-run! actormap thunk)
(define actor-refr
(actormap-spawn! actormap thunk))
(actormap-spawn! actormap (lambda (become) (thunk))))
(actormap-poke! actormap actor-refr))
......@@ -899,16 +903,23 @@
(make-live-refr debug-name))
(define new-actormap
(make-transactormap actormap))
(define-values (become become-unseal become?)
(make-become-sealer-triplet))
(transactormap-set! new-actormap actor-refr
(mactor:near actor-handler))
(mactor:near actor-handler
become become-unseal become?))
(values actor-refr new-actormap))
(define (actormap-spawn! actormap actor-handler
[debug-name (object-name actor-handler)])
(define actor-refr
(make-live-refr debug-name))
(define-values (become become-unseal become?)
(make-become-sealer-triplet))
(actormap-set! actormap actor-refr
(mactor:near actor-handler))
(mactor:near actor-handler
become become-unseal become?))
actor-refr)
(define (actormap-spawn-mactor! actormap mactor [debug-name #f])
......@@ -922,9 +933,9 @@
racket/contract)
(define am (make-whactormap))
(define ((counter n))
(become (counter (add1 n))
n))
(define ((counter n) bcom)
(bcom (counter (add1 n))
n))
;; can actors update themselves?
(define ctr-refr
......@@ -951,13 +962,13 @@
(actormap-turn am ctr-refr))
(check-eqv? turned-val3 3)
(define (friend-spawner friend-name)
(define ((a-friend [called-times 0]))
(define (friend-spawner bcom friend-name)
(define ((a-friend [called-times 0]) bcom)
(define new-called-times
(add1 called-times))
(become (a-friend new-called-times)
(format "Hello! My name is ~a and I've been called ~a times!"
friend-name new-called-times)))
(bcom (a-friend new-called-times)
(format "Hello! My name is ~a and I've been called ~a times!"
friend-name new-called-times)))
(spawn (a-friend) 'friend))
(define fr-spwn (actormap-spawn! am friend-spawner))
(define joe (actormap-poke! am fr-spwn 'joe))
......@@ -972,7 +983,7 @@
"Hello! My name is joe and I've been called 2 times!")
(define-values (noncommital-refr noncommital-am)
(actormap-spawn am (lambda () 'noncommital)))
(actormap-spawn am (lambda (bcom) 'noncommital)))
(check-eq?
(actormap-peek noncommital-am noncommital-refr)
'noncommital)
......@@ -1010,9 +1021,9 @@
(define (make-cell [val #f])
(case-lambda
[() val]
[(new-val)
(become (make-cell new-val))]))
[(bcom) val]
[(bcom new-val)
(bcom (make-cell new-val))]))
(define (spawn-cell [val #f])
(spawn (make-cell val) 'cell))
......@@ -1064,14 +1075,14 @@
(define resolver
(spawn
(match-lambda*
[(list 'fulfill val)
[(list bcom 'fulfill val)
(define sys (get-syscaller-or-die))
(sys 'fulfill-promise promise (sealer val))
(become already-resolved)]
[(list 'break problem)
(bcom already-resolved)]
[(list bcom 'break problem)
(define sys (get-syscaller-or-die))
(sys 'break-promise promise (sealer problem))
(become already-resolved)])
(bcom already-resolved)])
'resolver))
(list promise resolver))
......@@ -1240,7 +1251,8 @@
am
(actormap-full-run!
am (lambda ()
(define doubler (spawn (lambda (x) (* x 2))))
(define doubler (spawn (lambda (bcom x)
(* x 2))))
(define the-on-promise
(on (<-p doubler 3)
(lambda (x)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment