feat: depend on picos, use picos.exn_bt

src/core/chan.ml

@@ -175,7 +175,10 @@ let close (self : _ t) : unit =
       if A.compare_and_set self.st old_st St_closed then (
         (* fail all waiters with [Closed]. *)
         let bt = Printexc.get_callstack 10 in
-        Q.iter (fun w -> Fut.fulfill_idempotent w (Error (Closed, bt))) ws;
+        Q.iter
+          (fun w ->
+            Fut.fulfill_idempotent w (Error { Exn_bt.exn = Closed; bt }))
+          ws;
         false
       ) else
         true

src/core/dune

@@ -1,7 +1,7 @@
 (library
  (public_name moonpool)
  (name moonpool)
- (libraries moonpool.private moonpool.dpool)
+ (libraries moonpool.private moonpool.dpool picos.exn_bt picos)
  (flags :standard -open Moonpool_private)
  (private_modules types_ util_pool_)
  (preprocess

src/core/exn_bt.ml

@@ -1,19 +1,9 @@
-type t = exn * Printexc.raw_backtrace
+include Picos_exn_bt
 
-let[@inline] make exn bt : t = exn, bt
-let[@inline] exn (e, _) = e
-let[@inline] bt (_, bt) = bt
-
-let[@inline] get exn =
-  let bt = Printexc.get_raw_backtrace () in
-  make exn bt
-
-let[@inline] get_callstack n exn =
-  let bt = Printexc.get_callstack n in
-  make exn bt
-
-let show self = Printexc.to_string (fst self)
+let[@inline] make exn bt : t = { exn; bt }
+let[@inline] exn self = self.exn
+let[@inline] bt self = self.bt
+let show self = Printexc.to_string (exn self)
 let pp out self = Format.pp_print_string out (show self)
-let[@inline] raise self = Printexc.raise_with_backtrace (exn self) (bt self)
 
 type nonrec 'a result = ('a, t) result

src/core/exn_bt.mli

@@ -1,8 +1,10 @@
 (** Exception with backtrace.
 
+    Type changed @since NEXT_RELEASE
+
     @since 0.6 *)
 
-type t = exn * Printexc.raw_backtrace
+include module type of Picos_exn_bt
 (** An exception bundled with a backtrace *)
 
 val exn : t -> exn
@@ -11,14 +13,6 @@ val bt : t -> Printexc.raw_backtrace
 val make : exn -> Printexc.raw_backtrace -> t
 (** Trivial builder *)
 
-val get : exn -> t
-(** [get exn] is [make exn (get_raw_backtrace ())] *)
-
-val get_callstack : int -> exn -> t
-
-val raise : t -> 'a
-(** Raise the exception with its save backtrace *)
-
 val show : t -> string
 (** Simple printing *)
 

src/core/fut.ml

@@ -16,7 +16,7 @@ let make () =
 
 let[@inline] of_result x : _ t = { st = A.make (Done x) }
 let[@inline] return x : _ t = of_result (Ok x)
-let[@inline] fail e bt : _ t = of_result (Error (e, bt))
+let[@inline] fail exn bt : _ t = of_result (Error { Exn_bt.exn; bt })
 let[@inline] fail_exn_bt ebt = of_result (Error ebt)
 
 let[@inline] is_resolved self : bool =
@@ -59,7 +59,7 @@ let[@inline] get_or_fail self =
 let[@inline] get_or_fail_exn self =
   match A.get self.st with
   | Done (Ok x) -> x
-  | Done (Error (exn, bt)) -> Printexc.raise_with_backtrace exn bt
+  | Done (Error { exn; bt }) -> Printexc.raise_with_backtrace exn bt
   | Waiting _ -> raise Not_ready
 
 let on_result (self : _ t) (f : _ waiter) : unit =
@@ -108,9 +108,9 @@ let spawn ~on f : _ t =
   let task () =
     let res =
       try Ok (f ())
-      with e ->
+      with exn ->
         let bt = Printexc.get_raw_backtrace () in
-        Error (e, bt)
+        Error { Exn_bt.exn; bt }
     in
     fulfill promise res
   in
@@ -141,9 +141,9 @@ let map ?on ~f fut : _ t =
     match r with
     | Ok x ->
       (try Ok (f x)
-       with e ->
+       with exn ->
          let bt = Printexc.get_raw_backtrace () in
-         Error (e, bt))
+         Error { Exn_bt.exn; bt })
     | Error e_bt -> Error e_bt
   in
 
@@ -167,7 +167,7 @@ let map ?on ~f fut : _ t =
 let join (fut : 'a t t) : 'a t =
   match peek fut with
   | Some (Ok f) -> f
-  | Some (Error (e, bt)) -> fail e bt
+  | Some (Error ebt) -> fail_exn_bt ebt
   | None ->
     let fut2, promise = make () in
     on_result fut (function
@@ -183,7 +183,7 @@ let bind ?on ~f fut : _ t =
        with e ->
          let bt = Printexc.get_raw_backtrace () in
          fail e bt)
-    | Error (e, bt) -> fail e bt
+    | Error ebt -> fail_exn_bt ebt
   in
 
   let bind_and_fulfill (r : _ result) promise () : unit =
@@ -226,7 +226,7 @@ let update_atomic_ (st : 'a A.t) f : 'a =
 let both a b : _ t =
   match peek a, peek b with
   | Some (Ok x), Some (Ok y) -> return (x, y)
-  | Some (Error (e, bt)), _ | _, Some (Error (e, bt)) -> fail e bt
+  | Some (Error ebt), _ | _, Some (Error ebt) -> fail_exn_bt ebt
   | _ ->
     let fut, promise = make () in
 
@@ -259,7 +259,7 @@ let choose a b : _ t =
   match peek a, peek b with
   | Some (Ok x), _ -> return (Either.Left x)
   | _, Some (Ok y) -> return (Either.Right y)
-  | Some (Error (e, bt)), Some (Error _) -> fail e bt
+  | Some (Error ebt), Some (Error _) -> fail_exn_bt ebt
   | _ ->
     let fut, promise = make () in
 
@@ -282,7 +282,7 @@ let choose_same a b : _ t =
   match peek a, peek b with
   | Some (Ok x), _ -> return x
   | _, Some (Ok y) -> return y
-  | Some (Error (e, bt)), Some (Error _) -> fail e bt
+  | Some (Error ebt), Some (Error _) -> fail_exn_bt ebt
   | _ ->
     let fut, promise = make () in
 
@@ -415,7 +415,7 @@ let wait_block (self : 'a t) : 'a or_error =
 let wait_block_exn self =
   match wait_block self with
   | Ok x -> x
-  | Error (e, bt) -> Printexc.raise_with_backtrace e bt
+  | Error { exn; bt } -> Printexc.raise_with_backtrace exn bt
 
 [@@@ifge 5.0]
 
@@ -425,7 +425,7 @@ let await (fut : 'a t) : 'a =
     (* fast path: peek *)
     (match res with
     | Ok x -> x
-    | Error (exn, bt) -> Printexc.raise_with_backtrace exn bt)
+    | Error { exn; bt } -> Printexc.raise_with_backtrace exn bt)
   | None ->
     (* suspend until the future is resolved *)
     Suspend_.suspend
@@ -436,9 +436,9 @@ let await (fut : 'a t) : 'a =
               | Ok _ ->
                 (* schedule continuation with the same name *)
                 resume k (Ok ())
-              | Error (exn, bt) ->
+              | Error ebt ->
                 (* fail continuation immediately *)
-                resume k (Error (exn, bt))));
+                resume k (Error ebt)));
       };
     (* un-suspended: we should have a result! *)
     get_or_fail_exn fut

src/core/suspend_.ml

@@ -44,7 +44,7 @@ let with_suspend (WSH { on_suspend; run; resume }) (f : unit -> unit) : unit =
           let state = on_suspend () in
           let k' : suspension = function
             | Ok () -> E.continue k ()
-            | Error (exn, bt) -> E.discontinue_with_backtrace k exn bt
+            | Error ebt -> Exn_bt.discontinue k ebt
           in
           h.handle ~run:(run state) ~resume:(resume state) k')
     | Yield ->
@@ -54,7 +54,7 @@ let with_suspend (WSH { on_suspend; run; resume }) (f : unit -> unit) : unit =
           let state = on_suspend () in
           let k' : suspension = function
             | Ok () -> E.continue k ()
-            | Error (exn, bt) -> E.discontinue_with_backtrace k exn bt
+            | Error ebt -> Exn_bt.discontinue k ebt
           in
           resume state k' @@ Ok ())
     | _ -> None

src/forkjoin/moonpool_forkjoin.ml

@@ -125,7 +125,7 @@ let for_ ?chunk_size n (f : int -> int -> unit) : unit =
           if not (A.exchange has_failed true) then
             (* first one to fail, and [missing] must be >= 2
                because we're not decreasing it. *)
-            resume suspension (Error (exn, bt))
+            resume suspension (Error { Exn_bt.exn; bt })
       in
 
       let i = ref 0 in

src/lwt/base.ml

@@ -90,7 +90,7 @@ let lwt_of_fut (fut : 'a M.Fut.t) : 'a Lwt.t =
   let lwt_fut, lwt_prom = Lwt.wait () in
   M.Fut.on_result fut (function
     | Ok x -> Perform_action_in_lwt.schedule @@ Action.Wakeup (lwt_prom, x)
-    | Error (exn, _) ->
+    | Error { exn; _ } ->
       Perform_action_in_lwt.schedule @@ Action.Wakeup_exn (lwt_prom, exn));
   lwt_fut
 
@@ -101,7 +101,9 @@ let fut_of_lwt (lwt_fut : _ Lwt.t) : _ M.Fut.t =
     let fut, prom = M.Fut.make () in
     Lwt.on_any lwt_fut
       (fun x -> M.Fut.fulfill prom (Ok x))
-      (fun e -> M.Fut.fulfill prom (Error (e, Printexc.get_callstack 10)));
+      (fun exn ->
+        let bt = Printexc.get_callstack 10 in
+        M.Fut.fulfill prom (Error { Exn_bt.exn; bt }));
     fut
 
 let await_lwt (fut : _ Lwt.t) =