aboutsummaryrefslogtreecommitdiff
path: root/plugins
diff options
context:
space:
mode:
Diffstat (limited to 'plugins')
-rw-r--r--plugins/extraction/g_extraction.ml410
-rw-r--r--plugins/funind/g_indfun.ml42
-rw-r--r--plugins/funind/glob_term_to_relation.ml4
-rw-r--r--plugins/ltac/profile_ltac.ml21
-rw-r--r--plugins/ltac/profile_ltac.mli4
-rw-r--r--plugins/ltac/profile_ltac_tactics.ml436
-rw-r--r--plugins/ltac/taccoerce.ml18
-rw-r--r--plugins/ltac/taccoerce.mli3
-rw-r--r--plugins/ltac/tacinterp.ml23
-rw-r--r--plugins/micromega/MExtraction.v17
10 files changed, 85 insertions, 53 deletions
diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4
index 23452febdc..24c70bccfb 100644
--- a/plugins/extraction/g_extraction.ml4
+++ b/plugins/extraction/g_extraction.ml4
@@ -42,14 +42,20 @@ ARGUMENT EXTEND int_or_id
END
let pr_language = function
- | Ocaml -> str "Ocaml"
+ | Ocaml -> str "OCaml"
| Haskell -> str "Haskell"
| Scheme -> str "Scheme"
| JSON -> str "JSON"
+let warn_deprecated_ocaml_spelling =
+ CWarnings.create ~name:"deprecated-ocaml-spelling" ~category:"deprecated"
+ (fun () ->
+ strbrk ("The spelling \"OCaml\" should be used instead of \"Ocaml\"."))
+
VERNAC ARGUMENT EXTEND language
PRINTED BY pr_language
-| [ "Ocaml" ] -> [ Ocaml ]
+| [ "Ocaml" ] -> [ let _ = warn_deprecated_ocaml_spelling () in Ocaml ]
+| [ "OCaml" ] -> [ Ocaml ]
| [ "Haskell" ] -> [ Haskell ]
| [ "Scheme" ] -> [ Scheme ]
| [ "JSON" ] -> [ JSON ]
diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4
index 87609296bc..2fd6f53c4a 100644
--- a/plugins/funind/g_indfun.ml4
+++ b/plugins/funind/g_indfun.ml4
@@ -154,7 +154,7 @@ VERNAC COMMAND EXTEND Function
| _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in
match
Vernac_classifier.classify_vernac
- (Vernacexpr.VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl))
+ (Vernacexpr.(VernacExpr(VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl))))
with
| Vernacexpr.VtSideff ids, _ when hard ->
Vernacexpr.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater)
diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml
index 889c064b24..97066e5312 100644
--- a/plugins/funind/glob_term_to_relation.ml
+++ b/plugins/funind/glob_term_to_relation.ml
@@ -1509,7 +1509,7 @@ let do_build_inductive
in
let msg =
str "while trying to define"++ spc () ++
- Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Vernacexpr.GlobalNonCumulativity,false,Decl_kinds.Finite,repacked_rel_inds))
+ Ppvernac.pr_vernac Vernacexpr.(VernacExpr(VernacInductive(GlobalNonCumulativity,false,Decl_kinds.Finite,repacked_rel_inds)))
++ fnl () ++
msg
in
@@ -1524,7 +1524,7 @@ let do_build_inductive
in
let msg =
str "while trying to define"++ spc () ++
- Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Vernacexpr.GlobalNonCumulativity,false,Decl_kinds.Finite,repacked_rel_inds))
+ Ppvernac.pr_vernac Vernacexpr.(VernacExpr(VernacInductive(GlobalNonCumulativity,false,Decl_kinds.Finite,repacked_rel_inds)))
++ fnl () ++
CErrors.print reraise
in
diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml
index 5e3b7cf775..1615465281 100644
--- a/plugins/ltac/profile_ltac.ml
+++ b/plugins/ltac/profile_ltac.ml
@@ -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 feb7773526..adedf7ee91 100644
--- a/plugins/ltac/profile_ltac.mli
+++ b/plugins/ltac/profile_ltac.mli
@@ -52,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
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/taccoerce.ml b/plugins/ltac/taccoerce.ml
index 9ae112d371..e5933de2a6 100644
--- a/plugins/ltac/taccoerce.ml
+++ b/plugins/ltac/taccoerce.ml
@@ -61,12 +61,9 @@ struct
type t = Val.t
-let normalize v = v
-
let of_constr c = in_gen (topwit wit_constr) c
let to_constr v =
- let v = normalize v in
if has_type v (topwit wit_constr) then
let c = out_gen (topwit wit_constr) v in
Some c
@@ -78,7 +75,6 @@ let to_constr v =
let of_uconstr c = in_gen (topwit wit_uconstr) c
let to_uconstr v =
- let v = normalize v in
if has_type v (topwit wit_uconstr) then
Some (out_gen (topwit wit_uconstr) v)
else None
@@ -86,7 +82,6 @@ let to_uconstr v =
let of_int i = in_gen (topwit wit_int) i
let to_int v =
- let v = normalize v in
if has_type v (topwit wit_int) then
Some (out_gen (topwit wit_int) v)
else None
@@ -108,14 +103,12 @@ let constr_of_id env id =
(* Gives the constr corresponding to a Constr_context tactic_arg *)
let coerce_to_constr_context v =
- let v = Value.normalize v in
if has_type v (topwit wit_constr_context) then
out_gen (topwit wit_constr_context) v
else raise (CannotCoerceTo "a term context")
(* Interprets an identifier which must be fresh *)
let coerce_var_to_ident fresh env sigma v =
- let v = Value.normalize v in
let fail () = raise (CannotCoerceTo "a fresh identifier") in
if has_type v (topwit wit_intro_pattern) then
match out_gen (topwit wit_intro_pattern) v with
@@ -140,7 +133,6 @@ let g = sigma in
let id_of_name = function
| Name.Anonymous -> Id.of_string "x"
| Name.Name x -> x in
- let v = Value.normalize v in
let fail () = raise (CannotCoerceTo "an identifier") in
if has_type v (topwit wit_intro_pattern) then
match out_gen (topwit wit_intro_pattern) v with
@@ -179,7 +171,6 @@ let id_of_name = function
let coerce_to_intro_pattern env sigma v =
- let v = Value.normalize v in
if has_type v (topwit wit_intro_pattern) then
snd (out_gen (topwit wit_intro_pattern) v)
else if has_type v (topwit wit_var) then
@@ -198,7 +189,6 @@ let coerce_to_intro_pattern_naming env sigma v =
| _ -> raise (CannotCoerceTo "a naming introduction pattern")
let coerce_to_hint_base v =
- let v = Value.normalize v in
if has_type v (topwit wit_intro_pattern) then
match out_gen (topwit wit_intro_pattern) v with
| _, IntroNaming (IntroIdentifier id) -> Id.to_string id
@@ -206,13 +196,11 @@ let coerce_to_hint_base v =
else raise (CannotCoerceTo "a hint base name")
let coerce_to_int v =
- let v = Value.normalize v in
if has_type v (topwit wit_int) then
out_gen (topwit wit_int) v
else raise (CannotCoerceTo "an integer")
let coerce_to_constr env v =
- let v = Value.normalize v in
let fail () = raise (CannotCoerceTo "a term") in
if has_type v (topwit wit_intro_pattern) then
match out_gen (topwit wit_intro_pattern) v with
@@ -230,7 +218,6 @@ let coerce_to_constr env v =
else fail ()
let coerce_to_uconstr env v =
- let v = Value.normalize v in
if has_type v (topwit wit_uconstr) then
out_gen (topwit wit_uconstr) v
else
@@ -243,7 +230,6 @@ let coerce_to_closed_constr env v =
let coerce_to_evaluable_ref env sigma v =
let fail () = raise (CannotCoerceTo "an evaluable reference") in
- let v = Value.normalize v in
let ev =
if has_type v (topwit wit_intro_pattern) then
match out_gen (topwit wit_intro_pattern) v with
@@ -284,7 +270,6 @@ let coerce_to_intro_pattern_list ?loc env sigma v =
let coerce_to_hyp env sigma v =
let fail () = raise (CannotCoerceTo "a variable") in
- let v = Value.normalize v in
if has_type v (topwit wit_intro_pattern) then
match out_gen (topwit wit_intro_pattern) v with
| _, IntroNaming (IntroIdentifier id) when is_variable env id -> id
@@ -306,7 +291,6 @@ let coerce_to_hyp_list env sigma v =
(* Interprets a qualified name *)
let coerce_to_reference env sigma v =
- let v = Value.normalize v in
match Value.to_constr v with
| Some c ->
begin
@@ -318,7 +302,6 @@ let coerce_to_reference env sigma v =
(* Quantified named or numbered hypothesis or hypothesis in context *)
(* (as in Inversion) *)
let coerce_to_quantified_hypothesis sigma v =
- let v = Value.normalize v in
if has_type v (topwit wit_intro_pattern) then
let v = out_gen (topwit wit_intro_pattern) v in
match v with
@@ -336,7 +319,6 @@ let coerce_to_quantified_hypothesis sigma v =
(* Quantified named or numbered hypothesis or hypothesis in context *)
(* (as in Inversion) *)
let coerce_to_decl_or_quant_hyp env sigma v =
- let v = Value.normalize v in
if has_type v (topwit wit_int) then
AnonHyp (out_gen (topwit wit_int) v)
else
diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli
index d7b253a687..dce16b7333 100644
--- a/plugins/ltac/taccoerce.mli
+++ b/plugins/ltac/taccoerce.mli
@@ -31,9 +31,6 @@ module Value :
sig
type t = Val.t
- val normalize : t -> t
- (** Eliminated the leading dynamic type casts. *)
-
val of_constr : constr -> t
val to_constr : t -> constr option
val of_uconstr : Ltac_pretype.closed_glob_constr -> t
diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml
index 179952f28b..f2720954d0 100644
--- a/plugins/ltac/tacinterp.ml
+++ b/plugins/ltac/tacinterp.ml
@@ -136,7 +136,6 @@ let to_tacvalue v = out_gen (topwit wit_tacvalue) v
(** More naming applications *)
let name_vfun appl vle =
- let vle = Value.normalize vle in
if has_type vle (topwit wit_tacvalue) then
match to_tacvalue vle with
| VFun (appl0,trace,lfun,vars,t) -> of_tacvalue (VFun (combine_appl appl0 appl,trace,lfun,vars,t))
@@ -235,7 +234,6 @@ let curr_debug ist = match TacStore.get ist.extra f_debug with
(* Displays a value *)
let pr_value env v =
- let v = Value.normalize v in
let pr_with_env pr =
match env with
| Some (env,sigma) -> pr env sigma
@@ -285,7 +283,6 @@ let push_trace call ist = match TacStore.get ist.extra f_trace with
| Some trace -> Proofview.tclUNIT (call :: trace)
let propagate_trace ist loc id v =
- let v = Value.normalize v in
if has_type v (topwit wit_tacvalue) then
let tacv = to_tacvalue v in
match tacv with
@@ -298,7 +295,6 @@ let propagate_trace ist loc id v =
else Proofview.tclUNIT v
let append_trace trace v =
- let v = Value.normalize v in
if has_type v (topwit wit_tacvalue) then
match to_tacvalue v with
| VFun (appl,trace',lfun,it,b) -> of_tacvalue (VFun (appl,trace'@trace,lfun,it,b))
@@ -307,11 +303,9 @@ let append_trace trace v =
(* Dynamically check that an argument is a tactic *)
let coerce_to_tactic loc id v =
- let v = Value.normalize v in
let fail () = user_err ?loc
(str "Variable " ++ Id.print id ++ str " should be bound to a tactic.")
in
- let v = Value.normalize v in
if has_type v (topwit wit_tacvalue) then
let tacv = to_tacvalue v in
match tacv with
@@ -514,7 +508,6 @@ let rec intropattern_ids accu (loc,pat) = match pat with
let extract_ids ids lfun accu =
let fold id v accu =
- let v = Value.normalize v in
if has_type v (topwit wit_intro_pattern) then
let (_, ipat) = out_gen (topwit wit_intro_pattern) v in
if Id.List.mem id ids then accu
@@ -816,7 +809,6 @@ let interp_constr_may_eval ist env sigma c =
(** TODO: should use dedicated printers *)
let message_of_value v =
- let v = Value.normalize v in
let pr_with_env pr =
Ftactic.enter begin fun gl -> Ftactic.return (pr (pf_env gl) (project gl)) end in
let open Genprint in
@@ -986,7 +978,6 @@ let interp_destruction_arg ist gl arg =
try
(** FIXME: should be moved to taccoerce *)
let v = Id.Map.find id ist.lfun in
- let v = Value.normalize v in
if has_type v (topwit wit_intro_pattern) then
let v = out_gen (topwit wit_intro_pattern) v in
match v with
@@ -1158,10 +1149,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 ->
@@ -1244,7 +1239,6 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with
Ftactic.run args tac
and force_vrec ist v : Val.t Ftactic.t =
- let v = Value.normalize v in
if has_type v (topwit wit_tacvalue) then
let v = to_tacvalue v in
match v with
@@ -1320,7 +1314,6 @@ and interp_tacarg ist arg : Val.t Ftactic.t =
and interp_app loc ist fv largs : Val.t Ftactic.t =
let (>>=) = Ftactic.bind in
let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in
- let fv = Value.normalize fv in
if has_type fv (topwit wit_tacvalue) then
match to_tacvalue fv with
(* if var=[] and body has been delayed by val_interp, then body
@@ -1373,7 +1366,6 @@ and interp_app loc ist fv largs : Val.t Ftactic.t =
(* Gives the tactic corresponding to the tactic value *)
and tactic_of_value ist vle =
- let vle = Value.normalize vle in
if has_type vle (topwit wit_tacvalue) then
match to_tacvalue vle with
| VFun (appl,trace,lfun,[],t) ->
@@ -1600,7 +1592,6 @@ and interp_ltac_constr ist e : EConstr.t Ftactic.t =
Ftactic.enter begin fun gl ->
let env = Proofview.Goal.env gl in
let sigma = project gl in
- let result = Value.normalize result in
try
let cresult = coerce_to_closed_constr env result in
Proofview.tclLIFT begin
diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v
index e5b5854f0a..362cc3a597 100644
--- a/plugins/micromega/MExtraction.v
+++ b/plugins/micromega/MExtraction.v
@@ -49,16 +49,13 @@ Extract Constant Rmult => "( * )".
Extract Constant Ropp => "fun x -> - x".
Extract Constant Rinv => "fun x -> 1 / x".
-(** We now extract to stdout, see comment in Makefile.build *)
-
-(*Extraction "plugins/micromega/micromega.ml" *)
-Recursive Extraction
- List.map simpl_cone (*map_cone indexes*)
- denorm Qpower vm_add
- n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find.
-
-
-
+(** In order to avoid annoying build dependencies the actual
+ extraction is only performed as a test in the test suite. *)
+(* Extraction "plugins/micromega/micromega.ml" *)
+(* Recursive Extraction *)
+(* List.map simpl_cone (*map_cone indexes*) *)
+(* denorm Qpower vm_add *)
+(* n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. *)
(* Local Variables: *)
(* coding: utf-8 *)
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-29 14:22:20 +0000