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
|
open Names
open Term
open Vm
open Cemitcodes
open Cbytecodes
open Declarations
open Environ
open Cbytegen
open Cemitcodes
external tcode_of_code : emitcodes -> int -> tcode = "coq_tcode_of_code"
external free_tcode : tcode -> unit = "coq_static_free"
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
(* [global_transp],[global_boxed] contiennent les valeurs des
definitions gelees. Les deux versions sont maintenues en //.
[global_transp] contient la version transparente.
[global_boxed] contient la version gelees. *)
external global_transp : unit -> values array = "get_coq_global_transp"
external global_boxed : unit -> values array = "get_coq_global_boxed"
(* [realloc_global_data n] augmente de n la taille de [global_data] *)
external realloc_global_boxed : int -> unit = "realloc_coq_global_boxed"
let check_global_boxed n =
if n >= Array.length (global_boxed()) then realloc_global_boxed n
let num_boxed = ref 0
let set_boxed kn v =
let n = !num_boxed in
check_global_boxed n;
(global_transp()).(n) <- v;
let vb = val_of_constant_def kn v in
(global_boxed()).(n) <- vb;
incr num_boxed;
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 *)
(************************)
(* 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 (Obj.magic key) in
Hashtbl.add annot_tbl key n;
n
let rec slot_for_getglobal env kn =
let ck = lookup_constant_key kn env in
try constant_key_pos ck
with NotEvaluated ->
match force (constant_key_body ck).const_body_code with
| BCdefined(boxed,(code,pl,fv)) ->
let v = eval_to_patch env (code,pl,fv) in
let pos =
if boxed then set_boxed kn v
else set_global v in
let bpos = boxed,pos in
set_pos_constant ck bpos;
bpos
| BCallias kn' ->
let bpos = slot_for_getglobal env kn' in
set_pos_constant ck bpos;
bpos
| BCconstant ->
let v = val_of_constant kn in
let pos = set_global v in
let bpos = false,pos in
set_pos_constant ck bpos;
bpos
and slot_for_fv env fv=
match fv with
| FVnamed id ->
let nv = lookup_namedval id env in
begin
match kind_of_named nv with
| VKvalue v -> v
| VKaxiom id ->
let v = val_of_named id in
set_namedval nv v; v
| VKdef(c,e) ->
let v = val_of_constr e c in
set_namedval nv v; v
end
| FVrel i ->
let rv = lookup_relval i env in
begin
match kind_of_rel rv with
| VKvalue v -> v
| VKaxiom k ->
let v = val_of_rel k in
set_relval rv v; v
| VKdef(c,e) ->
let v = val_of_constr e c in
let k = nb_rel e in
set_relval rv v; v
end
and eval_to_patch env (buff,pl,fv) =
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_getglobal buff pos (slot_for_getglobal env kn)
in
List.iter patch pl;
let nfv = Array.length fv in
let vm_env = Array.map (slot_for_fv env) fv in
let tc = tcode_of_code buff (length buff) in
eval_tcode tc vm_env
and val_of_constr env c =
let (_,fun_code,_ as ccfv) = compile env c in
eval_to_patch env (to_memory ccfv)
|
