aboutsummaryrefslogtreecommitdiff
path: root/plugins/ltac
diff options
context:
space:
mode:
Diffstat (limited to 'plugins/ltac')
-rw-r--r--plugins/ltac/profile_ltac.ml29
-rw-r--r--plugins/ltac/profile_ltac.mli37
-rw-r--r--plugins/ltac/profile_ltac_tactics.ml436
-rw-r--r--plugins/ltac/rewrite.ml11
-rw-r--r--plugins/ltac/tacinterp.ml16
5 files changed, 113 insertions, 16 deletions
diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml
index 5225420dc4..1615465281 100644
--- a/plugins/ltac/profile_ltac.ml
+++ b/plugins/ltac/profile_ltac.ml
@@ -289,7 +289,7 @@ let rec find_in_stack what acc = function
| { name } as x :: rest when String.equal name what -> Some(acc, x, rest)
| { name } as x :: rest -> find_in_stack what (x :: acc) rest
-let exit_tactic start_time c =
+let exit_tactic ~count_call start_time c =
let diff = time () -. start_time in
match Local.(!stack) with
| [] | [_] ->
@@ -304,7 +304,7 @@ let exit_tactic start_time c =
let node = { node with
total = node.total +. diff;
local = node.local +. diff;
- ncalls = node.ncalls + 1;
+ ncalls = node.ncalls + (if count_call then 1 else 0);
max_total = max node.max_total diff;
} in
(* updating the stack *)
@@ -341,7 +341,7 @@ let tclFINALLY tac (finally : unit Proofview.tactic) =
(fun v -> finally <*> Proofview.tclUNIT v)
(fun (exn, info) -> finally <*> Proofview.tclZERO ~info exn)
-let do_profile s call_trace tac =
+let do_profile s call_trace ?(count_call=true) tac =
let open Proofview.Notations in
Proofview.tclLIFT (Proofview.NonLogical.make (fun () ->
if !is_profiling then
@@ -359,7 +359,7 @@ let do_profile s call_trace tac =
tac
(Proofview.tclLIFT (Proofview.NonLogical.make (fun () ->
(match call_trace with
- | (_, c) :: _ -> exit_tactic start_time c
+ | (_, c) :: _ -> exit_tactic ~count_call start_time c
| [] -> ()))))
| None -> tac
@@ -397,6 +397,27 @@ let reset_profile () =
reset_profile_tmp ();
data := SM.empty
+(* ****************************** Named timers ****************************** *)
+
+let timer_data = ref M.empty
+
+let timer_name = function
+ | Some v -> v
+ | None -> ""
+
+let restart_timer name =
+ timer_data := M.add (timer_name name) (System.get_time ()) !timer_data
+
+let get_timer name =
+ try M.find (timer_name name) !timer_data
+ with Not_found -> System.get_time ()
+
+let finish_timing ~prefix name =
+ let tend = System.get_time () in
+ let tstart = get_timer name in
+ Feedback.msg_info(str prefix ++ pr_opt str name ++ str " ran for " ++
+ System.fmt_time_difference tstart tend)
+
(* ******************** *)
let print_results_filter ~cutoff ~filter =
diff --git a/plugins/ltac/profile_ltac.mli b/plugins/ltac/profile_ltac.mli
index 52827cb36b..adedf7ee91 100644
--- a/plugins/ltac/profile_ltac.mli
+++ b/plugins/ltac/profile_ltac.mli
@@ -9,9 +9,39 @@
(** Ltac profiling primitives *)
+(* Note(JasonGross): Ltac semantics are a bit insane. There isn't
+ really a good notion of how many times a tactic has been "called",
+ because tactics can be partially evaluated, and it's unclear
+ whether the number of "calls" should be the number of times the
+ body is fetched and unfolded, or the number of times the code is
+ executed to a value, etc. The logic in [Tacinterp.eval_tactic]
+ gives a decent approximation, which I believe roughly corresponds
+ to the number of times that the engine runs the tactic value which
+ results from evaluating the tactic expression bound to the name
+ we're considering. However, this is a poor approximation of the
+ time spent in the tactic; we want to consider time spent evaluating
+ a tactic expression to a tactic value to be time spent in the
+ expression, not just time spent in the caller of the expression.
+ So we need to wrap some nodes in additional profiling calls which
+ don't count towards to total call count. Whether or not a call
+ "counts" is indicated by the [count_call] boolean argument.
+
+ Unfortunately, at present, we can get very strange call graphs when
+ a named tactic expression never runs as a tactic value: if we have
+ [Ltac t0 := t.] and [Ltac t1 := t0.], then [t1] is considered to
+ run 0(!) times. It evaluates to [t] during tactic expression
+ evaluation, and although the call trace records the fact that it
+ was called by [t0] which was called by [t1], the tactic running
+ phase never sees this. Thus we get one call tree (from expression
+ evaluation) that has [t1] calls [t0] calls [t], and another call
+ tree which says that the caller of [t1] calls [t] directly; the
+ expression evaluation time goes in the first tree, and the call
+ count and tactic running time goes in the second tree. Alas, I
+ suspect that fixing this requires a redesign of how the profiler
+ hooks into the tactic engine. *)
val do_profile :
string -> ('a * Tacexpr.ltac_call_kind) list ->
- 'b Proofview.tactic -> 'b Proofview.tactic
+ ?count_call:bool -> 'b Proofview.tactic -> 'b Proofview.tactic
val set_profiling : bool -> unit
@@ -22,6 +52,10 @@ val print_results_tactic : string -> unit
val reset_profile : unit -> unit
+val restart_timer : string option -> unit
+
+val finish_timing : prefix:string -> string option -> unit
+
val do_print_results_at_close : unit -> unit
(* The collected statistics for a tactic. The timing data is collected over all
@@ -46,4 +80,3 @@ type treenode = {
(* Returns the profiling results known by the current process *)
val get_local_profiling_results : unit -> treenode
val feedback_results : treenode -> unit
-
diff --git a/plugins/ltac/profile_ltac_tactics.ml4 b/plugins/ltac/profile_ltac_tactics.ml4
index f095660638..9864ffeb65 100644
--- a/plugins/ltac/profile_ltac_tactics.ml4
+++ b/plugins/ltac/profile_ltac_tactics.ml4
@@ -18,6 +18,21 @@ DECLARE PLUGIN "ltac_plugin"
let tclSET_PROFILING b =
Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> set_profiling b))
+let tclRESET_PROFILE =
+ Proofview.tclLIFT (Proofview.NonLogical.make reset_profile)
+
+let tclSHOW_PROFILE ~cutoff =
+ Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> print_results ~cutoff))
+
+let tclSHOW_PROFILE_TACTIC s =
+ Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> print_results_tactic s))
+
+let tclRESTART_TIMER s =
+ Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> restart_timer s))
+
+let tclFINISH_TIMING ?(prefix="Timer") (s : string option) =
+ Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> finish_timing ~prefix s))
+
TACTIC EXTEND start_ltac_profiling
| [ "start" "ltac" "profiling" ] -> [ tclSET_PROFILING true ]
END
@@ -26,8 +41,27 @@ TACTIC EXTEND stop_ltac_profiling
| [ "stop" "ltac" "profiling" ] -> [ tclSET_PROFILING false ]
END
+TACTIC EXTEND reset_ltac_profile
+| [ "reset" "ltac" "profile" ] -> [ tclRESET_PROFILE ]
+END
+
+TACTIC EXTEND show_ltac_profile
+| [ "show" "ltac" "profile" ] -> [ tclSHOW_PROFILE ~cutoff:!Flags.profile_ltac_cutoff ]
+| [ "show" "ltac" "profile" "cutoff" int(n) ] -> [ tclSHOW_PROFILE ~cutoff:(float_of_int n) ]
+| [ "show" "ltac" "profile" string(s) ] -> [ tclSHOW_PROFILE_TACTIC s ]
+END
+
+TACTIC EXTEND restart_timer
+| [ "restart_timer" string_opt(s) ] -> [ tclRESTART_TIMER s ]
+END
+
+TACTIC EXTEND finish_timing
+| [ "finish_timing" string_opt(s) ] -> [ tclFINISH_TIMING ~prefix:"Timer" s ]
+| [ "finish_timing" "(" string(prefix) ")" string_opt(s) ] -> [ tclFINISH_TIMING ~prefix s ]
+END
+
VERNAC COMMAND EXTEND ResetLtacProfiling CLASSIFIED AS SIDEFF
- [ "Reset" "Ltac" "Profile" ] -> [ reset_profile() ]
+ [ "Reset" "Ltac" "Profile" ] -> [ reset_profile () ]
END
VERNAC COMMAND EXTEND ShowLtacProfile CLASSIFIED AS QUERY
diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml
index 2e14243d8a..a698b05dd7 100644
--- a/plugins/ltac/rewrite.ml
+++ b/plugins/ltac/rewrite.ml
@@ -1781,7 +1781,9 @@ let declare_an_instance n s args =
let declare_instance a aeq n s = declare_an_instance n s [a;aeq]
let anew_instance global binders instance fields =
- new_instance (Flags.is_universe_polymorphism ())
+ let program_mode = Flags.is_program_mode () in
+ let poly = Flags.is_universe_polymorphism () in
+ new_instance ~program_mode poly
binders instance (Some (true, CAst.make @@ CRecord (fields)))
~global ~generalize:false ~refine:false Hints.empty_hint_info
@@ -2012,9 +2014,10 @@ let add_morphism glob binders m s n =
[cHole; s; m]))
in
let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in
- ignore(new_instance ~global:glob poly binders instance
- (Some (true, CAst.make @@ CRecord []))
- ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info)
+ let program_mode = Flags.is_program_mode () in
+ ignore(new_instance ~program_mode ~global:glob poly binders instance
+ (Some (true, CAst.make @@ CRecord []))
+ ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info)
(** Bind to "rewrite" too *)
diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml
index ded902a8fb..ccded44179 100644
--- a/plugins/ltac/tacinterp.ml
+++ b/plugins/ltac/tacinterp.ml
@@ -1158,10 +1158,14 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with
Proofview.V82.tactic begin
tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac))
end
- | TacAbstract (tac,ido) ->
+ | TacAbstract (t,ido) ->
+ let call = LtacMLCall tac in
+ push_trace(None,call) ist >>= fun trace ->
+ Profile_ltac.do_profile "eval_tactic:TacAbstract" trace
+ (catch_error_tac trace begin
Proofview.Goal.enter begin fun gl -> Tactics.tclABSTRACT
- (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist tac)
- end
+ (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist t)
+ end end)
| TacThen (t1,t) ->
Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t)
| TacDispatch tl ->
@@ -1272,7 +1276,8 @@ and interp_ltac_reference ?loc' mustbetac ist r : Val.t Ftactic.t =
let extra = TacStore.set extra f_trace trace in
let ist = { lfun = Id.Map.empty; extra = extra; } in
let appl = GlbAppl[r,[]] in
- val_interp ~appl ist (Tacenv.interp_ltac r)
+ Profile_ltac.do_profile "interp_ltac_reference" trace ~count_call:false
+ (val_interp ~appl ist (Tacenv.interp_ltac r))
and interp_tacarg ist arg : Val.t Ftactic.t =
match arg with
@@ -1338,7 +1343,8 @@ and interp_app loc ist fv largs : Val.t Ftactic.t =
let ist = {
lfun = newlfun;
extra = TacStore.set ist.extra f_trace []; } in
- catch_error_tac trace (val_interp ist body) >>= fun v ->
+ Profile_ltac.do_profile "interp_app" trace ~count_call:false
+ (catch_error_tac trace (val_interp ist body)) >>= fun v ->
Ftactic.return (name_vfun (push_appl appl largs) v)
end
begin fun (e, info) ->
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-09 07:28:00 +0000