Optimise "include struct ... end" in more cases (ocaml/ocaml#11134)

stedolan · stedolan · commit a78975eb57e1 · 2022-03-22T09:39:39.000Z
diff --git a/lambda/translmod.ml b/lambda/translmod.ml
@@ -943,7 +943,8 @@ let rec more_idents = function
     | Tstr_class_type _ -> more_idents rem
     | Tstr_include{incl_mod={mod_desc =
                              Tmod_constraint ({mod_desc = Tmod_structure str},
-                                              _, _, _)}} ->
+                                              _, _, _)
+                            | Tmod_structure str }} ->
         all_idents str.str_items @ more_idents rem
     | Tstr_include _ -> more_idents rem
     | Tstr_module
@@ -1227,15 +1228,16 @@ let transl_store_structure ~scopes glob map prims aliases str =
                       transl_store ~scopes rootpath (add_idents false ids subst)
                         cont rem)
 
-        | Tstr_include{
+        | Tstr_include({
             incl_loc=loc;
             incl_mod= {
               mod_desc = Tmod_constraint (
                   ({mod_desc = Tmod_structure str} as mexp), _, _,
-                  (Tcoerce_structure (map, _)))};
+                  (Tcoerce_structure _ | Tcoerce_none))}
+            | ({ mod_desc = Tmod_structure str} as mexp);
             incl_attributes;
             incl_type;
-          } ->
+          } as incl) ->
             List.iter (Translattribute.check_attribute_on_module mexp)
               incl_attributes;
             (* Shouldn't we use mod_attributes instead of incl_attributes?
@@ -1262,9 +1264,17 @@ let transl_store_structure ~scopes glob map prims aliases str =
                                  loop ids args))
               | _ -> assert false
             in
+            let map =
+              match incl.incl_mod.mod_desc with
+              | Tmod_constraint (_, _, _, Tcoerce_structure (map, _)) ->
+                 map
+              | Tmod_structure _
+              | Tmod_constraint (_, _, _, Tcoerce_none) ->
+                 List.init (List.length ids0) (fun i -> i, Tcoerce_none)
+              | _ -> assert false
+            in
             Lsequence(lam, loop ids0 map)
 
-
         | Tstr_include incl ->
             let ids = bound_value_identifiers incl.incl_type in
             let modl = incl.incl_mod in
diff --git a/testsuite/tests/typing-modules/struct_include_optimisation.ml b/testsuite/tests/typing-modules/struct_include_optimisation.ml
@@ -0,0 +1,49 @@
+(* TEST
+   * native *)
+type alloc_count = { mutable total: float }
+let allocs = Sys.opaque_identity { total = 0. }
+let[@inline never] set_allocs () =
+  allocs.total <- Gc.minor_words ()
+
+let[@inline never] count txt =
+  let now = int_of_float (Gc.minor_words () -. allocs.total) in
+  Printf.printf "%20s: %d\n" txt now;
+  set_allocs ()
+
+let v = Sys.opaque_identity (ref 0)
+
+let next () =
+  let r = !v in incr v; r
+
+let () = set_allocs ()
+
+include struct
+  let x = next ()
+  let y = next ()
+end
+
+let () = count "no signature"
+
+include (struct
+  let a = next ()
+  let b = next ()
+end : sig val a : int val b : int end)
+
+let () = count "trivial coercion"
+
+include (struct
+  let c = next ()
+  let d = next ()
+end : sig val c : int end)
+
+let () = count "prefix coercion"
+
+include (struct
+  let c = next ()
+  let d = next ()
+end : sig val d : int end)
+
+let () = count "reordering coercion"
+
+let () =
+  Printf.printf "%20s: %d%d%d%d%d%d\n" "outputs" x y a b c d
diff --git a/testsuite/tests/typing-modules/struct_include_optimisation.reference b/testsuite/tests/typing-modules/struct_include_optimisation.reference
@@ -0,0 +1,5 @@
+        no signature: 0
+    trivial coercion: 0
+     prefix coercion: 0
+ reordering coercion: 0
+             outputs: 012347
