X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Fagenda.scm;h=b41500dec5f502ce6a2d6188f3a2ceb4b056bbe7;hp=28df8bec25346049833528985823a2ee5333f7ab;hb=5dc2dceda9fab1eb92295989e8e8940fbd56a12c;hpb=d9fdd576a7c1b72999845f86d3cc38a8e6053c49 diff --git a/8sync/agenda.scm b/8sync/agenda.scm index 28df8be..b41500d 100644 --- a/8sync/agenda.scm +++ b/8sync/agenda.scm @@ -60,13 +60,9 @@ run-it wrap wrap-apply run run-at run-delay - 8sync 8sync-delay - 8sync-run 8sync-run-at 8sync-run-delay - 8sync-nowait - 8sleep + 8sync + 8sleep 8usleep - catch-8sync - ;; used for introspecting the error, but a method for making ;; is not exposed wrapped-exception? @@ -80,8 +76,6 @@ %current-agenda start-agenda agenda-run-once)) -(install-suspendable-ports!) - ;; @@: Using immutable agendas here, so wouldn't it make sense to ;; replace this queue stuff with using pfds based immutable queues? @@ -461,85 +455,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 +466,36 @@ 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 secs) + "Like sleep, but asynchronous." + (8sync-abort-to-prompt + (make-async-request + (lambda (kont) + (make-run-request (lambda () (kont #f)) (tdelta secs)))))) + +(define (8usleep usecs) + "Like usleep, but asynchronous." + (define (usecs->time-pair) + (if (< 1000000) + (cons 0 usecs) + (let* ((sec (floor (/ usecs 1000000))) + (msec (- usecs (* sec 1000000)))) + (cons sec msec)))) + (8sync-abort-to-prompt + (make-async-request + (lambda (kont) + (make-run-request (lambda () (kont #f)) (tdelta usecs->time-pair)))))) +;; 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 @@ -700,6 +627,7 @@ on suspendable ports." (post-run-hook #f)) ;; TODO: Document fields "Start up the AGENDA" + (install-suspendable-ports!) (let loop ((agenda agenda)) (let ((agenda ;; @@: Hm, maybe here would be a great place to handle @@ -829,7 +757,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