Improve protect

- Treat as an error the case where ~finally raises an exception

- Move to Fun module

- Describe the purpose in the documentation

- Remove boilerplate

#2118

Changes

@@ -138,11 +138,14 @@ OCaml 4.08.0
 - GPR#1959: Small simplification and optimization to Format.ifprintf
   (Gabriel Radanne, review by Gabriel Scherer)
 
-- GPR#1855: Add `Pervasives.protect ~finally`, similar to `Misc.try_finally`
-  from the compiler library but using `Printexc.raise_with_backtrace` for
-  preserving backtraces.
-  (Marcello Seri, review by Daniel Bünzli, Gabriel Scherer, François Bobot,
-  Nicolás Ojeda Bär, Xavier Clerc and Boris Yakobowski)
+- GPR#1855, GPR#2118: Add `Fun.protect ~finally` for enforcing local
+  invariants whether a function raises or not, similar to
+  `unwind-protect` in Lisp and `FINALLY` in Modula-2. It is careful
+  about preserving backtraces and treating exceptions in finally as
+  errors.
+  (Marcello Seri and Guillaume Munch-Maccagnoni, review by Daniel
+  Bünzli, Gabriel Scherer, François Bobot, Nicolás Ojeda Bär, Xavier
+  Clerc, Boris Yakobowski, Damien Doligez, and Xavier Leroy)
 
 - GPR#1986, MPR#6450: Add Set.disjoint
   (Nicolás Ojeda Bär, review by Gabriel Scherer)

otherlibs/threads/stdlib.ml

@@ -48,20 +48,6 @@ exception Division_by_zero = Division_by_zero
 exception Sys_blocked_io = Sys_blocked_io
 exception Undefined_recursive_module = Undefined_recursive_module
 
-type raw_backtrace
-external get_raw_backtrace:
-  unit -> raw_backtrace = "caml_get_exception_raw_backtrace"
-external raise_with_backtrace: exn -> raw_backtrace -> 'a
-  = "%raise_with_backtrace"
-
-let protect ~(finally: unit -> unit) work =
-  match work () with
-  | result -> finally (); result
-  | exception work_exn ->
-    let work_bt = get_raw_backtrace () in
-    finally ();
-    raise_with_backtrace work_exn work_bt
-
 (* Composition operators *)
 
 external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"

stdlib/.depend

@@ -262,8 +262,10 @@ stdlib__format.cmi : \
     stdlib.cmi \
     stdlib__buffer.cmi
 stdlib__fun.cmo : \
+    stdlib__printexc.cmi \
     stdlib__fun.cmi
 stdlib__fun.cmx : \
+    stdlib__printexc.cmx \
     stdlib__fun.cmi
 stdlib__fun.cmi :
 stdlib__gc.cmo : \
@@ -904,8 +906,10 @@ stdlib__format.p.cmx : \
     stdlib__buffer.cmx \
     stdlib__format.cmi
 stdlib__fun.cmo : \
+    stdlib__printexc.cmi \
     stdlib__fun.cmi
 stdlib__fun.p.cmx : \
+    stdlib__printexc.cmx \
     stdlib__fun.cmi
 stdlib__gc.cmo : \
     stdlib__sys.cmi \

stdlib/Makefile

@@ -44,14 +44,14 @@ P=stdlib__
 OBJS=camlinternalFormatBasics.cmo stdlib.cmo $(OTHERS)
 OTHERS= $(P)pervasives.cmo $(P)seq.cmo $(P)option.cmo $(P)result.cmo \
   $(P)bool.cmo $(P)char.cmo $(P)uchar.cmo $(P)sys.cmo $(P)list.cmo \
-  $(P)bytes.cmo $(P)string.cmo $(P)fun.cmo $(P)unit.cmo \
+  $(P)bytes.cmo $(P)string.cmo $(P)unit.cmo \
   $(P)marshal.cmo $(P)obj.cmo $(P)array.cmo $(P)float.cmo \
   $(P)int.cmo $(P)int32.cmo $(P)int64.cmo $(P)nativeint.cmo \
   $(P)lexing.cmo $(P)parsing.cmo \
   $(P)set.cmo $(P)map.cmo $(P)stack.cmo $(P)queue.cmo \
   camlinternalLazy.cmo $(P)lazy.cmo $(P)stream.cmo \
   $(P)buffer.cmo camlinternalFormat.cmo $(P)printf.cmo \
-  $(P)arg.cmo $(P)printexc.cmo $(P)gc.cmo \
+  $(P)arg.cmo $(P)printexc.cmo $(P)fun.cmo $(P)gc.cmo \
   $(P)digest.cmo $(P)random.cmo $(P)hashtbl.cmo $(P)weak.cmo \
   $(P)format.cmo $(P)scanf.cmo $(P)callback.cmo \
   camlinternalOO.cmo $(P)oo.cmo camlinternalMod.cmo \

stdlib/fun.ml

@@ -17,3 +17,18 @@ external id : 'a -> 'a = "%identity"
 let const c _ = c
 let flip f x y = f y x
 let negate p v = not (p v)
+
+exception Finally_raised of exn
+
+let protect ~(finally : unit -> unit) work =
+  let finally_no_exn () =
+    try finally () with e ->
+      let bt = Printexc.get_raw_backtrace () in
+      Printexc.raise_with_backtrace (Finally_raised e) bt
+  in
+  match work () with
+  | result -> finally_no_exn () ; result
+  | exception work_exn ->
+      let work_bt = Printexc.get_raw_backtrace () in
+      finally_no_exn () ;
+      Printexc.raise_with_backtrace work_exn work_bt

stdlib/fun.mli

@@ -13,10 +13,12 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(** Function values.
+(** Function manipulation.
 
     @since 4.08 *)
 
+(** {1 Combinators} *)
+
 external id : 'a -> 'a = "%identity"
 (** [id] is the identity function. For any argument [x], [id x] is [x]. *)
 
@@ -31,3 +33,31 @@ val flip : ('a -> 'b -> 'c) -> ('b -> 'a -> 'c)
 val negate : ('a -> bool) -> ('a -> bool)
 (** [negate p] is the negation of the predicate function [p]. For any
     argument [x], [(negate p) x] is [not (p x)]. *)
+
+(** {1 Exception handling} *)
+
+val protect : finally:(unit -> unit) -> (unit -> 'a) -> 'a
+(** [protect ~finally work] invokes [work ()] and then [finally ()]
+    before [work ()] returns with its value or an exception. In the
+    latter case the exception is re-raised after [finally ()]. If
+    [finally ()] raises an exception, then the exception
+    {!Finally_raised} is raised instead.
+
+    [protect] can be used to enforce local invariants whether [work
+    ()] returns normally or raises an exception. However, it does not
+    protect against unexpected exceptions raised inside [finally ()]
+    such as {!Stdlib.Out_of_memory}, {!Stdlib.Stack_overflow}, or
+    asynchronous exceptions raised by signal handlers
+    (e.g. {!Sys.Break}).
+
+    Note: It is a {e programming error} if other kinds of exceptions
+    are raised by [finally], as any exception raised in [work ()] will
+    be lost in the event of a {!Finally_raised} exception. Therefore,
+    one should make sure to handle those inside the finally. *)
+
+exception Finally_raised of exn
+(** [Finally_raised exn] is raised by [protect ~finally work] when
+    [finally] raises an exception [exn]. This exception denotes either
+    an unexpected exception or a programming error. As a general rule,
+    one should not catch a [Finally_raised] exception except as part of
+    a catch-all handler. *)

stdlib/stdlib.ml

@@ -43,20 +43,6 @@ exception Division_by_zero = Division_by_zero
 exception Sys_blocked_io = Sys_blocked_io
 exception Undefined_recursive_module = Undefined_recursive_module
 
-type raw_backtrace
-external get_raw_backtrace:
-  unit -> raw_backtrace = "caml_get_exception_raw_backtrace"
-external raise_with_backtrace: exn -> raw_backtrace -> 'a
-  = "%raise_with_backtrace"
-
-let protect ~(finally: unit -> unit) work =
-  match work () with
-  | result -> finally (); result
-  | exception work_exn ->
-    let work_bt = get_raw_backtrace () in
-    finally ();
-    raise_with_backtrace work_exn work_bt
-
 (* Composition operators *)
 
 external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"

stdlib/stdlib.mli

@@ -44,15 +44,6 @@ exception Exit
 (** The [Exit] exception is not raised by any library function.  It is
     provided for use in your programs. *)
 
-val protect : finally:(unit -> unit) -> (unit -> 'a) -> 'a
-(** [protect ~finally work] invokes [work ()] and then [finally ()]
-    before [work] returns with its value or an exception. In the latter
-    case the exception is re-raised after [finally ()].
-    If [finally ()] raises, this exception is not caught and may shadow
-    one [work ()] may have raised.
-
-    @since 4.08.0 *)
-
 exception Match_failure of (string * int * int)
   [@ocaml.warn_on_literal_pattern]
 (** Exception raised when none of the cases of a pattern-matching

testsuite/tests/lib-fun/test.ml

@@ -24,11 +24,26 @@ let test_negate () =
   assert (Fun.negate (Bool.equal true) false = true);
   ()
 
+let test_protect () =
+  let does_raise f x =
+    try f x ; false
+    with _ -> true
+  in
+  let double_raise () =
+    let f () = raise Exit in
+    try
+      Fun.protect ~finally:f f ()
+    with
+    | Exit -> ()
+  in
+  assert (does_raise double_raise ())
+
 let tests () =
   test_id ();
   test_const ();
   test_flip ();
   test_negate ();
+  test_protect ();
   ()
 
 let () =