Merge PR #13377: Fix timeout by ensuring signal exceptions are not erroneously caught

Reviewed-by: ppedrot

4 files changed, 9 insertions, 19 deletions

diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml
index 4c7ed9047d..38ec668884 100644
--- a/engine/logic_monad.ml
+++ b/engine/logic_monad.ml
@@ -99,7 +99,7 @@ struct
   let print_char = fun c -> (); fun () -> print_char c
 
   let timeout = fun n t -> (); fun () ->
-    Control.timeout n t () (Exception Tac_Timeout)
+    Control.timeout n t ()
 
   let make f = (); fun () ->
     try f ()
diff --git a/engine/logic_monad.mli b/engine/logic_monad.mli
index 7df29c6653..7784b38c80 100644
--- a/engine/logic_monad.mli
+++ b/engine/logic_monad.mli
@@ -74,7 +74,7 @@ module NonLogical : sig
 
   (** [try ... with ...] but restricted to {!Exception}. *)
   val catch : 'a t -> (Exninfo.iexn -> 'a t) -> 'a t
-  val timeout : int -> 'a t -> 'a t
+  val timeout : int -> 'a t -> 'a option t
 
   (** Construct a monadified side-effect. Exceptions raised by the argument are
       wrapped with {!Exception}. *)
diff --git a/engine/proofview.ml b/engine/proofview.ml
index 978088872c..22863f451d 100644
--- a/engine/proofview.ml
+++ b/engine/proofview.ml
@@ -937,22 +937,12 @@ let tclTIMEOUT n t =
   Proof.get >>= fun initial ->
   Proof.current >>= fun envvar ->
   Proof.lift begin
-    Logic_monad.NonLogical.catch
-      begin
-        let open Logic_monad.NonLogical in
-        timeout n (Proof.repr (Proof.run t envvar initial)) >>= fun r ->
-        match r with
-        | Logic_monad.Nil e -> return (Util.Inr e)
-        | Logic_monad.Cons (r, _) -> return (Util.Inl r)
-      end
-      begin let open Logic_monad.NonLogical in function (e, info) ->
-        match e with
-        | Logic_monad.Tac_Timeout ->
-          return (Util.Inr (Logic_monad.Tac_Timeout, info))
-        | Logic_monad.TacticFailure e ->
-          return (Util.Inr (e, info))
-        | e -> Logic_monad.NonLogical.raise (e, info)
-      end
+    let open Logic_monad.NonLogical in
+    timeout n (Proof.repr (Proof.run t envvar initial)) >>= fun r ->
+    match r with
+    | None -> return (Util.Inr (Logic_monad.Tac_Timeout, Exninfo.null))
+    | Some (Logic_monad.Nil e) -> return (Util.Inr e)
+    | Some (Logic_monad.Cons (r, _)) -> return (Util.Inl r)
   end >>= function
     | Util.Inl (res,s,m,i) ->
         Proof.set s >>
diff --git a/engine/proofview.mli b/engine/proofview.mli
index 816b45984b..fe0d7ae51e 100644
--- a/engine/proofview.mli
+++ b/engine/proofview.mli
@@ -417,7 +417,7 @@ end
 val tclCHECKINTERRUPT : unit tactic
 
 (** [tclTIMEOUT n t] can have only one success.
-    In case of timeout if fails with [tclZERO Timeout]. *)
+    In case of timeout it fails with [tclZERO Tac_Timeout]. *)
 val tclTIMEOUT : int -> 'a tactic -> 'a tactic
 
 (** [tclTIME s t] displays time for each atomic call to t, using s as an