inline-more: flatten structures in transl_store_structureinline-more

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/inline-more@10966 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

2 files changed, 112 insertions, 55 deletions

diff --git a/ChangeLog.txt b/ChangeLog.txt
index 27ae8ba7b5..865309628c 100644
--- a/ChangeLog.txt
+++ b/ChangeLog.txt
@@ -1,3 +1,6 @@
+2010/03/01:
+ * Implemented flattening of nested structures in Translmod.transl_store_structure
+
 2010/11/29:
  * Implemented early emission of structured constants, so functions
  with such constants can still be inlined
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);