2410 lines
80 KiB
OCaml
2410 lines
80 KiB
OCaml
[@@@ocaml.warning "-32"]
|
|
|
|
(* most of this is copied from ocaml sources because it's not exported in a way i found useful:
|
|
- toplevel/toploop.ml
|
|
- toplevel/topdirs.ml
|
|
- lambda/translmod.ml
|
|
|
|
ideally will reduce this file down in the future *)
|
|
|
|
module F = Fmt
|
|
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 =
|
|
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 print_toplevel_value_bindings ppf =
|
|
String.Map.iter
|
|
(fun k _ -> F.pf ppf "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 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 =
|
|
try Ident.find_same id !aliased_idents with Not_found -> Ident.name id
|
|
|
|
let toploop_getvalue 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 =
|
|
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 =
|
|
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 "@[<hv 0>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
|
|
|
|
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 _ -> " <str>"
|
|
| Directive_int _ -> " <int>"
|
|
| Directive_bool _ -> " <bool>"
|
|
| Directive_ident _ -> " <ident>"
|
|
in
|
|
match doc with
|
|
| None -> fprintf ppf "#%s%s@." name param
|
|
| Some doc ->
|
|
fprintf ppf "@[<hov 2>#%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) =
|
|
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
|
|
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 ();
|
|
let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
|
|
let phr = preprocess_phrase ppf phr in
|
|
Env.reset_cache_toplevel ();
|
|
ignore (execute_phrase true ppf phr)
|
|
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 =
|
|
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
|
|
let res =
|
|
List.for_all
|
|
(fun 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
|