diff --git a/Changes b/Changes index 7afa326a1fb0..14b6caa13993 100644 --- a/Changes +++ b/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) diff --git a/otherlibs/threads/stdlib.ml b/otherlibs/threads/stdlib.ml index 4ad04bf9ebbd..55dbe0e81bde 100644 --- a/otherlibs/threads/stdlib.ml +++ b/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" diff --git a/stdlib/.depend b/stdlib/.depend index 243eb4c11ec4..8929413f4005 100644 --- a/stdlib/.depend +++ b/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 \ diff --git a/stdlib/Makefile b/stdlib/Makefile index 4e45f147e446..67dc8bc4788a 100644 --- a/stdlib/Makefile +++ b/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 \ diff --git a/stdlib/fun.ml b/stdlib/fun.ml index 45890bdef278..247f107e51c1 100644 --- a/stdlib/fun.ml +++ b/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 diff --git a/stdlib/fun.mli b/stdlib/fun.mli index 60682fdde752..202e4c2343cd 100644 --- a/stdlib/fun.mli +++ b/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. *) diff --git a/stdlib/stdlib.ml b/stdlib/stdlib.ml index 023788bdac04..3c5a86b3de45 100644 --- a/stdlib/stdlib.ml +++ b/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" diff --git a/stdlib/stdlib.mli b/stdlib/stdlib.mli index d2b97a2711a6..3ee5eb626c61 100644 --- a/stdlib/stdlib.mli +++ b/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 diff --git a/testsuite/tests/lib-fun/test.ml b/testsuite/tests/lib-fun/test.ml index 3eb9b6163d05..ba534db2628a 100644 --- a/testsuite/tests/lib-fun/test.ml +++ b/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 () =