Make exception filtering optional

CHANGES

@@ -18,6 +18,7 @@
 
 ====== Additions ======
 
+  * Lwt.set_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,12 +710,18 @@ struct
 end
 open Basic_helpers
 
-
-(* Small helper function to avoid catching ocaml-runtime exceptions *)
-let is_not_ocaml_runtime_exception = function
+(* Small helpers to avoid catching ocaml-runtime exceptions *)
+type exception_filter = exn -> bool
+let catch_all_filter = fun _ -> true
+let catch_not_runtime_filter = function
   | Out_of_memory -> false
   | Stack_overflow -> false
   | _ -> true
+let exception_filter =
+  (* Default value: the legacy behaviour to avoid breaking programs *)
+  ref catch_all_filter
+let set_exception_filter f = exception_filter := f
+let filter_exception e = !exception_filter e
 
 module Sequence_associated_storage :
 sig
@@ -796,7 +802,7 @@ struct
       let result = f () in
       current_storage := saved_storage;
       result
-    with exn when is_not_ocaml_runtime_exception exn ->
+    with exn when !exception_filter exn ->
       current_storage := saved_storage;
       raise exn
 end
@@ -1134,7 +1140,7 @@ 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 when is_not_ocaml_runtime_exception exn ->
+    with exn when !exception_filter exn ->
       !async_exception_hook exn
 
 
@@ -1834,7 +1840,7 @@ struct
 
           let p' =
             try f v with exn
-            when is_not_ocaml_runtime_exception exn -> fail exn
+            when !exception_filter exn -> fail exn
           in
           let Internal p' = to_internal_promise p' in
           (* Run the user's function [f]. *)
@@ -1900,7 +1906,7 @@ struct
 
           let p' =
             try f v
-            with exn when is_not_ocaml_runtime_exception exn ->
+            with exn when !exception_filter exn ->
               fail (add_loc exn) in
           let Internal p' = to_internal_promise p' in
 
@@ -1957,7 +1963,7 @@ struct
 
           let p''_result =
             try Fulfilled (f v) with exn
-            when is_not_ocaml_runtime_exception exn -> Rejected exn
+            when !exception_filter exn -> Rejected exn
           in
 
           let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in
@@ -1987,7 +1993,7 @@ struct
           to_public_promise
             {state =
               try Fulfilled (f v)
-              with exn when is_not_ocaml_runtime_exception exn -> Rejected exn})
+              with exn when !exception_filter exn -> Rejected exn})
         ~if_deferred:(fun () ->
           let (p'', callback) =
             create_result_promise_and_callback_if_deferred () in
@@ -2006,7 +2012,7 @@ struct
   let catch f h =
     let p =
       try f ()
-      with exn when is_not_ocaml_runtime_exception exn -> fail exn
+      with exn when !exception_filter exn -> fail exn
     in
     let Internal p = to_internal_promise p in
     let p = underlying p in
@@ -2031,7 +2037,7 @@ struct
 
           let p' =
             try h exn
-            with exn when is_not_ocaml_runtime_exception exn -> fail exn
+            with exn when !exception_filter exn -> fail exn
           in
           let Internal p' = to_internal_promise p' in
 
@@ -2067,7 +2073,7 @@ struct
   let backtrace_catch add_loc f h =
     let p =
       try f ()
-      with exn when is_not_ocaml_runtime_exception exn -> fail exn
+      with exn when !exception_filter exn -> fail exn
     in
     let Internal p = to_internal_promise p in
     let p = underlying p in
@@ -2092,7 +2098,7 @@ struct
 
           let p' =
             try h exn
-            with exn when is_not_ocaml_runtime_exception exn ->
+            with exn when !exception_filter exn ->
               fail (add_loc exn)
           in
           let Internal p' = to_internal_promise p' in
@@ -2129,7 +2135,7 @@ struct
   let try_bind f f' h =
     let p =
       try f ()
-      with exn when is_not_ocaml_runtime_exception exn -> fail exn
+      with exn when !exception_filter exn -> fail exn
     in
     let Internal p = to_internal_promise p in
     let p = underlying p in
@@ -2146,7 +2152,7 @@ struct
 
           let p' =
             try f' v
-            with exn when is_not_ocaml_runtime_exception exn -> fail exn
+            with exn when !exception_filter exn -> fail exn
           in
           let Internal p' = to_internal_promise p' in
 
@@ -2162,7 +2168,7 @@ struct
 
           let p' =
             try h exn
-            with exn when is_not_ocaml_runtime_exception exn -> fail exn
+            with exn when !exception_filter exn -> fail exn
           in
           let Internal p' = to_internal_promise p' in
 
@@ -2204,7 +2210,7 @@ struct
   let backtrace_try_bind add_loc f f' h =
     let p =
       try f ()
-      with exn when is_not_ocaml_runtime_exception exn -> fail exn
+      with exn when !exception_filter exn -> fail exn
     in
     let Internal p = to_internal_promise p in
     let p = underlying p in
@@ -2221,7 +2227,7 @@ struct
 
           let p' =
             try f' v
-            with exn when is_not_ocaml_runtime_exception exn ->
+            with exn when !exception_filter exn ->
               fail (add_loc exn)
           in
           let Internal p' = to_internal_promise p' in
@@ -2238,7 +2244,7 @@ struct
 
           let p' =
             try h exn
-            with exn when is_not_ocaml_runtime_exception exn ->
+            with exn when !exception_filter exn ->
               fail (add_loc exn)
           in
           let Internal p' = to_internal_promise p' in
@@ -2493,7 +2499,7 @@ struct
   let dont_wait f h =
     let p =
       try f ()
-      with exn when is_not_ocaml_runtime_exception exn -> fail exn
+      with exn when !exception_filter exn -> fail exn
     in
     let Internal p = to_internal_promise p in
 
@@ -2516,7 +2522,7 @@ struct
   let async f =
     let p =
       try f ()
-      with exn when is_not_ocaml_runtime_exception exn -> fail exn
+      with exn when !exception_filter exn -> fail exn
     in
     let Internal p = to_internal_promise p in
 
@@ -3119,39 +3125,39 @@ struct
 
 
   let apply f x =
-    try f x with exn when is_not_ocaml_runtime_exception exn -> fail exn
+    try f x with exn when !exception_filter exn -> fail exn
 
   let wrap f =
     try return (f ())
-    with exn when is_not_ocaml_runtime_exception exn -> fail exn
+    with exn when !exception_filter exn -> fail exn
 
   let wrap1 f x1 =
     try return (f x1)
-    with exn when is_not_ocaml_runtime_exception exn -> fail exn
+    with exn when !exception_filter exn -> fail exn
 
   let wrap2 f x1 x2 =
     try return (f x1 x2)
-    with exn when is_not_ocaml_runtime_exception exn -> fail exn
+    with exn when !exception_filter exn -> fail exn
 
   let wrap3 f x1 x2 x3 =
     try return (f x1 x2 x3)
-    with exn when is_not_ocaml_runtime_exception exn -> fail exn
+    with exn when !exception_filter exn -> fail exn
 
   let wrap4 f x1 x2 x3 x4 =
     try return (f x1 x2 x3 x4)
-    with exn when is_not_ocaml_runtime_exception exn -> fail exn
+    with exn when !exception_filter exn -> fail exn
 
   let wrap5 f x1 x2 x3 x4 x5 =
     try return (f x1 x2 x3 x4 x5)
-    with exn when is_not_ocaml_runtime_exception exn -> fail exn
+    with exn when !exception_filter exn -> fail exn
 
   let wrap6 f x1 x2 x3 x4 x5 x6 =
     try return (f x1 x2 x3 x4 x5 x6)
-    with exn when is_not_ocaml_runtime_exception exn -> fail exn
+    with exn when !exception_filter 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 when is_not_ocaml_runtime_exception exn -> fail exn
+    with exn when !exception_filter exn -> fail exn
 
 
 

src/core/lwt.mli

@@ -1999,15 +1999,43 @@ 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. 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]. *)
+
+(** An [exception_filter] 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 exception_filter
+
+(** [catch_all_filter] is the default filter. With it the all the exceptions
+    (including [Out_of_memory] and [Stack_overflow]) are caught and transformed
+    into rejected promises. *)
+val catch_all_filter : exception_filter
+
+(** [catch_not_runtime_filter] 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]. *)
+val catch_not_runtime_filter : exception_filter
+
+(** [set_exception_filter] sets the given exception filter globally. *)
+val set_exception_filter : exception_filter -> unit
+
 
 
 (**/**)
 
 val poll : 'a t -> 'a option
 val apply : ('a -> 'b t) -> 'a -> 'b t
 
-val is_not_ocaml_runtime_exception : exn -> bool
-
 val backtrace_bind :
   (exn -> exn) -> 'a t -> ('a -> 'b t) -> 'b t
 val backtrace_catch :
@@ -2020,3 +2048,5 @@ val backtrace_try_bind :
 val abandon_wakeups : unit -> unit
 
 val debug_state_is : 'a state -> 'a t -> bool t
+
+val filter_exception : exn -> bool

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 when Lwt.is_not_ocaml_runtime_exception exc -> Lwt.fail exc
+  | exception exc when Lwt.filter_exception 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 when Lwt.is_not_ocaml_runtime_exception exn -> Lwt.fail exn
+  | exception exn when Lwt.filter_exception 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 when Lwt.is_not_ocaml_runtime_exception exc -> Lwt.fail exc
+    | exception exc when Lwt.filter_exception exc -> Lwt.fail exc

src/react/lwt_react.ml

@@ -98,7 +98,7 @@ module E = struct
       Lwt_stream.iter
         (fun v ->
           try push v
-          with exn when Lwt.is_not_ocaml_runtime_exception exn ->
+          with exn when Lwt.filter_exception exn ->
             !Lwt.async_exception_hook exn)
         stream in
     with_finaliser (cancel_thread t) event

src/unix/lwt_io.ml

@@ -537,7 +537,7 @@ let make :
         perform_io,
         fun pos cmd ->
           try seek pos cmd
-          with e when Lwt.is_not_ocaml_runtime_exception e -> Lwt.fail e
+          with e when Lwt.filter_exception e -> Lwt.fail e
     );
   } and wrapper = {
     state = Idle;

src/unix/lwt_main.ml

@@ -119,7 +119,7 @@ let run p =
   | result ->
     finished ();
     result
-  | exception exn when Lwt.is_not_ocaml_runtime_exception exn ->
+  | exception exn when Lwt.filter_exception exn ->
     finished ();
     raise exn
 

src/unix/lwt_preemptive.ml

@@ -182,7 +182,7 @@ let detach f args =
   let task () =
     try
       result := Result.Ok (f args)
-    with exn when Lwt.is_not_ocaml_runtime_exception exn ->
+    with exn when Lwt.filter_exception exn ->
       result := Result.Error exn
   in
   get_worker () >>= fun worker ->

src/unix/lwt_timeout.ml

@@ -72,7 +72,7 @@ let rec loop () =
       (*XXX Should probably report any exception *)
       try
         x.action ()
-      with e when Lwt.is_not_ocaml_runtime_exception e ->
+      with e when Lwt.filter_exception e ->
         !handle_exn e
     done;
     curr := (!curr + 1) mod (Array.length !buckets);