add attribute to produce a compiler error for polls

.depend

@@ -2818,13 +2818,17 @@ asmcomp/polling.cmo : \
     utils/numbers.cmi \
     utils/misc.cmi \
     asmcomp/mach.cmi \
+    parsing/location.cmi \
+    lambda/debuginfo.cmi \
     asmcomp/dataflow.cmi \
     asmcomp/cmm.cmi \
     asmcomp/polling.cmi
 asmcomp/polling.cmx : \
     utils/numbers.cmx \
     utils/misc.cmx \
     asmcomp/mach.cmx \
+    parsing/location.cmx \
+    lambda/debuginfo.cmx \
     asmcomp/dataflow.cmx \
     asmcomp/cmm.cmx \
     asmcomp/polling.cmi

Changes

@@ -3,6 +3,9 @@ Working version
 
 ### Language features:
 
+- #10462: Add attribute to produce a compiler error for polls.
+  (Sadiq Jaffer, review by ??)
+
 - #10437: Allow explicit binders for type variables.
   (Stephen Dolan, review by Leo White)
 

asmcomp/cmm.ml

@@ -203,6 +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_dbg : Debuginfo.t;
   }
 

asmcomp/cmm.mli

@@ -204,6 +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_dbg : Debuginfo.t;
   }
 

asmcomp/cmm_helpers.ml

@@ -1876,6 +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_dbg;
    }
 
@@ -1889,6 +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_dbg;
    }
 
@@ -1917,6 +1919,7 @@ let tuplify_function arity =
           :: access_components 0 @ [Cvar clos],
           (dbg ()));
     fun_codegen_options = [];
+    fun_poll_error = false;
     fun_dbg;
    }
 
@@ -1986,6 +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_dbg;
    }
 
@@ -2020,6 +2024,7 @@ let rec intermediate_curry_functions arity num =
                  Cvar arg; Cvar clos],
                 dbg ());
       fun_codegen_options = [];
+      fun_poll_error = false;
       fun_dbg;
      }
     ::
@@ -2059,6 +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_dbg;
               }
           in
@@ -2595,6 +2601,7 @@ let entry_point namelist =
              fun_args = [];
              fun_body = body;
              fun_codegen_options = [Reduce_code_size];
+             fun_poll_error = false;
              fun_dbg;
             }
 

asmcomp/cmmgen.ml

@@ -1375,6 +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_dbg  = f.dbg}
 
 (* Translate all function definitions *)
@@ -1476,6 +1477,7 @@ let compunit (ulam, preallocated_blocks, constants) =
                            No_CSE;
                          ]
                          else [ Reduce_code_size ];
+                       fun_poll_error = false;
                        fun_dbg  = Debuginfo.none }] in
   let c2 = transl_clambda_constants constants c1 in
   let c3 = transl_all_functions c2 in

asmcomp/mach.ml

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

asmcomp/mach.mli

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

asmcomp/polling.ml

@@ -18,13 +18,17 @@
 (**************************************************************************)
 
 open Mach
+open Format
 
 module Int = Numbers.Int
 module String = Misc.Stdlib.String
 
 let function_is_assumed_to_never_poll func =
   String.starts_with ~prefix:"caml_apply" func
   || String.starts_with ~prefix:"caml_send" func
+type error = Poll_error of Mach.instruction list
+
+exception Error of error
 
 (* Detection of recursive handlers that are not guaranteed to poll
    at every loop iteration. *)
@@ -184,7 +188,7 @@ let contains_polls = ref false
 
 let add_poll i =
   contains_polls := true;
-  Mach.instr_cons (Iop (Ipoll { return_label = None })) [||] [||] i
+  Mach.instr_cons_debug (Iop (Ipoll { return_label = None })) [||] [||] i.dbg i
 
 let instr_body handler_safe i =
   let add_unsafe_handler ube (k, _) =
@@ -240,12 +244,30 @@ let instr_body handler_safe i =
   in
   instr Int.Set.empty i
 
+let find_poll_alloc_or_calls instr =
+  let f_match i =
+      match i.desc with
+      | Iop(Ipoll _ | Ialloc _ | Icall_ind | Icall_imm _ |
+            Itailcall_ind | Itailcall_imm _ |
+            Iextcall { alloc = true }) -> true
+      | _ -> false in
+  let matches = ref [] in
+    Mach.instr_iter
+      (fun i -> if f_match i then matches := i :: !matches else ())
+      instr;
+  !matches
+
 let instrument_fundecl ~future_funcnames:_ (f : Mach.fundecl) : Mach.fundecl =
   if function_is_assumed_to_never_poll f.fun_name then f
   else begin
     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;
     let new_contains_calls = f.fun_contains_calls || !contains_polls in
     { f with fun_body = new_body; fun_contains_calls = new_contains_calls }
   end
@@ -256,3 +278,37 @@ let requires_prologue_poll ~future_funcnames ~fun_name i =
     match potentially_recursive_tailcall ~future_funcnames i with
     | Might_not_poll -> true
     | Always_polls -> false
+
+(* Error report *)
+
+let instr_type i =
+  match i.desc with
+  | Iop(Ipoll _) -> "inserted poll"
+  | Iop(Ialloc _) -> "allocation"
+  | Iop(Icall_ind | Icall_imm _ |
+        Itailcall_ind | Itailcall_imm _) -> "function call"
+  | Iop(Iextcall { alloc = true }) -> "alloc external call"
+  | _ -> assert(false) (* This should never happen *)
+
+let report_error ppf = function
+| Poll_error instrs ->
+   fprintf ppf
+     "Polling instructions in function annotated with [@poll error]\n";
+   List.iter (fun i ->
+    fprintf ppf "\t%s" (instr_type i);
+    begin match i.desc with
+    | Iop(Ipoll _) -> ()
+    | _ -> begin
+            fprintf ppf " at ";
+            Location.print_loc ppf (Debuginfo.to_location i.dbg)
+          end
+    end;
+    fprintf ppf "\n"
+   ) instrs
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )

asmcomp/reloadgen.ml

@@ -133,6 +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_contains_calls = f.fun_contains_calls;
     fun_num_stack_slots = Array.copy num_stack_slots;
    },

asmcomp/selectgen.ml

@@ -1192,6 +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_num_stack_slots = Array.make Proc.num_register_classes 0;
     fun_contains_calls = !contains_calls;
   }

asmcomp/spill.ml

@@ -412,6 +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_dbg  = f.fun_dbg;
     fun_num_stack_slots = f.fun_num_stack_slots;
     fun_contains_calls = f.fun_contains_calls;

asmcomp/split.ml

@@ -218,6 +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_dbg  = f.fun_dbg;
     fun_num_stack_slots = f.fun_num_stack_slots;
     fun_contains_calls = f.fun_contains_calls;

lambda/lambda.ml

@@ -247,6 +247,10 @@ type local_attribute =
   | Never_local (* [@local never] *)
   | Default_local (* [@local maybe] or no [@local] attribute *)
 
+type poll_attribute =
+  | Error_poll (* [@poll error] *)
+  | Default_poll (* no [@poll] attribute *)
+
 type function_kind = Curried | Tupled
 
 type let_kind = Strict | Alias | StrictOpt
@@ -266,6 +270,7 @@ type function_attribute = {
   inline : inline_attribute;
   specialise : specialise_attribute;
   local: local_attribute;
+  poll: poll_attribute;
   is_a_functor: bool;
   stub: bool;
 }
@@ -349,6 +354,7 @@ let default_function_attribute = {
   inline = Default_inline;
   specialise = Default_specialise;
   local = Default_local;
+  poll = Default_poll;
   is_a_functor = false;
   stub = false;
 }

lambda/lambda.mli

@@ -229,6 +229,10 @@ type local_attribute =
   | Never_local (* [@local never] *)
   | Default_local (* [@local maybe] or no [@local] attribute *)
 
+type poll_attribute =
+  | Error_poll (* [@poll error] *)
+  | Default_poll (* no [@poll] attribute *)
+
 type function_kind = Curried | Tupled
 
 type let_kind = Strict | Alias | StrictOpt
@@ -252,6 +256,7 @@ type function_attribute = {
   inline : inline_attribute;
   specialise : specialise_attribute;
   local: local_attribute;
+  poll: poll_attribute;
   is_a_functor: bool;
   stub: bool;
 }
@@ -309,6 +314,7 @@ and lambda_switch =
     sw_numblocks: int;                  (* Number of tag block cases *)
     sw_blocks: (int * lambda) list;     (* Tag block cases *)
     sw_failaction : lambda option}      (* Action to take if failure *)
+
 and lambda_event =
   { lev_loc: scoped_location;
     lev_kind: lambda_event_kind;

lambda/printlambda.ml

@@ -444,7 +444,8 @@ let name_of_primitive = function
   | Pint_as_pointer -> "Pint_as_pointer"
   | Popaque -> "Popaque"
 
-let function_attribute ppf { inline; specialise; local; is_a_functor; stub } =
+let function_attribute ppf
+  { inline; specialise; local; poll; is_a_functor; stub } =
   if is_a_functor then
     fprintf ppf "is_a_functor@ ";
   if stub then
@@ -465,6 +466,10 @@ let function_attribute ppf { inline; specialise; local; is_a_functor; stub } =
   | Default_local -> ()
   | Always_local -> fprintf ppf "always_local@ "
   | Never_local -> fprintf ppf "never_local@ "
+  end;
+  begin match poll with
+  | Default_poll -> ()
+  | Error_poll -> fprintf ppf "error_poll@ "
   end
 
 let apply_tailcall_attribute ppf = function