suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Converting to scheme/base

Browse Source 
svn: r15268
This commit is contained in:
Jay McCarthy 2009-06-25 18:56:11 +00:00
parent b8970a439b
commit 04566b2fcf
3 changed files with 720 additions and 733 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/frtime/dv.ss
View File

@ -23,6 +23,7 @@
[(struct dv (_ _ vec)) [(struct dv (_ _ vec))
(vector-set! vec pos new-val)])) (vector-set! vec pos new-val)]))
; XXX Make this more efficient by preserving previous vector
(define (dv:append a-dv item) (define (dv:append a-dv item)
(match a-dv (match a-dv
[(struct dv (real used vec)) [(struct dv (real used vec))

446
collects/frtime/frp-core.ss
View File

@ -1,72 +1,50 @@
#lang scheme
(module frp-core mzscheme (require (only-in mzlib/etc
(require mzlib/etc identity nor)
mzlib/list
mzlib/match
"erl.ss" "erl.ss"
"heap.ss") "heap.ss")
(require-for-syntax scheme/struct-info) ;;;;;;;;;;;;;
;; Globals ;;
;;;;;;;;;;;;;
;; the current logical time step
(define logical-time (box 0))
(define (current-logical-time)
;;;;;;;;;;;;;
;; Globals ;;
;;;;;;;;;;;;;
;; the current logical time step
(define logical-time (box 0))
(define (current-logical-time)
(unbox logical-time)) (unbox logical-time))
(define frtime-inspector (make-inspector)) (define frtime-inspector (make-inspector))
(print-struct #t) (print-struct #t)
(define snap? (make-parameter #f)) (define snap? (make-parameter #f))
(define named-dependents (make-hash-table)) (define named-dependents (make-hash))
(define (compose-continuation-mark-sets2 s1 s2) (define (compose-continuation-mark-sets2 s1 s2)
s2) s2)
(define (my-ccm)
(define (my-ccm)
(current-continuation-marks) (current-continuation-marks)
; XXX What is this?
#;(continuation-mark-set->list (current-continuation-marks) 'drscheme-debug-continuation-mark-key)) #;(continuation-mark-set->list (current-continuation-marks) 'drscheme-debug-continuation-mark-key))
;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;
;; Structures ;; ;; Structures ;;
;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;
; also models events, where 'value' is all the events that ; also models events, where 'value' is all the events that
; haven't yet occurred (more specifically, an event-cons cell whose ; haven't yet occurred (more specifically, an event-cons cell whose
; tail is *undefined*) ; tail is *undefined*)
(define-values (struct:signal (define-struct signal ([value #:mutable]
make-signal [dependents #:mutable]
signal? [stale? #:mutable]
signal-value [thunk #:mutable]
signal-dependents [depth #:mutable]
signal-stale? [continuation-marks #:mutable]
signal-thunk parameterization
signal-depth [producers #:mutable])
signal-continuation-marks #:inspector frtime-inspector
signal-parameterization #:property prop:procedure
signal-producers
set-signal-value!
set-signal-dependents!
set-signal-stale?!
set-signal-thunk!
set-signal-depth!
set-signal-continuation-marks!
set-signal-parameterization!
set-signal-producers!)
(let*-values ([(field-name-symbols)
(list 'value 'dependents 'stale? 'thunk
'depth 'continuation-marks 'parameterization 'producers)]
[(desc make-signal signal? acc mut)
(make-struct-type
'signal #f (length field-name-symbols) 0 #f null frtime-inspector
(lambda (fn . args) (lambda (fn . args)
(unregister #f fn) ; clear out stale dependencies from previous apps (unregister #f fn) ; clear out stale dependencies from previous apps
(let* (; revisit error-reporting for switched behaviors (let* (; revisit error-reporting for switched behaviors
@ -76,80 +54,53 @@
(when (signal? res) (when (signal? res)
(set-signal-continuation-marks! res ccm)) (set-signal-continuation-marks! res ccm))
res))]) res))])
(super-lift app-fun fn))))]) (super-lift app-fun fn))))
(apply values
desc
make-signal
signal?
(append
(build-list (length field-name-symbols)
(lambda (i) (make-struct-field-accessor acc i (list-ref field-name-symbols i))))
(build-list (length field-name-symbols)
(lambda (i) (make-struct-field-mutator mut i (list-ref field-name-symbols i))))))))
(define-syntax signal ; XXX Remove
(let ([field-name-symbols (list 'value 'dependents 'stale? 'thunk #;(define (signal-custodian sig)
'depth 'continuation-marks 'parameterization
'producers)]
[cert (syntax-local-certifier #t)])
(make-struct-info
(lambda ()
(list
(cert #'struct:signal)
(cert #'make-signal)
(cert #'signal?)
(map
(lambda (fd)
(cert (datum->syntax-object
#'here
(string->symbol (format "signal-~a" fd)))))
(reverse field-name-symbols))
(map
(lambda (fd)
(cert (datum->syntax-object
#'here
(string->symbol (format "set-signal-~a!" fd)))))
(reverse field-name-symbols))
#t)))))
(define (signal-custodian sig)
(call-with-parameterization (call-with-parameterization
(signal-parameterization sig) (signal-parameterization sig)
current-cust)) current-cust))
(define-struct ft-cust (signal constructed-sigs children)) (define-struct ft-cust (signal constructed-sigs children) #:mutable)
;(define-struct non-scheduled (signal))
(define make-non-scheduled identity) (define make-non-scheduled identity)
(define (non-scheduled? x) #f) (define (non-scheduled? x) #f)
(define (non-scheduled-signal x) (define (non-scheduled-signal x)
(error 'non-scheduled-signal "should never be called")) (error 'non-scheduled-signal "should never be called"))
(define current-cust (define current-cust
(make-parameter #f)) (make-parameter #f))
(define-struct multiple (values) frtime-inspector) (define-struct multiple (values)
#:inspector frtime-inspector)
(define-struct event-set (time events)) (define-struct event-set (time events))
(define (make-events-now events) (define (make-events-now events)
(make-event-set (current-logical-time) events)) (make-event-set (current-logical-time) events))
(define-struct (signal:unchanged signal) () frtime-inspector) (define-struct (signal:unchanged signal) ()
(define-struct (signal:compound signal:unchanged) (content copy) frtime-inspector) #:inspector frtime-inspector)
(define-struct (signal:switching signal:unchanged) (current trigger) frtime-inspector) (define-struct (signal:compound signal:unchanged) (content copy)
(define-struct (signal:event signal) () frtime-inspector) #:inspector frtime-inspector)
(define-struct (signal:switching signal:unchanged) (current trigger)
#:inspector frtime-inspector)
(define-struct (signal:event signal) ()
#:inspector frtime-inspector)
; an external event; contains a list of pairs ; an external event; contains a list of pairs
; (recip val), where val is passed to recip's thunk ; (recip val), where val is passed to recip's thunk
(define-struct external-event (recip-val-pairs)) (define-struct external-event (recip-val-pairs))
; update the given signal at the given time ; update the given signal at the given time
(define-struct alarm (time signal)) (define-struct alarm (time signal))
(define extra-cont-marks (make-parameter #f)) (define extra-cont-marks (make-parameter #f))
(define (effective-continuation-marks) (define (effective-continuation-marks)
(if (extra-cont-marks) (if (extra-cont-marks)
(begin (begin
; XXX Remove
#;(thread (lambda () (raise (make-exn:fail #;(thread (lambda () (raise (make-exn:fail
"extra marks present!" (extra-cont-marks))))) "extra marks present!" (extra-cont-marks)))))
(compose-continuation-mark-sets2 (compose-continuation-mark-sets2
@ -158,9 +109,9 @@
)) ))
(my-ccm))) (my-ccm)))
;; Simple Structure Combinators ;; Simple Structure Combinators
(define (event-receiver) (define (event-receiver)
(event-producer2 (event-producer2
(lambda (emit) (lambda (emit)
(lambda the-args (lambda the-args
@ -168,7 +119,7 @@
(emit (first the-args)) (emit (first the-args))
(make-events-now empty)))))) (make-events-now empty))))))
(define (event-producer2 proc . deps) (define (event-producer2 proc . deps)
(let* ([result (apply proc->signal (lambda args (make-events-now empty)) deps)] (let* ([result (apply proc->signal (lambda args (make-events-now empty)) deps)]
[proc/emit (proc [proc/emit (proc
(lambda (val) (lambda (val)
@ -181,7 +132,7 @@
(set-signal-thunk! result proc/emit) (set-signal-thunk! result proc/emit)
result)) result))
(define (build-signal ctor thunk producers) (define (build-signal ctor thunk producers)
(let ([ccm (effective-continuation-marks)]) (let ([ccm (effective-continuation-marks)])
(do-in-manager (do-in-manager
(let* ([cust (current-cust)] (let* ([cust (current-cust)]
@ -204,7 +155,7 @@
(iq-enqueue sig) (iq-enqueue sig)
sig)))) sig))))
(define (proc->signal:switching thunk current-box trigger . producers) (define (proc->signal:switching thunk current-box trigger . producers)
(let ([ccm (effective-continuation-marks)]) (let ([ccm (effective-continuation-marks)])
(do-in-manager (do-in-manager
(let* ([cust (current-cust)] (let* ([cust (current-cust)]
@ -230,87 +181,80 @@
(iq-enqueue sig) (iq-enqueue sig)
sig)))) sig))))
(define ht (make-hash-table)) (define (proc->signal thunk . producers)
(define (proc->signal thunk . producers)
(build-signal make-signal thunk producers)) (build-signal make-signal thunk producers))
(define (proc->signal/dont-gc-unless other-val thunk . producers) ; XXX Remove
#;(define ht (make-hash))
#;(define (proc->signal/dont-gc-unless other-val thunk . producers)
(let ([result (build-signal make-signal thunk producers)]) (let ([result (build-signal make-signal thunk producers)])
(hash-table-put! ht other-val result) (hash-set! ht other-val result)
result)) result))
(define (proc->signal:unchanged thunk . producers) (define (proc->signal:unchanged thunk . producers)
(build-signal make-signal:unchanged thunk producers)) (build-signal make-signal:unchanged thunk producers))
;;;;;;;;;;;;;;;;;;;;;;;;;
;; Simple Signal Tools ;;
;;;;;;;;;;;;;;;;;;;;;;;;;
(define (send-event rcvr val)
;;;;;;;;;;;;;;;;;;;;;;;;;
;; Simple Signal Tools ;;
;;;;;;;;;;;;;;;;;;;;;;;;;
(define (send-event rcvr val)
(! man (make-external-event (list (list rcvr val))))) (! man (make-external-event (list (list rcvr val)))))
(define (send-synchronous-event rcvr val) ; XXX move man check into contract
(define (send-synchronous-event rcvr val)
(when (man?) (when (man?)
(error 'send-synchronous-event "already in frtime engine (would deadlock)")) (error 'send-synchronous-event "already in frtime engine (would deadlock)"))
(! man (make-external-event (list (list rcvr val)))) (! man (make-external-event (list (list rcvr val))))
(do-in-manager ())) (do-in-manager '()))
(define (send-synchronous-events rcvr-val-pairs) ; XXX move man check into contract
(define (send-synchronous-events rcvr-val-pairs)
(when (man?) (when (man?)
(error 'send-synchronous-events "already in frtime engine (would deadlock)")) (error 'send-synchronous-events "already in frtime engine (would deadlock)"))
(unless (ormap list? rcvr-val-pairs) (error "not list"))
(unless (ormap signal? (map first rcvr-val-pairs)) (error "not signals"))
(! man (make-external-event rcvr-val-pairs)) (! man (make-external-event rcvr-val-pairs))
(do-in-manager ())) (do-in-manager '()))
; set-cell! : cell[a] a -> void
; set-cell! : cell[a] a -> void (define (set-cell! ref beh)
(define (set-cell! ref beh)
(if (man?) (if (man?)
(iq-enqueue (list ((signal-thunk ref) #t) beh)) (iq-enqueue (list ((signal-thunk ref) #t) beh))
(! man (make-external-event (list (list ((signal-thunk ref) #t) beh)))))) (! man (make-external-event (list (list ((signal-thunk ref) #t) beh))))))
(define-values (undefined undefined?)
(define-values (undefined undefined?) (let ()
(let-values ([(desc make-undefined undefined? acc mut) (define-struct undefined ()
(make-struct-type #:inspector frtime-inspector
'undefined #f 0 0 #f null frtime-inspector #:property prop:procedure (lambda (fn . args) fn))
(lambda (fn . args) fn))])
(values (make-undefined) undefined?))) (values (make-undefined) undefined?)))
(define (behavior? v)
(define (behavior? v)
(and (signal? v) (not (event-set? (signal-value v))))) (and (signal? v) (not (event-set? (signal-value v)))))
(define (undef b) (define (undef b)
(match b (match b
[(and (? signal?) [(and (? signal?)
(= signal-value value)) (app signal-value value))
(set-signal-stale?! b #f) (set-signal-stale?! b #f)
(when (not (undefined? value)) (when (not (undefined? value))
(set-signal-value! b undefined) (set-signal-value! b undefined)
(propagate b))] (propagate b))]
[_ (void)])) [_ (void)]))
(define (multiple->values v)
(define (multiple->values v)
(if (multiple? v) (if (multiple? v)
(apply values (multiple-values v)) (apply values (multiple-values v))
v)) v))
(define (values->multiple proc) (define (values->multiple proc)
(call-with-values (call-with-values
proc proc
(case-lambda (case-lambda
[(v) v] [(v) v]
[vals (make-multiple vals)]))) [vals (make-multiple vals)])))
; value-now : signal[a] -> a ; value-now : signal[a] -> a
(define (value-now val) (define (value-now val)
;(multiple->values ;(multiple->values
(cond (cond
[(signal:compound? val) ((signal:compound-copy val))] [(signal:compound? val) ((signal:compound-copy val))]
@ -318,21 +262,19 @@
[(signal? val) (signal-value val)] [(signal? val) (signal-value val)]
[else val]));) [else val]));)
(define (value-now/no-copy val) (define (value-now/no-copy val)
;(multiple->values ;(multiple->values
(cond (cond
[(signal:switching? val) (value-now/no-copy (unbox (signal:switching-current val)))] [(signal:switching? val) (value-now/no-copy (unbox (signal:switching-current val)))]
[(signal? val) (signal-value val)] [(signal? val) (signal-value val)]
[else val]));) [else val]));)
;; given a list, will return a list of their value-nows that will agree
;; given a list, will return a list of their value-nows that will agree (define (value-now/sync . sigs)
(define (value-now/sync . sigs)
(do-in-manager-after (do-in-manager-after
(apply values (map value-now sigs)))) (apply values (map value-now sigs))))
(define (kill-signal sig)
(define (kill-signal sig)
(for-each (for-each
(lambda (prod) (lambda (prod)
(unregister sig prod)) (unregister sig prod))
@ -342,24 +284,18 @@
(set-signal-dependents! sig empty) (set-signal-dependents! sig empty)
(set-signal-producers! sig empty)) (set-signal-producers! sig empty))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Dataflow Graph Maintenance ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (safe-signal-depth v)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Dataflow Graph Maintenance ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (safe-signal-depth v)
(cond (cond
[(signal? v) (signal-depth v)] [(signal? v) (signal-depth v)]
[(non-scheduled? v) (signal-depth (non-scheduled-signal v))] [(non-scheduled? v) (signal-depth (non-scheduled-signal v))]
[0])) [else 0]))
(define fix-depths
(define fix-depths (lambda (inf sup [mem empty])
(opt-lambda (inf sup [mem empty])
(if (memq sup mem) (if (memq sup mem)
(send-event exceptions (list (make-exn:fail "tight cycle in dataflow graph" (signal-continuation-marks sup)) (send-event exceptions (list (make-exn:fail "tight cycle in dataflow graph" (signal-continuation-marks sup))
sup)) sup))
@ -371,12 +307,11 @@
(foldl (lambda (wb acc) (foldl (lambda (wb acc)
(match (weak-box-value wb) (match (weak-box-value wb)
[(and sig (? signal?)) (cons sig acc)] [(and sig (? signal?)) (cons sig acc)]
[(and (? non-scheduled?) (= non-scheduled-signal sig)) (cons sig acc)] [(and (? non-scheduled?) (app non-scheduled-signal sig)) (cons sig acc)]
[_ acc])) [_ acc]))
empty (signal-dependents inf))))))) empty (signal-dependents inf)))))))
(define-values (iq-enqueue iq-dequeue iq-empty? iq-resort)
(define-values (iq-enqueue iq-dequeue iq-empty? iq-resort)
(let* ([depth (let* ([depth
(lambda (msg) (lambda (msg)
(let ([msg (if (weak-box? msg) (weak-box-value msg) msg)]) (let ([msg (if (weak-box? msg) (weak-box-value msg) msg)])
@ -402,34 +337,27 @@
(loop (rest elts)))) (loop (rest elts))))
(loop (cons (heap-pop heap) elts)))))))) (loop (cons (heap-pop heap) elts))))))))
(define-values (alarms-enqueue alarms-dequeue-beh alarms-peak-ms alarms-empty?) (define-values (alarms-enqueue alarms-dequeue-beh alarms-peak-ms alarms-empty?)
(let ([heap (make-heap (lambda (a b) (< (first a) (first b))) eq?)]) (let ([heap (make-heap (lambda (a b) (< (first a) (first b))) eq?)])
(values (lambda (ms beh) (heap-insert heap (list ms (make-weak-box beh)))) (values (lambda (ms beh) (heap-insert heap (list ms (make-weak-box beh))))
(lambda () (match (heap-pop heap) [(_ beh) (weak-box-value beh)])) (lambda () (match (heap-pop heap) [(list _ beh) (weak-box-value beh)]))
(lambda () (match (heap-peak heap) [(ms _) ms])) (lambda () (match (heap-peak heap) [(list ms _) ms]))
(lambda () (heap-empty? heap))))) (lambda () (heap-empty? heap)))))
(define (schedule-alarm ms beh) (define (schedule-alarm ms beh)
(if (eq? (self) man) (if (eq? (self) man)
(alarms-enqueue ms beh) (alarms-enqueue ms beh)
(! man (make-alarm ms beh)))) (! man (make-alarm ms beh))))
;;;;;;;;;;;;;;;;;;;;;
;; Manager Helpers ;;
;;;;;;;;;;;;;;;;;;;;;
(define man?
(lambda ([v (self)])
;;;;;;;;;;;;;;;;;;;;;
;; Manager Helpers ;;
;;;;;;;;;;;;;;;;;;;;;
(define man?
(opt-lambda ([v (self)])
(eq? v man))) (eq? v man)))
(define-syntax do-in-manager
(define-syntax do-in-manager
(syntax-rules () (syntax-rules ()
[(_ expr ...) [(_ expr ...)
(if (man?) (if (man?)
@ -444,7 +372,7 @@
(receive [(list-rest 'vals vs) (apply values vs)] (receive [(list-rest 'vals vs) (apply values vs)]
[(list 'exn e) (raise e)])))])) [(list 'exn e) (raise e)])))]))
(define-syntax do-in-manager-after (define-syntax do-in-manager-after
(syntax-rules () (syntax-rules ()
[(_ expr ...) [(_ expr ...)
(if (man?) (if (man?)
@ -459,11 +387,11 @@
(receive [(list-rest 'vals vs) (apply values vs)] (receive [(list-rest 'vals vs) (apply values vs)]
[(list 'exn e) (raise e)])))])) [(list 'exn e) (raise e)])))]))
(define (register inf sup) (define (register inf sup)
(do-in-manager (do-in-manager
(match sup (match sup
[(and (? signal?) [(and (? signal?)
(= signal-dependents dependents)) (app signal-dependents dependents))
(set-signal-dependents! (set-signal-dependents!
sup sup
(cons (make-weak-box inf) dependents)) (cons (make-weak-box inf) dependents))
@ -472,11 +400,11 @@
[_ (void)]) [_ (void)])
inf)) inf))
(define (unregister inf sup) (define (unregister inf sup)
(do-in-manager (do-in-manager
(match sup (match sup
[(and (? signal?) [(and (? signal?)
(= signal-dependents dependents)) (app signal-dependents dependents))
(set-signal-dependents! (set-signal-dependents!
sup sup
(filter (lambda (a) (filter (lambda (a)
@ -486,7 +414,7 @@
dependents))] dependents))]
[_ (void)]))) [_ (void)])))
(define (cust-killall! cust) (define (cust-killall! cust)
(let loop ([sigs (ft-cust-constructed-sigs cust)]) (let loop ([sigs (ft-cust-constructed-sigs cust)])
(when (cons? sigs) (when (cons? sigs)
(cond (cond
@ -495,7 +423,7 @@
(loop (rest sigs)))) (loop (rest sigs))))
(for-each cust-killall! (ft-cust-children cust))) (for-each cust-killall! (ft-cust-children cust)))
(define (super-lift fun bhvr) (define (super-lift fun bhvr)
(if (behavior? bhvr) (if (behavior? bhvr)
(parameterize ([extra-cont-marks (parameterize ([extra-cont-marks
(effective-continuation-marks)]) (effective-continuation-marks)])
@ -531,14 +459,14 @@
rtn)))) rtn))))
(fun bhvr))) (fun bhvr)))
(define (propagate b) (define (propagate b)
(let ([empty-boxes 0] (let ([empty-boxes 0]
[dependents (signal-dependents b)] [dependents (signal-dependents b)]
[depth (signal-depth b)]) [depth (signal-depth b)])
(for-each (for-each
(lambda (wb) (lambda (wb)
(match (weak-box-value wb) (match (weak-box-value wb)
[(and dep (? signal?) (= signal-stale? #f)) [(and dep (? signal?) (app signal-stale? #f))
(set-signal-stale?! dep #t) (set-signal-stale?! dep #t)
; If I'm crossing a "back" edge (one potentially causing a cycle), ; If I'm crossing a "back" edge (one potentially causing a cycle),
; then I send a message. Otherwise, I add to the internal ; then I send a message. Otherwise, I add to the internal
@ -554,12 +482,12 @@
b b
(filter weak-box-value dependents))))) (filter weak-box-value dependents)))))
(define (update0 b) (define (update0 b)
(match b (match b
[(and (? signal?) [(and (? signal?)
(= signal-value value) (app signal-value value)
(= signal-thunk thunk) (app signal-thunk thunk)
(= signal-parameterization params)) (app signal-parameterization params))
(set-signal-stale?! b #f) (set-signal-stale?! b #f)
(let ([new-value (call-with-parameterization (let ([new-value (call-with-parameterization
params params
@ -573,11 +501,11 @@
(propagate b))))] (propagate b))))]
[_ (void)])) [_ (void)]))
(define (update1 b a) (define (update1 b a)
(match b (match b
[(and (? signal?) [(and (? signal?)
(= signal-value value) (app signal-value value)
(= signal-thunk thunk)) (app signal-thunk thunk))
(set-signal-stale?! b #f) (set-signal-stale?! b #f)
(let ([new-value (thunk a)]) (let ([new-value (thunk a)])
(when (not (equal? value new-value)) (when (not (equal? value new-value))
@ -585,29 +513,29 @@
(propagate b)))] (propagate b)))]
[_ (void)])) [_ (void)]))
(define (signal-count) (define (signal-count)
(! man `(stat ,(self))) (! man `(stat ,(self)))
(receive [n n])) (receive [n n]))
(define (hash-table-size ht) (define (hash-table-size ht)
(let ([x 0]) (let ([x 0])
(hash-table-for-each ht (lambda (k v) (hash-for-each ht (lambda (k v)
(if k (set! x (add1 x))))) (when k (set! x (add1 x)))))
x)) x))
(define exn-handler (lambda (exn) (raise exn))) (define exn-handler (lambda (exn) (raise exn)))
;;;;;;;;;;;;; ;;;;;;;;;;;;;
;; Manager ;; ;; Manager ;;
;;;;;;;;;;;;; ;;;;;;;;;;;;;
;; the manager of all signals ;; the manager of all signals
(define man (define man
(spawn/name (spawn/name
'frtime-heart 'frtime-heart
(let* ([named-providers (make-hash-table)] (let* ([named-providers (make-hash)]
[cur-beh #f] [cur-beh #f]
[signal-cache (make-hash-table 'weak)] [signal-cache (make-weak-hash)]
[last-known-signal-count 50] [last-known-signal-count 50]
[notifications empty] [notifications empty]
@ -662,7 +590,6 @@
(do-and-queue rtn-pid thunk) (do-and-queue rtn-pid thunk)
(loop))] (loop))]
;; !Experimental! ;; !Experimental!
;; queues thunks to be evaluated after this round of computation, ;; queues thunks to be evaluated after this round of computation,
;; but before the next round ;; but before the next round
@ -672,18 +599,17 @@
(set! thunks-to-run (cons (list rtn-pid thunk) thunks-to-run)) (set! thunks-to-run (cons (list rtn-pid thunk) thunks-to-run))
(loop))] (loop))]
[(list 'stat rtn-pid) [(list 'stat rtn-pid)
(! rtn-pid (hash-table-size signal-cache))] (! rtn-pid (hash-table-size signal-cache))]
[(list 'remote-reg tid sym) [(list 'remote-reg tid sym)
(let ([f+l (hash-table-get named-providers sym)]) (let ([f+l (hash-ref named-providers sym)])
(when (not (member tid (mcdr f+l))) (when (not (member tid (mcdr f+l)))
(set-mcdr! f+l (cons tid (mcdr f+l))))) (set-mcdr! f+l (cons tid (mcdr f+l)))))
(loop)] (loop)]
[(list 'remote-evt sym val) [(list 'remote-evt sym val)
(iq-enqueue (iq-enqueue
(list (hash-table-get named-dependents sym (lambda () dummy)) val)) (list (hash-ref named-dependents sym (lambda () dummy)) val))
(loop)] (loop)]
[msg [msg
(fprintf (current-error-port) (fprintf (current-error-port)
@ -706,18 +632,17 @@
(let loop () (let loop ()
(unless (iq-empty?) (unless (iq-empty?)
(match (iq-dequeue) (match (iq-dequeue)
[(b val) [(list b val)
(set! cur-beh b) (set! cur-beh b)
(update1 b val) (update1 b val)
(set! cur-beh #f)] (set! cur-beh #f)]
[b [b
(set! cur-beh b) (set! cur-beh b)
(update0 b) (update0 b)
(hash-table-get signal-cache b (lambda () (hash-table-put! signal-cache b #t))) (hash-ref signal-cache b (lambda () (hash-set! signal-cache b #t)))
(set! cur-beh #f)]) (set! cur-beh #f)])
(loop))) (loop)))
;; do the run-thunk/stabalized; use existing notification mechanism ;; do the run-thunk/stabalized; use existing notification mechanism
(for-each (lambda (pair) (for-each (lambda (pair)
(do-and-queue (first pair) (second pair))) (do-and-queue (first pair) (second pair)))
@ -735,9 +660,70 @@
(inner))))))) (inner)))))))
(define exceptions (define exceptions (event-receiver))
(event-receiver))
(define dummy (proc->signal void)) (define dummy (proc->signal void))
(provide (all-defined))) (provide do-in-manager
do-in-manager-after)
(define thunk/c
(unconstrained-domain-> any/c)) ; XXX Not really thunk
(define producers/c
(listof any/c)) ; XXX bad
(define switching-current/c
(box/c any/c)) ; XXX
(define switching-trigger/c
any/c)
(provide/contract
; Event Sets
[make-events-now ((listof any/c) . -> . event-set?)] ; XXX Ugly contract
[event-set? (any/c . -> . boolean?)]
[event-set-time (event-set? . -> . number?)]
[event-set-events (event-set? . -> . (listof any/c))] ; XXX Ugly contract
; Undefined
[undefined undefined?]
[undefined? (any/c . -> . boolean?)]
; Signals
[proc->signal ((thunk/c) () #:rest producers/c . ->* . signal?)]
[signal? (any/c . -> . boolean?)]
[signal-value (signal? . -> . any/c)]
[set-signal-value! (signal? any/c . -> . void)]
[signal-depth (signal? . -> . exact-nonnegative-integer?)]
[set-signal-depth! (signal? exact-nonnegative-integer? . -> . void)]
[set-signal-producers! (signal? producers/c . -> . void)]
[signal-thunk (signal? . -> . thunk/c)]
[set-signal-thunk! (signal? thunk/c . -> . void)]
[signal-count (-> exact-nonnegative-integer?)]
; Signal : Compound
[signal:compound? (any/c . -> . boolean?)]
[signal:compound-content (signal:compound? . -> . cons?)] ; XXX Ugly contract on codomain
; Signal : Switching
[proc->signal:switching ((thunk/c switching-current/c switching-trigger/c) () #:rest producers/c . ->* . signal:switching?)]
[signal:switching? (any/c . -> . boolean?)]
[signal:switching-current (signal:switching? . -> . switching-current/c)]
[signal:switching-trigger (signal:switching? . -> . switching-trigger/c)]
; Input queue
[iq-enqueue (any/c . -> . void)] ; XXX Not sure what any/c should be
[iq-resort (-> void)]
; Events
[send-event (signal? any/c . -> . void)]
[send-synchronous-event (signal? any/c . -> . void)]
[send-synchronous-events ((listof (cons/c signal? (listof any/c))) . -> . void)]
[event-receiver (-> signal?)]
[event-producer2 ((thunk/c) () #:rest producers/c . ->* . signal?)]
; Other
[register (signal? any/c . -> . void)] ; XXX Ugly contract
[unregister (signal? any/c . -> . void)] ; XXX Ugly contract
[current-logical-time (-> exact-nonnegative-integer?)]
[snap? (parameter/c boolean?)]
[super-lift ((any/c . -> . any/c) any/c . -> . any/c)] ; XXX Ugly contract
[behavior? (any/c . -> . boolean?)]
[value-now (any/c . -> . any/c)] ; XXX Should this return (not/c signal?) and why not take signal?
[value-now/sync (() () #:rest (listof any/c) . ->* . any)] ; XXX See above + not matching number of values returned with number of signals
[value-now/no-copy (any/c . -> . any/c)] ; XXX Should this return (not/c signal?) and why not take signal?
[safe-signal-depth (any/c . -> . exact-nonnegative-integer?)] ; XXX Ugly contract
[schedule-alarm (number? signal? . -> . void)]
[set-cell! (signal? any/c . -> . void)] ; XXX What is any/c?
[exceptions signal?])