X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fng_kernel%2FnCicReduction.ml;h=61591e4f89698fc32092f054753f43648193f11d;hb=aa72d8d1a1c3986b41be8347ab4f236180eb1297;hp=73f78dc3693deab8606a4d5f894a3f27443dba54;hpb=f4d71b463ae8510e80a40cf4df475d19fab3df2c;p=helm.git diff --git a/helm/software/components/ng_kernel/nCicReduction.ml b/helm/software/components/ng_kernel/nCicReduction.ml index 73f78dc36..61591e4f8 100644 --- a/helm/software/components/ng_kernel/nCicReduction.ml +++ b/helm/software/components/ng_kernel/nCicReduction.ml @@ -13,6 +13,7 @@ module C = NCic module Ref = NReference +module E = NCicEnvironment module type Strategy = sig type stack_term @@ -170,8 +171,19 @@ let whd = R.whd let (===) x y = Pervasives.compare x y = 0 ;; +exception Dance;; + +let prof = HExtlib.profiling_enabled := true;HExtlib.profile "cache failures";; +let prof2 = HExtlib.profiling_enabled := true;HExtlib.profile "dancing sorts";; (* t1, t2 must be well-typed *) -let are_convertible whd ?(subst=[]) = +let are_convertible ?(subst=[]) get_relevance = + let get_relevance_p ~subst context t args = + (match prof with {HExtlib.profile = p} -> p) + (fun (a,b,c,d) -> get_relevance ~subst:a b c d) + (subst,context,t,args) + in + let dance () = (match prof2 with {HExtlib.profile = p} -> p) (fun () -> ()) () + in let rec aux test_eq_only context t1 t2 = let rec alpha_eq test_eq_only t1 t2 = if t1 === t2 then @@ -182,21 +194,22 @@ let are_convertible whd ?(subst=[]) = NCicEnvironment.universe_leq a b | (C.Sort (C.Type a), C.Sort (C.Type b)) -> NCicEnvironment.universe_eq a b - | (C.Sort s1,C.Sort (C.Type _)) -> (not test_eq_only) - | (C.Sort s1, C.Sort s2) -> s1 = s2 + | (C.Sort C.Prop,C.Sort (C.Type _)) -> (not test_eq_only) + | (C.Sort C.Prop, C.Sort C.Prop) -> true | (C.Prod (name1,s1,t1), C.Prod(_,s2,t2)) -> aux true context s1 s2 && aux test_eq_only ((name1, C.Decl s1)::context) t1 t2 - | (C.Lambda (name1,s1,t1), C.Lambda(_,s2,t2)) -> - aux true context s1 s2 && + | (C.Lambda (name1,s1,t1), C.Lambda(_,_,t2)) -> + (* thanks to inversion of well typedness, the source + * of these lambdas must be already convertible *) aux test_eq_only ((name1, C.Decl s1)::context) t1 t2 | (C.LetIn (name1,ty1,s1,t1), C.LetIn(_,ty2,s2,t2)) -> aux test_eq_only context ty1 ty2 && aux test_eq_only context s1 s2 && aux test_eq_only ((name1, C.Def (s1,ty1))::context) t1 t2 - | (C.Meta (n1,(s1, C.Irl i1)), C.Meta (n2,(s2, C.Irl i2))) + | (C.Meta (n1,(s1, C.Irl _)), C.Meta (n2,(s2, C.Irl _))) when n1 = n2 && s1 = s2 -> true | (C.Meta (n1,(s1, l1)), C.Meta (n2,(s2, l2))) when n1 = n2 && let l1 = NCicUtils.expand_local_context l1 in @@ -220,28 +233,71 @@ let are_convertible whd ?(subst=[]) = let term = NCicSubstitution.subst_meta l2 term in aux test_eq_only context t1 term with NCicUtils.Subst_not_found _ -> false) - - | (C.Appl (C.Const r1::tl1), C.Appl (C.Const r2::tl2)) -> - r1 = r2 && - let relevance = NCicEnvironment.get_relevance r1 in + + | (C.Appl ((C.Const r1) as hd1::tl1), C.Appl (C.Const r2::tl2)) + when (Ref.eq r1 r2 && + List.length (E.get_relevance r1) >= List.length tl1) -> + let relevance = E.get_relevance r1 in + let relevance = match r1 with + | Ref.Ref (_,Ref.Con (_,_,lno)) -> + let _,relevance = HExtlib.split_nth lno relevance in + HExtlib.mk_list false lno @ relevance + | _ -> relevance + in + let fail = ref ~-1 in + let res = (try + HExtlib.list_forall_default3 + (fun t1 t2 b -> fail := !fail+1; not b || aux test_eq_only context t1 t2) + tl1 tl2 true relevance + with Invalid_argument _ -> false) + in res + (* if res then true + else + let relevance = get_relevance_p ~subst context hd1 tl1 in + let _,relevance = HExtlib.split_nth !fail relevance in + let b,relevance = (match relevance with + | [] -> assert false + | b::tl -> b,tl) in + let _,tl1 = HExtlib.split_nth (!fail+1) tl1 in + let _,tl2 = HExtlib.split_nth (!fail+1) tl2 in + if (not b) then + (dance (); + try + HExtlib.list_forall_default3 + (fun t1 t2 b -> not b || aux test_eq_only context t1 t2) + tl1 tl2 true relevance + with Invalid_argument _ -> false) + else false *) + | (C.Appl (hd1::tl1), C.Appl (hd2::tl2)) -> + aux test_eq_only context hd1 hd2 && + let relevance = get_relevance ~subst context hd1 tl1 in (try HExtlib.list_forall_default3 (fun t1 t2 b -> not b || aux test_eq_only context t1 t2) tl1 tl2 true relevance with Invalid_argument _ -> false) - | (C.Appl l1, C.Appl l2) -> - (try List.for_all2 (aux test_eq_only context) l1 l2 - with Invalid_argument _ -> false) - - | (C.Match (ref1,outtype1,term1,pl1), - C.Match (ref2,outtype2,term2,pl2)) -> + | (C.Match (Ref.Ref (_,Ref.Ind (_,tyno,_)) as ref1,outtype1,term1,pl1), + C.Match (ref2,outtype2,term2,pl2)) -> + let _,_,itl,_,_ = E.get_checked_indtys ref1 in + let _,_,ty,_ = List.nth itl tyno in + let rec remove_prods ~subst context ty = + let ty = whd ~subst context ty in + match ty with + | C.Sort _ -> ty + | C.Prod (name,so,ta) -> remove_prods ~subst ((name,(C.Decl so))::context) ta + | _ -> assert false + in + let is_prop = + match remove_prods ~subst [] ty with + | C.Sort C.Prop -> true + | _ -> false + in Ref.eq ref1 ref2 && aux test_eq_only context outtype1 outtype2 && - aux test_eq_only context term1 term2 && + (is_prop || aux test_eq_only context term1 term2) && (try List.for_all2 (aux test_eq_only context) pl1 pl2 with Invalid_argument _ -> false) - | (C.Implicit _, _) | (_, C.Implicit _) -> assert false | (_,_) -> false in @@ -288,8 +344,6 @@ let are_convertible whd ?(subst=[]) = aux false ;; -let are_convertible = are_convertible whd - let rec head_beta_reduce ?(delta=max_int) ?(upto=(-1)) t l = match upto, t, l with | 0, C.Appl l1, _ -> C.Appl (l1 @ l)