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
stop-on-nothing-to-do
- %current-agenda
- start-agenda agenda-run-once))
+ %current-agenda-prompt
+ run-agenda agenda-run-once!))
\f
;;; Agenda definition
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"
"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 <kontinue>. 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>
+ (kontinue kont)
+ kontinue?
+ (kont kontinue-kont))
+
\f
;;; 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
(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)
(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)))))
\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.
(= 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)
(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))))
((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)))
projects / 8sync.git / blobdiff