From 27c93465dcf0d5233c1195d1649f5e699ed54a90 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Sun, 21 Aug 2016 20:55:23 +0200
Subject: Packing the named_context_val in a proper record and marking it
 private.

---
 kernel/pre_env.ml | 42 ++++++++++++++++++++++++++++--------------
 1 file changed, 28 insertions(+), 14 deletions(-)

(limited to 'kernel/pre_env.ml')

diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index 5afefeebde..47d003fe94 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.ml
@@ -63,10 +63,14 @@ let build_lazy_val vk key = vk := VKvalue (CEphemeron.create key)
 
 type named_vals = (Id.t * lazy_val) list
 
+type named_context_val = {
+  env_named_ctx : Context.Named.t;
+  env_named_val : named_vals;
+}
+
 type env = {
   env_globals       : globals;
-  env_named_context : Context.Named.t;
-  env_named_vals    : named_vals;
+  env_named_context : named_context_val;
   env_rel_context   : Context.Rel.t;
   env_rel_val       : lazy_val list;
   env_nb_rel        : int;
@@ -77,9 +81,10 @@ type env = {
   indirect_pterms : Opaqueproof.opaquetab;
 }
 
-type named_context_val = Context.Named.t * named_vals
-
-let empty_named_context_val = [],[]
+let empty_named_context_val = {
+  env_named_ctx = [];
+  env_named_val = [];
+}
 
 let empty_env = {
   env_globals = {
@@ -87,8 +92,7 @@ let empty_env = {
     env_inductives = Mindmap_env.empty;
     env_modules = MPmap.empty;
     env_modtypes = MPmap.empty};
-  env_named_context = Context.Named.empty;
-  env_named_vals = [];
+  env_named_context = empty_named_context_val;
   env_rel_context = Context.Rel.empty;
   env_rel_val = [];
   env_nb_rel = 0;
@@ -125,17 +129,27 @@ let env_of_rel n env =
 
 (* Named context *)
 
-let push_named_context_val d (ctxt,vals) =
-  let rval = ref VKnone in
-    Context.Named.add d ctxt, (get_id d,rval)::vals
+let push_named_context_val_val d rval ctxt =
+  {
+    env_named_ctx = Context.Named.add d ctxt.env_named_ctx;
+    env_named_val = (get_id d, rval) :: ctxt.env_named_val;
+  }
+
+let push_named_context_val d ctxt =
+  push_named_context_val_val d (ref VKnone) ctxt
+
+let match_named_context_val c = match c.env_named_ctx, c.env_named_val with
+| [], [] -> None
+| decl :: ctx, (_, v) :: vls ->
+  let cval = { env_named_ctx = ctx; env_named_val = vls } in
+  Some (decl, v, cval)
+| _ -> assert false
 
 let push_named d env =
 (*  if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context);
   assert (env.env_rel_context = []); *)
-  let rval = ref VKnone in
   { env_globals = env.env_globals;
-    env_named_context = Context.Named.add d env.env_named_context;
-    env_named_vals = (get_id d, rval) :: env.env_named_vals;
+    env_named_context = push_named_context_val d env.env_named_context;
     env_rel_context = env.env_rel_context;
     env_rel_val = env.env_rel_val;
     env_nb_rel = env.env_nb_rel;
@@ -147,7 +161,7 @@ let push_named d env =
   }
 
 let lookup_named_val id env =
-  snd(List.find (fun (id',_) -> Id.equal id id') env.env_named_vals)
+  snd(List.find (fun (id',_) -> Id.equal id id') env.env_named_context.env_named_val)
 
 (* Warning all the names should be different *)
 let env_of_named id env = env
-- 
cgit v1.2.3


From e046e9b7e35cbe2d419099907cdcc0909b59d52c Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Sun, 21 Aug 2016 21:43:16 +0200
Subject: Tentative fast-access named env

---
 kernel/pre_env.ml | 9 +++++++--
 1 file changed, 7 insertions(+), 2 deletions(-)

(limited to 'kernel/pre_env.ml')

diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index 47d003fe94..62e5cd3662 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.ml
@@ -66,6 +66,7 @@ type named_vals = (Id.t * lazy_val) list
 type named_context_val = {
   env_named_ctx : Context.Named.t;
   env_named_val : named_vals;
+  env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t;
 }
 
 type env = {
@@ -84,6 +85,7 @@ type env = {
 let empty_named_context_val = {
   env_named_ctx = [];
   env_named_val = [];
+  env_named_map = Id.Map.empty;
 }
 
 let empty_env = {
@@ -130,9 +132,11 @@ let env_of_rel n env =
 (* Named context *)
 
 let push_named_context_val_val d rval ctxt =
+  assert (not (Id.Map.mem (get_id d) ctxt.env_named_map));
   {
     env_named_ctx = Context.Named.add d ctxt.env_named_ctx;
     env_named_val = (get_id d, rval) :: ctxt.env_named_val;
+    env_named_map = Id.Map.add (get_id d) (d, rval) ctxt.env_named_map;
   }
 
 let push_named_context_val d ctxt =
@@ -141,7 +145,8 @@ let push_named_context_val d ctxt =
 let match_named_context_val c = match c.env_named_ctx, c.env_named_val with
 | [], [] -> None
 | decl :: ctx, (_, v) :: vls ->
-  let cval = { env_named_ctx = ctx; env_named_val = vls } in
+  let map = Id.Map.remove (get_id decl) c.env_named_map in
+  let cval = { env_named_ctx = ctx; env_named_val = vls; env_named_map = map } in
   Some (decl, v, cval)
 | _ -> assert false
 
@@ -161,7 +166,7 @@ let push_named d env =
   }
 
 let lookup_named_val id env =
-  snd(List.find (fun (id',_) -> Id.equal id id') env.env_named_context.env_named_val)
+  snd(Id.Map.find id env.env_named_context.env_named_map)
 
 (* Warning all the names should be different *)
 let env_of_named id env = env
-- 
cgit v1.2.3


From 37195c027472b7f0110249b28356271e713fee6f Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Mon, 22 Aug 2016 14:39:10 +0200
Subject: More efficient implementation of map_named_val.

---
 kernel/pre_env.ml | 15 ++++++++++++++-
 1 file changed, 14 insertions(+), 1 deletion(-)

(limited to 'kernel/pre_env.ml')

diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index 62e5cd3662..defc0afc8e 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.ml
@@ -132,7 +132,7 @@ let env_of_rel n env =
 (* Named context *)
 
 let push_named_context_val_val d rval ctxt =
-  assert (not (Id.Map.mem (get_id d) ctxt.env_named_map));
+(*   assert (not (Id.Map.mem (get_id d) ctxt.env_named_map)); *)
   {
     env_named_ctx = Context.Named.add d ctxt.env_named_ctx;
     env_named_val = (get_id d, rval) :: ctxt.env_named_val;
@@ -150,6 +150,19 @@ let match_named_context_val c = match c.env_named_ctx, c.env_named_val with
   Some (decl, v, cval)
 | _ -> assert false
 
+let map_named_val f ctxt =
+  let open Context.Named.Declaration in
+  let fold accu d =
+    let d' = map_constr f d in
+    let accu =
+      if d == d' then accu
+      else Id.Map.modify (get_id d) (fun _ (_, v) -> (d', v)) accu
+    in
+    (accu, d')
+  in
+  let map, ctx = List.fold_map fold ctxt.env_named_map ctxt.env_named_ctx in
+  { ctxt with env_named_ctx = ctx; env_named_map = map }
+
 let push_named d env =
 (*  if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context);
   assert (env.env_rel_context = []); *)
-- 
cgit v1.2.3


From 1888527bb43d6a8c801565af3e6376c91769fbc1 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Fri, 9 Sep 2016 11:51:51 +0200
Subject: Removing the now useless field env_named_val from named_context_val.

This field was only used by the VM before, but since the previous patches,
this part of the code relies on the map instead.
---
 kernel/pre_env.ml | 17 ++++++-----------
 1 file changed, 6 insertions(+), 11 deletions(-)

(limited to 'kernel/pre_env.ml')

diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index defc0afc8e..104fe59d1d 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.ml
@@ -61,11 +61,8 @@ let force_lazy_val vk = match !vk with
 let dummy_lazy_val () = ref VKnone
 let build_lazy_val vk key = vk := VKvalue (CEphemeron.create key)
 
-type named_vals = (Id.t * lazy_val) list
-
 type named_context_val = {
   env_named_ctx : Context.Named.t;
-  env_named_val : named_vals;
   env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t;
 }
 
@@ -84,7 +81,6 @@ type env = {
 
 let empty_named_context_val = {
   env_named_ctx = [];
-  env_named_val = [];
   env_named_map = Id.Map.empty;
 }
 
@@ -135,20 +131,19 @@ let push_named_context_val_val d rval ctxt =
 (*   assert (not (Id.Map.mem (get_id d) ctxt.env_named_map)); *)
   {
     env_named_ctx = Context.Named.add d ctxt.env_named_ctx;
-    env_named_val = (get_id d, rval) :: ctxt.env_named_val;
     env_named_map = Id.Map.add (get_id d) (d, rval) ctxt.env_named_map;
   }
 
 let push_named_context_val d ctxt =
   push_named_context_val_val d (ref VKnone) ctxt
 
-let match_named_context_val c = match c.env_named_ctx, c.env_named_val with
-| [], [] -> None
-| decl :: ctx, (_, v) :: vls ->
+let match_named_context_val c = match c.env_named_ctx with
+| [] -> None
+| decl :: ctx ->
+  let (_, v) = Id.Map.find (get_id decl) c.env_named_map in
   let map = Id.Map.remove (get_id decl) c.env_named_map in
-  let cval = { env_named_ctx = ctx; env_named_val = vls; env_named_map = map } in
+  let cval = { env_named_ctx = ctx; env_named_map = map } in
   Some (decl, v, cval)
-| _ -> assert false
 
 let map_named_val f ctxt =
   let open Context.Named.Declaration in
@@ -161,7 +156,7 @@ let map_named_val f ctxt =
     (accu, d')
   in
   let map, ctx = List.fold_map fold ctxt.env_named_map ctxt.env_named_ctx in
-  { ctxt with env_named_ctx = ctx; env_named_map = map }
+  { env_named_ctx = ctx; env_named_map = map }
 
 let push_named d env =
 (*  if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context);
-- 
cgit v1.2.3


From d55818c7da468ce1c7c9644cb63f68f7561a17bc Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Fri, 9 Sep 2016 13:29:28 +0200
Subject: Tracking careless uses of slow name lookup.

---
 kernel/pre_env.ml | 3 +++
 1 file changed, 3 insertions(+)

(limited to 'kernel/pre_env.ml')

diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index 104fe59d1d..7be8606ef4 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.ml
@@ -173,6 +173,9 @@ let push_named d env =
     indirect_pterms = env.indirect_pterms;
   }
 
+let lookup_named id env =
+  fst (Id.Map.find id env.env_named_context.env_named_map)
+
 let lookup_named_val id env =
   snd(Id.Map.find id env.env_named_context.env_named_map)
 
-- 
cgit v1.2.3