Merge pull request #9349 from lpw25/inline-hint

Add [@inlined hint] attribute

5 files changed, 14 insertions, 6 deletions

diff --git a/lambda/lambda.ml b/lambda/lambda.ml
index 60b846b929..bfeec50908 100644
--- a/lambda/lambda.ml
+++ b/lambda/lambda.ml
@@ -215,6 +215,7 @@ type structured_constant =
 type inline_attribute =
   | Always_inline (* [@inline] or [@inline always] *)
   | Never_inline (* [@inline never] *)
+  | Hint_inline (* [@inlined hint] attribute *)
   | Unroll of int (* [@unroll x] *)
   | Default_inline (* no [@inline] attribute *)
 
@@ -222,12 +223,14 @@ let equal_inline_attribute x y =
   match x, y with
   | Always_inline, Always_inline
   | Never_inline, Never_inline
+  | Hint_inline, Hint_inline
   | Default_inline, Default_inline
     ->
     true
   | Unroll u, Unroll v ->
     u = v
-  | (Always_inline | Never_inline | Unroll _ | Default_inline), _ ->
+  | (Always_inline | Never_inline
+    | Hint_inline | Unroll _ | Default_inline), _ ->
     false
 
 type specialise_attribute =
diff --git a/lambda/lambda.mli b/lambda/lambda.mli
index 0e37a9045e..a5b5784d77 100644
--- a/lambda/lambda.mli
+++ b/lambda/lambda.mli
@@ -206,6 +206,7 @@ type structured_constant =
 type inline_attribute =
   | Always_inline (* [@inline] or [@inline always] *)
   | Never_inline (* [@inline never] *)
+  | Hint_inline (* [@inline hint] *)
   | Unroll of int (* [@unroll x] *)
   | Default_inline (* no [@inline] attribute *)
 
diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml
index 6bdfbf31f5..43a93ba353 100644
--- a/lambda/printlambda.ml
+++ b/lambda/printlambda.ml
@@ -459,6 +459,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@ "
   | Never_inline -> fprintf ppf "never_inline@ "
   | Unroll i -> fprintf ppf "unroll(%i)@ " i
   end;
@@ -481,6 +482,7 @@ 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"
   | Unroll i -> fprintf ppf " never_inline(%i)" i
 
 let apply_specialised_attribute ppf = function
diff --git a/lambda/simplif.ml b/lambda/simplif.ml
index 465d299364..dcbfa38ba6 100644
--- a/lambda/simplif.ml
+++ b/lambda/simplif.ml
@@ -772,7 +772,8 @@ let simplify_local_functions lam =
     | {local = Always_local; _}
     | {local = Default_local; inline = (Never_inline | Default_inline); _}
       -> true
-    | {local = Default_local; inline = (Always_inline | Unroll _); _}
+    | {local = Default_local;
+       inline = (Always_inline | Unroll _ | Hint_inline); _}
     | {local = Never_local; _}
       -> false
   in
diff --git a/lambda/translattribute.ml b/lambda/translattribute.ml
index 1520a3b41f..d2d48c842e 100644
--- a/lambda/translattribute.ml
+++ b/lambda/translattribute.ml
@@ -122,6 +122,7 @@ let parse_inline_attribute attr =
         [
           "never", Never_inline;
           "always", Always_inline;
+          "hint", Hint_inline;
         ]
         payload
 
@@ -166,7 +167,7 @@ let get_local_attribute l =
 
 let check_local_inline loc attr =
   match attr.local, attr.inline with
-  | Always_local, (Always_inline | Unroll _) ->
+  | Always_local, (Always_inline | Hint_inline | Unroll _) ->
       Location.prerr_warning loc
         (Warnings.Duplicated_attribute "local/inline")
   | _ ->
@@ -178,14 +179,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 | Never_inline | Unroll _ ->
+      | Always_inline | Hint_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 | Never_inline | Unroll _) ->
+  | expr, (Always_inline | Hint_inline | Never_inline | Unroll _) ->
       Location.prerr_warning loc
         (Warnings.Misplaced_attribute "inline");
       expr
@@ -249,7 +250,7 @@ let get_and_remove_inlined_attribute_on_module e =
         let inner_attr, me = get_and_remove me in
         let attr =
           match attr with
-          | Always_inline | Never_inline | Unroll _ -> attr
+          | Always_inline | Hint_inline | Never_inline | Unroll _ -> attr
           | Default_inline -> inner_attr
         in
         attr, Tmod_constraint (me, mt, mtc, mc)