diff options
Diffstat (limited to 'bytecomp/translmod.ml')
| -rw-r--r-- | bytecomp/translmod.ml | 182 |
1 files changed, 182 insertions, 0 deletions
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index e49a049d1..a9407e2aa 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -20,11 +20,17 @@ open Asttypes open Path open Types open Typedtree +open Primitive open Lambda open Translobj open Translcore open Translclass +type error = + Circular_dependency of Ident.t + +exception Error of Location.t * error + (* Compile a coercion *) let rec apply_coercion restr arg = @@ -87,6 +93,149 @@ let field_path path field = None -> None | Some p -> Some(Pdot(p, Ident.name field, Path.nopos)) +(* Utilities for compiling "module rec" definitions *) + +let undefined_exception loc = + (* Confer Translcore.assert_failed *) + let fname = match loc.Location.loc_start.Lexing.pos_fname with + | "" -> !Location.input_name + | x -> x in + let pos = loc.Location.loc_start in + let line = pos.Lexing.pos_lnum in + let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in + Lprim(Pmakeblock(0, Immutable), + [transl_path Predef.path_undefined_recursive_module; + Lconst(Const_block(0, + [Const_base(Const_string fname); + Const_base(Const_int line); + Const_base(Const_int char)]))]) + +let undefined_function exn_id = + Lfunction(Curried, [Ident.create "undef"], Lprim(Praise, [Lvar exn_id])) + +let init_value modl = + let undef_exn_id = Ident.create "undef_exception" in + let undef_function_id = Ident.create "undef_function" in + let rec init_value_mod env mty = + match Mtype.scrape env mty with + Tmty_ident _ -> + raise Not_found + | Tmty_signature sg -> + Lprim(Pmakeblock(0, Mutable), init_value_struct env sg) + | Tmty_functor(id, arg, res) -> + raise Not_found (* to be fixed? *) + and init_value_struct env sg = + match sg with + [] -> [] + | Tsig_value(id, vdesc) :: rem -> + let init_v = + match Ctype.expand_head env vdesc.val_type with + {desc = Tarrow(_,_,_,_)} -> + Lvar undef_function_id + | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t -> + Lprim(Pmakeblock(Config.lazy_tag, Immutable), + [Lvar undef_function_id]) + | _ -> raise Not_found in + init_v :: init_value_struct env rem + | Tsig_type(id, tdecl) :: rem -> + init_value_struct (Env.add_type id tdecl env) rem + | Tsig_exception(id, edecl) :: rem -> + Lvar undef_exn_id :: init_value_struct env rem + | Tsig_module(id, mty) :: rem -> + init_value_mod env mty :: + init_value_struct (Env.add_module id mty env) rem + | Tsig_modtype(id, minfo) :: rem -> + init_value_struct (Env.add_modtype id minfo env) rem + | Tsig_class(id, cdecl) :: rem -> + Translclass.dummy_class (Lvar undef_function_id) :: + init_value_struct env rem + | Tsig_cltype(id, ctyp) :: rem -> + init_value_struct env rem + in + try + Some(Llet(Alias, undef_exn_id, undefined_exception modl.mod_loc, + Llet(Alias, undef_function_id, undefined_function undef_exn_id, + init_value_mod modl.mod_env modl.mod_type))) + with Not_found -> + None + +(* Reorder bindings to honor dependencies. *) + +type binding_status = Undefined | Inprogress | Defined + +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.create num_bindings Undefined in + let res = ref [] in + let rec emit_binding i = + match status.(i) with + Defined -> () + | Inprogress -> raise(Error(loc.(i), Circular_dependency id.(i))) + | Undefined -> + if init.(i) = None then begin + status.(i) <- Inprogress; + for j = 0 to num_bindings - 1 do + if IdentSet.mem id.(j) fv.(i) then emit_binding j + done + end; + res := (id.(i), init.(i), rhs.(i)) :: !res; + status.(i) <- Defined in + for i = 0 to num_bindings - 1 do + match status.(i) with + Undefined -> emit_binding i + | Inprogress -> assert false + | Defined -> () + done; + List.rev !res + +(* Generate lambda-code for a reordered list of bindings *) + +let prim_update = + { prim_name = "update_dummy"; + prim_arity = 2; + prim_alloc = true; + prim_native_name = ""; + prim_native_float = false } + +let eval_rec_bindings bindings cont = + let rec bind_inits = function + [] -> + bind_strict bindings + | (id, None, rhs) :: rem -> + bind_inits rem + | (id, Some init, rhs) :: rem -> + Llet(Strict, id, init, bind_inits rem) + and bind_strict = function + [] -> + patch_forwards bindings + | (id, None, rhs) :: rem -> + Llet(Strict, id, rhs, bind_strict rem) + | (id, Some init, rhs) :: rem -> + bind_strict rem + and patch_forwards = function + [] -> + cont + | (id, None, rhs) :: rem -> + patch_forwards rem + | (id, Some init, rhs) :: rem -> + Lsequence(Lprim(Pccall prim_update, [Lvar id; rhs]), patch_forwards rem) + in + bind_inits bindings + +let compile_recmodule compile_rhs bindings cont = + eval_rec_bindings + (reorder_rec_bindings + (List.map + (fun (id, modl) -> + (id, modl.mod_loc, init_value modl, compile_rhs id modl)) + bindings)) + cont + (* Compile a module expression *) let rec transl_module cc rootpath mexp = @@ -158,6 +307,12 @@ and transl_structure fields cc rootpath = function Llet(Strict, id, transl_module Tcoerce_none (field_path rootpath id) modl, transl_structure (id :: fields) cc rootpath rem) + | Tstr_recmodule bindings :: rem -> + compile_recmodule + (fun id modl -> + transl_module Tcoerce_none (field_path rootpath id) modl) + bindings + (transl_structure (map_end fst bindings fields) cc rootpath rem) | Tstr_modtype(id, decl) :: rem -> transl_structure fields cc rootpath rem | Tstr_open path :: rem -> @@ -245,6 +400,16 @@ let transl_store_structure glob map prims str = (add_ident true adds id -> Pgetglobal... to subst). *) Llet(Strict, id, subst_lambda subst lam, Lsequence(store_ident id, transl_store(add_ident true id subst) rem)) + | Tstr_recmodule bindings :: rem -> + let ids = List.map fst bindings in + compile_recmodule + (fun id modl -> + subst_lambda subst + (transl_module Tcoerce_none + (field_path (global_path glob) id) modl)) + bindings + (Lsequence(store_idents ids, + transl_store (add_idents true ids subst) rem)) | Tstr_modtype(id, decl) :: rem -> transl_store subst rem | Tstr_open path :: rem -> @@ -317,6 +482,7 @@ let rec defined_idents = function | Tstr_exception(id, decl) :: rem -> id :: defined_idents rem | Tstr_exn_rebind(id, path) :: rem -> id :: defined_idents rem | Tstr_module(id, modl) :: rem -> id :: defined_idents rem + | Tstr_recmodule decls :: rem -> List.map fst decls @ defined_idents rem | Tstr_modtype(id, decl) :: rem -> defined_idents rem | Tstr_open path :: rem -> defined_idents rem | Tstr_class cl_list :: rem -> @@ -423,6 +589,12 @@ let transl_toplevel_item = function set_toplevel_unique_name id; toploop_setvalue id (transl_module Tcoerce_none (Some(Pident id)) modl) + | Tstr_recmodule bindings -> + let idents = List.map fst bindings in + compile_recmodule + (fun id modl -> transl_module Tcoerce_none (Some(Pident id)) modl) + bindings + (make_sequence toploop_setvalue_id idents) | Tstr_modtype(id, decl) -> lambda_unit | Tstr_open path -> @@ -498,3 +670,13 @@ let transl_store_package component_names target_name coercion = apply_coercion cc (Lprim(Pgetglobal id.(src), []))])) 0 pos_cc_list) | _ -> assert false + +(* Error report *) + +open Format + +let report_error ppf = function + Circular_dependency id -> + fprintf ppf + "@[Cannot safely evaluate the definition@ of the recursively-defined module %a@]" + Printtyp.ident id |