From c233ce39dd4be632238faba62e93ff4b9a48766e Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 8 Oct 2013 19:03:33 +0100 Subject: [PATCH] debug: Print the name of goals that run, and goals required. --- goaljobs.ml | 22 +++++++++++++++++++++- goaljobs.mli | 6 +++++- pa_goal.ml | 18 +++++++++++++----- 3 files changed, 39 insertions(+), 7 deletions(-) diff --git a/goaljobs.ml b/goaljobs.ml index 4e3c07b..fcbcf23 100644 --- a/goaljobs.ml +++ b/goaljobs.ml @@ -33,11 +33,31 @@ exception Goal_result of goal_result_t let goal_failed msg = raise (Goal_result (Goal_failed msg)) +let depth = ref 0 +let indent fs = + let do_indent str = + prerr_string "| "; + for i = 0 to !depth-1 do prerr_string " " done; + prerr_string str; + Pervasives.flush Pervasives.stderr + in + ksprintf do_indent fs + let target v = if v then raise (Goal_result Goal_OK) let target_all vs = target (List.fold_left (&&) true vs) let target_exists vs = target (List.fold_left (||) false vs) -let require f = f () +let require name f = + indent "require: %s\n" name; + incr depth; + let r = (try Either (f ()) with exn -> Or exn) in + decr depth; + match r with + | Either x -> x + | Or exn -> raise exn + +let _enter_goal name = indent "enter goal: %s\n" name +let _leave_goal name = indent "leave goal: %s\n" name type period_t = Seconds | Days | Months | Years let seconds = (1, Seconds) diff --git a/goaljobs.mli b/goaljobs.mli index a6361c5..43432f1 100644 --- a/goaljobs.mli +++ b/goaljobs.mli @@ -70,7 +70,7 @@ val target_exists : bool list -> unit (** [target_exists [t1; t2; ...]] is the same as writing [target (t1 || t2 || ...)] *) -val require : (unit -> unit) -> unit +val require : string -> (unit -> unit) -> unit (** [require] {i goal} defines the requirements of this goal, that is, other goals that have to be met before the rest of the goal is able to run. @@ -343,3 +343,7 @@ val init : unit -> unit (* Export this so the macros can catch these exceptions. *) type goal_result_t = Goal_OK | Goal_failed of string exception Goal_result of goal_result_t + +(* Called to print debug message when we enter or leave a goal. *) +val _enter_goal : string -> unit +val _leave_goal : string -> unit diff --git a/pa_goal.ml b/pa_goal.ml index 20df4fa..c95095c 100644 --- a/pa_goal.ml +++ b/pa_goal.ml @@ -91,6 +91,8 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) = (* Define a goal name which the body may use. *) let goalname = $str:name$ in + _enter_goal goalname; + (* Source location. *) let goalloc = $str:goalloc$ in @@ -114,6 +116,7 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) = $body$ ; _call_onruns (); _call_onsuccesses (); + _leave_goal goalname; (* Avoid a compiler warning: *) ignore (goalname); ignore (goalloc) @@ -123,9 +126,11 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) = * ordinary function exit. *) | Goal_result Goal_OK -> + _leave_goal goalname; _call_onsuccesses (); () | exn -> + _leave_goal goalname; _call_onfails exn; raise exn >> in @@ -155,7 +160,7 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) = let () = publish $str:name$ ( function | [] -> - Goaljobs.require $lid:gname$ + Goaljobs.require $str:name$ $lid:gname$ | _ -> failwith (Printf.sprintf "goal '%s' does not take any arguments" $str:name$); @@ -174,14 +179,17 @@ let generate_require _loc expr = let rec rewrite = function | ExApp (_loc, ExId (_loc1, IdLid (_loc2, name)), right) -> let gname = "goal_" ^ name in - ExApp (_loc, ExId (_loc1, IdLid (_loc2, gname)), right) + ExApp (_loc, ExId (_loc1, IdLid (_loc2, gname)), right), name + | ExApp (_loc, (ExApp _ as expr), right) -> - ExApp (_loc, rewrite expr, right) + let expr, name = rewrite expr in + ExApp (_loc, expr, right), name + | _ -> locfail _loc "require (...) expression must contain a call to a goal" in - let expr = rewrite expr in - <:expr< Goaljobs.require (fun () -> $expr$) >> + let expr, name = rewrite expr in + <:expr< Goaljobs.require $str:name$ (fun () -> $expr$) >> ;; -- 1.8.3.1