Attribute [@@@zero_alloc check] to turn the check on (#1294)

Author: gretay-js

backend/checkmach.ml

@@ -786,7 +786,7 @@ end
 module Spec_zero_alloc : Spec = struct
   let property = Cmm.Zero_alloc
 
-  let enabled () = !Flambda_backend_flags.zero_alloc_check
+  let enabled () = !Clflags.zero_alloc_check
 
   (* Compact the mapping from function name to Value.t to reduce size of Checks
      in cmx and memory consumption Compilenv. Different components have

backend/checks.ml

@@ -24,7 +24,7 @@ let reset t =
   t.enabled <- false
 
 let merge src ~into:dst =
-  if !Flambda_backend_flags.zero_alloc_check
+  if !Clflags.zero_alloc_check
   then (
     let join _key b1 b2 = Some (b1 || b2) in
     dst.nor <- String.Map.union join dst.nor src.nor;

driver/flambda_backend_args.ml

@@ -742,7 +742,8 @@ module Flambda_backend_options_impl = struct
 
   let heap_reduction_threshold x =
     Flambda_backend_flags.heap_reduction_threshold := x
-  let zero_alloc_check = set' Flambda_backend_flags.zero_alloc_check
+
+  let zero_alloc_check = set' Clflags.zero_alloc_check
   let dcheckmach = set' Flambda_backend_flags.dump_checkmach
 
   let disable_poll_insertion = set' Flambda_backend_flags.disable_poll_insertion
@@ -972,7 +973,7 @@ module Extra_params = struct
        set_int_option' Flambda_backend_flags.reorder_blocks_random
     | "basic-block-sections" -> set' Flambda_backend_flags.basic_block_sections
     | "heap-reduction-threshold" -> set_int' Flambda_backend_flags.heap_reduction_threshold
-    | "zero-alloc-check" -> set' Flambda_backend_flags.zero_alloc_check
+    | "zero-alloc-check" -> set' Clflags.zero_alloc_check
     | "dump-checkmach" -> set' Flambda_backend_flags.dump_checkmach
     | "poll-insertion" -> set' Flambda_backend_flags.disable_poll_insertion
     | "long-frames" -> set' Flambda_backend_flags.allow_long_frames

driver/flambda_backend_flags.ml

@@ -28,7 +28,6 @@ let dasm_comments = ref false (* -dasm-comments *)
 
 let default_heap_reduction_threshold = 500_000_000 / (Sys.word_size / 8)
 let heap_reduction_threshold = ref default_heap_reduction_threshold (* -heap-reduction-threshold *)
-let zero_alloc_check = ref false        (* -zero-alloc-check *)
 let dump_checkmach = ref false          (* -dcheckmach *)
 
 let disable_poll_insertion = ref (not Config.poll_insertion)

driver/flambda_backend_flags.mli

@@ -29,7 +29,6 @@ val dasm_comments : bool ref
 
 val default_heap_reduction_threshold : int
 val heap_reduction_threshold : int ref
-val zero_alloc_check : bool ref
 val dump_checkmach : bool ref
 
 val disable_poll_insertion : bool ref

ocaml/parsing/builtin_attributes.ml

@@ -435,6 +435,14 @@ let parse_int_payload attr =
       "A constant payload of type int was expected";
     None
 
+let parse_ident_payload attr =
+  match ident_of_payload attr.attr_payload with
+  | Some i -> Some i
+  | None ->
+    warn_payload attr.attr_loc attr.attr_name.txt
+      "A constant payload of type ident was expected";
+    None
+
 let clflags_attribute_without_payload attr ~name clflags_ref =
   when_attribute_is [name; "ocaml." ^ name] attr ~f:(fun () ->
     match parse_empty_payload attr with
@@ -490,6 +498,20 @@ let inline_attribute attr =
         Clflags.Float_arg_helper.parse s err_msg Clflags.inline_threshold
       | None -> warn_payload attr.attr_loc attr.attr_name.txt err_msg)
 
+let parse_attribute_with_ident_payload attr ~name ~f =
+  when_attribute_is [name; "ocaml." ^ name] attr ~f:(fun () ->
+    match parse_ident_payload attr with
+    | Some i -> f i
+    | None -> ())
+
+let zero_alloc_attribute (attr : Parsetree.attribute)  =
+  parse_attribute_with_ident_payload attr
+    ~name:"zero_alloc" ~f:(function
+      | "check" -> Clflags.zero_alloc_check := true
+      | _ ->
+        warn_payload attr.attr_loc attr.attr_name.txt
+          "Only 'check' is supported")
+
 let afl_inst_ratio_attribute attr =
   clflags_attribute_with_int_payload attr
     ~name:"afl_inst_ratio" Clflags.afl_inst_ratio
@@ -508,7 +530,8 @@ let parse_standard_implementation_attributes attr =
   inline_attribute attr;
   afl_inst_ratio_attribute attr;
   flambda_o3_attribute attr;
-  flambda_oclassic_attribute attr
+  flambda_oclassic_attribute attr;
+  zero_alloc_attribute attr
 
 let has_local_opt attrs =
   has_attribute ["ocaml.local_opt"; "local_opt"] attrs

ocaml/stdlib/camlinternalAtomic.ml

@@ -14,6 +14,7 @@
 (**************************************************************************)
 
 [@@@ocaml.flambda_o3]
+[@@@ocaml.zero_alloc check]
 
 (* CamlinternalAtomic is a dependency of Stdlib, so it is compiled with
    -nopervasives. *)

ocaml/stdlib/camlinternalFormatBasics.ml

@@ -13,6 +13,7 @@
 (*   special exception on linking described in the file LICENSE.          *)
 (*                                                                        *)
 (**************************************************************************)
+[@@@ocaml.zero_alloc check]
 
 (* Padding position. *)
 type padty =

ocaml/stdlib/std_exit.ml

@@ -17,6 +17,7 @@
 open! Stdlib
 
 [@@@ocaml.flambda_o3]
+[@@@ocaml.zero_alloc check]
 
 (* Ensure that [at_exit] functions are called at the end of every program *)
 

ocaml/stdlib/stdlib.ml

@@ -16,6 +16,7 @@
 
 [@@@ocaml.warning "-49"]
 [@@@ocaml.flambda_o3]
+[@@@ocaml.zero_alloc check]
 
 (* Exceptions *)
 

ocaml/testsuite/tests/backtrace/pr2195-locs.byte.reference

@@ -1,4 +1,4 @@
 Fatal error: exception Stdlib.Exit
-Raised at Stdlib.open_in_gen in file "stdlib.ml", line 408, characters 28-54
+Raised at Stdlib.open_in_gen in file "stdlib.ml", line 409, characters 28-54
 Called from Pr2195 in file "pr2195.ml", line 24, characters 6-19
 Re-raised at Pr2195 in file "pr2195.ml", line 29, characters 4-41

ocaml/testsuite/tests/backtrace/pr2195.opt.reference

@@ -1,5 +1,5 @@
 Fatal error: exception Stdlib.Exit
-Raised at Stdlib.open_in_gen in file "stdlib.ml", line 408, characters 28-54
-Called from Stdlib.open_in in file "stdlib.ml", line 413, characters 2-45
+Raised at Stdlib.open_in_gen in file "stdlib.ml", line 409, characters 28-54
+Called from Stdlib.open_in in file "stdlib.ml", line 414, characters 2-45
 Called from Pr2195 in file "pr2195.ml", line 24, characters 6-19
 Re-raised at Pr2195 in file "pr2195.ml", line 29, characters 4-41

ocaml/testsuite/tests/lib-dynlink-initializers/test10_main.byte.reference

@@ -1,5 +1,5 @@
 Error: Failure("Plugin error")
-Raised at Stdlib.failwith in file "stdlib.ml", line 32, characters 17-33
+Raised at Stdlib.failwith in file "stdlib.ml", line 33, characters 17-33
 Called from Test10_plugin.g in file "test10_plugin.ml", line 3, characters 2-21
 Called from Test10_plugin.f in file "test10_plugin.ml", line 6, characters 2-6
 Called from Test10_plugin in file "test10_plugin.ml", line 10, characters 2-6

ocaml/testsuite/tests/lib-dynlink-initializers/test10_main.native.reference

@@ -1,5 +1,5 @@
 Error: Failure("Plugin error")
-Raised at Stdlib.failwith in file "stdlib.ml", line 32, characters 17-33
+Raised at Stdlib.failwith in file "stdlib.ml", line 33, characters 17-33
 Called from Test10_plugin.g in file "test10_plugin.ml" (inlined), line 2, characters 15-38
 Called from Test10_plugin.f in file "test10_plugin.ml", line 6, characters 2-6
 Called from Test10_plugin in file "test10_plugin.ml", line 10, characters 2-6

ocaml/utils/clflags.ml

@@ -632,3 +632,5 @@ let create_usage_msg program =
 
 let print_arguments program =
   Arg.usage !arg_spec (create_usage_msg program)
+
+let zero_alloc_check = ref false                   (* -zero-alloc-check *)

ocaml/utils/clflags.mli

@@ -283,3 +283,5 @@ val print_arguments : string -> unit
 
 (* [reset_arguments ()] clear all declared arguments *)
 val reset_arguments : unit -> unit
+
+val zero_alloc_check : bool ref