1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
|
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
(* Created by Bruno Barras for Benjamin Grégoire as part of the
bytecode-based reduction machine, Oct 2004 *)
(* Bug fix #1419 by Jean-Marc Notin, Mar 2007 *)
(* This file manages the table of global symbols for the bytecode machine *)
open Names
open Term
open Context
open Vm
open Cemitcodes
open Cbytecodes
open Declarations
open Pre_env
open Cbytegen
external tcode_of_code : emitcodes -> int -> tcode = "coq_tcode_of_code"
external eval_tcode : tcode -> values array -> values = "coq_eval_tcode"
(*******************)
(* Linkage du code *)
(*******************)
(* Table des globaux *)
(* [global_data] contient les valeurs des constantes globales
(axiomes,definitions), les annotations des switch et les structured
constant *)
external global_data : unit -> values array = "get_coq_global_data"
(* [realloc_global_data n] augmente de n la taille de [global_data] *)
external realloc_global_data : int -> unit = "realloc_coq_global_data"
let check_global_data n =
if n >= Array.length (global_data()) then realloc_global_data n
let num_global = ref 0
let set_global v =
let n = !num_global in
check_global_data n;
(global_data()).(n) <- v;
incr num_global;
n
(* table pour les structured_constant et les annotations des switchs *)
let str_cst_tbl = Hashtbl.create 31
(* (structured_constant * int) Hashtbl.t*)
let annot_tbl = Hashtbl.create 31
(* (annot_switch * int) Hashtbl.t *)
(*************************************************************)
(*** Mise a jour des valeurs des variables et des constantes *)
(*************************************************************)
exception NotEvaluated
let key rk =
match !rk with
| Some k -> (*Pp.msgnl (str"found at: "++int k);*) k
| _ -> raise NotEvaluated
(************************)
(* traduction des patch *)
(* slot_for_*, calcul la valeur de l'objet, la place
dans la table global, rend sa position dans la table *)
let slot_for_str_cst key =
try Hashtbl.find str_cst_tbl key
with Not_found ->
let n = set_global (val_of_str_const key) in
Hashtbl.add str_cst_tbl key n;
n
let slot_for_annot key =
try Hashtbl.find annot_tbl key
with Not_found ->
let n = set_global (val_of_annot_switch key) in
Hashtbl.add annot_tbl key n;
n
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) ->
let v = eval_to_patch env (code,pl,fv) in
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
and slot_for_fv env fv =
match fv with
| FVnamed id ->
let nv = Pre_env.lookup_named_val id env in
begin
match !nv with
| VKvalue (v,_) -> v
| VKnone ->
let (_, b, _) = Context.lookup_named id env.env_named_context in
let v,d =
match b with
| None -> (val_of_named id, Id.Set.empty)
| Some c -> (val_of_constr env c, Environ.global_vars_set (Environ.env_of_pre_env env) c)
in
nv := VKvalue (v,d); v
end
| FVrel i ->
let rv = Pre_env.lookup_rel_val i env in
begin
match !rv with
| VKvalue (v, _) -> v
| VKnone ->
let (_, b, _) = lookup_rel i env.env_rel_context in
let (v, d) =
match b with
| None -> (val_of_rel (nb_rel env - i), Id.Set.empty)
| Some c -> let renv = env_of_rel i env in
(val_of_constr renv c, Environ.global_vars_set (Environ.env_of_pre_env renv) c)
in
rv := VKvalue (v,d); v
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 ->
(* 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 =
let (_,fun_code,_ as ccfv) =
try compile env c
with reraise ->
let reraise = Errors.push reraise in
let () = print_string "can not compile \n" in
let () = Format.print_flush () in
raise reraise
in
eval_to_patch env (to_memory ccfv)
let set_transparent_const kn = () (* !?! *)
let set_opaque_const kn = () (* !?! *)
|
