delimcc/async fiber

async_fiber.ml

open Core.Std
open Async.Std

let print_endline = Caml.print_endline

module Fiber : sig
  val start : (unit -> 'a) -> 'a Deferred.t
  val await : 'a Deferred.t -> 'a
end = struct
  let active_prompt = ref None

  let waker () = (* lwt style deferred, is there an easier way? *)
    let ivar = ref None in
    let deferred = Deferred.create @@ fun ivar' -> ivar := Some ivar' in
    (deferred, Ivar.fill @@ Option.value_exn !ivar)

  let start f =
    let p = Delimcc.new_prompt () in
    active_prompt := Some p;
    let deferred, waker = waker () in
    Delimcc.push_prompt p begin fun () ->
      let res = f () in
      active_prompt := None;
      waker res
    end;
    deferred

  let await t =
    let p = match !active_prompt with
      | None -> failwith "await called outside of start"
      | Some p -> p
    in
    match Deferred.peek t with
    | Some t -> t
    | None ->
      active_prompt := None;
      Delimcc.shift0 p begin fun k ->
        let ready _ =
          active_prompt := Some p;
          print_endline "core dumping here";
          k ();
          Deferred.unit
        in don't_wait_for (t >>= ready)
      end;
      match Deferred.peek t with
      | Some v -> v
      | None -> assert false
end

open Fiber

let _ =
  start (fun () ->
      print_endline "started";
      let () = await @@ Clock.after (sec 1.) in
      print_endline "finished")

let () = never_returns @@ Scheduler.go ()