jon.recoil.org
this repo has no description
1(** Multiple isolated execution environments.
2
3 This module provides isolated execution environments for the OCaml toplevel.
4 Each environment maintains both:
5 - The typing environment (Env.t) which tracks type bindings
6 - Runtime values (via Toploop.getvalue/setvalue) which store actual values
7
8 When switching between environments, both are saved and restored to ensure
9 complete isolation of definitions. *)
10
11module StringSet = Set.Make (String)
12module StringMap = Map.Make (String)
13
14(* Debug logging - uses the Logs module which is configured in the worker *)
15let log_debug msg = Logs.debug (fun m -> m "%s" msg)
16
17type id = string
18
19(** Runtime values are stored as a map from binding name to Obj.t.
20 We use Obj.t because Toploop.getvalue/setvalue work with Obj.t. *)
21type runtime_values = Obj.t StringMap.t
22
23type t = {
24 id : id;
25 mutable toplevel_env : Env.t option;
26 mutable runtime_values : runtime_values;
27 mutable is_setup : bool;
28 failed_cells : StringSet.t ref;
29}
30
31let default_id = "default"
32
33(* Global table of environments *)
34let environments : (id, t) Hashtbl.t = Hashtbl.create 16
35
36let create id =
37 let env = {
38 id;
39 toplevel_env = None;
40 runtime_values = StringMap.empty;
41 is_setup = false;
42 failed_cells = ref StringSet.empty;
43 } in
44 Hashtbl.replace environments id env;
45 env
46
47let get id = Hashtbl.find_opt environments id
48
49let get_or_create id =
50 match get id with
51 | Some env -> env
52 | None -> create id
53
54let destroy id = Hashtbl.remove environments id
55
56let list () = Hashtbl.fold (fun id _ acc -> id :: acc) environments []
57
58let id env = env.id
59
60(** Get the toplevel name for a binding identifier.
61 This is used to look up runtime values via Toploop.getvalue. *)
62let toplevel_name ident = Translmod.toplevel_name ident
63
64(** Restore runtime values from the stored map.
65 This sets the values in the bytecode global table. *)
66let restore_runtime_values env_id values =
67 let count = StringMap.cardinal values in
68 if count > 0 then
69 log_debug (Printf.sprintf "[ENV] Restoring %d runtime values for env %s" count env_id);
70 StringMap.iter (fun name value ->
71 try
72 log_debug (Printf.sprintf "[ENV] setvalue %s" name);
73 Toploop.setvalue name value
74 with e ->
75 log_debug (Printf.sprintf "[ENV] setvalue %s failed: %s" name (Printexc.to_string e))
76 ) values
77
78(** Check if an identifier is a value binding in the given environment.
79 Returns true for let-bindings, false for exceptions, modules, types, etc. *)
80let is_value_binding typing_env ident =
81 try
82 let path = Path.Pident ident in
83 let _ = Env.find_value path typing_env in
84 true
85 with Not_found -> false
86
87(** Capture runtime values for the given identifiers.
88 Only captures value bindings (not exceptions, modules, etc.).
89 Returns an updated map with the new values. *)
90let capture_runtime_values typing_env env_id base_map idents =
91 (* Filter to only value bindings to avoid "Fatal error" from Toploop.getvalue *)
92 let value_idents = List.filter (is_value_binding typing_env) idents in
93 if value_idents <> [] then
94 log_debug (Printf.sprintf "[ENV] Capturing %d value bindings for env %s (filtered from %d total)"
95 (List.length value_idents) env_id (List.length idents));
96 List.fold_left (fun map ident ->
97 let name = toplevel_name ident in
98 try
99 let value = Toploop.getvalue name in
100 log_debug (Printf.sprintf "[ENV] captured %s" name);
101 StringMap.add name value map
102 with e ->
103 log_debug (Printf.sprintf "[ENV] could not capture %s: %s" name (Printexc.to_string e));
104 map
105 ) base_map value_idents
106
107let with_env env f =
108 log_debug (Printf.sprintf "[ENV] with_env called for %s (has_saved_env=%b, runtime_values_count=%d)"
109 env.id (Option.is_some env.toplevel_env) (StringMap.cardinal env.runtime_values));
110
111 (* Save current toplevel environment *)
112 let saved_typing_env = !Toploop.toplevel_env in
113 let saved_typing_env_before =
114 match env.toplevel_env with
115 | Some e -> e
116 | None -> saved_typing_env
117 in
118
119 (* Restore this environment's typing environment if we have one *)
120 (match env.toplevel_env with
121 | Some e -> Toploop.toplevel_env := e
122 | None -> ());
123
124 (* Restore this environment's runtime values *)
125 restore_runtime_values env.id env.runtime_values;
126
127 (* Run the function *)
128 let result =
129 try f ()
130 with exn ->
131 (* Capture new bindings before re-raising *)
132 let current_typing_env = !Toploop.toplevel_env in
133 let new_idents = Env.diff saved_typing_env_before current_typing_env in
134 let updated_values = capture_runtime_values current_typing_env env.id env.runtime_values new_idents in
135 env.runtime_values <- updated_values;
136 env.toplevel_env <- Some current_typing_env;
137 Toploop.toplevel_env := saved_typing_env;
138 raise exn
139 in
140
141 (* Capture new bindings that were added during execution *)
142 let current_typing_env = !Toploop.toplevel_env in
143 let new_idents = Env.diff saved_typing_env_before current_typing_env in
144 log_debug (Printf.sprintf "[ENV] Env.diff found %d new idents for %s" (List.length new_idents) env.id);
145 let updated_values = capture_runtime_values current_typing_env env.id env.runtime_values new_idents in
146
147 (* Save the updated environment state *)
148 env.runtime_values <- updated_values;
149 env.toplevel_env <- Some !Toploop.toplevel_env;
150
151 (* Restore the previous typing environment *)
152 Toploop.toplevel_env := saved_typing_env;
153
154 result
155
156let is_setup env = env.is_setup
157
158let mark_setup env = env.is_setup <- true
159
160let get_failed_cells env = !(env.failed_cells)
161
162let add_failed_cell env cell_id =
163 env.failed_cells := StringSet.add cell_id !(env.failed_cells)
164
165let remove_failed_cell env cell_id =
166 env.failed_cells := StringSet.remove cell_id !(env.failed_cells)
167
168let is_cell_failed env cell_id =
169 StringSet.mem cell_id !(env.failed_cells)