Functors

7 files changed, 171 insertions, 46 deletions

diff --git a/Changes b/Changes
index 4499f89b0f..d0e1180fc8 100644
--- a/Changes
+++ b/Changes
@@ -37,6 +37,12 @@ Working version
   (Markus Mottl, review by Alain Frisch, Xavier Leroy, Gabriel Scherer,
   Mark Shinwell and Leo White)
 
+- GPR#1183: compile curried functors to multi-argument functions
+  earlier in the compiler pipeline; correctly propagate [@@inline]
+  attributes on such functors; mark functor coercion veneers as
+  stubs.
+  (Mark Shinwell, Leo White)
+
 ### Standard library:
 
 - GRP#1119: Change Set (private) type to inline records.
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 3d126257ca..902557d743 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -702,5 +702,13 @@ let lam_of_loc kind loc =
     Lconst (Const_immstring loc)
   | Loc_LINE -> Lconst (Const_base (Const_int lnum))
 
+let merge_inline_attributes attr1 attr2 =
+  match attr1, attr2 with
+  | Default_inline, _ -> Some attr2
+  | _, Default_inline -> Some attr1
+  | _, _ ->
+    if attr1 = attr2 then Some attr1
+    else None
+
 let reset () =
   raise_count := 0
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index 192ce76cbe..e068a936e5 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -361,4 +361,9 @@ val patch_guarded : lambda -> lambda -> lambda
 val raise_kind: raise_kind -> string
 val lam_of_loc : loc_kind -> Location.t -> lambda
 
+val merge_inline_attributes
+   : inline_attribute
+  -> inline_attribute
+  -> inline_attribute option
+
 val reset: unit -> unit
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index c7ce0a9ff1..754cd9d099 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -29,7 +29,7 @@ open Translclass
 
 type error =
   Circular_dependency of Ident.t
-
+| Conflicting_inline_attributes
 
 exception Error of Location.t * error
 
@@ -75,20 +75,8 @@ let rec apply_coercion loc strict restr arg =
         wrap_id_pos_list loc id_pos_list get_field lam)
   | Tcoerce_functor(cc_arg, cc_res) ->
       let param = Ident.create "funarg" in
-      name_lambda strict arg (fun id ->
-        Lfunction{kind = Curried; params = [param];
-                  attr = { default_function_attribute with
-                           is_a_functor = true };
-                  loc = loc;
-                  body = apply_coercion
-                           loc Strict cc_res
-                           (Lapply{ap_should_be_tailcall=false;
-                                   ap_loc=loc;
-                                   ap_func=Lvar id;
-                                   ap_args=[apply_coercion loc Alias cc_arg
-                                                           (Lvar param)];
-                                   ap_inlined=Default_inline;
-                                   ap_specialised=Default_specialise})})
+      let carg = apply_coercion loc Alias cc_arg (Lvar param) in
+      apply_coercion_result loc strict arg [param] [carg] cc_res
   | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
       transl_primitive pc_loc pc_desc pc_env pc_type None
   | Tcoerce_alias (path, cc) ->
@@ -98,6 +86,29 @@ let rec apply_coercion loc strict restr arg =
 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 "funarg" in
+    let arg = apply_coercion loc Alias cc_arg (Lvar param) in
+    apply_coercion_result loc strict funct
+      (param :: params) (arg :: args) cc_res
+  | _ ->
+    name_lambda strict funct (fun id ->
+      Lfunction{kind = Curried; params = List.rev params;
+                attr = { default_function_attribute with
+                         is_a_functor = true;
+                         stub = true; };
+                loc = loc;
+                body = apply_coercion
+                         loc Strict cc_res
+                         (Lapply{ap_should_be_tailcall=false;
+                                 ap_loc=loc;
+                                 ap_func=Lvar id;
+                                 ap_args=List.rev args;
+                                 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;
@@ -342,9 +353,82 @@ let transl_class_bindings cl_list =
        (id, transl_class 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 (loc, Conflicting_inline_attributes))
+
+let merge_functors mexp coercion root_path =
+  let rec merge mexp coercion path acc inline_attribute =
+    let finished () = acc, mexp, path, coercion, inline_attribute in
+    match mexp.mod_type with
+    | Mty_alias _ -> finished ()
+    | _ ->
+      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 -> None, Tcoerce_none
+          | Tcoerce_functor (arg_coercion, res_coercion) ->
+            Some arg_coercion, res_coercion
+          | _ -> fatal_error "Translmod.merge_functors: bad coercion"
+        in
+        let loc = mexp.mod_loc in
+        let path = functor_path path param in
+        let inline_attribute =
+          merge_inline_attributes inline_attribute inline_attribute' loc
+        in
+        merge body res_coercion path ((param, loc, arg_coercion) :: acc)
+          inline_attribute
+      | _ -> finished ()
+  in
+  merge mexp coercion root_path [] Default_inline
+
+let rec compile_functor mexp coercion root_path loc =
+  let functor_params_rev, body, body_path, res_coercion, inline_attribute =
+    merge_functors 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 =
+          match arg_coercion with
+          | None -> Lvar param'
+          | Some arg_coercion ->
+            apply_coercion loc Alias arg_coercion (Lvar param')
+        in
+        let params = param' :: params in
+        let body = Llet (Alias, Pgenval, param, arg, body) in
+        params, body)
+      ([], transl_module res_coercion body_path body)
+      functor_params_rev
+  in
+  Lfunction {
+    kind = Curried;
+    params;
+    attr = {
+      inline = inline_attribute;
+      specialise = Default_specialise;
+      is_a_functor = true;
+      stub = false;
+    };
+    loc;
+    body;
+  }
+
 (* Compile a module expression *)
 
-let rec transl_module cc rootpath mexp =
+and transl_module cc rootpath mexp =
   List.iter (Translattribute.check_attribute_on_module mexp)
     mexp.mod_attributes;
   let loc = mexp.mod_loc in
@@ -357,36 +441,9 @@ let rec transl_module cc rootpath mexp =
             (transl_path ~loc mexp.mod_env path)
       | Tmod_structure str ->
           fst (transl_struct loc [] cc rootpath str)
-      | Tmod_functor(param, _, _, body) ->
-          let bodypath = functor_path rootpath param in
-          let inline_attribute =
-            Translattribute.get_inline_attribute mexp.mod_attributes
-          in
-          oo_wrap mexp.mod_env true
-            (function
-              | Tcoerce_none ->
-                  Lfunction{kind = Curried; params = [param];
-                            attr = { inline = inline_attribute;
-                                     specialise = Default_specialise;
-                                     is_a_functor = true;
-                                     stub = false; };
-                            loc = loc;
-                            body = transl_module Tcoerce_none bodypath body}
-              | Tcoerce_functor(ccarg, ccres) ->
-                  let param' = Ident.create "funarg" in
-                  Lfunction{kind = Curried; params = [param'];
-                            attr = { inline = inline_attribute;
-                                     specialise = Default_specialise;
-                                     is_a_functor = true;
-                                     stub = false; };
-                            loc = loc;
-                            body = Llet(Alias, Pgenval, param,
-                                        apply_coercion loc Alias ccarg
-                                                       (Lvar param'),
-                                        transl_module ccres bodypath body)}
-              | _ ->
-                  fatal_error "Translmod.transl_module")
-            cc
+      | Tmod_functor _ ->
+          oo_wrap mexp.mod_env true (fun () ->
+            compile_functor mexp cc rootpath loc) ()
       | Tmod_apply(funct, arg, ccarg) ->
           let inlined_attribute, funct =
             Translattribute.get_and_remove_inlined_attribute_on_module funct
@@ -1256,6 +1313,9 @@ let report_error ppf = function
         "@[Cannot safely evaluate the definition@ \
          of the recursively-defined module %a@]"
         Printtyp.ident id
+  | Conflicting_inline_attributes ->
+      fprintf ppf
+        "@[Conflicting ``inline'' attributes@]"
 
 let () =
   Location.register_error_of_exn
diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli
index f613a2f421..1b86328d8a 100644
--- a/bytecomp/translmod.mli
+++ b/bytecomp/translmod.mli
@@ -44,6 +44,7 @@ val primitive_declarations: Primitive.description list ref
 
 type error =
   Circular_dependency of Ident.t
+| Conflicting_inline_attributes
 
 exception Error of Location.t * error
 
diff --git a/testsuite/tests/functors/Makefile b/testsuite/tests/functors/Makefile
new file mode 100644
index 0000000000..c4223d4522
--- /dev/null
+++ b/testsuite/tests/functors/Makefile
@@ -0,0 +1,4 @@
+BASEDIR=../..
+TOPFLAGS+=-dlambda
+include $(BASEDIR)/makefiles/Makefile.dlambda
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/functors/functors.ml b/testsuite/tests/functors/functors.ml
new file mode 100644
index 0000000000..32541699e1
--- /dev/null
+++ b/testsuite/tests/functors/functors.ml
@@ -0,0 +1,41 @@
+module type S = sig
+  val foo : int -> int
+end
+
+module O (X : S) = struct
+  let cow x = X.foo x
+  let sheep x = 1 + cow x
+end [@@inline always]
+
+module F (X : S) (Y : S) = struct
+  let cow x = Y.foo (X.foo x)
+  let sheep x = 1 + cow x
+end [@@inline always]
+
+module type S1 = sig
+  val bar : int -> int
+  val foo : int -> int
+end
+
+module type T = sig
+  val sheep : int -> int
+end
+
+module F1 (X : S) (Y : S) : T = struct
+  let cow x = Y.foo (X.foo x)
+  let sheep x = 1 + cow x
+end [@@inline always]
+
+module F2 : S1 -> S1 -> T = functor (X : S) -> functor (Y : S) -> struct
+  let cow x = Y.foo (X.foo x)
+  let sheep x = 1 + cow x
+end [@@inline always]
+
+module M : sig
+  module F (X : S1) (Y : S1) : T
+end = struct
+  module F (X : S) (Y : S) = struct
+    let cow x = Y.foo (X.foo x)
+    let sheep x = 1 + cow x
+  end [@@inline always]
+end