Add [@poll error] attribute

.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

@@ -28,6 +28,10 @@ OCaml 4.14.0
 
 ### Language features:
 
+- #10462: Add attribute to produce a compiler error for polls.
+  (Sadiq Jaffer, review by Mark Shinwell, Stephen Dolan
+   and Guillaume Munch-Maccagnoni)
+
 - #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: Lambda.poll_attribute;
     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: Lambda.poll_attribute;
     fun_dbg : Debuginfo.t;
   }
 

asmcomp/cmm_helpers.ml

@@ -1877,6 +1877,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 = Default_poll;
     fun_dbg;
    }
 
@@ -1890,6 +1891,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 = Default_poll;
     fun_dbg;
    }
 
@@ -1918,6 +1920,7 @@ let tuplify_function arity =
           :: access_components 0 @ [Cvar clos],
           (dbg ()));
     fun_codegen_options = [];
+    fun_poll = Default_poll;
     fun_dbg;
    }
 
@@ -1987,6 +1990,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 = Default_poll;
     fun_dbg;
    }
 
@@ -2021,6 +2025,7 @@ let rec intermediate_curry_functions arity num =
                  Cvar arg; Cvar clos],
                 dbg ());
       fun_codegen_options = [];
+      fun_poll = Default_poll;
       fun_dbg;
      }
     ::
@@ -2060,6 +2065,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 = Default_poll;
                fun_dbg;
               }
           in
@@ -2596,6 +2602,7 @@ let entry_point namelist =
              fun_args = [];
              fun_body = body;
              fun_codegen_options = [Reduce_code_size];
+             fun_poll = Default_poll;
              fun_dbg;
             }
 

asmcomp/cmmgen.ml

@@ -1383,6 +1383,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 = f.poll;
              fun_dbg  = f.dbg}
 
 (* Translate all function definitions *)
@@ -1484,6 +1485,7 @@ let compunit (ulam, preallocated_blocks, constants) =
                            No_CSE;
                          ]
                          else [ Reduce_code_size ];
+                       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,6 +88,7 @@ type fundecl =
     fun_body: instruction;
     fun_codegen_options : Cmm.codegen_option list;
     fun_dbg : Debuginfo.t;
+    fun_poll: Lambda.poll_attribute;
     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: Lambda.poll_attribute;
     fun_num_stack_slots: int array;
     fun_contains_calls: bool;
   }

asmcomp/polling.ml

@@ -18,6 +18,7 @@
 (**************************************************************************)
 
 open Mach
+open Format
 
 module Int = Numbers.Int
 module String = Misc.Stdlib.String
@@ -26,6 +27,12 @@ let function_is_assumed_to_never_poll func =
   String.starts_with ~prefix:"caml_apply" func
   || String.starts_with ~prefix:"caml_send" func
 
+(* These are used for the poll error annotation later on*)
+type polling_point = Alloc | Poll | Function_call | External_call
+type error = Poll_error of (polling_point * Debuginfo.t) list
+
+exception Error of error
+
 (* Detection of recursive handlers that are not guaranteed to poll
    at every loop iteration. *)
 
@@ -184,7 +191,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 +247,44 @@ 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 _) -> Some (Poll, i.dbg)
+      | Iop(Ialloc _) -> Some (Alloc, i.dbg)
+      | Iop(Icall_ind | Icall_imm _ |
+            Itailcall_ind | Itailcall_imm _ ) -> Some (Function_call, i.dbg)
+      | Iop(Iextcall { alloc = true }) -> Some (External_call, i.dbg)
+      | Iop(Imove | Ispill | Ireload | Iconst_int _ | Iconst_float _ |
+            Iconst_symbol _ | Iextcall { alloc = false } | Istackoffset _ |
+            Iload _ | Istore _ | Iintop _ | Iintop_imm _ | Ifloatofint |
+            Iintoffloat | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf |
+            Iopaque | Ispecific _)-> None
+      | Iend | Ireturn | Iifthenelse _ | Iswitch _ | Icatch _ | Iexit _ |
+        Itrywith _ | Iraise _ -> None
+    in
+  let matches = ref [] in
+    Mach.instr_iter
+      (fun i ->
+        match f_match i with
+        | Some(x) -> matches := x :: !matches
+        | None -> ())
+      instr;
+  List.rev !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
+    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
+    | Default_poll -> () 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 +295,49 @@ 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 p =
+  match p with
+  | Poll -> "inserted poll"
+  | Alloc -> "allocation"
+  | Function_call -> "function call"
+  | External_call -> "external call that allocates"
+
+let report_error ppf = function
+| Poll_error instrs ->
+  begin
+    let num_inserted_polls =
+      List.fold_left
+      (fun s (p,_) -> s + match p with Poll -> 1
+                      | Alloc | Function_call | External_call -> 0
+      ) 0 instrs in
+      let num_user_polls = (List.length instrs) - num_inserted_polls in
+      if num_user_polls = 0 then
+        fprintf ppf "Function with poll-error attribute contains polling \
+        points (inserted by the compiler)\n"
+      else begin
+        fprintf ppf
+        "Function with poll-error attribute contains polling points:\n";
+        List.iter (fun (p,dbg) ->
+          begin match p with
+          | Poll -> ()
+          | Alloc | Function_call | External_call ->
+            fprintf ppf "\t%s at " (instr_type p);
+            Location.print_loc ppf (Debuginfo.to_location dbg);
+            fprintf ppf "\n"
+          end
+        ) instrs;
+        if num_inserted_polls > 0 then
+          fprintf ppf "\t(plus compiler-inserted polling point(s) in prologue \
+          and/or loop back edges)\n"
+      end
+  end
+
+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 = f.fun_poll;
     fun_contains_calls = f.fun_contains_calls;
     fun_num_stack_slots = Array.copy num_stack_slots;
    },

asmcomp/selectgen.ml

@@ -1181,7 +1181,8 @@ method emit_fundecl ~future_funcnames f =
     if Polling.requires_prologue_poll ~future_funcnames
          ~fun_name:f.Cmm.fun_name body
       then
-      instr_cons (Iop(Ipoll { return_label = None })) [||] [||] body
+        instr_cons_debug
+          (Iop(Ipoll { return_label = None })) [||] [||] f.Cmm.fun_dbg body
     else
       body
     in
@@ -1192,6 +1193,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 = f.Cmm.fun_poll;
     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 = 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,6 +218,7 @@ let fundecl f =
     fun_args = new_args;
     fun_body = new_body;
     fun_codegen_options = f.fun_codegen_options;
+    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;

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;
   tmc_candidate: bool;
@@ -350,6 +355,7 @@ let default_function_attribute = {
   inline = Default_inline;
   specialise = Default_specialise;
   local = Default_local;
+  poll = Default_poll;
   is_a_functor = false;
   stub = false;
   tmc_candidate = 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;
   tmc_candidate: bool;
@@ -310,6 +315,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

@@ -467,7 +467,11 @@ let function_attribute ppf t =
   | Never_local -> fprintf ppf "never_local@ "
   end;
   if t.tmc_candidate then
-    fprintf ppf "tail_mod_cons@ "
+    fprintf ppf "tail_mod_cons@ ";
+  begin match t.poll with
+  | Default_poll -> ()
+  | Error_poll -> fprintf ppf "error_poll@ "
+  end
 
 let apply_tailcall_attribute ppf = function
   | Default_tailcall -> ()