From 82f7c721ea066a4776be09bd40444cf491f3659e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 May 2018 12:12:43 +0200 Subject: Do not wrap FProd return types in a closure. There is little point to this as the type is dependent on an open value and is never computed further. --- kernel/cClosure.ml | 17 ++++++++++------- kernel/cClosure.mli | 2 +- kernel/reduction.ml | 6 +++--- 3 files changed, 14 insertions(+), 11 deletions(-) (limited to 'kernel') diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 7e73609996..0679fc30d7 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -300,7 +300,7 @@ and fterm = | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (Name.t * constr) list * constr * fconstr subs - | FProd of Name.t * fconstr * fconstr + | FProd of Name.t * constr * constr * fconstr subs | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs | FLIFT of int * fconstr @@ -584,9 +584,12 @@ let rec to_constr lfts v = let tys = List.mapi (fun i (na, c) -> na, subst_constr (subs_liftn i subs) c) tys in let f = subst_constr (subs_liftn len subs) f in Term.compose_lam (List.rev tys) f - | FProd (n,t,c) -> - mkProd (n, to_constr lfts t, - to_constr (el_lift lfts) c) + | FProd (n, t, c, e) -> + if is_subs_id e && is_lift_id lfts then + mkProd (n, t, c) + else + let subs' = comp_subs lfts e in + mkProd (n, subst_constr subs' t, subst_constr (subs_lift subs') c) | FLetIn (n,b,t,f,e) -> let subs = comp_subs (el_lift lfts) (subs_lift e) in mkLetIn (n, to_constr lfts b, @@ -869,7 +872,7 @@ and knht info e t stk = | CoFix cfx -> { norm = Cstr; term = FCoFix (cfx,e) }, stk | Lambda _ -> { norm = Cstr; term = mk_lambda e t }, stk | Prod (n, t, c) -> - { norm = Whnf; term = FProd (n, mk_clos e t, mk_clos (subs_lift e) c) }, stk + { norm = Whnf; term = FProd (n, t, c, e) }, stk | LetIn (n,b,t,c) -> { norm = Red; term = FLetIn (n, mk_clos e b, mk_clos e t, c, e) }, stk | Evar ev -> { norm = Red; term = FEvar (ev, e) }, stk @@ -992,8 +995,8 @@ and norm_head info tab m = | FLetIn(na,a,b,f,e) -> let c = mk_clos (subs_lift e) f in mkLetIn(na, kl info tab a, kl info tab b, kl info tab c) - | FProd(na,dom,rng) -> - mkProd(na, kl info tab dom, kl info tab rng) + | FProd(na,dom,rng,e) -> + mkProd(na, kl info tab (mk_clos e dom), kl info tab (mk_clos (subs_lift e) rng)) | FCoFix((n,(na,tys,bds)),e) -> let ftys = Array.Fun1.map mk_clos e tys in let fbds = diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index b6c87b3732..3163833ef3 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -114,7 +114,7 @@ type fterm = | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (Name.t * constr) list * constr * fconstr subs - | FProd of Name.t * fconstr * fconstr + | FProd of Name.t * constr * constr * fconstr subs | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs | FLIFT of int * fconstr diff --git a/kernel/reduction.ml b/kernel/reduction.ml index fbb481424f..f9423a848d 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -438,14 +438,14 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let cuniv = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 cuniv - | (FProd (_,c1,c2), FProd (_,c'1,c'2)) -> + | (FProd (_, c1, c2, e), FProd (_, c'1, c'2, e')) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (FProd)."); (* Luo's system *) let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in - let cuniv = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in - ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 cuniv + let cuniv = ccnv CONV l2r infos el1 el2 (mk_clos e c1) (mk_clos e' c'1) cuniv in + ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) (mk_clos (subs_lift e) c2) (mk_clos (subs_lift e') c'2) cuniv (* Eta-expansion on the fly *) | (FLambda _, _) -> -- cgit v1.2.3 From 2d81a99e14d32f9f79ae617986148db3a36707e7 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 23 May 2018 19:45:22 +0200 Subject: More efficient implementation of type_of_apply. --- kernel/typeops.ml | 44 +++++++++++++++++++++++++------------------- 1 file changed, 25 insertions(+), 19 deletions(-) (limited to 'kernel') diff --git a/kernel/typeops.ml b/kernel/typeops.ml index c8fd83c8a9..956e5f7947 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -152,27 +152,33 @@ let make_judgev c t = Array.map2 make_judge c t let type_of_apply env func funt argsv argstv = + let open CClosure in let len = Array.length argsv in - let rec apply_rec i typ = - if Int.equal i len then typ - else - (match kind (whd_all env typ) with - | Prod (_,c1,c2) -> - let arg = argsv.(i) and argt = argstv.(i) in - (try - let () = conv_leq false env argt c1 in - apply_rec (i+1) (subst1 arg c2) - with NotConvertible -> - error_cant_apply_bad_type env - (i+1,c1,argt) - (make_judge func funt) - (make_judgev argsv argstv)) - + let infos = create_clos_infos all env in + let tab = create_tab () in + let rec apply_rec i typ = + if Int.equal i len then term_of_fconstr typ + else + let typ, _ = whd_stack infos tab typ [] in + match fterm_of typ with + | FProd (_, c1, c2, e) -> + let arg = argsv.(i) in + let argt = argstv.(i) in + let c1 = term_of_fconstr (mk_clos e c1) in + begin match conv_leq false env argt c1 with + | () -> apply_rec (i+1) (mk_clos (Esubst.subs_cons ([| inject arg |], e)) c2) + | exception NotConvertible -> + error_cant_apply_bad_type env + (i+1,c1,argt) + (make_judge func funt) + (make_judgev argsv argstv) + end | _ -> - error_cant_apply_not_functional env - (make_judge func funt) - (make_judgev argsv argstv)) - in apply_rec 0 funt + error_cant_apply_not_functional env + (make_judge func funt) + (make_judgev argsv argstv) + in + apply_rec 0 (inject funt) (* Type of product *) -- cgit v1.2.3 From c4ec9bd2c8a31f5eddea87bbc3f1605ca731d598 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 1 Oct 2018 16:10:37 +0200 Subject: Use a closure for the domain argument of FProd. The use of a term is not needed for the fast typing algorithm of the application case, so this tweak brings the best of both worlds. --- kernel/cClosure.ml | 10 +++++----- kernel/cClosure.mli | 2 +- kernel/reduction.ml | 2 +- kernel/typeops.ml | 2 +- 4 files changed, 8 insertions(+), 8 deletions(-) (limited to 'kernel') diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 0679fc30d7..1f61bcae2e 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -300,7 +300,7 @@ and fterm = | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (Name.t * constr) list * constr * fconstr subs - | FProd of Name.t * constr * constr * fconstr subs + | FProd of Name.t * fconstr * constr * fconstr subs | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs | FLIFT of int * fconstr @@ -586,10 +586,10 @@ let rec to_constr lfts v = Term.compose_lam (List.rev tys) f | FProd (n, t, c, e) -> if is_subs_id e && is_lift_id lfts then - mkProd (n, t, c) + mkProd (n, to_constr lfts t, c) else let subs' = comp_subs lfts e in - mkProd (n, subst_constr subs' t, subst_constr (subs_lift subs') c) + mkProd (n, to_constr lfts t, subst_constr (subs_lift subs') c) | FLetIn (n,b,t,f,e) -> let subs = comp_subs (el_lift lfts) (subs_lift e) in mkLetIn (n, to_constr lfts b, @@ -872,7 +872,7 @@ and knht info e t stk = | CoFix cfx -> { norm = Cstr; term = FCoFix (cfx,e) }, stk | Lambda _ -> { norm = Cstr; term = mk_lambda e t }, stk | Prod (n, t, c) -> - { norm = Whnf; term = FProd (n, t, c, e) }, stk + { norm = Whnf; term = FProd (n, mk_clos e t, c, e) }, stk | LetIn (n,b,t,c) -> { norm = Red; term = FLetIn (n, mk_clos e b, mk_clos e t, c, e) }, stk | Evar ev -> { norm = Red; term = FEvar (ev, e) }, stk @@ -996,7 +996,7 @@ and norm_head info tab m = let c = mk_clos (subs_lift e) f in mkLetIn(na, kl info tab a, kl info tab b, kl info tab c) | FProd(na,dom,rng,e) -> - mkProd(na, kl info tab (mk_clos e dom), kl info tab (mk_clos (subs_lift e) rng)) + mkProd(na, kl info tab dom, kl info tab (mk_clos (subs_lift e) rng)) | FCoFix((n,(na,tys,bds)),e) -> let ftys = Array.Fun1.map mk_clos e tys in let fbds = diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index 3163833ef3..c2d53eed47 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -114,7 +114,7 @@ type fterm = | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (Name.t * constr) list * constr * fconstr subs - | FProd of Name.t * constr * constr * fconstr subs + | FProd of Name.t * fconstr * constr * fconstr subs | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs | FLIFT of int * fconstr diff --git a/kernel/reduction.ml b/kernel/reduction.ml index f9423a848d..97cd4c00d7 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -444,7 +444,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* Luo's system *) let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in - let cuniv = ccnv CONV l2r infos el1 el2 (mk_clos e c1) (mk_clos e' c'1) cuniv in + let cuniv = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) (mk_clos (subs_lift e) c2) (mk_clos (subs_lift e') c'2) cuniv (* Eta-expansion on the fly *) diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 956e5f7947..a87355e927 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -164,7 +164,7 @@ let type_of_apply env func funt argsv argstv = | FProd (_, c1, c2, e) -> let arg = argsv.(i) in let argt = argstv.(i) in - let c1 = term_of_fconstr (mk_clos e c1) in + let c1 = term_of_fconstr c1 in begin match conv_leq false env argt c1 with | () -> apply_rec (i+1) (mk_clos (Esubst.subs_cons ([| inject arg |], e)) c2) | exception NotConvertible -> -- cgit v1.2.3 From a181bcb8d8050984e57f4a21cc7e97c043feb043 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 5 Nov 2018 15:18:16 +0100 Subject: Add a check that the return stack of an FProd is indeed empty. --- kernel/typeops.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'kernel') diff --git a/kernel/typeops.ml b/kernel/typeops.ml index a87355e927..c9acd168e8 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -151,6 +151,11 @@ let type_of_abstraction _env name var ty = let make_judgev c t = Array.map2 make_judge c t +let rec check_empty_stack = function +| [] -> true +| CClosure.Zupdate _ :: s -> check_empty_stack s +| _ -> false + let type_of_apply env func funt argsv argstv = let open CClosure in let len = Array.length argsv in @@ -159,7 +164,9 @@ let type_of_apply env func funt argsv argstv = let rec apply_rec i typ = if Int.equal i len then term_of_fconstr typ else - let typ, _ = whd_stack infos tab typ [] in + let typ, stk = whd_stack infos tab typ [] in + (** The return stack is known to be empty *) + let () = assert (check_empty_stack stk) in match fterm_of typ with | FProd (_, c1, c2, e) -> let arg = argsv.(i) in -- cgit v1.2.3