diff --git a/lambda/lambda.ml b/lambda/lambda.ml index 01ebdc768fbc..3bf6b176b15c 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -353,6 +353,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 *) @@ -360,12 +361,13 @@ 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 c5ef7d8a6708..a1e3c87fa0cb 100644 --- a/lambda/lambda.mli +++ b/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 *) diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml index 189415585578..bb8d45c8b73c 100644 --- a/lambda/printlambda.ml +++ b/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 diff --git a/lambda/simplif.ml b/lambda/simplif.ml index 8675ae4d60c7..0ca59fad7619 100644 --- a/lambda/simplif.ml +++ b/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 diff --git a/lambda/translattribute.ml b/lambda/translattribute.ml index 1520a3b41fb4..d2d48c842e96 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) diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index 5b966f53c1d0..56408b47c92a 100644 --- a/middle_end/closure/closure.ml +++ b/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 diff --git a/testsuite/tests/warnings/w47_inline.compilers.reference b/testsuite/tests/warnings/w47_inline.compilers.reference index 7c9bed8ea161..c9048adc3e33 100644 --- a/testsuite/tests/warnings/w47_inline.compilers.reference +++ b/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 ^^^^^ diff --git a/testsuite/tests/warnings/w55.flambda.reference b/testsuite/tests/warnings/w55.flambda.reference index b71753901a2e..160121450897 100644 --- a/testsuite/tests/warnings/w55.flambda.reference +++ b/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: diff --git a/testsuite/tests/warnings/w55.ml b/testsuite/tests/warnings/w55.ml index 6013ced49873..67fecee7aeae 100644 --- a/testsuite/tests/warnings/w55.ml +++ b/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 diff --git a/testsuite/tests/warnings/w55.native.reference b/testsuite/tests/warnings/w55.native.reference index 03e5ea4e05d5..9ffb78f0990f 100644 --- a/testsuite/tests/warnings/w55.native.reference +++ b/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: