Change poison to poison_at and add poison with ?callstack

This should make `poison`able data structures more convenient to use.

Author: polytypic

CHANGES.md

@@ -2,6 +2,8 @@
 
 - Forbid cancelation propagation during `release` calls in the
   `picos_std.finally` library (@polytypic)
+- Renamed `(Ivar|Stream).poison` to `(Ivar|Stream).poison_at` and added
+  `(Ivar|Stream).poison` with optional `?callstack:int` (@polytypic)
 
 ## 0.5.0
 

lib/picos_std.sync/ivar.ml

@@ -7,13 +7,19 @@ let create () = Computation.create ()
 let of_value = Computation.returned
 let try_fill = Computation.try_return
 let fill = Computation.return
-let try_poison = Computation.try_cancel
-let poison = Computation.cancel
+let try_poison_at = Computation.try_cancel
+let poison_at = Computation.cancel
 
 let peek_opt ivar =
   match Computation.peek_exn ivar with
   | value -> Some value
   | exception Computation.Running -> None
 
+let try_poison ?(callstack = 0) ivar exn =
+  try_poison_at ivar exn (Printexc.get_callstack callstack)
+
 let read = Computation.await
 let read_evt = Event.from_computation
+
+let[@inline always] poison ?(callstack = 0) ivar exn =
+  poison_at ivar exn (Printexc.get_callstack callstack)

lib/picos_std.sync/picos_std_sync.mli

@@ -305,15 +305,25 @@ module Ivar : sig
   (** [fill ivar value] is equivalent to
       {{!try_fill} [try_fill ivar value |> ignore]}. *)
 
-  val try_poison : 'a t -> exn -> Printexc.raw_backtrace -> bool
-  (** [try_poison ivar exn bt] attempts to poison the incremental variable with
-      the specified exception and backtrace.  Returns [true] on success and
+  val try_poison_at : 'a t -> exn -> Printexc.raw_backtrace -> bool
+  (** [try_poison_at ivar exn bt] attempts to poison the incremental variable
+      with the specified exception and backtrace.  Returns [true] on success and
       [false] in case the variable had already been poisoned or assigned a
       value. *)
 
-  val poison : 'a t -> exn -> Printexc.raw_backtrace -> unit
-  (** [poison ivar exn bt] is equivalent to
-      {{!try_poison} [try_poison ivar exn bt |> ignore]}. *)
+  val try_poison : ?callstack:int -> 'a t -> exn -> bool
+  (** [try_poison ivar exn] is equivalent to
+      {{!try_poison_at} [try_poison_at ivar exn (Printexc.get_callstack n)]}
+      where [n] defaults to [0]. *)
+
+  val poison_at : 'a t -> exn -> Printexc.raw_backtrace -> unit
+  (** [poison_at ivar exn bt] is equivalent to
+      {{!try_poison_at} [try_poison_at ivar exn bt |> ignore]}. *)
+
+  val poison : ?callstack:int -> 'a t -> exn -> unit
+  (** [poison ivar exn] is equivalent to
+      {{!poison_at} [poison_at ivar exn (Printexc.get_callstack n)]}
+      where [n] defaults to [0]. *)
 
   val peek_opt : 'a t -> 'a option
   (** [peek_opt ivar] either returns [Some value] in case the variable has been
@@ -351,11 +361,16 @@ module Stream : sig
       has been {{!poison} poisoned} in which case only the exception given to
       {!poison} will be raised. *)
 
-  val poison : 'a t -> exn -> Printexc.raw_backtrace -> unit
-  (** [poison stream exn bt] marks the stream as poisoned at the current
+  val poison_at : 'a t -> exn -> Printexc.raw_backtrace -> unit
+  (** [poison_at stream exn bt] marks the stream as poisoned at the current
       position, which means that subsequent attempts to {!push} to the [stream]
       will raise the given exception with backtrace. *)
 
+  val poison : ?callstack:int -> 'a t -> exn -> unit
+  (** [poison stream exn] is equivalent to
+      {{!poison_at} [poison_at stream exn (Printexc.get_callstack n)]}
+      where [n] defaults to [0]. *)
+
   type !'a cursor
   (** Represents a (past or current) position in a stream. *)
 

lib/picos_std.sync/stream.ml

@@ -4,10 +4,6 @@ open Picos_std_event
 type 'a cursor = Cons of ('a * 'a cursor) Computation.t [@@unboxed]
 type 'a t = 'a cursor Atomic.t
 
-let create ?padded () =
-  Multicore_magic.copy_as ?padded
-    (Atomic.make (Cons (Computation.create ~mode:`LIFO ())))
-
 let[@inline] advance t tail curr =
   if Atomic.get t == Cons tail then
     Atomic.compare_and_set t (Cons tail) curr |> ignore
@@ -16,6 +12,10 @@ let[@inline] help t tail =
   let _, curr = Computation.peek_exn tail in
   advance t tail curr
 
+let create ?padded () =
+  Multicore_magic.copy_as ?padded
+    (Atomic.make (Cons (Computation.create ~mode:`LIFO ())))
+
 let rec push t ((_, curr) as next) backoff =
   let (Cons tail) = Atomic.get t in
   if Computation.try_return tail next then advance t tail curr
@@ -28,20 +28,23 @@ let push t value =
   let next = (value, Cons (Computation.create ~mode:`LIFO ())) in
   push t next Backoff.default
 
-let rec poison t exn bt backoff =
+let rec poison_at t exn bt backoff =
   let (Cons tail) = Atomic.get t in
   if not (Computation.try_cancel tail exn bt) then begin
     let backoff = Backoff.once backoff in
     help t tail;
-    poison t exn bt backoff
+    poison_at t exn bt backoff
   end
 
 let peek_opt (Cons at) =
   match Computation.peek_exn at with
   | value -> Some value
   | exception Computation.Running -> None
 
-let poison t exn bt = poison t exn bt Backoff.default
+let poison_at t exn bt = poison_at t exn bt Backoff.default
 let tap = Atomic.get
 let read (Cons at) = Computation.await at
 let read_evt (Cons at) = Event.from_computation at
+
+let[@inline always] poison ?(callstack = 0) t exn =
+  poison_at t exn (Printexc.get_callstack callstack)