flambda-backend: Zero alloc: refactor to remove "property" and improv…

…e naming (#2416) * Remove "Lambda.property" and rename "Lambda.check_attribute" and propagate this name down to Cmm. * Rename files checkmach.ml to zero_alloc_checker.ml check_attribute.ml to zero_alloc_attribute.ml * Rename compilation flags "checkmach" to "zero-alloc-checker" * Update autogenerated dune.inc file * Refactoring: simplify zero_alloc_checker by removing unused functor * Format * Update depend * Fix upstream testsuite * Lots of fixes after rebase (makes separate commits useless) too much diff to fix up in the right commit * Regenerate dune.inc * Fix chamelon build * Rename [check] labelled arguments to [zero_alloc_attribute] * fix up [dune] to list more things alphabetically * Fix assorted typos and improve printing * Format * Remove unused copy of is_check_enabled
ocaml-flambda · May 13, 2024 · bc85611 · bc85611
1 parent d59441e
commit bc85611
Show file tree

Hide file tree

Showing 26 changed files with 155 additions and 189 deletions.
diff --git a/.depend b/.depend
@@ -293,8 +293,10 @@ utils/zero_alloc_annotations.cmx : \
     utils/zero_alloc_annotations.cmi
 utils/zero_alloc_annotations.cmi :
 utils/zero_alloc_utils.cmo : \
+    utils/clflags.cmi \
     utils/zero_alloc_utils.cmi
 utils/zero_alloc_utils.cmx : \
+    utils/clflags.cmx \
     utils/zero_alloc_utils.cmi
 utils/zero_alloc_utils.cmi :
 parsing/ast_helper.cmo : \
@@ -4321,6 +4323,7 @@ lambda/transl_list_comprehension.cmi : \
     typing/jkind.cmi \
     lambda/debuginfo.cmi
 lambda/translattribute.cmo : \
+    utils/zero_alloc_utils.cmi \
     utils/warnings.cmi \
     typing/typedtree.cmi \
     parsing/parsetree.cmi \
@@ -4330,6 +4333,7 @@ lambda/translattribute.cmo : \
     parsing/builtin_attributes.cmi \
     lambda/translattribute.cmi
 lambda/translattribute.cmx : \
+    utils/zero_alloc_utils.cmx \
     utils/warnings.cmx \
     typing/typedtree.cmx \
     parsing/parsetree.cmi \

diff --git a/driver/compile_common.ml b/driver/compile_common.ml
@@ -143,6 +143,6 @@ let implementation ~hook_parse_tree ~hook_typed_tree info ~backend =
       end;
     end;
     if not (Clflags.(should_stop_after Compiler_pass.Selection)) then
-      Builtin_attributes.warn_unchecked_property ();
+      Builtin_attributes.warn_unchecked_zero_alloc_attribute ();
     Warnings.check_fatal ();
   )
diff --git a/lambda/lambda.ml b/lambda/lambda.ml
@@ -621,24 +621,19 @@ type local_attribute =
   | Never_local (* [@local never] *)
   | Default_local (* [@local maybe] or no [@local] attribute *)
 
-type property = Builtin_attributes.property =
-  | Zero_alloc
-
 type poll_attribute =
   | Error_poll (* [@poll error] *)
   | Default_poll (* no [@poll] attribute *)
 
-type check_attribute = Builtin_attributes.check_attribute =
-  | Default_check
-  | Ignore_assert_all of property
-  | Check of { property: property;
-               strict: bool;
+type zero_alloc_attribute = Builtin_attributes.zero_alloc_attribute =
+  | Default_zero_alloc
+  | Ignore_assert_all
+  | Check of { strict: bool;
                opt: bool;
                arity: int;
                loc: Location.t;
              }
-  | Assume of { property: property;
-                strict: bool;
+  | Assume of { strict: bool;
                 never_returns_normally: bool;
                 never_raises: bool;
                 arity: int;
@@ -673,7 +668,7 @@ type function_attribute = {
   inline : inline_attribute;
   specialise : specialise_attribute;
   local: local_attribute;
-  check : check_attribute;
+  zero_alloc : zero_alloc_attribute;
   poll: poll_attribute;
   loop: loop_attribute;
   is_a_functor: bool;
@@ -896,7 +891,7 @@ let default_function_attribute = {
   inline = Default_inline;
   specialise = Default_specialise;
   local = Default_local;
-  check = Default_check ;
+  zero_alloc = Default_zero_alloc ;
   poll = Default_poll;
   loop = Default_loop;
   is_a_functor = false;
@@ -915,7 +910,7 @@ let default_function_attribute = {
 }
 
 let default_stub_attribute =
-  { default_function_attribute with stub = true; check = Ignore_assert_all Zero_alloc }
+  { default_function_attribute with stub = true; zero_alloc = Ignore_assert_all }
 
 let default_param_attribute = { unbox_param = false }
 

diff --git a/lambda/lambda.mli b/lambda/lambda.mli
@@ -497,18 +497,14 @@ type local_attribute =
   | Never_local (* [@local never] *)
   | Default_local (* [@local maybe] or no [@local] attribute *)
 
-type property = Builtin_attributes.property =
-  | Zero_alloc
-
 type poll_attribute =
   | Error_poll (* [@poll error] *)
   | Default_poll (* no [@poll] attribute *)
 
-type check_attribute = Builtin_attributes.check_attribute =
-  | Default_check
-  | Ignore_assert_all of property
-  | Check of { property: property;
-               strict: bool;
+type zero_alloc_attribute = Builtin_attributes.zero_alloc_attribute =
+  | Default_zero_alloc
+  | Ignore_assert_all
+  | Check of { strict: bool;
                (* [strict=true] property holds on all paths.
                   [strict=false] if the function returns normally,
                   then the property holds (but property violations on
@@ -518,8 +514,7 @@ type check_attribute = Builtin_attributes.check_attribute =
                arity: int;
                loc: Location.t;
              }
-  | Assume of { property: property;
-                strict: bool;
+  | Assume of { strict: bool;
                 never_returns_normally: bool;
                 never_raises: bool;
                 arity: int;
@@ -561,7 +556,7 @@ type function_attribute = {
   inline : inline_attribute;
   specialise : specialise_attribute;
   local: local_attribute;
-  check : check_attribute;
+  zero_alloc : zero_alloc_attribute;
   poll: poll_attribute;
   loop: loop_attribute;
   is_a_functor: bool;

diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml
@@ -934,22 +934,18 @@ let name_of_primitive = function
   | Parray_to_iarray -> "Parray_to_iarray"
   | Pget_header _ -> "Pget_header"
 
-let check_attribute ppf check =
-  let check_property = function
-    | Zero_alloc -> "zero_alloc"
-  in
+let zero_alloc_attribute ppf check =
   match check with
-  | Default_check -> ()
-  | Ignore_assert_all p ->
-    fprintf ppf "ignore assert all %s@ " (check_property p)
-  | Assume {property=p; strict; never_returns_normally; loc = _} ->
-    fprintf ppf "assume_%s%s%s@ "
-      (check_property p)
+  | Default_zero_alloc -> ()
+  | Ignore_assert_all ->
+    fprintf ppf "ignore assert all zero_alloc@ "
+  | Assume {strict; never_returns_normally; loc = _} ->
+    fprintf ppf "assume_zero_alloc%s%s@ "
       (if strict then "_strict" else "")
       (if never_returns_normally then "_never_returns_normally" else "")
-  | Check {property=p; strict; loc = _; opt} ->
-    fprintf ppf "assert_%s%s%s@ "
-      (check_property p) (if opt then "_opt" else "")
+  | Check {strict; loc = _; opt} ->
+    fprintf ppf "assert_zero_alloc%s%s@ "
+      (if opt then "_opt" else "")
       (if strict then "_strict" else "")
 
 let function_attribute ppf t =
@@ -974,7 +970,7 @@ let function_attribute ppf t =
   | Always_local -> fprintf ppf "always_local@ "
   | Never_local -> fprintf ppf "never_local@ "
   end;
-  check_attribute ppf t.check;
+  zero_alloc_attribute ppf t.zero_alloc;
   if t.tmc_candidate then
     fprintf ppf "tail_mod_cons@ ";
   begin match t.loop with

diff --git a/lambda/printlambda.mli b/lambda/printlambda.mli
@@ -40,7 +40,7 @@ val record_rep : formatter -> Types.record_representation -> unit
 val print_bigarray :
   string -> bool -> Lambda.bigarray_kind -> formatter ->
   Lambda.bigarray_layout -> unit
-val check_attribute : formatter -> check_attribute -> unit
+val zero_alloc_attribute : formatter -> zero_alloc_attribute -> unit
 val alloc_mode : formatter -> alloc_mode -> unit
 val array_kind : array_kind -> string
 

diff --git a/lambda/simplif.ml b/lambda/simplif.ml
@@ -877,7 +877,7 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body
     | _ -> assert orig_region
     end;
     let body, inner = aux [] false body in
-    let attr = { default_stub_attribute with check = attr.check } in
+    let attr = { default_stub_attribute with zero_alloc = attr.zero_alloc } in
     [{ id = fun_id;
        def = lfunction' ~kind ~params ~return ~body ~attr ~loc
            ~mode ~ret_mode ~region:true };

diff --git a/lambda/translattribute.ml b/lambda/translattribute.ml
@@ -195,7 +195,6 @@ let get_opaque_attribute l =
   let attr = find_attribute is_opaque_attribute l in
   parse_opaque_attribute attr
 
-
 let get_poll_attribute l =
   let attr = find_attribute is_poll_attribute l in
   parse_poll_attribute attr

diff --git a/lambda/translcore.ml b/lambda/translcore.ml
@@ -1030,7 +1030,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
         { inline = Never_inline;
           specialise = Always_specialise;
           local = Never_local;
-          check = Default_check;
+          zero_alloc = Default_zero_alloc;
           loop = Never_loop;
           is_a_functor = false;
           is_opaque = false;
@@ -1603,7 +1603,7 @@ and transl_function ~in_new_scope ~scopes e params body
            ~scopes e.exp_loc repr ~region params body)
   in
   let attr =
-    { function_attribute_disallowing_arity_fusion with check = zero_alloc }
+    { function_attribute_disallowing_arity_fusion with zero_alloc }
   in
   let loc = of_location ~scopes e.exp_loc in
   let body = if region then maybe_region_layout return body else body in

diff --git a/lambda/translmod.ml b/lambda/translmod.ml
@@ -162,7 +162,7 @@ and apply_coercion_result loc strict funct params args cc_res =
              ~return:Lambda.layout_module
              ~attr:{ default_function_attribute with
                         is_a_functor = true;
-                        check = Ignore_assert_all Zero_alloc;
+                        zero_alloc = Ignore_assert_all;
                         stub = true; }
              ~loc
              ~mode:alloc_heap
@@ -572,7 +572,7 @@ let rec compile_functor ~scopes mexp coercion root_path loc =
       loop = Never_loop;
       is_a_functor = true;
       is_opaque = false;
-      check = Ignore_assert_all Zero_alloc;
+      zero_alloc = Ignore_assert_all;
       stub = false;
       tmc_candidate = false;
       may_fuse_arity = true;