GPR#173: Attributes to control inlining

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@16530 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

Changes

@@ -37,6 +37,9 @@ Language features:
   attribute is applied on predefined exception constructors which
   take an purely informational (with no stability guarantee) message.
   (Alain Frisch)
+- GPR#173: [@inline] and [@inlined] attributes (for function declarations
+  and call sites respectively) to control inlining
+  (Pierre Chambart, Mark Shinwell)
 
 Compilers:
 - PR#4800: better compilation of tuple assignment (Gabriel Scherer and

Makefile

@@ -68,7 +68,8 @@ TYPING=typing/ident.cmo typing/path.cmo \
 
 COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
   bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \
-  bytecomp/translobj.cmo bytecomp/translcore.cmo \
+  bytecomp/translobj.cmo bytecomp/translattribute.cmo \
+  bytecomp/translcore.cmo \
   bytecomp/translclass.cmo bytecomp/translmod.cmo \
   bytecomp/simplif.cmo bytecomp/runtimedef.cmo \
   driver/pparse.cmo driver/main_args.cmo \

asmcomp/closure.ml

@@ -101,7 +101,7 @@ let occurs_var var u =
    'Some' constructor, only to deconstruct it immediately in the
    function's body. *)
 
-let split_default_wrapper fun_id kind params body =
+let split_default_wrapper fun_id kind params body attr =
   let rec aux map = function
     | Llet(Strict, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when
         Ident.name optparam = "*opt*" && List.mem optparam params
@@ -129,14 +129,16 @@ let split_default_wrapper fun_id kind params body =
             Ident.empty inner_params new_ids
         in
         let body = Lambda.subst_lambda subst body in
-        let inner_fun = Lfunction{kind = Curried; params = new_ids; body} in
+        let inner_fun = Lfunction{kind = Curried; params = new_ids; body;
+                                  attr} in
         (wrapper_body, (inner_id, inner_fun))
   in
   try
     let wrapper_body, inner = aux [] body in
-    [(fun_id, Lfunction{kind; params; body = wrapper_body}); inner]
+    [(fun_id, Lfunction{kind; params; body = wrapper_body;
+                        attr = default_function_attribute}); inner]
   with Exit ->
-    [(fun_id, Lfunction{kind; params; body})]
+    [(fun_id, Lfunction{kind; params; body; attr})]
 
 
 (* Determine whether the estimated size of a clambda term is below
@@ -708,17 +710,23 @@ let rec is_pure = function
   | Levent(lam, ev) -> is_pure lam
   | _ -> false
 
+let warning_if_forced_inline ~loc ~attribute warning =
+  if attribute = Always_inline then
+    Location.prerr_warning loc (Warnings.Inlining_impossible warning)
+
 (* Generate a direct application *)
 
-let direct_apply fundesc funct ufunct uargs =
+let direct_apply fundesc funct ufunct uargs ~loc ~attribute =
   let app_args =
     if fundesc.fun_closed then uargs else uargs @ [ufunct] in
   let app =
-    match fundesc.fun_inline with
-    | None ->
+    match fundesc.fun_inline, attribute with
+    | _, Never_inline | None, _ ->
+        warning_if_forced_inline ~loc ~attribute "Function information unavailable";
         Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none)
-    | Some(params, body) ->
-        bind_params fundesc.fun_float_const_prop params app_args body in
+    | Some(params, body), _  ->
+        bind_params fundesc.fun_float_const_prop params app_args body
+  in
   (* If ufunct can contain side-effects or function definitions,
      we must make sure that it is evaluated exactly once.
      If the function is not closed, we evaluate ufunct as part of the
@@ -851,17 +859,17 @@ let rec close fenv cenv = function
 
     (* We convert [f a] to [let a' = a in fun b c -> f a' b c]
        when fun_arity > nargs *)
-  | Lapply(funct, args, {apply_loc=loc}) ->
+  | Lapply(funct, args, {apply_loc=loc; apply_inlined=attribute}) ->
       let nargs = List.length args in
       begin match (close fenv cenv funct, close_list fenv cenv args) with
         ((ufunct, Value_closure(fundesc, approx_res)),
          [Uprim(Pmakeblock(_, _), uargs, _)])
         when List.length uargs = - fundesc.fun_arity ->
-          let app = direct_apply fundesc funct ufunct uargs in
+          let app = direct_apply ~loc ~attribute fundesc funct ufunct uargs in
           (app, strengthen_approx app approx_res)
       | ((ufunct, Value_closure(fundesc, approx_res)), uargs)
         when nargs = fundesc.fun_arity ->
-          let app = direct_apply fundesc funct ufunct uargs in
+          let app = direct_apply ~loc ~attribute fundesc funct ufunct uargs in
           (app, strengthen_approx app approx_res)
 
       | ((ufunct, Value_closure(fundesc, approx_res)), uargs)
@@ -886,18 +894,22 @@ let rec close fenv cenv = function
           (Lfunction{
                kind = Curried;
                params = final_args;
-               body = Lapply(funct, internal_args, mk_apply_info loc)})
+               body = Lapply(funct, internal_args, mk_apply_info loc);
+               attr = default_function_attribute})
         in
         let new_fun = iter first_args new_fun in
+        warning_if_forced_inline ~loc ~attribute "Partial application";
         (new_fun, approx)
 
       | ((ufunct, Value_closure(fundesc, approx_res)), uargs)
         when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity ->
           let (first_args, rem_args) = split_list fundesc.fun_arity uargs in
-          (Ugeneric_apply(direct_apply fundesc funct ufunct first_args,
-                          rem_args, Debuginfo.none),
+          warning_if_forced_inline ~loc ~attribute "Over-application";
+          (Ugeneric_apply(direct_apply ~loc ~attribute fundesc funct ufunct
+                          first_args, rem_args, Debuginfo.none),
            Value_unknown)
       | ((ufunct, _), uargs) ->
+          warning_if_forced_inline ~loc ~attribute "Unknown function";
           (Ugeneric_apply(ufunct, uargs, Debuginfo.none), Value_unknown)
       end
   | Lsend(kind, met, obj, args, _) ->
@@ -1086,12 +1098,16 @@ and close_functions fenv cenv fun_defs =
     List.flatten
       (List.map
          (function
-           | (id, Lfunction{kind; params; body}) ->
-               split_default_wrapper id kind params body
+           | (id, Lfunction{kind; params; body; attr}) ->
+               split_default_wrapper id kind params body attr
            | _ -> assert false
          )
          fun_defs)
   in
+  let inline_attribute = match fun_defs with
+    | [_, Lfunction{kind; params; body; attr = { inline }}] -> inline
+    | _ -> Default_inline (* recursive functions can't be inlined *)
+  in
 
   (* Update and check nesting depth *)
   incr function_nesting_depth;
@@ -1170,8 +1186,13 @@ and close_functions fenv cenv fun_defs =
         0
         fun_params
     in
-    if lambda_smaller ubody
-        (!Clflags.inline_threshold + n)
+    let threshold =
+      match inline_attribute with
+      | Default_inline -> !Clflags.inline_threshold + n
+      | Always_inline -> max_int
+      | Never_inline -> min_int
+    in
+    if lambda_smaller ubody threshold
     then fundesc.fun_inline <- Some(fun_params, ubody);
 
     (f, (id, env_pos, Value_closure(fundesc, approx))) in

bytecomp/lambda.ml

@@ -161,17 +161,26 @@ type structured_constant =
   | Const_float_array of string list
   | Const_immstring of string
 
+type inline_attribute =
+  | Always_inline (* [@inline] or [@inline always] *)
+  | Never_inline (* [@inline never] *)
+  | Default_inline (* no [@inline] attribute *)
+
 type apply_info = {
   apply_loc : Location.t;
   apply_should_be_tailcall : bool; (* true if [@tailcall] was specified *)
+  apply_inlined : inline_attribute; (* specified with [@inlined] attribute *)
 }
 
-let mk_apply_info ?(tailcall=false) loc =
+let mk_apply_info ?(tailcall=false) ?(inlined_attribute=Default_inline) loc =
   {apply_loc=loc;
-   apply_should_be_tailcall=tailcall; }
+   apply_should_be_tailcall=tailcall;
+   apply_inlined=inlined_attribute;}
 
 let no_apply_info =
-  {apply_loc=Location.none; apply_should_be_tailcall=false;}
+  {apply_loc=Location.none;
+   apply_should_be_tailcall=false;
+   apply_inlined=Default_inline;}
 
 type function_kind = Curried | Tupled
 
@@ -181,6 +190,10 @@ type meth_kind = Self | Public | Cached
 
 type shared_code = (int * int) list
 
+type function_attribute = {
+  inline : inline_attribute;
+}
+
 type lambda =
     Lvar of Ident.t
   | Lconst of structured_constant
@@ -206,7 +219,8 @@ type lambda =
 and lfunction =
   { kind: function_kind;
     params: Ident.t list;
-    body: lambda }
+    body: lambda;
+    attr: function_attribute; } (* specified with [@inline] attribute *)
 
 and lambda_switch =
   { sw_numconsts: int;
@@ -230,6 +244,10 @@ let const_unit = Const_pointer 0
 
 let lambda_unit = Lconst const_unit
 
+let default_function_attribute = {
+  inline = Default_inline;
+}
+
 (* Build sharing keys *)
 (*
    Those keys are later compared with Pervasives.compare.
@@ -487,7 +505,8 @@ let subst_lambda s lam =
       begin try Ident.find_same id s with Not_found -> l end
   | Lconst sc as l -> l
   | Lapply(fn, args, loc) -> Lapply(subst fn, List.map subst args, loc)
-  | Lfunction{kind; params; body} -> Lfunction{kind; params; body = subst body}
+  | Lfunction{kind; params; body; attr} ->
+     Lfunction{kind; params; body = subst body; attr}
   | Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body)
   | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body)
   | Lprim(p, args) -> Lprim(p, List.map subst args)

bytecomp/lambda.mli

@@ -161,18 +161,28 @@ type structured_constant =
   | Const_float_array of string list
   | Const_immstring of string
 
+type inline_attribute =
+  | Always_inline (* [@inline] or [@inline always] *)
+  | Never_inline (* [@inline never] *)
+  | Default_inline (* no [@inline] attribute *)
+
 type apply_info = {
   apply_loc : Location.t;
   apply_should_be_tailcall : bool; (* true if [@tailcall] was specified *)
+  apply_inlined : inline_attribute; (* specified with [@inlined] attribute *)
 }
 
 val no_apply_info : apply_info
 (** Default [apply_info]: no location, no tailcall *)
 
-val mk_apply_info : ?tailcall:bool -> Location.t -> apply_info
+val mk_apply_info : ?tailcall:bool -> ?inlined_attribute:inline_attribute ->
+  Location.t -> apply_info
 (** Build apply_info
     @param tailcall if true, the application should be in tail position;
-           default false *)
+    default false
+    @param inlined_attribute specify wether the function should be inlined
+    or not
+*)
 
 type function_kind = Curried | Tupled
 
@@ -191,6 +201,10 @@ type meth_kind = Self | Public | Cached
 
 type shared_code = (int * int) list     (* stack size -> code label *)
 
+type function_attribute = {
+  inline : inline_attribute;
+}
+
 type lambda =
     Lvar of Ident.t
   | Lconst of structured_constant
@@ -218,7 +232,8 @@ type lambda =
 and lfunction =
   { kind: function_kind;
     params: Ident.t list;
-    body: lambda }
+    body: lambda;
+    attr: function_attribute; } (* specified with [@inline] attribute *)
 
 and lambda_switch =
   { sw_numconsts: int;                  (* Number of integer cases *)
@@ -260,6 +275,8 @@ val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda
 val commute_comparison : comparison -> comparison
 val negate_comparison : comparison -> comparison
 
+val default_function_attribute : function_attribute
+
 (***********************)
 (* For static failures *)
 (***********************)

bytecomp/printlambda.ml

@@ -246,20 +246,33 @@ let primitive ppf = function
   | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi
   | Pint_as_pointer -> fprintf ppf "int_as_pointer"
 
+let function_attribute ppf { inline } =
+  match inline with
+  | Default_inline -> ()
+  | Always_inline -> fprintf ppf "always_inline@ "
+  | Never_inline -> fprintf ppf "never_inline@ "
+
+let apply_tailcall_attribute ppf tailcall =
+  if tailcall then
+    fprintf ppf " @@tailcall"
+
+let apply_inlined_attribute ppf = function
+  | Default_inline -> ()
+  | Always_inline -> fprintf ppf " always_inline"
+  | Never_inline -> fprintf ppf " never_inline"
+
 let rec lam ppf = function
   | Lvar id ->
       Ident.print ppf id
   | Lconst cst ->
       struct_const ppf cst
-  | Lapply(lfun, largs, info) when info.apply_should_be_tailcall ->
-      let lams ppf largs =
-        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
-      fprintf ppf "@[<2>(apply@ %a%a @@tailcall)@]" lam lfun lams largs
-  | Lapply(lfun, largs, _) ->
+  | Lapply(lfun, largs, info) ->
       let lams ppf largs =
         List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
-      fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs
-  | Lfunction{kind; params; body} ->
+      fprintf ppf "@[<2>(apply@ %a%a%a%a)@]" lam lfun lams largs
+        apply_tailcall_attribute info.apply_should_be_tailcall
+        apply_inlined_attribute info.apply_inlined
+  | Lfunction{kind; params; body; attr} ->
       let pr_params ppf params =
         match kind with
         | Curried ->
@@ -273,7 +286,8 @@ let rec lam ppf = function
                 Ident.print ppf param)
               params;
             fprintf ppf ")" in
-      fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body
+      fprintf ppf "@[<2>(function%a@ %a%a)@]" pr_params params
+        function_attribute attr lam body
   | Llet(str, id, arg, body) ->
       let kind = function
         Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" in

bytecomp/simplif.ml

@@ -194,8 +194,8 @@ let simplify_exits lam =
   let rec simplif = function
   | (Lvar _|Lconst _) as l -> l
   | Lapply(l1, ll, info) -> Lapply(simplif l1, List.map simplif ll, info)
-  | Lfunction{kind; params; body = l} ->
-     Lfunction{kind; params; body = simplif l}
+  | Lfunction{kind; params; body = l; attr} ->
+      Lfunction{kind; params; body = simplif l; attr}
   | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2)
   | Lletrec(bindings, body) ->
       Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
@@ -440,13 +440,13 @@ let simplify_lets lam =
     when optimize && List.length params = List.length args ->
       simplif (beta_reduce params body args)
   | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc)
-  | Lfunction{kind; params; body = l} ->
+  | Lfunction{kind; params; body = l; attr} ->
       begin match simplif l with
-        Lfunction{kind=Curried; params=params'; body}
+        Lfunction{kind=Curried; params=params'; body; attr}
         when kind = Curried && optimize ->
-          Lfunction{kind; params = params @ params'; body}
+          Lfunction{kind; params = params @ params'; body; attr}
       | body ->
-          Lfunction{kind; params; body}
+          Lfunction{kind; params; body; attr}
       end
   | Llet(str, v, Lvar w, l2) when optimize ->
       Hashtbl.add subst v (simplif (Lvar w));