simon/moonpool
1
0
Fork 0
mirror of https://github.com/c-cube/moonpool.git synced 2025-12-06 03:05:30 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

wip: use shallow effect handlers

Browse source 
they still nest though, quite problematic
This commit is contained in:
Simon Cruanes 2024-02-23 20:55:37 -05:00
parent ed171c1171
commit 20e3af82fd
No known key found for this signature in database
GPG key ID: EBFFF6F283F3A2B4
1 changed files with 8 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
src/core/suspend_.ml
View file

@ -34,9 +34,9 @@ type with_suspend_handler =
-> with_suspend_handler
let with_suspend (WSH { on_suspend; run; resume }) (f : unit -> unit) : unit =
let module E = Effect.Deep in
let module E = Effect.Shallow in
(* effect handler *)
let effc : type e. e Effect.t -> ((e, _) E.continuation -> _) option =
let rec effc : type e. e Effect.t -> ((e, _) E.continuation -> _) option =
function
| Suspend h ->
(* TODO: discontinue [k] if current fiber (if any) is cancelled? *)
@ -44,8 +44,8 @@ let with_suspend (WSH { on_suspend; run; resume }) (f : unit -> unit) : unit =
(fun k ->
let state = on_suspend () in
let k' : suspension = function
| Ok () -> E.continue k ()
| Error (exn, bt) -> E.discontinue_with_backtrace k exn bt
| Ok () -> E.continue_with k () handler
| Error (exn, bt) -> E.discontinue_with_backtrace k exn bt handler
in
h.handle ~run:(run state) ~resume:(resume state) k')
| Yield ->
@ -54,14 +54,14 @@ let with_suspend (WSH { on_suspend; run; resume }) (f : unit -> unit) : unit =
(fun k ->
let state = on_suspend () in
let k' : suspension = function
| Ok () -> E.continue k ()
| Error (exn, bt) -> E.discontinue_with_backtrace k exn bt
| Ok () -> E.continue_with k () handler
| Error (exn, bt) -> E.discontinue_with_backtrace k exn bt handler
in
resume state k' @@ Ok ())
| _ -> None
in
and handler = { E.retc = Fun.id; exnc = raise; effc } in
E.try_with f () { E.effc }
E.continue_with (E.fiber f) () handler
(* DLA interop *)
let prepare_for_await () : Dla_.t =