Add attributes "check noalloc" "check noalloc_exn" "check noeffects"

Propagate through Flambda to Cmm

Author: gretay-js

backend/cmmgen.ml

@@ -1460,6 +1460,12 @@ and transl_letrec env bindings cont =
         fill_blocks rem
   in init_blocks bsz
 
+let transl_attrib : Lambda.check_attribute -> Cmm.codegen_option list = function
+  | Noalloc_check -> [ Noalloc_check ]
+  | Noalloc_exn_check -> [ Noalloc_exn_check ]
+  | Noeffects_check -> [ Noeffect_check ]
+  | Default_check -> []
+
 (* Translate a function definition *)
 
 let transl_function f =
@@ -1471,6 +1477,7 @@ let transl_function f =
     else
       transl env body in
   let fun_codegen_options =
+    transl_attrib f.attrib @
     if !Clflags.optimize_for_speed then
       []
     else

middle_end/clambda.ml

@@ -100,6 +100,7 @@ and ufunction = {
   dbg    : Debuginfo.t;
   env    : Backend_var.t option;
   mode   : Lambda.alloc_mode;
+  attrib : Lambda.check_attribute;
 }
 
 and ulambda_switch =

middle_end/clambda.mli

@@ -111,6 +111,7 @@ and ufunction = {
   dbg    : Debuginfo.t;
   env    : Backend_var.t option;
   mode   : Lambda.alloc_mode;
+  attrib : Lambda.check_attribute;
 }
 
 and ulambda_switch =

middle_end/closure/closure.ml

@@ -1394,9 +1394,10 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs =
   let uncurried_defs =
     List.map
       (function
-          (id, Lfunction({kind; params; return; body; loc; mode; region}
+          (id, Lfunction({kind; params; return; body; attr; loc; mode; region}
                          as funct)) ->
             Lambda.check_lfunction funct;
+            let attrib = attr.check in
             let label = Compilenv.make_fun_symbol loc (V.unique_name id) in
             let arity = List.length params in
             let fundesc =
@@ -1407,20 +1408,20 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs =
                fun_float_const_prop = !Clflags.float_const_prop;
                fun_region = region} in
             let dbg = Debuginfo.from_location loc in
-            (id, params, return, body, mode, fundesc, dbg)
+            (id, params, return, body, mode, attrib, fundesc, dbg)
         | (_, _) -> fatal_error "Closure.close_functions")
       fun_defs in
   (* Build an approximate fenv for compiling the functions *)
   let fenv_rec =
     List.fold_right
-      (fun (id, _params, _return, _body, mode, fundesc, _dbg) fenv ->
+      (fun (id, _params, _return, _body, mode, _attrib, fundesc, _dbg) fenv ->
         V.Map.add id (Value_closure(mode, fundesc, Value_unknown)) fenv)
       uncurried_defs fenv in
   (* Determine the offsets of each function's closure in the shared block *)
   let env_pos = ref (-1) in
   let clos_offsets =
     List.map
-      (fun (_id, _params, _return, _body, _mode, fundesc, _dbg) ->
+      (fun (_id, _params, _return, _body, _mode, _attrib, fundesc, _dbg) ->
         let pos = !env_pos + 1 in
         env_pos := !env_pos + 1 +
           (match fundesc.fun_arity with (Curried _, (0|1)) -> 2 | _ -> 3);
@@ -1431,13 +1432,13 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs =
      does not use its environment parameter is invalidated. *)
   let useless_env = ref initially_closed in
   (* Translate each function definition *)
-  let clos_fundef (id, params, return, body, mode, fundesc, dbg) env_pos =
+  let clos_fundef (id, params, return, body, mode, attrib, fundesc, dbg) env_pos =
     let env_param = V.create_local "env" in
     let cenv_fv =
       build_closure_env env_param (fv_pos - env_pos) fv in
     let cenv_body =
       List.fold_right2
-        (fun (id, _params, _return, _body, _mode, _fundesc, _dbg) pos env ->
+        (fun (id, _params, _return, _body, _mode, _attrib, _fundesc, _dbg) pos env ->
           V.Map.add id (Uoffset(Uvar env_param, pos - env_pos)) env)
         uncurried_defs clos_offsets cenv_fv in
     let (ubody, approx) =
@@ -1459,6 +1460,7 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs =
         dbg;
         env = Some env_param;
         mode;
+        attrib;
       }
     in
     (* give more chance of function with default parameters (i.e.
@@ -1497,7 +1499,7 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs =
          recompile *)
         Compilenv.backtrack snap; (* PR#6337 *)
         List.iter
-          (fun (_id, _params, _return, _body, _mode, fundesc, _dbg) ->
+          (fun (_id, _params, _return, _body, _mode, _attrib, fundesc, _dbg) ->
              fundesc.fun_closed <- false;
              fundesc.fun_inline <- None;
           )

middle_end/flambda/augment_specialised_args.ml

@@ -546,6 +546,7 @@ module Make (T : S) = struct
         ~stub:true
         ~inline:Default_inline
         ~specialise:Default_specialise
+        ~check:Default_check
         ~is_a_functor:false
         ~closure_origin:function_decl.closure_origin
     in
@@ -639,6 +640,7 @@ module Make (T : S) = struct
           ~stub:function_decl.stub
           ~inline:function_decl.inline
           ~specialise:function_decl.specialise
+          ~check:function_decl.check
           ~is_a_functor:function_decl.is_a_functor
           ~closure_origin
       in

middle_end/flambda/closure_conversion.ml

@@ -107,7 +107,7 @@ let tupled_function_call_stub original_params unboxed_version ~closure_bound_var
   let tuple_param = Parameter.wrap tuple_param_var alloc_mode in
   Flambda.create_function_declaration ~params:[tuple_param] ~alloc_mode ~region
     ~body ~stub:true ~inline:Default_inline
-    ~specialise:Default_specialise ~is_a_functor:false
+    ~specialise:Default_specialise ~check:Default_check ~is_a_functor:false
     ~closure_origin:(Closure_origin.create (Closure_id.wrap closure_bound_var))
 
 let register_const t (constant:Flambda.constant_defining_value) name
@@ -650,6 +650,7 @@ and close_functions t external_env function_declarations : Flambda.named =
         ~body ~stub
         ~inline:(Function_decl.inline decl)
         ~specialise:(Function_decl.specialise decl)
+        ~check:(Function_decl.check decl)
         ~is_a_functor:(Function_decl.is_a_functor decl)
         ~closure_origin
     in

middle_end/flambda/closure_conversion_aux.ml

@@ -125,6 +125,7 @@ module Function_decls = struct
     let free_idents t = t.free_idents_of_body
     let inline t = t.attr.inline
     let specialise t = t.attr.specialise
+    let check t = t.attr.check
     let is_a_functor t = t.attr.is_a_functor
     let stub t = t.attr.stub
     let loc t = t.loc

middle_end/flambda/closure_conversion_aux.mli

@@ -73,6 +73,7 @@ module Function_decls : sig
     val body : t -> Lambda.lambda
     val inline : t -> Lambda.inline_attribute
     val specialise : t -> Lambda.specialise_attribute
+    val check : t -> Lambda.check_attribute
     val is_a_functor : t -> bool
     val stub : t -> bool
     val loc : t -> Lambda.scoped_location

middle_end/flambda/export_info_for_pack.ml

@@ -146,6 +146,7 @@ and import_function_declarations_for_pack_aux units pack
           ~stub:function_decl.stub
           ~inline:function_decl.inline
           ~specialise:function_decl.specialise
+          ~check:function_decl.check
           ~is_a_functor:function_decl.is_a_functor
           ~closure_origin:function_decl.closure_origin)
       function_decls.funs

middle_end/flambda/flambda.ml

@@ -137,6 +137,7 @@ and function_declaration = {
   dbg : Debuginfo.t;
   inline : Lambda.inline_attribute;
   specialise : Lambda.specialise_attribute;
+  check : Lambda.check_attribute;
   is_a_functor : bool;
 }
 
@@ -406,8 +407,15 @@ and print_function_declaration ppf var (f : function_declaration) =
     | Never_specialise -> " *never_specialise*"
     | Default_specialise -> ""
   in
-  fprintf ppf "@[<2>(%a%s%s%s%s@ =@ fun@[<2>%a@] ->@ @[<2>%a@])@]@ "
-    Variable.print var stub is_a_functor inline specialise
+  let check =
+    match f.check with
+    | Noalloc_check -> " *noalloc_check*"
+    | Noalloc_exn_check -> " *noalloc_exn_check*"
+    | Noeffects_check -> " *noeffects_check*"
+    | Default_check -> ""
+  in
+  fprintf ppf "@[<2>(%a%s%s%s%s%s@ =@ fun@[<2>%a@] ->@ @[<2>%a@])@]@ "
+    Variable.print var stub is_a_functor inline specialise check
     params f.params lam f.body
 
 and print_set_of_closures ppf (set_of_closures : set_of_closures) =
@@ -1042,6 +1050,7 @@ let update_body_of_function_declaration (func_decl: function_declaration)
     stub = func_decl.stub;
     dbg = func_decl.dbg;
     inline = func_decl.inline;
+    check = func_decl.check;
     specialise = func_decl.specialise;
     is_a_functor = func_decl.is_a_functor;
   }
@@ -1056,7 +1065,9 @@ let rec check_param_modes mode = function
 
 let create_function_declaration ~params ~alloc_mode ~region ~body ~stub
       ~(inline : Lambda.inline_attribute)
-      ~(specialise : Lambda.specialise_attribute) ~is_a_functor
+      ~(specialise : Lambda.specialise_attribute)
+      ~(check : Lambda.check_attribute)
+      ~is_a_functor
       ~closure_origin
       : function_declaration =
   begin match stub, inline with
@@ -1090,6 +1101,7 @@ let create_function_declaration ~params ~alloc_mode ~region ~body ~stub
     dbg = dbg_origin;
     inline;
     specialise;
+    check;
     is_a_functor;
   }
 

middle_end/flambda/flambda.mli

@@ -336,6 +336,8 @@ and function_declaration = private {
   (** Inlining requirements from the source code. *)
   specialise : Lambda.specialise_attribute;
   (** Specialising requirements from the source code. *)
+  check : Lambda.check_attribute;
+  (** Check function properties requirements from the source code  *)
   is_a_functor : bool;
   (** Whether the function is known definitively to be a functor. *)
 }
@@ -567,6 +569,7 @@ val create_function_declaration
   -> stub:bool
   -> inline:Lambda.inline_attribute
   -> specialise:Lambda.specialise_attribute
+  -> check:Lambda.check_attribute
   -> is_a_functor:bool
   -> closure_origin:Closure_origin.t
   -> function_declaration

middle_end/flambda/flambda_to_clambda.ml

@@ -578,6 +578,7 @@ and to_clambda_set_of_closures t env
       dbg = function_decl.dbg;
       env = Some env_var;
       mode = set_of_closures.alloc_mode;
+      attrib = function_decl.check;
     }
   in
   let funs = List.map to_clambda_function all_functions in
@@ -627,6 +628,7 @@ and to_clambda_closed_set_of_closures t env symbol
       dbg = function_decl.dbg;
       env = None;
       mode = Lambda.alloc_heap;
+      attrib = function_decl.check;
     }
   in
   let ufunct = List.map to_clambda_function functions in

middle_end/flambda/flambda_utils.ml

@@ -364,7 +364,7 @@ let make_closure_declaration
     Flambda.create_function_declaration
       ~params:(List.map subst_param params) ~alloc_mode  ~region
       ~body ~stub ~inline:Default_inline
-      ~specialise:Default_specialise ~is_a_functor:false
+      ~specialise:Default_specialise ~check:Default_check ~is_a_functor:false
       ~closure_origin:(Closure_origin.create (Closure_id.wrap id))
   in
   assert (Variable.Set.equal (Variable.Set.map subst free_variables)

middle_end/flambda/freshening.ml

@@ -326,6 +326,7 @@ module Project_var = struct
             ~body
             ~stub:func_decl.stub
             ~inline:func_decl.inline ~specialise:func_decl.specialise
+            ~check:func_decl.check
             ~is_a_functor:func_decl.is_a_functor
             ~closure_origin:func_decl.closure_origin
         in

middle_end/flambda/inline_and_simplify.ml

@@ -615,6 +615,7 @@ and simplify_set_of_closures original_env r
         ~alloc_mode:function_decl.alloc_mode ~region:function_decl.region
         ~body ~stub:function_decl.stub
         ~inline:function_decl.inline ~specialise:function_decl.specialise
+        ~check:function_decl.check
         ~is_a_functor:function_decl.is_a_functor
         ~closure_origin:function_decl.closure_origin
     in
@@ -1500,6 +1501,7 @@ and duplicate_function ~env ~(set_of_closures : Flambda.set_of_closures)
       ~alloc_mode:function_decl.alloc_mode ~region:function_decl.region
       ~body ~stub:function_decl.stub
       ~inline:function_decl.inline ~specialise:function_decl.specialise
+      ~check:function_decl.check
       ~is_a_functor:function_decl.is_a_functor
       ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var))
   in

middle_end/flambda/inlining_transforms.ml

@@ -543,6 +543,7 @@ let rewrite_function ~lhs_of_application ~closure_id_being_applied
       ~stub:function_body.stub
       ~inline:function_body.inline
       ~specialise:function_body.specialise
+      ~check:function_body.check
       ~is_a_functor:function_body.is_a_functor
       ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var))
   in

middle_end/flambda/remove_unused_arguments.ml

@@ -43,7 +43,8 @@ let remove_params unused (fun_decl: Flambda.function_declaration)
     ~params:used_params ~alloc_mode:fun_decl.alloc_mode ~region:fun_decl.region
     ~body
     ~stub:fun_decl.stub ~inline:fun_decl.inline
-    ~specialise:fun_decl.specialise ~is_a_functor:fun_decl.is_a_functor
+    ~specialise:fun_decl.specialise ~check:fun_decl.check
+    ~is_a_functor:fun_decl.is_a_functor
     ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var))
 
 let make_stub unused var (fun_decl : Flambda.function_declaration)
@@ -107,7 +108,9 @@ let make_stub unused var (fun_decl : Flambda.function_declaration)
       ~alloc_mode:fun_decl.alloc_mode ~region:fun_decl.region
       ~body
       ~stub:true ~inline:Default_inline
-      ~specialise:Default_specialise ~is_a_functor:fun_decl.is_a_functor
+      ~specialise:Default_specialise
+      ~check:Default_check
+      ~is_a_functor:fun_decl.is_a_functor
       ~closure_origin:fun_decl.closure_origin
   in
   function_decl, renamed, additional_specialised_args

middle_end/flambda/simple_value_approx.ml

@@ -80,6 +80,7 @@ and function_body = {
   dbg : Debuginfo.t;
   inline : Lambda.inline_attribute;
   specialise : Lambda.specialise_attribute;
+  check : Lambda.check_attribute;
   is_a_functor : bool;
   body : Flambda.t;
 }
@@ -944,6 +945,7 @@ let function_declaration_approx ~keep_body fun_var
              inline = fun_decl.inline;
              dbg = fun_decl.dbg;
              specialise = fun_decl.specialise;
+             check = fun_decl.check;
              is_a_functor = fun_decl.is_a_functor;
              free_variables = fun_decl.free_variables;
              free_symbols = fun_decl.free_symbols; }

middle_end/flambda/simple_value_approx.mli

@@ -156,6 +156,7 @@ and function_body = private {
   dbg : Debuginfo.t;
   inline : Lambda.inline_attribute;
   specialise : Lambda.specialise_attribute;
+  check : Lambda.check_attribute;
   is_a_functor : bool;
   body : Flambda.t;
 }

middle_end/flambda/un_anf.ml

@@ -147,7 +147,8 @@ let make_var_info (clam : Clambda.ulambda) : var_info =
     | Uclosure (functions, captured_variables) ->
       List.iter (loop ~depth) captured_variables;
       List.iter (fun (
-        { Clambda. label; arity=_; params; return; body; dbg; env; mode=_} as clos) ->
+        { Clambda. label; arity=_; params; return; body; dbg; env; mode=_;
+            attrib=_} as clos) ->
           (match closure_environment_var clos with
            | None -> ()
            | Some env_var ->
@@ -323,7 +324,8 @@ let let_bound_vars_that_can_be_moved var_info (clam : Clambda.ulambda) =
     | Uclosure (functions, captured_variables) ->
       ignore_ulambda_list captured_variables;
       (* Start a new let stack for speed. *)
-      List.iter (fun {Clambda. label; arity=_; params; return; body; dbg; env; mode=_} ->
+      List.iter (fun {Clambda. label; arity=_; params; return; body; dbg; env; mode=_;
+                      attrib=_} ->
           ignore_function_label label;
           ignore_params_with_value_kind params;
           ignore_value_kind return;

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -1565,6 +1565,7 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply)
       { inline = Default_inline;
         specialise = Default_specialise;
         local = Default_local;
+        check = Default_check;
         is_a_functor = false;
         stub = false
       }

middle_end/printclambda.ml

@@ -52,6 +52,12 @@ let rec value_kind0 ppf kind =
 
 let value_kind kind = Format.asprintf "%a" value_kind0 kind
 
+let check : Lambda.check_attribute -> string = function
+  | Default_check -> ""
+  | Noalloc_check -> " noalloc_check"
+  | Noalloc_exn_check -> " noalloc_exn_check"
+  | Noeffects_check -> " noeffects_check"
+
 let rec structured_constant ppf = function
   | Uconst_float x -> fprintf ppf "%F" x
   | Uconst_int32 x -> fprintf ppf "%ldl" x
@@ -84,8 +90,8 @@ and one_fun ppf f =
            Printlambda.value_kind k
       )
   in
-  fprintf ppf "(fun@ %s%s@ %d@ @[<2>%a@]@ @[<2>%a@])"
-    f.label (value_kind f.return) (snd f.arity) idents f.params lam f.body
+  fprintf ppf "(fun@ %s%s%s@ %d@ @[<2>%a@]@ @[<2>%a@])"
+    f.label (value_kind f.return) (check f.attrib) (snd f.arity) idents f.params lam f.body
 
 and phantom_defining_expr ppf = function
   | Uphantom_const const -> uconstant ppf const

ocaml/lambda/lambda.ml

@@ -527,6 +527,7 @@ let default_function_attribute = {
   inline = Default_inline;
   specialise = Default_specialise;
   local = Default_local;
+  check = Default_check ;
   is_a_functor = false;
   stub = false;
 }