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/typeops.ml')

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/typeops.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'kernel/typeops.ml')

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/typeops.ml')

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