fix signal leakage, add support for #lang frtime

svn: r9061

collects/frtime/etc.ss

@@ -1,5 +1,5 @@
 
-(module etc "frtime.ss"
+(module etc frtime
   (require (lib "main-collects.ss" "setup"))
   (require-for-syntax syntax/kerncase
 		      syntax/stx

collects/frtime/frp-core.ss

@@ -686,6 +686,12 @@
     (! man `(stat ,(self)))
     (receive [n n]))
 
+  (define (hash-table-size ht)
+    (let ([x 0])
+      (hash-table-for-each ht (lambda (k v) 
+                                (if k (set! x (add1 x)))))
+      x))
+
   (define exn-handler (lambda (exn) (raise exn)))
   
   ;;;;;;;;;;;;;
@@ -699,6 +705,7 @@
      (let* ([named-providers (make-hash-table)] 
             [cur-beh #f]
             [signal-cache (make-hash-table 'weak)]
+            [last-known-signal-count 50]
             [notifications empty]
             
             ;; added for run-thunk/stablized
@@ -770,10 +777,7 @@
                         
                         
                         [('stat rtn-pid)
-                         (let ([x 0])
-                           (hash-table-for-each signal-cache (lambda (k v) 
-                                                               (if k (set! x (add1 x)))))
-                           (! rtn-pid x))]
+                         (! rtn-pid (hash-table-size signal-cache))]
                         
                         [('remote-reg tid sym)
                          (let ([f+l (hash-table-get named-providers sym)])
@@ -831,7 +835,12 @@
              (set! thunks-to-run empty)
 
              (set-box! logical-time (add1 (unbox logical-time)))
-             
+             (when (zero? (modulo logical-time 50))
+               (let ([new-signal-count (hash-table-size signal-cache)])
+                 (when (> new-signal-count (* 2 last-known-signal-count))
+                   (collect-garbage)
+                   (set! last-known-signal-count (hash-table-size signal-cache)))))
+
              (inner)))))))
   
   (define exceptions

collects/frtime/lang-ext.ss

@@ -361,7 +361,7 @@
              [head last]
              [producer (proc->signal
                         (lambda ()
-                          (let* ([now (current-inexact-milliseconds)]
+                          (let* ([now (and (behavior? consumer) (current-inexact-milliseconds))]
                                  [ms (value-now ms-b)])
                             (let loop ()
                               (if (or (empty? (mcdr head))
@@ -373,7 +373,7 @@
                                   (begin
                                     (set! head (mcdr head))
                                     (loop)))))))]
-             [consumer (proc->signal/dont-gc-unless producer
+             [consumer (proc->signal
                         (lambda ()
                           (let* ([now (current-inexact-milliseconds)]
                                  [new (deep-value-now beh)]
@@ -398,8 +398,8 @@
                [last-time (current-inexact-milliseconds)]
                [last-val (value-now b)]
                [last-alarm 0]
-               [producer (proc->signal (lambda () accum))]
-               [consumer (proc->signal/dont-gc-unless producer void b ms-b)])
+               [producer (proc->signal (lambda () (and (behavior? consumer) accum)))]
+               [consumer (proc->signal void b ms-b)])
         (set-signal-thunk!
          consumer
          (lambda ()

collects/frtime/lang.ss

@@ -0,0 +1,22 @@
+(module lang frtime/mzscheme-utils
+  (require frtime/lang-ext)
+  (require frtime/ft-qq)
+  (require (as-is:unchecked frtime/frp-core
+	    event-set? signal-value))
+  
+  (define (value-nowable? x)
+    (or (not (signal? x))
+	(not (event-set? (signal-value x)))))
+
+  (define ((behaviorof pred) x)
+    (let ([v (value-now x)])
+      (or (undefined? v)
+          (pred v))))
+
+
+  ;(provide-for-syntax (rename frtime/mzscheme-utils syntax->list syntax->list))
+  
+  (provide value-nowable? behaviorof
+	   (all-from frtime/mzscheme-utils)
+           (all-from-except frtime/lang-ext lift)
+           (all-from frtime/ft-qq)))

collects/frtime/lang/reader.ss

@@ -0,0 +1,2 @@
+(module reader syntax/module-reader
+  frtime)

collects/frtime/list.ss

@@ -1,4 +1,4 @@
-(module list "frtime.ss"
+(module list frtime
   
   (require (lifted mzlib/list sort
                    fifth sixth seventh eighth