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

fixed quadratic performance problem in switches

Browse Source 
svn: r5426
This commit is contained in:
Greg Cooper 2007-01-22 05:14:23 +00:00
parent 5fa4e9e5d1
commit ecd97933e6
1 changed files with 48 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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