From 27f8c39681252c5bbb116c53040852b864fa13ec Mon Sep 17 00:00:00 2001
From: Greg Cooper <greg@cs.brown.edu>
Date: Sat, 22 Mar 2008 03:12:10 +0000
Subject: [PATCH] fix signal leakage, add support for #lang frtime

svn: r9061
---
 collects/frtime/etc.ss         |  2 +-
 collects/frtime/frp-core.ss    | 19 ++++++++++++++-----
 collects/frtime/lang-ext.ss    |  8 ++++----
 collects/frtime/lang.ss        | 22 ++++++++++++++++++++++
 collects/frtime/lang/reader.ss |  2 ++
 collects/frtime/list.ss        |  2 +-
 6 files changed, 44 insertions(+), 11 deletions(-)
 create mode 100644 collects/frtime/lang.ss
 create mode 100644 collects/frtime/lang/reader.ss

diff --git a/collects/frtime/etc.ss b/collects/frtime/etc.ss
index 2ba40cd31e..69774ca991 100644
--- a/collects/frtime/etc.ss
+++ b/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
diff --git a/collects/frtime/frp-core.ss b/collects/frtime/frp-core.ss
index af3bbf3fd1..c0e7e749da 100644
--- a/collects/frtime/frp-core.ss
+++ b/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
diff --git a/collects/frtime/lang-ext.ss b/collects/frtime/lang-ext.ss
index be0dfd489b..1abc084040 100644
--- a/collects/frtime/lang-ext.ss
+++ b/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 ()
diff --git a/collects/frtime/lang.ss b/collects/frtime/lang.ss
new file mode 100644
index 0000000000..c26a239a38
--- /dev/null
+++ b/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)))
diff --git a/collects/frtime/lang/reader.ss b/collects/frtime/lang/reader.ss
new file mode 100644
index 0000000000..695ef177de
--- /dev/null
+++ b/collects/frtime/lang/reader.ss
@@ -0,0 +1,2 @@
+(module reader syntax/module-reader
+  frtime)
diff --git a/collects/frtime/list.ss b/collects/frtime/list.ss
index ad55fbb4a9..7a3b4bce9c 100644
--- a/collects/frtime/list.ss
+++ b/collects/frtime/list.ss
@@ -1,4 +1,4 @@
-(module list "frtime.ss"
+(module list frtime
   
   (require (lifted mzlib/list sort
                    fifth sixth seventh eighth