From 2f11fd75df06b5f005256a634fb55f3059bef556 Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Fri, 2 Feb 2024 20:58:07 -0500
Subject: [PATCH] feat: add `Exn_bt` to core

---
 src/core/exn_bt.ml    | 18 ++++++++++++++++++
 src/core/exn_bt.mli   | 25 +++++++++++++++++++++++++
 src/core/fut.ml       |  3 ++-
 src/core/fut.mli      |  6 +++++-
 src/core/moonpool.ml  |  1 +
 src/core/moonpool.mli |  1 +
 6 files changed, 52 insertions(+), 2 deletions(-)
 create mode 100644 src/core/exn_bt.ml
 create mode 100644 src/core/exn_bt.mli

diff --git a/src/core/exn_bt.ml b/src/core/exn_bt.ml
new file mode 100644
index 00000000..b69f6614
--- /dev/null
+++ b/src/core/exn_bt.ml
@@ -0,0 +1,18 @@
+type t = exn * Printexc.raw_backtrace
+
+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] 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
new file mode 100644
index 00000000..becfbf3b
--- /dev/null
+++ b/src/core/exn_bt.mli
@@ -0,0 +1,25 @@
+(** Exception with backtrace.
+
+    @since NEXT_RELEASE *)
+
+type t = exn * Printexc.raw_backtrace
+(** An exception bundled with a backtrace *)
+
+val exn : t -> exn
+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 *)
+
+type nonrec 'a result = ('a, t) result
diff --git a/src/core/fut.ml b/src/core/fut.ml
index 7fed5894..f22bd11b 100644
--- a/src/core/fut.ml
+++ b/src/core/fut.ml
@@ -1,6 +1,6 @@
 module A = Atomic_
 
-type 'a or_error = ('a, exn * Printexc.raw_backtrace) result
+type 'a or_error = ('a, Exn_bt.t) result
 type 'a waiter = 'a or_error -> unit
 
 type 'a state =
@@ -25,6 +25,7 @@ let make ?(name = "") () =
 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 ebt = of_result (Error ebt)
 
 let[@inline] is_resolved self : bool =
   match A.get self.st with
diff --git a/src/core/fut.mli b/src/core/fut.mli
index 08ac3b68..006419c4 100644
--- a/src/core/fut.mli
+++ b/src/core/fut.mli
@@ -17,7 +17,7 @@
     the runner [pool] (once [fut] resolves successfully with a value).
 *)
 
-type 'a or_error = ('a, exn * Printexc.raw_backtrace) result
+type 'a or_error = ('a, Exn_bt.t) result
 
 type 'a t
 (** A future with a result of type ['a]. *)
@@ -51,6 +51,10 @@ val return : 'a -> 'a t
 val fail : exn -> Printexc.raw_backtrace -> _ t
 (** Already settled future, with a failure *)
 
+val fail_exn_bt : Exn_bt.t -> _ t
+(** Fail from a bundle of exception and backtrace
+    @since NEXT_RELEASE *)
+
 val of_result : 'a or_error -> 'a t
 
 val is_resolved : _ t -> bool
diff --git a/src/core/moonpool.ml b/src/core/moonpool.ml
index b292531c..1604a456 100644
--- a/src/core/moonpool.ml
+++ b/src/core/moonpool.ml
@@ -17,6 +17,7 @@ module Atomic = Atomic_
 module Blocking_queue = Bb_queue
 module Bounded_queue = Bounded_queue
 module Chan = Chan
+module Exn_bt = Exn_bt
 module Fifo_pool = Fifo_pool
 module Fut = Fut
 module Lock = Lock
diff --git a/src/core/moonpool.mli b/src/core/moonpool.mli
index 1c8a5235..33aa2d50 100644
--- a/src/core/moonpool.mli
+++ b/src/core/moonpool.mli
@@ -13,6 +13,7 @@ module Ws_pool = Ws_pool
 module Fifo_pool = Fifo_pool
 module Runner = Runner
 module Immediate_runner = Immediate_runner
+module Exn_bt = Exn_bt
 
 val start_thread_on_some_domain : ('a -> unit) -> 'a -> Thread.t
 (** Similar to {!Thread.create}, but it picks a background domain at random