X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Fagenda.scm;h=4a126a4e1fddbcf140748f62b7b9861f7d5e03e2;hp=e35cd8efe538cb38abd54acfb4614c07aa738250;hb=2255f6996a4fbe708b235760816a6dd49959fb6d;hpb=b387687cfe0aea2f5461bb211b627ce072364ad4 diff --git a/8sync/agenda.scm b/8sync/agenda.scm index e35cd8e..4a126a4 100644 --- a/8sync/agenda.scm +++ b/8sync/agenda.scm @@ -49,7 +49,7 @@ run-it wrap wrap-apply run run-at run-delay 8sync - 8sleep 8usleep + 8sleep 8yield ;; used for introspecting the error, but a method for making ;; is not exposed @@ -61,8 +61,8 @@ stop-on-nothing-to-do - %current-agenda - start-agenda agenda-run-once)) + %current-agenda-prompt + run-agenda agenda-run-once!)) ;;; Agenda definition @@ -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" @@ -359,13 +350,23 @@ Will produce (0 . 0) instead of a negative number, if needed." "Run BODY at DELAY-TIME time from now" (make-run-request (wrap body ...) (delayed-time delay-time))) +;;; Procedures that are delimited continuations being resumed are +;;; wrapped in a . This is so that we don't accidentally +;;; wrap in another catch statement every time we resume them, which +;;; would be a drag. + +(define-record-type + (kontinue kont) + kontinue? + (kont kontinue-kont)) + ;;; Asynchronous escape to run things ;;; ================================= (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 @@ -394,10 +395,7 @@ forge ahead in our current function!" (make-async-request (lambda (kont) (list (make-run-request - ;; What's with returning #f to kont? - ;; Otherwise we sometimes get errors like - ;; "Zero values returned to single-valued continuation"" - (wrap (kont #f)) #f) + (kontinue kont) #f) (make-run-request (lambda () body ...) #f)))))) (define (delayed-time in-secs) @@ -426,21 +424,21 @@ forge ahead in our current function!" (8sync-abort-to-prompt (make-async-request (lambda (kont) - (make-run-request (lambda () (kont #f)) (delayed-time secs)))))) + (make-run-request (kontinue kont) (delayed-time secs)))))) ;; Voluntarily yield execution -(define (yield) ; @@: should this be define-inlinable? +(define (8yield) "Voluntarily yield execution to the scheduler." (8sync-abort-to-prompt (make-async-request (lambda (kont) - (make-run-request (lambda () (kont #f)) #f))))) + (make-run-request (kontinue kont) #f))))) ;;; 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. @@ -555,23 +553,24 @@ on suspendable ports." (= 0 (hash-count (const #t) (agenda-write-port-map agenda))))) -(define* (start-agenda agenda - #:key (stop-condition stop-on-nothing-to-do) - ;; For live hacking madness, etc - (post-run-hook #f)) +(define* (run-agenda agenda + #:key (stop-condition stop-on-nothing-to-do) + ;; For live hacking madness, etc + (post-run-hook #f)) ;; 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)) + (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) @@ -624,19 +623,21 @@ on suspendable ports." (define (agenda-run-once! agenda) "Run once through the agenda, and produce a new agenda based on the results" + ;; @@: Maybe rename proc -> run-this ? (define (call-proc proc) (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)))) + (if (kontinue? proc) + ;; Resume continuation. + ;; We need to pass in #f, otherwise we sometimes get errors like + ;; "Zero values returned to single-valued continuation"" + ((kontinue-kont proc) #f) + ;; Otherwise call the procedure and set up error catching. + (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 +673,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)))