diff options
Diffstat (limited to 'pretyping')
49 files changed, 2947 insertions, 1389 deletions
diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 4562c5aa5f..be22030ced 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -41,12 +41,12 @@ let section_segment_of_reference = function | ConstRef con -> Lib.section_segment_of_constant con | IndRef (kn,_) | ConstructRef ((kn,_),_) -> Lib.section_segment_of_mutual_inductive kn - | _ -> [] + | _ -> [], Univ.UContext.empty let discharge_rename_args = function | _, (ReqGlobal (c, names), _ as req) -> (try - let vars = section_segment_of_reference c in + let vars,_ = section_segment_of_reference c in let c' = pop_global_reference c in let var_names = List.map (fun (id, _,_,_) -> Name id) vars in let names' = List.map (fun l -> var_names @ l) names in @@ -87,22 +87,24 @@ let rename_type ty ref = with Not_found -> ty let rename_type_of_constant env c = - let ty = Typeops.type_of_constant env c in - rename_type ty (ConstRef c) + let ty = Typeops.type_of_constant_in env c in + rename_type ty (ConstRef (fst c)) let rename_type_of_inductive env ind = let ty = Inductiveops.type_of_inductive env ind in - rename_type ty (IndRef ind) + rename_type ty (IndRef (fst ind)) let rename_type_of_constructor env cstruct = let ty = Inductiveops.type_of_constructor env cstruct in - rename_type ty (ConstructRef cstruct) + rename_type ty (ConstructRef (fst cstruct)) let rename_typing env c = - let j = Typeops.typing env c in - match kind_of_term c with - | Const c -> { j with uj_type = rename_type j.uj_type (ConstRef c) } - | Ind i -> { j with uj_type = rename_type j.uj_type (IndRef i) } - | Construct k -> { j with uj_type = rename_type j.uj_type (ConstructRef k) } - | _ -> j + let j = Typeops.infer env c in + let j' = + match kind_of_term c with + | Const (c,u) -> { j with uj_type = rename_type j.uj_type (ConstRef c) } + | Ind (i,u) -> { j with uj_type = rename_type j.uj_type (IndRef i) } + | Construct (k,u) -> { j with uj_type = rename_type j.uj_type (ConstructRef k) } + | _ -> j + in j' diff --git a/pretyping/arguments_renaming.mli b/pretyping/arguments_renaming.mli index 09b8859e66..6c37f89389 100644 --- a/pretyping/arguments_renaming.mli +++ b/pretyping/arguments_renaming.mli @@ -16,7 +16,7 @@ val rename_arguments : bool -> global_reference -> Name.t list list -> unit (** [Not_found] is raised is no names are defined for [r] *) val arguments_names : global_reference -> Name.t list list -val rename_type_of_constant : env -> constant -> types -val rename_type_of_inductive : env -> inductive -> types -val rename_type_of_constructor : env -> constructor -> types +val rename_type_of_constant : env -> pconstant -> types +val rename_type_of_inductive : env -> pinductive -> types +val rename_type_of_constructor : env -> pconstructor -> types val rename_typing : env -> constr -> unsafe_judgment diff --git a/pretyping/cases.ml b/pretyping/cases.ml index d71499eda9..1db3fac524 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -264,7 +264,8 @@ let rec find_row_ind = function | PatCstr(loc,c,_,_) :: _ -> Some (loc,c) let inductive_template evdref env tmloc ind = - let arsign = get_full_arity_sign env ind in + let indu = evd_comb1 (Evd.fresh_inductive_instance env) evdref ind in + let arsign = get_full_arity_sign env indu in let hole_source = match tmloc with | Some loc -> fun i -> (loc, Evar_kinds.TomatchTypeParameter (ind,i)) | None -> fun _ -> (Loc.ghost, Evar_kinds.InternalHole) in @@ -279,7 +280,7 @@ let inductive_template evdref env tmloc ind = | Some b -> (substl subst b::subst,evarl,n+1)) arsign ([],[],1) in - applist (mkInd ind,List.rev evarl) + applist (mkIndU indu,List.rev evarl) let try_find_ind env sigma typ realnames = let (IndType(_,realargs) as ind) = find_rectype env sigma typ in @@ -349,7 +350,7 @@ let coerce_to_indtype typing_fun evdref env matx tomatchl = (* Utils *) let mkExistential env ?(src=(Loc.ghost,Evar_kinds.InternalHole)) evdref = - e_new_evar evdref env ~src:src (new_Type ()) + let e, u = e_new_type_evar evdref univ_flexible_alg env ~src:src in e let evd_comb2 f evdref x y = let (evd',y) = f !evdref x y in @@ -928,13 +929,19 @@ let expand_arg tms (p,ccl) ((_,t),_,na) = let k = length_of_tomatch_type_sign na t in (p+k,liftn_predicate (k-1) (p+1) ccl tms) + +let use_unit_judge evd = + let j, ctx = coq_unit_judge () in + let evd' = Evd.merge_context_set Evd.univ_flexible_alg evd ctx in + evd', j + let adjust_impossible_cases pb pred tomatch submat = match submat with | [] -> begin match kind_of_term (whd_evar !(pb.evdref) pred) with | Evar (evk,_) when snd (evar_source evk !(pb.evdref)) == Evar_kinds.ImpossibleCase -> - let default = (coq_unit_judge ()).uj_type in - pb.evdref := Evd.define evk default !(pb.evdref); + let evd, default = use_unit_judge !(pb.evdref) in + pb.evdref := Evd.define evk default.uj_type evd; (* we add an "assert false" case *) let pats = List.map (fun _ -> PatVar (Loc.ghost,Anonymous)) tomatch in let aliasnames = @@ -1159,7 +1166,7 @@ let build_leaf pb = let build_branch initial current realargs deps (realnames,curname) pb arsign eqns const_info = (* We remember that we descend through constructor C *) let history = - push_history_pattern const_info.cs_nargs const_info.cs_cstr pb.history in + push_history_pattern const_info.cs_nargs (fst const_info.cs_cstr) pb.history in (* We prepare the matching on x1:T1 .. xn:Tn using some heuristic to *) (* build the name x1..xn from the names present in the equations *) @@ -1236,7 +1243,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn let cur_alias = lift const_info.cs_nargs current in let ind = appvect ( - applist (mkInd (inductive_of_constructor const_info.cs_cstr), + applist (mkIndU (inductive_of_constructor (fst const_info.cs_cstr), snd const_info.cs_cstr), List.map (lift const_info.cs_nargs) const_info.cs_params), const_info.cs_concl_realargs) in Alias (initial,(aliasname,cur_alias,(ci,ind))) in @@ -1293,7 +1300,7 @@ and match_current pb (initial,tomatch) = let mind,_ = dest_ind_family indf in let cstrs = get_constructors pb.env indf in let arsign, _ = get_arity pb.env indf in - let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in + let eqns,onlydflt = group_equations pb (fst mind) current cstrs pb.mat in let no_cstr = Int.equal (Array.length cstrs) 0 in if (not no_cstr || not (List.is_empty pb.mat)) && onlydflt then compile_all_variables initial tomatch pb @@ -1313,7 +1320,7 @@ and match_current pb (initial,tomatch) = let (pred,typ) = find_predicate pb.caseloc pb.env pb.evdref pred current indt (names,dep) tomatch in - let ci = make_case_info pb.env mind pb.casestyle in + let ci = make_case_info pb.env (fst mind) pb.casestyle in let pred = nf_betaiota !(pb.evdref) pred in let case = mkCase (ci,pred,current,brvals) in Typing.check_allowed_sort pb.env !(pb.evdref) mind current pred; @@ -1594,10 +1601,9 @@ let build_tycon loc env tycon_env subst tycon extenv evdref t = we are in an impossible branch *) let n = rel_context_length (rel_context env) in let n' = rel_context_length (rel_context tycon_env) in - let tt = new_Type () in - let impossible_case_type = - e_new_evar evdref env ~src:(loc,Evar_kinds.ImpossibleCase) tt in - (lift (n'-n) impossible_case_type, tt) + let impossible_case_type, u = + e_new_type_evar evdref univ_flexible_alg env ~src:(loc,Evar_kinds.ImpossibleCase) in + (lift (n'-n) impossible_case_type, mkSort u) | Some t -> let t = abstract_tycon loc tycon_env evdref subst tycon extenv t in let evd,tt = Typing.e_type_of extenv !evdref t in @@ -1621,9 +1627,9 @@ let build_inversion_problem loc env sigma tms t = PatVar (Loc.ghost,Name id), ((id,t)::subst, id::avoid) in let rec reveal_pattern t (subst,avoid as acc) = match kind_of_term (whd_betadeltaiota env sigma t) with - | Construct cstr -> PatCstr (Loc.ghost,cstr,[],Anonymous), acc + | Construct (cstr,u) -> PatCstr (Loc.ghost,cstr,[],Anonymous), acc | App (f,v) when isConstruct f -> - let cstr = destConstruct f in + let cstr,u = destConstruct f in let n = constructor_nrealargs env cstr in let l = List.lastn n (Array.to_list v) in let l,acc = List.fold_map' reveal_pattern l acc in @@ -1707,11 +1713,18 @@ let build_inversion_problem loc env sigma tms t = it = None } } in (* [pb] is the auxiliary pattern-matching serving as skeleton for the return type of the original problem Xi *) + (* let sigma, s = Evd.new_sort_variable sigma in *) +(*FIXME TRY *) + (* let sigma, s = Evd.new_sort_variable univ_flexible sigma in *) + let s' = Retyping.get_sort_of env sigma t in + let sigma, s = Evd.new_sort_variable univ_flexible_alg sigma in + let sigma = Evd.set_leq_sort sigma s' s in let evdref = ref sigma in + (* let ty = evd_comb1 (refresh_universes false) evdref ty in *) let pb = { env = pb_env; evdref = evdref; - pred = new_Type(); + pred = (*ty *) mkSort s; tomatch = sub_tms; history = start_history n; mat = [eqn1;eqn2]; @@ -1744,7 +1757,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = str"Unexpected type annotation for a term of non inductive type.")) | IsInd (term,IndType(indf,realargs),_) -> let indf' = if dolift then lift_inductive_family n indf else indf in - let (ind,_) = dest_ind_family indf' in + let ((ind,u),_) = dest_ind_family indf' in let nparams_ctxt,nrealargs_ctxt = inductive_nargs_env env0 ind in let arsign = fst (get_arity env0 indf') in let realnal = @@ -1848,7 +1861,11 @@ let prepare_predicate loc typing_fun sigma env tomatchs arsign tycon pred = (* we use two strategies *) let sigma,t = match tycon with | Some t -> sigma,t - | None -> new_type_evar sigma env ~src:(loc, Evar_kinds.CasesType) in + | None -> + let sigma, (t, _) = + new_type_evar univ_flexible_alg sigma env ~src:(loc, Evar_kinds.CasesType) in + sigma, t + in (* First strategy: we build an "inversion" predicate *) let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in (* Second strategy: we directly use the evar as a non dependent pred *) @@ -1858,7 +1875,7 @@ let prepare_predicate loc typing_fun sigma env tomatchs arsign tycon pred = | Some rtntyp, _ -> (* We extract the signature of the arity *) let envar = List.fold_right push_rel_context arsign env in - let sigma, newt = new_sort_variable sigma in + let sigma, newt = new_sort_variable univ_flexible_alg sigma in let evdref = ref sigma in let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref rtntyp in let sigma = !evdref in @@ -1933,7 +1950,7 @@ let constr_of_pat env evdref arsign pat avoid = with Not_found -> error_case_not_inductive env {uj_val = ty; uj_type = Typing.type_of env !evdref ty} in - let ind, params = dest_ind_family indf in + let (ind,u), params = dest_ind_family indf in if not (eq_ind ind cind) then error_bad_constructor_loc l cstr ind; let cstrs = get_constructors env indf in let ci = cstrs.(i-1) in @@ -1954,7 +1971,7 @@ let constr_of_pat env evdref arsign pat avoid = let args = List.rev args in let patargs = List.rev patargs in let pat' = PatCstr (l, cstr, patargs, alias) in - let cstr = mkConstruct ci.cs_cstr in + let cstr = mkConstructU ci.cs_cstr in let app = applistc cstr (List.map (lift (List.length sign)) params) in let app = applistc app args in let apptype = Retyping.get_type_of env ( !evdref) app in @@ -2010,7 +2027,7 @@ let vars_of_ctx ctx = | Some t' when is_topvar t' -> prev, (GApp (Loc.ghost, - (GRef (Loc.ghost, delayed_force coq_eq_refl_ref)), + (GRef (Loc.ghost, delayed_force coq_eq_refl_ref, None)), [hole; GVar (Loc.ghost, prev)])) :: vars | _ -> match na with @@ -2282,7 +2299,7 @@ let compile_program_cases loc style (typing_function, evdref) tycon env (predopt, tomatchl, eqns) = let typing_fun tycon env = function | Some t -> typing_function tycon env evdref t - | None -> coq_unit_judge () in + | None -> Evarutil.evd_comb0 use_unit_judge evdref in (* We build the matrix of patterns and right-hand side *) let matx = matx_of_eqns env eqns in @@ -2361,7 +2378,7 @@ let compile_program_cases loc style (typing_function, evdref) tycon env let typing_function tycon env evdref = function | Some t -> typing_function tycon env evdref t - | None -> coq_unit_judge () in + | None -> evd_comb0 use_unit_judge evdref in let pb = { env = env; @@ -2435,7 +2452,7 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e (* A typing function that provides with a canonical term for absurd cases*) let typing_fun tycon env evdref = function | Some t -> typing_fun tycon env evdref t - | None -> coq_unit_judge () in + | None -> evd_comb0 use_unit_judge evdref in let myevdref = ref sigma in diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 1334fb2855..4c1e3c3af2 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -45,7 +45,7 @@ type cbv_value = | LAM of int * (Name.t * constr) list * constr * cbv_value subs | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array - | CONSTR of constructor * cbv_value array + | CONSTR of constructor puniverses * cbv_value array (* type of terms with a hole. This hole can appear only under App or Case. * TOP means the term is considered without context @@ -67,6 +67,7 @@ and cbv_stack = | TOP | APP of cbv_value array * cbv_stack | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack + | PROJ of projection * Declarations.projection_body * cbv_stack (* les vars pourraient etre des constr, cela permet de retarder les lift: utile ?? *) @@ -107,7 +108,7 @@ let contract_cofixp env (i,(_,_,bds as bodies)) = let make_constr_ref n = function | RelKey p -> mkRel (n+p) | VarKey id -> mkVar id - | ConstKey cst -> mkConst cst + | ConstKey cst -> mkConstU cst (* Adds an application list. Collapse APPs! *) let stack_app appl stack = @@ -121,6 +122,7 @@ let rec stack_concat stk1 stk2 = TOP -> stk2 | APP(v,stk1') -> APP(v,stack_concat stk1' stk2) | CASE(c,b,i,s,stk1') -> CASE(c,b,i,s,stack_concat stk1' stk2) + | PROJ (p,pinfo,stk1') -> PROJ (p,pinfo,stack_concat stk1' stk2) (* merge stacks when there is no shifts in between *) let mkSTACK = function @@ -136,7 +138,7 @@ open RedFlags let red_set_ref flags = function | RelKey _ -> red_set flags fDELTA | VarKey id -> red_set flags (fVAR id) - | ConstKey sp -> red_set flags (fCONST sp) + | ConstKey (sp,_) -> red_set flags (fCONST sp) (* Transfer application lists from a value to the stack * useful because fixpoints may be totally applied in several times. @@ -193,6 +195,10 @@ let rec norm_head info env t stack = norm_head info env head (stack_app nargs stack) | Case (ci,p,c,v) -> norm_head info env c (CASE(p,v,ci,env,stack)) | Cast (ct,_,_) -> norm_head info env ct stack + + | Proj (p, c) -> + let pinfo = Option.get ((Environ.lookup_constant p (info_env info)).Declarations.const_proj) in + norm_head info env c (PROJ (p, pinfo, stack)) (* constants, axioms * the first pattern is CRUCIAL, n=0 happens very often: @@ -221,7 +227,7 @@ let rec norm_head info env t stack = (CBN(t,env), stack) (* Considérer une coupure commutative ? *) | Evar ev -> - (match evar_value info ev with + (match evar_value info.i_cache ev with Some c -> norm_head info env c stack | None -> (VAL(0, t), stack)) @@ -279,14 +285,14 @@ and cbv_stack_term info stack env t = cbv_stack_term info stk envf redfix (* constructor in a Case -> IOTA *) - | (CONSTR((sp,n),[||]), APP(args,CASE(_,br,ci,env,stk))) + | (CONSTR(((sp,n),u),[||]), APP(args,CASE(_,br,ci,env,stk))) when red_set (info_flags info) fIOTA -> let cargs = Array.sub args ci.ci_npar (Array.length args - ci.ci_npar) in cbv_stack_term info (stack_app cargs stk) env br.(n-1) (* constructor of arity 0 in a Case -> IOTA *) - | (CONSTR((_,n),[||]), CASE(_,br,_,env,stk)) + | (CONSTR(((_,n),u),[||]), CASE(_,br,_,env,stk)) when red_set (info_flags info) fIOTA -> cbv_stack_term info stk env br.(n-1) @@ -312,6 +318,8 @@ let rec apply_stack info t = function (mkCase (ci, cbv_norm_term info env ty, t, Array.map (cbv_norm_term info env) br)) st + | PROJ (p, pinfo, st) -> + apply_stack info (mkProj (p, t)) st (* performs the reduction on a constr, and returns a constr *) and cbv_norm_term info env t = @@ -348,7 +356,7 @@ and cbv_norm_value info = function (* reduction under binders *) (subs_liftn (Array.length lty) env)) bds)), Array.map (cbv_norm_value info) args) | CONSTR (c,args) -> - mkApp(mkConstruct c, Array.map (cbv_norm_value info) args) + mkApp(mkConstructU c, Array.map (cbv_norm_value info) args) (* with profiling *) let cbv_norm infos constr = diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index 66aef4d142..adb2ed15d0 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -30,12 +30,13 @@ type cbv_value = | LAM of int * (Name.t * constr) list * constr * cbv_value subs | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array - | CONSTR of constructor * cbv_value array + | CONSTR of constructor puniverses * cbv_value array and cbv_stack = | TOP | APP of cbv_value array * cbv_stack | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack + | PROJ of projection * Declarations.projection_body * cbv_stack val shift_value : int -> cbv_value -> cbv_value diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 886e00e835..86b789f7d3 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -44,7 +44,9 @@ type coe_info_typ = { coe_value : constr; coe_type : types; coe_local : bool; + coe_context : Univ.universe_context_set; coe_is_identity : bool; + coe_is_projection : bool; coe_param : int } let coe_info_typ_equal c1 c2 = @@ -52,6 +54,7 @@ let coe_info_typ_equal c1 c2 = eq_constr c1.coe_type c2.coe_type && c1.coe_local == c2.coe_local && c1.coe_is_identity == c2.coe_is_identity && + c1.coe_is_projection == c2.coe_is_projection && Int.equal c1.coe_param c2.coe_param let cl_typ_ord t1 t2 = match t1, t2 with @@ -184,16 +187,16 @@ let coercion_info coe = CoeTypMap.find coe !coercion_tab let coercion_exists coe = CoeTypMap.mem coe !coercion_tab -(* find_class_type : evar_map -> constr -> cl_typ * constr list *) +(* find_class_type : evar_map -> constr -> cl_typ * universe_list * constr list *) let find_class_type sigma t = let t', args = Reductionops.whd_betaiotazeta_stack sigma t in match kind_of_term t' with - | Var id -> CL_SECVAR id, args - | Const sp -> CL_CONST sp, args - | Ind ind_sp -> CL_IND ind_sp, args - | Prod (_,_,_) -> CL_FUN, [] - | Sort _ -> CL_SORT, [] + | Var id -> CL_SECVAR id, Univ.Instance.empty, args + | Const (sp,u) -> CL_CONST sp, u, args + | Ind (ind_sp,u) -> CL_IND ind_sp, u, args + | Prod (_,_,_) -> CL_FUN, Univ.Instance.empty, [] + | Sort _ -> CL_SORT, Univ.Instance.empty, [] | _ -> raise Not_found @@ -201,38 +204,37 @@ let subst_cl_typ subst ct = match ct with CL_SORT | CL_FUN | CL_SECVAR _ -> ct - | CL_CONST kn -> - let kn',t = subst_con subst kn in - if kn' == kn then ct else - fst (find_class_type Evd.empty t) - | CL_IND (kn,i) -> - let kn' = subst_ind subst kn in - if kn' == kn then ct else - CL_IND (kn',i) + | CL_CONST c -> + let c',t = subst_con_kn subst c in + if c' == c then ct else + pi1 (find_class_type Evd.empty t) + | CL_IND i -> + let i' = subst_ind subst i in + if i' == i then ct else CL_IND i' (*CSC: here we should change the datatype for coercions: it should be possible to declare any term as a coercion *) -let subst_coe_typ subst t = fst (subst_global subst t) +let subst_coe_typ subst t = subst_global_reference subst t (* class_of : Term.constr -> int *) let class_of env sigma t = - let (t, n1, i, args) = + let (t, n1, i, u, args) = try - let (cl,args) = find_class_type sigma t in + let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in - (t, n1, i, args) + (t, n1, i, u, args) with Not_found -> let t = Tacred.hnf_constr env sigma t in - let (cl, args) = find_class_type sigma t in + let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in - (t, n1, i, args) + (t, n1, i, u, args) in if Int.equal (List.length args) n1 then t, i else raise Not_found let inductive_class_of ind = fst (class_info (CL_IND ind)) -let class_args_of env sigma c = snd (find_class_type sigma c) +let class_args_of env sigma c = pi3 (find_class_type sigma c) let string_of_class = function | CL_FUN -> "Funclass" @@ -261,14 +263,14 @@ let lookup_path_to_sort_from_class s = let apply_on_class_of env sigma t cont = try - let (cl,args) = find_class_type sigma t in + let (cl,u,args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; t, cont i with Not_found -> (* Is it worth to be more incremental on the delta steps? *) let t = Tacred.hnf_constr env sigma t in - let (cl, args) = find_class_type sigma t in + let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; t, cont i @@ -291,7 +293,7 @@ let get_coercion_constructor coe = Reductionops.whd_betadeltaiota_stack (Global.env()) Evd.empty coe.coe_value in match kind_of_term c with - | Construct cstr -> + | Construct (cstr,u) -> (cstr, Inductiveops.constructor_nrealargs (Global.env()) cstr -1) | _ -> raise Not_found @@ -303,8 +305,12 @@ let lookup_pattern_path_between (s,t) = (* coercion_value : coe_index -> unsafe_judgment * bool *) -let coercion_value { coe_value = c; coe_type = t; coe_is_identity = b } = - (make_judge c t, b) +let coercion_value { coe_value = c; coe_type = t; coe_context = ctx; + coe_is_identity = b; coe_is_projection = b' } = + let subst, ctx = Universes.fresh_universe_context_set_instance ctx in + let c' = Vars.subst_univs_level_constr subst c + and t' = Vars.subst_univs_level_constr subst t in + (make_judge c' t', b, b'), ctx (* pretty-print functions are now in Pretty *) (* rajouter une coercion dans le graphe *) @@ -323,9 +329,15 @@ let message_ambig l = (* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit coercion,source,target *) -let different_class_params i j = - (snd (class_info_from_index i)).cl_param > 0 - +let different_class_params i = + let ci = class_info_from_index i in + if (snd ci).cl_param > 0 then true + else + match fst ci with + | CL_IND i -> Global.is_polymorphic (IndRef i) + | CL_CONST c -> Global.is_polymorphic (ConstRef c) + | _ -> false + let add_coercion_in_graph (ic,source,target) = let old_inheritance_graph = !inheritance_graph in let ambig_paths = @@ -333,12 +345,12 @@ let add_coercion_in_graph (ic,source,target) = let try_add_new_path (i,j as ij) p = try if Bijint.Index.equal i j then begin - if different_class_params i j then begin + if different_class_params i then begin let _ = lookup_path_between_class ij in ambig_paths := (ij,p)::!ambig_paths end end else begin - let _ = lookup_path_between_class (i,j) in + let _ = lookup_path_between_class ij in ambig_paths := (ij,p)::!ambig_paths end; false @@ -374,6 +386,7 @@ type coercion = { coercion_type : coe_typ; coercion_local : bool; coercion_is_id : bool; + coercion_is_proj : bool; coercion_source : cl_typ; coercion_target : cl_typ; coercion_params : int; @@ -382,7 +395,7 @@ type coercion = { (* Calcul de l'arité d'une classe *) let reference_arity_length ref = - let t = Global.type_of_global ref in + let t,_ = Universes.type_of_global ref in List.length (fst (Reductionops.splay_arity (Global.env()) Evd.empty t)) let class_params = function @@ -413,11 +426,15 @@ let cache_coercion (_, c) = let () = add_class c.coercion_target in let is, _ = class_info c.coercion_source in let it, _ = class_info c.coercion_target in + let value, ctx = Universes.fresh_global_instance (Global.env()) c.coercion_type in + let typ = Retyping.get_type_of (Global.env ()) Evd.empty value in let xf = - { coe_value = constr_of_global c.coercion_type; - coe_type = Global.type_of_global c.coercion_type; + { coe_value = value; + coe_type = typ; + coe_context = ctx; coe_local = c.coercion_local; coe_is_identity = c.coercion_is_id; + coe_is_projection = c.coercion_is_proj; coe_param = c.coercion_params } in let () = add_new_coercion c.coercion_type xf in add_coercion_in_graph (xf,is,it) @@ -441,7 +458,6 @@ let subst_coercion (subst, c) = if c.coercion_type == coe && c.coercion_source == cls && c.coercion_target == clt then c else { c with coercion_type = coe; coercion_source = cls; coercion_target = clt } - let discharge_cl = function | CL_CONST kn -> CL_CONST (Lib.discharge_con kn) | CL_IND ind -> CL_IND (Lib.discharge_inductive ind) @@ -453,7 +469,7 @@ let discharge_coercion (_, c) = let n = try let ins = Lib.section_instance c.coercion_type in - Array.length ins + Array.length (snd ins) with Not_found -> 0 in let nc = { c with @@ -477,10 +493,16 @@ let inCoercion : coercion -> obj = discharge_function = discharge_coercion } let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps = + let isproj = + match coef with + | ConstRef c -> Environ.is_projection c (Global.env ()) + | _ -> false + in let c = { coercion_type = coef; coercion_local = local; coercion_is_id = isid; + coercion_is_proj = isproj; coercion_source = cls; coercion_target = clt; coercion_params = ps; diff --git a/pretyping/classops.mli b/pretyping/classops.mli index 7bde9e910e..3251dc4eb9 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -53,9 +53,9 @@ val class_info : cl_typ -> (cl_index * cl_info_typ) val class_info_from_index : cl_index -> cl_typ * cl_info_typ -(** [find_class_type env sigma c] returns the head reference of [c] and its - arguments *) -val find_class_type : evar_map -> types -> cl_typ * constr list +(** [find_class_type env sigma c] returns the head reference of [c], + its universe instance and its arguments *) +val find_class_type : evar_map -> types -> cl_typ * Univ.universe_instance * constr list (** raises [Not_found] if not convertible to a class *) val class_of : env -> evar_map -> types -> types * cl_index @@ -73,7 +73,7 @@ val declare_coercion : (** {6 Access to coercions infos } *) val coercion_exists : coe_typ -> bool -val coercion_value : coe_index -> (unsafe_judgment * bool) +val coercion_value : coe_index -> (unsafe_judgment * bool * bool) Univ.in_universe_context_set (** {6 Lookup functions for coercion paths } *) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 1db4119be4..43af6ec629 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -34,19 +34,22 @@ exception NoCoercion exception NoCoercionNoUnifier of evar_map * unification_error (* Here, funj is a coercion therefore already typed in global context *) -let apply_coercion_args env argl funj = +let apply_coercion_args env evd check argl funj = + let evdref = ref evd in let rec apply_rec acc typ = function | [] -> { uj_val = applist (j_val funj,argl); uj_type = typ } | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas Ă faire hnf_constr *) - match kind_of_term (whd_betadeltaiota env Evd.empty typ) with + match kind_of_term (whd_betadeltaiota env evd typ) with | Prod (_,c1,c2) -> - (* Typage garanti par l'appel ŕ app_coercion*) + if check && not (e_cumul env evdref (Retyping.get_type_of env evd h) c1) then + anomaly (Pp.str"apply_coercion_args: mismatch between arguments and coercion"); apply_rec (h::acc) (subst1 h c2) restl | _ -> anomaly (Pp.str "apply_coercion_args") in - apply_rec [] funj.uj_type argl + let res = apply_rec [] funj.uj_type argl in + !evdref, res (* appliquer le chemin de coercions de patterns p *) let apply_pattern_coercion loc pat p = @@ -78,10 +81,10 @@ let disc_subset x = match kind_of_term x with | App (c, l) -> (match kind_of_term c with - Ind i -> + Ind (i,_) -> let len = Array.length l in let sigty = delayed_force sig_typ in - if Int.equal len 2 && eq_ind i (destInd sigty) + if Int.equal len 2 && eq_ind i (fst (Term.destInd sigty)) then let (a, b) = pair_of_array l in Some (a, b) @@ -170,11 +173,11 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) in match (kind_of_term x, kind_of_term y) with | Sort s, Sort s' -> - (match s, s' with - Prop x, Prop y when x == y -> None - | Prop _, Type _ -> None - | Type x, Type y when Univ.Universe.equal x y -> None (* false *) - | _ -> subco ()) + (match s, s' with + | Prop x, Prop y when x == y -> None + | Prop _, Type _ -> None + | Type x, Type y when Univ.Universe.eq x y -> None (* false *) + | _ -> subco ()) | Prod (name, a, b), Prod (name', a', b') -> let name' = Name (Namegen.next_ident_away (Id.of_string "x") (Termops.ids_of_context env)) in let env' = push_rel (name', None, a') env in @@ -195,15 +198,15 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) | App (c, l), App (c', l') -> (match kind_of_term c, kind_of_term c' with - Ind i, Ind i' -> (* Inductive types *) + Ind (i, u), Ind (i', u') -> (* Inductive types *) let len = Array.length l in let sigT = delayed_force sigT_typ in let prod = delayed_force prod_typ in (* Sigma types *) if Int.equal len (Array.length l') && Int.equal len 2 && eq_ind i i' - && (eq_ind i (destInd sigT) || eq_ind i (destInd prod)) + && (eq_ind i (fst (Term.destInd sigT)) || eq_ind i (fst (Term.destInd prod))) then - if eq_ind i (destInd sigT) + if eq_ind i (fst (Term.destInd sigT)) then begin let (a, pb), (a', pb') = @@ -323,17 +326,25 @@ let saturate_evd env evd = (* appliquer le chemin de coercions p ŕ hj *) let apply_coercion env sigma p hj typ_cl = try - fst (List.fold_left - (fun (ja,typ_cl) i -> - let fv,isid = coercion_value i in - let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in - let jres = apply_coercion_args env argl fv in - (if isid then - { uj_val = ja.uj_val; uj_type = jres.uj_type } - else - jres), - jres.uj_type) - (hj,typ_cl) p) + let j,t,evd = + List.fold_left + (fun (ja,typ_cl,sigma) i -> + let ((fv,isid,isproj),ctx) = coercion_value i in + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in + let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in + let sigma, jres = + apply_coercion_args env sigma (not (Univ.ContextSet.is_empty ctx)) argl fv + in + (if isid then + { uj_val = ja.uj_val; uj_type = jres.uj_type } + else if isproj then + { uj_val = mkProj (fst (destConst fv.uj_val), ja.uj_val); + uj_type = jres.uj_type } + else + jres), + jres.uj_type,sigma) + (hj,typ_cl,sigma) p + in evd, j with e when Errors.noncritical e -> anomaly (Pp.str "apply_coercion") let inh_app_fun env evd j = @@ -346,7 +357,7 @@ let inh_app_fun env evd j = | _ -> try let t,p = lookup_path_to_fun_from env evd j.uj_type in - (evd,apply_coercion env evd p j t) + apply_coercion env evd p j t with Not_found when Flags.is_program_mode () -> try let evdref = ref evd in @@ -367,7 +378,7 @@ let inh_app_fun resolve_tc env evd j = let inh_tosort_force loc env evd j = try let t,p = lookup_path_to_sort_from env evd j.uj_type in - let j1 = apply_coercion env evd p j t in + let evd,j1 = apply_coercion env evd p j t in let j2 = on_judgment_type (whd_evar evd) j1 in (evd,type_judgment env j2) with Not_found -> @@ -405,16 +416,16 @@ let inh_coerce_to_fail env evd rigidonly v t c1 = then raise NoCoercion else - let v', t' = + let evd, v', t' = try let t2,t1,p = lookup_path_between env evd (t,c1) in match v with Some v -> - let j = + let evd,j = apply_coercion env evd p {uj_val = v; uj_type = t} t2 in - Some j.uj_val, j.uj_type - | None -> None, t + evd, Some j.uj_val, j.uj_type + | None -> evd, None, t with Not_found -> raise NoCoercion in try (the_conv_x_leq env t' c1 evd, v') @@ -466,11 +477,20 @@ let inh_conv_coerce_to_gen resolve_tc rigidonly loc env evd cj t = | NoSubtacCoercion when not resolve_tc -> error_actual_type_loc loc env best_failed_evd cj t e | NoSubtacCoercion -> - let evd = saturate_evd env evd in + let evd' = saturate_evd env evd in try - inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t + if evd' == evd then + error_actual_type_loc loc env best_failed_evd cj t e + else + inh_conv_coerce_to_fail loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t with NoCoercionNoUnifier (best_failed_evd,e) -> error_actual_type_loc loc env best_failed_evd cj t e + + (* let evd = saturate_evd env evd in *) + (* try *) + (* inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t *) + (* with NoCoercionNoUnifier (best_failed_evd,e) -> *) + (* error_actual_type_loc loc env best_failed_evd cj t e *) in let val' = match val' with Some v -> v | None -> assert(false) in (evd',{ uj_val = val'; uj_type = t }) diff --git a/pretyping/constrMatching.ml b/pretyping/constrMatching.ml index 45b097c003..243b563d36 100644 --- a/pretyping/constrMatching.ml +++ b/pretyping/constrMatching.ml @@ -63,7 +63,7 @@ let warn_bound_again name = let constrain n (ids, m as x) (names, terms as subst) = try let (ids', m') = Id.Map.find n terms in - if List.equal Id.equal ids ids' && eq_constr m m' then subst + if List.equal Id.equal ids ids' && eq_constr_nounivs m m' then subst else raise PatternMatchingFailure with Not_found -> let () = if Id.Map.mem n names then warn_bound_meta n in @@ -139,9 +139,18 @@ let merge_binding allow_bound_rels stk n cT subst = constrain n c subst let matches_core convert allow_partial_app allow_bound_rels pat c = - let conv = match convert with - | None -> eq_constr - | Some (env,sigma) -> is_conv env sigma in + let convref ref c = + match ref, kind_of_term c with + | VarRef id, Var id' -> Names.id_eq id id' + | ConstRef c, Const (c',_) -> Names.eq_constant c c' + | IndRef i, Ind (i', _) -> Names.eq_ind i i' + | ConstructRef c, Construct (c',u) -> Names.eq_constructor c c' + | _, _ -> (match convert with + | None -> false + | Some (env,sigma) -> + let sigma,c' = Evd.fresh_global env sigma ref in + is_conv env sigma c' c) + in let rec sorec stk subst p t = let cT = strip_outer_cast t in match p,kind_of_term cT with @@ -165,7 +174,7 @@ let matches_core convert allow_partial_app allow_bound_rels pat c = | PVar v1, Var v2 when Id.equal v1 v2 -> subst - | PRef ref, _ when conv (constr_of_global ref) cT -> subst + | PRef ref, _ when convref ref cT -> subst | PRel n1, Rel n2 when Int.equal n1 n2 -> subst @@ -193,8 +202,17 @@ let matches_core convert allow_partial_app allow_bound_rels pat c = else raise PatternMatchingFailure | PApp (c1,arg1), App (c2,arg2) -> - (try Array.fold_left2 (sorec stk) (sorec stk subst c1 c2) arg1 arg2 - with Invalid_argument _ -> raise PatternMatchingFailure) + (match c1, kind_of_term c2 with + | PRef (ConstRef r), Proj _ -> + (let subst = (sorec stk subst (PProj (r,arg1.(0))) c2) in + try Array.fold_left2 (sorec stk) subst (Array.tl arg1) arg2 + with Invalid_argument _ -> raise PatternMatchingFailure) + | _ -> + (try Array.fold_left2 (sorec stk) (sorec stk subst c1 c2) arg1 arg2 + with Invalid_argument _ -> raise PatternMatchingFailure)) + + | PProj (p1,c1), Proj (p2,c2) when eq_constant p1 p2 -> + sorec stk subst c1 c2 | PProd (na1,c1,d1), Prod(na2,c2,d2) -> sorec ((na1,na2,c2)::stk) @@ -367,6 +385,10 @@ let sub_match ?(partial_app=false) ?(closed=true) pat c = let next () = try_aux ((Array.to_list types)@(Array.to_list bodies)) next_mk_ctx next in authorized_occ partial_app closed pat c mk_ctx next + | Proj (p,c') -> + let next_mk_ctx le = mk_ctx (mkProj (p,List.hd le)) in + let next () = try_aux [c'] next_mk_ctx next in + authorized_occ partial_app closed pat c mk_ctx next | Construct _| Ind _|Evar _|Const _ | Rel _|Meta _|Var _|Sort _ -> authorized_occ partial_app closed pat c mk_ctx next diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 9bc3d68c6f..652c5acf93 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -73,10 +73,7 @@ module PrintingInductiveMake = type t = inductive let compare = ind_ord let encode = Test.encode - let subst subst (kn, ints as obj) = - let kn' = subst_ind subst kn in - if kn' == kn then obj else - kn', ints + let subst subst obj = subst_ind subst obj let printer ind = pr_global_env Id.Set.empty (IndRef ind) let key = ["Printing";Test.field] let title = Test.title @@ -373,7 +370,7 @@ let detype_sort = function | Type u -> GType (if !print_universes - then Some (Pp.string_of_ppcmds (Univ.pr_uni u)) + then Some (Pp.string_of_ppcmds (Univ.Universe.pr u)) else None) type binder_kind = BProd | BLambda | BLetIn @@ -384,6 +381,10 @@ type binder_kind = BProd | BLambda | BLetIn let detype_anonymous = ref (fun loc n -> anomaly ~label:"detype" (Pp.str "index to an anonymous variable")) let set_detype_anonymous f = detype_anonymous := f +let option_of_instance l = + if Univ.Instance.is_empty l then None + else Some l + let rec detype (isgoal:bool) avoid env t = match kind_of_term (collapse_appl t) with | Rel n -> @@ -397,7 +398,7 @@ let rec detype (isgoal:bool) avoid env t = (* Meta in constr are not user-parsable and are mapped to Evar *) GEvar (dl, Evar.unsafe_of_int n, None) | Var id -> - (try let _ = Global.lookup_named id in GRef (dl, VarRef id) + (try let _ = Global.lookup_named id in GRef (dl, VarRef id, None) with Not_found -> GVar (dl, id)) | Sort s -> GSort (dl,detype_sort s) | Cast (c1,REVERTcast,c2) when not !Flags.raw_print -> @@ -415,16 +416,26 @@ let rec detype (isgoal:bool) avoid env t = | Lambda (na,ty,c) -> detype_binder isgoal BLambda avoid env na ty c | LetIn (na,b,_,c) -> detype_binder isgoal BLetIn avoid env na b c | App (f,args) -> - GApp (dl,detype isgoal avoid env f, - Array.map_to_list (detype isgoal avoid env) args) - | Const sp -> GRef (dl, ConstRef sp) + let mkapp f' args' = + match f' with + | GApp (dl',f',args'') -> + GApp (dl,f',args''@args') + | _ -> GApp (dl,f',args') + in + mkapp (detype isgoal avoid env f) + (Array.map_to_list (detype isgoal avoid env) args) + (* GApp (dl,detype isgoal avoid env f, *) + (* Array.map_to_list (detype isgoal avoid env) args) *) + | Const (sp,u) -> GRef (dl, ConstRef sp, option_of_instance u) + | Proj (p,c) -> + GProj (dl, p, detype isgoal avoid env c) | Evar (ev,cl) -> GEvar (dl, ev, Some (List.map (detype isgoal avoid env) (Array.to_list cl))) - | Ind ind_sp -> - GRef (dl, IndRef ind_sp) - | Construct cstr_sp -> - GRef (dl, ConstructRef cstr_sp) + | Ind (ind_sp,u) -> + GRef (dl, IndRef ind_sp, option_of_instance u) + | Construct (cstr_sp,u) -> + GRef (dl, ConstructRef cstr_sp, option_of_instance u) | Case (ci,p,c,bl) -> let comp = computable p (ci.ci_pp_info.ind_nargs) in detype_case comp (detype isgoal avoid env) @@ -589,7 +600,7 @@ let rec subst_cases_pattern subst pat = match pat with | PatVar _ -> pat | PatCstr (loc,((kn,i),j),cpl,n) -> - let kn' = subst_ind subst kn + let kn' = subst_mind subst kn and cpl' = List.smartmap (subst_cases_pattern subst) cpl in if kn' == kn && cpl' == cpl then pat else PatCstr (loc,((kn',i),j),cpl',n) @@ -598,7 +609,7 @@ let (f_subst_genarg, subst_genarg_hook) = Hook.make () let rec subst_glob_constr subst raw = match raw with - | GRef (loc,ref) -> + | GRef (loc,ref,u) -> let ref',t = subst_global subst ref in if ref' == ref then raw else detype false [] [] t @@ -613,6 +624,12 @@ let rec subst_glob_constr subst raw = if r' == r && rl' == rl then raw else GApp(loc,r',rl') + | GProj (loc,p,c) -> + let p' = subst_constant subst p in + let c' = subst_glob_constr subst c in + if p' == p && c' == c then raw + else GProj (loc,p',c') + | GLambda (loc,n,bk,r1,r2) -> let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in if r1' == r1 && r2' == r2 then raw else @@ -635,7 +652,7 @@ let rec subst_glob_constr subst raw = let (n,topt) = x in let topt' = Option.smartmap (fun (loc,(sp,i),y as t) -> - let sp' = subst_ind subst sp in + let sp' = subst_mind subst sp in if sp == sp' then t else (loc,(sp',i),y)) topt in if a == a' && topt == topt' then y else (a',(n,topt'))) rl and branches' = List.smartmap diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index a0542cbb21..594481af30 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -27,41 +27,52 @@ let debug_unification = ref (false) let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = false; Goptions.optname = - "Print states sended to Evarconv unification"; + "Print states sent to Evarconv unification"; Goptions.optkey = ["Debug";"Unification"]; Goptions.optread = (fun () -> !debug_unification); Goptions.optwrite = (fun a -> debug_unification:=a); } -let eval_flexible_term ts env c = +let unfold_projection env p c stk = + (match try Some (lookup_projection p env) with Not_found -> None with + | Some pb -> + let s = Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) in + Some (c, s :: stk) + | None -> None) + +let eval_flexible_term ts env c stk = match kind_of_term c with - | Const c -> + | Const (c,u as cu) -> if is_transparent_constant ts c - then constant_opt_value env c + then Option.map (fun x -> x, stk) (constant_opt_value_in env cu) else None | Rel n -> - (try let (_,v,_) = lookup_rel n env in Option.map (lift n) v + (try let (_,v,_) = lookup_rel n env in Option.map (fun t -> lift n t, stk) v with Not_found -> None) | Var id -> (try if is_transparent_variable ts id then - let (_,v,_) = lookup_named id env in v + let (_,v,_) = lookup_named id env in Option.map (fun t -> t, stk) v else None with Not_found -> None) - | LetIn (_,b,_,c) -> Some (subst1 b c) - | Lambda _ -> Some c + | LetIn (_,b,_,c) -> Some (subst1 b c, stk) + | Lambda _ -> Some (c, stk) + | Proj (p, c) -> + if is_transparent_constant ts p + then unfold_projection env p c stk + else None | _ -> assert false type flex_kind_of_term = | Rigid - | MaybeFlexible of Constr.t (* reducible but not necessarily reduced *) + | MaybeFlexible of Constr.t * Constr.t Stack.t (* reducible but not necessarily reduced *) | Flexible of existential let flex_kind_of_term ts env c sk = match kind_of_term c with - | LetIn _ | Rel _ | Const _ | Var _ -> - Option.cata (fun x -> MaybeFlexible x) Rigid (eval_flexible_term ts env c) - | Lambda _ when not (Option.is_empty (Stack.decomp sk)) -> MaybeFlexible c + | LetIn _ | Rel _ | Const _ | Var _ | Proj _ -> + Option.cata (fun (x,y) -> MaybeFlexible (x,y)) Rigid (eval_flexible_term ts env c sk) + | Lambda _ when not (Option.is_empty (Stack.decomp sk)) -> MaybeFlexible (c, sk) | Evar ev -> Flexible ev | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ -> Rigid | Meta _ -> Rigid @@ -100,36 +111,43 @@ let position_problem l2r = function projection would have been reduced) *) let check_conv_record (t1,sk1) (t2,sk2) = - let proji = global_of_constr t1 in - let canon_s,sk2_effective = - try - match kind_of_term t2 with - Prod (_,a,b) -> (* assert (l2=[]); *) + let (proji, u), arg = Universes.global_app_of_constr t1 in + let canon_s,sk2_effective = + try + match kind_of_term t2 with + Prod (_,a,b) -> (* assert (l2=[]); *) if dependent (mkRel 1) b then raise Not_found else lookup_canonical_conversion (proji, Prod_cs),(Stack.append_app [|a;pop b|] Stack.empty) - | Sort s -> - lookup_canonical_conversion - (proji, Sort_cs (family_of_sort s)),[] - | _ -> - let c2 = global_of_constr t2 in - lookup_canonical_conversion (proji, Const_cs c2),sk2 - with Not_found -> - lookup_canonical_conversion (proji,Default_cs),[] - in - let { o_DEF = c; o_INJ=n; o_TABS = bs; - o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in - let params1, c1, extra_args1 = + | Sort s -> + lookup_canonical_conversion + (proji, Sort_cs (family_of_sort s)),[] + | _ -> + let c2 = global_of_constr t2 in + lookup_canonical_conversion (proji, Const_cs c2),sk2 + with Not_found -> + lookup_canonical_conversion (proji,Default_cs),[] + in + let { o_DEF = c; o_CTX = ctx; o_INJ=n; o_TABS = bs; + o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in + let params1, c1, extra_args1 = + match arg with + | Some c -> (* A primitive projection applied to c *) + [], c, sk1 + | None -> match Stack.strip_n_app nparams sk1 with | Some (params1, c1,extra_args1) -> params1, c1, extra_args1 | _ -> raise Not_found in - let us2,extra_args2 = - let l_us = List.length us in + let us2,extra_args2 = + let l_us = List.length us in if Int.equal l_us 0 then Stack.empty,sk2_effective else match (Stack.strip_n_app (l_us-1) sk2_effective) with - | None -> raise Not_found - | Some (l',el,s') -> (l'@Stack.append_app [|el|] Stack.empty,s') in - (c,bs,(Stack.append_app_list params Stack.empty,params1),(Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, - (n,Stack.zip(t2,sk2))) + | None -> raise Not_found + | Some (l',el,s') -> (l'@Stack.append_app [|el|] Stack.empty,s') in + let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in + let c' = subst_univs_level_constr subst c in + let bs' = List.map (subst_univs_level_constr subst) bs in + ctx',c',bs',(Stack.append_app_list params Stack.empty,params1),(Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, + (n,Stack.zip(t2,sk2)) (* Precondition: one of the terms of the pb is an uninstantiated evar, * possibly applied to arguments. *) @@ -206,6 +224,9 @@ let ise_stack2 no_app env evd f sk1 sk2 = | Success i'' -> ise_stack2 true i'' q1 q2 | UnifFailure _ as x -> fail x) | UnifFailure _ as x -> fail x) + | Stack.Proj (n1,a1,p1)::q1, Stack.Proj (n2,a2,p2)::q2 -> + if eq_constant p1 p2 then ise_stack2 true i q1 q2 + else fail (UnifFailure (i, NotSameHead)) | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1,_)::q1, Stack.Fix (((li2, i2),(_,tys2,bds2)),a2,_)::q2 -> if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then @@ -259,6 +280,13 @@ let exact_ise_stack2 env evd f sk1 sk2 = ise_stack2 evd (List.rev sk1) (List.rev sk2) else UnifFailure (evd, (* Dummy *) NotSameHead) +let eq_puniverses evd pbty f (x,u) (y,v) = + if f x y then + try + Success (Evd.set_eq_instances evd u v) + with Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e) + else UnifFailure (evd, NotSameHead) + let rec evar_conv_x ts env evd pbty term1 term2 = let term1 = whd_head_evar evd term1 in let term2 = whd_head_evar evd term2 in @@ -266,15 +294,19 @@ let rec evar_conv_x ts env evd pbty term1 term2 = could have found, we do it only if the terms are free of evar. Note: incomplete heuristic... *) let ground_test = - if is_ground_term evd term1 && is_ground_term evd term2 then - if is_trans_fconv pbty ts env evd term1 term2 then - Some true - else if is_ground_env evd env then Some false - else None - else None in + if is_ground_term evd term1 && is_ground_term evd term2 then ( + let evd, b = + try infer_conv ~pb:pbty ~ts env evd term1 term2 + with Univ.UniverseInconsistency _ -> evd, false + in + if b then Some (evd, true) + else if is_ground_env evd env then Some (evd, false) + else None) + else None + in match ground_test with - | Some true -> Success evd - | Some false -> UnifFailure (evd,ConversionFailed (env,term1,term2)) + | Some (evd, true) -> Success evd + | Some (evd, false) -> UnifFailure (evd,ConversionFailed (env,term1,term2)) | None -> (* Until pattern-unification is used consistently, use nohdbeta to not destroy beta-redexes that can be used for 1st-order unification *) @@ -392,11 +424,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty in ise_try evd [f1; f2] - | Flexible ev1, MaybeFlexible v2 -> flex_maybeflex true ev1 (appr1,csts1) (appr2,csts2) v2 + | Flexible ev1, MaybeFlexible (v2,sk2) -> + flex_maybeflex true ev1 (appr1,csts1) ((term2,sk2),csts2) v2 - | MaybeFlexible v1, Flexible ev2 -> flex_maybeflex false ev2 (appr2,csts2) (appr1,csts1) v1 + | MaybeFlexible (v1,sk1), Flexible ev2 -> + flex_maybeflex false ev2 (appr2,csts2) ((term1,sk1),csts1) v1 - | MaybeFlexible v1, MaybeFlexible v2 -> begin + | MaybeFlexible (v1,sk1), MaybeFlexible (v2,sk2) -> begin match kind_of_term term1, kind_of_term term2 with | LetIn (na,b1,t1,c'1), LetIn (_,b2,_,c'2) -> let f1 i = @@ -414,12 +448,37 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty in ise_try evd [f1; f2] + | Proj (p, c), Proj (p', c') when eq_constant p p' -> + let f1 i = + ise_and i + [(fun i -> evar_conv_x ts env i CONV c c'); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] + and f2 i = + if is_transparent_constant ts p then + match unfold_projection env p c sk1 with + | Some (c, sk1) -> + let out1 = whd_betaiota_deltazeta_for_iota_state ts env i csts1 (c,sk1) in + evar_eqappr_x ts env i pbty out1 (appr2, csts2) + | None -> assert false + else UnifFailure (i, NotSameHead) + in + ise_try evd [f1; f2] + | _, _ -> - let f1 i = - if eq_constr term1 term2 then - exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2 - else - UnifFailure (i,NotSameHead) + let f1 i = + (* Gather the universe constraints that would make term1 and term2 equal. + If these only involve unifications of flexible universes to other universes, + allow this identification (first-order unification of universes). Otherwise + fallback to unfolding. + *) + let b,univs = eq_constr_universes term1 term2 in + if b then + ise_and i [(fun i -> + try Success (Evd.add_universe_constraints i univs) + with UniversesDiffer -> UnifFailure (i,NotSameHead) + | Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] + else UnifFailure (i,NotSameHead) and f2 i = (try conv_record ts env i (try check_conv_record appr1 appr2 @@ -438,9 +497,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (* false (* immediate solution without Canon Struct *)*) | Lambda _ -> assert (match args with [] -> true | _ -> false); true | LetIn (_,b,_,c) -> is_unnamed - (fst (whd_betaiota_deltazeta_for_iota_state + (fst (whd_betaiota_deltazeta_for_iota_state ts env i Cst_stack.empty (subst1 b c, args))) - | Case _| Fix _| App _| Cast _ -> assert false in + | Fix _ -> true (* Partially applied fix can be the result of a whd call *) + | Proj (p, c) -> true + | Case _ | App _| Cast _ -> assert false in let rhs_is_stuck_and_unnamed () = let applicative_stack = fst (Stack.strip_app sk2) in is_unnamed @@ -475,7 +536,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2 | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1 - | MaybeFlexible v1, Rigid -> + | MaybeFlexible (v1,sk1), Rigid -> let f3 i = (try conv_record ts env i (check_conv_record appr1 appr2) with Not_found -> UnifFailure (i,NoCanonicalStructure)) @@ -487,14 +548,14 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty in ise_try evd [f3; f4] - | Rigid, MaybeFlexible v2 -> + | Rigid, MaybeFlexible (v2,sk2) -> let f3 i = (try conv_record ts env i (check_conv_record appr2 appr1) with Not_found -> UnifFailure (i,NoCanonicalStructure)) and f4 i = - evar_eqappr_x ts env i pbty (appr1,csts1) - (whd_betaiota_deltazeta_for_iota_state - ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + evar_eqappr_x ts env i pbty (appr1,csts1) + (whd_betaiota_deltazeta_for_iota_state + ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) in ise_try evd [f3; f4] @@ -515,8 +576,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty then Evd.set_eq_sort evd s1 s2 else Evd.set_leq_sort evd s1 s2 in Success evd' - with Univ.UniverseInconsistency _ -> - UnifFailure (evd,UnifUnivInconsistency) + with Univ.UniverseInconsistency p -> + UnifFailure (evd,UnifUnivInconsistency p) | e when Errors.noncritical e -> UnifFailure (evd,NotSameHead)) | Prod (n,c1,c'1), Prod (_,c2,c'2) when app_empty -> @@ -537,19 +598,19 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty else UnifFailure (evd,NotSameHead) | Const c1, Const c2 -> - if eq_constant c1 c2 then - exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2 - else UnifFailure (evd,NotSameHead) + ise_and evd + [(fun i -> eq_puniverses i pbty eq_constant c1 c2); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] | Ind sp1, Ind sp2 -> - if eq_ind sp1 sp2 then - exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2 - else UnifFailure (evd,NotSameHead) + ise_and evd + [(fun i -> eq_puniverses i pbty eq_ind sp1 sp2); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] | Construct sp1, Construct sp2 -> - if eq_constructor sp1 sp2 then - exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2 - else UnifFailure (evd,NotSameHead) + ise_and evd + [(fun i -> eq_puniverses i pbty eq_constructor sp1 sp2); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] | Fix ((li1, i1),(_,tys1,bds1 as recdef1)), Fix ((li2, i2),(_,tys2,bds2)) -> (* Partially applied fixs *) if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then @@ -583,13 +644,14 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | _, (Ind _ | Construct _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _) -> UnifFailure (evd,NotSameHead) - | (App _ | Cast _ | Case _), _ -> assert false + | (App _ | Cast _ | Case _ | Proj _), _ -> assert false | (LetIn _| Evar _), _ -> assert false | (Lambda _), _ -> assert false end -and conv_record trs env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = +and conv_record trs env evd (ctx,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = + let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in if Reductionops.Stack.compare_shape ts ts1 then let (evd',ks,_) = List.fold_left @@ -614,6 +676,28 @@ and conv_record trs env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) (fun i -> exact_ise_stack2 env i (evar_conv_x trs) ts ts1)] else UnifFailure(evd,(*dummy*)NotSameHead) +and eta_constructor ts env evd ((ind, i), u) l1 csts1 (c, csts2) = + let mib = lookup_mind (fst ind) env in + match mib.Declarations.mind_record with + | Some (exp,projs) when Array.length projs > 0 -> + let pars = mib.Declarations.mind_nparams in + (try + let l1' = Stack.tail pars l1 in + if Environ.is_projection projs.(0) env then + let sk2 = + let term = Stack.zip c in + List.map (fun p -> mkProj (p, term)) (Array.to_list projs) + in + exact_ise_stack2 env evd (evar_conv_x ts) l1' + (Stack.append_app_list sk2 Stack.empty) + else raise (Failure "") + with Failure _ -> UnifFailure(evd,NotSameHead)) + | _ -> UnifFailure (evd,NotSameHead) + +(* Profiling *) +(* let evar_conv_xkey = Profile.declare_profile "evar_conv_x";; *) +(* let evar_conv_x = Profile.profile6 evar_conv_xkey evar_conv_x *) + (* We assume here |l1| <= |l2| *) let first_order_unification ts env evd (ev1,l1) (term2,l2) = @@ -846,7 +930,7 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = (* Some head evar have been instantiated, or unknown kind of problem *) evar_conv_x ts env evd pbty t1 t2 -let check_problems_are_solved evd = +let check_problems_are_solved env evd = match snd (extract_all_conv_pbs evd) with | (pbty,env,t1,t2)::_ -> Pretype_errors.error_cannot_unify env evd (t1, t2) | _ -> () @@ -890,10 +974,16 @@ let rec solve_unconstrained_evars_with_canditates ts evd = let evd = aux (List.rev l) in solve_unconstrained_evars_with_canditates ts evd -let solve_unconstrained_impossible_cases evd = +let solve_unconstrained_impossible_cases env evd = Evd.fold_undefined (fun evk ev_info evd' -> match ev_info.evar_source with - | _,Evar_kinds.ImpossibleCase -> Evd.define evk (j_type (coq_unit_judge ())) evd' + | _,Evar_kinds.ImpossibleCase -> + let j, ctx = coq_unit_judge () in + let evd' = Evd.merge_context_set Evd.univ_flexible_alg evd' ctx in + let ty = j_type j in + let conv_algo = evar_conv_x full_transparent_state in + let evd' = check_evar_instance evd' evk ty conv_algo in + Evd.define evk ty evd' | _ -> evd') evd evd let consider_remaining_unif_problems env @@ -925,8 +1015,8 @@ let consider_remaining_unif_problems env in let (evd,pbs) = extract_all_conv_pbs evd in let heuristic_solved_evd = aux evd pbs false [] in - check_problems_are_solved heuristic_solved_evd; - solve_unconstrained_impossible_cases heuristic_solved_evd + check_problems_are_solved env heuristic_solved_evd; + solve_unconstrained_impossible_cases env heuristic_solved_evd (* Main entry points *) diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 3eb01439ee..c99929b5ec 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -38,12 +38,12 @@ val consider_remaining_unif_problems : env -> ?ts:transparent_state -> evar_map (** Check all pending unification problems are solved and raise an error otherwise *) -val check_problems_are_solved : evar_map -> unit +val check_problems_are_solved : env -> evar_map -> unit (** Check if a canonical structure is applicable *) val check_conv_record : constr * types Stack.t -> constr * types Stack.t -> - constr * constr list * (constr Stack.t * constr Stack.t) * + Univ.universe_context_set * constr * constr list * (constr Stack.t * constr Stack.t) * (constr Stack.t * types Stack.t) * (constr Stack.t * types Stack.t) * constr * (int * constr) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 4f982114af..b3c65ebaf5 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -26,6 +26,24 @@ let normalize_evar evd ev = | Evar (evk,args) -> (evk,args) | _ -> assert false +let refresh_universes dir evd t = + let evdref = ref evd in + let modified = ref false in + let rec refresh t = match kind_of_term t with + | Sort (Type u as s) when Univ.universe_level u = None || + Evd.is_sort_variable evd s = None -> + (modified := true; + (* s' will appear in the term, it can't be algebraic *) + let s' = evd_comb0 (new_sort_variable Evd.univ_flexible) evdref in + evdref := + (if dir then set_leq_sort !evdref s' s else + set_leq_sort !evdref s s'); + mkSort s') + | Prod (na,u,v) -> mkProd (na,u,refresh v) + | _ -> t in + let t' = refresh t in + if !modified then !evdref, t' else evd, t + (************************) (* Unification results *) (************************) @@ -416,8 +434,8 @@ let make_projectable_subst aliases sigma evi args = let a',args = decompose_app_vect a in match kind_of_term a' with | Construct cstr -> - let l = try Constrmap.find cstr cstrs with Not_found -> [] in - Constrmap.add cstr ((args,id)::l) cstrs + let l = try Constrmap.find (fst cstr) cstrs with Not_found -> [] in + Constrmap.add (fst cstr) ((args,id)::l) cstrs | _ -> cstrs in (rest,Id.Map.add id [a,normalize_alias_opt aliases a,id] all,cstrs) | Some c, a::rest -> @@ -450,6 +468,7 @@ let make_projectable_subst aliases sigma evi args = let define_evar_from_virtual_equation define_fun env evd t_in_env sign filter inst_in_env = let ty_t_in_env = Retyping.get_type_of env evd t_in_env in + let evd,ty_t_in_env = refresh_universes false evd ty_t_in_env in let evd,evar_in_env = new_evar_instance sign evd ty_t_in_env ~filter inst_in_env in let t_in_env = whd_evar evd t_in_env in let evd = define_fun env evd None (destEvar evar_in_env) t_in_env in @@ -955,7 +974,7 @@ exception CannotProject of Filter.t option let rec is_constrainable_in k (ev,(fv_rels,fv_ids) as g) t = let f,args = decompose_app_vect t in match kind_of_term f with - | Construct (ind,_) -> + | Construct ((ind,_),u) -> let n = Inductiveops.inductive_nparams ind in if n > Array.length args then true (* We don't try to be more clever *) else @@ -1012,10 +1031,26 @@ let project_evar_on_evar g env evd aliases k2 (evk1,argsv1 as ev1) (evk2,argsv2 else raise (CannotProject filter1) +exception IllTypedInstance of env * types * types + +let check_evar_instance evd evk1 body conv_algo = + let evi = Evd.find evd evk1 in + let evenv = evar_env evi in + (* FIXME: The body might be ill-typed when this is called from w_merge *) + (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) + let ty = + try Retyping.get_type_of ~lax:true evenv evd body + with Retyping.RetypeError _ -> error "Ill-typed evar instance" + in + match conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl with + | Success evd -> evd + | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,evi.evar_concl)) + let solve_evar_evar_l2r f g env evd aliases pbty ev1 (evk2,_ as ev2) = try let evd,body = project_evar_on_evar g env evd aliases 0 ev1 ev2 in - Evd.define evk2 body evd + let evd' = Evd.define evk2 body evd in + check_evar_instance evd' evk2 body g with EvarSolvedOnTheFly (evd,c) -> f env evd pbty ev2 c @@ -1037,27 +1072,39 @@ let solve_evar_evar ?(force=false) f g env evd pbty (evk1,args1 as ev1) (evk2,ar with CannotProject filter2 -> postpone_evar_evar f env evd pbty filter1 ev1 filter2 ev2 +let solve_evar_evar ?(force=false) f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = + let evi = Evd.find evd evk1 in + try + (* ?X : Î Î. Type i = ?Y : Î Î'. Type j. + The body of ?X and ?Y just has to be of type Î Î. Type k for some k <= i, j. *) + let evienv = Evd.evar_env evi in + let ctx, i = Reduction.dest_arity evienv evi.evar_concl in + let evi2 = Evd.find evd evk2 in + let evi2env = Evd.evar_env evi2 in + let ctx', j = Reduction.dest_arity evi2env evi2.evar_concl in + if i == j || Evd.check_eq evd (univ_of_sort i) (univ_of_sort j) + then (* Shortcut, i = j *) + solve_evar_evar ~force f g env evd pbty ev1 ev2 + else + let evd, k = Evd.new_sort_variable univ_flexible_alg evd in + let evd, ev3 = + Evarutil.new_pure_evar evd (Evd.evar_hyps evi) + ~src:evi.evar_source ~filter:evi.evar_filter + ?candidates:evi.evar_candidates (it_mkProd_or_LetIn (mkSort k) ctx) + in + let evd = Evd.set_leq_sort (Evd.set_leq_sort evd k i) k j in + solve_evar_evar ~force f g env + (solve_evar_evar ~force f g env evd None (ev3,args1) ev1) + pbty (ev3,args1) ev2 + with Reduction.NotArity -> + solve_evar_evar ~force f g env evd None ev1 ev2 + type conv_fun = env -> evar_map -> conv_pb -> constr -> constr -> unification_result type conv_fun_bool = env -> evar_map -> conv_pb -> constr -> constr -> bool -exception IllTypedInstance of env * types * types - -let check_evar_instance evd evk1 body conv_algo = - let evi = Evd.find evd evk1 in - let evenv = evar_env evi in - (* FIXME: The body might be ill-typed when this is called from w_merge *) - (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) - let ty = - try Retyping.get_type_of ~lax:true evenv evd body - with Retyping.RetypeError _ -> error "Ill-typed evar instance" - in - match conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl with - | Success evd -> evd - | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,evi.evar_concl)) - (* Solve pbs ?e[t1..tn] = ?e[u1..un] which arise often in fixpoint * definitions. We try to unify the ti with the ui pairwise. The pairs * that don't unify are discarded (i.e. ?e is redefined so that it does not @@ -1137,6 +1184,9 @@ exception NotEnoughInformationEvarEvar of constr exception OccurCheckIn of evar_map * constr exception MetaOccurInBodyInternal +let fast_stats = ref 0 +let not_fast_stats = ref 0 + let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let aliases = make_alias_map env in let evdref = ref evd in @@ -1224,7 +1274,8 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = (* Try to project (a restriction of) the left evar ... *) try let evd,body = project_evar_on_evar conv_algo env' evd aliases 0 ev'' ev' in - Evd.define evk' body evd + let evd = Evd.define evk' body evd in + check_evar_instance evd evk' body conv_algo with | EvarSolvedOnTheFly _ -> assert false (* ev has no candidates *) | CannotProject filter'' -> @@ -1237,7 +1288,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = match let c,args = decompose_app_vect t in match kind_of_term c with - | Construct cstr when noccur_between 1 k t -> + | Construct (cstr,u) when noccur_between 1 k t -> (* This is common case when inferring the return clause of match *) (* (currently rudimentary: we do not treat the case of multiple *) (* possible inversions; we do not treat overlap with a possible *) @@ -1268,6 +1319,19 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) imitate envk t in + let _fast rhs = + let filter_ctxt = evar_filtered_context evi in + let names = ref Idset.empty in + let rec is_id_subst ctxt s = + match ctxt, s with + | ((id, _, _) :: ctxt'), (c :: s') -> + names := Idset.add id !names; + isVarId id c && is_id_subst ctxt' s' + | [], [] -> true + | _ -> false in + is_id_subst filter_ctxt (Array.to_list argsv) && + closed0 rhs && + Idset.subset (collect_vars rhs) !names in let rhs = whd_beta evd rhs (* heuristic *) in let fast rhs = let filter_ctxt = evar_filtered_context evi in @@ -1296,7 +1360,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = * context "hyps" and not referring to itself. *) -and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = +and evar_define conv_algo ?(choose=false) ?(dir=false) env evd pbty (evk,argsv as ev) rhs = match kind_of_term rhs with | Evar (evk2,argsv2 as ev2) -> if Evar.equal evk evk2 then @@ -1315,7 +1379,7 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = (* so we recheck acyclicity *) if occur_evar evk body then raise (OccurCheckIn (evd',body)); (* needed only if an inferred type *) - let body = refresh_universes body in + let evd', body = refresh_universes dir evd' body in (* Cannot strictly type instantiations since the unification algorithm * does not unify applications from left to right. * e.g problem f x == g y yields x==y and f==g (in that order) @@ -1399,8 +1463,9 @@ let reconsider_conv_pbs conv_algo evd = let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1),t2) = try let t2 = whd_betaiota evd t2 in (* includes whd_evar *) - let evd = evar_define conv_algo ~choose env evd pbty ev1 t2 in - reconsider_conv_pbs conv_algo evd + let dir = match pbty with Some d -> d | None -> false in + let evd = evar_define conv_algo ~choose ~dir env evd pbty ev1 t2 in + reconsider_conv_pbs conv_algo evd with | NotInvertibleUsingOurAlgorithm t -> UnifFailure (evd,NotClean (ev1,t)) diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 5d0063c476..7276669bf5 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -31,9 +31,11 @@ type conv_fun = type conv_fun_bool = env -> evar_map -> conv_pb -> constr -> constr -> bool -val evar_define : conv_fun -> ?choose:bool -> env -> evar_map -> +val evar_define : conv_fun -> ?choose:bool -> ?dir:bool -> env -> evar_map -> bool option -> existential -> constr -> evar_map +val refresh_universes : bool -> evar_map -> types -> evar_map * types + val solve_refl : ?can_drop:bool -> conv_fun_bool -> env -> evar_map -> bool option -> existential_key -> constr array -> constr array -> evar_map diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 1605ef7cff..908e592270 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -21,6 +21,27 @@ open Evd open Reductionops open Pretype_errors +let evd_comb0 f evdref = + let (evd',x) = f !evdref in + evdref := evd'; + x + +let evd_comb1 f evdref x = + let (evd',y) = f !evdref x in + evdref := evd'; + y + +let evd_comb2 f evdref x y = + let (evd',z) = f !evdref x y in + evdref := evd'; + z + +let e_new_global evdref x = + evd_comb1 (Evd.fresh_global (Global.env())) evdref x + +let new_global evd x = + Evd.fresh_global (Global.env()) evd x + (****************************************************) (* Expanding/testing/exposing existential variables *) (****************************************************) @@ -37,6 +58,8 @@ let rec flush_and_check_evars sigma c = | Some c -> flush_and_check_evars sigma c) | _ -> map_constr (flush_and_check_evars sigma) c +(* let nf_evar_key = Profile.declare_profile "nf_evar" *) +(* let nf_evar = Profile.profile2 nf_evar_key Reductionops.nf_evar *) let nf_evar = Reductionops.nf_evar let j_nf_evar sigma j = { uj_val = nf_evar sigma j.uj_val; @@ -60,24 +83,38 @@ let env_nf_betaiotaevar sigma env = (fun d e -> push_rel (map_rel_declaration (Reductionops.nf_betaiota sigma) d) e) env +let nf_evars_universes evm = + Universes.nf_evars_and_universes_opt_subst (Reductionops.safe_evar_value evm) + (Evd.universe_subst evm) + +let nf_evars_and_universes evm = + let evm = Evd.nf_constraints evm in + evm, nf_evars_universes evm + +let e_nf_evars_and_universes evdref = + evdref := Evd.nf_constraints !evdref; + nf_evars_universes !evdref, Evd.universe_subst !evdref + +let nf_evar_map_universes evm = + let evm = Evd.nf_constraints evm in + let subst = Evd.universe_subst evm in + if Univ.LMap.is_empty subst then evm, nf_evar evm + else + let f = nf_evars_universes evm in + Evd.raw_map (fun _ -> map_evar_info f) evm, f + let nf_named_context_evar sigma ctx = - Context.map_named_context (Reductionops.nf_evar sigma) ctx + Context.map_named_context (nf_evar sigma) ctx let nf_rel_context_evar sigma ctx = - Context.map_rel_context (Reductionops.nf_evar sigma) ctx + Context.map_rel_context (nf_evar sigma) ctx let nf_env_evar sigma env = let nc' = nf_named_context_evar sigma (Environ.named_context env) in let rel' = nf_rel_context_evar sigma (Environ.rel_context env) in push_rel_context rel' (reset_with_named_context (val_of_named_context nc') env) -let nf_evar_info evc info = - { info with - evar_concl = Reductionops.nf_evar evc info.evar_concl; - evar_hyps = map_named_val (Reductionops.nf_evar evc) info.evar_hyps; - evar_body = match info.evar_body with - | Evar_empty -> Evar_empty - | Evar_defined c -> Evar_defined (Reductionops.nf_evar evc c) } +let nf_evar_info evc info = map_evar_info (nf_evar evc) info let nf_evar_map evm = Evd.raw_map (fun _ evi -> nf_evar_info evm evi) evm @@ -89,7 +126,7 @@ let nf_evar_map_undefined evm = (* Auxiliary functions for the conversion algorithms modulo evars *) -let has_undefined_evars_or_sorts evd t = +let has_undefined_evars or_sorts evd t = let rec has_ev t = match kind_of_term t with | Evar (ev,args) -> @@ -98,13 +135,16 @@ let has_undefined_evars_or_sorts evd t = has_ev c; Array.iter has_ev args | Evar_empty -> raise NotInstantiatedEvar) - | Sort s when is_sort_variable evd s -> raise Not_found + | Sort (Type _) (*FIXME could be finer, excluding Prop and Set universes *) when or_sorts -> + raise Not_found + | Ind (_,l) | Const (_,l) | Construct (_,l) + when l <> Univ.Instance.empty && or_sorts -> raise Not_found | _ -> iter_constr has_ev t in try let _ = has_ev t in false with (Not_found | NotInstantiatedEvar) -> true let is_ground_term evd t = - not (has_undefined_evars_or_sorts evd t) + not (has_undefined_evars true evd t) let is_ground_env evd env = let is_ground_decl = function @@ -333,9 +373,21 @@ let new_evar evd env ?src ?filter ?candidates typ = | Some filter -> Filter.filter_list filter instance in new_evar_instance sign evd typ' ?src ?filter ?candidates instance -let new_type_evar ?src ?filter evd env = - let evd', s = new_sort_variable evd in - new_evar evd' env ?src ?filter (mkSort s) +let new_type_evar ?src ?filter rigid evd env = + let evd', s = new_sort_variable rigid evd in + let evd', e = new_evar evd' env ?src ?filter (mkSort s) in + evd', (e, s) + + (* The same using side-effect *) +let e_new_evar evdref env ?(src=(Loc.ghost,Evar_kinds.InternalHole)) ?filter ?candidates ty = + let (evd',ev) = new_evar !evdref env ~src:src ?filter ?candidates ty in + evdref := evd'; + ev + +let e_new_type_evar evdref ?src ?filter rigid env = + let evd', c = new_type_evar ?src ?filter rigid !evdref env in + evdref := evd'; + c (* The same using side-effect *) let e_new_evar evdref env ?(src=default_source) ?filter ?candidates ty = @@ -470,7 +522,6 @@ let clear_hyps_in_evi evdref hyps concl ids = in (nhyps,nconcl) - (** The following functions return the set of evars immediately contained in the object, including defined evars *) @@ -597,6 +648,7 @@ let check_evars env initial_sigma sigma c = | _ -> iter_constr proc_rec c in proc_rec c + (****************************************) (* Operations on value/type constraints *) (****************************************) @@ -639,15 +691,25 @@ let define_pure_evar_as_product evd evk = let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in - let evd1,dom = new_type_evar evd evenv ~filter:(evar_filter evi) in + let s = destSort evi.evar_concl in + let evd1,(dom,u1) = new_type_evar univ_flexible_alg evd evenv ~filter:(evar_filter evi) in let evd2,rng = let newenv = push_named (id, None, dom) evenv in let src = evar_source evk evd1 in let filter = Filter.extend 1 (evar_filter evi) in - new_type_evar evd1 newenv ~src ~filter in + if is_prop_sort s then + (* Impredicative product, conclusion must fall in [Prop]. *) + new_evar evd1 newenv evi.evar_concl ~src ~filter + else + let evd3, (rng, srng) = + new_type_evar univ_flexible_alg evd1 newenv ~src ~filter in + let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in + let evd3 = Evd.set_leq_sort evd3 (Type prods) s in + evd3, rng + in let prod = mkProd (Name id, dom, subst_var id rng) in let evd3 = Evd.define evk prod evd2 in - evd3,prod + evd3,prod (* Refine an applied evar to a product and returns its instantiation *) @@ -707,15 +769,18 @@ let rec evar_absorb_arguments env evd (evk,args as ev) = function (* Refining an evar to a sort *) let define_evar_as_sort evd (ev,args) = - let evd, s = new_sort_variable evd in - Evd.define ev (mkSort s) evd, s + let evd, u = new_univ_variable univ_rigid evd in + let evi = Evd.find_undefined evd ev in + let s = Type u in + let evd' = Evd.define ev (mkSort s) evd in + Evd.set_leq_sort evd' (Type (Univ.super u)) (destSort evi.evar_concl), s (* We don't try to guess in which sort the type should be defined, since any type has type Type. May cause some trouble, but not so far... *) let judge_of_new_Type evd = - let evd', s = new_univ_variable evd in - evd', Typeops.judge_of_type s + let evd', s = new_univ_variable univ_rigid evd in + evd', { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) } (* Propagation of constraints through application and abstraction: Given a type constraint on a functional term, returns the type diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index f41f1ec862..b860ce3370 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -39,7 +39,16 @@ val e_new_evar : (** Create a new Type existential variable, as we keep track of them during type-checking and unification. *) val new_type_evar : - ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> evar_map -> env -> evar_map * constr + ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> rigid -> evar_map -> env -> + evar_map * (constr * sorts) + +val e_new_type_evar : evar_map ref -> + ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> rigid -> env -> constr * sorts + +(** Polymorphic constants *) + +val new_global : evar_map -> Globnames.global_reference -> evar_map * constr +val e_new_global : evar_map ref -> Globnames.global_reference -> constr (** Create a fresh evar in a context different from its definition context: [new_evar_instance sign evd ty inst] creates a new evar of context @@ -65,6 +74,9 @@ val head_evar : constr -> existential_key (** may raise NoHeadEvar *) (* Expand head evar if any *) val whd_head_evar : evar_map -> constr -> constr +(* [has_undefined_evars or_sorts evd c] checks if [c] has undefined evars + and optionally if it contains undefined sorts. *) +val has_undefined_evars : bool -> evar_map -> constr -> bool val is_ground_term : evar_map -> constr -> bool val is_ground_env : evar_map -> env -> bool (** [check_evars env initial_sigma extended_sigma c] fails if some @@ -160,6 +172,15 @@ val jv_nf_betaiotaevar : evar_map -> unsafe_judgment array -> unsafe_judgment array (** Presenting terms without solved evars *) +val nf_evars_universes : evar_map -> constr -> constr + +val nf_evars_and_universes : evar_map -> evar_map * (constr -> constr) +val e_nf_evars_and_universes : evar_map ref -> (constr -> constr) * Universes.universe_opt_subst + +(** Normalize the evar map w.r.t. universes, after simplification of constraints. + Return the substitution function for constrs as well. *) +val nf_evar_map_universes : evar_map -> evar_map * (constr -> constr) + (** Replacing all evars, possibly raising [Uninstantiated_evar] *) exception Uninstantiated_evar of existential_key val flush_and_check_evars : evar_map -> constr -> constr @@ -189,3 +210,9 @@ val push_rel_context_to_named_context : Environ.env -> types -> named_context_val * types * constr list * constr list * (identifier*constr) list val generalize_evar_over_rels : evar_map -> existential -> types * constr list + +(** Evar combinators *) + +val evd_comb0 : (evar_map -> evar_map * 'a) -> evar_map ref -> 'a +val evd_comb1 : (evar_map -> 'b -> evar_map * 'a) -> evar_map ref -> 'b -> 'a +val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b -> 'c -> 'a diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 8fc6b8ab2f..0776988d79 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -207,6 +207,18 @@ let eq_evar_info ei1 ei2 = eq_evar_body ei1.evar_body ei2.evar_body (** ppedrot: [eq_constr] may be a bit too permissive here *) + +let map_evar_body f = function + | Evar_empty -> Evar_empty + | Evar_defined d -> Evar_defined (f d) + +let map_evar_info f evi = + {evi with + evar_body = map_evar_body f evi.evar_body; + evar_hyps = map_named_val f evi.evar_hyps; + evar_concl = f evi.evar_concl; + evar_candidates = Option.map (List.map f) evi.evar_candidates } + (* spiwack: Revised hierarchy : - Evar.Map ( Maps of existential_keys ) - EvarInfoMap ( .t = evar_info Evar.Map.t * evar_info Evar.Map ) @@ -250,6 +262,202 @@ let instantiate_evar_array info c args = | [] -> c | _ -> replace_vars inst c +(* 2nd part used to check consistency on the fly. *) +type evar_universe_context = + { uctx_local : Univ.universe_context_set; (** The local context of variables *) + uctx_postponed : Univ.universe_constraints; + uctx_univ_variables : Universes.universe_opt_subst; + (** The local universes that are unification variables *) + uctx_univ_algebraic : Univ.universe_set; + (** The subset of unification variables that + can be instantiated with algebraic universes as they appear in types + and universe instances only. *) + uctx_universes : Univ.universes; (** The current graph extended with the local constraints *) + } + +let empty_evar_universe_context = + { uctx_local = Univ.ContextSet.empty; + uctx_postponed = Univ.UniverseConstraints.empty; + uctx_univ_variables = Univ.LMap.empty; + uctx_univ_algebraic = Univ.LSet.empty; + uctx_universes = Univ.initial_universes } + +let evar_universe_context_from e c = + {empty_evar_universe_context with + uctx_local = c; uctx_universes = universes e} + +let is_empty_evar_universe_context ctx = + Univ.ContextSet.is_empty ctx.uctx_local && + Univ.LMap.is_empty ctx.uctx_univ_variables + +let union_evar_universe_context ctx ctx' = + if ctx == ctx' then ctx + else if is_empty_evar_universe_context ctx then ctx' + else if is_empty_evar_universe_context ctx' then ctx + else + let local = + if ctx.uctx_local == ctx'.uctx_local then ctx.uctx_local + else Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local + in + { uctx_local = local; + uctx_postponed = Univ.UniverseConstraints.union ctx.uctx_postponed ctx'.uctx_postponed; + uctx_univ_variables = + Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; + uctx_univ_algebraic = + Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic; + uctx_universes = + if local == ctx.uctx_local then ctx.uctx_universes + else + let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in + Univ.merge_constraints cstrsr ctx.uctx_universes} + +(* let union_evar_universe_context_key = Profile.declare_profile "union_evar_universe_context";; *) +(* let union_evar_universe_context = *) +(* Profile.profile2 union_evar_universe_context_key union_evar_universe_context;; *) + +let diff_evar_universe_context ctx' ctx = + if ctx == ctx' then empty_evar_universe_context + else + let local = Univ.ContextSet.diff ctx'.uctx_local ctx.uctx_local in + { uctx_local = local; + uctx_postponed = Univ.UniverseConstraints.diff ctx'.uctx_postponed ctx.uctx_postponed; + uctx_univ_variables = + Univ.LMap.diff ctx'.uctx_univ_variables ctx.uctx_univ_variables; + uctx_univ_algebraic = + Univ.LSet.diff ctx'.uctx_univ_algebraic ctx.uctx_univ_algebraic; + uctx_universes = Univ.empty_universes } + +(* let diff_evar_universe_context_key = Profile.declare_profile "diff_evar_universe_context";; *) +(* let diff_evar_universe_context = *) +(* Profile.profile2 diff_evar_universe_context_key diff_evar_universe_context;; *) + +type 'a in_evar_universe_context = 'a * evar_universe_context + +let evar_universe_context_set ctx = ctx.uctx_local +let evar_context_universe_context ctx = Univ.ContextSet.to_context ctx.uctx_local +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 instantiate_variable l b v = + (* let b = Univ.subst_large_constraint (Univ.Universe.make l) Univ.type0m_univ b in *) + (* if Univ.univ_depends (Univ.Universe.make l) b then *) + (* error ("Occur-check in universe variable instantiation") *) + (* else *) v := Univ.LMap.add l (Some b) !v + +exception UniversesDiffer + +let process_universe_constraints univs postponed vars alg local cstrs = + let vars = ref vars in + let normalize = Universes.normalize_universe_opt_subst vars in + let rec unify_universes fo l d r local postponed = + let l = normalize l and r = normalize r in + if Univ.Universe.eq l r then local, postponed + else + let varinfo x = + match Univ.Universe.level x with + | None -> Inl x + | Some l -> Inr (l, Univ.LMap.mem l !vars, Univ.LSet.mem l alg) + in + if d == Univ.ULe then + if Univ.check_leq univs l r then + (** Keep Prop <= var around if var might be instantiated by prop later. *) + if Univ.is_type0m_univ l && not (Univ.is_small_univ r) then + match Univ.Universe.level l, Univ.Universe.level r with + | Some l, Some r -> Univ.Constraint.add (l,Univ.Le,r) local, postponed + | _, _ -> local, postponed + else local, postponed + else + match Univ.Universe.level r with + | None -> (local, Univ.UniverseConstraints.add (l,d,r) postponed) + | Some _ -> (Univ.enforce_leq l r local, postponed) + else if d == Univ.ULub then + match varinfo l, varinfo r with + | (Inr (l, true, _), Inr (r, _, _)) + | (Inr (r, _, _), Inr (l, true, _)) -> + instantiate_variable l (Univ.Universe.make r) vars; + Univ.enforce_eq_level l r local, postponed + | Inr (_, _, _), Inr (_, _, _) -> + unify_universes true l Univ.UEq r local postponed + | _, _ -> (* Dead code *) + if Univ.check_eq univs l r then local, postponed + else local, Univ.UniverseConstraints.add (l,d,r) postponed + else (* d = Univ.UEq *) + match varinfo l, varinfo r with + | Inr (l', lloc, _), Inr (r', rloc, _) -> + let () = + if lloc then + instantiate_variable l' (Univ.Universe.make r') vars + else if rloc then + instantiate_variable r' (Univ.Universe.make l') vars + else + (* Two rigid/global levels, one of them being Prop/Set, disallow *) + (* if Univ.is_small_univ l' || Univ.is_small_univ r' then *) + (* raise UniversesDiffer *) + (* else *) + if fo then + if not (Univ.check_eq univs l r) then + raise UniversesDiffer + in + Univ.enforce_eq_level l' r' local, postponed + | _, _ (* Algebraic or globals: + try first-order unification of formal expressions. + THIS IS WRONG: it should be postponed and the equality + turned into a common lub constraint. *) -> + if Univ.check_eq univs l r then local, postponed + else raise UniversesDiffer + (* anomaly (Pp.str"Trying to equate algebraic universes") *) + (* local, Univ.UniverseConstraints.add (l,d,r) postponed *) + in + let rec fixpoint local postponed cstrs = + let local, postponed' = + Univ.UniverseConstraints.fold (fun (l,d,r) (local, p) -> unify_universes false l d r local p) + cstrs (local, postponed) + in + if Univ.UniverseConstraints.is_empty postponed' then local, postponed' + else if Univ.UniverseConstraints.equal cstrs postponed' then local, postponed' + else (* Progress: *) + fixpoint local Univ.UniverseConstraints.empty postponed' + in + let local, pbs = fixpoint Univ.Constraint.empty postponed cstrs in + !vars, local, pbs + +let add_constraints_context ctx cstrs = + let univs, local = ctx.uctx_local in + let cstrs' = Univ.Constraint.fold (fun (l,d,r) acc -> + let l = Univ.Universe.make l and r = Univ.Universe.make r in + let cstr' = + if d == Univ.Lt then (Univ.Universe.super l, Univ.ULe, r) + else (l, (if d == Univ.Le then Univ.ULe else Univ.UEq), r) + in Univ.UniverseConstraints.add cstr' acc) + cstrs Univ.UniverseConstraints.empty + in + let vars, local', pbs = + process_universe_constraints ctx.uctx_universes ctx.uctx_postponed + ctx.uctx_univ_variables ctx.uctx_univ_algebraic + local cstrs' + in + { ctx with uctx_local = (univs, Univ.Constraint.union local local'); + uctx_postponed = pbs; + uctx_univ_variables = vars; + uctx_universes = Univ.merge_constraints cstrs ctx.uctx_universes } + +(* let addconstrkey = Profile.declare_profile "add_constraints_context";; *) +(* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *) + +let add_universe_constraints_context ctx cstrs = + let univs, local = ctx.uctx_local in + let vars, local', pbs = + process_universe_constraints ctx.uctx_universes ctx.uctx_postponed + ctx.uctx_univ_variables ctx.uctx_univ_algebraic local cstrs + in + { ctx with uctx_local = (univs, Univ.Constraint.union local local'); + uctx_postponed = pbs; + uctx_univ_variables = vars; + uctx_universes = Univ.merge_constraints local' ctx.uctx_universes } + +(* let addunivconstrkey = Profile.declare_profile "add_universe_constraints_context";; *) +(* let add_universe_constraints_context = *) +(* Profile.profile2 addunivconstrkey add_universe_constraints_context;; *) (*******************************************************************) (* Metamaps *) @@ -341,8 +549,7 @@ module EvMap = Evar.Map type evar_map = { defn_evars : evar_info EvMap.t; undf_evars : evar_info EvMap.t; - universes : Univ.UniverseLSet.t; - univ_cstrs : Univ.universes; + universes : evar_universe_context; conv_pbs : evar_constraint list; last_mods : Evar.Set.t; metas : clbinding Metamap.t; @@ -448,8 +655,11 @@ let existential_type d (n, args) = anomaly (str "Evar " ++ str (string_of_existential n) ++ str " was not declared") in instantiate_evar_array info info.evar_concl args -let add_constraints d cstrs = - { d with univ_cstrs = Univ.merge_constraints cstrs d.univ_cstrs } +let add_constraints d c = + { d with universes = add_constraints_context d.universes c } + +let add_universe_constraints d c = + { d with universes = add_universe_constraints_context d.universes c } (*** /Lifting... ***) @@ -473,8 +683,8 @@ let subst_evar_info s evi = evar_body = subst_evb evi.evar_body } let subst_evar_defs_light sub evd = - assert (Univ.is_initial_universes evd.univ_cstrs); - assert (match evd.conv_pbs with [] -> true | _ -> false); + assert (Univ.is_initial_universes evd.universes.uctx_universes); + assert (List.is_empty evd.conv_pbs); let map_info i = subst_evar_info sub i in { evd with undf_evars = EvMap.smartmap map_info evd.undf_evars; @@ -483,6 +693,13 @@ let subst_evar_defs_light sub evd = let subst_evar_map = subst_evar_defs_light +let cmap f evd = + { evd with + metas = Metamap.map (map_clb f) evd.metas; + defn_evars = EvMap.map (map_evar_info f) evd.defn_evars; + undf_evars = EvMap.map (map_evar_info f) evd.defn_evars + } + (* spiwack: deprecated *) let create_evar_defs sigma = { sigma with conv_pbs=[]; last_mods=Evar.Set.empty; metas=Metamap.empty } @@ -494,20 +711,32 @@ let create_goal_evar_defs sigma = { sigma with let empty = { defn_evars = EvMap.empty; undf_evars = EvMap.empty; - universes = Univ.UniverseLSet.empty; - univ_cstrs = Univ.initial_universes; + universes = empty_evar_universe_context; conv_pbs = []; last_mods = Evar.Set.empty; metas = Metamap.empty; effects = Declareops.no_seff; } +let from_env ?(ctx=Univ.ContextSet.empty) e = + { empty with universes = evar_universe_context_from e ctx } + + let has_undefined evd = not (EvMap.is_empty evd.undf_evars) -let evars_reset_evd ?(with_conv_pbs=false) evd d = +let evars_reset_evd ?(with_conv_pbs=false) ?(with_univs=true) evd d = let conv_pbs = if with_conv_pbs then evd.conv_pbs else d.conv_pbs in let last_mods = if with_conv_pbs then evd.last_mods else d.last_mods in - { evd with metas = d.metas; last_mods; conv_pbs; } + let universes = + if not with_univs then evd.universes + else union_evar_universe_context evd.universes d.universes + in + { evd with + metas = d.metas; + last_mods; conv_pbs; universes } + +let merge_universe_context evd uctx' = + { evd with universes = union_evar_universe_context evd.universes uctx' } let add_conv_pb pb d = {d with conv_pbs = pb::d.conv_pbs} @@ -608,80 +837,444 @@ let drop_side_effects evd = let eval_side_effects evd = evd.effects +let meta_diff ext orig = + Metamap.fold (fun m v acc -> + if Metamap.mem m orig then acc + else Metamap.add m v acc) + ext Metamap.empty + +(** ext is supposed to be an extension of odef: + it might have more defined evars, and more + or less undefined ones *) +let diff2 edef eundef odef oundef = + let def = + if odef == edef then EvMap.empty + else + EvMap.fold (fun e v acc -> + if EvMap.mem e odef then acc + else EvMap.add e v acc) + edef EvMap.empty + in + let undef = + if oundef == eundef then EvMap.empty + else + EvMap.fold (fun e v acc -> + if EvMap.mem e oundef then acc + else EvMap.add e v acc) + eundef EvMap.empty + in + (def, undef) + +let diff ext orig = + let defn, undf = diff2 ext.defn_evars ext.undf_evars orig.defn_evars orig.undf_evars in + { ext with + defn_evars = defn; undf_evars = undf; + universes = diff_evar_universe_context ext.universes orig.universes; + metas = meta_diff ext.metas orig.metas + } + +(** Invariant: sigma' is a partial extension of sigma: + It may define variables that are undefined in sigma, + or add new defined or undefined variables. It should not + undefine a defined variable in sigma. +*) + +let merge2 def undef def' undef' = + let def, undef = + EvMap.fold (fun n v (def,undef) -> + EvMap.add n v def, EvMap.remove n undef) + def' (def,undef) + in + let undef = EvMap.fold EvMap.add undef' undef in + (def, undef) + +let merge_metas metas1 metas2 = + List.fold_left (fun m (n,v) -> Metamap.add n v m) + metas2 (metamap_to_list metas1) + +let merge orig ext = + let defn, undf = merge2 orig.defn_evars orig.undf_evars ext.defn_evars ext.undf_evars in + let universes = union_evar_universe_context orig.universes ext.universes in + { orig with defn_evars = defn; undf_evars = undf; + universes; + metas = merge_metas orig.metas ext.metas } + (**********************************************************) (* Sort variables *) -let new_univ_variable evd = - let u = Termops.new_univ_level () in - let universes = Univ.UniverseLSet.add u evd.universes in - ({ evd with universes }, Univ.Universe.make u) +type rigid = + | UnivRigid + | UnivFlexible of bool (** Is substitution by an algebraic ok? *) + +let univ_rigid = UnivRigid +let univ_flexible = UnivFlexible false +let univ_flexible_alg = UnivFlexible true + +let evar_universe_context d = d.universes -let new_sort_variable d = - let (d', u) = new_univ_variable d in - (d', Type u) +let get_universe_context_set d = d.universes.uctx_local + +let universes evd = evd.universes.uctx_universes + +let universe_context evd = + Univ.ContextSet.to_context evd.universes.uctx_local + +let universe_subst evd = + evd.universes.uctx_univ_variables + +let merge_uctx rigid uctx ctx' = + let uctx = + match rigid with + | UnivRigid -> uctx + | UnivFlexible b -> + let uvars' = Univ.LMap.subst_union uctx.uctx_univ_variables + (Univ.LMap.of_set (Univ.ContextSet.levels ctx') None) in + if b then + { uctx with uctx_univ_variables = uvars'; + uctx_univ_algebraic = Univ.LSet.union uctx.uctx_univ_algebraic + (Univ.ContextSet.levels ctx') } + else { uctx with uctx_univ_variables = uvars' } + in + { uctx with uctx_local = Univ.ContextSet.union uctx.uctx_local ctx'; + uctx_universes = Univ.merge_constraints (Univ.ContextSet.constraints ctx') + uctx.uctx_universes } + +let merge_context_set rigid evd ctx' = + {evd with universes = merge_uctx rigid evd.universes ctx'} + +let with_context_set rigid d (a, ctx) = + (merge_context_set rigid d ctx, a) + +let uctx_new_univ_variable rigid + ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = + let u = Universes.new_univ_level (Global.current_dirpath ()) in + let ctx' = Univ.ContextSet.union ctx (Univ.ContextSet.singleton u) in + let uctx' = + match rigid with + | UnivRigid -> uctx + | UnivFlexible b -> + let uvars' = Univ.LMap.add u None uvars in + if b then {uctx with uctx_univ_variables = uvars'; + uctx_univ_algebraic = Univ.LSet.add u avars} + else {uctx with uctx_univ_variables = Univ.LMap.add u None uvars} in + {uctx' with uctx_local = ctx'}, u + +let new_univ_variable rigid evd = + let uctx', u = uctx_new_univ_variable rigid evd.universes in + ({evd with universes = uctx'}, Univ.Universe.make u) + +let new_sort_variable rigid d = + let (d', u) = new_univ_variable rigid d in + (d', Type u) + +let make_flexible_variable evd b u = + let {uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as ctx = evd.universes in + let uvars' = Univ.LMap.add u None uvars in + let avars' = + if b then + let uu = Univ.Universe.make u in + let substu_not_alg u' v = + Option.cata (fun vu -> Univ.Universe.eq uu vu && not (Univ.LSet.mem u' avars)) false v + in + if not (Univ.LMap.exists substu_not_alg uvars) + then Univ.LSet.add u avars else avars + else avars + in + {evd with universes = {ctx with uctx_univ_variables = uvars'; + uctx_univ_algebraic = avars'}} + + +let instantiate_univ_variable evd v u = + let uvars' = Univ.LMap.add v (Some u) evd.universes.uctx_univ_variables in + {evd with universes = {evd.universes with uctx_univ_variables = uvars'}} + +(****************************************) +(* Operations on constants *) +(****************************************) + +let fresh_sort_in_family env evd s = + with_context_set univ_flexible evd (Universes.fresh_sort_in_family env s) + +let fresh_constant_instance env evd c = + with_context_set univ_flexible evd (Universes.fresh_constant_instance env c) + +let fresh_inductive_instance env evd i = + with_context_set univ_flexible evd (Universes.fresh_inductive_instance env i) + +let fresh_constructor_instance env evd c = + with_context_set univ_flexible evd (Universes.fresh_constructor_instance env c) + +let fresh_global ?(rigid=univ_flexible) env evd gr = + (* match gr with *) + (* | ConstructRef c -> let evd, c = fresh_constructor_instance env evd c in *) + (* evd, mkConstructU c *) + (* | IndRef c -> let evd, c = fresh_inductive_instance env evd c in *) + (* evd, mkIndU c *) + (* | ConstRef c -> let evd, c = fresh_constant_instance env evd c in *) + (* evd, mkConstU c *) + (* | VarRef i -> evd, mkVar i *) + with_context_set rigid evd (Universes.fresh_global_instance env gr) -let is_sort_variable evd s = match s with Type u -> true | _ -> false let whd_sort_variable evd t = t -let univ_of_sort = function - | Type u -> u - | Prop Pos -> Univ.type0_univ - | Prop Null -> Univ.type0m_univ +let is_sort_variable evd s = + match s with + | Type u -> + (match Univ.universe_level u with + | Some l -> + let uctx = evd.universes in + if Univ.LSet.mem l (Univ.ContextSet.levels uctx.uctx_local) then + Some (l, not (Univ.LMap.mem l uctx.uctx_univ_variables)) + else None + | None -> None) + | _ -> None + let is_eq_sort s1 s2 = if Sorts.equal s1 s2 then None else let u1 = univ_of_sort s1 and u2 = univ_of_sort s2 in - if Univ.Universe.equal u1 u2 then None + if Univ.Universe.eq u1 u2 then None else Some (u1, u2) -let is_univ_var_or_set u = - Univ.is_univ_variable u || Univ.is_type0_univ u +let is_univ_var_or_set u = + not (Option.is_empty (Univ.universe_level u)) -let set_leq_sort evd s1 s2 = - match is_eq_sort s1 s2 with - | None -> evd - | Some (u1, u2) -> - match s1, s2 with - | Prop Null, Prop Pos -> evd - | Prop _, Prop _ -> - raise (Univ.UniverseInconsistency (Univ.Le, u1, u2,[])) - | Type u, Prop Pos -> - let cstr = Univ.enforce_leq u Univ.type0_univ Univ.empty_constraint in - add_constraints evd cstr - | Type _, Prop _ -> - raise (Univ.UniverseInconsistency (Univ.Le, u1, u2,[])) - | _, Type u -> - if is_univ_var_or_set u then - let cstr = Univ.enforce_leq u1 u2 Univ.empty_constraint in - add_constraints evd cstr - else raise (Univ.UniverseInconsistency (Univ.Le, u1, u2,[])) - -let is_univ_level_var us u = - match Univ.universe_level u with - | Some u -> Univ.UniverseLSet.mem u us - | None -> false +type universe_global = + | LocalUniv of Univ.universe_level + | GlobalUniv of Univ.universe_level + +type universe_kind = + | Algebraic of Univ.universe + | Variable of universe_global * bool -let set_eq_sort ({ universes = us; univ_cstrs = sm; } as d) s1 s2 = +let is_univ_level_var (us, cst) algs u = + match Univ.universe_level u with + | Some l -> + let glob = if Univ.LSet.mem l us then LocalUniv l else GlobalUniv l in + Variable (glob, Univ.LSet.mem l algs) + | None -> Algebraic u + +let normalize_universe evd = + let vars = ref evd.universes.uctx_univ_variables in + let normalize = Universes.normalize_universe_opt_subst vars in + normalize + +let memo_normalize_universe evd = + let vars = ref evd.universes.uctx_univ_variables in + let normalize = Universes.normalize_universe_opt_subst vars in + (fun () -> {evd with universes = {evd.universes with uctx_univ_variables = !vars}}), + normalize + +let normalize_universe_instance evd l = + let vars = ref evd.universes.uctx_univ_variables in + let normalize = Univ.level_subst_of (Universes.normalize_univ_variable_opt_subst vars) in + Univ.Instance.subst_fn normalize l + +let normalize_sort evars s = + match s with + | Prop _ -> s + | Type u -> + let u' = normalize_universe evars u in + if u' == u then s else Type u' + +(* FIXME inefficient *) +let set_eq_sort d s1 s2 = + let s1 = normalize_sort d s1 and s2 = normalize_sort d s2 in match is_eq_sort s1 s2 with | None -> d + | Some (u1, u2) -> add_universe_constraints d + (Univ.UniverseConstraints.singleton (u1,Univ.UEq,u2)) + +let has_lub evd u1 u2 = + (* let normalize = Universes.normalize_universe_opt_subst (ref univs.uctx_univ_variables) in *) + (* (\* let dref, norm = memo_normalize_universe d in *\) *) + (* let u1 = normalize u1 and u2 = normalize u2 in *) + if Univ.Universe.eq u1 u2 then evd + else add_universe_constraints evd + (Univ.UniverseConstraints.singleton (u1,Univ.ULub,u2)) + +let set_eq_level d u1 u2 = + add_constraints d (Univ.enforce_eq_level u1 u2 Univ.Constraint.empty) + +let set_leq_level d u1 u2 = + add_constraints d (Univ.enforce_leq_level u1 u2 Univ.Constraint.empty) + +let set_eq_instances d u1 u2 = + add_universe_constraints d + (Univ.enforce_eq_instances_univs false u1 u2 Univ.UniverseConstraints.empty) + +let set_leq_sort evd s1 s2 = + let s1 = normalize_sort evd s1 + and s2 = normalize_sort evd s2 in + match is_eq_sort s1 s2 with + | None -> evd | Some (u1, u2) -> match s1, s2 with - | Prop c, Type u when is_univ_level_var us u -> - add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) - | Type u, Prop c when is_univ_level_var us u -> - add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) - | Type u, Type v when (is_univ_level_var us u) || (is_univ_level_var us v) -> - add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) - | Prop c, Type u when is_univ_var_or_set u && - Univ.lax_check_eq sm u1 u2 -> d - | Type u, Prop c when is_univ_var_or_set u && - Univ.lax_check_eq sm u1 u2 -> d - | Type u, Type v when is_univ_var_or_set u && is_univ_var_or_set v -> - add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) - | _, _ -> raise (Univ.UniverseInconsistency (Univ.Eq, u1, u2, [])) - + | Prop c, Prop c' -> + if c == Null && c' == Pos then evd + else (raise (Univ.UniverseInconsistency (Univ.Le, u1, u2, []))) + | _, _ -> + add_universe_constraints evd (Univ.UniverseConstraints.singleton (u1,Univ.ULe,u2)) + +let check_eq evd s s' = + Univ.check_eq evd.universes.uctx_universes s s' + +let check_leq evd s s' = + Univ.check_leq evd.universes.uctx_universes s s' + +let subst_univs_context_with_def def usubst (ctx, cst) = + (Univ.LSet.diff ctx def, Univ.subst_univs_constraints usubst cst) + +let subst_univs_context usubst ctx = + subst_univs_context_with_def (Univ.LMap.universes usubst) (Univ.make_subst usubst) ctx + +let subst_univs_universes s g = + Univ.LMap.fold (fun u v g -> + (* Problem here: we might have instantiated an algebraic universe... *) + Univ.enforce_constraint (u, Univ.Eq, Option.get (Univ.Universe.level v)) g) s g + +let subst_univs_opt_universes s g = + Univ.LMap.fold (fun u v g -> + (* Problem here: we might have instantiated an algebraic universe... *) + match v with + | Some l -> + Univ.enforce_constraint (u, Univ.Eq, Option.get (Univ.Universe.level l)) g + | None -> g) s g + +let normalize_evar_universe_context_variables uctx = + let normalized_variables, undef, def, subst = + Universes.normalize_univ_variables uctx.uctx_univ_variables + in + let ctx_local = subst_univs_context_with_def def (Univ.make_subst subst) uctx.uctx_local in + (* let univs = subst_univs_universes subst uctx.uctx_universes in *) + let ctx_local', univs = Universes.refresh_constraints (Global.universes ()) ctx_local in + subst, { uctx with uctx_local = ctx_local'; + uctx_univ_variables = normalized_variables; + uctx_universes = univs } + +(* let normvarsconstrkey = Profile.declare_profile "normalize_evar_universe_context_variables";; *) +(* let normalize_evar_universe_context_variables = *) +(* Profile.profile1 normvarsconstrkey normalize_evar_universe_context_variables;; *) + +let mark_undefs_as_rigid uctx = + let vars' = + Univ.LMap.fold (fun u v acc -> + if v == None && not (Univ.LSet.mem u uctx.uctx_univ_algebraic) + then acc else Univ.LMap.add u v acc) + uctx.uctx_univ_variables Univ.LMap.empty + in { uctx with uctx_univ_variables = vars' } + +let mark_undefs_as_nonalg uctx = + let vars' = + Univ.LMap.fold (fun u v acc -> + if v == None then Univ.LSet.remove u acc + else acc) + uctx.uctx_univ_variables uctx.uctx_univ_algebraic + in { uctx with uctx_univ_algebraic = vars' } + +let abstract_undefined_variables evd = + {evd with universes = mark_undefs_as_nonalg evd.universes} + +let refresh_undefined_univ_variables uctx = + let subst, ctx' = Universes.fresh_universe_context_set_instance uctx.uctx_local in + let alg = Univ.LSet.fold (fun u acc -> Univ.LSet.add (Univ.subst_univs_level_level subst u) acc) + uctx.uctx_univ_algebraic Univ.LSet.empty + in + let vars = + Univ.LMap.fold + (fun u v acc -> + Univ.LMap.add (Univ.subst_univs_level_level subst u) + (Option.map (Univ.subst_univs_level_universe subst) v) acc) + uctx.uctx_univ_variables Univ.LMap.empty + in + let uctx' = {uctx_local = ctx'; + uctx_postponed = Univ.UniverseConstraints.empty;(*FIXME*) + uctx_univ_variables = vars; uctx_univ_algebraic = alg; + uctx_universes = Univ.initial_universes} in + uctx', subst + +let refresh_undefined_universes evd = + let uctx', subst = refresh_undefined_univ_variables evd.universes in + let evd' = cmap (subst_univs_level_constr subst) {evd with universes = uctx'} in + evd', subst + +let constraints_universes c = + Univ.Constraint.fold (fun (l',d,r') acc -> Univ.LSet.add l' (Univ.LSet.add r' acc)) + c Univ.LSet.empty + +let is_undefined_universe_variable l vars = + try (match Univ.LMap.find l vars with + | Some u -> false + | None -> true) + with Not_found -> false + +let normalize_evar_universe_context uctx = + let rec fixpoint uctx = + let ((vars',algs'), us') = + Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables + uctx.uctx_univ_algebraic + in + if Univ.LSet.equal (fst us') (fst uctx.uctx_local) then + uctx + else + let us', universes = Universes.refresh_constraints (Global.universes ()) us' in + (* let universes = subst_univs_opt_universes vars' uctx.uctx_universes in *) + let postponed = + Univ.subst_univs_universe_constraints (Universes.make_opt_subst vars') + uctx.uctx_postponed + in + let uctx' = + { uctx_local = us'; + uctx_univ_variables = vars'; + uctx_univ_algebraic = algs'; + uctx_postponed = postponed; + uctx_universes = universes} + in fixpoint uctx' + in fixpoint uctx + +let nf_univ_variables evd = + let subst, uctx' = normalize_evar_universe_context_variables evd.universes in + let evd' = {evd with universes = uctx'} in + evd', subst + +let normalize_univ_level fullsubst u = + try Univ.LMap.find u fullsubst + with Not_found -> Univ.Universe.make u + +let nf_constraints evd = + let subst, uctx' = normalize_evar_universe_context_variables evd.universes in + let uctx' = normalize_evar_universe_context uctx' in + {evd with universes = uctx'} + +(* let nfconstrkey = Profile.declare_profile "nf_constraints";; *) +(* let nf_constraints = Profile.profile1 nfconstrkey nf_constraints;; *) + +let universes evd = evd.universes.uctx_universes + +(* Conversion w.r.t. an evar map and its local universes. *) + +let conversion_gen env evd pb t u = + match pb with + | Reduction.CONV -> + Reduction.trans_conv_universes + full_transparent_state ~evars:(existential_opt_value evd) env + evd.universes.uctx_universes t u + | Reduction.CUMUL -> Reduction.trans_conv_leq_universes + full_transparent_state ~evars:(existential_opt_value evd) env + evd.universes.uctx_universes t u + +(* let conversion_gen_key = Profile.declare_profile "conversion_gen" *) +(* let conversion_gen = Profile.profile5 conversion_gen_key conversion_gen *) + +let conversion env d pb t u = + conversion_gen env d pb t u; d + +let test_conversion env d pb t u = + try conversion_gen env d pb t u; true + with _ -> false + (**********************************************************) (* Accessing metas *) @@ -691,7 +1284,6 @@ let set_metas evd metas = { defn_evars = evd.defn_evars; undf_evars = evd.undf_evars; universes = evd.universes; - univ_cstrs = evd.univ_cstrs; conv_pbs = evd.conv_pbs; last_mods = evd.last_mods; metas; @@ -787,9 +1379,12 @@ let meta_with_name evd id = (str "Binder name \"" ++ pr_id id ++ strbrk "\" occurs more than once in clause.") +let clear_metas evd = {evd with metas = Metamap.empty} + let meta_merge evd1 evd2 = let metas = Metamap.fold Metamap.add evd1.metas evd2.metas in - set_metas evd2 metas + let universes = union_evar_universe_context evd2.universes evd1.universes in + {evd2 with universes; metas; } type metabinding = metavariable * constr * instance_status @@ -907,7 +1502,7 @@ let pr_evar_source = function | Evar_kinds.ImplicitArg (c,(n,ido),b) -> let id = Option.get ido in str "parameter " ++ pr_id id ++ spc () ++ str "of" ++ - spc () ++ print_constr (constr_of_global c) + spc () ++ print_constr (printable_constr_of_global c) | Evar_kinds.InternalHole -> str "internal placeholder" | Evar_kinds.TomatchTypeParameter (ind,n) -> pr_nth n ++ str " argument of type " ++ print_constr (mkInd ind) @@ -989,6 +1584,16 @@ let evar_dependency_closure n sigma = let has_no_evar sigma = EvMap.is_empty sigma.defn_evars && EvMap.is_empty sigma.undf_evars +let pr_evar_universe_context ctx = + if is_empty_evar_universe_context ctx then mt () + else + (str"UNIVERSES:"++brk(0,1)++ h 0 (Univ.pr_universe_context_set ctx.uctx_local) ++ fnl () ++ + str"POSTPONED CONSTRAINTS:"++brk(0,1)++ + h 0 (Univ.UniverseConstraints.pr ctx.uctx_postponed) ++ fnl () ++ + str"ALGEBRAIC UNIVERSES:"++brk(0,1)++h 0 (Univ.LSet.pr ctx.uctx_univ_algebraic) ++ fnl() ++ + str"UNDEFINED UNIVERSES:"++brk(0,1)++ + h 0 (Universes.pr_universe_opt_subst ctx.uctx_univ_variables)) + let print_env_short env = let pr_body n = function | None -> pr_name n @@ -1012,17 +1617,9 @@ let pr_evar_constraints pbs = prlist_with_sep fnl pr_evconstr pbs let pr_evar_map_gen pr_evars sigma = - let { universes = uvs; univ_cstrs = univs; } = sigma in + let { universes = uvs } = sigma in let evs = if has_no_evar sigma then mt () else pr_evars sigma - and svs = - if Univ.UniverseLSet.is_empty uvs then mt () - else str "UNIVERSE VARIABLES:" ++ brk (0, 1) ++ - h 0 (prlist_with_sep fnl Univ.pr_uni_level - (Univ.UniverseLSet.elements uvs)) ++ fnl () - and cs = - if Univ.is_initial_universes univs then mt () - else str "UNIVERSES:" ++ brk (0, 1) ++ - h 0 (Univ.pr_universes univs) ++ fnl () + and svs = pr_evar_universe_context uvs and cstrs = if List.is_empty sigma.conv_pbs then mt () else @@ -1033,7 +1630,7 @@ let pr_evar_map_gen pr_evars sigma = else str "METAS:" ++ brk (0, 1) ++ pr_meta_map sigma.metas in - evs ++ svs ++ cs ++ cstrs ++ metas + evs ++ svs ++ cstrs ++ metas let pr_evar_list l = let pr (ev, evi) = diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 55bce05de6..18d68bebf4 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -112,6 +112,9 @@ val evar_filter : evar_info -> Filter.t val evar_env : evar_info -> env val evar_filtered_env : evar_info -> env +val map_evar_body : (constr -> constr) -> evar_body -> evar_body +val map_evar_info : (constr -> constr) -> evar_info -> evar_info + (** {6 Unification state} **) type evar_map @@ -125,6 +128,10 @@ val progress_evar_map : evar_map -> evar_map -> bool val empty : evar_map (** The empty evar map. *) +val from_env : ?ctx:Univ.universe_context_set -> env -> evar_map +(** The empty evar map with given universe context, taking its initial + universes from env. *) + val is_empty : evar_map -> bool (** Whether an evarmap is empty. *) @@ -174,6 +181,17 @@ val define : evar -> constr -> evar_map -> evar_map {- All the evars present in the constr should be present in the evar map.} } *) +val cmap : (constr -> constr) -> evar_map -> evar_map +(** Map the function on all terms in the evar map. *) + +val diff : evar_map -> evar_map -> evar_map +(** [diff ext orig] assuming [ext] is an extension of [orig], + return an evar map containing just the extension *) + +val merge : evar_map -> evar_map -> evar_map +(** [merge orig ext] assuming [ext] is an extension of [orig], + return an evar map containing the union of the two maps *) + val is_evar : evar_map -> evar -> bool (** Alias for {!mem}. *) @@ -208,7 +226,7 @@ val instantiate_evar_array : evar_info -> constr -> constr array -> constr val subst_evar_defs_light : substitution -> evar_map -> evar_map (** Assume empty universe constraints in [evar_map] and [conv_pbs] *) -val evars_reset_evd : ?with_conv_pbs:bool -> evar_map -> evar_map -> evar_map +val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool -> evar_map -> evar_map -> evar_map (** spiwack: this function seems to somewhat break the abstraction. *) (** {6 Misc} *) @@ -245,6 +263,13 @@ val whd_sort_variable : evar_map -> constr -> constr val set_leq_sort : evar_map -> sorts -> sorts -> evar_map val set_eq_sort : evar_map -> sorts -> sorts -> evar_map +exception UniversesDiffer + +val add_universe_constraints : evar_map -> Univ.universe_constraints -> evar_map +(** Add the given universe unification constraints to the evar map. + @raises UniversesDiffer in case a first-order unification fails. + @raises UniverseInconsistency +*) (** {5 Enriching with evar maps} *) type 'a sigma = { @@ -353,6 +378,8 @@ val meta_declare : val meta_assign : metavariable -> constr * instance_status -> evar_map -> evar_map val meta_reassign : metavariable -> constr * instance_status -> evar_map -> evar_map +val clear_metas : evar_map -> evar_map + (** [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *) val meta_merge : evar_map -> evar_map -> evar_map @@ -366,6 +393,106 @@ val subst_defined_metas : metabinding list -> constr -> constr option (** {5 FIXME: Nothing to do here} *) +(********************************************************* + Sort/universe variables *) + +(** Rigid or flexible universe variables *) + +type rigid = + | UnivRigid + | UnivFlexible of bool (** Is substitution by an algebraic ok? *) + +val univ_rigid : rigid +val univ_flexible : rigid +val univ_flexible_alg : rigid + +(** The universe context associated to an evar map *) +type evar_universe_context + +type 'a in_evar_universe_context = 'a * evar_universe_context + +val evar_universe_context_set : evar_universe_context -> Univ.universe_context_set +val evar_context_universe_context : evar_universe_context -> Univ.universe_context +val evar_universe_context_of : Univ.universe_context_set -> evar_universe_context +val empty_evar_universe_context : evar_universe_context +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 universes : evar_map -> Univ.universes + +val add_constraints_context : evar_universe_context -> + Univ.constraints -> evar_universe_context + +val normalize_evar_universe_context_variables : evar_universe_context -> + Univ.universe_subst in_evar_universe_context + +val normalize_evar_universe_context : evar_universe_context -> + evar_universe_context + +val new_univ_variable : rigid -> evar_map -> evar_map * Univ.universe +val new_sort_variable : rigid -> evar_map -> evar_map * sorts +val make_flexible_variable : evar_map -> bool -> Univ.universe_level -> evar_map +val is_sort_variable : evar_map -> sorts -> (Univ.universe_level * bool) option +(** [is_sort_variable evm s] returns [Some (u, is_rigid)] or [None] if [s] is + not a sort variable declared in [evm] *) +val whd_sort_variable : evar_map -> constr -> constr +(* val normalize_universe_level : evar_map -> Univ.universe_level -> Univ.universe_level *) +val normalize_universe : evar_map -> Univ.universe -> Univ.universe +val normalize_universe_instance : evar_map -> Univ.universe_instance -> Univ.universe_instance + +val set_leq_sort : evar_map -> sorts -> sorts -> evar_map +val set_eq_sort : evar_map -> sorts -> sorts -> evar_map +val has_lub : evar_map -> Univ.universe -> Univ.universe -> evar_map +val set_eq_level : evar_map -> Univ.universe_level -> Univ.universe_level -> evar_map +val set_leq_level : evar_map -> Univ.universe_level -> Univ.universe_level -> evar_map +val set_eq_instances : evar_map -> Univ.universe_instance -> Univ.universe_instance -> evar_map + +val check_eq : evar_map -> Univ.universe -> Univ.universe -> bool +val check_leq : evar_map -> Univ.universe -> Univ.universe -> bool + +val evar_universe_context : evar_map -> evar_universe_context +val get_universe_context_set : evar_map -> Univ.universe_context_set +val universe_context : evar_map -> Univ.universe_context +val universe_subst : evar_map -> Universes.universe_opt_subst +val universes : evar_map -> Univ.universes + + +val merge_universe_context : evar_map -> evar_universe_context -> evar_map + +val merge_context_set : rigid -> evar_map -> Univ.universe_context_set -> evar_map + +val with_context_set : rigid -> evar_map -> 'a Univ.in_universe_context_set -> evar_map * 'a + +val nf_univ_variables : evar_map -> evar_map * Univ.universe_subst +val abstract_undefined_variables : evar_map -> evar_map + +val refresh_undefined_universes : evar_map -> evar_map * Univ.universe_level_subst + +val nf_constraints : evar_map -> evar_map + +(** Polymorphic universes *) + +val fresh_sort_in_family : env -> evar_map -> sorts_family -> evar_map * sorts +val fresh_constant_instance : env -> evar_map -> constant -> evar_map * pconstant +val fresh_inductive_instance : env -> evar_map -> inductive -> evar_map * pinductive +val fresh_constructor_instance : env -> evar_map -> constructor -> evar_map * pconstructor + +val fresh_global : ?rigid:rigid -> env -> evar_map -> Globnames.global_reference -> evar_map * constr + +(******************************************************************** + Conversion w.r.t. an evar map: might generate universe unifications + that are kept in the evarmap. + Raises [NotConvertible]. *) + +val conversion : env -> evar_map -> conv_pb -> constr -> constr -> evar_map + +(** This one forgets about the assignemts of universes. *) +val test_conversion : env -> evar_map -> conv_pb -> constr -> constr -> bool + +(******************************************************************** + constr with holes *) + type open_constr = evar_map * constr (** Partially constructed constrs. *) @@ -380,6 +507,7 @@ val pr_evar_map : int option -> evar_map -> Pp.std_ppcmds val pr_evar_map_filter : (Evar.t -> evar_info -> bool) -> evar_map -> Pp.std_ppcmds val pr_metaset : Metaset.t -> Pp.std_ppcmds +val pr_evar_universe_context : evar_universe_context -> Pp.std_ppcmds (** {5 Deprecated functions} *) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index f1e38d0f8f..73bb343eeb 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -61,7 +61,7 @@ let cast_type_eq eq t1 t2 = match t1, t2 with | _ -> false let rec glob_constr_eq c1 c2 = match c1, c2 with -| GRef (_, gr1), GRef (_, gr2) -> eq_gr gr1 gr2 +| GRef (_, gr1, _), GRef (_, gr2, _) -> eq_gr gr1 gr2 | GVar (_, id1), GVar (_, id2) -> Id.equal id1 id2 | GEvar (_, ev1, arg1), GEvar (_, ev2, arg2) -> Evar.equal ev1 ev2 && @@ -156,6 +156,9 @@ let map_glob_constr_left_to_right f = function let comp2 = Util.List.map_left (fun (tm,x) -> (f tm,x)) tml in let comp3 = Util.List.map_left (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl in GCases (loc,sty,comp1,comp2,comp3) + | GProj (loc,p,c) -> + let comp1 = f c in + GProj (loc,p,comp1) | GLetTuple (loc,nal,(na,po),b,c) -> let comp1 = Option.map f po in let comp2 = f b in @@ -183,6 +186,7 @@ let fold_glob_constr f acc = let rec fold acc = function | GVar _ -> acc | GApp (_,c,args) -> List.fold_left fold (fold acc c) args + | GProj (_,p,c) -> fold acc c | GLambda (_,_,_,b,c) | GProd (_,_,_,b,c) | GLetIn (_,_,b,c) -> fold (fold acc b) c | GCases (_,_,rtntypopt,tml,pl) -> @@ -221,6 +225,7 @@ let occur_glob_constr id = let rec occur = function | GVar (loc,id') -> Id.equal id id' | GApp (loc,f,args) -> (occur f) || (List.exists occur args) + | GProj (loc,p,c) -> occur c | GLambda (loc,na,bk,ty,c) -> (occur ty) || (not (same_id na id) && (occur c)) | GProd (loc,na,bk,ty,c) -> @@ -270,6 +275,7 @@ let free_glob_vars = let rec vars bounded vs = function | GVar (loc,id') -> if Id.Set.mem id' bounded then vs else Id.Set.add id' vs | GApp (loc,f,args) -> List.fold_left (vars bounded) vs (f::args) + | GProj (loc,p,c) -> vars bounded vs c | GLambda (loc,na,_,ty,c) | GProd (loc,na,_,ty,c) | GLetIn (loc,na,ty,c) -> let vs' = vars bounded vs ty in let bounded' = add_name_to_ids bounded na in @@ -326,11 +332,12 @@ let free_glob_vars = let loc_of_glob_constr = function - | GRef (loc,_) -> loc + | GRef (loc,_,_) -> loc | GVar (loc,_) -> loc | GEvar (loc,_,_) -> loc | GPatVar (loc,_) -> loc | GApp (loc,_,_) -> loc + | GProj (loc,p,c) -> loc | GLambda (loc,_,_,_,_) -> loc | GProd (loc,_,_,_,_) -> loc | GLetIn (loc,_,_,_) -> loc @@ -354,18 +361,18 @@ let rec cases_pattern_of_glob_constr na = function | Anonymous -> PatVar (loc,Name id) end | GHole (loc,_,_) -> PatVar (loc,na) - | GRef (loc,ConstructRef cstr) -> + | GRef (loc,ConstructRef cstr,_) -> PatCstr (loc,cstr,[],na) - | GApp (loc,GRef (_,ConstructRef cstr),l) -> + | GApp (loc,GRef (_,ConstructRef cstr,_),l) -> PatCstr (loc,cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na) | _ -> raise Not_found (* Turn a closed cases pattern into a glob_constr *) let rec glob_constr_of_closed_cases_pattern_aux = function | PatCstr (loc,cstr,[],Anonymous) -> - GRef (loc,ConstructRef cstr) + GRef (loc,ConstructRef cstr,None) | PatCstr (loc,cstr,l,Anonymous) -> - let ref = GRef (loc,ConstructRef cstr) in + let ref = GRef (loc,ConstructRef cstr,None) in GApp (loc,ref, List.map glob_constr_of_closed_cases_pattern_aux l) | _ -> raise Not_found diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index bf9fd8a10c..35a9cbdb22 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -33,7 +33,7 @@ type dep_flag = bool (* Errors related to recursors building *) type recursion_scheme_error = - | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * inductive + | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * pinductive | NotMutualInScheme of inductive * inductive exception RecursionSchemeError of recursion_scheme_error @@ -49,16 +49,16 @@ let mkLambda_string s t c = mkLambda (Name (Id.of_string s), t, c) (* Building case analysis schemes *) (* Christine Paulin, 1996 *) -let mis_make_case_com dep env sigma ind (mib,mip as specif) kind = - let lnamespar = List.map - (fun (n, c, t) -> (n, c, Termops.refresh_universes t)) +let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = + let usubst = Inductive.make_inductive_subst mib u in + let lnamespar = Vars.subst_univs_context usubst mib.mind_params_ctxt in if not (Sorts.List.mem kind (elim_sorts specif)) then raise (RecursionSchemeError - (NotAllowedCaseAnalysis (false, Termops.new_sort_in_family kind, ind))); + (NotAllowedCaseAnalysis (false, fst (Universes.fresh_sort_in_family env kind), pind))); let ndepar = mip.mind_nrealargs_ctxt + 1 in @@ -66,7 +66,7 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind = (* mais pas trčs joli ... (mais manque get_sort_of ŕ ce niveau) *) let env' = push_rel_context lnamespar env in - let indf = make_ind_family(ind, Termops.extended_rel_list 0 lnamespar) in + let indf = make_ind_family(pind, Termops.extended_rel_list 0 lnamespar) in let constrs = get_constructors env indf in let rec add_branch env k = @@ -78,7 +78,7 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind = let depind = build_dependent_inductive env indf' in let deparsign = (Anonymous,None,depind)::arsign in - let ci = make_case_info env ind RegularStyle in + let ci = make_case_info env (fst pind) RegularStyle in let pbody = appvect (mkRel (ndepar + nbprod), @@ -101,10 +101,13 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind = mkLambda_string "f" t (add_branch (push_rel (Anonymous, None, t) env) (k+1)) in - let typP = make_arity env' dep indf (Termops.new_sort_in_family kind) in - it_mkLambda_or_LetIn_name env + let sigma, s = Evd.fresh_sort_in_family env sigma kind in + let typP = make_arity env' dep indf s in + let c = + it_mkLambda_or_LetIn_name env (mkLambda_string "P" typP - (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar + (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar + in sigma, c (* check if the type depends recursively on one of the inductive scheme *) @@ -188,7 +191,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = if dep then let realargs = List.rev_map (fun k -> mkRel (i-k)) li in let params = List.map (lift i) vargs in - let co = applist (mkConstruct cs.cs_cstr,params@realargs) in + let co = applist (mkConstructU cs.cs_cstr,params@realargs) in Reduction.beta_appvect c [|co|] else c in @@ -264,13 +267,14 @@ let context_chop k ctx = | (_, []) -> failwith "context_chop" in chop_aux [] (k,ctx) - (* Main function *) -let mis_make_indrec env sigma listdepkind mib = +let mis_make_indrec env sigma listdepkind mib u = let nparams = mib.mind_nparams in - let nparrec = mib. mind_nparams_rec in + let nparrec = mib.mind_nparams_rec in + let evdref = ref sigma in + let usubst = Inductive.make_inductive_subst mib u in let lnonparrec,lnamesparrec = - context_chop (nparams-nparrec) mib.mind_params_ctxt in + context_chop (nparams-nparrec) (Vars.subst_univs_context usubst mib.mind_params_ctxt) in let nrec = List.length listdepkind in let depPvec = Array.make mib.mind_ntypes (None : (bool * constr) option) in @@ -278,7 +282,7 @@ let mis_make_indrec env sigma listdepkind mib = let rec assign k = function | [] -> () - | (indi,mibi,mipi,dep,_)::rest -> + | ((indi,u),mibi,mipi,dep,_)::rest -> (Array.set depPvec (snd indi) (Some(dep,mkRel k)); assign (k-1) rest) in @@ -292,7 +296,7 @@ let mis_make_indrec env sigma listdepkind mib = let make_one_rec p = let makefix nbconstruct = let rec mrec i ln ltyp ldef = function - | (indi,mibi,mipi,dep,_)::rest -> + | ((indi,u),mibi,mipi,dep,_)::rest -> let tyi = snd indi in let nctyi = Array.length mipi.mind_consnames in (* nb constructeurs du type*) @@ -300,7 +304,7 @@ let mis_make_indrec env sigma listdepkind mib = (* arity in the context of the fixpoint, i.e. P1..P_nrec f1..f_nbconstruct *) let args = Termops.extended_rel_list (nrec+nbconstruct) lnamesparrec in - let indf = make_ind_family(indi,args) in + let indf = make_ind_family((indi,u),args) in let arsign,_ = get_arity env indf in let depind = build_dependent_inductive env indf in @@ -315,7 +319,7 @@ let mis_make_indrec env sigma listdepkind mib = P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *) let args' = Termops.extended_rel_list (dect+nrec) lnamesparrec in let args'' = Termops.extended_rel_list ndepar lnonparrec in - let indf' = make_ind_family(indi,args'@args'') in + let indf' = make_ind_family((indi,u),args'@args'') in let branches = let constrs = get_constructors env indf' in @@ -325,7 +329,7 @@ let mis_make_indrec env sigma listdepkind mib = fi in Array.map3 - (make_rec_branch_arg env sigma + (make_rec_branch_arg env !evdref (nparrec,depPvec,larsign)) vecfi constrs (dest_subterms recargsvec.(tyi)) in @@ -389,7 +393,7 @@ let mis_make_indrec env sigma listdepkind mib = mrec 0 [] [] [] in let rec make_branch env i = function - | (indi,mibi,mipi,dep,_)::rest -> + | ((indi,u),mibi,mipi,dep,_)::rest -> let tyi = snd indi in let nconstr = Array.length mipi.mind_consnames in let rec onerec env j = @@ -399,10 +403,10 @@ let mis_make_indrec env sigma listdepkind mib = let recarg = (dest_subterms recargsvec.(tyi)).(j) in let recarg = recargpar@recarg in let vargs = Termops.extended_rel_list (nrec+i+j) lnamesparrec in - let cs = get_constructor (indi,mibi,mipi,vargs) (j+1) in + let cs = get_constructor ((indi,u),mibi,mipi,vargs) (j+1) in let p_0 = type_rec_branch - true dep env sigma (vargs,depPvec,i+j) tyi cs recarg + true dep env !evdref (vargs,depPvec,i+j) tyi cs recarg in mkLambda_string "f" p_0 (onerec (push_rel (Anonymous,None,p_0) env) (j+1)) @@ -411,9 +415,10 @@ let mis_make_indrec env sigma listdepkind mib = makefix i listdepkind in let rec put_arity env i = function - | (indi,_,_,dep,kinds)::rest -> - let indf = make_ind_family (indi, Termops.extended_rel_list i lnamesparrec) in - let typP = make_arity env dep indf (Termops.new_sort_in_family kinds) in + | ((indi,u),_,_,dep,kinds)::rest -> + let indf = make_ind_family ((indi,u), Termops.extended_rel_list i lnamesparrec) in + let s = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evdref kinds in + let typP = make_arity env dep indf s in mkLambda_string "P" typP (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest) | [] -> @@ -421,36 +426,38 @@ let mis_make_indrec env sigma listdepkind mib = in (* Body on make_one_rec *) - let (indi,mibi,mipi,dep,kind) = List.nth listdepkind p in + let ((indi,u),mibi,mipi,dep,kind) = List.nth listdepkind p in if (mis_is_recursive_subset - (List.map (fun (indi,_,_,_,_) -> snd indi) listdepkind) + (List.map (fun ((indi,u),_,_,_,_) -> snd indi) listdepkind) mipi.mind_recargs) then let env' = push_rel_context lnamesparrec env in it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) lnamesparrec else - mis_make_case_com dep env sigma indi (mibi,mipi) kind + let evd', c = mis_make_case_com dep env !evdref (indi,u) (mibi,mipi) kind in + evdref := evd'; c in (* Body of mis_make_indrec *) - List.init nrec make_one_rec + !evdref, List.init nrec make_one_rec (**********************************************************************) (* This builds elimination predicate for Case tactic *) -let build_case_analysis_scheme env sigma ity dep kind = - let (mib,mip) = lookup_mind_specif env ity in - mis_make_case_com dep env sigma ity (mib,mip) kind +let build_case_analysis_scheme env sigma pity dep kind = + let (mib,mip) = lookup_mind_specif env (fst pity) in + mis_make_case_com dep env sigma pity (mib,mip) kind -let build_case_analysis_scheme_default env sigma ity kind = - let (mib,mip) = lookup_mind_specif env ity in - let dep = match inductive_sort_family mip with - | InProp -> false - | _ -> true - in - mis_make_case_com dep env sigma ity (mib,mip) kind +let is_in_prop mip = + match inductive_sort_family mip with + | InProp -> true + | _ -> false +let build_case_analysis_scheme_default env sigma pity kind = + let (mib,mip) = lookup_mind_specif env (fst pity) in + let dep = not (is_in_prop mip) in + mis_make_case_com dep env sigma pity (mib,mip) kind (**********************************************************************) (* [modify_sort_scheme s rec] replaces the sort of the scheme @@ -459,37 +466,25 @@ let build_case_analysis_scheme_default env sigma ity kind = let change_sort_arity sort = let rec drec a = match kind_of_term a with | Cast (c,_,_) -> drec c - | Prod (n,t,c) -> mkProd (n, t, drec c) - | LetIn (n,b,t,c) -> mkLetIn (n,b, t, drec c) - | Sort _ -> mkSort sort + | Prod (n,t,c) -> let s, c' = drec c in s, mkProd (n, t, c') + | LetIn (n,b,t,c) -> let s, c' = drec c in s, mkLetIn (n,b,t,c') + | Sort s -> s, mkSort sort | _ -> assert false in drec -(* [npar] is the number of expected arguments (then excluding letin's) *) -let modify_sort_scheme sort = - let rec drec npar elim = - match kind_of_term elim with - | Lambda (n,t,c) -> - if Int.equal npar 0 then - mkLambda (n, change_sort_arity sort t, c) - else - mkLambda (n, t, drec (npar-1) c) - | LetIn (n,b,t,c) -> mkLetIn (n,b,t,drec npar c) - | _ -> anomaly ~label:"modify_sort_scheme" (Pp.str "wrong elimination type") - in - drec - (* Change the sort in the type of an inductive definition, builds the corresponding eta-expanded term *) -let weaken_sort_scheme sort npars term = +let weaken_sort_scheme env evd set sort npars term ty = + let evdref = ref evd in let rec drec np elim = match kind_of_term elim with | Prod (n,t,c) -> if Int.equal np 0 then - let t' = change_sort_arity sort t in - mkProd (n, t', c), - mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1))) + let osort, t' = change_sort_arity sort t in + evdref := (if set then Evd.set_eq_sort else Evd.set_leq_sort) !evdref sort osort; + mkProd (n, t', c), + mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1))) else let c',term' = drec (np-1) c in mkProd (n, t, c'), mkLambda (n, t, term') @@ -497,7 +492,8 @@ let weaken_sort_scheme sort npars term = mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term') | _ -> anomaly ~label:"weaken_sort_scheme" (Pp.str "wrong elimination type") in - drec npars + let ty, term = drec npars ty in + !evdref, ty, term (**********************************************************************) (* Interface to build complex Scheme *) @@ -506,11 +502,12 @@ let weaken_sort_scheme sort npars term = let check_arities listdepkind = let _ = List.fold_left - (fun ln ((_,ni as mind),mibi,mipi,dep,kind) -> + (fun ln (((_,ni as mind),u),mibi,mipi,dep,kind) -> let kelim = elim_sorts (mibi,mipi) in if not (Sorts.List.mem kind kelim) then raise (RecursionSchemeError - (NotAllowedCaseAnalysis (true, Termops.new_sort_in_family kind,mind))) + (NotAllowedCaseAnalysis (true, fst (Universes.fresh_sort_in_family (Global.env ()) + kind),(mind,u)))) else if Int.List.mem ni ln then raise (RecursionSchemeError (NotMutualInScheme (mind,mind))) else ni::ln) @@ -518,28 +515,29 @@ let check_arities listdepkind = in true let build_mutual_induction_scheme env sigma = function - | (mind,dep,s)::lrecspec -> + | ((mind,u),dep,s)::lrecspec -> let (mib,mip) = Global.lookup_inductive mind in let (sp,tyi) = mind in let listdepkind = - (mind,mib,mip,dep,s):: + ((mind,u),mib,mip,dep,s):: (List.map - (function (mind',dep',s') -> + (function ((mind',u'),dep',s') -> let (sp',_) = mind' in if eq_mind sp sp' then let (mibi',mipi') = lookup_mind_specif env mind' in - (mind',mibi',mipi',dep',s') + ((mind',u'),mibi',mipi',dep',s') else raise (RecursionSchemeError (NotMutualInScheme (mind,mind')))) lrecspec) in let _ = check_arities listdepkind in - mis_make_indrec env sigma listdepkind mib + mis_make_indrec env sigma listdepkind mib u | _ -> anomaly (Pp.str "build_induction_scheme expects a non empty list of inductive types") -let build_induction_scheme env sigma ind dep kind = - let (mib,mip) = lookup_mind_specif env ind in - List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] mib) +let build_induction_scheme env sigma pind dep kind = + let (mib,mip) = lookup_mind_specif env (fst pind) in + let sigma, l = mis_make_indrec env sigma [(pind,mib,mip,dep,kind)] mib (snd pind) in + sigma, List.hd l (*s Eliminations. *) @@ -564,11 +562,11 @@ let lookup_eliminator ind_sp s = try let cst =Global.constant_of_delta_kn (make_kn mp dp (Label.of_id id)) in let _ = Global.lookup_constant cst in - mkConst cst + ConstRef cst with Not_found -> (* Then try to get a user-defined eliminator in some other places *) (* using short name (e.g. for "eq_rec") *) - try constr_of_global (Nametab.locate (qualid_of_ident id)) + try Nametab.locate (qualid_of_ident id) with Not_found -> errorlabstrm "default_elim" (strbrk "Cannot find the elimination combinator " ++ diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli index 6bcfac20ed..54827281a1 100644 --- a/pretyping/indrec.mli +++ b/pretyping/indrec.mli @@ -14,7 +14,7 @@ open Evd (** Errors related to recursors building *) type recursion_scheme_error = - | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * inductive + | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * pinductive | NotMutualInScheme of inductive * inductive exception RecursionSchemeError of recursion_scheme_error @@ -25,41 +25,38 @@ type dep_flag = bool (** Build a case analysis elimination scheme in some sort family *) -val build_case_analysis_scheme : env -> evar_map -> inductive -> - dep_flag -> sorts_family -> constr +val build_case_analysis_scheme : env -> evar_map -> pinductive -> + dep_flag -> sorts_family -> evar_map * constr (** Build a dependent case elimination predicate unless type is in Prop *) -val build_case_analysis_scheme_default : env -> evar_map -> inductive -> - sorts_family -> constr +val build_case_analysis_scheme_default : env -> evar_map -> pinductive -> + sorts_family -> evar_map * constr (** Builds a recursive induction scheme (Peano-induction style) in the same sort family as the inductive family; it is dependent if not in Prop *) -val build_induction_scheme : env -> evar_map -> inductive -> - dep_flag -> sorts_family -> constr +val build_induction_scheme : env -> evar_map -> pinductive -> + dep_flag -> sorts_family -> evar_map * constr (** Builds mutual (recursive) induction schemes *) val build_mutual_induction_scheme : - env -> evar_map -> (inductive * dep_flag * sorts_family) list -> constr list + env -> evar_map -> (pinductive * dep_flag * sorts_family) list -> evar_map * constr list (** Scheme combinators *) -(** [modify_sort_scheme s n c] modifies the quantification sort of - scheme c whose predicate is abstracted at position [n] of [c] *) +(** [weaken_sort_scheme env sigma eq s n c t] derives by subtyping from [c:t] + whose conclusion is quantified on [Type i] at position [n] of [t] a + scheme quantified on sort [s]. [set] asks for [s] be declared equal to [i], + otherwise just less or equal to [i]. *) -val modify_sort_scheme : sorts -> int -> constr -> constr - -(** [weaken_sort_scheme s n c t] derives by subtyping from [c:t] - whose conclusion is quantified on [Type] at position [n] of [t] a - scheme quantified on sort [s] *) - -val weaken_sort_scheme : sorts -> int -> constr -> types -> constr * types +val weaken_sort_scheme : env -> evar_map -> bool -> sorts -> int -> constr -> types -> + evar_map * types * constr (** Recursor names utilities *) -val lookup_eliminator : inductive -> sorts_family -> constr +val lookup_eliminator : inductive -> sorts_family -> Globnames.global_reference val elimination_suffix : sorts_family -> string val make_elimination_ident : Id.t -> sorts_family -> Id.t diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 775795ce0d..7e4d37b2e8 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -19,32 +19,38 @@ open Declarations open Declareops open Environ open Reductionops +open Inductive (* The following three functions are similar to the ones defined in Inductive, but they expect an env *) -let type_of_inductive env ind = +let type_of_inductive env (ind,u) = let specif = Inductive.lookup_mind_specif env ind in - Inductive.type_of_inductive env specif + Inductive.type_of_inductive env (specif,u) (* Return type as quoted by the user *) -let type_of_constructor env cstr = +let type_of_constructor env (cstr,u) = let specif = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in - Inductive.type_of_constructor cstr specif + Inductive.type_of_constructor (cstr,u) specif + +let type_of_constructor_in_ctx env cstr = + let specif = + Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in + Inductive.type_of_constructor_in_ctx cstr specif (* Return constructor types in user form *) -let type_of_constructors env ind = +let type_of_constructors env (ind,u as indu) = let specif = Inductive.lookup_mind_specif env ind in - Inductive.type_of_constructors ind specif + Inductive.type_of_constructors indu specif (* Return constructor types in normal form *) -let arities_of_constructors env ind = +let arities_of_constructors env (ind,u as indu) = let specif = Inductive.lookup_mind_specif env ind in - Inductive.arities_of_constructors ind specif + Inductive.arities_of_constructors indu specif (* [inductive_family] = [inductive_instance] applied to global parameters *) -type inductive_family = inductive * constr list +type inductive_family = pinductive * constr list let make_ind_family (mis, params) = (mis,params) let dest_ind_family (mis,params) = (mis,params) @@ -71,7 +77,7 @@ let lift_inductive_type n = liftn_inductive_type n 1 let substnl_ind_type l n = map_inductive_type (substnl l n) let mkAppliedInd (IndType ((ind,params), realargs)) = - applist (mkInd ind,params@realargs) + applist (mkIndU ind,params@realargs) (* Does not consider imbricated or mutually recursive types *) let mis_is_recursive_subset listind rarg = @@ -88,13 +94,14 @@ let mis_is_recursive (ind,mib,mip) = mis_is_recursive_subset (List.interval 0 (mib.mind_ntypes - 1)) mip.mind_recargs -let mis_nf_constructor_type (ind,mib,mip) j = +let mis_nf_constructor_type ((ind,u),mib,mip) j = let specif = mip.mind_nf_lc and ntypes = mib.mind_ntypes and nconstr = Array.length mip.mind_consnames in - let make_Ik k = mkInd ((fst ind),ntypes-k-1) in + let make_Ik k = mkIndU (((fst ind),ntypes-k-1),u) in if j > nconstr then error "Not enough constructors in the type."; - substl (List.init ntypes make_Ik) specif.(j-1) + let univsubst = make_inductive_subst mib u in + substl (List.init ntypes make_Ik) (subst_univs_constr univsubst specif.(j-1)) (* Arity of constructors excluding parameters and local defs *) @@ -139,9 +146,10 @@ let constructor_nrealhyps (ind,j) = let (mib,mip) = Global.lookup_inductive ind in mip.mind_consnrealdecls.(j-1) -let get_full_arity_sign env ind = +let get_full_arity_sign env (ind,u) = let (mib,mip) = Inductive.lookup_mind_specif env ind in - mip.mind_arity_ctxt + let subst = Inductive.make_inductive_subst mib u in + Vars.subst_univs_context subst mip.mind_arity_ctxt let nconstructors ind = let (mib,mip) = Inductive.lookup_mind_specif (Global.env()) ind in @@ -164,6 +172,10 @@ let inductive_has_local_defs ind = let inductive_nparams ind = (fst (Global.lookup_inductive ind)).mind_nparams +let inductive_params_ctxt (ind,u) = + let (mib,mip) = Global.lookup_inductive ind in + Inductive.inductive_params_ctxt (mib,u) + let inductive_nargs ind = let (mib,mip) = Global.lookup_inductive ind in (rel_context_length (mib.mind_params_ctxt), mip.mind_nrealargs_ctxt) @@ -189,7 +201,7 @@ let make_case_info env ind style = (*s Useful functions *) type constructor_summary = { - cs_cstr : constructor; + cs_cstr : pconstructor; cs_params : constr list; cs_nargs : int; cs_args : rel_context; @@ -219,21 +231,21 @@ let instantiate_params t args sign = | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") in inst [] t (List.rev sign,args) -let get_constructor (ind,mib,mip,params) j = +let get_constructor ((ind,u as indu),mib,mip,params) j = assert (j <= Array.length mip.mind_consnames); - let typi = mis_nf_constructor_type (ind,mib,mip) j in + let typi = mis_nf_constructor_type (indu,mib,mip) j in let typi = instantiate_params typi params mib.mind_params_ctxt in let (args,ccl) = decompose_prod_assum typi in let (_,allargs) = decompose_app ccl in let vargs = List.skipn (List.length params) allargs in - { cs_cstr = ith_constructor_of_inductive ind j; + { cs_cstr = (ith_constructor_of_inductive ind j,u); cs_params = params; cs_nargs = rel_context_length args; cs_args = args; cs_concl_realargs = Array.of_list vargs } let get_constructors env (ind,params) = - let (mib,mip) = Inductive.lookup_mind_specif env ind in + let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in Array.init (Array.length mip.mind_consnames) (fun j -> get_constructor (ind,mib,mip,params) (j+1)) @@ -255,8 +267,9 @@ let instantiate_context sign args = | _ -> anomaly (Pp.str "Signature/instance mismatch in inductive family") in aux [] (List.rev sign,args) -let get_arity env (ind,params) = +let get_arity env ((ind,u),params) = let (mib,mip) = Inductive.lookup_mind_specif env ind in + let univsubst = make_inductive_subst mib u in let parsign = (* Dynamically detect if called with an instance of recursively uniform parameter only or also of non recursively uniform @@ -267,15 +280,17 @@ let get_arity env (ind,params) = snd (List.chop nnonrecparams mib.mind_params_ctxt) else parsign in + let parsign = Vars.subst_univs_context univsubst parsign in let arproperlength = List.length mip.mind_arity_ctxt - List.length parsign in let arsign,_ = List.chop arproperlength mip.mind_arity_ctxt in let subst = instantiate_context parsign params in + let arsign = Vars.subst_univs_context univsubst arsign in (substl_rel_context subst arsign, Inductive.inductive_sort_family mip) (* Functions to build standard types related to inductive *) let build_dependent_constructor cs = applist - (mkConstruct cs.cs_cstr, + (mkConstructU cs.cs_cstr, (List.map (lift cs.cs_nargs) cs.cs_params) @(extended_rel_list 0 cs.cs_args)) @@ -283,7 +298,7 @@ let build_dependent_inductive env ((ind, params) as indf) = let arsign,_ = get_arity env indf in let nrealargs = List.length arsign in applist - (mkInd ind, + (mkIndU ind, (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign)) (* builds the arity of an elimination predicate in sort [s] *) @@ -328,18 +343,18 @@ let find_mrectype env sigma c = let find_rectype env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with - | Ind ind -> + | Ind (ind,u as indu) -> let (mib,mip) = Inductive.lookup_mind_specif env ind in if mib.mind_nparams > List.length l then raise Not_found; let (par,rargs) = List.chop mib.mind_nparams l in - IndType((ind, par),rargs) + IndType((indu, par),rargs) | _ -> raise Not_found let find_inductive env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with | Ind ind - when (fst (Inductive.lookup_mind_specif env ind)).mind_finite -> + when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite -> (ind, l) | _ -> raise Not_found @@ -347,7 +362,7 @@ let find_coinductive env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with | Ind ind - when not (fst (Inductive.lookup_mind_specif env ind)).mind_finite -> + when not (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite -> (ind, l) | _ -> raise Not_found @@ -414,7 +429,7 @@ let set_pattern_names env ind brv = let type_case_branches_with_names env indspec p c = let (ind,args) = indspec in - let (mib,mip as specif) = Inductive.lookup_mind_specif env ind in + let (mib,mip as specif) = Inductive.lookup_mind_specif env (fst ind) in let nparams = mib.mind_nparams in let (params,realargs) = List.chop nparams args in let lbrty = Inductive.build_branches_type ind specif params p in @@ -422,7 +437,7 @@ let type_case_branches_with_names env indspec p c = let conclty = Reduction.beta_appvect p (Array.of_list (realargs@[c])) in (* Adjust names *) if is_elim_predicate_explicitly_dependent env p (ind,params) then - (set_pattern_names env ind lbrty, conclty) + (set_pattern_names env (fst ind) lbrty, conclty) else (lbrty, conclty) (* Type of Case predicates *) @@ -436,40 +451,9 @@ let arity_of_case_predicate env (ind,params) dep k = (* Inferring the sort of parameters of a polymorphic inductive type knowing the sort of the conclusion *) -(* Compute the inductive argument types: replace the sorts - that appear in the type of the inductive by the sort of the - conclusion, and the other ones by fresh universes. *) -let rec instantiate_universes env scl is = function - | (_,Some _,_ as d)::sign, exp -> - d :: instantiate_universes env scl is (sign, exp) - | d::sign, None::exp -> - d :: instantiate_universes env scl is (sign, exp) - | (na,None,ty)::sign, Some u::exp -> - let ctx,_ = Reduction.dest_arity env ty in - let s = - (* Does the sort of parameter [u] appear in (or equal) - the sort of inductive [is] ? *) - if univ_depends u is then - scl (* constrained sort: replace by scl *) - else - (* unconstriained sort: replace by fresh universe *) - new_Type_sort() in - (na,None,mkArity(ctx,s)):: instantiate_universes env scl is (sign, exp) - | sign, [] -> sign (* Uniform parameters are exhausted *) - | [], _ -> assert false - -(* Does not deal with universes, but only with Set/Type distinction *) -let type_of_inductive_knowing_conclusion env mip conclty = - match mip.mind_arity with - | Monomorphic s -> - s.mind_user_arity - | Polymorphic ar -> - let _,scl = Reduction.dest_arity env conclty in - let ctx = List.rev mip.mind_arity_ctxt in - let ctx = - instantiate_universes - env scl ar.poly_level (ctx,ar.poly_param_levels) in - mkArity (List.rev ctx,scl) +let type_of_inductive_knowing_conclusion env ((mib,mip),u) conclty = + let subst = Inductive.make_inductive_subst mib u in + subst_univs_constr subst mip.mind_arity.mind_user_arity (***********************************************) (* Guard condition *) @@ -490,7 +474,3 @@ let control_only_guard env c = iter_constr_with_full_binders push_rel iter env c in iter env c - -let subst_inductive subst (kn,i as ind) = - let kn' = Mod_subst.subst_ind subst kn in - if kn == kn' then ind else (kn',i) diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 204f506a63..39451ec050 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -16,19 +16,20 @@ open Evd (** The following three functions are similar to the ones defined in Inductive, but they expect an env *) -val type_of_inductive : env -> inductive -> types +val type_of_inductive : env -> pinductive -> types (** Return type as quoted by the user *) -val type_of_constructor : env -> constructor -> types -val type_of_constructors : env -> inductive -> types array +val type_of_constructor : env -> pconstructor -> types +val type_of_constructor_in_ctx : env -> constructor -> types Univ.in_universe_context +val type_of_constructors : env -> pinductive -> types array (** Return constructor types in normal form *) -val arities_of_constructors : env -> inductive -> types array +val arities_of_constructors : env -> pinductive -> types array (** An inductive type with its parameters *) type inductive_family -val make_ind_family : inductive * constr list -> inductive_family -val dest_ind_family : inductive_family -> inductive * constr list +val make_ind_family : inductive puniverses * constr list -> inductive_family +val dest_ind_family : inductive_family -> inductive puniverses * constr list val map_ind_family : (constr -> constr) -> inductive_family -> inductive_family val liftn_inductive_family : int -> int -> inductive_family -> inductive_family val lift_inductive_family : int -> inductive_family -> inductive_family @@ -49,7 +50,7 @@ val mis_is_recursive_subset : int list -> wf_paths -> bool val mis_is_recursive : inductive * mutual_inductive_body * one_inductive_body -> bool val mis_nf_constructor_type : - inductive * mutual_inductive_body * one_inductive_body -> int -> constr + pinductive * mutual_inductive_body * one_inductive_body -> int -> constr (** {6 Extract information from an inductive name} @@ -69,6 +70,7 @@ val inductive_nargs_env : env -> inductive -> int * int (** @return nb of params without letin *) val inductive_nparams : inductive -> int +val inductive_params_ctxt : pinductive -> rel_context (** @return param + args without letin *) val mis_constructor_nargs : constructor -> int @@ -88,14 +90,14 @@ val constructor_nrealhyps : constructor -> int val mis_constructor_has_local_defs : constructor -> bool val inductive_has_local_defs : inductive -> bool -val get_full_arity_sign : env -> inductive -> rel_context +val get_full_arity_sign : env -> pinductive -> rel_context val allowed_sorts : env -> inductive -> sorts_family list (** Extract information from an inductive family *) type constructor_summary = { - cs_cstr : constructor; (* internal name of the constructor *) + cs_cstr : pconstructor; (* internal name of the constructor plus universes *) cs_params : constr list; (* parameters of the constructor in current ctx *) cs_nargs : int; (* length of arguments signature (letin included) *) cs_args : rel_context; (* signature of the arguments (letin included) *) @@ -103,7 +105,7 @@ type constructor_summary = { } val lift_constructor : int -> constructor_summary -> constructor_summary val get_constructor : - inductive * mutual_inductive_body * one_inductive_body * constr list -> + pinductive * mutual_inductive_body * one_inductive_body * constr list -> int -> constructor_summary val get_arity : env -> inductive_family -> rel_context * sorts_family val get_constructors : env -> inductive_family -> constructor_summary array @@ -114,11 +116,11 @@ val make_arity : env -> bool -> inductive_family -> sorts -> types val build_branch_type : env -> bool -> constr -> constructor_summary -> types (** Raise [Not_found] if not given an valid inductive type *) -val extract_mrectype : constr -> inductive * constr list -val find_mrectype : env -> evar_map -> types -> inductive * constr list +val extract_mrectype : constr -> pinductive * constr list +val find_mrectype : env -> evar_map -> types -> pinductive * constr list val find_rectype : env -> evar_map -> types -> inductive_type -val find_inductive : env -> evar_map -> types -> inductive * constr list -val find_coinductive : env -> evar_map -> types -> inductive * constr list +val find_inductive : env -> evar_map -> types -> pinductive * constr list +val find_coinductive : env -> evar_map -> types -> pinductive * constr list (********************) @@ -127,7 +129,7 @@ val arity_of_case_predicate : env -> inductive_family -> bool -> sorts -> types val type_case_branches_with_names : - env -> inductive * constr list -> constr -> constr -> + env -> pinductive * constr list -> constr -> constr -> types array * types (** Annotation for cases *) @@ -140,9 +142,7 @@ i*) (********************) val type_of_inductive_knowing_conclusion : - env -> one_inductive_body -> types -> types + env -> Inductive.mind_specif puniverses -> types -> types (********************) val control_only_guard : env -> types -> unit - -val subst_inductive : Mod_subst.substitution -> inductive -> inductive diff --git a/pretyping/namegen.ml b/pretyping/namegen.ml index d4435489a1..c6c21f0259 100644 --- a/pretyping/namegen.ml +++ b/pretyping/namegen.ml @@ -76,9 +76,10 @@ let hdchar env c = | LetIn (_,_,_,c) -> hdrec (k+1) c | Cast (c,_,_) -> hdrec k c | App (f,l) -> hdrec k f - | Const kn -> lowercase_first_char (Label.to_id (con_label kn)) - | Ind x -> lowercase_first_char (basename_of_global (IndRef x)) - | Construct x -> lowercase_first_char (basename_of_global (ConstructRef x)) + | Proj (kn,_) + | Const (kn,_) -> lowercase_first_char (Label.to_id (con_label kn)) + | Ind (x,_) -> lowercase_first_char (basename_of_global (IndRef x)) + | Construct (x,_) -> lowercase_first_char (basename_of_global (ConstructRef x)) | Var id -> lowercase_first_char id | Sort s -> sort_hdchar s | Rel n -> diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index b635229cfd..829fa106c5 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -59,7 +59,7 @@ 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 in + let s = ind_subst mind mib Univ.Instance.empty (* FIXME *)in let ctyp = substl s typ in let nparams = Array.length params in if Int.equal nparams 0 then ctyp @@ -67,7 +67,7 @@ let type_constructor mind mib typ params = let _,ctyp = decompose_prod_n nparams ctyp in substl (List.rev (Array.to_list params)) ctyp -let construct_of_constr_notnative const env tag (mind, _ as ind) allargs = +let construct_of_constr_notnative const env tag (mind, _ as ind) u allargs = let mib,mip = lookup_mind_specif env ind in let nparams = mib.mind_nparams in let params = Array.sub allargs 0 nparams in @@ -80,14 +80,14 @@ let construct_of_constr_notnative const env tag (mind, _ as ind) allargs = 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 - (mkApp(mkConstruct(ind,i), params), ctyp) + (mkApp(mkConstructU((ind,i),u), params), ctyp) let construct_of_constr const env tag typ = let t, l = app_type env typ in match kind_of_term t with - | Ind ind -> - construct_of_constr_notnative const env tag ind l + | Ind (ind,u) -> + construct_of_constr_notnative const env tag ind u l | _ -> assert false let construct_of_constr_const env tag typ = @@ -109,9 +109,9 @@ let build_branches_type env (mind,_ as _ind) mib mip params dep p = let codom = let papp = mkApp(lift (List.length decl) p,crealargs) in if dep then - let cstr = ith_constructor_of_inductive ind (i+1) in + let cstr = ith_constructor_of_inductive (fst ind) (i+1) in let relargs = Array.init carity (fun i -> mkRel (carity-i)) in - let dep_cstr = mkApp(mkApp(mkConstruct cstr,params),relargs) in + let dep_cstr = mkApp(mkApp(mkConstructU (cstr,snd ind),params),relargs) in mkApp(papp,[|dep_cstr|]) else papp in @@ -266,6 +266,9 @@ and nf_atom env atom = mkProd(n,dom,codom) | Ameta (mv,_) -> mkMeta mv | Aevar (ev,_) -> mkEvar ev + | Aproj(p,c) -> + let c = nf_accu env c in + mkProj(p,c) | _ -> fst (nf_atom_type env atom) and nf_atom_type env atom = @@ -274,17 +277,17 @@ and nf_atom_type env atom = let n = (nb_rel env - i) in mkRel n, type_of_rel env n | Aconstant cst -> - mkConst cst, Typeops.type_of_constant env cst + mkConst cst, fst (Typeops.type_of_constant env (cst,Univ.Instance.empty)) (* FIXME *) | Aind ind -> - mkInd ind, Inductiveops.type_of_inductive env ind + mkInd ind, Inductiveops.type_of_inductive env (ind,Univ.Instance.empty) | Asort s -> mkSort s, type_of_sort s | Avar id -> mkVar id, type_of_var env id | Acase(ans,accu,p,bs) -> let a,ta = nf_accu_type env accu in - let (mind,_ as ind),allargs = find_rectype_a env ta in - let (mib,mip) = Inductive.lookup_mind_specif env ind in + let ((mind,_),u as ind),allargs = find_rectype_a env ta in + let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in let nparams = mib.mind_nparams in let params,realargs = Array.chop nparams allargs in let pT = @@ -293,7 +296,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 ind mib mip params dep p in + let btypes = build_branches_type env (fst ind) mib mip params dep p in (* calcul des branches *) let bsw = branch_of_switch (nb_rel env) ans bs in let mkbranch i v = @@ -336,6 +339,12 @@ and nf_atom_type env atom = | Ameta(mv,ty) -> let ty = nf_type env ty in mkMeta mv, ty + | Aproj(p,c) -> + let c,tc = nf_accu_type env c in + let cj = make_judge c tc in + let uj = Typeops.judge_of_projection env p cj in + uj.uj_val, uj.uj_type + and nf_predicate env ind mip params v pT = match kind_of_value v, kind_of_term pT with @@ -358,7 +367,7 @@ and nf_predicate env ind mip params v pT = let n = mip.mind_nrealargs in let rargs = Array.init n (fun i -> mkRel (n-i)) in let params = if Int.equal n 0 then params else Array.map (lift n) params in - let dom = mkApp(mkInd ind,Array.append params rargs) in + let dom = mkApp(mkIndU ind,Array.append params rargs) in let body = nf_type (push_rel (name,None,dom) env) vb in true, mkLambda(name,dom,body) | _, _ -> false, nf_type env v diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index cc13d342a5..8557953cc4 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -81,6 +81,7 @@ and rec_declaration_eq (n1, c1, r1) (n2, c2, r2) = let rec occur_meta_pattern = function | PApp (f,args) -> (occur_meta_pattern f) || (Array.exists occur_meta_pattern args) + | PProj (_,arg) -> occur_meta_pattern arg | PLambda (na,t,c) -> (occur_meta_pattern t) || (occur_meta_pattern c) | PProd (na,t,c) -> (occur_meta_pattern t) || (occur_meta_pattern c) | PLetIn (na,t,c) -> (occur_meta_pattern t) || (occur_meta_pattern c) @@ -105,6 +106,7 @@ let rec head_pattern_bound t = | PCase (_,p,c,br) -> head_pattern_bound c | PRef r -> r | PVar id -> VarRef id + | PProj (p,c) -> ConstRef p | PEvar _ | PRel _ | PMeta _ | PSoApp _ | PSort _ | PFix _ -> raise BoundPattern (* Perhaps they were arguments, but we don't beta-reduce *) @@ -112,9 +114,9 @@ let rec head_pattern_bound t = | PCoFix _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type") let head_of_constr_reference c = match kind_of_term c with - | Const sp -> ConstRef sp - | Construct sp -> ConstructRef sp - | Ind sp -> IndRef sp + | Const (sp,_) -> ConstRef sp + | Construct (sp,_) -> ConstructRef sp + | Ind (sp,_) -> IndRef sp | Var id -> VarRef id | _ -> anomaly (Pp.str "Not a rigid reference") @@ -145,9 +147,11 @@ let pattern_of_constr sigma t = with | Some n -> PSoApp (n,Array.to_list (Array.map pattern_of_constr a)) | None -> PApp (pattern_of_constr f,Array.map (pattern_of_constr) a)) - | Const sp -> PRef (ConstRef (constant_of_kn(canonical_con sp))) - | Ind sp -> PRef (canonical_gr (IndRef sp)) - | Construct sp -> PRef (canonical_gr (ConstructRef sp)) + | Const (sp,u) -> PRef (ConstRef (constant_of_kn(canonical_con sp))) + | Ind (sp,u) -> PRef (canonical_gr (IndRef sp)) + | Construct (sp,u) -> PRef (canonical_gr (ConstructRef sp)) + | Proj (p, c) -> + PProj (constant_of_kn(canonical_con p), pattern_of_constr c) | Evar (evk,ctxt as ev) -> (match snd (Evd.evar_source evk sigma) with | Evar_kinds.MatchingVar (b,id) -> @@ -185,6 +189,7 @@ let map_pattern_with_binders g f l = function | PIf (c,b1,b2) -> PIf (f l c,f l b1,f l b2) | PCase (ci,po,p,pl) -> PCase (ci,f l po,f l p, List.map (fun (i,n,c) -> (i,n,f l c)) pl) + | PProj (p,pc) -> PProj (p, f l pc) (* Non recursive *) | (PVar _ | PEvar _ | PRel _ | PRef _ | PSort _ | PMeta _ (* Bound to terms *) @@ -240,6 +245,12 @@ let rec subst_pattern subst pat = | PVar _ | PEvar _ | PRel _ -> pat + | PProj (p,c) -> + let p',t = subst_global subst (ConstRef p) in + let p' = destConstRef p' in + let c' = subst_pattern subst c in + if p' == p && c' == c then pat else + PProj(p',c') | PApp (f,args) -> let f' = subst_pattern subst f in let args' = Array.smartmap (subst_pattern subst) args in @@ -274,7 +285,7 @@ let rec subst_pattern subst pat = PIf (c',c1',c2') | PCase (cip,typ,c,branches) -> let ind = cip.cip_ind in - let ind' = Option.smartmap (Inductiveops.subst_inductive subst) ind in + let ind' = Option.smartmap (subst_ind subst) ind in let cip' = if ind' == ind then cip else { cip with cip_ind = ind' } in let typ' = subst_pattern subst typ in let c' = subst_pattern subst c in @@ -308,11 +319,13 @@ let rec pat_of_raw metas vars = function with Not_found -> PVar id) | GPatVar (_,(false,n)) -> metas := n::!metas; PMeta (Some n) - | GRef (_,gr) -> + | GRef (_,gr,_) -> PRef (canonical_gr gr) (* Hack pour ne pas réécrire une interprétation complčte des patterns*) | GApp (_, GPatVar (_,(true,n)), cl) -> metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl) + | GProj (_, p, c) -> + PProj (p, pat_of_raw metas vars c) | GApp (_,c,cl) -> PApp (pat_of_raw metas vars c, Array.of_list (List.map (pat_of_raw metas vars) cl)) diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 8ffd53055e..003665db59 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -21,7 +21,7 @@ type unification_error = | ConversionFailed of env * constr * constr | MetaOccurInBody of existential_key | InstanceNotSameType of existential_key * env * types * types - | UnifUnivInconsistency + | UnifUnivInconsistency of Univ.univ_inconsistency type pretype_error = (* Old Case *) diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 8e98f63076..d9ee969e3c 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -22,7 +22,7 @@ type unification_error = | ConversionFailed of env * constr * constr | MetaOccurInBody of existential_key | InstanceNotSameType of existential_key * env * types * types - | UnifUnivInconsistency + | UnifUnivInconsistency of Univ.univ_inconsistency type pretype_error = (** Old Case *) @@ -70,7 +70,7 @@ val error_case_not_inductive_loc : val error_ill_formed_branch_loc : Loc.t -> env -> Evd.evar_map -> - constr -> constructor -> constr -> constr -> 'b + constr -> pconstructor -> constr -> constr -> 'b val error_number_branches_loc : Loc.t -> env -> Evd.evar_map -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index c66221e5f7..7777de514b 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -93,10 +93,10 @@ let ((constr_in : constr -> Dyn.t), (** Miscellaneous interpretation functions *) -let interp_sort = function - | GProp -> Prop Null - | GSet -> Prop Pos - | GType _ -> new_Type_sort () +let interp_sort evd = function + | GProp -> evd, Prop Null + | GSet -> evd, Prop Pos + | GType _ -> new_sort_variable univ_rigid evd let interp_elimination_sort = function | GProp -> InProp @@ -157,7 +157,7 @@ let check_extra_evars_are_solved env initial_sigma sigma = let check_evars_are_solved env initial_sigma sigma = check_typeclasses_instances_are_solved env sigma; - check_problems_are_solved sigma; + check_problems_are_solved env sigma; check_extra_evars_are_solved env initial_sigma sigma (* Try typeclasses, hooks, unification heuristics ... *) @@ -179,21 +179,6 @@ let process_inference_flags flags env initial_sigma (sigma,c) = (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *) let allow_anonymous_refs = ref false -let evd_comb0 f evdref = - let (evd',x) = f !evdref in - evdref := evd'; - x - -let evd_comb1 f evdref x = - let (evd',y) = f !evdref x in - evdref := evd'; - y - -let evd_comb2 f evdref x y = - let (evd',z) = f !evdref x y in - evdref := evd'; - z - (* Utilisé pour inférer le prédicat des Cases *) (* Semble exagérement fort *) (* Faudra préférer une unification entre les types de toutes les clauses *) @@ -236,7 +221,8 @@ let protected_get_type_of env sigma c = (str "Cannot reinterpret " ++ quote (print_constr c) ++ str " in the current environment.") -let pretype_id loc env sigma (lvar,unbndltacvars) id = +let pretype_id loc env evdref (lvar,unbndltacvars) id = + let sigma = !evdref in (* Look for the binder of [id] *) try let (n,_,typ) = lookup_rel_id id (rel_context env) in @@ -257,6 +243,12 @@ let pretype_id loc env sigma (lvar,unbndltacvars) id = (* Check if [id] is a section or goal variable *) try let (_,_,typ) = lookup_named id env in + (* let _ = *) + (* try *) + (* let ctx = Decls.variable_context id in *) + (* evdref := Evd.merge_context_set univ_rigid !evdref ctx; *) + (* with Not_found -> () *) + (* in *) { uj_val = mkVar id; uj_type = typ } with Not_found -> (* [id] not found, standard error message *) @@ -268,18 +260,26 @@ let evar_kind_of_term sigma c = (*************************************************************************) (* Main pretyping function *) -let pretype_ref loc evdref env = function +(* Check with universe list? *) +let pretype_global rigid env evd gr us = Evd.fresh_global ~rigid env evd gr + +let pretype_ref loc evdref env ref us = + match ref with | VarRef id -> (* Section variable *) - (try let (_,_,ty) = lookup_named id env in make_judge (mkVar id) ty + (try let (_,_,ty) = lookup_named id env in + (* let ctx = Decls.variable_context id in *) + (* evdref := Evd.merge_context_set univ_rigid !evdref ctx; *) + make_judge (mkVar id) ty with Not_found -> (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal variables *) Pretype_errors.error_var_not_found_loc loc id) | ref -> - let c = constr_of_global ref in - make_judge c (Retyping.get_type_of env Evd.empty c) + let evd, c = pretype_global univ_flexible env !evdref ref us in + evdref := evd; + make_judge c (Retyping.get_type_of env evd c) let pretype_sort evdref = function | GProp -> judge_of_prop @@ -287,27 +287,37 @@ let pretype_sort evdref = function | GType _ -> evd_comb0 judge_of_new_Type evdref let new_type_evar evdref env loc = - evd_comb0 (fun evd -> Evarutil.new_type_evar evd env ~src:(loc,Evar_kinds.InternalHole)) evdref + let e, s = + evd_comb0 (fun evd -> Evarutil.new_type_evar univ_flexible_alg evd env ~src:(loc,Evar_kinds.InternalHole)) evdref + in e + +let get_projection env cst = + let cb = lookup_constant cst env in + match cb.Declarations.const_proj with + | Some {Declarations.proj_ind = mind; proj_npars = n; proj_arg = m; proj_type = ty} -> + (cst,mind,n,m,ty) + | None -> raise Not_found let (f_genarg_interp, genarg_interp_hook) = Hook.make () (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *) (* in environment [env], with existential variables [evdref] and *) (* the type constraint tycon *) + let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t = let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in let pretype_type = pretype_type resolve_tc in let pretype = pretype resolve_tc in match t with - | GRef (loc,ref) -> + | GRef (loc,ref,u) -> inh_conv_coerce_to_tycon loc env evdref - (pretype_ref loc evdref env ref) + (pretype_ref loc evdref env ref u) tycon | GVar (loc, id) -> - inh_conv_coerce_to_tycon loc env evdref - (pretype_id loc env !evdref lvar id) - tycon + inh_conv_coerce_to_tycon loc env evdref + (pretype_id loc env evdref lvar id) + tycon | GEvar (loc, evk, instopt) -> (* Ne faudrait-il pas s'assurer que hyps est bien un @@ -321,12 +331,12 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t = inh_conv_coerce_to_tycon loc env evdref j tycon | GPatVar (loc,(someta,n)) -> - let ty = - match tycon with - | Some ty -> ty - | None -> new_type_evar evdref env loc in - let k = Evar_kinds.MatchingVar (someta,n) in - { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty } + let ty = + match tycon with + | Some ty -> ty + | None -> new_type_evar evdref env loc in + let k = Evar_kinds.MatchingVar (someta,n) in + { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty } | GHole (loc, k, None) -> let ty = @@ -348,178 +358,216 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t = { uj_val = c; uj_type = ty } | GRec (loc,fixkind,names,bl,lar,vdef) -> - let rec type_bl env ctxt = function - [] -> ctxt - | (na,bk,None,ty)::bl -> - let ty' = pretype_type empty_valcon env evdref lvar ty in - let dcl = (na,None,ty'.utj_val) in - type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl - | (na,bk,Some bd,ty)::bl -> - let ty' = pretype_type empty_valcon env evdref lvar ty in - let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar ty in - let dcl = (na,Some bd'.uj_val,ty'.utj_val) in - type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in - let ctxtv = Array.map (type_bl env empty_rel_context) bl in - let larj = - Array.map2 - (fun e ar -> - pretype_type empty_valcon (push_rel_context e env) evdref lvar ar) - ctxtv lar in - let lara = Array.map (fun a -> a.utj_val) larj in - let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in - let nbfix = Array.length lar in - let names = Array.map (fun id -> Name id) names in - let _ = - match tycon with - | Some t -> - let fixi = match fixkind with - | GFix (vn,i) -> i - | GCoFix i -> i - in e_conv env evdref ftys.(fixi) t - | None -> true - in - (* Note: bodies are not used by push_rec_types, so [||] is safe *) - let newenv = push_rec_types (names,ftys,[||]) env in - let vdefj = - Array.map2_i - (fun i ctxt def -> + let rec type_bl env ctxt = function + [] -> ctxt + | (na,bk,None,ty)::bl -> + let ty' = pretype_type empty_valcon env evdref lvar ty in + let dcl = (na,None,ty'.utj_val) in + type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl + | (na,bk,Some bd,ty)::bl -> + let ty' = pretype_type empty_valcon env evdref lvar ty in + let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar ty in + let dcl = (na,Some bd'.uj_val,ty'.utj_val) in + type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in + let ctxtv = Array.map (type_bl env empty_rel_context) bl in + let larj = + Array.map2 + (fun e ar -> + pretype_type empty_valcon (push_rel_context e env) evdref lvar ar) + ctxtv lar in + let lara = Array.map (fun a -> a.utj_val) larj in + let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in + let nbfix = Array.length lar in + let names = Array.map (fun id -> Name id) names in + let _ = + match tycon with + | Some t -> + let fixi = match fixkind with + | GFix (vn,i) -> i + | GCoFix i -> i + in e_conv env evdref ftys.(fixi) t + | None -> true + in + (* Note: bodies are not used by push_rec_types, so [||] is safe *) + let newenv = push_rec_types (names,ftys,[||]) env in + let vdefj = + Array.map2_i + (fun i ctxt def -> (* we lift nbfix times the type in tycon, because of * the nbfix variables pushed to newenv *) - let (ctxt,ty) = - decompose_prod_n_assum (rel_context_length ctxt) - (lift nbfix ftys.(i)) in - let nenv = push_rel_context ctxt newenv in - let j = pretype (mk_tycon ty) nenv evdref lvar def in - { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; - uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) - ctxtv vdef in - evar_type_fixpoint loc env evdref names ftys vdefj; - let ftys = Array.map (nf_evar !evdref) ftys in - let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in - let fixj = match fixkind with - | GFix (vn,i) -> + let (ctxt,ty) = + decompose_prod_n_assum (rel_context_length ctxt) + (lift nbfix ftys.(i)) in + let nenv = push_rel_context ctxt newenv in + let j = pretype (mk_tycon ty) nenv evdref lvar def in + { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; + uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) + ctxtv vdef in + evar_type_fixpoint loc env evdref names ftys vdefj; + let ftys = Array.map (nf_evar !evdref) ftys in + let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in + let fixj = match fixkind with + | GFix (vn,i) -> (* First, let's find the guard indexes. *) (* If recursive argument was not given by user, we try all args. An earlier approach was to look only for inductive arguments, but doing it properly involves delta-reduction, and it finally doesn't seem worth the effort (except for huge mutual fixpoints ?) *) - let possible_indexes = - Array.to_list (Array.mapi - (fun i (n,_) -> match n with - | Some n -> [n] - | None -> List.map_i (fun i _ -> i) 0 ctxtv.(i)) - vn) - in - let fixdecls = (names,ftys,fdefs) in - let indexes = search_guard loc env possible_indexes fixdecls in - make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) - | GCoFix i -> - let cofix = (i,(names,ftys,fdefs)) in - (try check_cofix env cofix - with reraise -> - let e = Errors.push reraise in Loc.raise loc e); - make_judge (mkCoFix cofix) ftys.(i) - in + let possible_indexes = + Array.to_list (Array.mapi + (fun i (n,_) -> match n with + | Some n -> [n] + | None -> List.map_i (fun i _ -> i) 0 ctxtv.(i)) + vn) + in + let fixdecls = (names,ftys,fdefs) in + let indexes = search_guard loc env possible_indexes fixdecls in + make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) + | GCoFix i -> + let cofix = (i,(names,ftys,fdefs)) in + (try check_cofix env cofix + with reraise -> + let e = Errors.push reraise in Loc.raise loc e); + make_judge (mkCoFix cofix) ftys.(i) + in inh_conv_coerce_to_tycon loc env evdref fixj tycon | GSort (loc,s) -> - let j = pretype_sort evdref s in - inh_conv_coerce_to_tycon loc env evdref j tycon + let j = pretype_sort evdref s in + inh_conv_coerce_to_tycon loc env evdref j tycon + + | GProj (loc, p, arg) -> + let (cst, mind, n, m, ty) = + try get_projection env p + with Not_found -> + user_err_loc (loc,"",str "Not a projection") + in + let mk_ty k = + let ind = + Evarutil.evd_comb1 (Evd.fresh_inductive_instance env) evdref (mind,0) + in + let args = + let ctx = smash_rel_context (Inductiveops.inductive_params_ctxt ind) in + List.fold_right (fun (n, b, ty) (* par *)args -> + let ty = substl args ty in + let ev = e_new_evar evdref env ~src:(loc,k) ty in + ev :: args) ctx [] + (* let j = pretype (mk_tycon ty) env evdref lvar par in *) + (* j.uj_val :: args) ctx pars [] *) + in (ind, List.rev args) + in + let argtycon = + match arg with + (** FIXME ? *) + | GHole (loc, k, _) -> (* Typeclass projection application: + create the necessary type constraint *) + let ind, args = mk_ty k in + mk_tycon (applist (mkIndU ind, args)) + | _ -> empty_tycon + in + let recty = pretype argtycon env evdref lvar arg in + let recty, ((ind,u), pars) = + try + let IndType (indf, _ (*[]*)) = + find_rectype env !evdref recty.uj_type + in recty, dest_ind_family indf + with Not_found -> + (match argtycon with + | Some ty -> assert false + (* let IndType (indf, _) = find_rectype env !evdref ty in *) + (* recty, dest_ind_family indf *) + | None -> + let ind, args = mk_ty Evar_kinds.InternalHole in + let j' = + inh_conv_coerce_to_tycon loc env evdref recty + (mk_tycon (applist (mkIndU ind, args))) in + j', (ind, args)) + in + let usubst = make_inductive_subst (fst (lookup_mind_specif env ind)) u in + let ty = Vars.subst_univs_constr usubst ty in + let ty = substl (recty.uj_val :: List.rev pars) ty in + let j = {uj_val = mkProj (cst,recty.uj_val); uj_type = ty} in + inh_conv_coerce_to_tycon loc env evdref j tycon | GApp (loc,f,args) -> - let fj = pretype empty_tycon env evdref lvar f in - let floc = loc_of_glob_constr f in - let length = List.length args in - let candargs = + let fj = pretype empty_tycon env evdref lvar f in + let floc = loc_of_glob_constr f in + let length = List.length args in + let candargs = (* Bidirectional typechecking hint: parameters of a constructor are completely determined by a typing constraint *) - if Flags.is_program_mode () && length > 0 && isConstruct fj.uj_val then - match tycon with - | None -> [] - | Some ty -> - let (ind, i) = destConstruct fj.uj_val in - let npars = inductive_nparams ind in - if Int.equal npars 0 then [] - else - try - (* Does not treat partially applied constructors. *) - let ty = evd_comb1 (Coercion.inh_coerce_to_prod loc env) evdref ty in - let IndType (indf, args) = find_rectype env !evdref ty in - let (ind',pars) = dest_ind_family indf in - if eq_ind ind ind' then pars - else (* Let the usual code throw an error *) [] - with Not_found -> [] - else [] - in - let rec apply_rec env n resj candargs = function - | [] -> resj - | c::rest -> - let argloc = loc_of_glob_constr c in - let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env) evdref resj in - let resty = whd_betadeltaiota env !evdref resj.uj_type in - match kind_of_term resty with - | Prod (na,c1,c2) -> - let hj = pretype (mk_tycon c1) env evdref lvar c in - let candargs, ujval = - match candargs with - | [] -> [], j_val hj - | arg :: args -> - if e_conv env evdref (j_val hj) arg then - args, nf_evar !evdref (j_val hj) - else [], j_val hj - in - let value, typ = applist (j_val resj, [ujval]), subst1 ujval c2 in - apply_rec env (n+1) - { uj_val = value; - uj_type = typ } - candargs rest - - | _ -> - let hj = pretype empty_tycon env evdref lvar c in - error_cant_apply_not_functional_loc - (Loc.merge floc argloc) env !evdref - resj [hj] - in - let resj = apply_rec env 1 fj candargs args in - let resj = - match evar_kind_of_term !evdref resj.uj_val with - | App (f,args) -> - let f = whd_evar !evdref f in - begin match kind_of_term f with - | Ind _ | Const _ - when isInd f || has_polymorphic_type (destConst f) - -> - let sigma = !evdref in - let c = mkApp (f,Array.map (whd_evar sigma) args) in - let t = Retyping.get_type_of env sigma c in - make_judge c (* use this for keeping evars: resj.uj_val *) t - | _ -> resj end - | _ -> resj in - inh_conv_coerce_to_tycon loc env evdref resj tycon + if Flags.is_program_mode () && length > 0 && isConstruct fj.uj_val then + match tycon with + | None -> [] + | Some ty -> + let ((ind, i), u) = destConstruct fj.uj_val in + let npars = inductive_nparams ind in + if Int.equal npars 0 then [] + else + try + let ty = evd_comb1 (Coercion.inh_coerce_to_prod loc env) evdref ty in + let IndType (indf, args) = find_rectype env !evdref ty in + let ((ind',u'),pars) = dest_ind_family indf in + if eq_ind ind ind' then pars + else (* Let the usual code throw an error *) [] + with Not_found -> [] + else [] + in + let rec apply_rec env n resj candargs = function + | [] -> resj + | c::rest -> + let argloc = loc_of_glob_constr c in + let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env) evdref resj in + let resty = whd_betadeltaiota env !evdref resj.uj_type in + match kind_of_term resty with + | Prod (na,c1,c2) -> + let hj = pretype (mk_tycon c1) env evdref lvar c in + let candargs, ujval = + match candargs with + | [] -> [], j_val hj + | arg :: args -> + if e_conv env evdref (j_val hj) arg then + args, nf_evar !evdref (j_val hj) + else [], j_val hj + in + let value, typ = applist (j_val resj, [ujval]), subst1 ujval c2 in + apply_rec env (n+1) + { uj_val = value; + uj_type = typ } + candargs rest + + | _ -> + let hj = pretype empty_tycon env evdref lvar c in + error_cant_apply_not_functional_loc + (Loc.merge floc argloc) env !evdref + resj [hj] + in + let resj = apply_rec env 1 fj candargs args in + inh_conv_coerce_to_tycon loc env evdref resj tycon | GLambda(loc,name,bk,c1,c2) -> - let tycon' = evd_comb1 - (fun evd tycon -> - match tycon with - | None -> evd, tycon - | Some ty -> - let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in - evd, Some ty') - evdref tycon - in - let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in - let dom_valcon = valcon_of_tycon dom in - let j = pretype_type dom_valcon env evdref lvar c1 in - let var = (name,None,j.utj_val) in - let j' = pretype rng (push_rel var env) evdref lvar c2 in - let resj = judge_of_abstraction env (orelse_name name name') j j' in - inh_conv_coerce_to_tycon loc env evdref resj tycon + let tycon' = evd_comb1 + (fun evd tycon -> + match tycon with + | None -> evd, tycon + | Some ty -> + let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in + evd, Some ty') + evdref tycon + in + let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in + let dom_valcon = valcon_of_tycon dom in + let j = pretype_type dom_valcon env evdref lvar c1 in + let var = (name,None,j.utj_val) in + let j' = pretype rng (push_rel var env) evdref lvar c2 in + let resj = judge_of_abstraction env (orelse_name name name') j j' in + inh_conv_coerce_to_tycon loc env evdref resj tycon | GProd(loc,name,bk,c1,c2) -> - let j = pretype_type empty_valcon env evdref lvar c1 in - let j' = match name with + let j = pretype_type empty_valcon env evdref lvar c1 in + let j' = match name with | Anonymous -> let j = pretype_type empty_valcon env evdref lvar c2 in { j with utj_val = lift 1 j.utj_val } @@ -527,212 +575,208 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t = let var = (name,j.utj_val) in let env' = push_rel_assum var env in pretype_type empty_valcon env' evdref lvar c2 - in - let resj = - try judge_of_product env name j j' - with TypeError _ as e -> let e = Errors.push e in Loc.raise loc e in - inh_conv_coerce_to_tycon loc env evdref resj tycon + in + let resj = + try judge_of_product env name j j' + with TypeError _ as e -> let e = Errors.push e in Loc.raise loc e in + inh_conv_coerce_to_tycon loc env evdref resj tycon | GLetIn(loc,name,c1,c2) -> - let j = - match c1 with - | GCast (loc, c, CastConv t) -> - let tj = pretype_type empty_valcon env evdref lvar t in - pretype (mk_tycon tj.utj_val) env evdref lvar c - | _ -> pretype empty_tycon env evdref lvar c1 - in - let t = refresh_universes j.uj_type in - let var = (name,Some j.uj_val,t) in - let tycon = lift_tycon 1 tycon in - let j' = pretype tycon (push_rel var env) evdref lvar c2 in - { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; - uj_type = subst1 j.uj_val j'.uj_type } + let j = + match c1 with + | GCast (loc, c, CastConv t) -> + let tj = pretype_type empty_valcon env evdref lvar t in + pretype (mk_tycon tj.utj_val) env evdref lvar c + | _ -> pretype empty_tycon env evdref lvar c1 + in + let t = j.uj_type in + let var = (name,Some j.uj_val,t) in + let tycon = lift_tycon 1 tycon in + let j' = pretype tycon (push_rel var env) evdref lvar c2 in + { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; + uj_type = subst1 j.uj_val j'.uj_type } | GLetTuple (loc,nal,(na,po),c,d) -> - let cj = pretype empty_tycon env evdref lvar c in - let (IndType (indf,realargs)) = - try find_rectype env !evdref cj.uj_type - with Not_found -> - let cloc = loc_of_glob_constr c in - error_case_not_inductive_loc cloc env !evdref cj - in - let cstrs = get_constructors env indf in - if not (Int.equal (Array.length cstrs) 1) then - user_err_loc (loc,"",str "Destructing let is only for inductive types" ++ - str " with one constructor."); - let cs = cstrs.(0) in - if not (Int.equal (List.length nal) cs.cs_nargs) then - user_err_loc (loc,"", str "Destructing let on this type expects " ++ - int cs.cs_nargs ++ str " variables."); - let fsign = List.map2 (fun na (_,c,t) -> (na,c,t)) - (List.rev nal) cs.cs_args in - let env_f = push_rel_context fsign env in - (* Make dependencies from arity signature impossible *) - let arsgn = - let arsgn,_ = get_arity env indf in - if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn - else arsgn - in - let psign = (na,None,build_dependent_inductive env indf)::arsgn in - let nar = List.length arsgn in - (match po with - | Some p -> - let env_p = push_rel_context psign env in - let pj = pretype_type empty_valcon env_p evdref lvar p in - let ccl = nf_evar !evdref pj.utj_val in - let psign = make_arity_signature env true indf in (* with names *) - let p = it_mkLambda_or_LetIn ccl psign in - let inst = - (Array.to_list cs.cs_concl_realargs) - @[build_dependent_constructor cs] in - let lp = lift cs.cs_nargs p in - let fty = hnf_lam_applist env !evdref lp inst in - let fj = pretype (mk_tycon fty) env_f evdref lvar d in - let f = it_mkLambda_or_LetIn fj.uj_val fsign in - let v = - let ind,_ = dest_ind_family indf in - let ci = make_case_info env ind LetStyle in - Typing.check_allowed_sort env !evdref ind cj.uj_val p; - mkCase (ci, p, cj.uj_val,[|f|]) in - { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } - - | None -> - let tycon = lift_tycon cs.cs_nargs tycon in - let fj = pretype tycon env_f evdref lvar d in - let f = it_mkLambda_or_LetIn fj.uj_val fsign in - let ccl = nf_evar !evdref fj.uj_type in - let ccl = - if noccur_between 1 cs.cs_nargs ccl then - lift (- cs.cs_nargs) ccl - else - error_cant_find_case_type_loc loc env !evdref - cj.uj_val in - let ccl = refresh_universes ccl in - let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in - let v = - let ind,_ = dest_ind_family indf in - let ci = make_case_info env ind LetStyle in - Typing.check_allowed_sort env !evdref ind cj.uj_val p; - mkCase (ci, p, cj.uj_val,[|f|]) - in { uj_val = v; uj_type = ccl }) - - | GIf (loc,c,(na,po),b1,b2) -> - let cj = pretype empty_tycon env evdref lvar c in - let (IndType (indf,realargs)) = - try find_rectype env !evdref cj.uj_type - with Not_found -> - let cloc = loc_of_glob_constr c in - error_case_not_inductive_loc cloc env !evdref cj in - let cstrs = get_constructors env indf in - if not (Int.equal (Array.length cstrs) 2) then - user_err_loc (loc,"", - str "If is only for inductive types with two constructors."); - + let cj = pretype empty_tycon env evdref lvar c in + let (IndType (indf,realargs)) = + try find_rectype env !evdref cj.uj_type + with Not_found -> + let cloc = loc_of_glob_constr c in + error_case_not_inductive_loc cloc env !evdref cj + in + let cstrs = get_constructors env indf in + if not (Int.equal (Array.length cstrs) 1) then + user_err_loc (loc,"",str "Destructing let is only for inductive types" ++ + str " with one constructor."); + let cs = cstrs.(0) in + if not (Int.equal (List.length nal) cs.cs_nargs) then + user_err_loc (loc,"", str "Destructing let on this type expects " ++ + int cs.cs_nargs ++ str " variables."); + let fsign = List.map2 (fun na (_,c,t) -> (na,c,t)) + (List.rev nal) cs.cs_args in + let env_f = push_rel_context fsign env in + (* Make dependencies from arity signature impossible *) let arsgn = let arsgn,_ = get_arity env indf in if not !allow_anonymous_refs then - (* Make dependencies from arity signature impossible *) List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn else arsgn in - let nar = List.length arsgn in let psign = (na,None,build_dependent_inductive env indf)::arsgn in - let pred,p = match po with + let nar = List.length arsgn in + (match po with | Some p -> - let env_p = push_rel_context psign env in - let pj = pretype_type empty_valcon env_p evdref lvar p in - let ccl = nf_evar !evdref pj.utj_val in - let pred = it_mkLambda_or_LetIn ccl psign in - let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in - pred, typ + let env_p = push_rel_context psign env in + let pj = pretype_type empty_valcon env_p evdref lvar p in + let ccl = nf_evar !evdref pj.utj_val in + let psign = make_arity_signature env true indf in (* with names *) + let p = it_mkLambda_or_LetIn ccl psign in + let inst = + (Array.to_list cs.cs_concl_realargs) + @[build_dependent_constructor cs] in + let lp = lift cs.cs_nargs p in + let fty = hnf_lam_applist env !evdref lp inst in + let fj = pretype (mk_tycon fty) env_f evdref lvar d in + let f = it_mkLambda_or_LetIn fj.uj_val fsign in + let v = + let ind,_ = dest_ind_family indf in + let ci = make_case_info env (fst ind) LetStyle in + Typing.check_allowed_sort env !evdref ind cj.uj_val p; + mkCase (ci, p, cj.uj_val,[|f|]) in + { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } + | None -> - let p = match tycon with - | Some ty -> ty - | None -> new_type_evar evdref env loc - in - it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in - let pred = nf_evar !evdref pred in - let p = nf_evar !evdref p in - let f cs b = - let n = rel_context_length cs.cs_args in - let pi = lift n pred in (* liftn n 2 pred ? *) - let pi = beta_applist (pi, [build_dependent_constructor cs]) in - let csgn = - if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args - else - List.map - (fun (n, b, t) -> - match n with - Name _ -> (n, b, t) - | Anonymous -> (Name (Id.of_string "H"), b, t)) - cs.cs_args + let tycon = lift_tycon cs.cs_nargs tycon in + let fj = pretype tycon env_f evdref lvar d in + let f = it_mkLambda_or_LetIn fj.uj_val fsign in + let ccl = nf_evar !evdref fj.uj_type in + let ccl = + if noccur_between 1 cs.cs_nargs ccl then + lift (- cs.cs_nargs) ccl + else + error_cant_find_case_type_loc loc env !evdref + cj.uj_val in + (* let ccl = refresh_universes ccl in *) + let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in + let v = + let ind,_ = dest_ind_family indf in + let ci = make_case_info env (fst ind) LetStyle in + Typing.check_allowed_sort env !evdref ind cj.uj_val p; + mkCase (ci, p, cj.uj_val,[|f|]) + in { uj_val = v; uj_type = ccl }) + + | GIf (loc,c,(na,po),b1,b2) -> + let cj = pretype empty_tycon env evdref lvar c in + let (IndType (indf,realargs)) = + try find_rectype env !evdref cj.uj_type + with Not_found -> + let cloc = loc_of_glob_constr c in + error_case_not_inductive_loc cloc env !evdref cj in + let cstrs = get_constructors env indf in + if not (Int.equal (Array.length cstrs) 2) then + user_err_loc (loc,"", + str "If is only for inductive types with two constructors."); + + let arsgn = + let arsgn,_ = get_arity env indf in + if not !allow_anonymous_refs then + (* Make dependencies from arity signature impossible *) + List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn + else arsgn + in + let nar = List.length arsgn in + let psign = (na,None,build_dependent_inductive env indf)::arsgn in + let pred,p = match po with + | Some p -> + let env_p = push_rel_context psign env in + let pj = pretype_type empty_valcon env_p evdref lvar p in + let ccl = nf_evar !evdref pj.utj_val in + let pred = it_mkLambda_or_LetIn ccl psign in + let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in + pred, typ + | None -> + let p = match tycon with + | Some ty -> ty + | None -> new_type_evar evdref env loc in - let env_c = push_rel_context csgn env in - let bj = pretype (mk_tycon pi) env_c evdref lvar b in - it_mkLambda_or_LetIn bj.uj_val cs.cs_args in - let b1 = f cstrs.(0) b1 in - let b2 = f cstrs.(1) b2 in - let v = - let ind,_ = dest_ind_family indf in - let ci = make_case_info env ind IfStyle in - let pred = nf_evar !evdref pred in - Typing.check_allowed_sort env !evdref ind cj.uj_val pred; - mkCase (ci, pred, cj.uj_val, [|b1;b2|]) + it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in + let pred = nf_evar !evdref pred in + let p = nf_evar !evdref p in + let f cs b = + let n = rel_context_length cs.cs_args in + let pi = lift n pred in (* liftn n 2 pred ? *) + let pi = beta_applist (pi, [build_dependent_constructor cs]) in + let csgn = + if not !allow_anonymous_refs then + List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args + else + List.map + (fun (n, b, t) -> + match n with + Name _ -> (n, b, t) + | Anonymous -> (Name (Id.of_string "H"), b, t)) + cs.cs_args in - { uj_val = v; uj_type = p } + let env_c = push_rel_context csgn env in + let bj = pretype (mk_tycon pi) env_c evdref lvar b in + it_mkLambda_or_LetIn bj.uj_val cs.cs_args in + let b1 = f cstrs.(0) b1 in + let b2 = f cstrs.(1) b2 in + let v = + let ind,_ = dest_ind_family indf in + let ci = make_case_info env (fst ind) IfStyle in + let pred = nf_evar !evdref pred in + Typing.check_allowed_sort env !evdref ind cj.uj_val pred; + mkCase (ci, pred, cj.uj_val, [|b1;b2|]) + in + { uj_val = v; uj_type = p } | GCases (loc,sty,po,tml,eqns) -> - Cases.compile_cases loc sty - ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref) - tycon env (* loc *) (po,tml,eqns) + Cases.compile_cases loc sty + ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref) + tycon env (* loc *) (po,tml,eqns) | GCast (loc,c,k) -> - let cj = - match k with - | CastCoerce -> - let cj = pretype empty_tycon env evdref lvar c in - evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj - | CastConv t | CastVM t | CastNative t -> - let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in - let tj = pretype_type empty_valcon env evdref lvar t in - let tval = nf_evar !evdref tj.utj_val in - let cj = match k with - | VMcast -> - let cj = pretype empty_tycon env evdref lvar c in - let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in - if not (occur_existential cty || occur_existential tval) then - begin - try - ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj - with Reduction.NotConvertible -> - error_actual_type_loc loc env !evdref cj tval - (ConversionFailed (env,cty,tval)) - end - else user_err_loc (loc,"",str "Cannot check cast with vm: " ++ - str "unresolved arguments remain.") - | NATIVEcast -> - let cj = pretype empty_tycon env evdref lvar c in - let cty = nf_evar !evdref cj.uj_type and - tval = nf_evar !evdref tj.utj_val in - let evars = Nativenorm.evars_of_evar_map !evdref in - begin - try - ignore - (Nativeconv.native_conv Reduction.CUMUL evars env cty tval); - cj - with Reduction.NotConvertible -> - error_actual_type_loc loc env !evdref cj tval + let cj = + match k with + | CastCoerce -> + let cj = pretype empty_tycon env evdref lvar c in + evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj + | CastConv t | CastVM t | CastNative t -> + let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in + let tj = pretype_type empty_valcon env evdref lvar t in + let tval = nf_evar !evdref tj.utj_val in + let cj = match k with + | VMcast -> + let cj = pretype empty_tycon env evdref lvar c in + let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in + if not (occur_existential cty || occur_existential tval) then + begin + try + ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj + with Reduction.NotConvertible -> + error_actual_type_loc loc env !evdref cj tval + (ConversionFailed (env,cty,tval)) + end + else user_err_loc (loc,"",str "Cannot check cast with vm: " ++ + str "unresolved arguments remain.") + | NATIVEcast -> + let cj = pretype empty_tycon env evdref lvar c in + let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in + let evars = Nativenorm.evars_of_evar_map !evdref in + begin + try + ignore (Nativeconv.native_conv Reduction.CUMUL evars env cty tval); cj + with Reduction.NotConvertible -> + error_actual_type_loc loc env !evdref cj tval (ConversionFailed (env,cty,tval)) - end - - | _ -> - pretype (mk_tycon tval) env evdref lvar c - in - let v = mkCast (cj.uj_val, k, tval) in - { uj_val = v; uj_type = tval } - in inh_conv_coerce_to_tycon loc env evdref cj tycon + end + | _ -> + pretype (mk_tycon tval) env evdref lvar c + in + let v = mkCast (cj.uj_val, k, tval) in + { uj_val = v; uj_type = tval } + in inh_conv_coerce_to_tycon loc env evdref cj tycon (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *) and pretype_type resolve_tc valcon env evdref lvar = function @@ -751,7 +795,7 @@ and pretype_type resolve_tc valcon env evdref lvar = function { utj_val = v; utj_type = s } | None -> - let s = evd_comb0 new_sort_variable evdref in + let s = evd_comb0 (new_sort_variable univ_flexible_alg) evdref in { utj_val = e_new_evar evdref env ~src:(loc, knd) (mkSort s); utj_type = s}) | c -> @@ -778,11 +822,6 @@ let ise_pretype_gen flags sigma env lvar kind c = in process_inference_flags flags env sigma (!evdref,c') -(* TODO: comment faire remonter l'information si le typage a resolu des - variables du sigma original. il faudrait que la fonction de typage - retourne aussi le nouveau sigma... -*) - let default_inference_flags fail = { use_typeclasses = true; use_unif_heuristics = true; @@ -810,8 +849,10 @@ let on_judgment f j = let understand_judgment sigma env c = let evdref = ref sigma in let j = pretype true empty_tycon env evdref empty_lvar c in - on_judgment (fun c -> - snd (process_inference_flags all_and_fail_flags env sigma (!evdref,c))) j + let j = on_judgment (fun c -> + let evd, c = process_inference_flags all_and_fail_flags env sigma (!evdref,c) in + evdref := evd; c) j + in j, Evd.evar_universe_context !evdref let understand_judgment_tcc evdref env c = let j = pretype true empty_tycon env evdref empty_lvar c in @@ -819,13 +860,18 @@ let understand_judgment_tcc evdref env c = let (evd,c) = process_inference_flags all_no_fail_flags env Evd.empty (!evdref,c) in evdref := evd; c) j +let ise_pretype_gen_ctx flags sigma env lvar kind c = + let evd, c = ise_pretype_gen flags sigma env lvar kind c in + let evd, f = Evarutil.nf_evars_and_universes evd in + f c, Evd.get_universe_context_set evd + (** Entry points of the high-level type synthesis algorithm *) let understand ?(flags=all_and_fail_flags) ?(expected_type=WithoutTypeConstraint) sigma env c = - snd (ise_pretype_gen flags sigma env empty_lvar expected_type c) + ise_pretype_gen_ctx flags sigma env empty_lvar expected_type c let understand_tcc ?(flags=all_no_fail_flags) sigma env ?(expected_type=WithoutTypeConstraint) c = ise_pretype_gen flags sigma env empty_lvar expected_type c diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index ec8aae1403..79b0518451 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -81,14 +81,16 @@ val understand_ltac : inference_flags -> (** Standard call to get a constr from a glob_constr, resolving implicit args *) val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> - evar_map -> env -> glob_constr -> constr + evar_map -> env -> glob_constr -> constr Univ.in_universe_context_set (** Idem but returns the judgment of the understood term *) -val understand_judgment : evar_map -> env -> glob_constr -> unsafe_judgment +val understand_judgment : evar_map -> env -> + glob_constr -> unsafe_judgment Evd.in_evar_universe_context (** Idem but do not fail on unresolved evars *) -val understand_judgment_tcc : evar_map ref -> env -> glob_constr -> unsafe_judgment +val understand_judgment_tcc : evar_map ref -> env -> + glob_constr -> unsafe_judgment (** Trying to solve remaining evars and remaining conversion problems with type classes, heuristics, and possibly an external solver *) @@ -122,7 +124,7 @@ val ise_pretype_gen : val constr_in : constr -> Dyn.t val constr_out : Dyn.t -> constr -val interp_sort : glob_sort -> sorts +val interp_sort : evar_map -> glob_sort -> evar_map * sorts val interp_elimination_sort : glob_sort -> sorts_family val genarg_interp_hook : diff --git a/pretyping/program.ml b/pretyping/program.ml index 6d913060b1..67bb3bd2a7 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -21,7 +21,7 @@ let find_reference locstr dir s = anomaly ~label:locstr (Pp.str "cannot find" ++ spc () ++ Libnames.pr_path sp) let coq_reference locstr dir s = find_reference locstr ("Coq"::dir) s -let coq_constant locstr dir s = Globnames.constr_of_global (coq_reference locstr dir s) +let coq_constant locstr dir s = Universes.constr_of_global (coq_reference locstr dir s) let init_constant dir s () = coq_constant "Program" dir s let init_reference dir s () = coq_reference "Program" dir s diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 9f8ba956a9..967583a2b4 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -63,12 +63,12 @@ let cache_structure o = load_structure 1 o let subst_structure (subst,((kn,i),id,kl,projs as obj)) = - let kn' = subst_ind subst kn in + let kn' = subst_mind subst kn in let projs' = (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) List.smartmap - (Option.smartmap (fun kn -> fst (subst_con subst kn))) + (Option.smartmap (fun kn -> fst (subst_con_kn subst kn))) projs in let id' = fst (subst_constructor subst id) in @@ -132,6 +132,7 @@ that maps the pair (Li,ci) to the following data type obj_typ = { o_DEF : constr; + o_CTX : Univ.ContextSet.t; o_INJ : int; (* position of trivial argument (negative= none) *) o_TABS : constr list; (* ordered *) o_TPARAMS : constr list; (* ordered *) @@ -189,9 +190,13 @@ let cs_pattern_of_constr t = (* Intended to always succeed *) let compute_canonical_projections (con,ind) = - let v = mkConst con in - let c = Environ.constant_value (Global.env()) con in - let lt,t = Reductionops.splay_lam (Global.env()) Evd.empty c in + let env = Global.env () in + let ctx = Environ.constant_context env con in + let u = Univ.UContext.instance ctx in + let v = (mkConstU (con,u)) in + let ctx = Univ.ContextSet.of_context ctx in + let c = Environ.constant_value_in env (con,u) in + let lt,t = Reductionops.splay_lam env Evd.empty c in let lt = List.rev_map snd lt in let args = snd (decompose_app t) in let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = @@ -221,7 +226,7 @@ let compute_canonical_projections (con,ind) = [] lps in List.map (fun (refi,c,inj,argj) -> (refi,c), - {o_DEF=v; o_INJ=inj; o_TABS=lt; + {o_DEF=v; o_CTX=ctx; o_INJ=inj; o_TABS=lt; o_TPARAMS=params; o_NPARAMS=List.length params; o_TCOMPS=argj}) comp @@ -256,8 +261,8 @@ let cache_canonical_structure o = let subst_canonical_structure (subst,(cst,ind as obj)) = (* invariant: cst is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) - let cst' = fst (subst_con subst cst) in - let ind' = Inductiveops.subst_inductive subst ind in + let cst' = subst_constant subst cst in + let ind' = subst_ind subst ind in if cst' == cst && ind' == ind then obj else (cst',ind') let discharge_canonical_structure (_,(cst,ind)) = @@ -282,7 +287,9 @@ let error_not_structure ref = let check_and_decompose_canonical_structure ref = let sp = match ref with ConstRef sp -> sp | _ -> error_not_structure ref in let env = Global.env () in - let vc = match Environ.constant_opt_value env sp with + let ctx = Environ.constant_context env sp in + let u = Univ.UContext.instance ctx in + let vc = match Environ.constant_opt_value_in env (sp, u) with | Some vc -> vc | None -> error_not_structure ref in let body = snd (splay_lam (Global.env()) Evd.empty vc) in @@ -290,7 +297,7 @@ let check_and_decompose_canonical_structure ref = | App (f,args) -> f,args | _ -> error_not_structure ref in let indsp = match kind_of_term f with - | Construct (indsp,1) -> indsp + | Construct ((indsp,1),u) -> indsp | _ -> error_not_structure ref in let s = try lookup_structure indsp with Not_found -> error_not_structure ref in let ntrue_projs = List.length (List.filter (fun (_, x) -> x) s.s_PROJKIND) in @@ -304,6 +311,9 @@ let declare_canonical_structure ref = let lookup_canonical_conversion (proj,pat) = List.assoc_f eq_cs_pattern pat (Refmap.find proj !object_table) + (* let cst, u' = destConst cs.o_DEF in *) + (* { cs with o_DEF = mkConstU (cst, u) } *) + let is_open_canonical_projection env sigma (c,args) = try let n = find_projection_nparams (global_of_constr c) in diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 42663c0144..b1763a359e 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -56,6 +56,7 @@ type cs_pattern = type obj_typ = { o_DEF : constr; + o_CTX : Univ.ContextSet.t; o_INJ : int; (** position of trivial argument *) o_TABS : constr list; (** ordered *) o_TPARAMS : constr list; (** ordered *) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 0b6c3197d0..676fc4f3ad 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -61,7 +61,7 @@ module ReductionBehaviour = struct let discharge = function | _,(ReqGlobal (ConstRef c, req), (_, b)) -> let c' = pop_con c in - let vars = Lib.section_segment_of_constant c in + let vars, _ctx = Lib.section_segment_of_constant c in let extra = List.length vars in let nargs' = if b.b_nargs < 0 then b.b_nargs else b.b_nargs + extra in let recargs' = List.map ((+) extra) b.b_recargs in @@ -142,6 +142,7 @@ sig type 'a member = | App of 'a app_node | Case of case_info * 'a * 'a array * ('a * 'a list) option + | Proj of int * int * projection | Fix of fixpoint * 'a t * ('a * 'a list) option | Shift of int | Update of 'a @@ -186,6 +187,7 @@ struct type 'a member = | App of 'a app_node | Case of Term.case_info * 'a * 'a array * ('a * 'a list) option + | Proj of int * int * projection | Fix of fixpoint * 'a t * ('a * 'a list) option | Shift of int | Update of 'a @@ -200,6 +202,9 @@ struct str "ZCase(" ++ prvect_with_sep (pr_bar) pr_c br ++ str ")" + | Proj (n,m,p) -> + str "ZProj(" ++ int n ++ pr_comma () ++ int m ++ + pr_comma () ++ pr_con p ++ str ")" | Fix (f,args,cst) -> str "ZFix(" ++ Termops.pr_fix Termops.print_constr f ++ pr_comma () ++ pr pr_c args ++ str ")" @@ -261,6 +266,8 @@ struct | (_, App (i,_,j)::s2) -> compare_rec (bal - j - 1 + i) stk1 s2 | (Case(c1,_,_,_)::s1, Case(c2,_,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 + | (Proj (n1,m1,p)::s1, Proj(n2,m2,p2)::s2) -> + Int.equal bal 0 && compare_rec 0 s1 s2 | (Fix(_,a1,_)::s1, Fix(_,a2,_)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 | (_,_) -> false in @@ -284,6 +291,9 @@ struct aux (fold_array (f o (Vars.lift lft1 t1) (Vars.lift lft2 t2)) a1 a2) lft1 q1 lft2 q2 + | Proj (n1,m1,p1) :: q1, Proj (n2,m2,p2) :: q2 -> + (* MS: FIXME: unsure *) + aux o lft1 q1 lft2 q2 | Fix ((_,(_,a1,b1)),s1,_) :: q1, Fix ((_,(_,a2,b2)),s2,_) :: q2 -> let (o',_,_) = aux (fold_array (fold_array o b1 b2) a1 a2) lft1 s1 lft2 s2 in @@ -323,7 +333,7 @@ struct in aux n [] s let not_purely_applicative args = - List.exists (function (Fix _ | Case _) -> true | _ -> false) args + List.exists (function (Fix _ | Case _ | Proj _) -> true | _ -> false) args let list_of_app_stack s = let rec aux = function | App (i,a,j) :: s -> @@ -379,6 +389,7 @@ struct | f, (Fix (fix,st,_)::s) -> zip ~refold (mkFix fix, st @ (append_app [|f|] s)) | f, (Shift n::s) -> zip ~refold (lift n f, s) + | f, (Proj (n,m,p)::s) -> zip ~refold (mkProj (p,f),s) | _ -> assert false end @@ -388,6 +399,7 @@ type state = constr * constr Stack.t type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr +type e_reduction_function = env -> evar_map -> constr -> evar_map * constr type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list @@ -527,9 +539,17 @@ let magicaly_constant_of_fixbody env bd = function try let cst = Nametab.locate_constant (Libnames.make_qualid DirPath.empty id) in - match constant_opt_value env cst with + let (cst, u), ctx = Universes.fresh_constant_instance env cst in + match constant_opt_value env (cst,u) with | None -> bd - | Some t -> if eq_constr t bd then mkConst cst else bd + | Some (t,cstrs) -> + let b, csts = eq_constr_universes t bd in + let subst = UniverseConstraints.fold (fun (l,d,r) acc -> + Univ.LMap.add (Option.get (Universe.level l)) (Option.get (Universe.level r)) acc) + csts Univ.LMap.empty + in + let inst = Instance.subst_fn (fun u -> Univ.LMap.find u subst) u in + if b then mkConstU (cst,inst) else bd with | Not_found -> bd @@ -550,7 +570,7 @@ let contract_cofix ?env (bodynum,(names,types,bodies as typedbodies)) cst = let reduce_mind_case mia = match kind_of_term mia.mconstr with - | Construct (ind_sp,i) -> + | Construct ((ind_sp,i),u) -> (* let ncargs = (fst mia.mci).(i-1) in*) let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in applist (mia.mlf.(i-1),real_cargs) @@ -585,6 +605,10 @@ let fix_recarg ((recindices,bodynum),_) stack = with Not_found -> None +type 'a reduced_state = + | NotReducible + | Reduced of constr + (** Generic reduction function with environment Here is where unfolded constant are stored in order to be @@ -625,15 +649,15 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = (match safe_meta_value sigma ev with | Some body -> whrec cst_l (body, stack) | None -> fold ()) - | Const const when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST const) -> - (match constant_opt_value env const with + | Const (c,u as const) when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST c) -> + (match constant_opt_value_in env const with | None -> fold () - | Some body -> + | Some body -> if not tactic_mode - then whrec (Cst_stack.add_cst (mkConst const) cst_l) (body, stack) + then whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack) else (* Looks for ReductionBehaviour *) - match ReductionBehaviour.get (Globnames.ConstRef const) with - | None -> whrec (Cst_stack.add_cst (mkConst const) cst_l) (body, stack) + match ReductionBehaviour.get (Globnames.ConstRef c) with + | None -> whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack) | Some (recargs, nargs, flags) -> if (List.mem `ReductionNeverUnfold flags || (nargs > 0 && Stack.args_size stack < nargs)) @@ -642,7 +666,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = if List.mem `ReductionDontExposeCase flags then let app_sk,sk = Stack.strip_app stack in let (tm',sk'),cst_l' = - whrec (Cst_stack.add_cst (mkConst const) cst_l) (body, app_sk) in + whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, app_sk) in let f_equal (x,lft1) (y,lft2) = Constr.equal (Vars.lift lft1 x) (Vars.lift lft2 y) in if (match Stack.equal f_equal @@ -660,6 +684,11 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = whrec cst_l (body, stack) |l -> failwith "TODO recargs in cbn" ) + | Proj (p, c) when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST p) -> + (match (lookup_constant p env).Declarations.const_proj with + | None -> assert false + | Some pb -> whrec cst_l (c, Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) + :: stack)) | LetIn (_,b,_,c) when Closure.RedFlags.red_set flags Closure.RedFlags.fZETA -> apply_subst whrec [b] cst_l c stack | Cast (c,_,_) -> whrec cst_l (c, stack) @@ -698,11 +727,13 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = |Some (bef,arg,s') -> whrec noth (arg, Stack.Fix(f,bef,Cst_stack.best_cst cst_l)::s')) - | Construct (ind,c) -> + | Construct ((ind,c),u) -> if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then match Stack.strip_app stack with |args, (Stack.Case(ci, _, lf,_)::s') -> whrec noth (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') + |args, (Stack.Proj (n,m,p)::s') -> + whrec noth (Stack.nth args (n+m), s') |args, (Stack.Fix (f,s',cst)::s'') -> let x' = Stack.zip(x,args) in whrec noth ((if tactic_mode then contract_fix ~env f else contract_fix f) cst, @@ -720,7 +751,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = |_ -> fold () else fold () - | Rel _ | Var _ | Const _ | LetIn _ -> fold () + | Rel _ | Var _ | Const _ | LetIn _ | Proj _ -> fold () | Sort _ | Ind _ | Prod _ -> fold () in whrec (Option.default noth csts) @@ -752,6 +783,12 @@ let local_whd_state_gen flags sigma = else s | _ -> s) | _ -> s) + + | Proj (p,c) when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST p) -> + (match (lookup_constant p (Global.env ())).Declarations.const_proj with + | None -> assert false + | Some pb -> whrec (c, Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) + :: stack)) | Case (ci,p,d,lf) -> whrec (d, Stack.Case (ci,p,lf,None) :: stack) @@ -771,14 +808,13 @@ let local_whd_state_gen flags sigma = Some c -> whrec (c,stack) | None -> s) - | Construct (ind,c) -> + | Construct ((ind,c),u) -> if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then match Stack.strip_app stack with |args, (Stack.Case(ci, _, lf,_)::s') -> whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') - |args, (Stack.Fix (f,s',cst)::s'') -> - let x' = Stack.zip(x,args) in - whrec (contract_fix f cst, s' @ (Stack.append_app [|x'|] s'')) + |args, (Stack.Proj (n,m,p) :: s') -> + whrec (Stack.nth args (n+m), s') |_ -> s else s @@ -899,7 +935,18 @@ let rec whd_evar sigma c = (match safe_evar_value sigma ev with Some c -> whd_evar sigma c | None -> c) - | Sort s -> whd_sort_variable sigma c + | Sort (Type u) -> + let u' = Evd.normalize_universe sigma u in + if u' == u then c else mkSort (Type u') + | Const (c', u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkConstU (c', u') + | Ind (i, u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkIndU (i, u') + | Construct (co, u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkConstructU (co, u') | _ -> c let nf_evar = @@ -916,12 +963,13 @@ let clos_norm_flags flgs env sigma t = (Closure.inject t) with e when is_anomaly e -> error "Tried to normalize ill-typed term" -let nf_beta = clos_norm_flags Closure.beta empty_env -let nf_betaiota = clos_norm_flags Closure.betaiota empty_env -let nf_betaiotazeta = clos_norm_flags Closure.betaiotazeta empty_env +let nf_beta = clos_norm_flags Closure.beta (Global.env ()) +let nf_betaiota = clos_norm_flags Closure.betaiota (Global.env ()) +let nf_betaiotazeta = clos_norm_flags Closure.betaiotazeta (Global.env ()) let nf_betadeltaiota env sigma = clos_norm_flags Closure.betadeltaiota env sigma + (********************************************************************) (* Conversion *) (********************************************************************) @@ -948,32 +996,43 @@ let pb_equal = function | Reduction.CUMUL -> Reduction.CONV | Reduction.CONV -> Reduction.CONV -let sort_cmp = Reduction.sort_cmp +let sort_cmp cv_pb s1 s2 u = + ignore(Reduction.sort_cmp_universes cv_pb s1 s2 (u, None)) -let test_conversion (f: ?l2r:bool-> ?evars:'a->'b) env sigma x y = +let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y = try let evars ev = safe_evar_value sigma ev in - let _ = f ~evars env x y in + let _ = f ~evars reds env (Evd.universes sigma) x y in true with Reduction.NotConvertible -> false | e when is_anomaly e -> error "Conversion test raised an anomaly" -let is_conv env sigma = test_conversion Reduction.conv env sigma -let is_conv_leq env sigma = test_conversion Reduction.conv_leq env sigma +let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv_universes reds env sigma +let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq_universes reds env sigma +let is_trans_fconv = function Reduction.CONV -> is_trans_conv | Reduction.CUMUL -> is_trans_conv_leq + +let is_conv = is_trans_conv full_transparent_state +let is_conv_leq = is_trans_conv_leq full_transparent_state let is_fconv = function | Reduction.CONV -> is_conv | Reduction.CUMUL -> is_conv_leq -let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y = - try - let evars ev = safe_evar_value sigma ev in - let _ = f ~evars reds env x y in - true - with Reduction.NotConvertible -> false +let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = + let f = match pb with + | Reduction.CONV -> Reduction.trans_conv_universes + | Reduction.CUMUL -> Reduction.trans_conv_leq_universes in + try f ~evars:(safe_evar_value sigma) ts env (Evd.universes sigma) x y; true + with Reduction.NotConvertible -> false | e when is_anomaly e -> error "Conversion test raised an anomaly" -let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv reds env sigma -let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq reds env sigma -let is_trans_fconv = function | Reduction.CONV -> is_trans_conv | Reduction.CUMUL -> is_trans_conv_leq - +let infer_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = + let f = match pb with + | Reduction.CONV -> Reduction.infer_conv + | Reduction.CUMUL -> Reduction.infer_conv_leq in + try + let cstrs = f ~evars:(safe_evar_value sigma) ~ts env (Evd.universes sigma) x y in + Evd.add_constraints sigma cstrs, true + with Reduction.NotConvertible -> sigma, false + | e when is_anomaly e -> error "Conversion test raised an anomaly" + (********************************************************************) (* Special-Purpose Reduction *) (********************************************************************) @@ -1164,6 +1223,14 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' false (Closure.RedFlags.red_add_transparent betadeltaiota ts) env sigma (t,args) in if isConstruct t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' + |args, (Stack.Proj (n,m,p) :: stack'' as stack') -> + let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' false + (Closure.RedFlags.red_add_transparent betadeltaiota ts) env sigma (t,args) in + if isConstruct t_o then + if Closure.is_transparent_constant ts p then + whrec csts_o (Stack.nth stack_o (n+m), stack'') + else (* Won't unfold *) (whd_betaiota_state sigma (t_o, stack_o@stack'),csts') + else s,csts' |_ -> s,csts' in whrec csts s @@ -1245,6 +1312,17 @@ let meta_reducible_instance evd b = let is_coerce = match s with CoerceToType -> true | _ -> false in if not is_coerce then irec g else u with Not_found -> u) + | Proj (p,c) when isMeta c || isCast c && isMeta (pi1 (destCast c)) -> + let m = try destMeta c with _ -> destMeta (pi1 (destCast c)) in + (match + try + let g, s = Metamap.find m metas in + let is_coerce = match s with CoerceToType -> true | _ -> false in + if isConstruct g || not is_coerce then Some g else None + with Not_found -> None + with + | Some g -> irec (mkProj (p,g)) + | None -> mkProj (p,c)) | _ -> map_constr irec u in if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus @@ -1252,12 +1330,12 @@ let meta_reducible_instance evd b = let head_unfold_under_prod ts env _ c = - let unfold cst = + let unfold (cst,u as cstu) = if Cpred.mem cst (snd ts) then - match constant_opt_value env cst with + match constant_opt_value_in env cstu with | Some c -> c - | None -> mkConst cst - else mkConst cst in + | None -> mkConstU cstu + else mkConstU cstu in let rec aux c = match kind_of_term c with | Prod (n,t,c) -> mkProd (n,aux t, aux c) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 5ba0d74eca..29d7a6b2fe 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -17,7 +17,7 @@ open Environ exception Elimconst -(** Machinery to custom the behavior of the reduction *) +(** Machinery to customize the behavior of the reduction *) module ReductionBehaviour : sig type flag = [ `ReductionDontExposeCase | `ReductionNeverUnfold ] @@ -37,6 +37,7 @@ module Stack : sig type 'a member = | App of 'a app_node | Case of case_info * 'a * 'a array * ('a * 'a list) option + | Proj of int * int * projection | Fix of fixpoint * 'a t * ('a * 'a list) option | Shift of int | Update of 'a @@ -82,6 +83,8 @@ type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr +type e_reduction_function = env -> evar_map -> constr -> evar_map * constr + type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list type stack_reduction_function = contextual_stack_reduction_function @@ -203,6 +206,7 @@ val splay_prod_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_lam_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_prod_assum : env -> evar_map -> constr -> rel_context * constr +val is_sort : env -> evar_map -> types -> bool type 'a miota_args = { mP : constr; (** the result type *) @@ -223,7 +227,7 @@ val contract_fix : ?env:Environ.env -> fixpoint -> val fix_recarg : fixpoint -> constr Stack.t -> (int * constr) option (** {6 Querying the kernel conversion oracle: opaque/transparent constants } *) -val is_transparent : Environ.env -> 'a tableKey -> bool +val is_transparent : Environ.env -> constant tableKey -> bool (** {6 Conversion Functions (uses closures, lazy strategy) } *) @@ -232,7 +236,7 @@ type conversion_test = constraints -> constraints val pb_is_equal : conv_pb -> bool val pb_equal : conv_pb -> conv_pb -val sort_cmp : conv_pb -> sorts -> sorts -> conversion_test +val sort_cmp : conv_pb -> sorts -> sorts -> universes -> unit val is_conv : env -> evar_map -> constr -> constr -> bool val is_conv_leq : env -> evar_map -> constr -> constr -> bool @@ -242,6 +246,17 @@ val is_trans_conv : transparent_state -> env -> evar_map -> constr -> constr -> val is_trans_conv_leq : transparent_state -> env -> evar_map -> constr -> constr -> bool val is_trans_fconv : conv_pb -> transparent_state -> env -> evar_map -> constr -> constr -> bool +(** [check_conv} Checks universe constraints only. + pb defaults to CUMUL and ts to a full transparent state. + *) +val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> bool + +(** [infer_fconv] Adds necessary universe constraints to the evar map. + pb defaults to CUMUL and ts to a full transparent state. + *) +val infer_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> + evar_map * bool + (** {6 Special-Purpose Reduction Functions } *) val whd_meta : evar_map -> constr -> constr diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index c66ca7ac1d..31487125ad 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -85,9 +85,10 @@ let type_of_var env id = try let (_,_,ty) = lookup_named id env in ty with Not_found -> retype_error (BadVariable id) -let is_impredicative_set env = match Environ.engagement env with -| Some ImpredicativeSet -> true -| _ -> false +let decomp_sort env sigma t = + match kind_of_term (whd_betadeltaiota env sigma t) with + | Sort s -> s + | _ -> retype_error NotASort let retype ?(polyprop=true) sigma = let rec type_of env cstr= @@ -99,7 +100,7 @@ let retype ?(polyprop=true) sigma = let (_,_,ty) = lookup_rel n env in lift n ty | Var id -> type_of_var env id - | Const cst -> Typeops.type_of_constant env cst + | Const cst -> Typeops.type_of_constant_in env cst | Evar ev -> Evd.existential_type sigma ev | Ind ind -> type_of_inductive env ind | Construct cstr -> type_of_constructor env cstr @@ -129,6 +130,13 @@ let retype ?(polyprop=true) sigma = | App(f,args) -> strip_outer_cast (subst_type env sigma (type_of env f) (Array.to_list args)) + | Proj (p,c) -> + let Inductiveops.IndType(pars,realargs) = + try Inductiveops.find_rectype env sigma (type_of env c) + with Not_found -> anomaly ~label:"type_of" (str "Bad recursive type") + in + let (_,u), pars = dest_ind_family pars in + substl (c :: List.rev pars) (Typeops.type_of_projection env (p,u)) | Cast (c,_, t) -> t | Sort _ | Prod _ -> mkSort (sort_of env cstr) @@ -142,15 +150,13 @@ let retype ?(polyprop=true) sigma = | _, (Prop Null as s) -> s | Prop _, (Prop Pos as s) -> s | Type _, (Prop Pos as s) when is_impredicative_set env -> s - | (Type _, _) | (_, Type _) -> new_Type_sort () -(* | Type u1, Prop Pos -> Type (Univ.sup u1 Univ.type0_univ) | Prop Pos, (Type u2) -> Type (Univ.sup Univ.type0_univ u2) | Prop Null, (Type _ as s) -> s - | Type u1, Type u2 -> Type (Univ.sup u1 u2)*)) - | App(f,args) when isGlobalRef f -> - let t = type_of_global_reference_knowing_parameters env f args in - sort_of_atomic_type env sigma t args + | Type u1, Type u2 -> Type (Univ.sup u1 u2)) + (* | App(f,args) when isGlobalRef f -> *) + (* let t = type_of_global_reference_knowing_parameters env f args in *) + (* sort_of_atomic_type env sigma t args *) | App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args | Lambda _ | Fix _ | Construct _ -> retype_error NotAType | _ -> decomp_sort env sigma (type_of env t) @@ -178,12 +184,12 @@ let retype ?(polyprop=true) sigma = Array.map (fun c -> lazy (nf_evar sigma (type_of env c))) args in match kind_of_term c with | Ind ind -> - let (_,mip) = lookup_mind_specif env ind in + let mip = lookup_mind_specif env (fst ind) in (try Inductive.type_of_inductive_knowing_parameters - ~polyprop env mip argtyps + ~polyprop env (mip,snd ind) argtyps with Reduction.NotArity -> retype_error NotAnArity) | Const cst -> - let t = constant_type env cst in + let t = constant_type_in env cst in (try Typeops.type_of_constant_knowing_parameters env t argtyps with Reduction.NotArity -> retype_error NotAnArity) | Var id -> type_of_var env id @@ -203,24 +209,31 @@ let type_of_global_reference_knowing_parameters env sigma c args = let type_of_global_reference_knowing_conclusion env sigma c conclty = let conclty = nf_evar sigma conclty in match kind_of_term c with - | Ind ind -> - let (_,mip) = Inductive.lookup_mind_specif env ind in - type_of_inductive_knowing_conclusion env mip conclty + | Ind (ind,u) -> + let spec = Inductive.lookup_mind_specif env ind in + type_of_inductive_knowing_conclusion env (spec,u) conclty | Const cst -> - let t = constant_type env cst in + let t = constant_type_in env cst in (* TODO *) Typeops.type_of_constant_knowing_parameters env t [||] | Var id -> type_of_var env id | Construct cstr -> type_of_constructor env cstr | _ -> assert false -(* We are outside the kernel: we take fresh universes *) -(* to avoid tactics and co to refresh universes themselves *) -let get_type_of ?(polyprop=true) ?(refresh=true) ?(lax=false) env sigma c = +(* Profiling *) +(* let get_type_of polyprop lax env sigma c = *) +(* let f,_,_,_ = retype ~polyprop sigma in *) +(* if lax then f env c else anomaly_on_error (f env) c *) + +(* let get_type_of_key = Profile.declare_profile "get_type_of" *) +(* let get_type_of = Profile.profile5 get_type_of_key get_type_of *) + +(* let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = *) +(* get_type_of polyprop lax env sigma c *) + +let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = let f,_,_,_ = retype ~polyprop sigma in - let t = if lax then f env c else anomaly_on_error (f env) c in - if refresh then refresh_universes t else t + if lax then f env c else anomaly_on_error (f env) c (* Makes an unsafe judgment from a constr *) let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c } - diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index c2a08f4b99..fc1dd3564b 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -26,8 +26,7 @@ type retype_error exception RetypeError of retype_error val get_type_of : - ?polyprop:bool -> ?refresh:bool -> ?lax:bool -> - env -> evar_map -> constr -> types + ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> types val get_sort_of : ?polyprop:bool -> env -> evar_map -> types -> sorts diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index dd7542fc7f..da45952548 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -41,7 +41,8 @@ let error_not_evaluable r = spc () ++ str "to an evaluable reference.") let is_evaluable_const env cst = - is_transparent env (ConstKey cst) && evaluable_constant cst env + is_transparent env (ConstKey cst) && + (evaluable_constant cst env || is_projection cst env) let is_evaluable_var env id = is_transparent env (VarKey id) && evaluable_named id env @@ -50,12 +51,17 @@ let is_evaluable env = function | EvalConstRef cst -> is_evaluable_const env cst | EvalVarRef id -> is_evaluable_var env id -let value_of_evaluable_ref env = function - | EvalConstRef con -> constant_value env con +let value_of_evaluable_ref env evref u = + match evref with + | EvalConstRef con -> + (try constant_value_in env (con,u) + with NotEvaluableConst IsProj -> + raise (Invalid_argument "value_of_evaluable_ref")) | EvalVarRef id -> Option.get (pi2 (lookup_named id env)) -let constr_of_evaluable_ref = function - | EvalConstRef con -> mkConst con +let constr_of_evaluable_ref evref u = + match evref with + | EvalConstRef con -> mkConstU (con,u) | EvalVarRef id -> mkVar id let evaluable_of_global_reference env = function @@ -81,27 +87,43 @@ let evaluable_reference_eq r1 r2 = match r1, r2 with Evar.equal e1 e2 && Array.equal eq_constr ctx1 ctx2 | _ -> false -let mkEvalRef = function - | EvalConst cst -> mkConst cst +let mkEvalRef ref u = + match ref with + | EvalConst cst -> mkConstU (cst,u) | EvalVar id -> mkVar id | EvalRel n -> mkRel n | EvalEvar ev -> mkEvar ev let isEvalRef env c = match kind_of_term c with - | Const sp -> is_evaluable env (EvalConstRef sp) + | Const (sp,_) -> is_evaluable env (EvalConstRef sp) | Var id -> is_evaluable env (EvalVarRef id) | Rel _ | Evar _ -> true | _ -> false -let destEvalRef c = match kind_of_term c with - | Const cst -> EvalConst cst - | Var id -> EvalVar id - | Rel n -> EvalRel n - | Evar ev -> EvalEvar ev +let destEvalRefU c = match kind_of_term c with + | Const (cst,u) -> EvalConst cst, u + | Var id -> (EvalVar id, Univ.Instance.empty) + | Rel n -> (EvalRel n, Univ.Instance.empty) + | Evar ev -> (EvalEvar ev, Univ.Instance.empty) | _ -> anomaly (Pp.str "Not an unfoldable reference") -let reference_opt_value sigma env = function - | EvalConst cst -> constant_opt_value env cst +let unsafe_reference_opt_value sigma env eval = + match eval with + | EvalConst cst -> + (match (lookup_constant cst env).Declarations.const_body with + | Declarations.Def c -> Some (Mod_subst.force_constr c) + | _ -> None) + | EvalVar id -> + let (_,v,_) = lookup_named id env in + v + | EvalRel n -> + let (_,v,_) = lookup_rel n env in + Option.map (lift n) v + | EvalEvar ev -> Evd.existential_opt_value sigma ev + +let reference_opt_value sigma env eval u = + match eval with + | EvalConst cst -> constant_opt_value_in env (cst,u) | EvalVar id -> let (_,v,_) = lookup_named id env in v @@ -111,8 +133,8 @@ let reference_opt_value sigma env = function | EvalEvar ev -> Evd.existential_opt_value sigma ev exception NotEvaluable -let reference_value sigma env c = - match reference_opt_value sigma env c with +let reference_value sigma env c u = + match reference_opt_value sigma env c u with | None -> raise NotEvaluable | Some d -> d @@ -127,6 +149,7 @@ type constant_evaluation = ((int*evaluable_reference) option array * (int * (int * constr) list * int)) | EliminationCases of int + | EliminationProj of int | NotAnElimination (* We use a cache registered as a global table *) @@ -215,7 +238,7 @@ let invert_name labs l na0 env sigma ref = function match refi with | None -> None | Some ref -> - try match reference_opt_value sigma env ref with + try match unsafe_reference_opt_value sigma env ref with | None -> None | Some c -> let labs',ccl = decompose_lam c in @@ -243,9 +266,10 @@ let compute_consteval_direct sigma env ref = (try check_fix_reversibility labs l fix with Elimconst -> NotAnElimination) | Case (_,_,d,_) when isRel d -> EliminationCases n + | Proj (p, d) when isRel d -> EliminationProj n | _ -> NotAnElimination in - match reference_opt_value sigma env ref with + match unsafe_reference_opt_value sigma env ref with | None -> NotAnElimination | Some c -> srec env 0 [] c @@ -270,13 +294,13 @@ let compute_consteval_mutual_fix sigma env ref = | _ -> assert false) | _ when isEvalRef env c' -> (* Forget all \'s and args and do as if we had started with c' *) - let ref = destEvalRef c' in - (match reference_opt_value sigma env ref with + let ref,_ = destEvalRefU c' in + (match unsafe_reference_opt_value sigma env ref with | None -> anomaly (Pp.str "Should have been trapped by compute_direct") | Some c -> srec env (minarg-nargs) [] ref c) | _ -> (* Should not occur *) NotAnElimination in - match reference_opt_value sigma env ref with + match unsafe_reference_opt_value sigma env ref with | None -> (* Should not occur *) NotAnElimination | Some c -> srec env 0 [] ref c @@ -320,7 +344,7 @@ let reference_eval sigma env = function let x = Name (Id.of_string "x") -let make_elim_fun (names,(nbfix,lv,n)) largs = +let make_elim_fun (names,(nbfix,lv,n)) u largs = let lu = List.firstn n largs in let p = List.length lv in let lyi = List.map fst lv in @@ -335,7 +359,7 @@ let make_elim_fun (names,(nbfix,lv,n)) largs = match names.(i) with | None -> None | Some (minargs,ref) -> - let body = applistc (mkEvalRef ref) la in + let body = applistc (mkEvalRef ref u) la in let g = List.fold_left_i (fun q (* j = n+1-q *) c (ij,tij) -> let subst = List.map (lift (-q)) (List.firstn (n-ij) la) in @@ -392,8 +416,9 @@ let solve_arity_problem env sigma fxminargs c = else raise Partial; List.iter (check strict) rcargs | (Var _|Const _) when isEvalRef env h -> - (match reference_opt_value sigma env (destEvalRef h) with - Some h' -> + (let ev, u = destEvalRefU h in + match reference_opt_value sigma env ev u with + | Some h' -> let bak = !evm in (try List.iter (check false) rcargs with Partial -> @@ -465,7 +490,7 @@ let contract_cofix_use_function env sigma f let reduce_mind_case_use_function func env sigma mia = match kind_of_term mia.mconstr with - | Construct(ind_sp,i) -> + | Construct ((ind_sp,i),u) -> let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in applist (mia.mlf.(i-1), real_cargs) | CoFix (bodynum,(names,_,_) as cofix) -> @@ -481,12 +506,13 @@ let reduce_mind_case_use_function func env sigma mia = mutual inductive, try to reuse the global name if the block was indeed initially built as a global definition *) - let kn = con_with_label (destConst func) (Label.of_id id) + let kn = map_puniverses (fun x -> con_with_label x (Label.of_id id)) + (destConst func) in - try match constant_opt_value env kn with + try match constant_opt_value_in env kn with | None -> None (* TODO: check kn is correct *) - | Some _ -> Some (minargs,mkConst kn) + | Some _ -> Some (minargs,mkConstU kn) with Not_found -> None else fun _ -> None in @@ -495,21 +521,42 @@ let reduce_mind_case_use_function func env sigma mia = mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false + +let match_eval_ref env constr = + match kind_of_term constr with + | Const (sp, u) when is_evaluable env (EvalConstRef sp) -> + Some (EvalConst sp, u) + | Var id when is_evaluable env (EvalVarRef id) -> Some (EvalVar id, Univ.Instance.empty) + | Rel i -> Some (EvalRel i, Univ.Instance.empty) + | Evar ev -> Some (EvalEvar ev, Univ.Instance.empty) + | _ -> None + +let match_eval_ref_value sigma env constr = + match kind_of_term constr with + | Const (sp, u) when is_evaluable env (EvalConstRef sp) -> + Some (constant_value_in env (sp, u)) + | Var id when is_evaluable env (EvalVarRef id) -> + let (_,v,_) = lookup_named id env in v + | Rel n -> let (_,v,_) = lookup_rel n env in + Option.map (lift n) v + | Evar ev -> Evd.existential_opt_value sigma ev + | _ -> None + let special_red_case env sigma whfun (ci, p, c, lf) = let rec redrec s = let (constr, cargs) = whfun s in - if isEvalRef env constr then - let ref = destEvalRef constr in - match reference_opt_value sigma env ref with - | None -> raise Redelimination - | Some gvalue -> - if reducible_mind_case gvalue then - reduce_mind_case_use_function constr env sigma - {mP=p; mconstr=gvalue; mcargs=cargs; - mci=ci; mlf=lf} - else - redrec (applist(gvalue, cargs)) - else + match match_eval_ref env constr with + | Some (ref, u) -> + (match reference_opt_value sigma env ref u with + | None -> raise Redelimination + | Some gvalue -> + if reducible_mind_case gvalue then + reduce_mind_case_use_function constr env sigma + {mP=p; mconstr=gvalue; mcargs=cargs; + mci=ci; mlf=lf} + else + redrec (applist(gvalue, cargs))) + | None -> if reducible_mind_case constr then reduce_mind_case {mP=p; mconstr=constr; mcargs=cargs; @@ -524,6 +571,34 @@ let recargs = function | EvalConst c -> Option.map (fun (x,y,_) -> (x,y)) (ReductionBehaviour.get (ConstRef c)) +let reduce_projection env sigma proj (recarg'hd,stack') stack = + (match kind_of_term recarg'hd with + | Construct _ -> + let proj_narg = + let pb = Option.get ((lookup_constant proj env).Declarations.const_proj) in + pb.Declarations.proj_npars + pb.Declarations.proj_arg + in Reduced (List.nth stack' proj_narg, stack) + | _ -> NotReducible) + +let reduce_proj env sigma whfun c = + (* Pp.msgnl (str" reduce_proj: " ++ print_constr c); *) + let rec redrec s = + match kind_of_term s with + | Proj (proj, c) -> + let c' = try redrec c with Redelimination -> c in + let constr, cargs = whfun c' in + (* Pp.msgnl (str" reduce_proj: constructor: " ++ print_constr constr); *) + (match kind_of_term constr with + | Construct _ -> + let proj_narg = + let pb = Option.get ((lookup_constant proj env).Declarations.const_proj) in + pb.Declarations.proj_npars + pb.Declarations.proj_arg + in List.nth cargs proj_narg + | _ -> raise Redelimination) + | _ -> raise Redelimination + in redrec c + + let dont_expose_case = function | EvalVar _ | EvalRel _ | EvalEvar _ -> false | EvalConst c -> @@ -547,8 +622,8 @@ let whd_nothing_for_iota env sigma s = | Meta ev -> (try whrec (Evd.meta_value sigma ev, stack) with Not_found -> s) - | Const const when is_transparent_constant full_transparent_state const -> - (match constant_opt_value env const with + | Const const when is_transparent_constant full_transparent_state (fst const) -> + (match constant_opt_value_in env const with | Some body -> whrec (body, stack) | None -> s) | LetIn (_,b,_,c) -> stacklam whrec [b] c stack @@ -567,7 +642,7 @@ let whd_nothing_for_iota env sigma s = constants by keeping the name of the constants in the recursive calls; it fails if no redex is around *) -let rec red_elim_const env sigma ref largs = +let rec red_elim_const env sigma ref u largs = let nargs = List.length largs in let largs, unfold_anyway, unfold_nonelim = match recargs ref with @@ -586,39 +661,44 @@ let rec red_elim_const env sigma ref largs = n >= 0 && not is_empty && nargs >= n in try match reference_eval sigma env ref with | EliminationCases n when nargs >= n -> - let c = reference_value sigma env ref in + let c = reference_value sigma env ref u in let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in let whfun = whd_simpl_stack env sigma in (special_red_case env sigma whfun (destCase c'), lrest) + | EliminationProj n when nargs >= n -> + let c = reference_value sigma env ref u in + let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in + let whfun = whd_construct_stack env sigma in + (reduce_proj env sigma whfun c', lrest) | EliminationFix (min,minfxargs,infos) when nargs >= min -> - let c = reference_value sigma env ref in + let c = reference_value sigma env ref u in let d, lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in - let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) largs in + let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) u largs in let whfun = whd_construct_stack env sigma in (match reduce_fix_use_function env sigma f whfun (destFix d) lrest with | NotReducible -> raise Redelimination | Reduced (c,rest) -> (nf_beta sigma c, rest)) | EliminationMutualFix (min,refgoal,refinfos) when nargs >= min -> - let rec descend ref args = - let c = reference_value sigma env ref in + let rec descend (ref,u) args = + let c = reference_value sigma env ref u in if evaluable_reference_eq ref refgoal then (c,args) else let c', lrest = whd_betalet_stack sigma (applist(c,args)) in - descend (destEvalRef c') lrest in - let (_, midargs as s) = descend ref largs in + descend (destEvalRefU c') lrest in + let (_, midargs as s) = descend (ref,u) largs in let d, lrest = whd_nothing_for_iota env sigma (applist s) in - let f = make_elim_fun refinfos midargs in + let f = make_elim_fun refinfos u midargs in let whfun = whd_construct_stack env sigma in (match reduce_fix_use_function env sigma f whfun (destFix d) lrest with | NotReducible -> raise Redelimination | Reduced (c,rest) -> (nf_beta sigma c, rest)) | NotAnElimination when unfold_nonelim -> - let c = reference_value sigma env ref in + let c = reference_value sigma env ref u in whd_betaiotazeta sigma (applist (c, largs)), [] | _ -> raise Redelimination with Redelimination when unfold_anyway -> - let c = reference_value sigma env ref in + let c = reference_value sigma env ref u in whd_betaiotazeta sigma (applist (c, largs)), [] (* reduce to whd normal form or to an applied constant that does not hide @@ -645,20 +725,31 @@ and whd_simpl_stack env sigma = | Reduced s' -> redrec (applist s') | NotReducible -> s' with Redelimination -> s') - | _ when isEvalRef env x -> - let ref = destEvalRef x in + + | Proj (p, c) -> + (try + (match recargs (EvalConst p) with + | Some (_, n) when n > 1 -> (* simpl never *) s' + | _ -> + match reduce_projection env sigma p (whd_construct_stack env sigma c) stack with + | Reduced s' -> redrec (applist s') + | NotReducible -> s') + with Redelimination -> s') + + | _ -> + match match_eval_ref env x with + | Some (ref, u) -> (try - let hd, _ as s'' = redrec (applist(red_elim_const env sigma ref stack)) in - let rec is_case x = match kind_of_term x with - | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x - | App (hd, _) -> is_case hd - | Case _ -> true - | _ -> false in - if dont_expose_case ref && is_case hd then raise Redelimination - else s'' - with Redelimination -> - s') - | _ -> s' + let hd, _ as s'' = redrec (applist(red_elim_const env sigma ref u stack)) in + let rec is_case x = match kind_of_term x with + | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x + | App (hd, _) -> is_case hd + | Case _ -> true + | _ -> false in + if dont_expose_case ref && is_case hd then raise Redelimination + else s'' + with Redelimination -> s') + | None -> s' in redrec @@ -667,13 +758,12 @@ and whd_simpl_stack env sigma = and whd_construct_stack env sigma s = let (constr, cargs as s') = whd_simpl_stack env sigma s in if reducible_mind_case constr then s' - else if isEvalRef env constr then - let ref = destEvalRef constr in - match reference_opt_value sigma env ref with - | None -> raise Redelimination - | Some gvalue -> whd_construct_stack env sigma (applist(gvalue, cargs)) - else - raise Redelimination + else match match_eval_ref env constr with + | Some (ref, u) -> + (match reference_opt_value sigma env ref u with + | None -> raise Redelimination + | Some gvalue -> whd_construct_stack env sigma (applist(gvalue, cargs))) + | _ -> raise Redelimination (************************************************************************) (* Special Purpose Reduction Strategies *) @@ -703,14 +793,24 @@ let try_red_product env sigma c = | Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b) | LetIn (x,a,b,t) -> redrec env (subst1 a t) | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) - | _ when isEvalRef env x -> + | Proj (p, c) -> + let c' = + match kind_of_term c with + | Construct _ -> c + | _ -> redrec env c + in + (match reduce_projection env sigma p (whd_betaiotazeta_stack sigma c') [] with + | Reduced s -> simpfun (applist s) + | NotReducible -> raise Redelimination) + | _ -> + (match match_eval_ref env x with + | Some (ref, u) -> (* TO DO: re-fold fixpoints after expansion *) (* to get true one-step reductions *) - let ref = destEvalRef x in - (match reference_opt_value sigma env ref with + (match reference_opt_value sigma env ref u with | None -> raise Redelimination | Some c -> c) - | _ -> raise Redelimination + | _ -> raise Redelimination) in redrec env c let red_product env sigma c = @@ -778,14 +878,13 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c = let whd_simpl_orelse_delta_but_fix env sigma c = let rec redrec s = let (constr, stack as s') = whd_simpl_stack env sigma s in - if isEvalRef env constr then - match reference_opt_value sigma env (destEvalRef constr) with - | Some c -> - (match kind_of_term (strip_lam c) with - | CoFix _ | Fix _ -> s' - | _ -> redrec (applist(c, stack))) - | None -> s' - else s' in + match match_eval_ref_value sigma env constr with + | Some c -> + (match kind_of_term (strip_lam c) with + | CoFix _ | Fix _ -> s' + | _ -> redrec (applist(c, stack))) + | None -> s' + in let simpfun = clos_norm_flags betaiota env sigma in simpfun (applist (redrec c)) @@ -803,12 +902,14 @@ let simpl env sigma c = strong whd_simpl env sigma c let matches_head c t = match kind_of_term t with | App (f,_) -> ConstrMatching.matches c f + | Proj (p, _) -> ConstrMatching.matches c (mkConst p) | _ -> raise ConstrMatching.PatternMatchingFailure -let contextually byhead (occs,c) f env sigma t = +let e_contextually byhead (occs,c) f env sigma t = let (nowhere_except_in,locs) = Locusops.convert_occs occs in let maxocc = List.fold_right max locs 0 in let pos = ref 1 in + let evd = ref sigma in let rec traverse (env,c as envc) t = if nowhere_except_in && (!pos > maxocc) then t else @@ -821,11 +922,15 @@ let contextually byhead (occs,c) f env sigma t = incr pos; if ok then let subst' = Id.Map.map (traverse envc) subst in - f subst' env sigma t + let evm, t = f subst' env !evd t in + (evd := evm; t) else if byhead then (* find other occurrences of c in t; TODO: ensure left-to-right *) - let (f,l) = destApp t in - mkApp (f, Array.map_left (traverse envc) l) + (match kind_of_term t with + | App (f,l) -> + mkApp (f, Array.map_left (traverse envc) l) + | Proj (p,c) -> mkProj (p,traverse envc c) + | _ -> assert false) else t with ConstrMatching.PatternMatchingFailure -> @@ -835,30 +940,45 @@ let contextually byhead (occs,c) f env sigma t = in let t' = traverse (env,c) t in if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs; - t' + !evd, t' + +let contextually byhead occs f env sigma t = + let f' subst env sigma t = sigma, f subst env sigma t in + snd (e_contextually byhead occs f' env sigma t) (* linear bindings (following pretty-printer) of the value of name in c. * n is the number of the next occurence of name. * ol is the occurence list to find. *) -let substlin env evalref n (nowhere_except_in,locs) c = +let match_constr_evaluable_ref sigma c evref = + match kind_of_term c, evref with + | Const (c,u), EvalConstRef c' when eq_constant c c' -> Some u + | Proj (p,c), EvalConstRef p' when eq_constant p p' -> Some Univ.Instance.empty + | Var id, EvalVarRef id' when id_eq id id' -> Some Univ.Instance.empty + | _, _ -> None + +let substlin env sigma evalref n (nowhere_except_in,locs) c = let maxocc = List.fold_right max locs 0 in let pos = ref n in assert (List.for_all (fun x -> x >= 0) locs); - let value = value_of_evaluable_ref env evalref in - let term = constr_of_evaluable_ref evalref in + let value u = + value_of_evaluable_ref env evalref u + (* Some (whd_betaiotazeta sigma c) *) + in let rec substrec () c = if nowhere_except_in && !pos > maxocc then c - else if eq_constr c term then - let ok = - if nowhere_except_in then Int.List.mem !pos locs - else not (Int.List.mem !pos locs) in - incr pos; - if ok then value else c - else - map_constr_with_binders_left_to_right - (fun _ () -> ()) - substrec () c + else + match match_constr_evaluable_ref sigma c evalref with + | Some u -> + let ok = + if nowhere_except_in then Int.List.mem !pos locs + else not (Int.List.mem !pos locs) in + incr pos; + if ok then value u else c + | None -> + map_constr_with_binders_left_to_right + (fun _ () -> ()) + substrec () c in let t' = substrec () c in (!pos, t') @@ -881,7 +1001,7 @@ let unfold env sigma name = * Performs a betaiota reduction after unfolding. *) let unfoldoccs env sigma (occs,name) c = let unfo nowhere_except_in locs = - let (nbocc,uc) = substlin env name 1 (nowhere_except_in,locs) c in + let (nbocc,uc) = substlin env sigma name 1 (nowhere_except_in,locs) c in if Int.equal nbocc 1 then error ((string_of_evaluable_ref env name)^" does not occur."); let rest = List.filter (fun o -> o >= nbocc) locs in @@ -934,6 +1054,22 @@ let compute = cbv_betadeltaiota (* Pattern *) +let make_eq_univs_test evd c = + { match_fun = (fun evd c' -> + let b, cst = eq_constr_universes c c' in + if b then + try Evd.add_universe_constraints evd cst + with Evd.UniversesDiffer -> raise NotUnifiable + else raise NotUnifiable); + merge_fun = (fun evd _ -> evd); + testing_state = evd; + last_found = None +} +let subst_closed_term_univs_occ evd occs c t = + let test = make_eq_univs_test evd c in + let t' = subst_closed_term_occ_modulo occs test None t in + t', test.testing_state + (* gives [na:ta]c' such that c converts to ([na:ta]c' a), abstracting only * the specified occurrences. *) @@ -944,7 +1080,8 @@ let abstract_scheme env sigma (locc,a) c = if occur_meta a then mkLambda (na,ta,c) else - mkLambda (na,ta,subst_closed_term_occ locc a c) + let c', sigma' = subst_closed_term_univs_occ sigma locc a c in + mkLambda (na,ta,c') let pattern_occs loccs_trm env sigma c = let abstr_trm = List.fold_right (abstract_scheme env sigma) loccs_trm c in @@ -1011,11 +1148,11 @@ let one_step_reduce env sigma c = | Reduced s' -> s' | NotReducible -> raise NotStepReducible) | _ when isEvalRef env x -> - let ref = destEvalRef x in + let ref,u = destEvalRefU x in (try - red_elim_const env sigma ref stack + red_elim_const env sigma ref u stack with Redelimination -> - match reference_opt_value sigma env ref with + match reference_opt_value sigma env ref u with | Some d -> (d, stack) | None -> raise NotStepReducible) @@ -1027,7 +1164,7 @@ let isIndRef = function IndRef _ -> true | _ -> false let reduce_to_ref_gen allow_product env sigma ref t = if isIndRef ref then - let (mind,t) = reduce_to_ind_gen allow_product env sigma t in + let ((mind,u),t) = reduce_to_ind_gen allow_product env sigma t in begin match ref with | IndRef mind' when eq_ind mind mind' -> t | _ -> diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index 34aca3e332..5146cd3458 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -59,8 +59,17 @@ val unfoldn : (** Fold *) val fold_commands : constr list -> reduction_function +val make_eq_univs_test : evar_map -> constr -> evar_map Termops.testing_function + +(** [subst_closed_term_occ occl c d] replaces occurrences of closed [c] at + positions [occl] by [Rel 1] in [d] (see also Note OCC), unifying universes + which results in a set of constraints. *) +val subst_closed_term_univs_occ : evar_map -> occurrences -> constr -> constr -> + constr * evar_map + (** Pattern *) -val pattern_occs : (occurrences * constr) list -> reduction_function +val pattern_occs : (occurrences * constr) list -> env -> evar_map -> constr -> + constr (** Rem: Lazy strategies are defined in Reduction *) @@ -74,12 +83,12 @@ val cbv_norm_flags : Closure.RedFlags.reds -> reduction_function (** [reduce_to_atomic_ind env sigma t] puts [t] in the form [t'=(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_atomic_ind : env -> evar_map -> types -> inductive * types +val reduce_to_atomic_ind : env -> evar_map -> types -> pinductive * types (** [reduce_to_quantified_ind env sigma t] puts [t] in the form [t'=(x1:A1)..(xn:An)(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_quantified_ind : env -> evar_map -> types -> inductive * types +val reduce_to_quantified_ind : env -> evar_map -> types -> pinductive * types (** [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form [t'=(x1:A1)..(xn:An)(ref args)] and fails with user error if not possible *) @@ -90,7 +99,10 @@ val reduce_to_atomic_ref : env -> evar_map -> global_reference -> types -> types val find_hnf_rectype : - env -> evar_map -> types -> inductive * constr list + env -> evar_map -> types -> pinductive * constr list val contextually : bool -> occurrences * constr_pattern -> (patvar_map -> reduction_function) -> reduction_function + +val e_contextually : bool -> occurrences * constr_pattern -> + (patvar_map -> e_reduction_function) -> e_reduction_function diff --git a/pretyping/term_dnet.ml b/pretyping/term_dnet.ml index 10ec651fad..e05f4bcfe8 100644 --- a/pretyping/term_dnet.ml +++ b/pretyping/term_dnet.ml @@ -261,9 +261,9 @@ struct | Rel _ -> Term DRel | Sort _ -> Term DSort | Var i -> Term (DRef (VarRef i)) - | Const c -> Term (DRef (ConstRef c)) - | Ind i -> Term (DRef (IndRef i)) - | Construct c -> Term (DRef (ConstructRef c)) + | Const (c,u) -> Term (DRef (ConstRef c)) + | Ind (i,u) -> Term (DRef (IndRef i)) + | Construct (c,u)-> Term (DRef (ConstructRef c)) | Term.Meta _ -> assert false | Evar (i,_) -> let meta = @@ -287,6 +287,8 @@ struct | App (f,ca) -> Array.fold_left (fun c a -> Term (DApp (c,a))) (pat_of_constr f) (Array.map pat_of_constr ca) + | Proj (p,c) -> + Term (DApp (Term (DRef (ConstRef p)), pat_of_constr c)) and ctx_of_constr ctx c = match kind_of_term c with | Prod (_,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t,None),ctx))) c diff --git a/pretyping/termops.ml b/pretyping/termops.ml index 741601167d..b3fa53eeee 100644 --- a/pretyping/termops.ml +++ b/pretyping/termops.ml @@ -22,7 +22,7 @@ open Locus let print_sort = function | Prop Pos -> (str "Set") | Prop Null -> (str "Prop") - | Type u -> (str "Type(" ++ Univ.pr_uni u ++ str ")") + | Type u -> (str "Type(" ++ Univ.Universe.pr u ++ str ")") let pr_sort_family = function | InSet -> (str "Set") @@ -44,6 +44,10 @@ let pr_fix pr_constr ((t,i),(lna,tl,bl)) = cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++ str"}") +let pr_puniverses p u = + if Univ.Instance.is_empty u then p + else p ++ str"(*" ++ Univ.Instance.pr u ++ str"*)" + let rec pr_constr c = match kind_of_term c with | Rel n -> str "#"++int n | Meta n -> str "Meta(" ++ int n ++ str ")" @@ -71,10 +75,11 @@ let rec pr_constr c = match kind_of_term c with | Evar (e,l) -> hov 1 (str"Evar#" ++ int (Evar.repr e) ++ str"{" ++ prlist_with_sep spc pr_constr (Array.to_list l) ++str"}") - | Const c -> str"Cst(" ++ pr_con c ++ str")" - | Ind (sp,i) -> str"Ind(" ++ pr_mind sp ++ str"," ++ int i ++ str")" - | Construct ((sp,i),j) -> - str"Constr(" ++ pr_mind sp ++ str"," ++ int i ++ str"," ++ int j ++ str")" + | Const (c,u) -> str"Cst(" ++ pr_puniverses (pr_con c) u ++ str")" + | Ind ((sp,i),u) -> str"Ind(" ++ pr_puniverses (pr_mind sp ++ str"," ++ int i) u ++ str")" + | Construct (((sp,i),j),u) -> + str"Constr(" ++ pr_puniverses (pr_mind sp ++ str"," ++ int i ++ str"," ++ int j) u ++ str")" + | Proj (p,c) -> str"Proj(" ++ pr_con p ++ str"," ++ pr_constr c ++ str")" | Case (ci,p,c,bl) -> v 0 (hv 0 (str"<"++pr_constr p++str">"++ cut() ++ str"Case " ++ pr_constr c ++ str"of") ++ cut() ++ @@ -145,41 +150,6 @@ let print_env env = in (sign_env ++ db_env) -(*let current_module = ref DirPath.empty - -let set_module m = current_module := m*) - -let new_univ_level, set_remote_new_univ_level = - RemoteCounter.new_counter ~name:"univ_level" 0 ~incr:((+) 1) - ~build:(fun n -> Univ.UniverseLevel.make (Lib.library_dp()) n) - -let new_univ () = Univ.Universe.make (new_univ_level ()) -let new_Type () = mkType (new_univ ()) -let new_Type_sort () = Type (new_univ ()) - -(* This refreshes universes in types; works only for inferred types (i.e. for - types of the form (x1:A1)...(xn:An)B with B a sort or an atom in - head normal form) *) -let refresh_universes_gen strict t = - let modified = ref false in - let rec refresh t = match kind_of_term t with - | Sort (Type u) when strict || not (Univ.is_type0m_univ u) -> - modified := true; new_Type () - | Prod (na,u,v) -> mkProd (na,u,refresh v) - | _ -> t in - let t' = refresh t in - if !modified then t' else t - -let refresh_universes = refresh_universes_gen false -let refresh_universes_strict = refresh_universes_gen true - -let new_sort_in_family = function - | InProp -> prop_sort - | InSet -> set_sort - | InType -> Type (new_univ ()) - - - (* [Rel (n+m);...;Rel(n+1)] *) let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) @@ -319,6 +289,7 @@ let map_constr_with_named_binders g f l c = match kind_of_term c with | Lambda (na,t,c) -> mkLambda (na, f l t, f (g na l) c) | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g na l) c) | App (c,al) -> mkApp (f l c, Array.map (f l) al) + | Proj (p,c) -> mkProj (p, f l c) | Evar (e,al) -> mkEvar (e, Array.map (f l) al) | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl) | Fix (ln,(lna,tl,bl)) -> @@ -375,6 +346,8 @@ let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with let a = al.(Array.length al - 1) in let hd = f l (mkApp (c, Array.sub al 0 (Array.length al - 1))) in mkApp (hd, [| f l a |]) + | Proj (p,c) -> + mkProj (p, f l c) | Evar (e,al) -> mkEvar (e, Array.map_left (f l) al) | Case (ci,p,c,bl) -> (* In v8 concrete syntax, predicate is after the term to match! *) @@ -415,6 +388,9 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with let c' = f l c in let al' = Array.map (f l) al in if c==c' && Array.for_all2 (==) al al' then cstr else mkApp (c', al') + | Proj (p,c) -> + let c' = f l c in + if c' == c then cstr else mkProj (p, c') | Evar (e,al) -> let al' = Array.map (f l) al in if Array.for_all2 (==) al al' then cstr else mkEvar (e, al') @@ -456,6 +432,7 @@ let fold_constr_with_binders g f n acc c = match kind_of_term c with | Lambda (_,t,c) -> f (g n) (f n acc t) c | LetIn (_,b,t,c) -> f (g n) (f n (f n acc b) t) c | App (c,l) -> Array.fold_left (f n) (f n acc c) l + | Proj (p,c) -> f n acc c | Evar (_,l) -> Array.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl | Fix (_,(lna,tl,bl)) -> @@ -480,6 +457,7 @@ let iter_constr_with_full_binders g f l c = match kind_of_term c with | Lambda (na,t,c) -> f l t; f (g (na,None,t) l) c | LetIn (na,b,t,c) -> f l b; f l t; f (g (na,Some b,t) l) c | App (c,args) -> f l c; Array.iter (f l) args + | Proj (p,c) -> f l c | Evar (_,args) -> Array.iter (f l) args | Case (_,p,c,bl) -> f l p; f l c; Array.iter (f l) bl | Fix (_,(lna,tl,bl)) -> @@ -516,6 +494,13 @@ let occur_meta_or_existential c = | _ -> iter_constr occrec c in try occrec c; false with Occur -> true +let occur_const s c = + let rec occur_rec c = match kind_of_term c with + | Const (sp,_) when sp=s -> raise Occur + | _ -> iter_constr occur_rec c + in + try occur_rec c; false with Occur -> true + let occur_evar n c = let rec occur_rec c = match kind_of_term c with | Evar (sp,_) when Evar.equal sp n -> raise Occur @@ -573,9 +558,10 @@ let collect_vars c = (* Tests whether [m] is a subterm of [t]: [m] is appropriately lifted through abstractions of [t] *) -let dependent_main noevar m t = +let dependent_main noevar univs m t = + let eqc x y = if univs then fst (eq_constr_universes x y) else eq_constr_nounivs x y in let rec deprec m t = - if eq_constr m t then + if eqc m t then raise Occur else match kind_of_term m, kind_of_term t with @@ -590,8 +576,11 @@ let dependent_main noevar m t = in try deprec m t; false with Occur -> true -let dependent = dependent_main false -let dependent_no_evar = dependent_main true +let dependent = dependent_main false false +let dependent_no_evar = dependent_main true false + +let dependent_univs = dependent_main false true +let dependent_univs_no_evar = dependent_main true true let count_occurrences m t = let n = ref 0 in @@ -725,7 +714,7 @@ let error_cannot_unify_occurrences nested (cl2,pos2,t2) (cl1,pos1,t1) = exception NotUnifiable type 'a testing_function = { - match_fun : constr -> 'a; + match_fun : 'a -> constr -> 'a; merge_fun : 'a -> 'a -> 'a; mutable testing_state : 'a; mutable last_found : ((Id.t * hyp_location_flag) option * int * constr) option @@ -746,7 +735,7 @@ let subst_closed_term_occ_gen_modulo occs test cl occ t = let rec substrec k t = if nowhere_except_in && !pos > maxocc then t else try - let subst = test.match_fun t in + let subst = test.match_fun test.testing_state t in if Locusops.is_selected !pos occs then (add_subst t subst; incr pos; (* Check nested matching subterms *) @@ -781,7 +770,7 @@ let proceed_with_occurrences f occs x = x let make_eq_test c = { - match_fun = (fun c' -> if eq_constr c c' then () else raise NotUnifiable); + match_fun = (fun () c' -> if eq_constr c c' then () else raise NotUnifiable); merge_fun = (fun () () -> ()); testing_state = (); last_found = None @@ -879,10 +868,7 @@ let isGlobalRef c = | Const _ | Ind _ | Construct _ | Var _ -> true | _ -> false -let has_polymorphic_type c = - match (Global.lookup_constant c).Declarations.const_type with - | Declarations.PolymorphicArity _ -> true - | _ -> false +let has_polymorphic_type c = (Global.lookup_constant c).Declarations.const_polymorphic let base_sort_cmp pb s0 s1 = match (s0,s1) with @@ -1117,9 +1103,11 @@ let coq_unit_judge = let na2 = Name (Id.of_string "H") in fun () -> match !impossible_default_case with - | Some (id,type_of_id) -> - make_judge id type_of_id + | Some fn -> + let (id,type_of_id), ctx = fn () in + make_judge id type_of_id, ctx | None -> (* In case the constants id/ID are not defined *) make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1))) - (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))) + (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))), + Univ.ContextSet.empty diff --git a/pretyping/termops.mli b/pretyping/termops.mli index d0d3fd767e..eec4a9b9d8 100644 --- a/pretyping/termops.mli +++ b/pretyping/termops.mli @@ -13,18 +13,6 @@ open Context open Environ open Locus -(** TODO: merge this with Term *) - -(** Universes *) -val new_univ_level : unit -> Univ.universe_level -val set_remote_new_univ_level : Univ.universe_level RemoteCounter.installer -val new_univ : unit -> Univ.universe -val new_sort_in_family : sorts_family -> sorts -val new_Type : unit -> types -val new_Type_sort : unit -> sorts -val refresh_universes : types -> types -val refresh_universes_strict : types -> types - (** printers *) val print_sort : sorts -> std_ppcmds val pr_sort_family : sorts_family -> std_ppcmds @@ -120,6 +108,8 @@ val free_rels : constr -> Int.Set.t (** [dependent m t] tests whether [m] is a subterm of [t] *) val dependent : constr -> constr -> bool val dependent_no_evar : constr -> constr -> bool +val dependent_univs : constr -> constr -> bool +val dependent_univs_no_evar : constr -> constr -> bool val count_occurrences : constr -> constr -> int val collect_metas : constr -> int list val collect_vars : constr -> Id.Set.t (** for visible vars only *) @@ -168,7 +158,7 @@ val subst_closed_term_occ_gen : required too *) type 'a testing_function = { - match_fun : constr -> 'a; + match_fun : 'a -> constr -> 'a; merge_fun : 'a -> 'a -> 'a; mutable testing_state : 'a; mutable last_found : ((Id.t * hyp_location_flag) option * int * constr) option @@ -290,5 +280,5 @@ val on_judgment_value : (types -> types) -> unsafe_judgment -> unsafe_judgment val on_judgment_type : (types -> types) -> unsafe_judgment -> unsafe_judgment (** {6 Functions to deal with impossible cases } *) -val set_impossible_default_clause : constr * types -> unit -val coq_unit_judge : unit -> unsafe_judgment +val set_impossible_default_clause : (unit -> (constr * types) Univ.in_universe_context_set) -> unit +val coq_unit_judge : unit -> unsafe_judgment Univ.in_universe_context_set diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index b5735bc646..fac73670bb 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -20,7 +20,6 @@ open Typeclasses_errors open Libobject (*i*) - let (add_instance_hint, add_instance_hint_hook) = Hook.make () let add_instance_hint id = Hook.get add_instance_hint id @@ -64,6 +63,7 @@ type instance = { -1 for discard, 0 for none, mutable to avoid redeclarations when multiple rebuild_object happen. *) is_global: int; + is_poly: bool; is_impl: global_reference; } @@ -73,7 +73,7 @@ let instance_impl is = is.is_impl let instance_priority is = is.is_pri -let new_instance cl pri glob impl = +let new_instance cl pri glob poly impl = let global = if glob then Lib.sections_depth () else -1 @@ -81,6 +81,7 @@ let new_instance cl pri glob impl = { is_class = cl.cl_impl; is_pri = pri ; is_global = global ; + is_poly = poly; is_impl = impl } (* @@ -90,12 +91,35 @@ let new_instance cl pri glob impl = let classes : typeclasses ref = Summary.ref Refmap.empty ~name:"classes" let instances : instances ref = Summary.ref Refmap.empty ~name:"instances" +open Declarations + +let typeclass_univ_instance (cl,u') = + let subst = + let u = + match cl.cl_impl with + | ConstRef c -> + let cb = Global.lookup_constant c in + if cb.const_polymorphic then Univ.UContext.instance (Future.force cb.const_universes) + else Univ.Instance.empty + | IndRef c -> + let mib,oib = Global.lookup_inductive c in + if mib.mind_polymorphic then Univ.UContext.instance mib.mind_universes + else Univ.Instance.empty + | _ -> Univ.Instance.empty + in Array.fold_left2 (fun subst u u' -> Univ.LMap.add u u' subst) + Univ.LMap.empty (Univ.Instance.to_array u) (Univ.Instance.to_array u') + in + let subst_ctx = Context.map_rel_context (subst_univs_level_constr subst) in + { cl with cl_context = fst cl.cl_context, subst_ctx (snd cl.cl_context); + cl_props = subst_ctx cl.cl_props}, u' + let class_info c = try Refmap.find c !classes - with Not_found -> not_a_class (Global.env()) (constr_of_global c) + with Not_found -> not_a_class (Global.env()) (printable_constr_of_global c) let global_class_of_constr env c = - try class_info (global_of_constr c) + try let gr, u = Universes.global_of_constr c in + class_info gr, u with Not_found -> not_a_class env c let dest_class_app env c = @@ -110,16 +134,19 @@ let class_of_constr c = try Some (dest_class_arity (Global.env ()) c) with e when Errors.noncritical e -> None -let rec is_class_type evd c = - match kind_of_term c with - | Prod (_, _, t) -> is_class_type evd t - | Evar (e, _) when is_defined evd e -> is_class_type evd (Evarutil.nf_evar evd c) - | _ -> - begin match class_of_constr c with - | Some _ -> true - | None -> false - end +let is_class_constr c = + try let gr, u = Universes.global_of_constr c in + Refmap.mem gr !classes + with Not_found -> false +let rec is_class_type evd c = + let c, args = decompose_app c in + match kind_of_term c with + | Prod (_, _, t) -> is_class_type evd t + | Evar (e, _) when Evd.is_defined evd e -> + is_class_type evd (Evarutil.whd_head_evar evd c) + | _ -> is_class_constr c + let is_class_evar evd evi = is_class_type evd evi.Evd.evar_concl @@ -133,7 +160,7 @@ let load_class (_, cl) = let cache_class = load_class let subst_class (subst,cl) = - let do_subst_con c = fst (Mod_subst.subst_con subst c) + let do_subst_con c = Mod_subst.subst_constant subst c and do_subst c = Mod_subst.subst_mps subst c and do_subst_gr gr = fst (subst_global subst gr) in let do_subst_ctx ctx = List.smartmap @@ -142,7 +169,8 @@ let subst_class (subst,cl) = let do_subst_context (grs,ctx) = List.smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs, do_subst_ctx ctx in - let do_subst_projs projs = List.smartmap (fun (x, y, z) -> (x, y, Option.smartmap do_subst_con z)) projs in + let do_subst_projs projs = List.smartmap (fun (x, y, z) -> + (x, y, Option.smartmap do_subst_con z)) projs in { cl_impl = do_subst_gr cl.cl_impl; cl_context = do_subst_context cl.cl_context; cl_props = do_subst_ctx cl.cl_props; @@ -174,7 +202,7 @@ let discharge_class (_,cl) = let newgrs = List.map (fun (_, _, t) -> match class_of_constr t with | None -> None - | Some (_, (tc, _)) -> Some (tc.cl_impl, true)) + | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true)) ctx' in List.smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs @@ -182,7 +210,7 @@ let discharge_class (_,cl) = in grs', discharge_rel_context subst 1 ctx @ ctx' in let cl_impl' = Lib.discharge_global cl.cl_impl in if cl_impl' == cl.cl_impl then cl else - let ctx = abs_context cl in + let ctx, uctx = abs_context cl in let ctx, subst = rel_of_variable_context ctx in let context = discharge_context ctx subst cl.cl_context in let props = discharge_rel_context subst (succ (List.length (fst cl.cl_context))) cl.cl_props in @@ -217,7 +245,7 @@ let check_instance env sigma c = try let (evd, c) = resolve_one_typeclass env sigma (Retyping.get_type_of env sigma c) in - Evd.has_undefined evd + not (Evd.has_undefined evd) with e when Errors.noncritical e -> false let build_subclasses ~check env sigma glob pri = @@ -231,7 +259,7 @@ let build_subclasses ~check env sigma glob pri = let ty = Evarutil.nf_evar sigma (Retyping.get_type_of env sigma c) in match class_of_constr ty with | None -> [] - | Some (rels, (tc, args)) -> + | Some (rels, ((tc,u), args)) -> let instapp = Reductionops.whd_beta sigma (appvectc c (Termops.extended_rel_vect 0 rels)) in @@ -243,7 +271,7 @@ let build_subclasses ~check env sigma glob pri = | Some (Backward, _) -> None | Some (Forward, pri') -> let proj = Option.get proj in - let body = it_mkLambda_or_LetIn (mkApp (mkConst proj, projargs)) rels in + let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in if check && check_instance env sigma body then None else let pri = @@ -259,7 +287,7 @@ let build_subclasses ~check env sigma glob pri = let rest = aux pri body path' in hints @ (path', pri, body) :: rest in List.fold_left declare_proj [] projs - in aux pri (constr_of_global glob) [glob] + in aux pri (Universes.constr_of_global glob) [glob] (* * instances persistent object @@ -305,9 +333,11 @@ let discharge_instance (_, (action, inst)) = let is_local i = Int.equal i.is_global (-1) let add_instance check inst = - add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] (is_local inst) inst.is_pri; + let poly = Global.is_polymorphic inst.is_impl in + add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] (is_local inst) + inst.is_pri poly; List.iter (fun (path, pri, c) -> add_instance_hint (IsConstr c) path - (is_local inst) pri) + (is_local inst) pri poly) (build_subclasses ~check:(check && not (isVarRef inst.is_impl)) (Global.env ()) Evd.empty inst.is_impl inst.is_pri) @@ -342,11 +372,10 @@ let remove_instance i = remove_instance_hint i.is_impl let declare_instance pri local glob = - let c = constr_of_global glob in - let ty = Retyping.get_type_of (Global.env ()) Evd.empty c in + let ty = Global.type_of_global_unsafe (*FIXME*) glob in match class_of_constr ty with - | Some (rels, (tc, args) as _cl) -> - add_instance (new_instance tc pri (not local) glob) + | Some (rels, ((tc,_), args) as _cl) -> + add_instance (new_instance tc pri (not local) (Flags.use_polymorphic_flag ()) glob) (* let path, hints = build_subclasses (not local) (Global.env ()) Evd.empty glob in *) (* let entries = List.map (fun (path, pri, c) -> (pri, local, path, c)) hints in *) (* Auto.add_hints local [typeclasses_db] (Auto.HintsResolveEntry entries); *) @@ -367,9 +396,9 @@ let add_class cl = open Declarations - +(* FIXME: deal with universe instances *) let add_constant_class cst = - let ty = Typeops.type_of_constant (Global.env ()) cst in + let ty = Typeops.type_of_constant_in (Global.env ()) (cst,Univ.Instance.empty) in let ctx, arity = decompose_prod_assum ty in let tc = { cl_impl = ConstRef cst; @@ -386,7 +415,8 @@ let add_inductive_class ind = let ctx = oneind.mind_arity_ctxt in let ty = Inductive.type_of_inductive_knowing_parameters (push_rel_context ctx (Global.env ())) - oneind (Array.map (fun x -> lazy x) (Termops.extended_rel_vect 0 ctx)) + ((mind,oneind),Univ.Instance.empty) + (Array.map (fun x -> lazy x) (Termops.extended_rel_vect 0 ctx)) in { cl_impl = IndRef ind; cl_context = List.map (const None) ctx, ctx; @@ -398,7 +428,7 @@ let add_inductive_class ind = * interface functions *) -let instance_constructor cl args = +let instance_constructor (cl,u) args = let filter (_, b, _) = match b with | None -> true | Some _ -> false @@ -406,14 +436,17 @@ let instance_constructor cl args = let lenpars = List.length (List.filter filter (snd cl.cl_context)) in let pars = fst (List.chop lenpars args) in match cl.cl_impl with - | IndRef ind -> Some (applistc (mkConstruct (ind, 1)) args), - applistc (mkInd ind) pars + | IndRef ind -> + let ind = ind, u in + (Some (applistc (mkConstructUi (ind, 1)) args), + applistc (mkIndU ind) pars) | ConstRef cst -> + let cst = cst, u in let term = match args with - | [] -> None - | _ -> Some (List.last args) + | [] -> None + | _ -> Some (List.last args) in - term, applistc (mkConst cst) pars + (term, applistc (mkConstU cst) pars) | _ -> assert false let typeclasses () = Refmap.fold (fun _ l c -> l :: c) !classes [] @@ -504,12 +537,19 @@ let mark_resolvables sigma = mark_resolvability all_evars true sigma let has_typeclasses filter evd = let check ev evi = - filter ev (snd evi.evar_source) && is_class_evar evd evi && is_resolvable evi + filter ev (snd evi.evar_source) && is_resolvable evi && is_class_evar evd evi in Evar.Map.exists check (Evd.undefined_map evd) let solve_instanciations_problem = ref (fun _ _ _ _ _ -> assert false) +let solve_problem env evd filter split fail = + !solve_instanciations_problem env evd filter split fail + +(** Profiling resolution of typeclasses *) +(* let solve_classeskey = Profile.declare_profile "solve_typeclasses" *) +(* let solve_problem = Profile.profile5 solve_classeskey solve_problem *) + let resolve_typeclasses ?(filter=no_goals) ?(split=true) ?(fail=true) env evd = if not (has_typeclasses filter evd) then evd - else !solve_instanciations_problem env evd filter split fail + else solve_problem env evd filter split fail diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index c362935253..a8ce9ca7c9 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -48,18 +48,24 @@ val add_constant_class : constant -> unit val add_inductive_class : inductive -> unit -val new_instance : typeclass -> int option -> bool -> global_reference -> instance +val new_instance : typeclass -> int option -> bool -> Decl_kinds.polymorphic -> + global_reference -> instance val add_instance : instance -> unit val remove_instance : instance -> unit val class_info : global_reference -> typeclass (** raises a UserError if not a class *) -(** These raise a UserError if not a class. *) -val dest_class_app : env -> constr -> typeclass * constr list +(** These raise a UserError if not a class. + Caution: the typeclass structures is not instantiated w.r.t. the universe instance. + This is done separately by typeclass_univ_instance. *) +val dest_class_app : env -> constr -> typeclass puniverses * constr list + +(** Get the instantiated typeclass structure for a given universe instance. *) +val typeclass_univ_instance : typeclass puniverses -> typeclass puniverses (** Just return None if not a class *) -val class_of_constr : constr -> (rel_context * (typeclass * constr list)) option +val class_of_constr : constr -> (rel_context * (typeclass puniverses * constr list)) option val instance_impl : instance -> global_reference @@ -73,7 +79,8 @@ val is_implicit_arg : Evar_kinds.t -> bool (** Returns the term and type for the given instance of the parameters and fields of the type class. *) -val instance_constructor : typeclass -> constr list -> constr option * types +val instance_constructor : typeclass puniverses -> constr list -> + constr option * types (** Filter which evars to consider for resolution. *) type evar_filter = existential_key -> Evar_kinds.t -> bool @@ -104,10 +111,10 @@ val classes_transparent_state : unit -> transparent_state val add_instance_hint_hook : (global_reference_or_constr -> global_reference list -> - bool (* local? *) -> int option -> unit) Hook.t + bool (* local? *) -> int option -> Decl_kinds.polymorphic -> unit) Hook.t val remove_instance_hint_hook : (global_reference -> unit) Hook.t val add_instance_hint : global_reference_or_constr -> global_reference list -> - bool -> int option -> unit + bool -> int option -> Decl_kinds.polymorphic -> unit val remove_instance_hint : global_reference -> unit val solve_instanciations_problem : (env -> evar_map -> evar_filter -> bool -> bool -> evar_map) ref diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 0cd9099e35..bd559ddd58 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -27,12 +27,12 @@ let meta_type evd mv = let constant_type_knowing_parameters env cst jl = let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in - type_of_constant_knowing_parameters env (constant_type env cst) paramstyp + type_of_constant_knowing_parameters env (constant_type_in env cst) paramstyp -let inductive_type_knowing_parameters env ind jl = - let (mib,mip) = lookup_mind_specif env ind in +let inductive_type_knowing_parameters env (ind,u) jl = + let mspec = lookup_mind_specif env ind in let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in - Inductive.type_of_inductive_knowing_parameters env mip paramstyp + Inductive.type_of_inductive_knowing_parameters env (mspec,u) paramstyp let e_type_judgment env evdref j = match kind_of_term (whd_betadeltaiota env !evdref j.uj_type) with @@ -69,12 +69,12 @@ let e_judge_of_apply env evdref funj argjv = in apply_rec 1 funj.uj_type (Array.to_list argjv) -let e_check_branch_types env evdref ind cj (lfj,explft) = +let e_check_branch_types env evdref (ind,u) cj (lfj,explft) = if not (Int.equal (Array.length lfj) (Array.length explft)) then error_number_branches env cj (Array.length explft); for i = 0 to Array.length explft - 1 do if not (Evarconv.e_cumul env evdref lfj.(i).uj_type explft.(i)) then - error_ill_formed_branch env cj.uj_val (ind,i+1) lfj.(i).uj_type explft.(i) + error_ill_formed_branch env cj.uj_val ((ind,i+1),u) lfj.(i).uj_type explft.(i) done let max_sort l = @@ -95,8 +95,8 @@ let e_is_correct_arity env evdref c pj ind specif params = if not (Sorts.List.mem (Sorts.family s) allowed_sorts) then error () | Evar (ev,_), [] -> - let s = Termops.new_sort_in_family (max_sort allowed_sorts) in - evdref := Evd.define ev (mkSort s) !evdref + let evd, s = Evd.fresh_sort_in_family env !evdref (max_sort allowed_sorts) in + evdref := Evd.define ev (mkSort s) evd | _, (_,Some _,_ as d)::ar' -> srec (push_rel d env) (lift 1 pt') ar' | _ -> @@ -105,7 +105,7 @@ let e_is_correct_arity env evdref c pj ind specif params = srec env pj.uj_type (List.rev arsign) let e_type_case_branches env evdref (ind,largs) pj c = - let specif = lookup_mind_specif env ind in + let specif = lookup_mind_specif env (fst ind) in let nparams = inductive_params specif in let (params,realargs) = List.chop nparams largs in let p = pj.uj_val in @@ -126,10 +126,11 @@ let e_judge_of_case env evdref ci pj cj lfj = { uj_val = mkCase (ci, pj.uj_val, cj.uj_val, Array.map j_val lfj); uj_type = rslty } +(* FIXME: might depend on the level of actual parameters!*) let check_allowed_sort env sigma ind c p = let pj = Retyping.get_judgment_of env sigma p in let ksort = family_of_sort (sort_of_arity env sigma pj.uj_type) in - let specif = Global.lookup_inductive ind in + let specif = Global.lookup_inductive (fst ind) in let sorts = elim_sorts specif in if not (List.exists ((==) ksort) sorts) then let s = inductive_sort_family (snd specif) in @@ -196,7 +197,11 @@ let rec execute env evdref cstr = judge_of_prop_contents c | Sort (Type u) -> - judge_of_type u + judge_of_type u + + | Proj (p, c) -> + let cj = execute env evdref c in + judge_of_projection env p (Evarutil.j_nf_evar !evdref cj) | App (f,args) -> let jl = execute_array env evdref args in @@ -236,7 +241,7 @@ let rec execute env evdref cstr = let j1 = execute env evdref c1 in let j2 = execute env evdref c2 in let j2 = e_type_judgment env evdref j2 in - let _ = judge_of_cast env j1 DEFAULTcast j2 in + let _ = e_judge_of_cast env evdref j1 DEFAULTcast j2 in let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in let j3 = execute env1 evdref c3 in judge_of_letin env name j1 j2 j3 @@ -268,9 +273,7 @@ let check env evd c t = let type_of env evd c = let j = execute env (ref evd) c in - (* We are outside the kernel: we take fresh universes *) - (* to avoid tactics and co to refresh universes themselves *) - Termops.refresh_universes j.uj_type + j.uj_type (* Sort of a type *) @@ -286,7 +289,7 @@ let e_type_of env evd c = let evdref = ref evd in let j = execute env evdref c in (* side-effect on evdref *) - !evdref, Termops.refresh_universes j.uj_type + !evdref, j.uj_type let solve_evars env evdref c = let c = (execute env evdref c).uj_val in diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 084bdbc4f1..8b194a9c9a 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -34,5 +34,5 @@ val solve_evars : env -> evar_map ref -> constr -> constr (** Raise an error message if incorrect elimination for this inductive *) (** (first constr is term to match, second is return predicate) *) -val check_allowed_sort : env -> evar_map -> inductive -> constr -> constr -> +val check_allowed_sort : env -> evar_map -> pinductive -> constr -> constr -> unit diff --git a/pretyping/unification.ml b/pretyping/unification.ml index bfcc469c54..f7379b4a0e 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -33,7 +33,9 @@ let occur_meta_or_undefined_evar evd c = | Evar_defined c -> occrec c; Array.iter occrec args | Evar_empty -> raise Occur) - | Sort s when is_sort_variable evd s -> raise Occur + (* | Sort (Type _) (\* FIXME could be finer *\) -> raise Occur *) + | Const (_, i) (* | Ind (_, i) | Construct (_, i) *) + when not (Univ.Instance.is_empty i) -> raise Occur | _ -> iter_constr occrec c in try occrec c; false with Occur | Not_found -> true @@ -49,16 +51,19 @@ let occur_meta_evd sigma mv c = (* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms, gives [x1:A1]..[xn:An]c' such that c converts to ([x1:A1]..[xn:An]c' l) *) -let abstract_scheme env c l lname_typ = +let abstract_scheme env evd c l lname_typ = List.fold_left2 - (fun t (locc,a) (na,_,ta) -> + (fun (t,evd) (locc,a) (na,_,ta) -> let na = match kind_of_term a with Var id -> Name id | _ -> na in (* [occur_meta ta] test removed for support of eelim/ecase but consequences are unclear... if occur_meta ta then error "cannot find a type for the generalisation" - else *) if occur_meta a then mkLambda_name env (na,ta,t) - else mkLambda_name env (na,ta,subst_closed_term_occ locc a t)) - c + else *) + if occur_meta a then mkLambda_name env (na,ta,t), evd + else + let t', evd' = Tacred.subst_closed_term_univs_occ evd locc a t in + mkLambda_name env (na,ta,t'), evd') + (c,evd) (List.rev l) lname_typ @@ -67,15 +72,15 @@ let abstract_scheme env c l lname_typ = let abstract_list_all env evd typ c l = let ctxt,_ = splay_prod_n env evd (List.length l) typ in let l_with_all_occs = List.map (function a -> (AllOccurrences,a)) l in - let p = abstract_scheme env c l_with_all_occs ctxt in - let typp = - try Typing.type_of env evd p + let p,evd = abstract_scheme env evd c l_with_all_occs ctxt in + let evd,typp = + try Typing.e_type_of env evd p with | UserError _ -> error_cannot_find_well_typed_abstraction env evd p l None | Type_errors.TypeError (env',x) -> error_cannot_find_well_typed_abstraction env evd p l (Some (env',x)) in - (p,typp) + evd,(p,typp) let set_occurrences_of_last_arg args = Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args) @@ -88,7 +93,7 @@ let abstract_list_all_with_dependencies env evd typ c l = Evarconv.second_order_matching empty_transparent_state env evd ev' argoccs c in let p = nf_evar evd (existential_value evd (destEvar ev)) in - if b then p else error_cannot_find_well_typed_abstraction env evd p l None + if b then evd, p else error_cannot_find_well_typed_abstraction env evd p l None (**) @@ -251,11 +256,12 @@ type unify_flags = { (* Default flag for unifying a type against a type (e.g. apply) *) (* We set all conversion flags (no flag should be modified anymore) *) -let default_unify_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; +let default_unify_flags () = + let ts = Names.full_transparent_state in + { modulo_conv_on_closed_terms = Some ts; use_metas_eagerly_in_conv_on_closed_terms = true; - modulo_delta = full_transparent_state; - modulo_delta_types = full_transparent_state; + modulo_delta = ts; + modulo_delta_types = ts; modulo_delta_in_merge = None; check_applied_meta_types = true; resolve_evars = false; @@ -279,7 +285,7 @@ let set_merge_flags flags = (* type against a type (e.g. apply) *) (* We set only the flags available at the time the new "apply" extends *) (* out of "simple apply" *) -let default_no_delta_unify_flags = { default_unify_flags with +let default_no_delta_unify_flags () = { (default_unify_flags ()) with modulo_delta = empty_transparent_state; check_applied_meta_types = false; use_pattern_unification = false; @@ -292,13 +298,13 @@ let default_no_delta_unify_flags = { default_unify_flags with (* allow_K) because only closed terms are involved in *) (* induction/destruct/case/elim and w_unify_to_subterm_list does not *) (* call w_unify for induction/destruct/case/elim (13/6/2011) *) -let elim_flags = { default_unify_flags with +let elim_flags () = { (default_unify_flags ()) with restrict_conv_on_strict_subterms = false; (* ? *) modulo_betaiota = false; allow_K_in_toplevel_higher_order_unification = true } -let elim_no_delta_flags = { elim_flags with +let elim_no_delta_flags () = { (elim_flags ()) with modulo_delta = empty_transparent_state; check_applied_meta_types = false; use_pattern_unification = false; @@ -314,10 +320,28 @@ let use_metas_pattern_unification flags nb l = flags.use_meta_bound_pattern_unification) && Array.for_all (fun c -> isRel c && destRel c <= nb) l -let expand_key env = function - | Some (ConstKey cst) -> constant_opt_value env cst - | Some (VarKey id) -> (try named_body id env with Not_found -> None) - | Some (RelKey _) -> None +type key = + | IsKey of Closure.table_key + | IsProj of constant * constr + +let expand_table_key env = function + | ConstKey cst -> constant_opt_value_in env cst + | VarKey id -> (try named_body id env with Not_found -> None) + | RelKey _ -> None + +let unfold_projection env p stk = + (match try Some (lookup_projection p env) with Not_found -> None with + | Some pb -> + let s = Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) in + s :: stk + | None -> assert false) + +let expand_key ts env sigma = function + | Some (IsKey k) -> expand_table_key env k + | Some (IsProj (p, c)) -> + let red = Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma + Cst_stack.empty (c, unfold_projection env p []))) + in if eq_constr (mkProj (p, c)) red then None else Some red | None -> None let subterm_restriction is_subterm flags = @@ -326,14 +350,24 @@ let subterm_restriction is_subterm flags = let key_of env b flags f = if subterm_restriction b flags then None else match kind_of_term f with - | Const cst when is_transparent env (ConstKey cst) && - Cpred.mem cst (snd flags.modulo_delta) -> - Some (ConstKey cst) - | Var id when is_transparent env (VarKey id) && - Id.Pred.mem id (fst flags.modulo_delta) -> - Some (VarKey id) + | Const (cst, u) when Cpred.mem cst (snd flags.modulo_delta) -> + Some (IsKey (ConstKey (cst, u))) + | Var id when Id.Pred.mem id (fst flags.modulo_delta) -> + Some (IsKey (VarKey id)) + | Proj (p, c) when Cpred.mem p (snd flags.modulo_delta) -> + Some (IsProj (p, c)) | _ -> None + +let translate_key = function + | ConstKey (cst,u) -> ConstKey cst + | VarKey id -> VarKey id + | RelKey n -> RelKey n + +let translate_key = function + | IsKey k -> translate_key k + | IsProj (c, _) -> ConstKey c + let oracle_order env cf1 cf2 = match cf1 with | None -> @@ -344,8 +378,36 @@ let oracle_order env cf1 cf2 = match cf2 with | None -> Some true | Some k2 -> - Some (Conv_oracle.oracle_order (Environ.oracle env) false k1 k2) + Some (Conv_oracle.oracle_order (Environ.oracle env) false (translate_key k1) (translate_key k2)) + +let is_rigid_head flags t = + match kind_of_term t with + | Const (cst,u) -> not (Cpred.mem cst (snd flags.modulo_delta)) + | Ind (i,u) -> true + | _ -> false +let force_eqs c = + Univ.UniverseConstraints.fold + (fun ((l,d,r) as c) acc -> + let c' = if d == Univ.ULub then (l,Univ.UEq,r) else c in + Univ.UniverseConstraints.add c' acc) + c Univ.UniverseConstraints.empty + +let constr_cmp pb sigma flags t u = + let b, cstrs = + if pb == Reduction.CONV then eq_constr_universes t u + else leq_constr_universes t u + in + if b then + try Evd.add_universe_constraints sigma cstrs, b + with Univ.UniverseInconsistency _ -> sigma, false + | Evd.UniversesDiffer -> + if is_rigid_head flags t then + try Evd.add_universe_constraints sigma (force_eqs cstrs), b + with Univ.UniverseInconsistency _ -> sigma, false + else sigma, false + else sigma, b + let do_reduce ts (env, nb) sigma c = Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma Cst_stack.empty (c, Stack.empty))) @@ -356,14 +418,14 @@ let isAllowedEvar flags c = match kind_of_term c with | Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars) | _ -> false -let check_compatibility env (sigma,metasubst,evarsubst) tyM tyN = +let check_compatibility env flags (sigma,metasubst,evarsubst) tyM tyN = match subst_defined_metas metasubst tyM with | None -> () | Some m -> match subst_defined_metas metasubst tyN with | None -> () | Some n -> - if not (is_trans_fconv CONV full_transparent_state env sigma m n) + if not (is_trans_fconv CONV flags.modulo_delta env sigma m n) && is_ground_term sigma m && is_ground_term sigma n then error_cannot_unify env sigma (m,n) @@ -379,7 +441,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag if wt && flags.check_applied_meta_types then (let tyM = Typing.meta_type sigma k1 in let tyN = Typing.meta_type sigma k2 in - check_compatibility curenv substn tyM tyN); + check_compatibility curenv flags substn tyM tyN); if k2 < k1 then sigma,(k1,cN,stN)::metasubst,evarsubst else sigma,(k2,cM,stM)::metasubst,evarsubst | Meta k, _ @@ -388,7 +450,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag (try let tyM = Typing.meta_type sigma k in let tyN = get_type_of curenv ~lax:true sigma cN in - check_compatibility curenv substn tyM tyN + check_compatibility curenv flags substn tyM tyN with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) ()); (* Here we check that [cN] does not contain any local variables *) @@ -405,7 +467,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag (try let tyM = get_type_of curenv ~lax:true sigma cM in let tyN = Typing.meta_type sigma k in - check_compatibility curenv substn tyM tyN + check_compatibility curenv flags substn tyM tyN with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) ()); (* Here we check that [cM] does not contain any local variables *) @@ -431,7 +493,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag | Sort s1, Sort s2 -> (try let sigma' = - if cv_pb == CUMUL + if pb == CUMUL then Evd.set_leq_sort sigma s1 s2 else Evd.set_eq_sort sigma s1 s2 in (sigma', metasubst, evarsubst) @@ -455,6 +517,8 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag unirec_rec (push (na,t2) curenvnb) CONV true wt substn (mkApp (lift 1 cM,[|mkRel 1|])) c2 + (* TODO: eta for records *) + | Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) -> (try Array.fold_left2 (unirec_rec curenvnb CONV true wt) @@ -493,6 +557,22 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag | App (f1,l1), App (f2,l2) -> unify_app curenvnb pb b substn cM f1 l1 cN f2 l2 + | Proj (p1,c1), Proj (p2,c2) -> + if eq_constant p1 p2 then + try + let c1, c2, substn = + if isCast c1 && isCast c2 then + let (c1,_,tc1) = destCast c1 in + let (c2,_,tc2) = destCast c2 in + c1, c2, unirec_rec curenvnb CONV true false substn tc1 tc2 + else c1, c2, substn + in + unirec_rec curenvnb CONV true wt substn c1 c2 + with ex when precatchable_exception ex -> + unify_not_same_head curenvnb pb b wt substn cM cN + else + unify_not_same_head curenvnb pb b wt substn cM cN + | _ -> unify_not_same_head curenvnb pb b wt substn cM cN @@ -508,20 +588,22 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag with ex when precatchable_exception ex -> expand curenvnb pb b false substn cM f1 l1 cN f2 l2 - and unify_not_same_head curenvnb pb b wt substn cM cN = + and unify_not_same_head curenvnb pb b wt (sigma, metas, evars as substn) cM cN = try canonical_projections curenvnb pb b cM cN substn with ex when precatchable_exception ex -> - if constr_cmp cv_pb cM cN then substn else - try reduce curenvnb pb b wt substn cM cN - with ex when precatchable_exception ex -> - let (f1,l1) = - match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in - let (f2,l2) = - match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in - expand curenvnb pb b wt substn cM f1 l1 cN f2 l2 + let sigma', b = constr_cmp cv_pb sigma flags cM cN in + if b then (sigma', metas, evars) + else + try reduce curenvnb pb b wt substn cM cN + with ex when precatchable_exception ex -> + let (f1,l1) = + match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in + let (f2,l2) = + match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in + expand curenvnb pb b wt substn cM f1 l1 cN f2 l2 and reduce curenvnb pb b wt (sigma, metas, evars as substn) cM cN = - if use_full_betaiota flags && not (subterm_restriction b flags) then + if not (subterm_restriction b flags) && use_full_betaiota flags then let cM' = do_reduce flags.modulo_delta curenvnb sigma cM in if not (eq_constr cM cM') then unirec_rec curenvnb pb b wt substn cM' cN @@ -530,12 +612,10 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag if not (eq_constr cN cN') then unirec_rec curenvnb pb b wt substn cM cN' else error_cannot_unify (fst curenvnb) sigma (cM,cN) - else - error_cannot_unify (fst curenvnb) sigma (cM,cN) + else error_cannot_unify (fst curenvnb) sigma (cM,cN) - and expand (curenv,_ as curenvnb) pb b wt (sigma,metasubst,_ as substn) cM f1 l1 cN f2 l2 = - - if + and expand (curenv,_ as curenvnb) pb b wt (sigma,metasubst,evarsubst as substn) cM f1 l1 cN f2 l2 = + let res = (* Try full conversion on meta-free terms. *) (* Back to 1995 (later on called trivial_unify in 2002), the heuristic was to apply conversion on meta-free (but not @@ -548,48 +628,50 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag (it is used by apply and rewrite); it might now be redundant with the support for delta-expansion (which is used essentially for apply)... *) - not (subterm_restriction b flags) && + if subterm_restriction b flags then None else match flags.modulo_conv_on_closed_terms with - | None -> false + | None -> None | Some convflags -> let subst = if flags.use_metas_eagerly_in_conv_on_closed_terms then metasubst else ms in match subst_defined_metas subst cM with - | None -> (* some undefined Metas in cM *) false + | None -> (* some undefined Metas in cM *) None | Some m1 -> match subst_defined_metas subst cN with - | None -> (* some undefined Metas in cN *) false + | None -> (* some undefined Metas in cN *) None | Some n1 -> (* No subterm restriction there, too much incompatibilities *) - if is_trans_fconv pb convflags env sigma m1 n1 - then true else - if is_ground_term sigma m1 && is_ground_term sigma n1 then - error_cannot_unify curenv sigma (cM,cN) - else false - then - substn - else + let b = check_conv ~pb ~ts:convflags env sigma m1 n1 in + if b then Some (sigma, metasubst, evarsubst) + else + if is_ground_term sigma m1 && is_ground_term sigma n1 then + error_cannot_unify curenv sigma (cM,cN) + else None + in + match res with + | Some substn -> substn + | None -> let cf1 = key_of env b flags f1 and cf2 = key_of env b flags f2 in match oracle_order curenv cf1 cf2 with | None -> error_cannot_unify curenv sigma (cM,cN) | Some true -> - (match expand_key curenv cf1 with + (match expand_key flags.modulo_delta curenv sigma cf1 with | Some c -> unirec_rec curenvnb pb b wt substn (whd_betaiotazeta sigma (mkApp(c,l1))) cN | None -> - (match expand_key curenv cf2 with + (match expand_key flags.modulo_delta curenv sigma cf2 with | Some c -> unirec_rec curenvnb pb b wt substn cM (whd_betaiotazeta sigma (mkApp(c,l2))) | None -> error_cannot_unify curenv sigma (cM,cN))) | Some false -> - (match expand_key curenv cf2 with + (match expand_key flags.modulo_delta curenv sigma cf2 with | Some c -> unirec_rec curenvnb pb b wt substn cM (whd_betaiotazeta sigma (mkApp(c,l2))) | None -> - (match expand_key curenv cf1 with + (match expand_key flags.modulo_delta curenv sigma cf1 with | Some c -> unirec_rec curenvnb pb b wt substn (whd_betaiotazeta sigma (mkApp(c,l1))) cN @@ -623,11 +705,12 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag else error_cannot_unify (fst curenvnb) sigma (cM,cN) and solve_canonical_projection curenvnb pb b cM f1l1 cN f2l2 (sigma,ms,es) = - let (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = + let (ctx,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = try Evarconv.check_conv_record f1l1 f2l2 with Not_found -> error_cannot_unify (fst curenvnb) sigma (cM,cN) in if Reductionops.Stack.compare_shape ts ts1 then + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in let (evd,ks,_) = List.fold_left (fun (evd,ks,m) b -> @@ -652,19 +735,24 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag else error_cannot_unify (fst curenvnb) sigma (cM,cN) in let evd = sigma in - if (if occur_meta_or_undefined_evar evd m || occur_meta_or_undefined_evar evd n - || subterm_restriction conv_at_top flags then false - else if (match flags.modulo_conv_on_closed_terms with - | Some convflags -> is_trans_fconv cv_pb convflags env sigma m n - | _ -> constr_cmp cv_pb m n) then true - else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with + let res = + if occur_meta_or_undefined_evar evd m || occur_meta_or_undefined_evar evd n + || subterm_restriction conv_at_top flags then None + else + let sigma, b = match flags.modulo_conv_on_closed_terms with + | Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma m n + | _ -> constr_cmp cv_pb sigma flags m n in + if b then Some sigma + else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with | Some (cv_id, cv_k), (dl_id, dl_k) -> Id.Pred.subset dl_id cv_id && Cpred.subset dl_k cv_k | None,(dl_id, dl_k) -> Id.Pred.is_empty dl_id && Cpred.is_empty dl_k) - then error_cannot_unify env sigma (m, n) else false) - then subst - else unirec_rec (env,0) cv_pb conv_at_top false subst m n + then error_cannot_unify env sigma (m, n) else None + in + match res with + | Some sigma -> sigma, ms, es + | None -> unirec_rec (env,0) cv_pb conv_at_top false subst m n let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env @@ -792,7 +880,7 @@ let applyHead env evd n c = let is_mimick_head ts f = match kind_of_term f with - | Const c -> not (Closure.is_transparent_constant ts c) + | Const (c,u) -> not (Closure.is_transparent_constant ts c) | Var id -> not (Closure.is_transparent_variable ts id) | (Rel _|Construct _|Ind _) -> true | _ -> false @@ -820,7 +908,7 @@ let w_coerce env evd mv c = w_coerce_to_type env evd c cty mvty let unify_to_type env sigma flags c status u = - let c = refresh_universes c in + let sigma, c = refresh_universes false sigma c in let t = get_type_of env sigma (nf_meta sigma c) in let t = nf_betaiota sigma (nf_meta sigma t) in unify_0 env sigma CUMUL flags t u @@ -957,7 +1045,7 @@ let w_merge env with_types flags (evd,metas,evars) = (* merge constraints *) w_merge_rec evd (order_metas metas) (List.rev evars) [] -let w_unify_meta_types env ?(flags=default_unify_flags) evd = +let w_unify_meta_types env ?(flags=default_unify_flags ()) evd = let metas,evd = retract_coercible_metas evd in w_merge env true flags (evd,metas,[]) @@ -1032,7 +1120,7 @@ let iter_fail f a = (* Tries to find an instance of term [cl] in term [op]. Unifies [cl] to every subterm of [op] until it finds a match. Fails if no match is found *) -let w_unify_to_subterm env evd ?(flags=default_unify_flags) (op,cl) = +let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = let rec matchrec cl = let cl = strip_outer_cast cl in (try @@ -1061,6 +1149,8 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags) (op,cl) = with ex when precatchable_exception ex -> matchrec c2) + | Proj (p,c) -> matchrec c + | Fix(_,(_,types,terms)) -> (try iter_fail matchrec types @@ -1092,7 +1182,7 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags) (op,cl) = (* Tries to find all instances of term [cl] in term [op]. Unifies [cl] to every subterm of [op] and return all the matches. Fails if no match is found *) -let w_unify_to_subterm_all env evd ?(flags=default_unify_flags) (op,cl) = +let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = let return a b = let (evd,c as a) = a () in if List.exists (fun (evd',c') -> eq_constr c c') b then b else a :: b @@ -1130,6 +1220,8 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags) (op,cl) = | Case(_,_,c,lf) -> (* does not search in the predicate *) bind (matchrec c) (bind_iter matchrec lf) + | Proj (p,c) -> matchrec c + | LetIn(_,c1,_,c2) -> bind (matchrec c1) (matchrec c2) @@ -1173,7 +1265,8 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = List.exists (fun op -> eq_constr op cl) l then error_non_linear_unification env evd hdmeta cl else (evd',cl::l) - else if flags.allow_K_in_toplevel_higher_order_unification || dependent op t + else if flags.allow_K_in_toplevel_higher_order_unification + || dependent_univs op t then (evd,op::l) else @@ -1187,15 +1280,24 @@ let secondOrderAbstraction env evd flags typ (p, oplist) = let flags = { flags with modulo_delta = (fst flags.modulo_delta, Cpred.empty) } in let (evd',cllist) = w_unify_to_subterm_list env evd flags p oplist typ in let typp = Typing.meta_type evd' p in - let pred,predtyp = abstract_list_all env evd' typp typ cllist in - if not (is_conv_leq env evd predtyp typp) then - error_wrong_abstraction_type env evd - (Evd.meta_name evd p) pred typp predtyp; - w_merge env false flags (evd',[p,pred,(Conv,TypeProcessed)],[]) + let evd',(pred,predtyp) = abstract_list_all env evd' typp typ cllist in + let evd', b = infer_conv ~pb:CUMUL env evd' predtyp typp in + if not b then + error_wrong_abstraction_type env evd' + (Evd.meta_name evd p) pred typp predtyp; + w_merge env false flags (evd',[p,pred,(Conv,TypeProcessed)],[]) + + (* let evd',metas,evars = *) + (* try unify_0 env evd' CUMUL flags predtyp typp *) + (* with NotConvertible -> *) + (* error_wrong_abstraction_type env evd *) + (* (Evd.meta_name evd p) pred typp predtyp *) + (* in *) + (* w_merge env false flags (evd',(p,pred,(Conv,TypeProcessed))::metas,evars) *) let secondOrderDependentAbstraction env evd flags typ (p, oplist) = let typp = Typing.meta_type evd p in - let pred = abstract_list_all_with_dependencies env evd typp typ oplist in + let evd, pred = abstract_list_all_with_dependencies env evd typp typ oplist in w_merge env false flags (evd,[p,pred,(Conv,TypeProcessed)],[]) let secondOrderAbstractionAlgo dep = @@ -1233,7 +1335,7 @@ let w_unify2 env evd flags dep cv_pb ty1 ty2 = Before, second-order was used if the type of Meta(1) and [x:A]t was convertible and first-order otherwise. But if failed if e.g. the type of Meta(1) had meta-variables in it. *) -let w_unify env evd cv_pb ?(flags=default_unify_flags) ty1 ty2 = +let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = let hd1,l1 = decompose_appvect (whd_nored evd ty1) in let hd2,l2 = decompose_appvect (whd_nored evd ty2) in let is_empty1 = Array.is_empty l1 in @@ -1267,3 +1369,14 @@ let w_unify env evd cv_pb ?(flags=default_unify_flags) ty1 ty2 = (* General case: try first order *) | _ -> w_typed_unify env evd cv_pb flags ty1 ty2 + +(* Profiling *) +(* let wunifkey = Profile.declare_profile "w_unify";; *) + +(* let w_unify env evd cv_pb flags ty1 ty2 = *) +(* w_unify env evd cv_pb ~flags:flags ty1 ty2 *) + +(* let w_unify = Profile.profile6 wunifkey w_unify *) + +(* let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = *) +(* w_unify env evd cv_pb flags ty1 ty2 *) diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 04e65b8622..3f93d817d2 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -27,11 +27,11 @@ type unify_flags = { allow_K_in_toplevel_higher_order_unification : bool } -val default_unify_flags : unify_flags -val default_no_delta_unify_flags : unify_flags +val default_unify_flags : unit -> unify_flags +val default_no_delta_unify_flags : unit -> unify_flags -val elim_flags : unify_flags -val elim_no_delta_flags : unify_flags +val elim_flags : unit -> unify_flags +val elim_no_delta_flags : unit -> unify_flags (** The "unique" unification fonction *) val w_unify : @@ -59,8 +59,7 @@ val w_coerce_to_type : env -> evar_map -> constr -> types -> types -> abstracts the terms in l over c to get a term of type t (exported for inv.ml) *) val abstract_list_all : - env -> evar_map -> constr -> constr -> constr list -> constr * types - + env -> evar_map -> constr -> constr -> constr list -> evar_map * (constr * types) (* For tracing *) @@ -77,3 +76,15 @@ val unify_0 : Environ.env -> Evd.evar_map * Evd.metabinding list * (Environ.env * Term.types Term.pexistential * Term.constr) list +val unify_0_with_initial_metas : + Evd.evar_map * Evd.metabinding list * + (Environ.env * Term.types Term.pexistential * Term.constr) list -> + bool -> + Environ.env -> + Evd.conv_pb -> + unify_flags -> + Term.types -> + Term.types -> + Evd.evar_map * Evd.metabinding list * + (Environ.env * Term.types Term.pexistential * Term.constr) list + diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index b2fa631cd8..16eeaa2932 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -55,9 +55,11 @@ 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 in +let type_constructor mind mib u typ params = + let s = ind_subst mind mib u in let ctyp = substl s typ in + let usubst = make_inductive_subst mib u in + let ctyp = subst_univs_constr usubst ctyp in let nparams = Array.length params in if Int.equal nparams 0 then ctyp else @@ -67,11 +69,11 @@ let type_constructor mind mib typ params = let construct_of_constr const env tag typ = - let (mind,_ as ind), allargs = find_rectype_a env typ in + let ((mind,_ as ind), u) as indu, allargs = find_rectype_a env typ in (* spiwack : here be a branch for specific decompilation handled by retroknowledge *) try if const then - ((retroknowledge Retroknowledge.get_vm_decompile_constant_info env (mkInd ind) tag), + ((retroknowledge Retroknowledge.get_vm_decompile_constant_info env (mkIndU indu) tag), typ) (*spiwack: this may need to be changed in case there are parameters in the type which may cause a constant value to have an arity. (type_constructor seems to be all about parameters actually) @@ -84,18 +86,19 @@ let construct_of_constr const env tag typ = let nparams = mib.mind_nparams in let i = invert_tag const tag mip.mind_reloc_tbl in let params = Array.sub allargs 0 nparams in - let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in - (mkApp(mkConstruct(ind,i), params), ctyp) + let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(i-1)) params in + (mkApp(mkConstructUi(indu,i), params), ctyp) let construct_of_constr_const env tag typ = fst (construct_of_constr true env tag typ) let construct_of_constr_block = construct_of_constr false +(* FIXME: treatment of universes *) let constr_type_of_idkey env idkey = match idkey with | ConstKey cst -> - mkConst cst, Typeops.type_of_constant env cst + mkConst cst, (Environ.lookup_constant cst env).const_type | VarKey id -> let (_,_,ty) = lookup_named id env in mkVar id, ty @@ -104,17 +107,17 @@ let constr_type_of_idkey env idkey = let (_,_,ty) = lookup_rel n env in mkRel n, lift n ty -let type_of_ind env ind = - type_of_inductive env (Inductive.lookup_mind_specif env ind) +let type_of_ind env ind u = + type_of_inductive env (Inductive.lookup_mind_specif env ind, u) -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 = decompose_prod_assum typi in - let ind,cargs = find_rectype_a env indapp in + let ((ind,u),cargs) = find_rectype_a env indapp in let nparams = Array.length params in let carity = snd (rtbl.(i)) in let crealargs = Array.sub cargs nparams (Array.length cargs - nparams) in @@ -123,7 +126,7 @@ let build_branches_type env (mind,_ as _ind) mib mip params dep p = if dep then let cstr = ith_constructor_of_inductive ind (i+1) in let relargs = Array.init carity (fun i -> mkRel (carity-i)) in - let dep_cstr = mkApp(mkApp(mkConstruct cstr,params),relargs) in + let dep_cstr = mkApp(mkApp(mkConstructU (cstr,u),params),relargs) in mkApp(papp,[|dep_cstr|]) else papp in @@ -170,7 +173,7 @@ and nf_whd env whd typ = | Vatom_stk(Aiddef(idkey,v), stk) -> nf_whd env (whd_stack v stk) typ | Vatom_stk(Aind ind, stk) -> - nf_stk env (mkInd ind) (type_of_ind env ind) stk + nf_stk env (mkInd ind) (type_of_ind env ind Univ.Instance.empty (*FIXME*)) stk and nf_stk env c t stk = match stk with @@ -183,16 +186,16 @@ and nf_stk env c t stk = let _,_,codom = try decompose_prod env typ with DestKO -> exit 120 in nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk | Zswitch sw :: stk -> - let (mind,_ as ind),allargs = find_rectype_a env t in + 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 let params,realargs = Util.Array.chop nparams allargs in let pT = - hnf_prod_applist env (type_of_ind env ind) (Array.to_list params) in + hnf_prod_applist env (type_of_ind env ind u) (Array.to_list params) in let pT = whd_betadeltaiota env pT in let dep, p = nf_predicate env ind mip params (type_of_switch sw) pT in (* Calcul du type des branches *) - let btypes = build_branches_type env ind mib mip params dep p in + let btypes = build_branches_type env ind mib mip u params dep p in (* calcul des branches *) let bsw = branch_of_switch (nb_rel env) sw in let mkbranch i (n,v) = |