-
Notifications
You must be signed in to change notification settings - Fork 5
/
runcode.ml
149 lines (135 loc) · 4.88 KB
/
runcode.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
(* Run the closed code: byte-code and native code *)
open Format
open Print_code
(* Add a directory to search for .cmo/.cmi files, needed
for the sake of running the generated code .
The specified directory is prepended to the load_path.
*)
let add_search_path : string -> unit = fun dir ->
let dir = Misc.expand_directory Config.standard_library dir in
Config.load_path := dir :: !Config.load_path;
Dll.add_path [dir];
Env.reset_cache ()
(* Execute a thunk (which does compilation) while disabling certain
warnings.
*)
let warnings_descr =
[(Warnings.Partial_match "",("P","p"));
(Warnings.Unused_argument,("X","x"));
(Warnings.Unused_var "",("Y","y"));
(Warnings.Unused_var_strict "",("Z","z"))
]
let with_disabled_warnings warnings thunk =
let disable_str =
String.concat ""
(List.map
(fun w -> snd (List.assoc w warnings_descr)) warnings) in
(*
let curr_str =
String.concat ""
(List.map
(fun w ->
let state = Warnings.is_active w in
(if state then fst else snd) (List.assoc w warnings_descr))
warnings) in
*)
let warnings_old = Warnings.backup () in
let () = Warnings.parse_options false disable_str in
try
let r = thunk () in
Warnings.restore warnings_old; r
with e ->
Warnings.restore warnings_old;
raise e
let initial_env = ref Env.empty
(* Load and execute bytecode: copied from toploop/toploop.ml *)
let load_lambda ppf lam =
if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
let slam = Simplif.simplify_lambda "//toplevel//" 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, code_size, reloc, events) =
Emitcode.to_memory init_code fun_code
in
Meta.add_debug_info code code_size [| events |];
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 *)
try
Toploop.may_trace := true;
let retval = (Meta.reify_bytecode code code_size) () in
Toploop.may_trace := false;
if can_free then begin
Meta.remove_debug_info code;
Meta.static_release_bytecode code code_size;
Meta.static_free code;
end;
retval
with x ->
Toploop.may_trace := false;
if can_free then begin
Meta.remove_debug_info code;
Meta.static_release_bytecode code code_size;
Meta.static_free code;
end;
(* let initial_bindings = !toplevel_value_bindings in *)
Symtable.restore_state initial_symtable;
raise x
(* Patterned after toploop.ml:execute_phrase *)
let typecheck_code' : Parsetree.expression -> Typedtree.structure = fun exp ->
if !initial_env = Env.empty then begin
let old_time = Ident.current_time() in
(* does Ident.reinit() and may corrupt the timestamp if we
run in top-level. See Ident.reinit code
*)
initial_env := Compmisc.initial_env();
Ident.set_current_time old_time
end;
(* Ctype.init_def(Ident.current_time()); *)
let ppf = std_formatter in
with_disabled_warnings [Warnings.Partial_match "";
Warnings.Unused_argument;
Warnings.Unused_var "";
Warnings.Unused_var_strict ""]
(fun () ->
let sstr = [Ast_helper.Str.eval exp] in
if !Clflags.dump_source then Pprintast.structure ppf sstr;
try
begin
Typecore.reset_delayed_checks ();
let (str, sg, newenv) = Typemod.type_toplevel_phrase !initial_env sstr in
if !Clflags.dump_typedtree then Printtyped.implementation ppf str;
let sg' = Typemod.simplify_signature sg in
if !Clflags.dump_typedtree then Printtyp.signature ppf sg';
ignore (Includemod.signatures !initial_env sg sg');
Typecore.force_delayed_checks (); str
end
with
x -> (Errors.report_error ppf x;
Format.pp_print_newline ppf ();
failwith
"Error type-checking generated code: scope extrusion?")
)
(* For the benefit of offshoring, etc. *)
let typecheck_code : 'a closed_code -> Typedtree.expression = fun cde ->
let str = typecheck_code'
(cde : Trx.closed_code_repr :> Parsetree.expression) in
match str.Typedtree.str_items with
| [{Typedtree.str_desc = Typedtree.Tstr_eval (texp,_)}] -> texp
| _ -> failwith "cannot happen: Parsetree was not an expression?"
let run_bytecode : 'a closed_code -> 'a = fun cde ->
let str = typecheck_code'
(cde : Trx.closed_code_repr :> Parsetree.expression) in
let lam = Translmod.transl_toplevel_definition str in
Warnings.check_fatal ();
Obj.obj @@ load_lambda Format.std_formatter lam
(* Abbreviations for backwards compatibility *)
let run cde = run_bytecode (close_code cde)
let (!.) cde = run cde