[@@@ocaml.warning "-6-9-26-27-32-33-34"] module F = Fmt let _ = F.epr "topinf.ml comin at ya @." open Format open Misc open Parsetree open Typedtree open Types open Trace open Cmo_format open Outcometree open Ast_helper open Lambda open Translcore open Translclass open Translobj open Debuginfo.Scoped_location open Path module String = Misc.Stdlib.String exception PPerror type directive_fun = | Directive_none of (unit -> unit) | Directive_string of (string -> unit) | Directive_int of (int -> unit) | Directive_ident of (Longident.t -> unit) | Directive_bool of (bool -> unit) type directive_info = { section : string; doc : string } (* Phase buffer that stores the last toplevel phrase (see [Location.input_phrase_buffer]). *) let phrase_buffer = Buffer.create 1024 (* 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 = F.epr "Topinf.getvalue %s@." name; try String.Map.find name !toplevel_value_bindings with Not_found -> fatal_error (name ^ " unbound at toplevel") let setvalue name v = F.epr "Topinf.setvalue %s@." name; toplevel_value_bindings := String.Map.add name v !toplevel_value_bindings let print_toplevel_value_bindings () = String.Map.iter (fun k v -> F.epr "toplevel_value_bindings: %s\n" k) !toplevel_value_bindings (* copied in lots of ocaml/lambda/translmod.ml *) type unsafe_component = | Unsafe_module_binding | Unsafe_functor | Unsafe_non_function | Unsafe_typext type unsafe_info = | Unsafe of { reason : unsafe_component; loc : Location.t; subid : Ident.t } | Unnamed type error = | Circular_dependency of (Ident.t * unsafe_info) list | Conflicting_inline_attributes exception Error of Location.t * error let cons_opt x_opt xs = match x_opt with None -> xs | Some x -> x :: xs (* Keep track of the root path (from the root of the namespace to the currently compiled module expression). Useful for naming extensions. *) let global_path glob = Some (Pident glob) let functor_path path param = match path with None -> None | Some p -> Some (Papply (p, Pident param)) let field_path path field = match path with None -> None | Some p -> Some (Pdot (p, Ident.name field)) (* Compile type extensions *) let transl_type_extension ~scopes env rootpath tyext body = List.fold_right (fun ext body -> let lam = transl_extension_constructor ~scopes env (field_path rootpath ext.ext_id) ext in Llet (Strict, Pgenval, ext.ext_id, lam, body)) tyext.tyext_constructors body (* Compile a coercion *) let rec apply_coercion loc strict restr arg = match restr with | Tcoerce_none -> arg | Tcoerce_structure (pos_cc_list, id_pos_list) -> name_lambda strict arg (fun id -> let get_field pos = if pos < 0 then lambda_unit else Lprim (Pfield pos, [ Lvar id ], loc) in let lam = Lprim ( Pmakeblock (0, Immutable, None), List.map (apply_coercion_field loc get_field) pos_cc_list, loc ) in wrap_id_pos_list loc id_pos_list get_field lam) | Tcoerce_functor (cc_arg, cc_res) -> let param = Ident.create_local "funarg" in let carg = apply_coercion loc Alias cc_arg (Lvar param) in apply_coercion_result loc strict arg [ (param, Pgenval) ] [ carg ] cc_res | Tcoerce_primitive { pc_loc = _; pc_desc; pc_env; pc_type } -> Translprim.transl_primitive loc pc_desc pc_env pc_type None | Tcoerce_alias (env, path, cc) -> let lam = transl_module_path loc env path in name_lambda strict arg (fun _ -> apply_coercion loc Alias cc lam) and apply_coercion_field loc get_field (pos, cc) = apply_coercion loc Alias cc (get_field pos) and apply_coercion_result loc strict funct params args cc_res = match cc_res with | Tcoerce_functor (cc_arg, cc_res) -> let param = Ident.create_local "funarg" in let arg = apply_coercion loc Alias cc_arg (Lvar param) in apply_coercion_result loc strict funct ((param, Pgenval) :: params) (arg :: args) cc_res | _ -> name_lambda strict funct (fun id -> Lfunction { kind = Curried; params = List.rev params; return = Pgenval; attr = { default_function_attribute with is_a_functor = true; stub = true; }; loc; body = apply_coercion loc Strict cc_res (Lapply { ap_loc = loc; ap_func = Lvar id; ap_args = List.rev args; ap_tailcall = Default_tailcall; ap_inlined = Default_inline; ap_specialised = Default_specialise; }); }) and wrap_id_pos_list loc id_pos_list get_field lam = let fv = free_variables lam in (*Format.eprintf "%a@." Printlambda.lambda lam; Ident.Set.iter (fun id -> Format.eprintf "%a " Ident.print id) fv; Format.eprintf "@.";*) let lam, s = List.fold_left (fun (lam, s) (id', pos, c) -> if Ident.Set.mem id' fv then let id'' = Ident.create_local (Ident.name id') in ( Llet ( Alias, Pgenval, id'', apply_coercion loc Alias c (get_field pos), lam ), Ident.Map.add id' id'' s ) else (lam, s)) (lam, Ident.Map.empty) id_pos_list in if s == Ident.Map.empty then lam else Lambda.rename s lam (* Compose two coercions apply_coercion c1 (apply_coercion c2 e) behaves like apply_coercion (compose_coercions c1 c2) e. *) let rec compose_coercions c1 c2 = match (c1, c2) with | Tcoerce_none, c2 -> c2 | c1, Tcoerce_none -> c1 | Tcoerce_structure (pc1, ids1), Tcoerce_structure (pc2, ids2) -> let v2 = Array.of_list pc2 in let ids1 = List.map (fun (id, pos1, c1) -> let pos2, c2 = v2.(pos1) in (id, pos2, compose_coercions c1 c2)) ids1 in Tcoerce_structure ( List.map (fun pc -> match pc with | _, (Tcoerce_primitive _ | Tcoerce_alias _) -> (* These cases do not take an argument (the position is -1), so they do not need adjusting. *) pc | p1, c1 -> let p2, c2 = v2.(p1) in (p2, compose_coercions c1 c2)) pc1, ids1 @ ids2 ) | Tcoerce_functor (arg1, res1), Tcoerce_functor (arg2, res2) -> Tcoerce_functor (compose_coercions arg2 arg1, compose_coercions res1 res2) | c1, Tcoerce_alias (env, path, c2) -> Tcoerce_alias (env, path, compose_coercions c1 c2) | _, _ -> fatal_error "Translmod.compose_coercions" (* let apply_coercion a b c = Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b; apply_coercion a b c let compose_coercions c1 c2 = let c3 = compose_coercions c1 c2 in let open Includemod in Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@." print_coercion c1 print_coercion c2 print_coercion c3; c3 *) (* Record the primitive declarations occurring in the module compiled *) let primitive_declarations = ref ([] : Primitive.description list) let record_primitive = function | { val_kind = Val_prim p; val_loc } -> Translprim.check_primitive_arity val_loc p; primitive_declarations := p :: !primitive_declarations | _ -> () (* Utilities for compiling "module rec" definitions *) let mod_prim = Lambda.transl_prim "CamlinternalMod" let undefined_location loc = let fname, line, char = Location.get_pos_info loc.Location.loc_start in Lconst (Const_block ( 0, [ Const_base (Const_string (fname, loc, None)); const_int line; const_int char; ] )) exception Initialization_failure of unsafe_info let init_shape id modl = let rec init_shape_mod subid loc env mty = match Mtype.scrape env mty with | Mty_ident _ | Mty_alias _ -> raise (Initialization_failure (Unsafe { reason = Unsafe_module_binding; loc; subid })) | Mty_signature sg -> Const_block (0, [ Const_block (0, init_shape_struct env sg) ]) | Mty_functor _ -> (* can we do better? *) raise (Initialization_failure (Unsafe { reason = Unsafe_functor; loc; subid })) and init_shape_struct env sg = match sg with | [] -> [] | Sig_value (subid, { val_kind = Val_reg; val_type = ty; val_loc = loc }, _) :: rem -> let init_v = match Ctype.expand_head env ty with | { desc = Tarrow (_, _, _, _) } -> const_int 0 (* camlinternalMod.Function *) | { desc = Tconstr (p, _, _) } when Path.same p Predef.path_lazy_t -> const_int 1 (* camlinternalMod.Lazy *) | _ -> let not_a_function = Unsafe { reason = Unsafe_non_function; loc; subid } in raise (Initialization_failure not_a_function) in init_v :: init_shape_struct env rem | Sig_value (_, { val_kind = Val_prim _ }, _) :: rem -> init_shape_struct env rem | Sig_value _ :: _rem -> assert false | Sig_type (id, tdecl, _, _) :: rem -> init_shape_struct (Env.add_type ~check:false id tdecl env) rem | Sig_typext (subid, { ext_loc = loc }, _, _) :: _ -> raise (Initialization_failure (Unsafe { reason = Unsafe_typext; loc; subid })) | Sig_module (id, Mp_present, md, _, _) :: rem -> init_shape_mod id md.md_loc env md.md_type :: init_shape_struct (Env.add_module_declaration ~check:false id Mp_present md env) rem | Sig_module (id, Mp_absent, md, _, _) :: rem -> init_shape_struct (Env.add_module_declaration ~check:false id Mp_absent md env) rem | Sig_modtype (id, minfo, _) :: rem -> init_shape_struct (Env.add_modtype id minfo env) rem | Sig_class _ :: rem -> const_int 2 (* camlinternalMod.Class *) :: init_shape_struct env rem | Sig_class_type _ :: rem -> init_shape_struct env rem in try Ok ( undefined_location modl.mod_loc, Lconst (init_shape_mod id modl.mod_loc modl.mod_env modl.mod_type) ) with Initialization_failure reason -> Result.Error reason (* Reorder bindings to honor dependencies. *) type binding_status = | Undefined | Inprogress of int option (** parent node *) | Defined type id_or_ignore_loc = Id of Ident.t | Ignore_loc of Lambda.scoped_location let extract_unsafe_cycle id status init cycle_start = let info i = match init.(i) with | Result.Error r -> ( match id.(i) with | Id id -> (id, r) | Ignore_loc _ -> assert false (* Can't refer to something without a name. *)) | Ok _ -> assert false in let rec collect stop l i = match status.(i) with | Inprogress None | Undefined | Defined -> assert false | Inprogress (Some i) when i = stop -> info i :: l | Inprogress (Some i) -> collect stop (info i :: l) i in collect cycle_start [] cycle_start let reorder_rec_bindings bindings = let id = Array.of_list (List.map (fun (id, _, _, _) -> id) bindings) and loc = Array.of_list (List.map (fun (_, loc, _, _) -> loc) bindings) and init = Array.of_list (List.map (fun (_, _, init, _) -> init) bindings) and rhs = Array.of_list (List.map (fun (_, _, _, rhs) -> rhs) bindings) in let fv = Array.map Lambda.free_variables rhs in let num_bindings = Array.length id in let status = Array.make num_bindings Undefined in let res = ref [] in let is_unsafe i = match init.(i) with Ok _ -> false | Result.Error _ -> true in let init_res i = match init.(i) with Result.Error _ -> None | Ok (a, b) -> Some (a, b) in let rec emit_binding parent i = match status.(i) with | Defined -> () | Inprogress _ -> status.(i) <- Inprogress parent; let cycle = extract_unsafe_cycle id status init i in raise (Error (loc.(i), Circular_dependency cycle)) | Undefined -> if is_unsafe i then ( status.(i) <- Inprogress parent; for j = 0 to num_bindings - 1 do match id.(j) with | Id id when Ident.Set.mem id fv.(i) -> emit_binding (Some i) j | _ -> () done); res := (id.(i), init_res i, rhs.(i)) :: !res; status.(i) <- Defined in for i = 0 to num_bindings - 1 do match status.(i) with | Undefined -> emit_binding None i | Inprogress _ -> assert false | Defined -> () done; List.rev !res (* Generate lambda-code for a reordered list of bindings *) let eval_rec_bindings bindings cont = let rec bind_inits = function | [] -> bind_strict bindings | (Ignore_loc _, _, _) :: rem | (_, None, _) :: rem -> bind_inits rem | (Id id, Some (loc, shape), _rhs) :: rem -> Llet ( Strict, Pgenval, id, Lapply { ap_loc = Loc_unknown; ap_func = mod_prim "init_mod"; ap_args = [ loc; shape ]; ap_tailcall = Default_tailcall; ap_inlined = Default_inline; ap_specialised = Default_specialise; }, bind_inits rem ) and bind_strict = function | [] -> patch_forwards bindings | (Ignore_loc loc, None, rhs) :: rem -> Lsequence (Lprim (Pignore, [ rhs ], loc), bind_strict rem) | (Id id, None, rhs) :: rem -> Llet (Strict, Pgenval, id, rhs, bind_strict rem) | (_id, Some _, _rhs) :: rem -> bind_strict rem and patch_forwards = function | [] -> cont | (Ignore_loc _, _, _rhs) :: rem | (_, None, _rhs) :: rem -> patch_forwards rem | (Id id, Some (_loc, shape), rhs) :: rem -> Lsequence ( Lapply { ap_loc = Loc_unknown; ap_func = mod_prim "update_mod"; ap_args = [ shape; Lvar id; rhs ]; ap_tailcall = Default_tailcall; ap_inlined = Default_inline; ap_specialised = Default_specialise; }, patch_forwards rem ) in bind_inits bindings let compile_recmodule ~scopes compile_rhs bindings cont = eval_rec_bindings (reorder_rec_bindings (List.map (fun { mb_id = id; mb_name; mb_expr = modl; mb_loc = loc; _ } -> let id_or_ignore_loc, shape = match id with | None -> let loc = of_location ~scopes mb_name.loc in (Ignore_loc loc, Result.Error Unnamed) | Some id -> (Id id, init_shape id modl) in (id_or_ignore_loc, modl.mod_loc, shape, compile_rhs id modl loc)) bindings)) cont (* Code to translate class entries in a structure *) let transl_class_bindings ~scopes cl_list = let ids = List.map (fun (ci, _) -> ci.ci_id_class) cl_list in ( ids, List.map (fun ({ ci_id_class = id; ci_expr = cl; ci_virt = vf }, meths) -> (id, transl_class ~scopes ids id meths cl vf)) cl_list ) (* Compile one or more functors, merging curried functors to produce multi-argument functors. Any [@inline] attribute on a functor that is merged must be consistent with any other [@inline] attribute(s) on the functor(s) being merged with. Such an attribute will be placed on the resulting merged functor. *) let merge_inline_attributes attr1 attr2 loc = match Lambda.merge_inline_attributes attr1 attr2 with | Some attr -> attr | None -> raise (Error (to_location loc, Conflicting_inline_attributes)) let merge_functors ~scopes mexp coercion root_path = let rec merge ~scopes mexp coercion path acc inline_attribute = let finished = (acc, mexp, path, coercion, inline_attribute) in match mexp.mod_desc with | Tmod_functor (param, body) -> let inline_attribute' = Translattribute.get_inline_attribute mexp.mod_attributes in let arg_coercion, res_coercion = match coercion with | Tcoerce_none -> (Tcoerce_none, Tcoerce_none) | Tcoerce_functor (arg_coercion, res_coercion) -> (arg_coercion, res_coercion) | _ -> fatal_error "Translmod.merge_functors: bad coercion" in let loc = of_location ~scopes mexp.mod_loc in let path, param = match param with | Unit -> (None, Ident.create_local "*") | Named (None, _, _) -> let id = Ident.create_local "_" in (functor_path path id, id) | Named (Some id, _, _) -> (functor_path path id, id) in let inline_attribute = merge_inline_attributes inline_attribute inline_attribute' loc in merge ~scopes body res_coercion path ((param, loc, arg_coercion) :: acc) inline_attribute | _ -> finished in merge ~scopes mexp coercion root_path [] Default_inline let rec compile_functor ~scopes mexp coercion root_path loc = let functor_params_rev, body, body_path, res_coercion, inline_attribute = merge_functors ~scopes mexp coercion root_path in assert (List.length functor_params_rev >= 1); (* cf. [transl_module] *) let params, body = List.fold_left (fun (params, body) (param, loc, arg_coercion) -> let param' = Ident.rename param in let arg = apply_coercion loc Alias arg_coercion (Lvar param') in let params = (param', Pgenval) :: params in let body = Llet (Alias, Pgenval, param, arg, body) in (params, body)) ([], transl_module ~scopes res_coercion body_path body) functor_params_rev in Lfunction { kind = Curried; params; return = Pgenval; attr = { inline = inline_attribute; specialise = Default_specialise; local = Default_local; is_a_functor = true; stub = false; }; loc; body; } (* Compile a module expression *) and transl_module ~scopes cc rootpath mexp = List.iter (Translattribute.check_attribute_on_module mexp) mexp.mod_attributes; let loc = of_location ~scopes mexp.mod_loc in match mexp.mod_desc with | Tmod_ident (path, _) -> apply_coercion loc Strict cc (transl_module_path loc mexp.mod_env path) | Tmod_structure str -> fst (transl_struct ~scopes loc [] cc rootpath str) | Tmod_functor _ -> oo_wrap mexp.mod_env true (fun () -> compile_functor ~scopes mexp cc rootpath loc) () | Tmod_apply (funct, arg, ccarg) -> let inlined_attribute, funct = Translattribute.get_and_remove_inlined_attribute_on_module funct in oo_wrap mexp.mod_env true (apply_coercion loc Strict cc) (Lapply { ap_loc = loc; ap_func = transl_module ~scopes Tcoerce_none None funct; ap_args = [ transl_module ~scopes ccarg None arg ]; ap_tailcall = Default_tailcall; ap_inlined = inlined_attribute; ap_specialised = Default_specialise; }) | Tmod_constraint (arg, _, _, ccarg) -> transl_module ~scopes (compose_coercions cc ccarg) rootpath arg | Tmod_unpack (arg, _) -> apply_coercion loc Strict cc (Translcore.transl_exp ~scopes arg) and transl_struct ~scopes loc fields cc rootpath { str_final_env; str_items; _ } = transl_structure ~scopes loc fields cc rootpath str_final_env str_items (* The function transl_structure is called by the bytecode compiler. Some effort is made to compile in top to bottom order, in order to display warning by increasing locations. *) and transl_structure ~scopes loc fields cc rootpath final_env = function | [] -> let body, size = match cc with | Tcoerce_none -> ( Lprim ( Pmakeblock (0, Immutable, None), List.map (fun id -> Lvar id) (List.rev fields), loc ), List.length fields ) | Tcoerce_structure (pos_cc_list, id_pos_list) -> (* Do not ignore id_pos_list ! *) (*Format.eprintf "%a@.@[" Includemod.print_coercion cc; List.iter (fun l -> Format.eprintf "%a@ " Ident.print l) fields; Format.eprintf "@]@.";*) let v = Array.of_list (List.rev fields) in let get_field pos = if pos < 0 then lambda_unit else Lvar v.(pos) in let ids = List.fold_right Ident.Set.add fields Ident.Set.empty in let lam = Lprim ( Pmakeblock (0, Immutable, None), List.map (fun (pos, cc) -> match cc with | Tcoerce_primitive p -> Translprim.transl_primitive (of_location ~scopes p.pc_loc) p.pc_desc p.pc_env p.pc_type None | _ -> apply_coercion loc Strict cc (get_field pos)) pos_cc_list, loc ) and id_pos_list = List.filter (fun (id, _, _) -> not (Ident.Set.mem id ids)) id_pos_list in ( wrap_id_pos_list loc id_pos_list get_field lam, List.length pos_cc_list ) | _ -> fatal_error "Translmod.transl_structure" in (* This debugging event provides information regarding the structure items. It is ignored by the OCaml debugger but is used by Js_of_ocaml to preserve variable names. *) ( (if !Clflags.debug && not !Clflags.native_code then Levent ( body, { lev_loc = loc; lev_kind = Lev_pseudo; lev_repr = None; lev_env = final_env; } ) else body), size ) | item :: rem -> ( match item.str_desc with | Tstr_eval (expr, _) -> let body, size = transl_structure ~scopes loc fields cc rootpath final_env rem in (Lsequence (transl_exp ~scopes expr, body), size) | Tstr_value (rec_flag, pat_expr_list) -> (* Translate bindings first *) let mk_lam_let = transl_let ~scopes ~in_structure:true rec_flag pat_expr_list in let ext_fields = List.rev_append (let_bound_idents pat_expr_list) fields in (* Then, translate remainder of struct *) let body, size = transl_structure ~scopes loc ext_fields cc rootpath final_env rem in (mk_lam_let body, size) | Tstr_primitive descr -> record_primitive descr.val_val; transl_structure ~scopes loc fields cc rootpath final_env rem | Tstr_type _ -> transl_structure ~scopes loc fields cc rootpath final_env rem | Tstr_typext tyext -> let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in let body, size = transl_structure ~scopes loc (List.rev_append ids fields) cc rootpath final_env rem in (transl_type_extension ~scopes item.str_env rootpath tyext body, size) | Tstr_exception ext -> let id = ext.tyexn_constructor.ext_id in let path = field_path rootpath id in let body, size = transl_structure ~scopes loc (id :: fields) cc rootpath final_env rem in ( Llet ( Strict, Pgenval, id, transl_extension_constructor ~scopes item.str_env path ext.tyexn_constructor, body ), size ) | Tstr_module ({ mb_presence = Mp_present } as mb) -> ( let id = mb.mb_id in (* Translate module first *) let subscopes = match id with | None -> scopes | Some id -> enter_module_definition ~scopes id in let module_body = transl_module ~scopes:subscopes Tcoerce_none (Option.bind id (field_path rootpath)) mb.mb_expr in let module_body = Translattribute.add_inline_attribute module_body mb.mb_loc mb.mb_attributes in (* Translate remainder second *) let body, size = transl_structure ~scopes loc (cons_opt id fields) cc rootpath final_env rem in match id with | None -> ( Lsequence ( Lprim ( Pignore, [ module_body ], of_location ~scopes mb.mb_name.loc ), body ), size ) | Some id -> let module_body = Levent ( module_body, { lev_loc = of_location ~scopes mb.mb_loc; lev_kind = Lev_module_definition id; lev_repr = None; lev_env = Env.empty; } ) in ( Llet (pure_module mb.mb_expr, Pgenval, id, module_body, body), size )) | Tstr_module ({ mb_presence = Mp_absent } as mb) -> List.iter (Translattribute.check_attribute_on_module mb.mb_expr) mb.mb_attributes; List.iter (Translattribute.check_attribute_on_module mb.mb_expr) mb.mb_expr.mod_attributes; transl_structure ~scopes loc fields cc rootpath final_env rem | Tstr_recmodule bindings -> let ext_fields = List.rev_append (List.filter_map (fun mb -> mb.mb_id) bindings) fields in let body, size = transl_structure ~scopes loc ext_fields cc rootpath final_env rem in let lam = compile_recmodule ~scopes (fun id modl loc -> match id with | None -> transl_module ~scopes Tcoerce_none None modl | Some id -> let module_body = transl_module ~scopes:(enter_module_definition ~scopes id) Tcoerce_none (field_path rootpath id) modl in Levent ( module_body, { lev_loc = of_location ~scopes loc; lev_kind = Lev_module_definition id; lev_repr = None; lev_env = Env.empty; } )) bindings body in (lam, size) | Tstr_class cl_list -> let ids, class_bindings = transl_class_bindings ~scopes cl_list in let body, size = transl_structure ~scopes loc (List.rev_append ids fields) cc rootpath final_env rem in (Lletrec (class_bindings, body), size) | Tstr_include incl -> let ids = bound_value_identifiers incl.incl_type in let modl = incl.incl_mod in let mid = Ident.create_local "include" in let rec rebind_idents pos newfields = function | [] -> transl_structure ~scopes loc newfields cc rootpath final_env rem | id :: ids -> let body, size = rebind_idents (pos + 1) (id :: newfields) ids in ( Llet ( Alias, Pgenval, id, Lprim ( Pfield pos, [ Lvar mid ], of_location ~scopes incl.incl_loc ), body ), size ) in let body, size = rebind_idents 0 fields ids in ( Llet ( pure_module modl, Pgenval, mid, transl_module ~scopes Tcoerce_none None modl, body ), size ) | Tstr_open od -> ( let pure = pure_module od.open_expr in (* this optimization shouldn't be needed because Simplif would actually remove the [Llet] when it's not used. But since [scan_used_globals] runs before Simplif, we need to do it. *) match od.open_bound_items with | [] when pure = Alias -> transl_structure ~scopes loc fields cc rootpath final_env rem | _ -> let ids = bound_value_identifiers od.open_bound_items in let mid = Ident.create_local "open" in let rec rebind_idents pos newfields = function | [] -> transl_structure ~scopes loc newfields cc rootpath final_env rem | id :: ids -> let body, size = rebind_idents (pos + 1) (id :: newfields) ids in ( Llet ( Alias, Pgenval, id, Lprim ( Pfield pos, [ Lvar mid ], of_location ~scopes od.open_loc ), body ), size ) in let body, size = rebind_idents 0 fields ids in ( Llet ( pure, Pgenval, mid, transl_module ~scopes Tcoerce_none None od.open_expr, body ), size )) | Tstr_modtype _ | Tstr_class_type _ | Tstr_attribute _ -> transl_structure ~scopes loc fields cc rootpath final_env rem) (* Compile a toplevel phrase *) let toploop_ident = Ident.create_persistent "Topinf" let toploop_getvalue_pos = 0 (* position of getvalue in module Topinf *) let toploop_setvalue_pos = 1 (* position of setvalue in module Topinf *) let aliased_idents = ref Ident.empty let set_toplevel_unique_name id = aliased_idents := Ident.add id (Ident.unique_toplevel_name id) !aliased_idents let toplevel_name id = F.epr "toplevel_name: %s @." (Ident.name id); try Ident.find_same id !aliased_idents with Not_found -> Ident.name id let toploop_getvalue id = F.epr "toploop_getvalue: %s @." (Ident.name id); Lapply { ap_loc = Loc_unknown; ap_func = Lprim ( Pfield toploop_getvalue_pos, [ Lprim (Pgetglobal toploop_ident, [], Loc_unknown) ], Loc_unknown ); ap_args = [ Lconst (Const_base (Const_string (toplevel_name id, Location.none, None))); ]; ap_tailcall = Default_tailcall; ap_inlined = Default_inline; ap_specialised = Default_specialise; } let toploop_setvalue id lam = F.epr "toploop_setvalue: %s @." (Ident.name id); Lapply { ap_loc = Loc_unknown; ap_func = Lprim ( Pfield toploop_setvalue_pos, [ Lprim (Pgetglobal toploop_ident, [], Loc_unknown) ], Loc_unknown ); ap_args = [ Lconst (Const_base (Const_string (toplevel_name id, Location.none, None))); lam; ]; ap_tailcall = Default_tailcall; ap_inlined = Default_inline; ap_specialised = Default_specialise; } let toploop_setvalue_id id = F.epr "toploop_setvalue_id: %s @." (Ident.name id); toploop_setvalue id (Lambda.Lvar id) let close_toplevel_term (lam, ()) = Ident.Set.fold (fun id l -> Lambda.Llet (Strict, Pgenval, id, toploop_getvalue id, l)) (Lambda.free_variables lam) lam let transl_toplevel_item ~scopes (item : structure_item) = match item.str_desc with | Tstr_eval (expr, _) | Tstr_value (Nonrecursive, [ { vb_pat = { pat_desc = Tpat_any }; vb_expr = expr } ]) -> (* special compilation for toplevel "let _ = expr", so that Toploop can display the result of the expression. Otherwise, the normal compilation would result in a Lsequence returning unit. *) Translcore.transl_exp ~scopes expr | Tstr_value (rec_flag, pat_expr_list) -> let idents = let_bound_idents pat_expr_list in transl_let ~scopes ~in_structure:true rec_flag pat_expr_list (make_sequence toploop_setvalue_id idents) | Tstr_typext tyext -> let idents = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in (* we need to use unique name in case of multiple definitions of the same extension constructor in the toplevel *) List.iter set_toplevel_unique_name idents; transl_type_extension ~scopes item.str_env None tyext (make_sequence toploop_setvalue_id idents) | Tstr_exception ext -> set_toplevel_unique_name ext.tyexn_constructor.ext_id; toploop_setvalue ext.tyexn_constructor.ext_id (transl_extension_constructor ~scopes item.str_env None ext.tyexn_constructor) | Tstr_module { mb_id = None; mb_presence = Mp_present; mb_expr = modl } -> transl_module ~scopes Tcoerce_none None modl | Tstr_module { mb_id = Some id; mb_presence = Mp_present; mb_expr = modl } -> (* we need to use the unique name for the module because of issues with "open" (PR#8133) *) set_toplevel_unique_name id; let lam = transl_module ~scopes:(enter_module_definition ~scopes id) Tcoerce_none (Some (Pident id)) modl in toploop_setvalue id lam | Tstr_recmodule bindings -> let idents = List.filter_map (fun mb -> mb.mb_id) bindings in compile_recmodule ~scopes (fun id modl _loc -> match id with | None -> transl_module ~scopes Tcoerce_none None modl | Some id -> transl_module ~scopes:(enter_module_definition ~scopes id) Tcoerce_none (Some (Pident id)) modl) bindings (make_sequence toploop_setvalue_id idents) | Tstr_class cl_list -> (* we need to use unique names for the classes because there might be a value named identically *) let ids, class_bindings = transl_class_bindings ~scopes cl_list in List.iter set_toplevel_unique_name ids; Lletrec (class_bindings, make_sequence toploop_setvalue_id ids) | Tstr_include incl -> let ids = bound_value_identifiers incl.incl_type in let modl = incl.incl_mod in let mid = Ident.create_local "include" in let rec set_idents pos = function | [] -> lambda_unit | id :: ids -> Lsequence ( toploop_setvalue id (Lprim (Pfield pos, [ Lvar mid ], Loc_unknown)), set_idents (pos + 1) ids ) in Llet ( Strict, Pgenval, mid, transl_module ~scopes Tcoerce_none None modl, set_idents 0 ids ) | Tstr_primitive descr -> record_primitive descr.val_val; lambda_unit | Tstr_open od -> ( let pure = pure_module od.open_expr in (* this optimization shouldn't be needed because Simplif would actually remove the [Llet] when it's not used. But since [scan_used_globals] runs before Simplif, we need to do it. *) match od.open_bound_items with | [] when pure = Alias -> lambda_unit | _ -> let ids = bound_value_identifiers od.open_bound_items in let mid = Ident.create_local "open" in let rec set_idents pos = function | [] -> lambda_unit | id :: ids -> Lsequence ( toploop_setvalue id (Lprim (Pfield pos, [ Lvar mid ], Loc_unknown)), set_idents (pos + 1) ids ) in Llet ( pure, Pgenval, mid, transl_module ~scopes Tcoerce_none None od.open_expr, set_idents 0 ids )) | Tstr_module ({ mb_presence = Mp_absent } as mb) -> List.iter (Translattribute.check_attribute_on_module mb.mb_expr) mb.mb_attributes; List.iter (Translattribute.check_attribute_on_module mb.mb_expr) mb.mb_expr.mod_attributes; lambda_unit | Tstr_modtype _ | Tstr_type _ | Tstr_class_type _ | Tstr_attribute _ -> lambda_unit let transl_toplevel_item_and_close ~scopes itm = close_toplevel_term (transl_label_init (fun () -> (transl_toplevel_item ~scopes itm, ()))) let transl_toplevel_definition str = Translobj.reset_labels (); Translprim.clear_used_primitives (); Lambda.make_sequence (transl_toplevel_item_and_close ~scopes:empty_scopes) str.str_items (* Return the value referred to by a path *) let rec eval_address = function | Env.Aident id -> ( if Ident.persistent id || Ident.global id then Symtable.get_global_value id else let name = toplevel_name id in try String.Map.find name !toplevel_value_bindings with Not_found -> raise (Symtable.Error (Symtable.Undefined_global name))) | Env.Adot (p, pos) -> Obj.field (eval_address p) pos let eval_path find env path = match find path env with | addr -> eval_address addr | exception Not_found -> fatal_error ("Cannot find address for: " ^ Path.name path) let eval_module_path env path = eval_path Env.find_module_address env path let eval_value_path env path = eval_path Env.find_value_address env path let eval_extension_path env path = eval_path Env.find_constructor_address env path let eval_class_path env path = eval_path Env.find_class_address env path (* To print values *) module EvalPath = struct type valu = Obj.t exception Error let eval_address addr = try eval_address addr with Symtable.Error _ -> raise Error let same_value v1 v2 = v1 == v2 end module Printer = Genprintval.Make (Obj) (EvalPath) let max_printer_depth = ref 100 let max_printer_steps = ref 300 let print_out_value = Oprint.out_value let print_out_type = Oprint.out_type let print_out_class_type = Oprint.out_class_type let print_out_module_type = Oprint.out_module_type let print_out_type_extension = Oprint.out_type_extension let print_out_sig_item = Oprint.out_sig_item let print_out_signature = Oprint.out_signature let print_out_phrase = Oprint.out_phrase let print_untyped_exception ppf obj = !print_out_value ppf (Printer.outval_of_untyped_exception obj) let outval_of_value env obj ty = Printer.outval_of_value !max_printer_steps !max_printer_depth (fun _ _ _ -> None) env obj ty let print_value env obj ppf ty = !print_out_value ppf (outval_of_value env obj ty) type ('a, 'b) gen_printer = ('a, 'b) Genprintval.gen_printer = | Zero of 'b | Succ of ('a -> ('a, 'b) gen_printer) let install_printer = Printer.install_printer let install_generic_printer = Printer.install_generic_printer let install_generic_printer' = Printer.install_generic_printer' let remove_printer = Printer.remove_printer (* Hooks for parsing functions *) let parse_toplevel_phrase = ref Parse.toplevel_phrase let parse_use_file = ref Parse.use_file let print_location = Location.print_loc let print_error = Location.print_report let print_warning = Location.print_warning let input_name = Location.input_name let parse_mod_use_file name lb = let modname = String.capitalize_ascii (Filename.remove_extension (Filename.basename name)) in let items = List.concat (List.map (function Ptop_def s -> s | Ptop_dir _ -> []) (!parse_use_file lb)) in [ Ptop_def [ Str.module_ (Mb.mk (Location.mknoloc (Some modname)) (Mod.structure items)); ]; ] (* Hook for initialization *) let toplevel_startup_hook = ref (fun () -> ()) type event = .. type event += Startup | After_setup let hooks = ref [] let add_hook f = hooks := f :: !hooks let () = add_hook (function Startup -> !toplevel_startup_hook () | _ -> ()) let run_hooks hook = List.iter (fun f -> f hook) !hooks (* Load in-core and execute a lambda term *) let outval_of_value env obj ty = Printer.outval_of_value !max_printer_steps !max_printer_depth (fun _ _ _ -> None) env obj ty let may_trace = ref false (* Global lock on tracing *) type evaluation_outcome = Result of Obj.t | Exception of exn let backtrace = ref None let record_backtrace () = if Printexc.backtrace_status () then backtrace := Some (Printexc.get_backtrace ()) let load_lambda ppf lam = if !Clflags.dump_rawlambda then Format.fprintf ppf "%a@." Printlambda.lambda lam; let slam = Simplif.simplify_lambda lam in if !Clflags.dump_lambda then Format.fprintf ppf "%a@." Printlambda.lambda slam; let init_code, fun_code = Bytegen.compile_phrase slam in if !Clflags.dump_instr then Format.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 (toplevel_name id)) val_type) | _ -> None) let read_interactive_input = ref (fun _ _ -> 0) (* Toplevel initialization. Performed here instead of at the beginning of loop() so that user code linked in with ocamlmktop can call directives from Topdirs. *) let _ = (*if !Sys.interactive then (* PR#6108 *) invalid_arg "The ocamltoplevel.cma library from compiler-libs \ cannot be loaded inside the OCaml toplevel"; *) Sys.interactive := true; let crc_intfs = Symtable.init_toplevel () in Compmisc.init_path (); Env.import_crcs ~source:Sys.executable_name crc_intfs; () (* The current typing environment for the toplevel *) let toplevel_env = ref Env.empty let initialize_toplevel_env () = toplevel_env := Compmisc.initial_env () let set_paths () = (* Add whatever -I options have been specified on the command line, but keep the directories that user code linked in with ocamlmktop may have added to load_path. *) let expand = Misc.expand_directory Config.standard_library in let current_load_path = Load_path.get_paths () in let load_path = List.concat [ [ "" ]; List.map expand (List.rev !Compenv.first_include_dirs); List.map expand (List.rev !Clflags.include_dirs); List.map expand (List.rev !Compenv.last_include_dirs); current_load_path; [ expand "+camlp4" ]; ] in Load_path.init load_path; Dll.add_path load_path (* Print an exception produced by an evaluation *) let print_out_exception ppf exn outv = !print_out_phrase ppf (Ophr_exception (exn, outv)) let print_exception_outcome ppf exn = if exn = Out_of_memory then Gc.full_major (); let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in print_out_exception ppf exn outv; if Printexc.backtrace_status () then match !backtrace with | None -> () | Some b -> print_string b; backtrace := None (* Inserting new toplevel directives *) let directive_table = (Hashtbl.create 23 : (string, directive_fun) Hashtbl.t) let directive_info_table = (Hashtbl.create 23 : (string, directive_info) Hashtbl.t) let add_directive name dir_fun dir_info = Hashtbl.add directive_table name dir_fun; Hashtbl.add directive_info_table name dir_info (* 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, newenv = Typemod.type_toplevel_phrase oldenv sstr in if !Clflags.dump_typedtree then Printtyped.implementation ppf str; 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 = transl_toplevel_definition str in Warnings.check_fatal (); 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 match !backtrace with | None -> () | Some b -> pp_print_string ppf b; pp_print_flush ppf (); backtrace := None); match out_phr with | Ophr_eval (_, _) | Ophr_signature _ -> true | Ophr_exception _ -> false with x -> toplevel_env := oldenv; raise x) | Ptop_dir { pdir_name = { Location.txt = dir_name }; pdir_arg } -> ( let d = try Some (Hashtbl.find directive_table dir_name) with Not_found -> None in match d with | None -> fprintf ppf "Unknown directive `%s'." dir_name; let directives = Hashtbl.fold (fun dir _ acc -> dir :: acc) directive_table [] in Misc.did_you_mean ppf (fun () -> Misc.spellcheck directives dir_name); fprintf ppf "@."; false | Some d -> ( match (d, pdir_arg) with | Directive_none f, None -> f (); true | Directive_string f, Some { pdira_desc = Pdir_string s } -> f s; true | Directive_int f, Some { pdira_desc = Pdir_int (n, None) } -> ( match Int_literal_converter.int n with | n -> f n; true | exception _ -> fprintf ppf "Integer literal exceeds the range of representable \ integers for directive `%s'.@." dir_name; false) | Directive_int _, Some { pdira_desc = Pdir_int (_, Some _) } -> fprintf ppf "Wrong integer literal for directive `%s'.@." dir_name; false | Directive_ident f, Some { pdira_desc = Pdir_ident lid } -> f lid; true | Directive_bool f, Some { pdira_desc = Pdir_bool b } -> f b; true | _ -> fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name; false)) let execute_phrase print_outcome ppf phr = try execute_phrase print_outcome ppf phr with exn -> Warnings.reset_fatal (); raise exn (* Read and execute commands from a file, or from stdin if [name] is "". *) let use_print_results = ref true let preprocess_phrase ppf phr = let phr = match phr with | Ptop_def str -> let str = Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str in Ptop_def str | phr -> phr in if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; if !Clflags.dump_source then Pprintast.top_phrase ppf phr; phr let use_channel ppf ~wrap_in_module ic name filename = let lb = Lexing.from_channel ic in Warnings.reset_fatal (); Location.init lb filename; (* Skip initial #! line if any *) Lexer.skip_hash_bang lb; protect_refs [ R (Location.input_name, filename); R (Location.input_lexbuf, Some lb) ] (fun () -> try List.iter (fun ph -> let ph = preprocess_phrase ppf ph in if not (execute_phrase !use_print_results ppf ph) then raise Exit) (if wrap_in_module then parse_mod_use_file name lb else !parse_use_file lb); true with | Exit -> false | Sys.Break -> fprintf ppf "Interrupted.@."; false | x -> Location.report_exception ppf x; false) let use_output ppf command = let fn = Filename.temp_file "ocaml" "_toploop.ml" in Misc.try_finally ~always:(fun () -> try Sys.remove fn with Sys_error _ -> ()) (fun () -> match Printf.ksprintf Sys.command "%s > %s" command (Filename.quote fn) with | 0 -> let ic = open_in_bin fn in Misc.try_finally ~always:(fun () -> close_in ic) (fun () -> use_channel ppf ~wrap_in_module:false ic "" "(command-output)") | n -> fprintf ppf "Command exited with code %d.@." n; false) let use_file ppf ~wrap_in_module name = match name with | "" -> use_channel ppf ~wrap_in_module stdin name "(stdin)" | _ -> ( match Load_path.find name with | filename -> let ic = open_in_bin filename in Misc.try_finally ~always:(fun () -> close_in ic) (fun () -> use_channel ppf ~wrap_in_module ic name filename) | exception Not_found -> fprintf ppf "Cannot find file %s.@." name; false) let mod_use_file ppf name = use_file ppf ~wrap_in_module:true name let use_file ppf name = use_file ppf ~wrap_in_module:false name let use_silently ppf name = protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name) module Topdirs = struct (* Toplevel directives *) (* The standard output formatter *) let std_out = ref std_formatter (* Directive sections (used in #help) *) let section_general = "General" let section_run = "Loading code" let section_env = "Environment queries" let section_print = "Pretty-printing" let section_trace = "Tracing" let section_options = "Compiler options" let section_undocumented = "Undocumented" (* we will print the sections in the first list, then all user-defined sections, then the sections in the second list, then all undocumented directives *) let order_of_sections = ( [ section_general; section_run; section_env ], [ section_print; section_trace; section_options; section_undocumented ] ) (* Do not forget to keep the directives synchronized with the manual in manual/manual/cmds/top.etex *) (* To quit *) let dir_quit () = raise (Compenv.Exit_with_status 0) let _ = add_directive "quit" (Directive_none dir_quit) { section = section_general; doc = "Exit the toplevel." } (* To add a directory to the load path *) let dir_directory s = let d = expand_directory Config.standard_library s in Dll.add_path [ d ]; let dir = Load_path.Dir.create d in Load_path.add dir; toplevel_env := Stdlib.String.Set.fold (fun name env -> Env.add_persistent_structure (Ident.create_persistent name) env) (Env.persistent_structures_of_dir dir) !toplevel_env let _ = add_directive "directory" (Directive_string dir_directory) { section = section_run; doc = "Add the given directory to search path for source and compiled \ files."; } (* To remove a directory from the load path *) let dir_remove_directory s = let d = expand_directory Config.standard_library s in let keep id = match Load_path.find_uncap (Ident.name id ^ ".cmi") with | exception Not_found -> true | fn -> Filename.dirname fn <> d in toplevel_env := Env.filter_non_loaded_persistent keep !toplevel_env; Load_path.remove_dir s; Dll.remove_path [ d ] let _ = add_directive "remove_directory" (Directive_string dir_remove_directory) { section = section_run; doc = "Remove the given directory from the search path."; } (* To change the current directory *) let dir_cd s = Sys.chdir s let _ = add_directive "cd" (Directive_string dir_cd) { section = section_run; doc = "Change the current working directory." } (* Load in-core a .cmo file *) 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 "@[The files %s@ and %s@ disagree over interface %s@]@." user auth name; raise Load_failed 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 ( seek_in ic compunit.cu_debug; [| input_value ic |]) in 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 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 ( 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 match Load_path.find_uncap file with | exception Not_found -> () | file -> if not (load_file recursive ppf file) then raise Load_failed) | _ -> ()) cu.cu_reloc; load_compunit ic filename ppf cu; true) else if buffer = Config.cma_magic_number then ( 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) else ( fprintf ppf "File %s is not a bytecode object file.@." name; false) with Load_failed -> false let dir_load ppf name = ignore (load_file false ppf name) let _ = add_directive "load" (Directive_string (dir_load !std_out)) { section = section_run; doc = "Load in memory a bytecode object, produced by ocamlc."; } let dir_load_rec ppf name = ignore (load_file true ppf name) let _ = add_directive "load_rec" (Directive_string (dir_load_rec !std_out)) { section = section_run; doc = "As #load, but loads dependencies recursively."; } let load_file = load_file false (* Load commands from a file *) let dir_use ppf name = ignore (use_file ppf name) let dir_use_output ppf name = ignore (use_output ppf name) let dir_mod_use ppf name = ignore (mod_use_file ppf name) let _ = add_directive "use" (Directive_string (dir_use !std_out)) { section = section_run; doc = "Read, compile and execute source phrases from the given file."; } let _ = add_directive "use_output" (Directive_string (dir_use_output !std_out)) { section = section_run; doc = "Execute a command and read, compile and execute source phrases from \ its output."; } let _ = add_directive "mod_use" (Directive_string (dir_mod_use !std_out)) { section = section_run; doc = "Usage is identical to #use but #mod_use wraps the contents in a \ module."; } (* Install, remove a printer *) let filter_arrow ty = let ty = Ctype.expand_head !toplevel_env ty in match ty.desc with | Tarrow (lbl, l, r, _) when not (Btype.is_optional lbl) -> Some (l, r) | _ -> None let rec extract_last_arrow desc = match filter_arrow desc with | None -> raise (Ctype.Unify []) | Some ((_, r) as res) -> ( try extract_last_arrow r with Ctype.Unify _ -> res) let extract_target_type ty = fst (extract_last_arrow ty) let extract_target_parameters ty = let ty = extract_target_type ty |> Ctype.expand_head !toplevel_env in match ty.desc with | Tconstr (path, (_ :: _ as args), _) when Ctype.all_distinct_vars !toplevel_env args -> Some (path, args) | _ -> None type 'a printer_type_new = Format.formatter -> 'a -> unit type 'a printer_type_old = 'a -> unit let printer_type ppf typename = let printer_type = match Env.find_type_by_name (Ldot (Lident "Topdirs", typename)) !toplevel_env with | path, _ -> path | exception Not_found -> fprintf ppf "Cannot find type Topdirs.%s.@." typename; raise Exit in printer_type let match_simple_printer_type desc printer_type = Ctype.begin_def (); let ty_arg = Ctype.newvar () in Ctype.unify !toplevel_env (Ctype.newconstr printer_type [ ty_arg ]) (Ctype.instance desc.val_type); Ctype.end_def (); Ctype.generalize ty_arg; (ty_arg, None) let match_generic_printer_type desc path args printer_type = Ctype.begin_def (); let args = List.map (fun _ -> Ctype.newvar ()) args in let ty_target = Ctype.newty (Tconstr (path, args, ref Mnil)) in let ty_args = List.map (fun ty_var -> Ctype.newconstr printer_type [ ty_var ]) args in let ty_expected = List.fold_right (fun ty_arg ty -> Ctype.newty (Tarrow (Asttypes.Nolabel, ty_arg, ty, Cunknown))) ty_args (Ctype.newconstr printer_type [ ty_target ]) in Ctype.unify !toplevel_env ty_expected (Ctype.instance desc.val_type); Ctype.end_def (); Ctype.generalize ty_expected; if not (Ctype.all_distinct_vars !toplevel_env args) then raise (Ctype.Unify []); (ty_expected, Some (path, ty_args)) let match_printer_type ppf desc = let printer_type_new = printer_type ppf "printer_type_new" in let printer_type_old = printer_type ppf "printer_type_old" in try (match_simple_printer_type desc printer_type_new, false) with Ctype.Unify _ -> ( try (match_simple_printer_type desc printer_type_old, true) with Ctype.Unify _ as exn -> ( match extract_target_parameters desc.val_type with | None -> raise exn | Some (path, args) -> (match_generic_printer_type desc path args printer_type_new, false))) let find_printer_type ppf lid = match Env.find_value_by_name lid !toplevel_env with | path, desc -> ( match match_printer_type ppf desc with | ty_arg, is_old_style -> (ty_arg, path, is_old_style) | exception Ctype.Unify _ -> fprintf ppf "%a has a wrong type for a printing function.@." Printtyp.longident lid; raise Exit) | exception Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid; raise Exit let dir_install_printer ppf lid = try let (ty_arg, ty), path, is_old_style = find_printer_type ppf lid in let v = eval_value_path !toplevel_env path in match ty with | None -> let print_function = if is_old_style then fun _formatter repr -> Obj.obj v (Obj.obj repr) else fun formatter repr -> Obj.obj v formatter (Obj.obj repr) in install_printer path ty_arg print_function | Some (ty_path, ty_args) -> let rec build v = function | [] -> let print_function = if is_old_style then fun _formatter repr -> Obj.obj v (Obj.obj repr) else fun formatter repr -> Obj.obj v formatter (Obj.obj repr) in Zero print_function | _ :: args -> Succ (fun fn -> build ((Obj.obj v : _ -> Obj.t) fn) args) in install_generic_printer' path ty_path (build v ty_args) with Exit -> () let dir_remove_printer ppf lid = try let _ty_arg, path, _is_old_style = find_printer_type ppf lid in try remove_printer path with Not_found -> fprintf ppf "No printer named %a.@." Printtyp.longident lid with Exit -> () let _ = add_directive "install_printer" (Directive_ident (dir_install_printer !std_out)) { section = section_print; doc = "Registers a printer for values of a certain type."; } let _ = add_directive "remove_printer" (Directive_ident (dir_remove_printer !std_out)) { section = section_print; doc = "Remove the named function from the table of toplevel printers."; } (* The trace *) external current_environment : unit -> Obj.t = "caml_get_current_environment" let tracing_function_ptr = get_code_pointer (Obj.repr (fun arg -> Trace.print_trace (current_environment ()) arg)) let dir_trace ppf lid = match Env.find_value_by_name lid !toplevel_env with | path, desc -> ( (* Check if this is a primitive *) match desc.val_kind with | Val_prim _ -> fprintf ppf "%a is an external function and cannot be traced.@." Printtyp.longident lid | _ -> let clos = eval_value_path !toplevel_env path in (* Nothing to do if it's not a closure *) if Obj.is_block clos && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag) && match Ctype.(repr (expand_head !toplevel_env desc.val_type)) with | { desc = Tarrow _ } -> true | _ -> false then ( match is_traced clos with | Some opath -> fprintf ppf "%a is already traced (under the name %a).@." Printtyp.path path Printtyp.path opath | None -> (* Instrument the old closure *) traced_functions := { path; closure = clos; actual_code = get_code_pointer clos; instrumented_fun = instrument_closure !toplevel_env lid ppf desc.val_type; } :: !traced_functions; (* Redirect the code field of the closure to point to the instrumentation function *) set_code_pointer clos tracing_function_ptr; fprintf ppf "%a is now traced.@." Printtyp.longident lid) else fprintf ppf "%a is not a function.@." Printtyp.longident lid) | exception Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid let dir_untrace ppf lid = match Env.find_value_by_name lid !toplevel_env with | path, _desc -> let rec remove = function | [] -> fprintf ppf "%a was not traced.@." Printtyp.longident lid; [] | f :: rem -> if Path.same f.path path then ( set_code_pointer f.closure f.actual_code; fprintf ppf "%a is no longer traced.@." Printtyp.longident lid; rem) else f :: remove rem in traced_functions := remove !traced_functions | exception Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid let dir_untrace_all ppf () = List.iter (fun f -> set_code_pointer f.closure f.actual_code; fprintf ppf "%a is no longer traced.@." Printtyp.path f.path) !traced_functions; traced_functions := [] let parse_warnings ppf iserr s = try Warnings.parse_options iserr s with Arg.Bad err -> fprintf ppf "%s.@." err (* Typing information *) let trim_signature = function | Mty_signature sg -> Mty_signature (List.map (function | Sig_module (id, pres, md, rs, priv) -> let attribute = Ast_helper.Attr.mk (Location.mknoloc "...") (Parsetree.PStr []) in Sig_module ( id, pres, { md with md_attributes = attribute :: md.md_attributes }, rs, priv ) (*| Sig_modtype (id, Modtype_manifest mty) -> Sig_modtype (id, Modtype_manifest (trim_modtype mty))*) | item -> item) sg) | mty -> mty let show_prim to_sig ppf lid = let env = !toplevel_env in let loc = Location.none in try let s = match lid with | Longident.Lident s -> s | Longident.Ldot (_, s) -> s | Longident.Lapply _ -> fprintf ppf "Invalid path %a@." Printtyp.longident lid; raise Exit in let id = Ident.create_persistent s in let sg = to_sig env loc id lid in Printtyp.wrap_printing_env ~error:false env (fun () -> fprintf ppf "@[%a@]@." Printtyp.signature sg) with | Not_found -> fprintf ppf "@[Unknown element.@]@." | Exit -> () let all_show_funs = ref [] let reg_show_prim name to_sig doc = all_show_funs := to_sig :: !all_show_funs; add_directive name (Directive_ident (show_prim to_sig !std_out)) { section = section_env; doc } let () = reg_show_prim "show_val" (fun env loc id lid -> let _path, desc = Env.lookup_value ~loc lid env in [ Sig_value (id, desc, Exported) ]) "Print the signature of the corresponding value." let () = reg_show_prim "show_type" (fun env loc id lid -> let _path, desc = Env.lookup_type ~loc lid env in [ Sig_type (id, desc, Trec_not, Exported) ]) "Print the signature of the corresponding type constructor." (* Each registered show_prim function is called in turn * and any output produced is sent to std_out. * Two show_prim functions are needed for constructors, * one for exception constructors and another for * non-exception constructors (normal and extensible variants). *) let is_exception_constructor env type_expr = Ctype.equal env true [ type_expr ] [ Predef.type_exn ] let is_extension_constructor = function | Cstr_extension _ -> true | _ -> false let () = (* This show_prim function will only show constructor types * that are not also exception types. *) reg_show_prim "show_constructor" (fun env loc id lid -> let desc = Env.lookup_constructor ~loc Env.Positive lid env in if is_exception_constructor env desc.cstr_res then raise Not_found; let path = match Ctype.repr desc.cstr_res with | { desc = Tconstr (path, _, _) } -> path | _ -> raise Not_found in let type_decl = Env.find_type path env in if is_extension_constructor desc.cstr_tag then let ret_type = if desc.cstr_generalized then Some desc.cstr_res else None in let ext = { ext_type_path = path; ext_type_params = type_decl.type_params; ext_args = Cstr_tuple desc.cstr_args; ext_ret_type = ret_type; ext_private = Asttypes.Public; ext_loc = desc.cstr_loc; ext_attributes = desc.cstr_attributes; ext_uid = desc.cstr_uid; } in [ Sig_typext (id, ext, Text_first, Exported) ] else (* make up a fake Ident.t as type_decl : Types.type_declaration * does not have an Ident.t yet. Ident.create_presistent is a * good choice because it has no side-effects. * *) let type_id = Ident.create_persistent (Path.name path) in [ Sig_type (type_id, type_decl, Trec_first, Exported) ]) "Print the signature of the corresponding value constructor." let () = reg_show_prim "show_exception" (fun env loc id lid -> let desc = Env.lookup_constructor ~loc Env.Positive lid env in if not (is_exception_constructor env desc.cstr_res) then raise Not_found; let ret_type = if desc.cstr_generalized then Some Predef.type_exn else None in let ext = { ext_type_path = Predef.path_exn; ext_type_params = []; ext_args = Cstr_tuple desc.cstr_args; ext_ret_type = ret_type; ext_private = Asttypes.Public; ext_loc = desc.cstr_loc; ext_attributes = desc.cstr_attributes; ext_uid = desc.cstr_uid; } in [ Sig_typext (id, ext, Text_exception, Exported) ]) "Print the signature of the corresponding exception." let () = reg_show_prim "show_module" (fun env loc id lid -> let rec accum_aliases md acc = let acc = Sig_module ( id, Mp_present, { md with md_type = trim_signature md.md_type }, Trec_not, Exported ) :: acc in match md.md_type with | Mty_alias path -> let md = Env.find_module path env in accum_aliases md acc | Mty_ident _ | Mty_signature _ | Mty_functor _ -> List.rev acc in let _, md = Env.lookup_module ~loc lid env in accum_aliases md []) "Print the signature of the corresponding module." let () = reg_show_prim "show_module_type" (fun env loc id lid -> let _path, desc = Env.lookup_modtype ~loc lid env in [ Sig_modtype (id, desc, Exported) ]) "Print the signature of the corresponding module type." let () = reg_show_prim "show_class" (fun env loc id lid -> let _path, desc = Env.lookup_class ~loc lid env in [ Sig_class (id, desc, Trec_not, Exported) ]) "Print the signature of the corresponding class." let () = reg_show_prim "show_class_type" (fun env loc id lid -> let _path, desc = Env.lookup_cltype ~loc lid env in [ Sig_class_type (id, desc, Trec_not, Exported) ]) "Print the signature of the corresponding class type." let show env loc id lid = let sg = List.fold_left (fun sg f -> try f env loc id lid @ sg with _ -> sg) [] !all_show_funs in if sg = [] then raise Not_found else sg let () = add_directive "show" (Directive_ident (show_prim show !std_out)) { section = section_env; doc = "Print the signatures of components from any of the categories below."; } let _ = add_directive "trace" (Directive_ident (dir_trace !std_out)) { section = section_trace; doc = "All calls to the function named function-name will be traced."; } let _ = add_directive "untrace" (Directive_ident (dir_untrace !std_out)) { section = section_trace; doc = "Stop tracing the given function." } let _ = add_directive "untrace_all" (Directive_none (dir_untrace_all !std_out)) { section = section_trace; doc = "Stop tracing all functions traced so far."; } (* Control the printing of values *) let _ = add_directive "print_depth" (Directive_int (fun n -> max_printer_depth := n)) { section = section_print; doc = "Limit the printing of values to a maximal depth of n."; } let _ = add_directive "print_length" (Directive_int (fun n -> max_printer_steps := n)) { section = section_print; doc = "Limit the number of value nodes printed to at most n."; } (* Set various compiler flags *) let _ = add_directive "labels" (Directive_bool (fun b -> Clflags.classic := not b)) { section = section_options; doc = "Choose whether to ignore labels in function types."; } let _ = add_directive "principal" (Directive_bool (fun b -> Clflags.principal := b)) { section = section_options; doc = "Make sure that all types are derived in a principal way."; } let _ = add_directive "rectypes" (Directive_none (fun () -> Clflags.recursive_types := true)) { section = section_options; doc = "Allow arbitrary recursive types during type-checking."; } let _ = add_directive "ppx" (Directive_string (fun s -> Clflags.all_ppx := s :: !Clflags.all_ppx)) { section = section_options; doc = "After parsing, pipe the abstract syntax tree through the \ preprocessor command."; } let _ = add_directive "warnings" (Directive_string (parse_warnings !std_out false)) { section = section_options; doc = "Enable or disable warnings according to the argument."; } let _ = add_directive "warn_error" (Directive_string (parse_warnings !std_out true)) { section = section_options; doc = "Treat as errors the warnings enabled by the argument."; } (* #help directive *) let directive_sections () = let sections = Hashtbl.create 10 in let add_dir name dir = let section, doc = match Hashtbl.find directive_info_table name with | { section; doc } -> (section, Some doc) | exception Not_found -> ("Undocumented", None) in Hashtbl.replace sections section ((name, dir, doc) :: (try Hashtbl.find sections section with Not_found -> [])) in Hashtbl.iter add_dir directive_table; let take_section section = if not (Hashtbl.mem sections section) then (section, []) else let section_dirs = Hashtbl.find sections section |> List.sort (fun (n1, _, _) (n2, _, _) -> String.compare n1 n2) in Hashtbl.remove sections section; (section, section_dirs) in let before, after = order_of_sections in let sections_before = List.map take_section before in let sections_after = List.map take_section after in let sections_user = Hashtbl.fold (fun section _ acc -> section :: acc) sections [] |> List.sort String.compare |> List.map take_section in sections_before @ sections_user @ sections_after let print_directive ppf (name, directive, doc) = let param = match directive with | Directive_none _ -> "" | Directive_string _ -> " " | Directive_int _ -> " " | Directive_bool _ -> " " | Directive_ident _ -> " " in match doc with | None -> fprintf ppf "#%s%s@." name param | Some doc -> fprintf ppf "@[#%s%s@\n%a@]@." name param Format.pp_print_text doc let print_section ppf (section, directives) = if directives <> [] then ( fprintf ppf "%30s%s@." "" section; List.iter (print_directive ppf) directives; fprintf ppf "@.") let print_directives ppf () = List.iter (print_section ppf) (directive_sections ()) let _ = add_directive "help" (Directive_none (print_directives !std_out)) { section = section_general; doc = "Prints a list of all available directives, with corresponding \ argument type if appropriate."; } end type evalenv = Format.formatter -> string -> unit let eval lb ppf (text : string) = F.epr "Topmain.eval: \n"; Topdirs.std_out := ppf; (read_interactive_input := fun buffer _ -> Bytes.blit_string text 0 buffer 0 (String.length text); Buffer.add_string phrase_buffer text; (* Also populate the phrase buffer as new characters are added. *) String.length text); let snap = Btype.snapshot () in try F.epr "Topmain.eval: 1 reset@."; Buffer.reset phrase_buffer; (* Reset the phrase buffer, then flush the lexing buffer. *) Lexing.flush_input lb; (* calls read_interactive_input to fill buffer again *) Location.reset (); Warnings.reset_fatal (); F.epr "Topmain.eval: 2 parse_toplevel_phrase@."; let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in F.epr "Topmain.eval: 3 preprocess_phrase@."; let phr = preprocess_phrase ppf phr in F.epr "Topmain.eval: 4 Env.reset_cache_toplevel@."; Env.reset_cache_toplevel (); F.epr "Topmain.eval: 5 execute_phrase=%b@." (execute_phrase true ppf phr); F.epr "Topmain.eval: 6 handle exceptions@." with | End_of_file -> F.epr "Topmain.eval End_of_file exception\n"; Btype.backtrack snap | Sys.Break -> F.epr "Topmain.eval Sys.Break exception\n"; F.pf ppf "Interrupted.@."; Btype.backtrack snap | PPerror -> F.epr "Topmain.eval PPerror exception\n"; () | x -> F.epr "Topmain.eval unknown exception\n"; Location.report_exception ppf x; Btype.backtrack snap let preload_objects = ref [ (*"komm.cma"*) ] let init ppf = F.epr "Topmain.init: \n"; Topdirs.std_out := ppf; Clflags.include_dirs := List.rev_append [ Sys.getcwd () ] !Clflags.include_dirs; (* Topdirs.dir_directory ((Sys.getcwd ()) ^ "/topfind");*) let extra_paths = match Sys.getenv "OCAML_TOPLEVEL_PATH" with | exception Not_found -> [] | s -> Misc.split_path_contents s in Clflags.include_dirs := List.rev_append extra_paths !Clflags.include_dirs; Compenv.readenv ppf Before_args; Compenv.readenv ppf Before_link; Compmisc.read_clflags_from_env (); set_paths (); (try F.epr "Load_path.get_paths: @."; List.iter (fun s -> F.epr "\t%s\n" s) (Load_path.get_paths ()); let res = List.for_all (fun name -> F.epr "Topdirs.load_file: name=%s@." name; Topdirs.load_file ppf name) (List.rev !preload_objects @ !Compenv.first_objfiles) in run_hooks Startup; if not res then raise Exit with Exit as x -> Format.fprintf ppf "Topmain.init: Uncaught exception: %s\n" (Printexc.to_string x)); Compmisc.init_path (); Clflags.debug := true; Location.formatter_for_warnings := ppf; if not !Clflags.noversion then F.pf ppf "OCaml version %s@.@." Config.version; (try initialize_toplevel_env () with (Env.Error _ | Typetexp.Error _) as exn -> Location.report_exception ppf exn; raise Exit); let lb = Lexing.from_function (fun b l -> !read_interactive_input b l) in Location.init lb "//toplevel//"; Location.input_name := "//toplevel//"; Location.input_lexbuf := Some lb; Location.input_phrase_buffer := Some phrase_buffer; Sys.catch_break true; run_hooks After_setup; eval lb