flambda-backend: Add [@inline ready] attribute and remove [@inline hint] (not [@inlined hint]) (#351)

Author: mshinwell

bytecomp/bytegen.ml

@@ -685,7 +685,7 @@ let rec comp_expr env exp sz cont =
         ap_func=func;
         ap_args=[arg];
         ap_tailcall=Default_tailcall;
-        ap_inlined=Default_inline;
+        ap_inlined=Default_inlined;
         ap_specialised=Default_specialise;
         ap_probe=None;
       } in

lambda/lambda.ml

@@ -235,22 +235,43 @@ type tailcall_attribute =
 type inline_attribute =
   | Always_inline (* [@inline] or [@inline always] *)
   | Never_inline (* [@inline never] *)
-  | Hint_inline (* [@inlined hint] attribute *)
+  | Available_inline (* [@inline available] *)
   | Unroll of int (* [@unroll x] *)
   | Default_inline (* no [@inline] attribute *)
 
-let equal_inline_attribute x y =
+type inlined_attribute =
+  | Always_inlined (* [@inlined] or [@inlined always] *)
+  | Never_inlined (* [@inlined never] *)
+  | Hint_inlined (* [@inlined hint] *)
+  | Unroll of int (* [@unroll x] *)
+  | Default_inlined (* no [@inlined] attribute *)
+
+let equal_inline_attribute (x : inline_attribute) (y : inline_attribute) =
   match x, y with
   | Always_inline, Always_inline
   | Never_inline, Never_inline
-  | Hint_inline, Hint_inline
+  | Available_inline, Available_inline
   | Default_inline, Default_inline
     ->
     true
   | Unroll u, Unroll v ->
     u = v
   | (Always_inline | Never_inline
-    | Hint_inline | Unroll _ | Default_inline), _ ->
+    | Available_inline | Unroll _ | Default_inline), _ ->
+    false
+
+let equal_inlined_attribute (x : inlined_attribute) (y : inlined_attribute) =
+  match x, y with
+  | Always_inlined, Always_inlined
+  | Never_inlined, Never_inlined
+  | Hint_inlined, Hint_inlined
+  | Default_inlined, Default_inlined
+    ->
+    true
+  | Unroll u, Unroll v ->
+    u = v
+  | (Always_inlined | Never_inlined
+    | Hint_inlined | Unroll _ | Default_inlined), _ ->
     false
 
 type probe_desc = { name: string }
@@ -336,7 +357,7 @@ and lambda_apply =
     ap_args : lambda list;
     ap_loc : scoped_location;
     ap_tailcall : tailcall_attribute;
-    ap_inlined : inline_attribute;
+    ap_inlined : inlined_attribute;
     ap_specialised : specialise_attribute;
     ap_probe : probe;
   }

lambda/lambda.mli

@@ -220,14 +220,24 @@ type tailcall_attribute =
        [@tailcall false] has [false] *)
   | Default_tailcall (* no [@tailcall] attribute *)
 
+(* Function declaration inlining annotations *)
 type inline_attribute =
   | Always_inline (* [@inline] or [@inline always] *)
   | Never_inline (* [@inline never] *)
-  | Hint_inline (* [@inline hint] *)
+  | Available_inline (* [@inline available] *)
   | Unroll of int (* [@unroll x] *)
   | Default_inline (* no [@inline] attribute *)
 
+(* Call site inlining annotations *)
+type inlined_attribute =
+  | Always_inlined (* [@inlined] or [@inlined always] *)
+  | Never_inlined (* [@inlined never] *)
+  | Hint_inlined (* [@inlined hint] *)
+  | Unroll of int (* [@unroll x] *)
+  | Default_inlined (* no [@inlined] attribute *)
+
 val equal_inline_attribute : inline_attribute -> inline_attribute -> bool
+val equal_inlined_attribute : inlined_attribute -> inlined_attribute -> bool
 
 type probe_desc = { name: string }
 type probe = probe_desc option
@@ -317,7 +327,7 @@ and lambda_apply =
     ap_args : lambda list;
     ap_loc : scoped_location;
     ap_tailcall : tailcall_attribute;
-    ap_inlined : inline_attribute; (* specified with the [@inlined] attribute *)
+    ap_inlined : inlined_attribute; (* [@inlined] attribute in code *)
     ap_specialised : specialise_attribute;
     ap_probe : probe;
   }

lambda/matching.ml

@@ -1846,7 +1846,7 @@ let inline_lazy_force_cond arg loc =
                       ap_loc = loc;
                       ap_func = force_fun;
                       ap_args = [ varg ];
-                      ap_inlined = Default_inline;
+                      ap_inlined = Default_inlined;
                       ap_specialised = Default_specialise;
                        ap_probe=None
                     },
@@ -1880,7 +1880,7 @@ let inline_lazy_force_switch arg loc =
                           ap_loc = loc;
                           ap_func = force_fun;
                           ap_args = [ varg ];
-                          ap_inlined = Default_inline;
+                          ap_inlined = Default_inlined;
                           ap_specialised = Default_specialise;
                           ap_probe=None;
                         } )
@@ -1900,7 +1900,7 @@ let inline_lazy_force arg loc =
         ap_loc = loc;
         ap_func = Lazy.force code_force_lazy;
         ap_args = [ arg ];
-        ap_inlined = Default_inline;
+        ap_inlined = Default_inlined;
         ap_specialised = Default_specialise;
         ap_probe=None;
       }

lambda/printlambda.ml

@@ -507,7 +507,7 @@ let function_attribute ppf { inline; specialise; local; is_a_functor; stub } =
   begin match inline with
   | Default_inline -> ()
   | Always_inline -> fprintf ppf "always_inline@ "
-  | Hint_inline -> fprintf ppf "hint_inline@ "
+  | Available_inline -> fprintf ppf "available_inline@ "
   | Never_inline -> fprintf ppf "never_inline@ "
   | Unroll i -> fprintf ppf "unroll(%i)@ " i
   end;
@@ -530,10 +530,10 @@ let apply_tailcall_attribute ppf = function
     fprintf ppf " tailcall(false)"
 
 let apply_inlined_attribute ppf = function
-  | Default_inline -> ()
-  | Always_inline -> fprintf ppf " always_inline"
-  | Never_inline -> fprintf ppf " never_inline"
-  | Hint_inline -> fprintf ppf " hint_inline"
+  | Default_inlined -> ()
+  | Always_inlined -> fprintf ppf " always_inline"
+  | Never_inlined -> fprintf ppf " never_inline"
+  | Hint_inlined -> fprintf ppf " hint_inline"
   | Unroll i -> fprintf ppf " never_inline(%i)" i
 
 let apply_specialised_attribute ppf = function

lambda/simplif.ml

@@ -226,7 +226,7 @@ let simplify_exits lam =
             ap_func=f;
             ap_args=[x];
             ap_tailcall=Default_tailcall;
-            ap_inlined=Default_inline;
+            ap_inlined=Default_inlined;
             ap_specialised=Default_specialise;
             ap_probe=None;
           }
@@ -240,7 +240,7 @@ let simplify_exits lam =
             ap_func=f;
             ap_args=[x];
             ap_tailcall=Default_tailcall;
-            ap_inlined=Default_inline;
+            ap_inlined=Default_inlined;
             ap_specialised=Default_specialise;
             ap_probe=None;
           }
@@ -743,7 +743,7 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~attr ~loc =
             ap_args = args;
             ap_loc = Loc_unknown;
             ap_tailcall = Default_tailcall;
-            ap_inlined = Default_inline;
+            ap_inlined = Default_inlined;
             ap_specialised = Default_specialise;
             ap_probe=None;
           }
@@ -806,10 +806,11 @@ let simplify_local_functions lam =
   in
   let enabled = function
     | {local = Always_local; _}
-    | {local = Default_local; inline = (Never_inline | Default_inline); _}
+    | {local = Default_local;
+       inline = (Never_inline | Default_inline | Available_inline); _}
       -> true
     | {local = Default_local;
-       inline = (Always_inline | Unroll _ | Hint_inline); _}
+       inline = (Always_inline | Unroll _); _}
     | {local = Never_local; _}
       -> false
   in

lambda/translattribute.ml

@@ -120,7 +120,7 @@ let parse_id_payload txt loc ~default ~empty cases payload =
       | Some r -> r
       | None -> warn ()
 
-let parse_inline_attribute attr =
+let parse_inline_attribute attr : inline_attribute =
   match attr with
   | None -> Default_inline
   | Some {Parsetree.attr_name = {txt;loc} as id; attr_payload = payload} ->
@@ -141,7 +141,32 @@ let parse_inline_attribute attr =
         [
           "never", Never_inline;
           "always", Always_inline;
-          "hint", Hint_inline;
+          "available", Available_inline;
+        ]
+        payload
+
+let parse_inlined_attribute attr : inlined_attribute =
+  match attr with
+  | None -> Default_inlined
+  | Some {Parsetree.attr_name = {txt;loc} as id; attr_payload = payload} ->
+    if is_unrolled id then begin
+      (* the 'unrolled' attributes must be used as [@unrolled n]. *)
+      let warning txt = Warnings.Attribute_payload
+          (txt, "It must be an integer literal")
+      in
+      match get_payload get_int_from_exp payload with
+      | Ok n -> Unroll n
+      | Error () ->
+        Location.prerr_warning loc (warning txt);
+        Default_inlined
+    end else
+      parse_id_payload txt loc
+        ~default:Default_inlined
+        ~empty:Always_inlined
+        [
+          "never", Never_inlined;
+          "always", Always_inlined;
+          "hint", Hint_inlined;
         ]
         payload
 
@@ -186,7 +211,7 @@ let get_local_attribute l =
 
 let check_local_inline loc attr =
   match attr.local, attr.inline with
-  | Always_local, (Always_inline | Hint_inline | Unroll _) ->
+  | Always_local, (Always_inline | Available_inline | Unroll _) ->
       Location.prerr_warning loc
         (Warnings.Duplicated_attribute "local/inline")
   | _ ->
@@ -198,14 +223,14 @@ let add_inline_attribute expr loc attributes =
   | Lfunction({ attr = { stub = false } as attr } as funct), inline ->
       begin match attr.inline with
       | Default_inline -> ()
-      | Always_inline | Hint_inline | Never_inline | Unroll _ ->
+      | Always_inline | Available_inline | Never_inline | Unroll _ ->
           Location.prerr_warning loc
             (Warnings.Duplicated_attribute "inline")
       end;
       let attr = { attr with inline } in
       check_local_inline loc attr;
       Lfunction { funct with attr = attr }
-  | expr, (Always_inline | Hint_inline | Never_inline | Unroll _) ->
+  | expr, (Always_inline | Available_inline | Never_inline | Unroll _) ->
       Location.prerr_warning loc
         (Warnings.Misplaced_attribute "inline");
       expr
@@ -254,23 +279,23 @@ let get_and_remove_inlined_attribute e =
   let attr, exp_attributes =
     find_attribute is_inlined_attribute e.exp_attributes
   in
-  let inlined = parse_inline_attribute attr in
+  let inlined = parse_inlined_attribute attr in
   inlined, { e with exp_attributes }
 
 let get_and_remove_inlined_attribute_on_module e =
   let rec get_and_remove mod_expr =
     let attr, mod_attributes =
       find_attribute is_inlined_attribute mod_expr.mod_attributes
     in
-    let attr = parse_inline_attribute attr in
+    let attr = parse_inlined_attribute attr in
     let attr, mod_desc =
       match mod_expr.Typedtree.mod_desc with
       | Tmod_constraint (me, mt, mtc, mc) ->
         let inner_attr, me = get_and_remove me in
         let attr =
           match attr with
-          | Always_inline | Hint_inline | Never_inline | Unroll _ -> attr
-          | Default_inline -> inner_attr
+          | Always_inlined | Hint_inlined | Never_inlined | Unroll _ -> attr
+          | Default_inlined -> inner_attr
         in
         attr, Tmod_constraint (me, mt, mtc, mc)
       | md -> attr, md

lambda/translattribute.mli

@@ -55,11 +55,11 @@ val get_local_attribute
 
 val get_and_remove_inlined_attribute
    : Typedtree.expression
-  -> Lambda.inline_attribute * Typedtree.expression
+  -> Lambda.inlined_attribute * Typedtree.expression
 
 val get_and_remove_inlined_attribute_on_module
    : Typedtree.module_expr
-  -> Lambda.inline_attribute * Typedtree.module_expr
+  -> Lambda.inlined_attribute * Typedtree.module_expr
 
 val get_and_remove_specialised_attribute
    : Typedtree.expression

lambda/translclass.ml

@@ -55,7 +55,7 @@ let mkappl (func, args) =
     ap_func=func;
     ap_args=args;
     ap_tailcall=Default_tailcall;
-    ap_inlined=Default_inline;
+    ap_inlined=Default_inlined;
     ap_specialised=Default_specialise;
     ap_probe=None;
   };;
@@ -499,7 +499,7 @@ let transl_class_rebind ~scopes cl vf =
         ap_func=Lvar obj_init;
         ap_args=[Lvar self];
         ap_tailcall=Default_tailcall;
-        ap_inlined=Default_inline;
+        ap_inlined=Default_inlined;
         ap_specialised=Default_specialise;
         ap_probe=None;
       }

lambda/translcore.ml

@@ -487,7 +487,7 @@ and transl_exp0 ~in_new_scope ~scopes e =
               [transl_class_path loc e.exp_env cl], loc);
         ap_args=[lambda_unit];
         ap_tailcall=Default_tailcall;
-        ap_inlined=Default_inline;
+        ap_inlined=Default_inlined;
         ap_specialised=Default_specialise;
         ap_probe=None;
       }
@@ -511,7 +511,7 @@ and transl_exp0 ~in_new_scope ~scopes e =
              ap_func=Translobj.oo_prim "copy";
              ap_args=[self];
              ap_tailcall=Default_tailcall;
-             ap_inlined=Default_inline;
+             ap_inlined=Default_inlined;
              ap_specialised=Default_specialise;
              ap_probe=None;
            },
@@ -662,7 +662,7 @@ and transl_exp0 ~in_new_scope ~scopes e =
           ap_args = List.map (fun id -> Lvar id) arg_idents;
           ap_loc = of_location e.exp_loc ~scopes;
           ap_tailcall = Default_tailcall;
-          ap_inlined = Never_inline;
+          ap_inlined = Never_inlined;
           ap_specialised = Always_specialise;
           ap_probe = Some {name};
         }
@@ -741,7 +741,7 @@ and transl_tupled_cases ~scopes patl_expr_list =
 
 and transl_apply ~scopes
       ?(tailcall=Default_tailcall)
-      ?(inlined = Default_inline)
+      ?(inlined = Default_inlined)
       ?(specialised = Default_specialise)
       lam sargs loc
   =
@@ -1207,7 +1207,7 @@ and transl_letop ~scopes loc env let_ ands param case partial =
                ap_func = op;
                ap_args=[Lvar left_id; Lvar right_id];
                ap_tailcall = Default_tailcall;
-               ap_inlined = Default_inline;
+               ap_inlined = Default_inlined;
                ap_specialised = Default_specialise;
                ap_probe=None;
              })
@@ -1236,7 +1236,7 @@ and transl_letop ~scopes loc env let_ ands param case partial =
     ap_func = op;
     ap_args=[exp; func];
     ap_tailcall = Default_tailcall;
-    ap_inlined = Default_inline;
+    ap_inlined = Default_inlined;
     ap_specialised = Default_specialise;
     ap_probe=None;
   }

lambda/translcore.mli

@@ -26,7 +26,7 @@ val pure_module : module_expr -> let_kind
 val transl_exp: scopes:scopes -> expression -> lambda
 val transl_apply: scopes:scopes
                   -> ?tailcall:tailcall_attribute
-                  -> ?inlined:inline_attribute
+                  -> ?inlined:inlined_attribute
                   -> ?specialised:specialise_attribute
                   -> lambda -> (arg_label * expression option) list
                   -> scoped_location -> lambda