handle exceptions properly
This commit is contained in:
parent
f7b51ed1a0
commit
0dd0511581
|
@ -77,8 +77,7 @@ module Build_error = struct
|
||||||
|
|
||||||
exception E of t
|
exception E of t
|
||||||
|
|
||||||
let raise ~targeting exn =
|
let raise ~targeting ~backtrace exn =
|
||||||
let backtrace = Printexc.get_raw_backtrace () in
|
|
||||||
let rec build_path acc targeting ~seen =
|
let rec build_path acc targeting ~seen =
|
||||||
assert (not (Pset.mem targeting seen));
|
assert (not (Pset.mem targeting seen));
|
||||||
let seen = Pset.add targeting seen in
|
let seen = Pset.add targeting seen in
|
||||||
|
@ -109,12 +108,11 @@ let wait_for_file fn ~targeting =
|
||||||
| Not_started f ->
|
| Not_started f ->
|
||||||
file.rule.exec <- Starting { for_file = targeting };
|
file.rule.exec <- Starting { for_file = targeting };
|
||||||
let future =
|
let future =
|
||||||
try
|
with_exn_handler (fun () -> f ~targeting:fn)
|
||||||
f ~targeting:fn
|
~handler:(fun exn backtrace ->
|
||||||
with
|
match exn with
|
||||||
| Build_error.E _ as exn -> raise exn
|
| Build_error.E _ -> reraise exn
|
||||||
| exn ->
|
| exn -> Build_error.raise exn ~targeting:fn ~backtrace)
|
||||||
Build_error.raise ~targeting:fn exn
|
|
||||||
in
|
in
|
||||||
file.rule.exec <- Running { for_file = targeting; future };
|
file.rule.exec <- Running { for_file = targeting; future };
|
||||||
future
|
future
|
||||||
|
|
|
@ -1,5 +1,7 @@
|
||||||
open Import
|
open Import
|
||||||
|
|
||||||
|
type exn_handler = exn -> Printexc.raw_backtrace -> unit
|
||||||
|
|
||||||
type 'a t = { mutable state : 'a state }
|
type 'a t = { mutable state : 'a state }
|
||||||
|
|
||||||
and 'a state =
|
and 'a state =
|
||||||
|
@ -9,9 +11,11 @@ and 'a state =
|
||||||
|
|
||||||
and 'a handlers =
|
and 'a handlers =
|
||||||
| Empty
|
| Empty
|
||||||
| One of ('a -> unit)
|
| One of exn_handler * ('a -> unit)
|
||||||
| Append of 'a handlers * 'a handlers
|
| Append of 'a handlers * 'a handlers
|
||||||
|
|
||||||
|
let exn_handler = ref (fun exn _ -> reraise exn)
|
||||||
|
|
||||||
let append h1 h2 =
|
let append h1 h2 =
|
||||||
match h1, h2 with
|
match h1, h2 with
|
||||||
| Empty, _ -> h2
|
| Empty, _ -> h2
|
||||||
|
@ -25,15 +29,26 @@ let rec repr t =
|
||||||
|
|
||||||
let run_handlers handlers x =
|
let run_handlers handlers x =
|
||||||
let rec loop handlers acc =
|
let rec loop handlers acc =
|
||||||
match handlers, acc with
|
match handlers with
|
||||||
| Empty, [] -> ()
|
| Empty -> continue acc
|
||||||
| Empty, h :: acc -> loop h acc
|
| One (handler, f) ->
|
||||||
| One f, [] -> f x
|
exn_handler := handler;
|
||||||
| One f, h :: acc -> f x; loop h acc
|
(try
|
||||||
| Append (h1, h2), _ -> loop h1 (h2 :: acc)
|
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
|
in
|
||||||
loop handlers []
|
protectx !exn_handler
|
||||||
|
~finally:(fun saved ->
|
||||||
|
exn_handler := saved)
|
||||||
|
~f:(fun _ ->
|
||||||
|
loop handlers [])
|
||||||
|
|
||||||
let connect t1 t2 =
|
let connect t1 t2 =
|
||||||
let t1 = repr t1 and t2 = repr t2 in
|
let t1 = repr t1 and t2 = repr t2 in
|
||||||
|
@ -64,13 +79,22 @@ let ( >>= ) t f =
|
||||||
| Return v -> f v
|
| Return v -> f v
|
||||||
| Sleep handlers ->
|
| Sleep handlers ->
|
||||||
let res = sleeping () in
|
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
|
res
|
||||||
| Repr _ ->
|
| Repr _ ->
|
||||||
assert false
|
assert false
|
||||||
|
|
||||||
let ( >>| ) t f = t >>= fun x -> return (f x)
|
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 =
|
let both a b =
|
||||||
a >>= fun a ->
|
a >>= fun a ->
|
||||||
b >>= fun b ->
|
b >>= fun b ->
|
||||||
|
@ -97,7 +121,7 @@ end
|
||||||
let rec all = function
|
let rec all = function
|
||||||
| [] -> return []
|
| [] -> return []
|
||||||
| x :: l ->
|
| x :: l ->
|
||||||
x >>= fun x ->
|
x >>= fun x ->
|
||||||
all l >>= fun l ->
|
all l >>= fun l ->
|
||||||
return (x :: l)
|
return (x :: l)
|
||||||
|
|
||||||
|
|
|
@ -11,6 +11,8 @@ val both : 'a t -> 'b t -> ('a * 'b) t
|
||||||
val all : 'a t list -> 'a list t
|
val all : 'a t list -> 'a list t
|
||||||
val all_unit : unit t list -> unit 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 *)
|
(** [run ?dir ?stdout_to prog args] spawns a sub-process and wait for its termination *)
|
||||||
val run
|
val run
|
||||||
: ?dir:string
|
: ?dir:string
|
||||||
|
|
|
@ -2,6 +2,8 @@ module Array = StdLabels.Array
|
||||||
module Bytes = StdLabels.Bytes
|
module Bytes = StdLabels.Bytes
|
||||||
module Set = MoreLabels.Set
|
module Set = MoreLabels.Set
|
||||||
|
|
||||||
|
external reraise : exn -> _ = "%reraise"
|
||||||
|
|
||||||
let open_in = open_in_bin
|
let open_in = open_in_bin
|
||||||
let open_out = open_out_bin
|
let open_out = open_out_bin
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue