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.

5 files changed, 9 insertions, 9 deletions

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 ->
diff --git a/pretyping/inferCumulativity.ml b/pretyping/inferCumulativity.ml
index 4ce7cdff77..e46d03b743 100644
--- a/pretyping/inferCumulativity.ml
+++ b/pretyping/inferCumulativity.ml
@@ -111,7 +111,7 @@ let rec infer_fterm cv_pb infos variances hd stk =
     let variances = infer_fterm CONV infos variances ty [] in
     infer_fterm CONV infos variances bd []
   | FProd (_,dom,codom,e) ->
-    let variances = infer_fterm CONV infos variances (mk_clos e dom) [] in
+    let variances = infer_fterm CONV infos variances dom [] in
     infer_fterm cv_pb infos variances (mk_clos (Esubst.subs_lift e) codom) []
   | FInd (ind, u) ->
     let variances =