-
Notifications
You must be signed in to change notification settings - Fork 1.1k
/
topeval.ml
305 lines (274 loc) · 10.2 KB
/
topeval.ml
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
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* The interactive toplevel loop *)
open Format
open Misc
open Parsetree
open Types
open Typedtree
open Outcometree
open Topcommon
module String = Misc.Stdlib.String
(* The table of toplevel value bindings and its accessors *)
let toplevel_value_bindings : Obj.t String.Map.t ref = ref String.Map.empty
let getvalue name =
try
String.Map.find name !toplevel_value_bindings
with Not_found ->
fatal_error (name ^ " unbound at toplevel")
let setvalue name v =
toplevel_value_bindings := String.Map.add name v !toplevel_value_bindings
let implementation_label = ""
(* To print values *)
module EvalBase = struct
let eval_ident id =
if Ident.persistent id || Ident.global id then begin
try
Symtable.get_global_value id
with Symtable.Error (Undefined_global name) ->
raise (Undefined_global name)
end else begin
let name = Translmod.toplevel_name id in
try
String.Map.find name !toplevel_value_bindings
with Not_found ->
raise (Undefined_global name)
end
end
include Topcommon.MakeEvalPrinter(EvalBase)
(* Load in-core and execute a lambda term *)
let may_trace = ref false (* Global lock on tracing *)
let load_lambda ppf lam =
if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
let slam = Simplif.simplify_lambda lam in
if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam;
let (init_code, fun_code) = Bytegen.compile_phrase slam in
if !Clflags.dump_instr then
fprintf ppf "%a%a@."
Printinstr.instrlist init_code
Printinstr.instrlist fun_code;
let (code, reloc, events) =
Emitcode.to_memory init_code fun_code
in
let can_free = (fun_code = []) in
let initial_symtable = Symtable.current_state() in
Symtable.patch_object code reloc;
Symtable.check_global_initialized reloc;
Symtable.update_global_table();
let initial_bindings = !toplevel_value_bindings in
let bytecode, closure = Meta.reify_bytecode code [| events |] None in
match
may_trace := true;
Fun.protect
~finally:(fun () -> may_trace := false;
if can_free then Meta.release_bytecode bytecode)
closure
with
| retval -> Result retval
| exception x ->
record_backtrace ();
toplevel_value_bindings := initial_bindings; (* PR#6211 *)
Symtable.restore_state initial_symtable;
Exception x
(* Print the outcome of an evaluation *)
let pr_item =
Printtyp.print_items
(fun env -> function
| Sig_value(id, {val_kind = Val_reg; val_type}, _) ->
Some (outval_of_value env (getvalue (Translmod.toplevel_name id))
val_type)
| _ -> None
)
(* Execute a toplevel phrase *)
let execute_phrase print_outcome ppf phr =
match phr with
| Ptop_def sstr ->
let oldenv = !toplevel_env in
Typecore.reset_delayed_checks ();
let (str, sg, sn, shape, newenv) =
Typemod.type_toplevel_phrase oldenv sstr
in
if !Clflags.dump_typedtree then Printtyped.implementation ppf str;
if !Clflags.dump_shape then Shape.print ppf shape;
let sg' = Typemod.Signature_names.simplify newenv sn sg in
ignore (Includemod.signatures ~mark:Mark_positive oldenv sg sg');
Typecore.force_delayed_checks ();
let lam = Translmod.transl_toplevel_definition str in
Warnings.check_fatal ();
begin try
toplevel_env := newenv;
let res = load_lambda ppf lam in
let out_phr =
match res with
| Result v ->
if print_outcome then
Printtyp.wrap_printing_env ~error:false oldenv (fun () ->
match str.str_items with
| [ { str_desc =
(Tstr_eval (exp, _)
|Tstr_value
(Asttypes.Nonrecursive,
[{vb_pat = {pat_desc=Tpat_any};
vb_expr = exp}
]
)
)
}
] ->
let outv = outval_of_value newenv v exp.exp_type in
let ty = Printtyp.tree_of_type_scheme exp.exp_type in
Ophr_eval (outv, ty)
| [] -> Ophr_signature []
| _ -> Ophr_signature (pr_item oldenv sg'))
else Ophr_signature []
| Exception exn ->
toplevel_env := oldenv;
if exn = Out_of_memory then Gc.full_major();
let outv =
outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn
in
Ophr_exception (exn, outv)
in
!print_out_phrase ppf out_phr;
if Printexc.backtrace_status ()
then begin
match !backtrace with
| None -> ()
| Some b ->
pp_print_string ppf b;
pp_print_flush ppf ();
backtrace := None;
end;
begin match out_phr with
| Ophr_eval (_, _) | Ophr_signature _ -> true
| Ophr_exception _ -> false
end
with x ->
toplevel_env := oldenv; raise x
end
| Ptop_dir {pdir_name = {Location.txt = dir_name}; pdir_arg } ->
try_run_directive ppf dir_name pdir_arg
let execute_phrase print_outcome ppf phr =
try execute_phrase print_outcome ppf phr
with exn ->
Warnings.reset_fatal ();
raise exn
(* Additional directives for the bytecode toplevel only *)
open Cmo_format
(* Loading files *)
exception Load_failed
let check_consistency ppf filename cu =
try Env.import_crcs ~source:filename cu.cu_imports
with Persistent_env.Consistbl.Inconsistency {
unit_name = name;
inconsistent_source = user;
original_source = auth;
} ->
fprintf ppf "@[<hv 0>The files %s@ and %s@ \
disagree over interface %s@]@."
user auth name;
raise Load_failed
(* This is basically Dynlink.Bytecode.run with no digest *)
let load_compunit ic filename ppf compunit =
check_consistency ppf filename compunit;
seek_in ic compunit.cu_pos;
let code_size = compunit.cu_codesize + 8 in
let code = LongString.create code_size in
LongString.input_bytes_into code ic compunit.cu_codesize;
LongString.set code compunit.cu_codesize (Char.chr Opcodes.opRETURN);
LongString.blit_string "\000\000\000\001\000\000\000" 0
code (compunit.cu_codesize + 1) 7;
let initial_symtable = Symtable.current_state() in
Symtable.patch_object code compunit.cu_reloc;
Symtable.update_global_table();
let events =
if compunit.cu_debug = 0 then [| |]
else begin
seek_in ic compunit.cu_debug;
[| input_value ic |]
end in
begin try
may_trace := true;
let _bytecode, closure = Meta.reify_bytecode code events None in
ignore (closure ());
may_trace := false;
with exn ->
record_backtrace ();
may_trace := false;
Symtable.restore_state initial_symtable;
print_exception_outcome ppf exn;
raise Load_failed
end
let rec load_file recursive ppf name =
let filename =
try Some (Load_path.find name) with Not_found -> None
in
match filename with
| None -> fprintf ppf "Cannot find file %s.@." name; false
| Some filename ->
let ic = open_in_bin filename in
Misc.try_finally
~always:(fun () -> close_in ic)
(fun () -> really_load_file recursive ppf name filename ic)
and really_load_file recursive ppf name filename ic =
let buffer = really_input_string ic (String.length Config.cmo_magic_number) in
try
if buffer = Config.cmo_magic_number then begin
let compunit_pos = input_binary_int ic in (* Go to descriptor *)
seek_in ic compunit_pos;
let cu : compilation_unit = input_value ic in
if recursive then
List.iter
(function
| (Reloc_getglobal id, _)
when not (Symtable.is_global_defined id) ->
let file = Ident.name id ^ ".cmo" in
begin match Load_path.find_uncap file with
| exception Not_found -> ()
| file ->
if not (load_file recursive ppf file) then raise Load_failed
end
| _ -> ()
)
cu.cu_reloc;
load_compunit ic filename ppf cu;
true
end else
if buffer = Config.cma_magic_number then begin
let toc_pos = input_binary_int ic in (* Go to table of contents *)
seek_in ic toc_pos;
let lib = (input_value ic : library) in
List.iter
(fun dllib ->
let name = Dll.extract_dll_name dllib in
try Dll.open_dlls Dll.For_execution [name]
with Failure reason ->
fprintf ppf
"Cannot load required shared library %s.@.Reason: %s.@."
name reason;
raise Load_failed)
lib.lib_dllibs;
List.iter (load_compunit ic filename ppf) lib.lib_units;
true
end else begin
fprintf ppf "File %s is not a bytecode object file.@." name;
false
end
with Load_failed -> false
let init () =
let crc_intfs = Symtable.init_toplevel() in
Compmisc.init_path ();
Env.import_crcs ~source:Sys.executable_name crc_intfs;
()