From f1ff17dbd6c3f30e5130551df7581d0c47094dde Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 26 Aug 2024 13:05:50 -0400 Subject: [PATCH] feat: depend on picos, use picos.exn_bt --- src/core/chan.ml | 5 ++++- src/core/dune | 2 +- src/core/exn_bt.ml | 20 +++++--------------- src/core/exn_bt.mli | 12 +++--------- src/core/fut.ml | 30 +++++++++++++++--------------- src/core/suspend_.ml | 4 ++-- src/forkjoin/moonpool_forkjoin.ml | 2 +- src/lwt/base.ml | 6 ++++-- 8 files changed, 35 insertions(+), 46 deletions(-) diff --git a/src/core/chan.ml b/src/core/chan.ml index 5ce82376..70a07359 100644 --- a/src/core/chan.ml +++ b/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 diff --git a/src/core/dune b/src/core/dune index 1c39c97b..fba9da7d 100644 --- a/src/core/dune +++ b/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 diff --git a/src/core/exn_bt.ml b/src/core/exn_bt.ml index dc1fab0f..e3d4c520 100644 --- a/src/core/exn_bt.ml +++ b/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 diff --git a/src/core/exn_bt.mli b/src/core/exn_bt.mli index eb8f1b02..b78e7b4c 100644 --- a/src/core/exn_bt.mli +++ b/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 *) diff --git a/src/core/fut.ml b/src/core/fut.ml index 17afb908..00354bad 100644 --- a/src/core/fut.ml +++ b/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 diff --git a/src/core/suspend_.ml b/src/core/suspend_.ml index fefbaff3..8d7d229f 100644 --- a/src/core/suspend_.ml +++ b/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 diff --git a/src/forkjoin/moonpool_forkjoin.ml b/src/forkjoin/moonpool_forkjoin.ml index 052ca7f2..d5961d95 100644 --- a/src/forkjoin/moonpool_forkjoin.ml +++ b/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 diff --git a/src/lwt/base.ml b/src/lwt/base.ml index 88e7ed3d..73ccc049 100644 --- a/src/lwt/base.ml +++ b/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) =