Merge pull request #964 from ocsigen/dont-catch-ocaml-runtime-exceptions

Dont catch ocaml runtime exceptions

CHANGES

@@ -18,6 +18,7 @@
 
 ====== Additions ======
 
+  * Lwt.Exception_filter for enabling/disabling system-exception catching (#964)
   * Lwt.reraise an exception raising function which preserves backtraces, recommended for use in Lwt.catch (#963)
   * Expose Lwt_io.delete_recursively for deleting a directory and its content recursively. (#984, Antonin Décimo)
 

src/core/lwt.ml

@@ -710,7 +710,20 @@ struct
 end
 open Basic_helpers
 
-
+(* Small helpers to avoid catching ocaml-runtime exceptions *)
+module Exception_filter = struct
+  type t = exn -> bool
+  let handle_all = fun _ -> true
+  let handle_all_except_runtime = function
+    | Out_of_memory -> false
+    | Stack_overflow -> false
+    | _ -> true
+  let v =
+    (* Default value: the legacy behaviour to avoid breaking programs *)
+    ref handle_all
+  let set f = v := f
+  let run e = !v e
+end
 
 module Sequence_associated_storage :
 sig
@@ -791,7 +804,7 @@ struct
       let result = f () in
       current_storage := saved_storage;
       result
-    with exn ->
+    with exn when Exception_filter.run exn ->
       current_storage := saved_storage;
       raise exn
 end
@@ -1129,7 +1142,8 @@ struct
        be reject later, it is not the responsibility of this function to pass
        the exception to [!async_exception_hook]. *)
     try f v
-    with exn -> !async_exception_hook exn
+    with exn when Exception_filter.run exn ->
+      !async_exception_hook exn
 
 
 
@@ -1826,7 +1840,10 @@ struct
         | Fulfilled v ->
           current_storage := saved_storage;
 
-          let p' = try f v with exn -> fail exn in
+          let p' =
+            try f v with exn
+            when Exception_filter.run exn -> fail exn
+          in
           let Internal p' = to_internal_promise p' in
           (* Run the user's function [f]. *)
 
@@ -1889,7 +1906,10 @@ struct
         | Fulfilled v ->
           current_storage := saved_storage;
 
-          let p' = try f v with exn -> fail (add_loc exn) in
+          let p' =
+            try f v
+            with exn when Exception_filter.run exn ->
+              fail (add_loc exn) in
           let Internal p' = to_internal_promise p' in
 
           let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in
@@ -1943,7 +1963,10 @@ struct
         | Fulfilled v ->
           current_storage := saved_storage;
 
-          let p''_result = try Fulfilled (f v) with exn -> Rejected exn in
+          let p''_result =
+            try Fulfilled (f v) with exn
+            when Exception_filter.run exn -> Rejected exn
+          in
 
           let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in
           let p'' = underlying p'' in
@@ -1970,7 +1993,9 @@ struct
         ~run_immediately_and_ensure_tail_call:true
         ~callback:(fun () ->
           to_public_promise
-            {state = try Fulfilled (f v) with exn -> Rejected exn})
+            {state =
+              try Fulfilled (f v)
+              with exn when Exception_filter.run exn -> Rejected exn})
         ~if_deferred:(fun () ->
           let (p'', callback) =
             create_result_promise_and_callback_if_deferred () in
@@ -1987,7 +2012,10 @@ struct
   external reraise : exn -> 'a = "%reraise"
 
   let catch f h =
-    let p = try f () with exn -> fail exn in
+    let p =
+      try f ()
+      with exn when Exception_filter.run exn -> fail exn
+    in
     let Internal p = to_internal_promise p in
     let p = underlying p in
 
@@ -2009,7 +2037,10 @@ struct
         | Rejected exn ->
           current_storage := saved_storage;
 
-          let p' = try h exn with exn -> fail exn in
+          let p' =
+            try h exn
+            with exn when Exception_filter.run exn -> fail exn
+          in
           let Internal p' = to_internal_promise p' in
 
           let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in
@@ -2042,7 +2073,10 @@ struct
       p''
 
   let backtrace_catch add_loc f h =
-    let p = try f () with exn -> fail exn in
+    let p =
+      try f ()
+      with exn when Exception_filter.run exn -> fail exn
+    in
     let Internal p = to_internal_promise p in
     let p = underlying p in
 
@@ -2064,7 +2098,11 @@ struct
         | Rejected exn ->
           current_storage := saved_storage;
 
-          let p' = try h exn with exn -> fail (add_loc exn) in
+          let p' =
+            try h exn
+            with exn when Exception_filter.run exn ->
+              fail (add_loc exn)
+          in
           let Internal p' = to_internal_promise p' in
 
           let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in
@@ -2097,7 +2135,10 @@ struct
       p''
 
   let try_bind f f' h =
-    let p = try f () with exn -> fail exn in
+    let p =
+      try f ()
+      with exn when Exception_filter.run exn -> fail exn
+    in
     let Internal p = to_internal_promise p in
     let p = underlying p in
 
@@ -2111,7 +2152,10 @@ struct
         | Fulfilled v ->
           current_storage := saved_storage;
 
-          let p' = try f' v with exn -> fail exn in
+          let p' =
+            try f' v
+            with exn when Exception_filter.run exn -> fail exn
+          in
           let Internal p' = to_internal_promise p' in
 
           let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in
@@ -2124,7 +2168,10 @@ struct
         | Rejected exn ->
           current_storage := saved_storage;
 
-          let p' = try h exn with exn -> fail exn in
+          let p' =
+            try h exn
+            with exn when Exception_filter.run exn -> fail exn
+          in
           let Internal p' = to_internal_promise p' in
 
           let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in
@@ -2163,7 +2210,10 @@ struct
       p''
 
   let backtrace_try_bind add_loc f f' h =
-    let p = try f () with exn -> fail exn in
+    let p =
+      try f ()
+      with exn when Exception_filter.run exn -> fail exn
+    in
     let Internal p = to_internal_promise p in
     let p = underlying p in
 
@@ -2177,7 +2227,11 @@ struct
         | Fulfilled v ->
           current_storage := saved_storage;
 
-          let p' = try f' v with exn -> fail (add_loc exn) in
+          let p' =
+            try f' v
+            with exn when Exception_filter.run exn ->
+              fail (add_loc exn)
+          in
           let Internal p' = to_internal_promise p' in
 
           let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in
@@ -2190,7 +2244,11 @@ struct
         | Rejected exn ->
           current_storage := saved_storage;
 
-          let p' = try h exn with exn -> fail (add_loc exn) in
+          let p' =
+            try h exn
+            with exn when Exception_filter.run exn ->
+              fail (add_loc exn)
+          in
           let Internal p' = to_internal_promise p' in
 
           let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in
@@ -2441,7 +2499,10 @@ struct
   external reraise : exn -> 'a = "%reraise"
 
   let dont_wait f h =
-    let p = try f () with exn -> fail exn in
+    let p =
+      try f ()
+      with exn when Exception_filter.run exn -> fail exn
+    in
     let Internal p = to_internal_promise p in
 
     match (underlying p).state with
@@ -2461,7 +2522,10 @@ struct
       add_implicitly_removed_callback p_callbacks callback
 
   let async f =
-    let p = try f () with exn -> fail exn in
+    let p =
+      try f ()
+      with exn when Exception_filter.run exn -> fail exn
+    in
     let Internal p = to_internal_promise p in
 
     match (underlying p).state with
@@ -3062,37 +3126,40 @@ struct
 
 
 
-  let apply f x = try f x with exn -> fail exn
+  let apply f x =
+    try f x with exn when Exception_filter.run exn -> fail exn
 
-  let wrap f = try return (f ()) with exn -> fail exn
+  let wrap f =
+    try return (f ())
+    with exn when Exception_filter.run exn -> fail exn
 
   let wrap1 f x1 =
     try return (f x1)
-    with exn -> fail exn
+    with exn when Exception_filter.run exn -> fail exn
 
   let wrap2 f x1 x2 =
     try return (f x1 x2)
-    with exn -> fail exn
+    with exn when Exception_filter.run exn -> fail exn
 
   let wrap3 f x1 x2 x3 =
     try return (f x1 x2 x3)
-    with exn -> fail exn
+    with exn when Exception_filter.run exn -> fail exn
 
   let wrap4 f x1 x2 x3 x4 =
     try return (f x1 x2 x3 x4)
-    with exn -> fail exn
+    with exn when Exception_filter.run exn -> fail exn
 
   let wrap5 f x1 x2 x3 x4 x5 =
     try return (f x1 x2 x3 x4 x5)
-    with exn -> fail exn
+    with exn when Exception_filter.run exn -> fail exn
 
   let wrap6 f x1 x2 x3 x4 x5 x6 =
     try return (f x1 x2 x3 x4 x5 x6)
-    with exn -> fail exn
+    with exn when Exception_filter.run exn -> fail exn
 
   let wrap7 f x1 x2 x3 x4 x5 x6 x7 =
     try return (f x1 x2 x3 x4 x5 x6 x7)
-    with exn -> fail exn
+    with exn when Exception_filter.run exn -> fail exn
 
 
 

src/core/lwt.mli

@@ -1999,6 +1999,49 @@ val ignore_result : _ t -> unit
       resolved, completing any associated side effects along the way. In fact,
       the function that does {e that} is ordinary {!Lwt.bind}. *)
 
+(** {4 Runtime exception filters}
+
+    Depending on the kind of programs that you write, you may need to treat
+    exceptions thrown by the OCaml runtime (namely [Out_of_memory] and
+    [Stack_overflow]) differently than all the other exceptions. This is because
+    (a) these exceptions are not reproducible (in that they are thrown at
+    different points of your program depending on the machine that your program
+    runs on) and (b) recovering from these errors may be impossible.
+
+    The helpers below allow you to change the way that Lwt handles the two OCaml
+    runtime exceptions [Out_of_memory] and [Stack_overflow]. *)
+
+module Exception_filter: sig
+
+  (** An [Exception_filter.t] is a value which indicates to Lwt what exceptions to
+      catch and what exceptions to let bubble up all the way out of the main loop
+      immediately. *)
+  type t
+
+  (** [handle_all] is the default filter. With it the all the exceptions
+      (including [Out_of_memory] and [Stack_overflow]) can be handled: caught
+      and transformed into rejected promises. *)
+  val handle_all : t
+
+  (** [handle_all_except_runtime] is a filter which lets the OCaml runtime
+      exceptions ([Out_of_memory] and [Stack_overflow]) go through all the Lwt
+      abstractions and bubble all the way out of the call to [Lwt_main.run].
+
+      Note that if you set this handler, then the runtime exceptions leave the
+      Lwt internal state inconsistent. For this reason, you will not be able to
+      call [Lwt_main.run] again after such an exception has escaped
+      [Lwt_main.run]. *)
+  val handle_all_except_runtime : t
+
+  (** [set] sets the given exception filter globally. You should call this
+      function at most once during the start of your program, before the
+      first call to [Lwt_main.run]. *)
+  val set : t -> unit
+
+  (**/**)
+  val run : exn -> bool
+
+end
 
 
 (**/**)

src/core/lwt_seq.ml

@@ -270,7 +270,7 @@ let rec unfold f u () =
   match f u with
   | None -> return_nil
   | Some (x, u') -> Lwt.return (Cons (x, unfold f u'))
-  | exception exc -> Lwt.fail exc
+  | exception exc when Lwt.Exception_filter.run exc -> Lwt.fail exc
 
 let rec unfold_lwt f u () =
   let* x = f u in
@@ -305,7 +305,7 @@ let rec of_seq seq () =
   | Seq.Nil -> return_nil
   | Seq.Cons (x, next) ->
     Lwt.return (Cons (x, (of_seq next)))
-  | exception exn -> Lwt.fail exn
+  | exception exn when Lwt.Exception_filter.run exn -> Lwt.fail exn
 
 let rec of_seq_lwt (seq: 'a Lwt.t Seq.t): 'a t = fun () ->
     match seq () with
@@ -321,4 +321,4 @@ let of_seq_lwt (seq: 'a Lwt.t Seq.t): 'a t = fun () ->
        let+ x = x in
        let next = of_seq_lwt next in
        Cons (x, next)
-    | exception exc -> Lwt.fail exc
+    | exception exc when Lwt.Exception_filter.run exc -> Lwt.fail exc

src/react/lwt_react.ml

@@ -95,7 +95,12 @@ module E = struct
     let event, push = create () in
     let t =
       Lwt.pause () >>= fun () ->
-      Lwt_stream.iter (fun v -> try push v with exn -> !Lwt.async_exception_hook exn) stream in
+      Lwt_stream.iter
+        (fun v ->
+          try push v
+          with exn when Lwt.Exception_filter.run exn ->
+            !Lwt.async_exception_hook exn)
+        stream in
     with_finaliser (cancel_thread t) event
 
   let delay thread =

src/unix/lwt_io.ml

@@ -533,8 +533,12 @@ let make :
     mode = mode;
     offset = 0L;
     typ =
-      Type_normal
-        (perform_io, fun pos cmd -> try seek pos cmd with e -> Lwt.fail e);
+      Type_normal (
+        perform_io,
+        fun pos cmd ->
+          try seek pos cmd
+          with e when Lwt.Exception_filter.run e -> Lwt.fail e
+    );
   } and wrapper = {
     state = Idle;
     channel = ch;