Merge PR #8255: Fast typing of application nodes

4 files changed, 45 insertions, 29 deletions

diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml
index 7e73609996..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 * fconstr * fconstr
+  | 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
@@ -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, to_constr lfts t, c)
+      else
+        let subs' = comp_subs lfts e in
+        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,
@@ -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, 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
@@ -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 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..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 * fconstr * fconstr
+  | 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 fbb481424f..97cd4c00d7 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
+        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 _, _) ->
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index c8fd83c8a9..c9acd168e8 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -151,28 +151,41 @@ 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
-  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, 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
+        let argt = argstv.(i) 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 ->
+          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 *)