diff options
Diffstat (limited to 'inline-more/bytecomp/translmod.ml')
| -rw-r--r-- | inline-more/bytecomp/translmod.ml | 164 |
1 files changed, 109 insertions, 55 deletions
diff --git a/inline-more/bytecomp/translmod.ml b/inline-more/bytecomp/translmod.ml index bd6107f035..8829eee5dc 100644 --- a/inline-more/bytecomp/translmod.ml +++ b/inline-more/bytecomp/translmod.ml @@ -353,6 +353,67 @@ let transl_implementation module_name (str, cc) = [transl_label_init (transl_structure [] cc (global_path module_id) str)]) + +(* Build the list of value identifiers defined by a toplevel structure + (excluding primitive declarations). *) + +let rec defined_idents = function + [] -> [] + | Tstr_eval expr :: rem -> defined_idents rem + | Tstr_value(rec_flag, pat_expr_list) :: rem -> + let_bound_idents pat_expr_list @ defined_idents rem + | Tstr_primitive(id, descr) :: rem -> defined_idents rem + | Tstr_type decls :: rem -> defined_idents rem + | 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 -> + List.map (fun (i, _, _, _, _) -> i) cl_list @ defined_idents rem + | Tstr_cltype cl_list :: rem -> defined_idents rem + | Tstr_include(modl, ids) :: rem -> ids @ defined_idents rem + +(* second level idents (module M = struct ... let id = ... end), and all sub-levels idents *) +let rec more_idents = function + [] -> [] + | Tstr_eval expr :: rem -> more_idents rem + | Tstr_value(rec_flag, pat_expr_list) :: rem -> more_idents rem + | Tstr_primitive(id, descr) :: rem -> more_idents rem + | Tstr_type decls :: rem -> more_idents rem + | Tstr_exception(id, decl) :: rem -> more_idents rem + | Tstr_exn_rebind(id, path) :: rem -> more_idents rem + | Tstr_recmodule decls :: rem -> more_idents rem + | Tstr_modtype(id, decl) :: rem -> more_idents rem + | Tstr_open path :: rem -> more_idents rem + | Tstr_class cl_list :: rem -> more_idents rem + | Tstr_cltype cl_list :: rem -> more_idents rem + | Tstr_include(modl, ids) :: rem -> more_idents rem + | Tstr_module(id, { mod_desc = Tmod_structure str }) :: rem -> all_idents str @ more_idents rem + | Tstr_module(id, _) :: rem -> more_idents rem + +and all_idents = function + [] -> [] + | Tstr_eval expr :: rem -> all_idents rem + | Tstr_value(rec_flag, pat_expr_list) :: rem -> + let_bound_idents pat_expr_list @ all_idents rem + | Tstr_primitive(id, descr) :: rem -> all_idents rem + | Tstr_type decls :: rem -> all_idents rem + | Tstr_exception(id, decl) :: rem -> id :: all_idents rem + | Tstr_exn_rebind(id, path) :: rem -> id :: all_idents rem + | Tstr_recmodule decls :: rem -> List.map fst decls @ all_idents rem + | Tstr_modtype(id, decl) :: rem -> all_idents rem + | Tstr_open path :: rem -> all_idents rem + | Tstr_class cl_list :: rem -> + List.map (fun (i, _, _, _, _) -> i) cl_list @ all_idents rem + | Tstr_cltype cl_list :: rem -> all_idents rem + | Tstr_include(modl, ids) :: rem -> ids @ all_idents rem + + | Tstr_module(id, { mod_desc = Tmod_structure str }) :: rem -> id :: all_idents str @ all_idents rem + | Tstr_module(id, _) :: rem -> id :: all_idents rem + + (* A variant of transl_structure used to compile toplevel structure definitions for the native-code compiler. Store the defined values in the fields of the global as soon as they are defined, in order to reduce register @@ -374,34 +435,44 @@ let nat_toplevel_name id = fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id) let transl_store_structure glob map prims str = - let rec transl_store subst = function + let rec transl_store rootpath subst = function [] -> transl_store_subst := subst; lambda_unit | Tstr_eval expr :: rem -> Lsequence(subst_lambda subst (transl_exp expr), - transl_store subst rem) + transl_store rootpath subst rem) | Tstr_value(rec_flag, pat_expr_list) :: rem -> let ids = let_bound_idents pat_expr_list in let lam = transl_let rec_flag pat_expr_list (store_idents ids) in Lsequence(subst_lambda subst lam, - transl_store (add_idents false ids subst) rem) + transl_store rootpath (add_idents false ids subst) rem) | Tstr_primitive(id, descr) :: rem -> record_primitive descr; - transl_store subst rem + transl_store rootpath subst rem | Tstr_type(decls) :: rem -> - transl_store subst rem + transl_store rootpath subst rem | Tstr_exception(id, decl) :: rem -> - let lam = transl_exception id (field_path (global_path glob) id) decl in + let lam = transl_exception id (field_path rootpath id) decl in Lsequence(Llet(Strict, id, lam, store_ident id), - transl_store (add_ident false id subst) rem) + transl_store rootpath (add_ident false id subst) rem) | Tstr_exn_rebind(id, path) :: rem -> let lam = subst_lambda subst (transl_path path) in Lsequence(Llet(Strict, id, lam, store_ident id), - transl_store (add_ident false id subst) rem) + transl_store rootpath (add_ident false id subst) rem) + | Tstr_module(id, { mod_desc = Tmod_structure str }) :: rem -> + let lam = transl_store (field_path rootpath id) subst str in + (* Careful: see next case *) + let subst = !transl_store_subst in +(* let lam = subst_lambda subst lam in *) + Lsequence(lam, + Llet(Strict, id, + subst_lambda subst + (Lprim(Pmakeblock(0, Immutable), List.map (fun id -> Lvar id) (defined_idents str))), + Lsequence(store_ident id, transl_store rootpath (add_ident true id subst) rem))) | Tstr_module(id, modl) :: rem -> let lam = - transl_module Tcoerce_none (field_path (global_path glob) id) modl in + transl_module Tcoerce_none (field_path rootpath id) modl in (* Careful: the module value stored in the global may be different from the local module value, in case a coercion is applied. If so, keep using the local module value (id) in the remainder of @@ -409,21 +480,21 @@ let transl_store_structure glob map prims str = If not, we can use the value from the global (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)) + Lsequence(store_ident id, transl_store rootpath (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)) + (field_path rootpath id) modl)) bindings (Lsequence(store_idents ids, - transl_store (add_idents true ids subst) rem)) + transl_store rootpath (add_idents true ids subst) rem)) | Tstr_modtype(id, decl) :: rem -> - transl_store subst rem + transl_store rootpath subst rem | Tstr_open path :: rem -> - transl_store subst rem + transl_store rootpath subst rem | Tstr_class cl_list :: rem -> let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in let lam = @@ -433,13 +504,13 @@ let transl_store_structure glob map prims str = cl_list, store_idents ids) in Lsequence(subst_lambda subst lam, - transl_store (add_idents false ids subst) rem) + transl_store rootpath (add_idents false ids subst) rem) | Tstr_cltype cl_list :: rem -> - transl_store subst rem + transl_store rootpath subst rem | Tstr_include(modl, ids) :: rem -> let mid = Ident.create "include" in let rec store_idents pos = function - [] -> transl_store (add_idents true ids subst) rem + [] -> transl_store rootpath (add_idents true ids subst) rem | id :: idl -> Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]), Lsequence(store_ident id, store_idents (pos + 1) idl)) in @@ -477,28 +548,8 @@ let transl_store_structure glob map prims str = [Lprim(Pgetglobal glob, []); transl_primitive prim]), cont) - in List.fold_right store_primitive prims (transl_store !transl_store_subst str) + in List.fold_right store_primitive prims (transl_store (global_path glob) !transl_store_subst str) -(* Build the list of value identifiers defined by a toplevel structure - (excluding primitive declarations). *) - -let rec defined_idents = function - [] -> [] - | Tstr_eval expr :: rem -> defined_idents rem - | Tstr_value(rec_flag, pat_expr_list) :: rem -> - let_bound_idents pat_expr_list @ defined_idents rem - | Tstr_primitive(id, descr) :: rem -> defined_idents rem - | Tstr_type decls :: rem -> defined_idents rem - | 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 -> - List.map (fun (i, _, _, _, _) -> i) cl_list @ defined_idents rem - | Tstr_cltype cl_list :: rem -> defined_idents rem - | Tstr_include(modl, ids) :: rem -> ids @ defined_idents rem (* Transform a coercion and the list of value identifiers defined by a toplevel structure into a table [id -> (pos, coercion)], @@ -512,29 +563,32 @@ let rec defined_idents = function Also compute the total size of the global block, and the list of all primitives exported as values. *) -let build_ident_map restr idlist = +let build_ident_map restr idlist more_ids = let rec natural_map pos map prims = function [] -> (map, prims, pos) | id :: rem -> natural_map (pos+1) (Ident.add id (pos, Tcoerce_none) map) prims rem in - match restr with - Tcoerce_none -> - natural_map 0 Ident.empty [] idlist - | Tcoerce_structure pos_cc_list -> - let idarray = Array.of_list idlist in - let rec export_map pos map prims undef = function + let (map, prims, pos) = + match restr with + Tcoerce_none -> + natural_map 0 Ident.empty [] idlist + | Tcoerce_structure pos_cc_list -> + let idarray = Array.of_list idlist in + let rec export_map pos map prims undef = function [] -> natural_map pos map prims undef - | (source_pos, Tcoerce_primitive p) :: rem -> - export_map (pos + 1) map ((pos, p) :: prims) undef rem - | (source_pos, cc) :: rem -> - let id = idarray.(source_pos) in - export_map (pos + 1) (Ident.add id (pos, cc) map) - prims (list_remove id undef) rem - in export_map 0 Ident.empty [] idlist pos_cc_list - | _ -> - fatal_error "Translmod.build_ident_map" + | (source_pos, Tcoerce_primitive p) :: rem -> + export_map (pos + 1) map ((pos, p) :: prims) undef rem + | (source_pos, cc) :: rem -> + let id = idarray.(source_pos) in + export_map (pos + 1) (Ident.add id (pos, cc) map) + prims (list_remove id undef) rem + in export_map 0 Ident.empty [] idlist pos_cc_list + | _ -> + fatal_error "Translmod.build_ident_map" + in + natural_map pos map prims more_ids (* Compile an implementation using transl_store_structure (for the native-code compiler). *) @@ -543,7 +597,7 @@ let transl_store_gen module_name (str, restr) topl = reset_labels (); primitive_declarations := []; let module_id = Ident.create_persistent module_name in - let (map, prims, size) = build_ident_map restr (defined_idents str) in + let (map, prims, size) = build_ident_map restr (defined_idents str) (more_idents str) in let f = function | [ Tstr_eval expr ] when topl -> assert (size = 0); |