Fix warning 55 semantics (ocaml-flambda#1375)

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -259,7 +259,7 @@ module Inlining = struct
           | Never_inlined ->
             ( Call_site_inlining_decision_type.Never_inlined_attribute,
               Not_inlinable )
-          | Always_inlined | Hint_inlined ->
+          | Always_inlined _ | Hint_inlined ->
             Call_site_inlining_decision_type.Attribute_always, Inlinable code
           | Default_inlined | Unroll _ ->
             (* Closure ignores completely [@unrolled] attributes, so it seems
@@ -1056,17 +1056,6 @@ let close_let_cont acc env ~name ~is_exn_handler ~params
     Let_cont_with_acc.build_recursive acc
       ~invariant_params:Bound_parameters.empty ~handlers ~body
 
-let warn_not_inlined_if_needed (apply : IR.apply) reason =
-  let warn kind =
-    Location.prerr_warning
-      (Debuginfo.Scoped_location.to_location apply.loc)
-      (Warnings.Inlining_impossible (reason kind))
-  in
-  match apply.inlined with
-  | Hint_inlined | Never_inlined | Default_inlined -> ()
-  | Always_inlined -> warn Inlining_helpers.Inlined
-  | Unroll _ -> warn Inlining_helpers.Unrolled
-
 let close_exact_or_unknown_apply acc env
     ({ kind;
        func;
@@ -1080,7 +1069,7 @@ let close_exact_or_unknown_apply acc env
        region_close;
        region;
        return_arity
-     } as ir_apply :
+     } :
       IR.apply) callee_approx ~replace_region : Expr_with_acc.t =
   let callee = find_simple_from_id env func in
   let current_region =
@@ -1148,8 +1137,11 @@ let close_exact_or_unknown_apply acc env
   then
     match Inlining.inlinable env apply callee_approx with
     | Not_inlinable ->
-      warn_not_inlined_if_needed ir_apply (fun _ ->
-          "Function information unavailable");
+      let apply =
+        Apply.with_inlined_attribute apply
+          (Inlined_attribute.with_use_info (Apply.inlined apply)
+             Unused_because_function_unknown)
+      in
       Expr_with_acc.create_apply acc apply
     | Inlinable func_desc ->
       let acc = Acc.mark_continuation_as_untrackable continuation acc in
@@ -2266,8 +2258,14 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t =
         { apply with args; continuation = apply.continuation }
         (Some approx) ~replace_region:None
     | Partial_app { provided; missing_arity } ->
-      warn_not_inlined_if_needed apply
-        Inlining_helpers.inlined_attribute_on_partial_application_msg;
+      (match apply.inlined with
+      | Always_inlined | Unroll _ ->
+        Location.prerr_warning
+          (Debuginfo.Scoped_location.to_location apply.loc)
+          (Warnings.Inlining_impossible
+             Inlining_helpers.(
+               inlined_attribute_on_partial_application_msg Inlined))
+      | Never_inlined | Hint_inlined | Default_inlined -> ());
       wrap_partial_application acc env apply.continuation apply approx ~provided
         ~missing_arity ~arity ~num_trailing_local_params
         ~contains_no_escaping_local_allocs

middle_end/flambda2/parser/fexpr.ml

@@ -391,7 +391,7 @@ type inline_attribute = Inline_attribute.t =
   | Unroll of int
   | Default_inline
 
-type inlined_attribute = Inlined_attribute.t =
+type inlined_attribute =
   | Always_inlined
   | Hint_inlined
   | Never_inlined

middle_end/flambda2/parser/fexpr_to_flambda.ml

@@ -964,8 +964,13 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t =
         | None | Some { params_arity = None; ret_arity = _ } ->
           Misc.fatal_errorf "Must specify arities for C call")
     in
-    let inlined =
-      inlined |> Option.value ~default:Inlined_attribute.Default_inlined
+    let inlined : Inlined_attribute.t =
+      match inlined with
+      | None | Some Default_inlined -> Default_inlined
+      | Some Hint_inlined -> Hint_inlined
+      | Some Always_inlined -> Always_inlined Expected_to_be_used
+      | Some (Unroll n) -> Unroll (n, Expected_to_be_used)
+      | Some Never_inlined -> Never_inlined
     in
     let inlining_state =
       match inlining_state with

middle_end/flambda2/parser/flambda_to_fexpr.ml

@@ -1022,10 +1022,16 @@ and apply_expr env (app : Apply_expr.t) : Fexpr.expr =
     | Method _ ->
       None
   in
-  let inlined =
+  let inlined : Fexpr.inlined_attribute option =
     if Flambda2_terms.Inlined_attribute.is_default (Apply_expr.inlined app)
     then None
-    else Some (Apply_expr.inlined app)
+    else
+      match Apply_expr.inlined app with
+      | Default_inlined -> Some Default_inlined
+      | Hint_inlined -> Some Hint_inlined
+      | Always_inlined _ -> Some Always_inlined
+      | Unroll (n, _) -> Some (Unroll n)
+      | Never_inlined -> Some Never_inlined
   in
   let inlining_state = inlining_state (Apply_expr.inlining_state app) in
   let region = Env.find_region_exn env (Apply_expr.region app) in

middle_end/flambda2/parser/print_fexpr.ml

@@ -645,7 +645,7 @@ let inline_attribute ~space ppf (i : Inline_attribute.t) =
 let inline_attribute_opt ~space ppf i =
   pp_option ~space (inline_attribute ~space:Neither) ppf i
 
-let inlined_attribute ~space ppf (i : Inlined_attribute.t) =
+let inlined_attribute ~space ppf (i : Fexpr.inlined_attribute) =
   let str =
     match i with
     | Always_inlined -> Some "inlined(always)"

middle_end/flambda2/simplify/inlining/call_site_inlining_decision.ml

@@ -187,7 +187,7 @@ let make_decision dacc ~simplify_expr ~function_type ~apply ~return_arity :
   let inlined = Apply.inlined apply in
   match inlined with
   | Never_inlined -> Never_inlined_attribute
-  | Default_inlined | Unroll _ | Always_inlined | Hint_inlined -> (
+  | Default_inlined | Unroll _ | Always_inlined _ | Hint_inlined -> (
     let code_or_metadata =
       DE.find_code_exn (DA.denv dacc) (FT.code_id function_type)
     in
@@ -247,12 +247,12 @@ let make_decision dacc ~simplify_expr ~function_type ~apply ~return_arity :
             else
               might_inline dacc ~apply ~code_or_metadata ~function_type
                 ~simplify_expr ~return_arity
-          | Unroll unroll_to ->
+          | Unroll (unroll_to, _) ->
             if Simplify_rec_info_expr.can_unroll dacc rec_info
             then
               (* This sets off step 1 in the comment above; see
                  [Inlining_transforms] for how [unroll_to] is ultimately
                  handled. *)
               Attribute_unroll unroll_to
             else Unrolling_depth_exceeded
-          | Always_inlined | Hint_inlined -> Attribute_always))
+          | Always_inlined _ | Hint_inlined -> Attribute_always))

middle_end/flambda2/simplify/simplify_apply_expr.ml

@@ -26,19 +26,6 @@ let fail_if_probe apply =
        always be direct applications of an OCaml function:@ %a"
       Apply.print apply
 
-let warn_not_inlined_if_needed apply reason =
-  match Apply.inlined apply with
-  | Hint_inlined | Never_inlined | Default_inlined -> ()
-  | Always_inlined | Unroll _ ->
-    let dbg = Apply.dbg apply in
-    let reason =
-      Format.asprintf "%s@ (the full inlining stack was:@ %a)" reason
-        Debuginfo.print_compact dbg
-    in
-    Location.prerr_warning
-      (Debuginfo.to_location dbg)
-      (Warnings.Inlining_impossible reason)
-
 let record_free_names_of_apply_as_used0 apply ~use_id ~exn_cont_use_id data_flow
     =
   let data_flow =
@@ -181,6 +168,10 @@ let rebuild_non_inlined_direct_full_application apply ~use_id ~exn_cont_use_id
   in
   after_rebuild expr uacc
 
+type inlining_decision =
+  | Do_not_inline of { erase_attribute : bool }
+  | Inline of DA.t * Expr.t
+
 let simplify_direct_full_application ~simplify_expr dacc apply function_type
     ~params_arity ~result_arity ~(result_types : _ Or_unknown_or_bottom.t)
     ~down_to_up ~coming_from_indirect ~callee's_code_metadata =
@@ -203,35 +194,28 @@ let simplify_direct_full_application ~simplify_expr dacc apply function_type
         ~are_rebuilding_terms:(DA.are_rebuilding_terms dacc)
         ~apply decision;
     match Call_site_inlining_decision_type.can_inline decision with
-    | Do_not_inline { warn_if_attribute_ignored; because_of_definition } ->
-      (* emission of the warning at this point should not happen, if it does,
-         then that means that {Inlining_decision.make_decision_for_call_site}
-         did not honour the attributes on the call site *)
-      if warn_if_attribute_ignored
-         && Are_rebuilding_terms.are_rebuilding (DA.are_rebuilding_terms dacc)
-      then
-        if because_of_definition
-        then
-          warn_not_inlined_if_needed apply
-            "[@inlined] attribute was not used on this function application \
-             (the optimizer decided not to inline the function given its \
-             definition)"
-        else
-          (* XXX talk to Pierre O. about message *)
-          warn_not_inlined_if_needed apply
-            "[@inlined] attribute was not used on this function \
-             application{Do_not_inline}";
-      None
+    | Do_not_inline { erase_attribute_if_ignored } ->
+      Do_not_inline { erase_attribute = erase_attribute_if_ignored }
     | Inline { unroll_to; was_inline_always } ->
       let dacc, inlined =
         Inlining_transforms.inline dacc ~apply ~unroll_to ~was_inline_always
           function_type
       in
-      Some (dacc, inlined)
+      Inline (dacc, inlined)
   in
   match inlined with
-  | Some (dacc, inlined) -> simplify_expr dacc inlined ~down_to_up
-  | None -> (
+  | Inline (dacc, inlined) -> simplify_expr dacc inlined ~down_to_up
+  | Do_not_inline { erase_attribute } -> (
+    let apply =
+      let inlined : Inlined_attribute.t =
+        if erase_attribute
+        then Default_inlined
+        else
+          Inlined_attribute.with_use_info (Apply.inlined apply)
+            Unused_because_of_call_site_decision
+      in
+      Apply.with_inlined_attribute apply inlined
+    in
     match loopify_decision_for_call dacc apply with
     | Loopify self_cont ->
       simplify_self_tail_call dacc apply self_cont ~down_to_up
@@ -366,7 +350,7 @@ let simplify_direct_partial_application ~simplify_expr dacc apply
     | Return continuation -> continuation
   in
   (match Apply.inlined apply with
-  | Always_inlined | Never_inlined ->
+  | Always_inlined _ | Never_inlined ->
     Location.prerr_warning
       (Debuginfo.to_location dbg)
       (Warnings.Inlining_impossible
@@ -694,7 +678,7 @@ let simplify_direct_function_call ~simplify_expr dacc apply
     ~current_region function_decl ~down_to_up =
   (match Apply.probe_name apply, Apply.inlined apply with
   | None, _ | Some _, Never_inlined -> ()
-  | Some _, (Hint_inlined | Unroll _ | Default_inlined | Always_inlined) ->
+  | Some _, (Hint_inlined | Unroll _ | Default_inlined | Always_inlined _) ->
     Misc.fatal_errorf
       "[Apply] terms with a [probe_name] (i.e. that call a tracing probe) must \
        always be marked as [Never_inline]:@ %a"
@@ -807,6 +791,11 @@ let rebuild_function_call_where_callee's_type_unavailable apply call_kind
     Apply.with_call_kind apply call_kind
     |> Simplify_common.update_exn_continuation_extra_args uacc ~exn_cont_use_id
   in
+  let apply =
+    Apply.with_inlined_attribute apply
+      (Inlined_attribute.with_use_info (Apply.inlined apply)
+         Unused_because_function_unknown)
+  in
   let uacc, expr =
     EB.rewrite_fixed_arity_apply uacc ~use_id (Apply.return_arity apply) apply
   in
@@ -892,11 +881,6 @@ let simplify_function_call ~simplify_expr dacc apply ~callee_ty
     | Indirect_unknown_arity -> is_function_decl_tupled
   in
   let type_unavailable () =
-    if Are_rebuilding_terms.are_rebuilding (DA.are_rebuilding_terms dacc)
-    then
-      warn_not_inlined_if_needed apply
-        "[@inlined] attribute was not used on this function application (the \
-         optimizer did not know what function was being applied)";
     simplify_function_call_where_callee's_type_unavailable dacc apply call
       ~apply_alloc_mode ~down_to_up
   in

middle_end/flambda2/simplify_shared/call_site_inlining_decision_type.ml

@@ -100,10 +100,7 @@ let [@ocamlformat "disable"] print ppf t =
       threshold
 
 type can_inline =
-  | Do_not_inline of
-      { warn_if_attribute_ignored : bool;
-        because_of_definition : bool
-      }
+  | Do_not_inline of { erase_attribute_if_ignored : bool }
   | Inline of
       { unroll_to : int option;
         was_inline_always : bool
@@ -115,17 +112,14 @@ let can_inline (t : t) : can_inline =
   | Recursion_depth_exceeded | Speculatively_not_inline _
   | Definition_says_not_to_inline | Argument_types_not_useful ->
     (* If there's an [@inlined] attribute on this, something's gone wrong *)
-    Do_not_inline
-      { warn_if_attribute_ignored = true; because_of_definition = true }
+    Do_not_inline { erase_attribute_if_ignored = false }
   | Never_inlined_attribute ->
     (* If there's an [@inlined] attribute on this, something's gone wrong *)
-    Do_not_inline
-      { warn_if_attribute_ignored = true; because_of_definition = true }
+    Do_not_inline { erase_attribute_if_ignored = false }
   | Unrolling_depth_exceeded ->
     (* If there's an [@unrolled] attribute on this, then we'll ignore the
        attribute when we stop unrolling, which is fine *)
-    Do_not_inline
-      { warn_if_attribute_ignored = false; because_of_definition = true }
+    Do_not_inline { erase_attribute_if_ignored = true }
   | Attribute_unroll unroll_to ->
     Inline { unroll_to = Some unroll_to; was_inline_always = false }
   | Definition_says_inline { was_inline_always } ->

middle_end/flambda2/simplify_shared/call_site_inlining_decision_type.mli

@@ -45,10 +45,7 @@ val print : Format.formatter -> t -> unit
 val report : Format.formatter -> t -> unit
 
 type can_inline = private
-  | Do_not_inline of
-      { warn_if_attribute_ignored : bool;
-        because_of_definition : bool
-      }
+  | Do_not_inline of { erase_attribute_if_ignored : bool }
   | Inline of
       { unroll_to : int option;
         was_inline_always : bool

middle_end/flambda2/terms/apply_expr.ml

@@ -373,3 +373,5 @@ let region t = t.region
 let args_arity t = t.args_arity
 
 let return_arity t = t.return_arity
+
+let with_inlined_attribute t inlined = { t with inlined }

middle_end/flambda2/terms/apply_expr.mli

@@ -129,3 +129,5 @@ val returns : t -> bool
 
 (** The local allocation region for this application. *)
 val region : t -> Variable.t
+
+val with_inlined_attribute : t -> Inlined_attribute.t -> t