flambda-backend: Propagate never-returning functions, except when annotated with [@opaque] (#2099)

* Propagate never-returning functions, except when annotated with [@opaque]

* fix backtrace tests

* Remove redundant `[@@inline never]`

Co-authored-by: Vincent Laviron <[email protected]>

---------

Co-authored-by: Vincent Laviron <[email protected]>

Author: Ekdohibs

lambda/lambda.ml

@@ -569,6 +569,7 @@ type function_attribute = {
   poll: poll_attribute;
   loop: loop_attribute;
   is_a_functor: bool;
+  is_opaque: bool;
   stub: bool;
   tmc_candidate: bool;
 }
@@ -758,6 +759,7 @@ let default_function_attribute = {
   poll = Default_poll;
   loop = Default_loop;
   is_a_functor = false;
+  is_opaque = false;
   stub = false;
   tmc_candidate = false;
 }

lambda/lambda.mli

@@ -465,6 +465,7 @@ type function_attribute = {
   poll: poll_attribute;
   loop: loop_attribute;
   is_a_functor: bool;
+  is_opaque: bool;
   stub: bool;
   tmc_candidate: bool;
 }

lambda/translattribute.ml

@@ -50,6 +50,10 @@ let is_poll_attribute =
 let is_loop_attribute =
   [ ["loop"; "ocaml.loop"], true ]
 
+let is_opaque_attribute =
+  [ ["opaque"; "ocaml.opaque"], true ]
+
+
 let find_attribute p attributes =
   let inline_attribute =
     Builtin_attributes.filter_attributes
@@ -297,6 +301,17 @@ let parse_loop_attribute attr =
         ]
         payload
 
+let parse_opaque_attribute attr =
+  match attr with
+  | None -> false
+  | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} ->
+      parse_id_payload txt loc
+        ~default:false
+        ~empty:true
+        []
+        payload
+
+
 let get_inline_attribute l =
   let attr = find_attribute is_inline_attribute l in
   parse_inline_attribute attr
@@ -309,6 +324,11 @@ let get_local_attribute l =
   let attr = find_attribute is_local_attribute l in
   parse_local_attribute attr
 
+let get_opaque_attribute l =
+  let attr = find_attribute is_opaque_attribute l in
+  parse_opaque_attribute attr
+
+
 let get_property_attribute l p =
   let attr = find_attribute (is_property_attribute p) l in
   let res = parse_property_attribute attr p in
@@ -360,6 +380,25 @@ let check_poll_local loc attr =
   | _ ->
       ()
 
+let check_opaque_inline loc attr =
+  match attr.is_opaque, attr.inline with
+  | true, (Always_inline | Available_inline | Unroll _) ->
+      Location.prerr_warning loc
+        (Warnings.Inlining_impossible
+           "[@opaque] is incompatible with inlining")
+  | _ ->
+      ()
+
+let check_opaque_local loc attr =
+  match attr.is_opaque, attr.local with
+  | true, Always_local ->
+      Location.prerr_warning loc
+        (Warnings.Inlining_impossible
+           "[@opaque] is incompatible with local function optimization")
+  | _ ->
+      ()
+
+
 let lfunction_with_attr ~attr
   { kind; params; return; body; attr=_; loc; mode; ret_mode; region } =
   lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~ret_mode ~region
@@ -525,6 +564,24 @@ let add_poll_attribute expr loc attributes =
     end
   | expr -> expr
 
+let add_opaque_attribute expr loc attributes =
+  match expr with
+  | Lfunction({ attr } as funct) ->
+      if not (get_opaque_attribute attributes) then
+        expr
+      else begin
+        if attr.is_opaque then
+          Location.prerr_warning loc
+            (Warnings.Duplicated_attribute "opaque");
+        let attr = { attr with is_opaque = true } in
+        check_opaque_inline loc attr;
+        check_opaque_local loc attr;
+        let attr = { attr with inline = Never_inline; local = Never_local } in
+        lfunction_with_attr ~attr funct
+      end
+  | _ -> expr
+
+
 (* Get the [@inlined] attribute payload (or default if not present). *)
 let get_inlined_attribute e =
   let attr = find_attribute is_inlined_attribute e.exp_attributes in
@@ -584,8 +641,11 @@ let add_function_attributes lam loc attr =
   let lam =
     add_tmc_attribute lam loc attr
   in
+  (* last because poll and opaque overrides inline and local *)
   let lam =
-    (* last because poll overrides inline and local *)
     add_poll_attribute lam loc attr
   in
+  let lam =
+    add_opaque_attribute lam loc attr
+  in
   lam

lambda/translcore.ml

@@ -955,6 +955,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
           check = Default_check;
           loop = Never_loop;
           is_a_functor = false;
+          is_opaque = false;
           stub = false;
           poll = Default_poll;
           tmc_candidate = false;

lambda/translmod.ml

@@ -598,6 +598,7 @@ let rec compile_functor ~scopes mexp coercion root_path loc =
       poll = Default_poll;
       loop = Never_loop;
       is_a_functor = true;
+      is_opaque = false;
       check = Ignore_assert_all Zero_alloc;
       stub = false;
       tmc_candidate = false;

testsuite/tests/backtrace/pr6920_why_at.ml

@@ -5,7 +5,7 @@
    exit_status = "2"
 *)
 
-let why : unit -> unit = fun () -> raise Exit [@@inline never]
+let why : unit -> unit = fun () -> raise Exit [@@opaque]
 let f () =
   why @@ ();
   ignore (3 + 2);

testsuite/tests/backtrace/pr6920_why_swallow.ml

@@ -5,7 +5,7 @@
    exit_status = "2"
 *)
 
-let why : unit -> unit = fun () -> raise Exit [@@inline never]
+let why : unit -> unit = fun () -> raise Exit [@@opaque]
 let f () =
   for i = 1 to 10 do
     why @@ ();