fixed bug 2580. Quick fix: copy emitcodes before patching it

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@14376 85f007b7-540e-0410-9357-904b9bb8a0f7

5 files changed, 31 insertions, 2 deletions

diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml
index 277b343b2..1f00a70e7 100644
--- a/kernel/cemitcodes.ml
+++ b/kernel/cemitcodes.ml
@@ -307,6 +307,8 @@ let init () =
 
 type emitcodes = string
 
+let copy = String.copy
+
 let length = String.length
 
 type to_patch = emitcodes * (patch list) * fv
@@ -348,6 +350,8 @@ let force = force subst_body_code
 
 let subst_to_patch_subst = subst_substituted
 
+let repr_body_code = repr_substituted
+
 let to_memory (init_code, fun_code, fv) =
   init();
   emit init_code;
diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli
index 43cebb474..287c39304 100644
--- a/kernel/cemitcodes.mli
+++ b/kernel/cemitcodes.mli
@@ -13,6 +13,8 @@ val subst_patch : Mod_subst.substitution -> patch -> patch
 
 type emitcodes
 
+val copy : emitcodes -> emitcodes
+
 val length : emitcodes -> int
 
 val patch_int : emitcodes -> (*pos*)int -> int -> unit
@@ -35,5 +37,8 @@ val force : to_patch_substituted -> body_code
 
 val subst_to_patch_subst : Mod_subst.substitution -> to_patch_substituted -> to_patch_substituted
 
+val repr_body_code :
+  to_patch_substituted -> Mod_subst.substitution list option * body_code
+
 val to_memory : bytecodes * bytecodes * fv -> to_patch
                (** init code, fun code, fv *)
diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml
index 897cbf13a..e8b66d090 100644
--- a/kernel/csymtable.ml
+++ b/kernel/csymtable.ml
@@ -94,9 +94,10 @@ let annot_tbl = Hashtbl.create 31
 
 exception NotEvaluated
 
+open Pp
 let key rk =
   match !rk with
-  | Some k -> k
+  | Some k -> (*Pp.msgnl (str"found at: "++int k);*)  k
   | _ -> raise NotEvaluated
 
 (************************)
@@ -123,6 +124,7 @@ let rec slot_for_getglobal env kn =
   let (cb,rk) = lookup_constant_key kn env in
   try key rk
   with NotEvaluated ->
+(*    Pp.msgnl(str"not yet evaluated");*)
     let pos =
       match Cemitcodes.force cb.const_body_code with
       | BCdefined(code,pl,fv) ->
@@ -130,6 +132,7 @@ let rec slot_for_getglobal env kn =
 	set_global v
     | BCallias kn' -> slot_for_getglobal env kn'
     | BCconstant -> set_global (val_of_constant kn) in
+(*Pp.msgnl(str"value stored at: "++int pos);*)
     rk := Some pos;
     pos
 
@@ -166,15 +169,22 @@ and slot_for_fv env fv =
       end
 
 and eval_to_patch env (buff,pl,fv) =
+  (* copy code *before* patching because of nested evaluations:
+     the code we are patching might be called (and thus "concurrently" patched)
+     and results in wrong results. Side-effects... *)
+  let buff = Cemitcodes.copy buff in
   let patch = function
     | Reloc_annot a, pos -> patch_int buff pos (slot_for_annot a)
     | Reloc_const sc, pos -> patch_int buff pos (slot_for_str_cst sc)
     | Reloc_getglobal kn, pos ->
-	patch_int buff pos (slot_for_getglobal env kn)
+(*      Pp.msgnl (str"patching global: "++str(debug_string_of_con kn));*)
+	patch_int buff pos (slot_for_getglobal env kn);
+(*      Pp.msgnl (str"patch done: "++str(debug_string_of_con kn))*)
   in
   List.iter patch pl;
   let vm_env = Array.map (slot_for_fv env) fv in
   let tc = tcode_of_code buff (length buff) in
+(*Pp.msgnl (str"execute code");*)
   eval_tcode tc vm_env
 
 and val_of_constr env c =
diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml
index 6a7ecc442..bf08841c8 100644
--- a/kernel/mod_subst.ml
+++ b/kernel/mod_subst.ml
@@ -553,3 +553,8 @@ let subst_substituted s r =
     | LSlazy(s',a) ->
 	  ref (LSlazy(s::s',a))
 
+(* debug *)
+let repr_substituted r =
+  match !r with
+    | LSval a -> None, a
+    | LSlazy(s,a) -> Some s, a
diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli
index f9b76e6ee..dd240d7f3 100644
--- a/kernel/mod_subst.mli
+++ b/kernel/mod_subst.mli
@@ -137,3 +137,8 @@ val subst_mps : substitution -> constr -> constr
 
 val occur_mbid : mod_bound_id -> substitution -> bool
 
+(** [repr_substituted r] dumps the representation of a substituted:
+    - [None, a] when r is a value
+    - [Some s, a] when r is a delayed substitution [s] applied to [a] *)
+
+val repr_substituted : 'a substituted -> substitution list option * 'a