From: Christopher Allan Webber <cwebber@dustycloud.org>
Date: Wed, 28 Dec 2016 16:33:19 +0000 (-0600)
Subject: agenda: Fix prompt buildup in agenda.
X-Git-Tag: v0.4.0~45
X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=8f95d94e4963d0c61a9435a078f2b6496e31c7cf;p=8sync.git

agenda: Fix prompt buildup in agenda.

Every time a delimited continuation was resumed, we were re-parameterizing.

* 8sync/agenda.scm (current-agenda-prompt): Remove.
(8sync-abort-to-prompt): Use (%current-agenda-prompt) parameter.
(%current-agenda-prompt): New prompt, deprecating %current-agenda.  This
is a slight optimization; we were only using the agenda for the prompt,
so we can remove the indirection of looking up the agenda prompt tag
every time.
(%current-agenda): Removed, see above.
(start-agenda): Move parameterization of %current-agenda-prompt,
current-read-waiter, and current-write-waiter here.
(agenda-run-once!): Remove parameterization.
Also remove comment which is irrelevant now that we're no longer using
an immutable-record-type on the agenda.
---

diff --git a/8sync/agenda.scm b/8sync/agenda.scm
index 0aaae25..c177dd2 100644
--- a/8sync/agenda.scm
+++ b/8sync/agenda.scm
@@ -61,7 +61,7 @@
 
             stop-on-nothing-to-do
 
-            %current-agenda
+            %current-agenda-prompt
             start-agenda agenda-run-once))
 
 
@@ -118,15 +118,6 @@ Generally done automatically for the user through (make-agenda)."
                       read-port-map write-port-map
                       schedule catch-handler pre-unwind-handler))
 
-(define (current-agenda-prompt)
-  "Get the prompt for the current agenda; signal an error if there isn't one."
-  (let ((current-agenda (%current-agenda)))
-    (if (not current-agenda)
-        (throw
-         'no-current-agenda
-         "Can't get current agenda prompt if there's no current agenda!")
-        (agenda-prompt-tag current-agenda))))
-
 ;; helper for making queues for an agenda
 (define (list->q lst)
   "Makes a queue composed of LST items"
@@ -365,7 +356,7 @@ Will produce (0 . 0) instead of a negative number, if needed."
 ;;; =================================
 
 (define-syntax-rule (8sync-abort-to-prompt async-request)
-  (abort-to-prompt (current-agenda-prompt)
+  (abort-to-prompt (%current-agenda-prompt)
                    async-request))
 
 ;; Async port request and run-request meta-requests
@@ -440,7 +431,7 @@ forge ahead in our current function!"
 ;;; Execution of agenda, and current agenda
 ;;; =======================================
 
-(define %current-agenda (make-parameter #f))
+(define %current-agenda-prompt (make-parameter #f))
 
 (define (update-agenda-from-select! agenda)
   "Potentially (select) on ports specified in agenda, adding items to queue.
@@ -562,16 +553,19 @@ on suspendable ports."
   ;; TODO: Document fields
   "Start up the AGENDA"
   (install-suspendable-ports!)
-  (while (not (stop-condition agenda))
-    (agenda-run-once! agenda)
-    (update-agenda-from-select! agenda)
-    ;; Update the agenda's current queue based on
-    ;; currently applicable time segments
-    (add-segments-contents-to-queue!
-     (schedule-extract-until! (agenda-schedule agenda) (gettimeofday))
-     (agenda-queue agenda))
-    (if post-run-hook
-        (post-run-hook agenda)))
+  (parameterize ((%current-agenda-prompt (agenda-prompt-tag agenda))
+                 ;; @@: Couldn't we just parameterize this at the start of
+                 ;;   the agenda...?
+                 (current-read-waiter wait-for-readable)
+                 (current-write-waiter wait-for-writable))
+    (while (not (stop-condition agenda))
+      (agenda-run-once! agenda)
+      (update-agenda-from-select! agenda)
+      (add-segments-contents-to-queue!
+       (schedule-extract-until! (agenda-schedule agenda) (gettimeofday))
+       (agenda-queue agenda))
+      (if post-run-hook
+          (post-run-hook agenda))))
   'done)
 
 (define (print-error-and-continue key . args)
@@ -628,15 +622,10 @@ based on the results"
     (call-with-prompt
      (agenda-prompt-tag agenda)
      (lambda ()
-       (parameterize ((%current-agenda agenda)
-                      ;; @@: Couldn't we just parameterize this at the start of
-                      ;;   the agenda...?
-                      (current-read-waiter wait-for-readable)
-                      (current-write-waiter wait-for-writable))
-         (maybe-catch-all
-          ((agenda-catch-handler agenda)
-           (agenda-pre-unwind-handler agenda))
-          (proc))))
+       (maybe-catch-all
+        ((agenda-catch-handler agenda)
+         (agenda-pre-unwind-handler agenda))
+        (proc)))
      (lambda (kont async-request)
        (setup-async-request kont async-request))))
 
@@ -672,7 +661,4 @@ based on the results"
           ((results ...)
            (for-each handle-individual results))
           (one-result (handle-individual one-result)))))
-    ;; TODO: Alternately, we could return the next-queue
-    ;;   along with changes to be added to the schedule here?
-    ;; Return new agenda, with next queue set
     (set-agenda-queue! agenda next-queue)))