From 300293c119981054c95182a90c829058530a6b6f Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Sun, 25 Dec 2011 13:19:42 +0100 Subject: Imported Upstream version 8.3.pl3 --- kernel/csymtable.ml | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) (limited to 'kernel/csymtable.ml') diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index 8eeb1ce6..2b3d3fac 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -81,9 +81,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 (************************) @@ -110,6 +111,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(boxed,(code,pl,fv)) -> @@ -118,6 +120,7 @@ let rec slot_for_getglobal env kn = else 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 @@ -154,15 +157,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 = -- cgit v1.2.3