aboutsummaryrefslogtreecommitdiff
path: root/pretyping
diff options
context:
space:
mode:
Diffstat (limited to 'pretyping')
-rw-r--r--pretyping/detyping.ml11
-rw-r--r--pretyping/nativenorm.ml104
-rw-r--r--pretyping/nativenorm.mli7
-rw-r--r--pretyping/pretyping.ml73
-rw-r--r--pretyping/pretyping.mli25
5 files changed, 117 insertions, 103 deletions
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index a27debe735..b9cb7ba1b1 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -476,7 +476,7 @@ let rec detype flags avoid env sigma t = CAst.make @@
| _ -> GApp (f',args')
in
mkapp (detype flags avoid env sigma f)
- (detype_array flags avoid env sigma args)
+ (Array.map_to_list (detype flags avoid env sigma) args)
| Const (sp,u) -> GRef (ConstRef sp, detype_instance sigma u)
| Proj (p,c) ->
let noparams () =
@@ -694,15 +694,6 @@ and detype_binder (lax,isgoal as flags) bk avoid env sigma na body ty c =
let t = if s != InProp && not !Flags.raw_print then None else Some (detype (lax,false) avoid env sigma ty) in
GLetIn (na', c, t, r)
-(** We use a dedicated function here to prevent overallocation from
- Array.map_to_list. *)
-and detype_array flags avoid env sigma args =
- let ans = ref [] in
- for i = Array.length args - 1 downto 0 do
- ans := detype flags avoid env sigma args.(i) :: !ans;
- done;
- !ans
-
let detype_rel_context ?(lax=false) where avoid env sigma sign =
let where = Option.map (fun c -> EConstr.it_mkLambda_or_LetIn c sign) where in
let rec aux avoid env = function
diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml
index 5142af3567..39c2ceeba8 100644
--- a/pretyping/nativenorm.ml
+++ b/pretyping/nativenorm.ml
@@ -26,6 +26,59 @@ module RelDecl = Context.Rel.Declaration
exception Find_at of int
+(* profiling *)
+
+let profiling_enabled = ref false
+
+(* for supported platforms, filename for profiler results *)
+
+let profile_filename = ref "native_compute_profile.data"
+
+let profiler_platform () =
+ match [@warning "-8"] Sys.os_type with
+ | "Unix" ->
+ let in_ch = Unix.open_process_in "uname" in
+ let uname = input_line in_ch in
+ let _ = close_in in_ch in
+ Format.sprintf "Unix (%s)" uname
+ | "Win32" -> "Windows (Win32)"
+ | "Cygwin" -> "Windows (Cygwin)"
+
+let get_profile_filename () = !profile_filename
+
+let set_profile_filename fn =
+ profile_filename := fn
+
+(* find unused profile filename *)
+let get_available_profile_filename () =
+ let profile_filename = get_profile_filename () in
+ let dir = Filename.dirname profile_filename in
+ let base = Filename.basename profile_filename in
+ (* starting with OCaml 4.04, could use Filename.remove_extension and Filename.extension, which
+ gets rid of need for exception-handling here
+ *)
+ let (name,ext) =
+ try
+ let nm = Filename.chop_extension base in
+ let nm_len = String.length nm in
+ let ex = String.sub base nm_len (String.length base - nm_len) in
+ (nm,ex)
+ with Invalid_argument _ -> (base,"")
+ in
+ try
+ (* unlikely race: fn deleted, another process uses fn *)
+ Filename.temp_file ~temp_dir:dir (name ^ "_") ext
+ with Sys_error s ->
+ let msg = "When trying to find native_compute profile output file: " ^ s in
+ let _ = Feedback.msg_info (Pp.str msg) in
+ assert false
+
+let get_profiling_enabled () =
+ !profiling_enabled
+
+let set_profiling_enabled b =
+ profiling_enabled := b
+
let invert_tag cst tag reloc_tbl =
try
for j = 0 to Array.length reloc_tbl - 1 do
@@ -379,6 +432,52 @@ let evars_of_evar_map sigma =
Nativelambda.evars_typ = Evd.existential_type sigma;
Nativelambda.evars_metas = Evd.meta_type sigma }
+(* fork perf process, return profiler's process id *)
+let start_profiler_linux profile_fn =
+ let coq_pid = Unix.getpid () in (* pass pid of running coqtop *)
+ (* we don't want to see perf's console output *)
+ let dev_null = Unix.descr_of_out_channel (open_out_bin "/dev/null") in
+ let _ = Feedback.msg_info (Pp.str ("Profiling to file " ^ profile_fn)) in
+ let perf = "perf" in
+ let profiler_pid =
+ Unix.create_process
+ perf
+ [|perf; "record"; "-g"; "-o"; profile_fn; "-p"; string_of_int coq_pid |]
+ Unix.stdin dev_null dev_null
+ in
+ (* doesn't seem to be a way to test whether process creation succeeded *)
+ if !Flags.debug then
+ Feedback.msg_debug (Pp.str (Format.sprintf "Native compute profiler started, pid = %d, output to: %s" profiler_pid profile_fn));
+ Some profiler_pid
+
+(* kill profiler via SIGINT *)
+let stop_profiler_linux m_pid =
+ match m_pid with
+ | Some pid -> (
+ let _ = if !Flags.debug then Feedback.msg_debug (Pp.str "Stopping native code profiler") in
+ try
+ Unix.kill pid Sys.sigint;
+ let _ = Unix.waitpid [] pid in ()
+ with Unix.Unix_error (Unix.ESRCH,"kill","") ->
+ Feedback.msg_info (Pp.str "Could not stop native code profiler, no such process")
+ )
+ | None -> ()
+
+let start_profiler () =
+ let profile_fn = get_available_profile_filename () in
+ match profiler_platform () with
+ "Unix (Linux)" -> start_profiler_linux profile_fn
+ | _ ->
+ let _ = Feedback.msg_info
+ (Pp.str (Format.sprintf "Native_compute profiling not supported on the platform: %s"
+ (profiler_platform ()))) in
+ None
+
+let stop_profiler m_pid =
+ match profiler_platform() with
+ "Unix (Linux)" -> stop_profiler_linux m_pid
+ | _ -> ()
+
let native_norm env sigma c ty =
let c = EConstr.Unsafe.to_constr c in
let ty = EConstr.Unsafe.to_constr ty in
@@ -392,12 +491,15 @@ let native_norm env sigma c ty =
*)
let ml_filename, prefix = Nativelib.get_ml_filename () in
let code, upd = mk_norm_code penv (evars_of_evar_map sigma) prefix c in
- match Nativelib.compile ml_filename code with
+ let profile = get_profiling_enabled () in
+ match Nativelib.compile ml_filename code ~profile:profile with
| true, fn ->
if !Flags.debug then Feedback.msg_debug (Pp.str "Running norm ...");
+ let profiler_pid = if profile then start_profiler () else None in
let t0 = Sys.time () in
Nativelib.call_linker ~fatal:true prefix fn (Some upd);
let t1 = Sys.time () in
+ if profile then stop_profiler profiler_pid;
let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in
if !Flags.debug then Feedback.msg_debug (Pp.str time_info);
let res = nf_val env sigma !Nativelib.rt1 ty in
diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli
index 4e7f2110dd..579a7d2acb 100644
--- a/pretyping/nativenorm.mli
+++ b/pretyping/nativenorm.mli
@@ -12,6 +12,13 @@ open Evd
(** This module implements normalization by evaluation to OCaml code *)
+val get_profile_filename : unit -> string
+val set_profile_filename : string -> unit
+
+val get_profiling_enabled : unit -> bool
+val set_profiling_enabled : bool -> unit
+
+
val native_norm : env -> evar_map -> constr -> types -> constr
(** Conversion with inference of universe constraints *)
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index b4d87dfdb0..40b8bcad92 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -47,8 +47,6 @@ open Misctypes
module NamedDecl = Context.Named.Declaration
type typing_constraint = OfType of types | IsType | WithoutTypeConstraint
-type glob_constr_ltac_closure = ltac_var_map * glob_constr
-type pure_open_constr = evar_map * EConstr.constr
(************************************************************************)
(* This concerns Cases *)
@@ -385,9 +383,6 @@ let adjust_evar_source evdref na c =
end
| _, _ -> c
-(* Allow references to syntactically nonexistent variables (i.e., if applied on an inductive) *)
-let allow_anonymous_refs = ref false
-
(* coerce to tycon if any *)
let inh_conv_coerce_to_tycon ?loc resolve_tc env evdref j = function
| None -> j
@@ -918,9 +913,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
(* Make dependencies from arity signature impossible *)
let arsgn =
let arsgn,_ = get_arity env.ExtraEnv.env indf in
- if not !allow_anonymous_refs then
- List.map (set_name Anonymous) arsgn
- else arsgn
+ List.map (set_name Anonymous) arsgn
in
let indt = build_dependent_inductive env.ExtraEnv.env indf in
let psign = LocalAssum (na, indt) :: arsgn in (* For locating names in [po] *)
@@ -981,10 +974,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
let arsgn =
let arsgn,_ = get_arity env.ExtraEnv.env indf in
- if not !allow_anonymous_refs then
- (* Make dependencies from arity signature impossible *)
- List.map (set_name Anonymous) arsgn
- else arsgn
+ (* Make dependencies from arity signature impossible *)
+ List.map (set_name Anonymous) arsgn
in
let nar = List.length arsgn in
let indt = build_dependent_inductive env.ExtraEnv.env indf in
@@ -1018,13 +1009,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
let pi = beta_applist !evdref (pi, [EConstr.of_constr (build_dependent_constructor cs)]) in
let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cs.cs_args in
let csgn =
- if not !allow_anonymous_refs then
- List.map (set_name Anonymous) cs_args
- else
- List.map (map_name (function Name _ as n -> n
- | Anonymous -> Name Namegen.default_non_dependent_ident))
- cs_args
- in
+ List.map (set_name Anonymous) cs_args
+ in
let env_c = push_rel_context !evdref csgn env in
let bj = pretype (mk_tycon pi) env_c evdref lvar b in
it_mkLambda_or_LetIn bj.uj_val cs_args in
@@ -1191,29 +1177,6 @@ let no_classes_no_fail_inference_flags = {
let all_and_fail_flags = default_inference_flags true
let all_no_fail_flags = default_inference_flags false
-let on_judgment sigma f j =
- let c = mkCast(j.uj_val,DEFAULTcast, j.uj_type) in
- let (c,_,t) = destCast sigma (f c) in
- {uj_val = c; uj_type = t}
-
-let understand_judgment env sigma c =
- let env = make_env env sigma in
- let evdref = ref sigma in
- let k0 = Context.Rel.length (rel_context env) in
- let j = pretype k0 true empty_tycon env evdref empty_lvar c in
- let j = on_judgment sigma (fun c ->
- let evd, c = process_inference_flags all_and_fail_flags env.ExtraEnv.env sigma (!evdref,c) in
- evdref := evd; c) j
- in j, Evd.evar_universe_context !evdref
-
-let understand_judgment_tcc env evdref c =
- let env = make_env env !evdref in
- let k0 = Context.Rel.length (rel_context env) in
- let j = pretype k0 true empty_tycon env evdref empty_lvar c in
- on_judgment !evdref (fun c ->
- let (evd,c) = process_inference_flags all_no_fail_flags env.ExtraEnv.env Evd.empty (!evdref,c) in
- evdref := evd; c) j
-
let ise_pretype_gen_ctx flags env sigma lvar kind c =
let evd, c = ise_pretype_gen flags env sigma lvar kind c in
let evd, f = Evarutil.nf_evars_and_universes evd in
@@ -1231,36 +1194,10 @@ let understand_tcc ?(flags=all_no_fail_flags) env sigma ?(expected_type=WithoutT
let (sigma, c) = ise_pretype_gen flags env sigma empty_lvar expected_type c in
(sigma, c)
-let understand_tcc_evars ?(flags=all_no_fail_flags) env evdref ?(expected_type=WithoutTypeConstraint) c =
- let sigma, c = ise_pretype_gen flags env !evdref empty_lvar expected_type c in
- evdref := sigma;
- c
-
let understand_ltac flags env sigma lvar kind c =
let (sigma, c) = ise_pretype_gen flags env sigma lvar kind c in
(sigma, c)
-let constr_flags = {
- use_typeclasses = true;
- solve_unification_constraints = true;
- use_hook = None;
- fail_evar = true;
- expand_evars = true }
-
-(* Fully evaluate an untyped constr *)
-let type_uconstr ?(flags = constr_flags)
- ?(expected_type = WithoutTypeConstraint) ist c =
- begin fun env sigma ->
- let { closure; term } = c in
- let vars = {
- ltac_constrs = closure.typed;
- ltac_uconstrs = closure.untyped;
- ltac_idents = closure.idents;
- ltac_genargs = Id.Map.empty;
- } in
- understand_ltac flags env sigma vars expected_type term
- end
-
let pretype k0 resolve_tc typcon env evdref lvar t =
pretype k0 resolve_tc typcon (make_env env !evdref) evdref lvar t
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index 6e533f1784..7395e94a09 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -27,9 +27,6 @@ val search_guard :
type typing_constraint = OfType of types | IsType | WithoutTypeConstraint
-type glob_constr_ltac_closure = ltac_var_map * glob_constr
-type pure_open_constr = evar_map * constr
-
type inference_hook = env -> evar_map -> evar -> evar_map * constr
type inference_flags = {
@@ -48,9 +45,6 @@ val all_no_fail_flags : inference_flags
val all_and_fail_flags : inference_flags
-(** Allow references to syntactically nonexistent variables (i.e., if applied on an inductive) *)
-val allow_anonymous_refs : bool ref
-
(** Generic calls to the interpreter from glob_constr to open_constr;
by default, inference_flags tell to use type classes and
heuristics (but no external tactic solver hooks), as well as to
@@ -61,9 +55,6 @@ val allow_anonymous_refs : bool ref
val understand_tcc : ?flags:inference_flags -> env -> evar_map ->
?expected_type:typing_constraint -> glob_constr -> evar_map * constr
-val understand_tcc_evars : ?flags:inference_flags -> env -> evar_map ref ->
- ?expected_type:typing_constraint -> glob_constr -> constr
-
(** More general entry point with evars from ltac *)
(** Generic call to the interpreter from glob_constr to constr
@@ -78,7 +69,7 @@ val understand_tcc_evars : ?flags:inference_flags -> env -> evar_map ref ->
val understand_ltac : inference_flags ->
env -> evar_map -> ltac_var_map ->
- typing_constraint -> glob_constr -> pure_open_constr
+ typing_constraint -> glob_constr -> evar_map * EConstr.t
(** Standard call to get a constr from a glob_constr, resolving
implicit arguments and coercions, and compiling pattern-matching;
@@ -90,20 +81,6 @@ val understand_ltac : inference_flags ->
val understand : ?flags:inference_flags -> ?expected_type:typing_constraint ->
env -> evar_map -> glob_constr -> Constr.constr Evd.in_evar_universe_context
-(** Idem but returns the judgment of the understood term *)
-
-val understand_judgment : env -> evar_map ->
- glob_constr -> unsafe_judgment Evd.in_evar_universe_context
-
-(** Idem but do not fail on unresolved evars (type cl*)
-val understand_judgment_tcc : env -> evar_map ref ->
- glob_constr -> unsafe_judgment
-
-val type_uconstr :
- ?flags:inference_flags ->
- ?expected_type:typing_constraint ->
- Geninterp.interp_sign -> Glob_term.closed_glob_constr -> constr Tactypes.delayed_open
-
(** Trying to solve remaining evars and remaining conversion problems
possibly using type classes, heuristics, external tactic solver
hook depending on given flags. *)
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-08 09:11:23 +0000