handle exceptions properly
This commit is contained in:
parent
f7b51ed1a0
commit
0dd0511581
|
@ -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
|
||||
|
|
|
@ -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 ->
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
Loading…
Reference in New Issue