STM: hook called whenever a state is unreachable

Even indirectly, if it depends on another state that in turn failed.

2 files changed, 7 insertions, 1 deletions

diff --git a/stm/stm.ml b/stm/stm.ml
index 35c7239135..1c51c56a02 100644
--- a/stm/stm.ml
+++ b/stm/stm.ml
@@ -46,6 +46,9 @@ let execution_error, execution_error_hook = Hook.make
  ~default:(fun state_id loc msg ->
     feedback ~state_id (Feedback.ErrorMsg (loc, string_of_ppcmds msg))) ()
 
+let unreachable_state, unreachable_state_hook = Hook.make
+ ~default:(fun _ -> ()) ()
+
 include Hook
 
 (* enables:  Hooks.(call foo args) *)
@@ -667,6 +670,7 @@ end = struct (* {{{ *)
       let good_id = !cur_id in
       cur_id := Stateid.dummy;
       VCS.reached id false;
+      Hooks.(call unreachable_state id);
       match Stateid.get e, safe_id with
       | None, None -> raise (exn_on id ~valid:good_id e)
       | None, Some good_id -> raise (exn_on id ~valid:good_id e)
@@ -2389,5 +2393,6 @@ let forward_feedback_hook = Hooks.forward_feedback_hook
 let process_error_hook = Hooks.process_error_hook
 let interp_hook = Hooks.interp_hook
 let with_fail_hook = Hooks.with_fail_hook
+let unreachable_state_hook = Hooks.unreachable_state_hook
 
 (* vim:set foldmethod=marker: *)
diff --git a/stm/stm.mli b/stm/stm.mli
index 3dd0764dd4..475a367b30 100644
--- a/stm/stm.mli
+++ b/stm/stm.mli
@@ -92,7 +92,7 @@ module QueryTask : AsyncTaskQueue.Task
 (** customization ********************************************************** **)
 
 (* From the master (or worker, but beware that to install the hook
- * into a worker one has to build the wroker toplevel to do so and
+ * into a worker one has to build the worker toploop to do so and
  * the alternative toploop for the worker can be selected by changing
  * the name of the Task(s) above) *)
 
@@ -100,6 +100,7 @@ val state_computed_hook : (Stateid.t -> in_cache:bool -> unit) Hook.t
 val parse_error_hook :
   (Feedback.edit_or_state_id -> Loc.t -> Pp.std_ppcmds -> unit) Hook.t
 val execution_error_hook : (Stateid.t -> Loc.t -> Pp.std_ppcmds -> unit) Hook.t
+val unreachable_state_hook : (Stateid.t -> unit) Hook.t
 
 (* Messages from the workers to the master *)
 val forward_feedback_hook : (Feedback.feedback -> unit) Hook.t