propogate poll_attribute to the backend instead of a boolean

asmcomp/cmm.ml

@@ -203,7 +203,7 @@ type fundecl =
     fun_args: (Backend_var.With_provenance.t * machtype) list;
     fun_body: expression;
     fun_codegen_options : codegen_option list;
-    fun_poll_error: bool;
+    fun_poll: Lambda.poll_attribute;
     fun_dbg : Debuginfo.t;
   }
 

asmcomp/cmm.mli

@@ -204,7 +204,7 @@ type fundecl =
     fun_args: (Backend_var.With_provenance.t * machtype) list;
     fun_body: expression;
     fun_codegen_options : codegen_option list;
-    fun_poll_error: bool;
+    fun_poll: Lambda.poll_attribute;
     fun_dbg : Debuginfo.t;
   }
 

asmcomp/cmm_helpers.ml

@@ -1876,7 +1876,7 @@ let send_function arity =
     fun_args = List.map (fun (arg, ty) -> VP.create arg, ty) fun_args;
     fun_body = body;
     fun_codegen_options = [];
-    fun_poll_error = false;
+    fun_poll = Default_poll;
     fun_dbg;
    }
 
@@ -1890,7 +1890,7 @@ let apply_function arity =
     fun_args = List.map (fun arg -> (VP.create arg, typ_val)) all_args;
     fun_body = body;
     fun_codegen_options = [];
-    fun_poll_error = false;
+    fun_poll = Default_poll;
     fun_dbg;
    }
 
@@ -1919,7 +1919,7 @@ let tuplify_function arity =
           :: access_components 0 @ [Cvar clos],
           (dbg ()));
     fun_codegen_options = [];
-    fun_poll_error = false;
+    fun_poll = Default_poll;
     fun_dbg;
    }
 
@@ -1989,7 +1989,7 @@ let final_curry_function arity =
     fun_args = [VP.create last_arg, typ_val; VP.create last_clos, typ_val];
     fun_body = curry_fun [] last_clos (arity-1);
     fun_codegen_options = [];
-    fun_poll_error = false;
+    fun_poll = Default_poll;
     fun_dbg;
    }
 
@@ -2024,7 +2024,7 @@ let rec intermediate_curry_functions arity num =
                  Cvar arg; Cvar clos],
                 dbg ());
       fun_codegen_options = [];
-      fun_poll_error = false;
+      fun_poll = Default_poll;
       fun_dbg;
      }
     ::
@@ -2064,7 +2064,7 @@ let rec intermediate_curry_functions arity num =
                fun_body = iter (num+1)
                   (List.map (fun (arg,_) -> Cvar arg) direct_args) clos;
                fun_codegen_options = [];
-               fun_poll_error = false;
+               fun_poll = Default_poll;
                fun_dbg;
               }
           in
@@ -2601,7 +2601,7 @@ let entry_point namelist =
              fun_args = [];
              fun_body = body;
              fun_codegen_options = [Reduce_code_size];
-             fun_poll_error = false;
+             fun_poll = Default_poll;
              fun_dbg;
             }
 

asmcomp/cmmgen.ml

@@ -1375,7 +1375,7 @@ let transl_function f =
              fun_args = List.map (fun (id, _) -> (id, typ_val)) f.params;
              fun_body = cmm_body;
              fun_codegen_options;
-             fun_poll_error = f.poll_error;
+             fun_poll = f.poll;
              fun_dbg  = f.dbg}
 
 (* Translate all function definitions *)
@@ -1477,7 +1477,7 @@ let compunit (ulam, preallocated_blocks, constants) =
                            No_CSE;
                          ]
                          else [ Reduce_code_size ];
-                       fun_poll_error = false;
+                       fun_poll = Default_poll;
                        fun_dbg  = Debuginfo.none }] in
   let c2 = transl_clambda_constants constants c1 in
   let c3 = transl_all_functions c2 in

asmcomp/mach.ml

@@ -88,7 +88,7 @@ type fundecl =
     fun_body: instruction;
     fun_codegen_options : Cmm.codegen_option list;
     fun_dbg : Debuginfo.t;
-    fun_poll_error: bool;
+    fun_poll: Lambda.poll_attribute;
     fun_num_stack_slots: int array;
     fun_contains_calls: bool;
   }

asmcomp/mach.mli

@@ -89,7 +89,7 @@ type fundecl =
     fun_body: instruction;
     fun_codegen_options : Cmm.codegen_option list;
     fun_dbg : Debuginfo.t;
-    fun_poll_error: bool;
+    fun_poll: Lambda.poll_attribute;
     fun_num_stack_slots: int array;
     fun_contains_calls: bool;
   }

asmcomp/polling.ml

@@ -263,11 +263,13 @@ let instrument_fundecl ~future_funcnames:_ (f : Mach.fundecl) : Mach.fundecl =
     let handler_needs_poll = polled_loops_analysis f.fun_body in
     contains_polls := false;
     let new_body = instr_body handler_needs_poll f.fun_body in
-    if f.fun_poll_error then begin
-      match find_poll_alloc_or_calls new_body with
-      | [] -> ()
-      | poll_error_instrs -> raise (Error(Poll_error poll_error_instrs))
-    end;
+    begin match f.fun_poll with
+    | Error_poll -> begin
+        match find_poll_alloc_or_calls new_body with
+        | [] -> ()
+        | poll_error_instrs -> raise (Error(Poll_error poll_error_instrs))
+      end
+    | _ -> () end;
     let new_contains_calls = f.fun_contains_calls || !contains_polls in
     { f with fun_body = new_body; fun_contains_calls = new_contains_calls }
   end

asmcomp/reloadgen.ml

@@ -133,7 +133,7 @@ method fundecl f num_stack_slots =
   ({fun_name = f.fun_name; fun_args = f.fun_args;
     fun_body = new_body; fun_codegen_options = f.fun_codegen_options;
     fun_dbg  = f.fun_dbg;
-    fun_poll_error = f.fun_poll_error;
+    fun_poll = f.fun_poll;
     fun_contains_calls = f.fun_contains_calls;
     fun_num_stack_slots = Array.copy num_stack_slots;
    },

asmcomp/selectgen.ml

@@ -1192,7 +1192,7 @@ method emit_fundecl ~future_funcnames f =
     fun_body = body_with_prologue;
     fun_codegen_options = f.Cmm.fun_codegen_options;
     fun_dbg  = f.Cmm.fun_dbg;
-    fun_poll_error = f.Cmm.fun_poll_error;
+    fun_poll = f.Cmm.fun_poll;
     fun_num_stack_slots = Array.make Proc.num_register_classes 0;
     fun_contains_calls = !contains_calls;
   }

asmcomp/spill.ml

@@ -412,7 +412,7 @@ let fundecl f =
     fun_args = f.fun_args;
     fun_body = new_body;
     fun_codegen_options = f.fun_codegen_options;
-    fun_poll_error = f.fun_poll_error;
+    fun_poll = f.fun_poll;
     fun_dbg  = f.fun_dbg;
     fun_num_stack_slots = f.fun_num_stack_slots;
     fun_contains_calls = f.fun_contains_calls;

asmcomp/split.ml

@@ -218,7 +218,7 @@ let fundecl f =
     fun_args = new_args;
     fun_body = new_body;
     fun_codegen_options = f.fun_codegen_options;
-    fun_poll_error = f.fun_poll_error;
+    fun_poll = f.fun_poll;
     fun_dbg  = f.fun_dbg;
     fun_num_stack_slots = f.fun_num_stack_slots;
     fun_contains_calls = f.fun_contains_calls;

middle_end/clambda.ml

@@ -82,7 +82,7 @@ and ufunction = {
   body   : ulambda;
   dbg    : Debuginfo.t;
   env    : Backend_var.t option;
-  poll_error: bool;
+  poll   : poll_attribute;
 }
 
 and ulambda_switch =
@@ -99,7 +99,7 @@ type function_description =
     mutable fun_closed: bool;           (* True if environment not used *)
     mutable fun_inline: (Backend_var.With_provenance.t list * ulambda) option;
     mutable fun_float_const_prop: bool; (* Can propagate FP consts *)
-    fun_poll_error: bool;               (* Error on poll/alloc/call *)
+    fun_poll: poll_attribute;               (* Error on poll/alloc/call *)
   }
 
 (* Approximation of values *)

middle_end/clambda.mli

@@ -93,7 +93,7 @@ and ufunction = {
   body   : ulambda;
   dbg    : Debuginfo.t;
   env    : Backend_var.t option;
-  poll_error: bool;
+  poll   : poll_attribute;
 }
 
 and ulambda_switch =
@@ -110,7 +110,7 @@ type function_description =
     mutable fun_closed: bool;           (* True if environment not used *)
     mutable fun_inline: (Backend_var.With_provenance.t list * ulambda) option;
     mutable fun_float_const_prop: bool; (* Can propagate FP consts *)
-    fun_poll_error: bool;               (* Error on poll/alloc/call *)
+    fun_poll: poll_attribute;           (* Behaviour for polls *)
   }
 
 (* Approximation of values *)

middle_end/closure/closure.ml

@@ -1236,16 +1236,13 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs =
           (id, Lfunction{kind; params; return; body; loc; attr}) ->
             let label = Compilenv.make_symbol (Some (V.unique_name id)) in
             let arity = List.length params in
-            let poll_error = match attr.poll with
-              | Error_poll -> true
-              | Default_poll -> false in
             let fundesc =
               {fun_label = label;
                fun_arity = (if kind = Tupled then -arity else arity);
                fun_closed = initially_closed;
                fun_inline = None;
                fun_float_const_prop = !Clflags.float_const_prop;
-               fun_poll_error = poll_error } in
+               fun_poll = attr.poll } in
             let dbg = Debuginfo.from_location loc in
             (id, params, return, body, fundesc, dbg)
         | (_, _) -> fatal_error "Closure.close_functions")
@@ -1297,7 +1294,7 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs =
         body   = ubody;
         dbg;
         env = Some env_param;
-        poll_error = fundesc.fun_poll_error
+        poll = fundesc.fun_poll
       }
     in
     (* give more chance of function with default parameters (i.e.

middle_end/flambda/augment_specialised_args.ml

@@ -537,7 +537,7 @@ module Make (T : S) = struct
         ~specialise:Default_specialise
         ~is_a_functor:false
         ~closure_origin:function_decl.closure_origin
-        ~poll_error:false (* don't propagate attribute to wrappers *)
+        ~poll:Default_poll (* don't propagate attribute to wrappers *)
     in
     new_fun_var, new_function_decl, rewritten_existing_specialised_args,
       benefit
@@ -626,7 +626,7 @@ module Make (T : S) = struct
           ~specialise:function_decl.specialise
           ~is_a_functor:function_decl.is_a_functor
           ~closure_origin
-          ~poll_error:function_decl.poll_error
+          ~poll:function_decl.poll
       in
       let funs, direct_call_surrogates =
         if for_one_function.make_direct_call_surrogates then

middle_end/flambda/closure_conversion.ml

@@ -101,7 +101,7 @@ let tupled_function_call_stub original_params unboxed_version ~closure_bound_var
     ~body ~stub:true ~dbg:Debuginfo.none ~inline:Default_inline
     ~specialise:Default_specialise ~is_a_functor:false
     ~closure_origin:(Closure_origin.create (Closure_id.wrap closure_bound_var))
-    ~poll_error:false (* don't propogate attribute to wrappers *)
+    ~poll:Default_poll (* don't propogate attribute to wrappers *)
 
 let register_const t (constant:Flambda.constant_defining_value) name
     : Flambda.constant_defining_value_block_field * Internal_variable_names.t =
@@ -592,17 +592,13 @@ and close_functions t external_env function_declarations : Flambda.named =
     let closure_origin =
       Closure_origin.create (Closure_id.wrap unboxed_version)
     in
-    let poll_error = match Function_decl.poll_attribute decl with
-                    | Error_poll -> true
-                    | Default_poll -> false
-    in
     let fun_decl =
       Flambda.create_function_declaration ~params ~body ~stub ~dbg
         ~inline:(Function_decl.inline decl)
         ~specialise:(Function_decl.specialise decl)
         ~is_a_functor:(Function_decl.is_a_functor decl)
         ~closure_origin
-        ~poll_error
+        ~poll:(Function_decl.poll_attribute decl)
     in
     match Function_decl.kind decl with
     | Curried -> Variable.Map.add closure_bound_var fun_decl map

middle_end/flambda/flambda.ml

@@ -127,7 +127,7 @@ and function_declaration = {
   inline : Lambda.inline_attribute;
   specialise : Lambda.specialise_attribute;
   is_a_functor : bool;
-  poll_error: bool;
+  poll: Lambda.poll_attribute;
 }
 
 and switch = {
@@ -1000,7 +1000,7 @@ let update_body_of_function_declaration (func_decl: function_declaration)
     inline = func_decl.inline;
     specialise = func_decl.specialise;
     is_a_functor = func_decl.is_a_functor;
-    poll_error = func_decl.poll_error;
+    poll = func_decl.poll;
   }
 
 let update_function_decl's_params_and_body
@@ -1015,14 +1015,14 @@ let update_function_decl's_params_and_body
     inline = func_decl.inline;
     specialise = func_decl.specialise;
     is_a_functor = func_decl.is_a_functor;
-    poll_error = func_decl.poll_error;
+    poll = func_decl.poll;
   }
 
 
 let create_function_declaration ~params ~body ~stub ~dbg
       ~(inline : Lambda.inline_attribute)
       ~(specialise : Lambda.specialise_attribute) ~is_a_functor
-      ~closure_origin ~poll_error
+      ~closure_origin ~poll
       : function_declaration =
   begin match stub, inline with
   | true, (Never_inline | Default_inline)
@@ -1052,7 +1052,7 @@ let create_function_declaration ~params ~body ~stub ~dbg
     inline;
     specialise;
     is_a_functor;
-    poll_error;
+    poll;
   }
 
 let update_function_declaration fun_decl ~params ~body =

middle_end/flambda/flambda.mli

@@ -325,8 +325,8 @@ and function_declaration = private {
   (** Specialising requirements from the source code. *)
   is_a_functor : bool;
   (** Whether the function is known definitively to be a functor. *)
-  poll_error: bool;
-  (** Whether polls in this function are an error *)
+  poll: Lambda.poll_attribute;
+  (** Behaviour for polls *)
 }
 
 (** Equivalent to the similar type in [Lambda]. *)
@@ -556,7 +556,7 @@ val create_function_declaration
   -> specialise:Lambda.specialise_attribute
   -> is_a_functor:bool
   -> closure_origin:Closure_origin.t
-  -> poll_error:bool
+  -> poll:Lambda.poll_attribute
   -> function_declaration
 
 (** Create a function declaration based on another function declaration *)

middle_end/flambda/flambda_to_clambda.ml

@@ -545,7 +545,7 @@ and to_clambda_set_of_closures t env
       body = to_clambda t env_body function_decl.body;
       dbg = function_decl.dbg;
       env = Some env_var;
-      poll_error = function_decl.poll_error;
+      poll = function_decl.poll;
     }
   in
   let funs = List.map to_clambda_function all_functions in
@@ -591,7 +591,7 @@ and to_clambda_closed_set_of_closures t env symbol
       body;
       dbg = function_decl.dbg;
       env = None;
-      poll_error = function_decl.poll_error;
+      poll = function_decl.poll;
     }
   in
   let ufunct = List.map to_clambda_function functions in

middle_end/flambda/flambda_utils.ml

@@ -350,10 +350,10 @@ let make_closure_declaration
       ~body ~stub ~dbg:Debuginfo.none ~inline:Default_inline
       ~specialise:Default_specialise ~is_a_functor:false
       ~closure_origin:(Closure_origin.create (Closure_id.wrap id))
-      ~poll_error:false
+      ~poll:Default_poll
   in
   begin
-    (* this is required because of poll_error *)
+    (* this is required because we hardcode poll behaviour above *)
     assert( stub );
     assert (Variable.Set.equal (Variable.Set.map subst free_variables)
     function_declaration.free_variables);

middle_end/flambda/freshening.ml

@@ -326,7 +326,7 @@ module Project_var = struct
             ~inline:func_decl.inline ~specialise:func_decl.specialise
             ~is_a_functor:func_decl.is_a_functor
             ~closure_origin:func_decl.closure_origin
-            ~poll_error:func_decl.poll_error
+            ~poll:func_decl.poll
         in
         function_decl, subst
       in