Attempts to improve the timing code when interacting with select

(but it's still pretty messed up...)

diff --git a/loopy.scm b/loopy.scm
index f346a9e1a61bb95b992edc3b6116087d9cb83147..ee1bc8121319943f49271b47b17e495ac92821de 100644 (file)
--- a/loopy.scm
+++ b/loopy.scm
@@ -17,7 +17,8 @@
             make-time-segment time-segment?
             time-segment-time time-segment-queue
 
-            time-< time-= time-<= time-+
+            time< time= time<= time-delta+
+            time-minus time-plus
 
             <time-delta>
             make-time-delta tdelta time-delta?
@@ -119,7 +120,7 @@
 (define* (make-time-segment time #:optional (queue (make-q)))
   (make-time-segment-intern time queue))
 
-(define (time-< time1 time2)
+(define (time< time1 time2)
   (cond ((< (car time1)
             (car time2))
          #t)
@@ -130,13 +131,13 @@
          #t)
         (else #f)))
 
-(define (time-= time1 time2)
+(define (time= time1 time2)
   (and (= (car time1) (car time2))
        (= (cdr time1) (cdr time2))))
 
-(define (time-<= time1 time2)
-  (or (time-< time1 time2)
-      (time-= time1 time2)))
+(define (time<= time1 time2)
+  (or (time< time1 time2)
+      (time= time1 time2)))
 
 
 (define-record-type <time-delta>
@@ -150,9 +151,35 @@
 
 (define tdelta make-time-delta)
 
-(define (time-+ time time-delta)
-  (cons (+ (car time) (time-delta-sec time-delta))
-        (+ (cdr time) (time-delta-usec time-delta))))
+(define (time-carry-correct time)
+  "Corrects/handles time microsecond carry.
+Will produce (0 . 0) instead of a negative number, if needed."
+  (cond ((>= (cdr time) 1000000)
+         (cons
+          (+ (car time) 1)
+          (- (cdr time) 1000000)))
+        ((< (cdr time) 0)
+         (if (= (car time) 0)
+             '(0 0)
+             (cons
+              (- (car time) 1)
+              (+ (cdr time) 1000000))))
+        (else time)))
+
+(define (time-delta+ time time-delta)
+  (time-carry-correct
+   (cons (+ (car time) (time-delta-sec time-delta))
+         (+ (cdr time) (time-delta-usec time-delta)))))
+
+(define (time-minus time1 time2)
+  (time-carry-correct
+   (cons (- (car time1) (car time2))
+         (- (car time2) (cdr time2)))))
+
+(define (time-plus time1 time2)
+  (time-carry-correct
+   (cons (+ (car time1) (car time2))
+         (+ (car time2) (cdr time2)))))
 
 
 (define-record-type <schedule>
@@ -183,10 +210,10 @@
         new-segment))
     (define (loop segments)
       (define (segment-equals-time? segment)
-        (time-= time (time-segment-time segment)))
+        (time= time (time-segment-time segment)))
 
       (define (segment-more-than-time? segment)
-        (time-< time (time-segment-time segment)))
+        (time< time (time-segment-time segment)))
 
       ;; We could switch this out to be more mutate'y
       ;; and avoid the O(n) of space... is that over-optimizing?
@@ -218,9 +245,9 @@
   "Does a multiple value return of time segments before/at and after TIME"
   (let ((time (time-segment-right-format time)))
     (define (segment-is-now? segment)
-      (time-= (time-segment-time segment) time))
+      (time= (time-segment-time segment) time))
     (define (segment-is-before-now? segment)
-      (time-< (time-segment-time segment) time))
+      (time< (time-segment-time segment) time))
 
     (let loop ((segments-before '())
                (segments-left (schedule-segments schedule)))
@@ -326,26 +353,24 @@
     (let ((soonest-time (schedule-soonest-time (agenda-schedule agenda))))
       (cond 
        ((not (q-empty? (agenda-queue agenda)))
-        (values 0 0))
+        (cons 0 0))
        (soonest-time    ; ie, the agenda is non-empty
         (let* ((current-time (agenda-time agenda)))
-          (if (time-<= soonest-time current-time)
+          (if (time<= (pk 'soonest-time soonest-time) (pk 'current-time current-time))
               ;; Well there's something due so let's select
               ;; (this avoids a (possible?) race condition chance)
-              (values 0 0)
-              (values
-               (- (car soonest-time) (car current-time))
-               (- (cdr soonest-time) (cdr current-time))))))
+              (cons 0 0)
+              (pk 'time-minus (time-minus soonest-time current-time)))))
        (else
-        (values #f #f)))))
+        (cons #f #f)))))
   (define (do-select)
     ;; TODO: support usecond wait time too
-    (receive (sec usec)
-        (get-wait-time)
-      (select (hash-keys (agenda-read-port-map agenda))
-              (hash-keys (agenda-write-port-map agenda))
-              (hash-keys (agenda-except-port-map agenda))
-              sec usec)))
+    (match (get-wait-time)
+      ((sec . usec)
+       (select (hash-keys (agenda-read-port-map agenda))
+               (hash-keys (agenda-write-port-map agenda))
+               (hash-keys (agenda-except-port-map agenda))
+               sec usec))))
   (define (get-procs-to-run)
     (define (ports->procs ports port-map)
       (lambda (initial-procs)
@@ -444,8 +469,8 @@ based on the results"
                 (let ((request-time (run-request-when run-request)))
                   (match request-time
                     ((? time-delta? time-delta)
-                     (let ((time (time-+ (agenda-time agenda)
-                                         time-delta)))
+                     (let ((time (time-delta+ (agenda-time agenda)
+                                              time-delta)))
                        (schedule-at! time (run-request-proc run-request))))
                     ((? integer? sec)
                      (let ((time (cons sec 0)))

diff --git a/tests.scm b/tests.scm
index a958ea247bd8ff0d4c2fa6203ec1fab51d35c536..0843fb4b8ab484d475b33cf9f3895fa71b7bfea5 100644 (file)
--- a/tests.scm
+++ b/tests.scm
@@ -14,22 +14,22 @@
 ;; Timer tests
 ;; ===========
 
-(test-assert (time-= '(1 . 1) '(1 . 1)))
-(test-assert (not (time-= '(1 . 1) '(1 . 0))))
-(test-assert (not (time-= '(0 . 1) '(1 . 1))))
+(test-assert (time= '(1 . 1) '(1 . 1)))
+(test-assert (not (time= '(1 . 1) '(1 . 0))))
+(test-assert (not (time= '(0 . 1) '(1 . 1))))
 
-(test-assert (time-< '(1 . 1) '(1 . 2)))
-(test-assert (time-< '(7 . 2) '(8 . 2)))
-(test-assert (not (time-< '(7 . 2) '(7 . 2))))
-(test-assert (not (time-< '(7 . 8) '(7 . 2))))
-(test-assert (not (time-< '(8 . 2) '(7 . 2))))
+(test-assert (time< '(1 . 1) '(1 . 2)))
+(test-assert (time< '(7 . 2) '(8 . 2)))
+(test-assert (not (time< '(7 . 2) '(7 . 2))))
+(test-assert (not (time< '(7 . 8) '(7 . 2))))
+(test-assert (not (time< '(8 . 2) '(7 . 2))))
 
 (let ((tdelta (make-time-delta 8)))
   (test-assert (time-delta? tdelta))
   (test-eqv (time-delta-sec tdelta) 8)
   (test-eqv (time-delta-usec tdelta) 0)
   (test-equal
-      (time-+ '(2 . 3) tdelta)
+      (time-delta+ '(2 . 3) tdelta)
     '(10 . 3)))
 
 (let ((tdelta (make-time-delta 10 1)))
@@ -37,7 +37,7 @@
   (test-eqv (time-delta-sec tdelta) 10)
   (test-eqv (time-delta-usec tdelta) 1)
   (test-equal
-      (time-+ '(2 . 3) tdelta)
+      (time-delta+ '(2 . 3) tdelta)
     '(12 . 4)))