X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Fagenda.scm;h=118bb28d9a53374af007ab0826e08c30b0e4b29f;hp=f22134d0157ca1c01ff1d806922657a8a906cf02;hb=ad2cc60c709045ba78a7957b149be86b4a21b49c;hpb=64099f71e0d685260289229a599a753923d2dc8f diff --git a/8sync/agenda.scm b/8sync/agenda.scm index f22134d..118bb28 100644 --- a/8sync/agenda.scm +++ b/8sync/agenda.scm @@ -27,7 +27,7 @@ #:export ( make-agenda agenda? agenda-queue agenda-prompt-tag - agenda-read-port-map agenda-write-port-map agenda-except-port-map + agenda-read-port-map agenda-write-port-map agenda-schedule make-async-prompt-tag @@ -60,13 +60,11 @@ run-it wrap wrap-apply run run-at run-delay - 8sync 8sync-delay + 8sync-delay 8sync-run 8sync-run-at 8sync-run-delay - 8sync-nowait + 8sync 8sleep - catch-8sync - ;; used for introspecting the error, but a method for making ;; is not exposed wrapped-exception? @@ -461,85 +459,7 @@ return the wrong thing via (8sync) and trip themselves up." "Invalid request passed back via an (8sync) procedure." async-request)))) -(define-record-type - (make-wrapped-exception key args stacks) - wrapped-exception? - (key wrapped-exception-key) - (args wrapped-exception-args) - (stacks wrapped-exception-stacks)) - -(define-syntax-rule (propagate-%async-exceptions body) - (let ((body-result body)) - (if (wrapped-exception? body-result) - (throw '8sync-caught-error - (wrapped-exception-key body-result) - (wrapped-exception-args body-result) - (wrapped-exception-stacks body-result)) - body-result))) - -(define-syntax 8sync - (syntax-rules () - "Run BODY asynchronously (8synchronously?) at a prompt, then return. - -Possibly specify WHEN as the second argument." - ((8sync body) - (8sync-run body)) - ((8sync body when) - (8sync-run-at body when)))) - -(define-syntax-rule (8sync-run body ...) - (8sync-run-at body ... #f)) - -(define-syntax-rule (8sync-run-at body ... when) - (propagate-%async-exceptions - (8sync-abort-to-prompt - ;; Send an asynchronous request to apply a continuation to the - ;; following function, then handle that as a request to the agenda - (make-async-request - (lambda (kont) - ;; We're making a run request - (make-run-request - ;; Wrapping the following execution to run... - (wrap - ;; Once we get the result from the inner part, we'll resume - ;; this continuation, but first - ;; @@: Is this running immediately, or queueing the result - ;; after evaluation for the next agenda tick? It looks - ;; like evaluating immediately. Is that what we want? - (kont - ;; Any unhandled errors are caught - (let ((exception-stack #f)) - (catch #t - ;; Run the actual code the user requested - (lambda () - body ...) - ;; If something bad happened and we didn't catch it, - ;; we'll wrap it up in such a way that the continuation - ;; can address it - (lambda (key . args) - (cond - ((eq? key '8sync-caught-error) - (match args - ((orig-key orig-args orig-stacks) - (make-wrapped-exception - orig-key orig-args - (cons exception-stack orig-stacks))))) - (else - (make-wrapped-exception key args - (list exception-stack))))) - (lambda _ - (set! exception-stack (make-stack #t 1 0))))))) - when)))))) - -(define-syntax-rule (8sync-run-delay body ... delay-time) - (8sync-run-at body ... (tdelta delay-time))) - -(define-syntax-rule (8sync-delay args ...) - (8sync-run-delay args ...)) - -;; TODO: Write (%run-immediately) - -(define-syntax-rule (8sync-nowait body) +(define-syntax-rule (8sync body ...) "Run body asynchronously but ignore its result... forge ahead in our current function!" (8sync-abort-to-prompt @@ -550,25 +470,22 @@ forge ahead in our current function!" ;; Otherwise we sometimes get errors like ;; "Zero values returned to single-valued continuation"" (wrap (kont #f)) #f) - (make-run-request (lambda () body) #f)))))) - -(define-syntax-rule (catch-8sync exp (handler-key handler) ...) - (catch '8sync-caught-error - (lambda () - exp) - (lambda (_ orig-key orig-args orig-stacks) - (cond - ((or (eq? handler-key #t) - (eq? orig-key handler-key)) - (apply handler orig-stacks orig-args)) ... - (else (raise '8sync-caught-error - orig-key orig-args orig-stacks)))))) - -;; This is sugar... and could probably be considerably -;; simplified and optimized. But whatever. -(define-syntax-rule (8sleep time) - (8sync-delay 'no-op time)) + (make-run-request (lambda () body ...) #f)))))) + +;; TODO: Rewrite when we move to this being just `sleep'. +(define (8sleep time) + (8sync-abort-to-prompt + (make-async-request + (lambda (kont) + (make-run-request (lambda () (kont #f)) (tdelta time)))))) +;; Voluntarily yield execution +(define (yield) ; @@: should this be define-inlinable? + "Voluntarily yield execution to the scheduler." + (8sync-abort-to-prompt + (make-async-request + (lambda (kont) + (make-run-request (lambda () (kont #f)) #f))))) ;;; Execution of agenda, and current agenda @@ -650,8 +567,7 @@ Also handles sleeping when all we have to do is wait on the schedule." (selector agenda)) 0))) (or (has-items? agenda-read-port-map) - (has-items? agenda-write-port-map) - (has-items? agenda-except-port-map))) + (has-items? agenda-write-port-map))) (if (or (ports-to-select?) ;; select doubles as sleep... @@ -768,14 +684,12 @@ on suspendable ports." (begin body ...))) (define (wait-for-readable port) - (display "Waiting to read\n") (8sync-abort-to-prompt (make-async-request (lambda (kont) (make-read-request port (wrap (kont #f))))))) (define (wait-for-writable port) - (display "Waiting to write\n") (8sync-abort-to-prompt (make-async-request (lambda (kont) @@ -832,7 +746,10 @@ based on the results" ((? write-request? write-request) (agenda-handle-write-request! agenda write-request)) ;; do nothing - ;; @@: Why not throw an error? + ;; Remember, we don't throw an error here because procedures can + ;; return a run request, eg with run-it, at the end of their + ;; evaluation to keep looping. + ;; @@: Though is this really a useful feature? (_ #f))) ;; @@: We might support delay-wrapped procedures here (match proc-result