handle exceptions properly

src/build_system.ml

@@ -77,8 +77,7 @@ module Build_error = struct
 
   exception E of t
 
-  let raise ~targeting exn =
-    let backtrace = Printexc.get_raw_backtrace () in
+  let raise ~targeting ~backtrace exn =
     let rec build_path acc targeting ~seen =
       assert (not (Pset.mem targeting seen));
       let seen = Pset.add targeting seen in
@@ -109,12 +108,11 @@ let wait_for_file fn ~targeting =
     | Not_started f ->
       file.rule.exec <- Starting { for_file = targeting };
       let future =
-        try
-          f ~targeting:fn
-        with
-        | Build_error.E _ as exn -> raise exn
-        | exn ->
-          Build_error.raise ~targeting:fn exn
+        with_exn_handler (fun () -> f ~targeting:fn)
+          ~handler:(fun exn backtrace ->
+              match exn with
+              | Build_error.E _ -> reraise exn
+              | exn -> Build_error.raise exn ~targeting:fn ~backtrace)
       in
       file.rule.exec <- Running { for_file = targeting; future };
       future

src/future.ml

@@ -1,5 +1,7 @@
 open Import
 
+type exn_handler = exn -> Printexc.raw_backtrace -> unit
+
 type 'a t = { mutable state : 'a state }
 
 and 'a state =
@@ -9,9 +11,11 @@ and 'a state =
 
 and 'a handlers =
   | Empty
-  | One    of ('a -> unit)
+  | One    of exn_handler * ('a -> unit)
   | Append of 'a handlers * 'a handlers
 
+let exn_handler = ref (fun exn _ -> reraise exn)
+
 let append h1 h2 =
   match h1, h2 with
   | Empty, _ -> h2
@@ -25,15 +29,26 @@ let rec repr t =
 
 let run_handlers handlers x =
   let rec loop handlers acc =
-    match handlers, acc with
-    | Empty, [] -> ()
-    | Empty, h :: acc -> loop h acc
-    | One f, [] -> f x
-    | One f, h :: acc -> f x; loop h acc
-    | Append (h1, h2), _ -> loop h1 (h2 :: acc)
+    match handlers with
+    | Empty -> continue acc
+    | One (handler, f) ->
+      exn_handler := handler;
+      (try
+         f x
+       with exn ->
+         let bt = Printexc.get_raw_backtrace () in
+         handler exn bt);
+      continue acc
+    | Append (h1, h2) -> loop h1 (h2 :: acc)
+  and continue = function
+    | [] -> ()
+    | h :: acc -> loop h acc
   in
-  loop handlers []
-
+  protectx !exn_handler
+    ~finally:(fun saved ->
+        exn_handler := saved)
+    ~f:(fun _ ->
+        loop handlers [])
 
 let connect t1 t2 =
   let t1 = repr t1 and t2 = repr t2 in
@@ -64,13 +79,22 @@ let ( >>= ) t f =
   | Return v -> f v
   | Sleep handlers ->
     let res = sleeping () in
-    t.state <- Sleep (append handlers (One (fun x -> connect res (f x))));
+    t.state <- Sleep (append handlers (One (!exn_handler,
+                                            fun x -> connect res (f x))));
     res
   | Repr _ ->
     assert false
 
 let ( >>| ) t f = t >>= fun x -> return (f x)
 
+let with_exn_handler f ~handler =
+  protectx !exn_handler
+    ~finally:(fun saved ->
+        exn_handler := saved)
+    ~f:(fun _ ->
+        exn_handler := handler;
+        f ())
+
 let both a b =
   a >>= fun a ->
   b >>= fun b ->
@@ -97,7 +121,7 @@ end
 let rec all = function
   | [] -> return []
   | x :: l ->
-    x >>= fun x ->
+    x     >>= fun x ->
     all l >>= fun l ->
     return (x :: l)
 

src/future.mli

@@ -11,6 +11,8 @@ val both : 'a t -> 'b t -> ('a * 'b) t
 val all : 'a t list -> 'a list t
 val all_unit : unit t list -> unit t
 
+val with_exn_handler : (unit -> 'a) -> handler:(exn -> Printexc.raw_backtrace -> unit) -> 'a
+
 (** [run ?dir ?stdout_to prog args] spawns a sub-process and wait for its termination *)
 val run
   :  ?dir:string

src/import.ml

@@ -2,6 +2,8 @@ module Array   = StdLabels.Array
 module Bytes   = StdLabels.Bytes
 module Set     = MoreLabels.Set
 
+external reraise : exn -> _ = "%reraise"
+
 let open_in = open_in_bin
 let open_out = open_out_bin