Parse zero_alloc attributes into the typed tree (ocaml-flambda#2400)

Check for [@zero_alloc] earlier, record it in the typed tree

ocaml/lambda/translattribute.ml

@@ -57,108 +57,12 @@ let is_unrolled = function
   | {txt="inline"|"ocaml.inline"|"inlined"|"ocaml.inlined"} -> false
   | _ -> assert false
 
-let get_payload get_from_exp =
-  let open Parsetree in
-  function
-  | PStr [{pstr_desc = Pstr_eval (exp, [])}] -> get_from_exp exp
-  | _ -> Result.Error ()
-
-let get_optional_payload get_from_exp =
-  let open Parsetree in
-  function
-  | PStr [] -> Result.Ok None
-  | other -> Result.map Option.some (get_payload get_from_exp other)
-
-let get_id_from_exp =
-  let open Parsetree in
-  function
-  | { pexp_desc = Pexp_ident { txt = Longident.Lident id } } -> Result.Ok id
-  | _ -> Result.Error ()
-
-let get_int_from_exp =
-  let open Parsetree in
-  function
-    | { pexp_desc = Pexp_constant (Pconst_integer(s, None)) } ->
-        begin match Misc.Int_literal_converter.int s with
-        | n -> Result.Ok n
-        | exception (Failure _) -> Result.Error ()
-        end
-    | _ -> Result.Error ()
-
-let get_construct_from_exp =
-  let open Parsetree in
-  function
-    | { pexp_desc =
-          Pexp_construct ({ txt = Longident.Lident constr }, None) } ->
-        Result.Ok constr
-    | _ -> Result.Error ()
-
-let get_bool_from_exp exp =
-  Result.bind (get_construct_from_exp exp)
-    (function
-      | "true" -> Result.Ok true
-      | "false" -> Result.Ok false
-      | _ -> Result.Error ())
-
-let get_ids_from_exp exp =
-  let open Parsetree in
-  (match exp with
-   | { pexp_desc = Pexp_apply (exp, args) } ->
-     get_id_from_exp exp ::
-     List.map (function
-       | (Nolabel, Parg_expr arg) -> get_id_from_exp arg
-       | (_, _) -> Result.Error ())
-       args
-   | _ -> [get_id_from_exp exp])
-  |> List.fold_left (fun acc r ->
-    match acc, r with
-    | Result.Ok ids, Ok id -> Result.Ok (id::ids)
-    | (Result.Error _ | Ok _), _ -> Result.Error ())
-    (Ok [])
-  |> Result.map List.rev
-
-
-(* [parse_ids_payload] requires that each element in [cases]
-   the first component (string list) is alphabetically sorted. *)
-let parse_ids_payload txt loc ~default ~empty cases payload =
-  let[@local] warn () =
-    let ( %> ) f g x = g (f x) in
-    let msg =
-      cases
-      |> List.map (fst %> String.concat " " %> Printf.sprintf "'%s'")
-      |> String.concat ", "
-      |> Printf.sprintf "It must be either %s or empty"
-    in
-    Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg));
-    default
-  in
-  match get_optional_payload get_ids_from_exp payload with
-  | Error () -> warn ()
-  | Ok None -> empty
-  | Ok (Some ids) ->
-      match List.assoc_opt (List.sort String.compare ids) cases with
-      | Some r -> r
-      | None -> warn ()
-
-let parse_id_payload txt loc ~default ~empty cases payload =
-  let[@local] warn () =
-    let ( %> ) f g x = g (f x) in
-    let msg =
-      cases
-      |> List.map (fst %> Printf.sprintf "'%s'")
-      |> String.concat ", "
-      |> Printf.sprintf "It must be either %s or empty"
-    in
-    Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg));
-    default
-  in
-  match get_optional_payload get_id_from_exp payload with
-  | Error () -> warn ()
-  | Ok None -> empty
-  | Ok (Some id) ->
-      match List.assoc_opt id cases with
-      | Some r -> r
-      | None -> warn ()
+let parse_id_payload txt loc options ~default ~empty payload =
+  match
+    Builtin_attributes.parse_optional_id_payload txt loc options ~empty payload
+  with
+  | Ok a -> a
+  | Error () -> default
 
 let parse_inline_attribute attr : inline_attribute =
   match attr with

ocaml/otherlibs/dynlink/Makefile

@@ -132,7 +132,10 @@ COMPILERLIBS_SOURCES=\
   file_formats/cmi_format.ml \
   typing/persistent_env.ml \
   typing/env.ml \
+<<<<<<< HEAD
   typing/shape_reduce.ml \
+=======
+>>>>>>> fb471efa (Parse `zero_alloc` attributes into the typed tree (#2400))
   lambda/debuginfo.ml \
   lambda/lambda.ml \
   lambda/runtimedef.ml \

ocaml/testsuite/tests/warnings/w53.ml

@@ -536,10 +536,13 @@ module TestZeroAllocStruct = struct
     let x = 42 in
     fun z -> z + x
 end
+<<<<<<< HEAD
 (* TEST
  flags = "-w +A-60-70";
  setup-ocamlc.byte-build-env;
  compile_only = "true";
  ocamlc.byte;
  check-ocamlc.byte-output;
 *)
+=======
+>>>>>>> fb471efa (Parse `zero_alloc` attributes into the typed tree (#2400))

ocaml/testsuite/tests/warnings/w53_marshalled.ml

@@ -1,3 +1,4 @@
+<<<<<<< HEAD
 (* TEST_BELOW
 (* Blank lines added here to preserve locations. *)
 
@@ -17,6 +18,27 @@
 
 
 
+=======
+(* TEST
+readonly_files = "marshall_for_w53.ml w53.ml w53_zero_alloc_all.ml"
+include ocamlcommon
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+program = "${test_build_directory}/marshall_for_w53.exe"
+all_modules = "marshall_for_w53.ml"
+*** run
+**** ocamlc.byte
+flags = "-w +A-60-70"
+module = "w53.marshalled.ml"
+compiler_reference = "${test_source_directory}/w53.compilers.reference"
+***** check-ocamlc.byte-output
+**** setup-ocamlc.byte-build-env
+***** ocamlc.byte
+flags = "-w +A-60-70"
+module = "w53_zero_alloc_all.marshalled.ml"
+compiler_reference = "${test_source_directory}/w53_zero_alloc_all.compilers.reference"
+****** check-ocamlc.byte-output
+>>>>>>> fb471efa (Parse `zero_alloc` attributes into the typed tree (#2400))
 *)
 
 (* This tests that warning 53 happen appropriately when dealing with marshalled

ocaml/testsuite/tests/warnings/w53_zero_alloc_all.ml

@@ -1,3 +1,4 @@
+<<<<<<< HEAD
 (* TEST_BELOW
 (* Blank lines added here to preserve locations. *)
 
@@ -6,6 +7,16 @@
 
 
 
+=======
+(* TEST
+
+flags = "-w +A-60-70"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+compile_only = "true"
+*** check-ocamlc.byte-output
+>>>>>>> fb471efa (Parse `zero_alloc` attributes into the typed tree (#2400))
 
 *)
 
@@ -77,6 +88,7 @@ module TestZeroAllocStruct = struct
     let x = 42 in
     fun z -> z + x
 end
+<<<<<<< HEAD
 
 (* TEST
  flags = "-w +A-60-70";
@@ -85,3 +97,5 @@ end
  ocamlc.byte;
  check-ocamlc.byte-output;
 *)
+=======
+>>>>>>> fb471efa (Parse `zero_alloc` attributes into the typed tree (#2400))

ocaml/typing/typecore.ml

@@ -3976,7 +3976,7 @@ let rec is_nonexpansive exp =
              Val_prim {Primitive.prim_name =
                          ("%raise" | "%reraise" | "%raise_notrace")}},
              Id_prim _, _) },
-      [Nolabel, Arg (Targ_expr (e, _))], _, _) ->
+      [Nolabel, Arg (Targ_expr (e, _))], _, _, _) ->
      is_nonexpansive e
   | Texp_array (_, _, _ :: _, _)
   | Texp_apply _

ocaml/typing/value_rec_check.ml

@@ -656,8 +656,8 @@ let rec expression : Typedtree.expression -> term_judg =
     | Texp_instvar (self_path, pth, _inst_var) ->
         join [path self_path << Dereference; path pth]
     | Texp_apply
-        ({exp_desc = Texp_ident (_, _, vd, Id_prim _, _)},
-          [_, Arg (Targ_expr (arg, _))], _, _)
+        ({exp_desc = Texp_ident (_, _, vd, Id_prim _, _)}, [_, Arg (Targ_expr (arg, _))], _,
+         _, _)
       when is_ref vd ->
       (*
         G |- e: m[Guard]