From d1114c5f55fcb96a99a1a5562b014414ad8217ba Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 24 Oct 2015 18:10:24 +0200 Subject: Documenting a bit more interpretation functions in passing. --- pretyping/pretyping.mli | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) (limited to 'pretyping') diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index a6aa086579..5f0e19cf2b 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -66,9 +66,12 @@ 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 call to the interpreter from glob_constr to open_constr, leaving - unresolved holes as evars and returning the typing contexts of - these evars. Work as [understand_gen] for the rest. *) +(** 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 + ensure that conversion problems are all solved and expand evars, + but unresolved evars can remain. The difference is in whether the + evar_map is modified explicitly or by side-effect. *) val understand_tcc : ?flags:inference_flags -> env -> evar_map -> ?expected_type:typing_constraint -> glob_constr -> open_constr @@ -92,7 +95,12 @@ val understand_ltac : inference_flags -> env -> evar_map -> ltac_var_map -> typing_constraint -> glob_constr -> pure_open_constr -(** Standard call to get a constr from a glob_constr, resolving implicit args *) +(** Standard call to get a constr from a glob_constr, resolving + implicit arguments and coercions, and compiling pattern-matching; + the default inference_flags tells to use type classes and + heuristics (but no external tactic solver hook), as well as to + ensure that conversion problems are all solved and that no + unresolved evar remains, expanding evars. *) val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> env -> evar_map -> glob_constr -> constr Evd.in_evar_universe_context @@ -102,12 +110,13 @@ val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> val understand_judgment : env -> evar_map -> glob_constr -> unsafe_judgment Evd.in_evar_universe_context -(** Idem but do not fail on unresolved evars *) +(** Idem but do not fail on unresolved evars (type cl*) val understand_judgment_tcc : env -> evar_map ref -> glob_constr -> unsafe_judgment (** Trying to solve remaining evars and remaining conversion problems - with type classes, heuristics, and possibly an external solver *) + possibly using type classes, heuristics, external tactic solver + hook depending on given flags. *) (* For simplicity, it is assumed that current map has no other evars with candidate and no other conversion problems that the one in [pending], however, it can contain more evars than the pending ones. *) @@ -115,7 +124,8 @@ val understand_judgment_tcc : env -> evar_map ref -> val solve_remaining_evars : inference_flags -> env -> (* initial map *) evar_map -> (* map to solve *) pending -> evar_map -(** Checking evars are all solved and reporting an appropriate error message *) +(** Checking evars and pending conversion problems are all solved, + reporting an appropriate error message *) val check_evars_are_solved : env -> (* current map: *) evar_map -> (* map to check: *) pending -> unit -- cgit v1.2.3 From e3ec13976d39909ac6f1a82bf1b243ba8a895190 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 28 Oct 2015 12:42:27 +0100 Subject: Revert "Fixing #4198 (continued): not matching within the inner lambdas/let-ins" After all, let's target 8.6. --- pretyping/constr_matching.ml | 19 +++---------------- 1 file changed, 3 insertions(+), 16 deletions(-) (limited to 'pretyping') diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 3fa037ffdd..5e99521a12 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -413,25 +413,12 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in let sub = (env, c1) :: subargs env lc in try_aux sub mk_ctx next - | Case (ci,p,c,brs) -> - (* Warning: this assumes predicate and branches to be - in canonical form using let and fun of the signature *) - let nardecls = List.length ci.ci_pp_info.ind_tags in - let sign_p,p = decompose_lam_n_decls (nardecls + 1) p in - let env_p = Environ.push_rel_context sign_p env in - let brs = Array.map2 decompose_lam_n_decls ci.ci_cstr_ndecls brs in - let sign_brs = Array.map fst brs in - let f (sign,br) = (Environ.push_rel_context sign env, br) in - let sub_br = Array.map f brs in + | Case (ci,hd,c1,lc) -> let next_mk_ctx = function - | c :: p :: brs -> - let p = it_mkLambda_or_LetIn p sign_p in - let brs = - Array.map2 it_mkLambda_or_LetIn (Array.of_list brs) sign_brs in - mk_ctx (mkCase (ci,p,c,brs)) + | c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc)) | _ -> assert false in - let sub = (env, c) :: (env_p, p) :: Array.to_list sub_br in + let sub = (env, c1) :: (env, hd) :: subargs env lc in try_aux sub next_mk_ctx next | Fix (indx,(names,types,bodies)) -> let nb_fix = Array.length types in -- cgit v1.2.3 From 7d9331a2a188842a98936278d02177f1a6fa7001 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Sat, 17 Oct 2015 21:40:49 -0700 Subject: Adds support for the virtual machine to perform reduction of universe polymorphic definitions. - This implementation passes universes in separate arguments and does not eagerly instanitate polymorphic definitions. - This means that it pays no cost on monomorphic definitions. --- pretyping/vnorm.ml | 96 ++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 72 insertions(+), 24 deletions(-) (limited to 'pretyping') diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 46af784dda..b9c1a5a1c7 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -93,19 +93,6 @@ let construct_of_constr_const env tag typ = let construct_of_constr_block = construct_of_constr false -let constr_type_of_idkey env idkey = - match idkey with - | ConstKey cst -> - let const_type = Typeops.type_of_constant_in env cst in - mkConstU cst, const_type - | VarKey id -> - let (_,_,ty) = lookup_named id env in - mkVar id, ty - | RelKey i -> - let n = (nb_rel env - i) in - let (_,_,ty) = lookup_rel n env in - mkRel n, lift n ty - let type_of_ind env (ind, u) = type_of_inductive env (Inductive.lookup_mind_specif env ind, u) @@ -164,9 +151,11 @@ and nf_whd env whd typ = let t = ta.(i) in let _, args = nf_args env vargs t in mkApp(cfd,args) - | Vconstr_const n -> construct_of_constr_const env n typ + | Vconstr_const n -> + construct_of_constr_const env n typ | Vconstr_block b -> let tag = btag b in + let x = tag in let (tag,ofs) = if tag = Cbytecodes.last_variant_tag then match whd_val (bfield b 0) with @@ -177,22 +166,80 @@ and nf_whd env whd typ = let args = nf_bargs env b ofs ctyp in mkApp(capp,args) | Vatom_stk(Aid idkey, stk) -> - let c,typ = constr_type_of_idkey env idkey in - nf_stk env c typ stk - | Vatom_stk(Aind ind, stk) -> - nf_stk env (mkIndU ind) (type_of_ind env ind) stk + constr_type_of_idkey env idkey stk nf_stk +(*let c,typ = constr_type_of_idkey env idkey in + nf_stk env c typ stk *) + | Vatom_stk(Aind ((mi,i) as ind), stk) -> + if Environ.polymorphic_ind ind env then + let mib = Environ.lookup_mind mi env in + let ulen = Univ.UContext.size mib.mind_universes in + match stk with + | Zapp args :: stk' -> + assert (ulen <= nargs args) ; + let inst = + Array.init ulen (fun i -> Vm.uni_lvl_val (arg args i)) + in + let pind = (ind, Univ.Instance.of_array inst) in + nf_stk ~from:ulen env (mkIndU pind) (type_of_ind env pind) stk + | _ -> assert false + else + let pind = (ind, Univ.Instance.empty) in + nf_stk env (mkIndU pind) (type_of_ind env pind) stk + | Vatom_stk(Atype u, stk) -> + mkSort (Type (Vm.instantiate_universe u stk)) + | Vuniv_level lvl -> + assert false + +and constr_type_of_idkey env (idkey : Vars.id_key) stk cont = + match idkey with + | ConstKey cst -> + if Environ.polymorphic_constant cst env then + let cbody = Environ.lookup_constant cst env in + match stk with + | Zapp vargs :: stk' -> + let uargs = Univ.UContext.size cbody.const_universes in + assert (Vm.nargs vargs >= uargs) ; + let uary = Array.init uargs (fun i -> Vm.uni_lvl_val (Vm.arg vargs i)) in + let ui = Univ.Instance.of_array uary in + let ucst = (cst, ui) in + let const_type = Typeops.type_of_constant_in env ucst in + if uargs < Vm.nargs vargs then + let t, args = nf_args env vargs ~from:uargs const_type in + cont env (mkApp (mkConstU ucst, args)) t stk' + else + cont env (mkConstU ucst) const_type stk' + | _ -> assert false + else + begin + let ucst = (cst, Univ.Instance.empty) in + let const_type = Typeops.type_of_constant_in env ucst in + cont env (mkConstU ucst) const_type stk + end + | VarKey id -> + let (_,_,ty) = lookup_named id env in + cont env (mkVar id) ty stk + | RelKey i -> + let n = (nb_rel env - i) in + let (_,_,ty) = lookup_rel n env in + cont env (mkRel n) (lift n ty) stk -and nf_stk env c t stk = +and nf_stk ?from:(from=0) env c t stk = match stk with | [] -> c | Zapp vargs :: stk -> - let t, args = nf_args env vargs t in - nf_stk env (mkApp(c,args)) t stk + if nargs vargs >= from then + let t, args = nf_args ~from:from env vargs t in + nf_stk env (mkApp(c,args)) t stk + else + let rest = from - nargs vargs in + nf_stk ~from:rest env c t stk | Zfix (f,vargs) :: stk -> + assert (from = 0) ; let fa, typ = nf_fix_app env f vargs in let _,_,codom = decompose_prod env typ in nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk | Zswitch sw :: stk -> + assert (from = 0) ; let ((mind,_ as ind), u), allargs = find_rectype_a env t in let (mib,mip) = Inductive.lookup_mind_specif env ind in let nparams = mib.mind_nparams in @@ -215,6 +262,7 @@ and nf_stk env c t stk = let ci = case_info sw in nf_stk env (mkCase(ci, p, c, branchs)) tcase stk | Zproj p :: stk -> + assert (from = 0) ; let p' = Projection.make p true in let ty = Inductiveops.type_of_projection_knowing_arg env Evd.empty p' c t in nf_stk env (mkProj(p',c)) ty stk @@ -240,14 +288,14 @@ and nf_predicate env ind mip params v pT = true, mkLambda(name,dom,body) | _, _ -> false, nf_val env v crazy_type -and nf_args env vargs t = +and nf_args env vargs ?from:(f=0) t = let t = ref t in - let len = nargs vargs in + let len = nargs vargs - f in let args = Array.init len (fun i -> let _,dom,codom = decompose_prod env !t in - let c = nf_val env (arg vargs i) dom in + let c = nf_val env (arg vargs (f+i)) dom in t := subst1 c codom; c) in !t,args -- cgit v1.2.3 From 90dfacaacfec8265b11dc9291de9510f515c0081 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Tue, 27 Oct 2015 23:59:05 +0100 Subject: Conversion of polymorphic inductive types was incomplete in VM and native. Was showing up when comparing e.g. prod Type Type with prod Type Type (!) with a polymorphic prod. --- pretyping/reductionops.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'pretyping') diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index bb1bc7d2ea..0714c93b4f 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1282,7 +1282,7 @@ let sigma_compare_sorts env pb s0 s1 sigma = | Reduction.CONV -> Evd.set_eq_sort env sigma s0 s1 | Reduction.CUMUL -> Evd.set_leq_sort env sigma s0 s1 -let sigma_compare_instances flex i0 i1 sigma = +let sigma_compare_instances ~flex i0 i1 sigma = try Evd.set_eq_instances ~flex sigma i0 i1 with Evd.UniversesDiffer | Univ.UniverseInconsistency _ -> -- cgit v1.2.3 From 4f8a9d10123bd8aa4d17853a7248d3b3fe8a3625 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 28 Oct 2015 11:16:24 +0100 Subject: Refine Gregory Malecha's patch on VM and universe polymorphism. - Universes are now represented in the VM by a structured constant containing the global levels. This constant is applied to local level variables if any. - When reading back a universe, we perform the union of these levels and return a [Vsort]. - Fixed a bug: structured constants could contain local universe variables in constructor arguments, which has to be prevented. Was showing up for instance when evaluating [cons _ list (nil _)] with a polymorphic [list] type. - Fixed a bug: polymorphic inductive types can have an empty stack. Was showing up when evaluating [bool] with a polymorphic [bool] type. - Made a few cosmetic changes. Patch written with Benjamin Grégoire. --- pretyping/vnorm.ml | 85 ++++++++++++++++++++++++------------------------------ 1 file changed, 38 insertions(+), 47 deletions(-) (limited to 'pretyping') diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index b9c1a5a1c7..c4c85a62ed 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -155,7 +155,6 @@ and nf_whd env whd typ = construct_of_constr_const env n typ | Vconstr_block b -> let tag = btag b in - let x = tag in let (tag,ofs) = if tag = Cbytecodes.last_variant_tag then match whd_val (bfield b 0) with @@ -166,62 +165,54 @@ and nf_whd env whd typ = let args = nf_bargs env b ofs ctyp in mkApp(capp,args) | Vatom_stk(Aid idkey, stk) -> - constr_type_of_idkey env idkey stk nf_stk -(*let c,typ = constr_type_of_idkey env idkey in - nf_stk env c typ stk *) + constr_type_of_idkey env idkey stk | Vatom_stk(Aind ((mi,i) as ind), stk) -> - if Environ.polymorphic_ind ind env then - let mib = Environ.lookup_mind mi env in - let ulen = Univ.UContext.size mib.mind_universes in - match stk with - | Zapp args :: stk' -> - assert (ulen <= nargs args) ; - let inst = - Array.init ulen (fun i -> Vm.uni_lvl_val (arg args i)) - in - let pind = (ind, Univ.Instance.of_array inst) in - nf_stk ~from:ulen env (mkIndU pind) (type_of_ind env pind) stk - | _ -> assert false - else - let pind = (ind, Univ.Instance.empty) in - nf_stk env (mkIndU pind) (type_of_ind env pind) stk - | Vatom_stk(Atype u, stk) -> - mkSort (Type (Vm.instantiate_universe u stk)) + let mib = Environ.lookup_mind mi env in + let nb_univs = + if mib.mind_polymorphic then Univ.UContext.size mib.mind_universes + else 0 + in + let mk u = + let pind = (ind, u) in (mkIndU pind, type_of_ind env pind) + in + nf_univ_args ~nb_univs mk env stk + | Vatom_stk(Atype u, stk) -> assert false | Vuniv_level lvl -> assert false -and constr_type_of_idkey env (idkey : Vars.id_key) stk cont = +and nf_univ_args ~nb_univs mk env stk = + let u = + if Int.equal nb_univs 0 then Univ.Instance.empty + else match stk with + | Zapp args :: _ -> + let inst = + Array.init nb_univs (fun i -> Vm.uni_lvl_val (arg args i)) + in + Univ.Instance.of_array inst + | _ -> assert false + in + let (t,ty) = mk u in + nf_stk ~from:nb_univs env t ty stk + +and constr_type_of_idkey env (idkey : Vars.id_key) stk = match idkey with | ConstKey cst -> - if Environ.polymorphic_constant cst env then - let cbody = Environ.lookup_constant cst env in - match stk with - | Zapp vargs :: stk' -> - let uargs = Univ.UContext.size cbody.const_universes in - assert (Vm.nargs vargs >= uargs) ; - let uary = Array.init uargs (fun i -> Vm.uni_lvl_val (Vm.arg vargs i)) in - let ui = Univ.Instance.of_array uary in - let ucst = (cst, ui) in - let const_type = Typeops.type_of_constant_in env ucst in - if uargs < Vm.nargs vargs then - let t, args = nf_args env vargs ~from:uargs const_type in - cont env (mkApp (mkConstU ucst, args)) t stk' - else - cont env (mkConstU ucst) const_type stk' - | _ -> assert false - else - begin - let ucst = (cst, Univ.Instance.empty) in - let const_type = Typeops.type_of_constant_in env ucst in - cont env (mkConstU ucst) const_type stk - end - | VarKey id -> + let cbody = Environ.lookup_constant cst env in + let nb_univs = + if cbody.const_polymorphic then Univ.UContext.size cbody.const_universes + else 0 + in + let mk u = + let pcst = (cst, u) in (mkConstU pcst, Typeops.type_of_constant_in env pcst) + in + nf_univ_args ~nb_univs mk env stk + | VarKey id -> let (_,_,ty) = lookup_named id env in - cont env (mkVar id) ty stk + nf_stk env (mkVar id) ty stk | RelKey i -> let n = (nb_rel env - i) in let (_,_,ty) = lookup_rel n env in - cont env (mkRel n) (lift n ty) stk + nf_stk env (mkRel n) (lift n ty) stk and nf_stk ?from:(from=0) env c t stk = match stk with -- cgit v1.2.3 From f1dd27ae0e6082b111770fa74cba6abda30f3b89 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 28 Oct 2015 12:51:51 +0100 Subject: Fix bug in native compiler with universe polymorphism. Universe instances for constructors were not always correct, for instance in: [cons _ list (nil _)] with a polymorphic [list] type, [nil] was receiving an empty instance. --- pretyping/nativenorm.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'pretyping') diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index dafe88d8db..de988aa2cd 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -53,8 +53,8 @@ let find_rectype_a env c = (* Instantiate inductives and parameters in constructor type *) -let type_constructor mind mib typ params = - let s = ind_subst mind mib Univ.Instance.empty (* FIXME *)in +let type_constructor mind mib u typ params = + let s = ind_subst mind mib u in let ctyp = substl s typ in let nparams = Array.length params in if Int.equal nparams 0 then ctyp @@ -68,13 +68,13 @@ let construct_of_constr_notnative const env tag (mind, _ as ind) u allargs = let params = Array.sub allargs 0 nparams in try if const then - let ctyp = type_constructor mind mib (mip.mind_nf_lc.(0)) params in + let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(0)) params in retroknowledge Retroknowledge.get_vm_decompile_constant_info env (mkInd ind) tag, ctyp else raise Not_found with Not_found -> let i = invert_tag const tag mip.mind_reloc_tbl in - let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in + let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(i-1)) params in (mkApp(mkConstructU((ind,i),u), params), ctyp) @@ -90,12 +90,12 @@ let construct_of_constr_const env tag typ = let construct_of_constr_block = construct_of_constr false -let build_branches_type env (mind,_ as _ind) mib mip params dep p = +let build_branches_type env (mind,_ as _ind) mib mip u params dep p = let rtbl = mip.mind_reloc_tbl in (* [build_one_branch i cty] construit le type de la ieme branche (commence a 0) et les lambda correspondant aux realargs *) let build_one_branch i cty = - let typi = type_constructor mind mib cty params in + let typi = type_constructor mind mib u cty params in let decl,indapp = Reductionops.splay_prod env Evd.empty typi in let decl_with_letin,_ = decompose_prod_assum typi in let ind,cargs = find_rectype_a env indapp in @@ -292,7 +292,7 @@ and nf_atom_type env atom = let pT = whd_betadeltaiota env pT in let dep, p = nf_predicate env ind mip params p pT in (* Calcul du type des branches *) - let btypes = build_branches_type env (fst ind) mib mip params dep p in + let btypes = build_branches_type env (fst ind) mib mip u params dep p in (* calcul des branches *) let bsw = branch_of_switch (nb_rel env) ans bs in let mkbranch i v = -- cgit v1.2.3 From 908dcd613b12645f3b62bf44c2696b80a0b16940 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 28 Oct 2015 16:46:42 +0100 Subject: Avoid type checking private_constants (side_eff) again during Qed (#4357). Side effects are now an opaque data type, called private_constant, you can only obtain from safe_typing. When add_constant is called on a definition_entry that contains private constants, they are either - inlined in the main proof term but not re-checked - declared globally without re-checking them As a safety measure, the opaque data type contains a pointer to the revstruct (an internal field of safe_env that changes every time a new constant is added), and such pointer is compared with the current value store in safe_env when the private_constant is inlined. Only when the comparison is successful the private_constant is not re-checked. Otherwise else it is. In short, we accept into the kernel private constant only when they arrive in the very same order and on top of the very same env they arrived when we fist checked them. Note: private_constants produced by workers never pass the safety measure (the revstruct pointer is an Ephemeron). Sending back the entire revstruct is possible but: 1. we lack a way to quickly compare two revstructs, 2. it can be large. --- pretyping/evd.ml | 26 ++++++-------------------- pretyping/evd.mli | 4 ++-- 2 files changed, 8 insertions(+), 22 deletions(-) (limited to 'pretyping') diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 1107c2951e..0593bbca8a 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -579,7 +579,7 @@ type evar_map = { (** Metas *) metas : clbinding Metamap.t; (** Interactive proofs *) - effects : Declareops.side_effects; + effects : Safe_typing.private_constants; future_goals : Evar.t list; (** list of newly created evars, to be eventually turned into goals if not solved.*) principal_future_goal : Evar.t option; (** if [Some e], [e] must be @@ -768,7 +768,7 @@ let empty = { conv_pbs = []; last_mods = Evar.Set.empty; metas = Metamap.empty; - effects = Declareops.no_seff; + effects = Safe_typing.empty_private_constants; evar_names = (EvMap.empty,Idmap.empty); (* id<->key for undefined evars *) future_goals = []; principal_future_goal = None; @@ -1041,22 +1041,8 @@ let with_context_set rigid d (a, ctx) = (merge_context_set rigid d ctx, a) let emit_universe_side_effects eff u = - Declareops.fold_side_effects - (fun acc eff -> - match eff with - | Declarations.SEscheme (l,s) -> - List.fold_left - (fun acc (_,_,cb,c) -> - let acc = match c with - | `Nothing -> acc - | `Opaque (s, ctx) -> merge_uctx true univ_rigid acc ctx - in if cb.Declarations.const_polymorphic then acc - else - merge_uctx true univ_rigid acc - (Univ.ContextSet.of_context cb.Declarations.const_universes)) - acc l - | Declarations.SEsubproof _ -> acc) - u eff + let uctxs = Safe_typing.universes_of_private eff in + List.fold_left (merge_uctx true univ_rigid) u uctxs let add_uctx_names s l (names, names_rev) = (UNameMap.add s l names, Univ.LMap.add l s names_rev) @@ -1399,11 +1385,11 @@ let e_eq_constr_univs evdref t u = (* Side effects *) let emit_side_effects eff evd = - { evd with effects = Declareops.union_side_effects eff evd.effects; + { evd with effects = Safe_typing.concat_private eff evd.effects; universes = emit_universe_side_effects eff evd.universes } let drop_side_effects evd = - { evd with effects = Declareops.no_seff; } + { evd with effects = Safe_typing.empty_private_constants; } let eval_side_effects evd = evd.effects diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 52d7d42120..9379b50b52 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -261,10 +261,10 @@ val dependent_evar_ident : existential_key -> evar_map -> Id.t (** {5 Side-effects} *) -val emit_side_effects : Declareops.side_effects -> evar_map -> evar_map +val emit_side_effects : Safe_typing.private_constants -> evar_map -> evar_map (** Push a side-effect into the evar map. *) -val eval_side_effects : evar_map -> Declareops.side_effects +val eval_side_effects : evar_map -> Safe_typing.private_constants (** Return the effects contained in the evar map. *) val drop_side_effects : evar_map -> evar_map -- cgit v1.2.3 From 0132b5b51fc1856356fb74130d3dea7fd378f76c Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 28 Oct 2015 12:36:20 -0400 Subject: Univs: local names handling. Keep user-side information on the names used in instances of universe polymorphic references and use them for printing. --- pretyping/evd.ml | 30 ++++++++++++++++++++---------- pretyping/evd.mli | 6 +++++- 2 files changed, 25 insertions(+), 11 deletions(-) (limited to 'pretyping') diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 0593bbca8a..36d9c25fdd 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -356,6 +356,16 @@ let evar_context_universe_context ctx = Univ.ContextSet.to_context ctx.uctx_loca let evar_universe_context_of ctx = { empty_evar_universe_context with uctx_local = ctx } let evar_universe_context_subst ctx = ctx.uctx_univ_variables +let add_uctx_names s l (names, names_rev) = + (UNameMap.add s l names, Univ.LMap.add l s names_rev) + +let evar_universe_context_of_binders b = + let ctx = empty_evar_universe_context in + let names = + List.fold_left (fun acc (id, l) -> add_uctx_names (Id.to_string id) l acc) + ctx.uctx_names b + in { ctx with uctx_names = names } + let instantiate_variable l b v = v := Univ.LMap.add l (Some b) !v @@ -965,19 +975,19 @@ let pr_uctx_level uctx = let universe_context ?names evd = match names with - | None -> Univ.ContextSet.to_context evd.universes.uctx_local + | None -> [], Univ.ContextSet.to_context evd.universes.uctx_local | Some pl -> let levels = Univ.ContextSet.levels evd.universes.uctx_local in - let newinst, left = + let newinst, map, left = List.fold_right - (fun (loc,id) (newinst, acc) -> + (fun (loc,id) (newinst, map, acc) -> let l = try UNameMap.find (Id.to_string id) (fst evd.universes.uctx_names) with Not_found -> user_err_loc (loc, "universe_context", str"Universe " ++ pr_id id ++ str" is not bound anymore.") - in (l :: newinst, Univ.LSet.remove l acc)) - pl ([], levels) + in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc)) + pl ([], [], levels) in if not (Univ.LSet.is_empty left) then let n = Univ.LSet.cardinal left in @@ -985,8 +995,11 @@ let universe_context ?names evd = (str(CString.plural n "Universe") ++ spc () ++ Univ.LSet.pr (pr_uctx_level evd.universes) left ++ spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.") - else Univ.UContext.make (Univ.Instance.of_array (Array.of_list newinst), - Univ.ContextSet.constraints evd.universes.uctx_local) + else + let inst = Univ.Instance.of_array (Array.of_list newinst) in + let ctx = Univ.UContext.make (inst, + Univ.ContextSet.constraints evd.universes.uctx_local) + in map, ctx let restrict_universe_context evd vars = let uctx = evd.universes in @@ -1044,9 +1057,6 @@ let emit_universe_side_effects eff u = let uctxs = Safe_typing.universes_of_private eff in List.fold_left (merge_uctx true univ_rigid) u uctxs -let add_uctx_names s l (names, names_rev) = - (UNameMap.add s l names, Univ.LMap.add l s names_rev) - let uctx_new_univ_variable rigid name predicative ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = let u = Universes.new_univ_level (Global.current_dirpath ()) in diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 9379b50b52..3c16b27ad9 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -487,6 +487,9 @@ val union_evar_universe_context : evar_universe_context -> evar_universe_context evar_universe_context val evar_universe_context_subst : evar_universe_context -> Universes.universe_opt_subst +val evar_universe_context_of_binders : + Universes.universe_binders -> evar_universe_context + val make_evar_universe_context : env -> (Id.t located) list option -> evar_universe_context val restrict_universe_context : evar_map -> Univ.universe_set -> evar_map (** Raises Not_found if not a name for a universe in this map. *) @@ -534,7 +537,8 @@ val check_leq : evar_map -> Univ.universe -> Univ.universe -> bool val evar_universe_context : evar_map -> evar_universe_context val universe_context_set : evar_map -> Univ.universe_context_set -val universe_context : ?names:(Id.t located) list -> evar_map -> Univ.universe_context +val universe_context : ?names:(Id.t located) list -> evar_map -> + (Id.t * Univ.Level.t) list * Univ.universe_context val universe_subst : evar_map -> Universes.universe_opt_subst val universes : evar_map -> Univ.universes -- cgit v1.2.3