diff --git a/collects/frtime/frp-core.ss b/collects/frtime/frp-core.ss index 0de560d02f..c85082a816 100644 --- a/collects/frtime/frp-core.ss +++ b/collects/frtime/frp-core.ss @@ -107,20 +107,20 @@ (reverse field-name-symbols))) #t))) - (define (signal-custodians sig) + (define (signal-custodian sig) (call-with-parameterization (signal-parameterization sig) - current-custs)) + current-cust)) - (define-struct ft-cust (signal constructed-sigs)) + (define-struct ft-cust (signal constructed-sigs children)) ;(define-struct non-scheduled (signal)) (define make-non-scheduled identity) (define (non-scheduled? x) #f) (define (non-scheduled-signal x) (error 'non-scheduled-signal "should never be called")) - (define current-custs - (make-parameter empty)) + (define current-cust + (make-parameter #f)) (define-struct multiple (values) frtime-inspector) @@ -176,55 +176,53 @@ (define (build-signal ctor thunk producers) (let ([ccm (effective-continuation-marks)]) + ;(printf "*") (do-in-manager - (let* ([custs (current-custs)] - [cust-sigs (map ft-cust-signal custs)] + (let* ([cust (current-cust)] + [cust-sig (and cust (ft-cust-signal cust))] [sig (ctor undefined empty #t thunk - (add1 (apply max 0 (append (map safe-signal-depth producers) - (map safe-signal-depth cust-sigs)))) + (add1 (apply max 0 (cons (safe-signal-depth cust-sig) (map safe-signal-depth producers)))) ccm (parameterize ([uncaught-exception-handler (lambda (exn) (exn-handler exn))] [extra-cont-marks ccm]) (current-parameterization)) - (append cust-sigs producers))]) + (if cust-sig (append producers (list cust-sig)) producers))]) ;(printf "~a custodians~n" (length custs)) (when (cons? producers) (register sig producers)) - (when (cons? cust-sigs) - (register (make-non-scheduled sig) cust-sigs)) - (for-each (lambda (g) (set-ft-cust-constructed-sigs! - g (cons (make-weak-box sig) (ft-cust-constructed-sigs g)))) - custs) + (when cust-sig + (register (make-non-scheduled sig) cust-sig)) + (when cust + (set-ft-cust-constructed-sigs! cust (cons (make-weak-box sig) (ft-cust-constructed-sigs cust)))) (iq-enqueue sig) sig)))) (define (proc->signal:switching thunk current-box trigger . producers) (let ([ccm (effective-continuation-marks)]) (do-in-manager - (let* ([custs (current-custs)] - [cust-sigs (map ft-cust-signal custs)] + (let* ([cust (current-cust)] + [cust-sig (and cust (ft-cust-signal cust))] [sig (make-signal:switching undefined empty #t thunk - (add1 (apply max 0 (append (map safe-signal-depth producers) - (map safe-signal-depth cust-sigs)))) + (add1 (apply max 0 (cons (safe-signal-depth cust-sig) (map safe-signal-depth producers)))) ccm (parameterize ([uncaught-exception-handler (lambda (exn) (exn-handler exn))] [extra-cont-marks ccm]) (current-parameterization)) - (append cust-sigs producers) + (if cust-sig (cons cust-sig producers) producers) current-box trigger)]) ;(printf "~a custodians~n" (length custs)) (when (cons? producers) (register sig producers)) - (when (cons? cust-sigs) - (register (make-non-scheduled sig) cust-sigs)) - (for-each (lambda (g) (set-ft-cust-constructed-sigs! - g (cons (make-weak-box sig) (ft-cust-constructed-sigs g)))) - custs) + (when cust-sig + (register (make-non-scheduled sig) cust-sig)) + (when cust + (set-ft-cust-constructed-sigs! + cust (cons (make-weak-box sig) (ft-cust-constructed-sigs cust)))) (iq-enqueue sig) sig)))) @@ -238,8 +236,8 @@ (define (procs->signal:compound ctor mutate! . args) (let ([ccm (effective-continuation-marks)]) (do-in-manager - (let* ([custs (current-custs)] - [cust-sigs (map ft-cust-signal custs)] + (let* ([cust (current-cust)] + [cust-sig (and cust (ft-cust-signal cust))] [value (apply ctor (map value-now/no-copy args))] #;[mutators (foldl @@ -268,24 +266,22 @@ undefined val))) val))) - (add1 (apply max 0 (append (map safe-signal-depth args) - (map safe-signal-depth cust-sigs)))) + (add1 (apply max 0 (cons (safe-signal-depth cust-sig) (map safe-signal-depth args)))) ccm (parameterize ([uncaught-exception-handler (lambda (exn) (exn-handler exn))] [extra-cont-marks ccm]) (current-parameterization)) - (append cust-sigs args) + (if cust-sig (cons cust-sig args) args) (apply ctor args) (lambda () (apply ctor (map value-now args))))]) ;(printf "mutators = ~a~n" mutators) (when (cons? args) (register sig args)) - (when (cons? cust-sigs) - (register (make-non-scheduled sig) cust-sigs)) - (for-each (lambda (g) (set-ft-cust-constructed-sigs! - g (cons (make-weak-box sig) (ft-cust-constructed-sigs g)))) - custs) + (when cust-sig + (register (make-non-scheduled sig) cust-sig)) + (when cust + (set-ft-cust-constructed-sigs! cust (cons (make-weak-box sig) (ft-cust-constructed-sigs cust)))) (iq-enqueue sig) ;(printf "~n*made a compound [~a]*~n~n" (value-now/no-copy sig)) sig)))) @@ -408,7 +404,7 @@ (set-signal-value! sig 'dead) (set-signal-dependents! sig empty) (set-signal-producers! sig empty) - (for-each + #;(for-each (lambda (c) (set-ft-cust-constructed-sigs! c @@ -612,21 +608,33 @@ dependents))] [_ (void)]))) + (define (cust-killall! cust) + (let loop ([sigs (ft-cust-constructed-sigs cust)]) + (when (cons? sigs) + (cond + [(weak-box-value (first sigs)) => kill-signal] + [else (void)]) + (loop (rest sigs)))) + (for-each cust-killall! (ft-cust-children cust))) + (define (super-lift fun bhvr) (if (behavior? bhvr) (parameterize ([extra-cont-marks (effective-continuation-marks)]) (do-in-manager - (let* ([cust (make-ft-cust (void) empty)] - [custs (cons cust (current-custs))] + (let* ([cust (make-ft-cust (void) empty empty)] + [_ (when (current-cust) (set-ft-cust-children! (current-cust) (cons cust (ft-cust-children (current-cust)))))] [pfun (lambda (b) - (parameterize ([current-custs custs]) + (parameterize ([current-cust cust]) (fun b)))] [current (box undefined)]) (letrec ([custodian-signal (proc->signal:unchanged (lambda () - (for-each kill-signal + (cust-killall! cust) + (set-ft-cust-constructed-sigs! cust empty) + (set-ft-cust-children! cust empty) + #;(for-each kill-signal (filter identity (map weak-box-value (ft-cust-constructed-sigs cust)))) (unregister rtn (unbox current)) @@ -644,7 +652,6 @@ rtn)))) (fun bhvr))) - (define (propagate b) (let ([empty-boxes 0] [dependents (signal-dependents b)]