ocaml#9349 from lpw25/inline-int (cherry-pick commit a026f6b)

Add [@inlined hint] attribute

lambda/lambda.ml

@@ -353,19 +353,21 @@ 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 *)
 
 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 =

lambda/lambda.mli

@@ -235,6 +235,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 *)
 

lambda/printlambda.ml

@@ -486,6 +486,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;
@@ -508,6 +509,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

lambda/simplif.ml

@@ -812,7 +812,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

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)

middle_end/closure/closure.ml

@@ -1325,7 +1325,7 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs =
           in
           let magic_scale_constant = 8. in
           int_of_float (inline_threshold *. magic_scale_constant) + n
-      | Always_inline -> max_int
+      | Always_inline | Hint_inline -> max_int
       | Never_inline -> min_int
       | Unroll _ -> assert false
     in

testsuite/tests/warnings/w47_inline.compilers.reference

@@ -10,27 +10,27 @@ File "w47_inline.ml", line 15, characters 23-29:
 15 | let d = (fun x -> x) [@inline malformed attribute] (* rejected *)
                             ^^^^^^
 Warning 47: illegal payload for attribute 'inline'.
-It must be either 'never', 'always' or empty
+It must be either 'never', 'always', 'hint' or empty
 File "w47_inline.ml", line 16, characters 23-29:
 16 | let e = (fun x -> x) [@inline malformed_attribute] (* rejected *)
                             ^^^^^^
 Warning 47: illegal payload for attribute 'inline'.
-It must be either 'never', 'always' or empty
+It must be either 'never', 'always', 'hint' or empty
 File "w47_inline.ml", line 17, characters 23-29:
 17 | let f = (fun x -> x) [@inline : malformed_attribute] (* rejected *)
                             ^^^^^^
 Warning 47: illegal payload for attribute 'inline'.
-It must be either 'never', 'always' or empty
+It must be either 'never', 'always', 'hint' or empty
 File "w47_inline.ml", line 18, characters 23-29:
 18 | let g = (fun x -> x) [@inline ? malformed_attribute] (* rejected *)
                             ^^^^^^
 Warning 47: illegal payload for attribute 'inline'.
-It must be either 'never', 'always' or empty
+It must be either 'never', 'always', 'hint' or empty
 File "w47_inline.ml", line 23, characters 15-22:
 23 | let k x = (a [@inlined malformed]) x (* rejected *)
                     ^^^^^^^
 Warning 47: illegal payload for attribute 'inlined'.
-It must be either 'never', 'always' or empty
+It must be either 'never', 'always', 'hint' or empty
 File "w47_inline.ml", line 31, characters 7-12:
 31 |   let[@local malformed] f3 x = x (* bad payload *) in
             ^^^^^

testsuite/tests/warnings/w55.flambda.reference

@@ -3,7 +3,7 @@ File "w55.ml", line 33, characters 10-26:
                ^^^^^^^^^^^^^^^^
 Warning 55: Cannot inline: [@inlined] attributes may not be used on partial applications
 File "w55.ml", line 29, characters 10-27:
-29 | let i x = (!h [@inlined]) x
+29 | let i x = (!r [@inlined]) x
                ^^^^^^^^^^^^^^^^^
 Warning 55: Cannot inline: [@inlined] attribute was not used on this function application (the optimizer did not know what function was being applied)
 File "w55.ml", line 39, characters 12-30:

testsuite/tests/warnings/w55.ml

@@ -24,9 +24,9 @@ let f = (fun x -> x + 1) [@inline never]
 
 let g x = (f [@inlined]) x
 
-let h = ref f
+let r = ref f
 
-let i x = (!h [@inlined]) x
+let i x = (!r [@inlined]) x
 
 let j x y = x + y
 
@@ -40,3 +40,13 @@ let b x y = (a [@inlined]) x y
 
 let c x = x + 1 [@@inline never]
 let d x = (c [@inlined]) x
+
+let g' x = (f [@inlined hint]) x
+
+let i' x = (!r [@inlined hint]) x
+
+let h' x = (j [@inlined hint]) x
+
+let b' x y = (a [@inlined hint]) x y
+
+let d' x = (c [@inlined hint]) x

testsuite/tests/warnings/w55.native.reference

@@ -3,7 +3,7 @@ File "w55.ml", line 25, characters 10-26:
                ^^^^^^^^^^^^^^^^
 Warning 55: Cannot inline: Function information unavailable
 File "w55.ml", line 29, characters 10-27:
-29 | let i x = (!h [@inlined]) x
+29 | let i x = (!r [@inlined]) x
                ^^^^^^^^^^^^^^^^^
 Warning 55: Cannot inline: Unknown function
 File "w55.ml", line 33, characters 10-26: