Polling: more tests (#2849)

backend/cfg/cfg_polling.ml

@@ -52,7 +52,8 @@ type polling_point = Polling.polling_point =
   | Function_call
   | External_call
 
-type error = Polling.error = Poll_error of (polling_point * Debuginfo.t) list
+type error = Polling.error =
+  | Poll_error of Debuginfo.t * (polling_point * Debuginfo.t) list
 
 exception Error = Polling.Error
 
@@ -347,7 +348,7 @@ let instrument_fundecl :
             ~cmp:(fun left right -> Debuginfo.compare (snd left) (snd right))
             poll_error_instrs
         in
-        raise (Error (Poll_error poll_error_instrs)))
+        raise (Error (Poll_error (cfg.fun_dbg, poll_error_instrs))))
     | Default_poll -> ());
     let new_contains_calls =
       (* `added_poll` is used to avoid iterating over the CFG if we have added a

backend/polling.ml

@@ -29,7 +29,7 @@ let function_is_assumed_to_never_poll 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
+type error = Poll_error of Debuginfo.t * (polling_point * Debuginfo.t) list
 
 exception Error of error
 
@@ -276,7 +276,7 @@ let instrument_fundecl ~future_funcnames:_ (f : Mach.fundecl) : Mach.fundecl =
     | Error_poll -> begin
         match find_poll_alloc_or_calls new_body with
         | [] -> ()
-        | poll_error_instrs -> raise (Error(Poll_error poll_error_instrs))
+        | poll_error_instrs -> raise (Error(Poll_error (f.fun_dbg, poll_error_instrs)))
       end
     | Default_poll -> () end;
     let new_contains_calls = f.fun_contains_calls || !contains_polls in
@@ -300,7 +300,7 @@ let instr_type p =
   | External_call -> "external call that allocates"
 
 let report_error ppf = function
-| Poll_error instrs ->
+| Poll_error (_fun_dbg, instrs) ->
   begin
     let num_inserted_polls =
       List.fold_left
@@ -311,27 +311,28 @@ let report_error ppf = function
       if num_user_polls = 0 then
         fprintf ppf "Function with poll-error attribute contains polling \
         points (inserted by the compiler)\n"
-      else begin
+      else
         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);
+      List.iter (fun (p,dbg) ->
+        begin match p with
+        | Poll
+        | Alloc | Function_call | External_call ->
+          fprintf ppf "\t%s" (instr_type p);
+          if not (Debuginfo.is_none dbg) then begin
+            fprintf ppf " at ";
             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;
+          fprintf ppf "\n"
+        end
+      ) (List.sort (fun (_, left) (_, right) -> Debuginfo.compare left right) instrs)
   end
 
 let () =
   Location.register_error_of_exn
     (function
-      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | Error (Poll_error (fun_dbg, _instrs) as err) ->
+        let loc = Debuginfo.to_location fun_dbg in
+        Some (Location.error_of_printer ~loc report_error err)
       | _ -> None
     )

backend/polling.mli

@@ -24,7 +24,7 @@ val is_disabled : string -> bool
 
 type polling_point = Alloc | Poll | Function_call | External_call
 
-type error = Poll_error of (polling_point * Debuginfo.t) list
+type error = Poll_error of Debuginfo.t * (polling_point * Debuginfo.t) list
 
 exception Error of error
 

flambda-backend/testsuite/tests/asmcomp/poll_attr_both.compilers.reference

@@ -1,6 +1,13 @@
-File "poll_attr_both.ml", line 1:
+File "poll_attr_both.ml", lines 16-22, characters 19-13:
+16 | ...................x =
+17 |   let y = Sys.opaque_identity(ref 42) in
+18 |     let x2 = v x in
+19 |       for c = 0 to x2 do
+20 |         ignore(Sys.opaque_identity(42))
+21 |       done;
+22 |       x2 + !y
 Error: Function with poll-error attribute contains polling points:
+	inserted poll
 	allocation at File "poll_attr_both.ml", line 17, characters 29-37
 	function call at File "poll_attr_both.ml", line 18, characters 13-16
-	(plus compiler-inserted polling point(s) in prologue and/or loop back edges)
 

flambda-backend/testsuite/tests/asmcomp/poll_attr_inserted.compilers.reference

@@ -1,3 +1,8 @@
-File "poll_attr_inserted.ml", line 1:
+File "poll_attr_inserted.ml", lines 16-19, characters 19-6:
+16 | ...................x =
+17 |   for c = 0 to 2 do
+18 |     ignore(Sys.opaque_identity(42))
+19 |   done
 Error: Function with poll-error attribute contains polling points (inserted by the compiler)
+	inserted poll
 

flambda-backend/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference

@@ -1,5 +1,9 @@
-File "poll_attr_prologue.ml", line 1:
+File "poll_attr_prologue.ml", lines 14-17, characters 23-38:
+14 | .......................x l =
+15 |   match l with
+16 |   | [] -> 0
+17 |   | _ :: tl -> (d[@tailcall]) (x+1) tl
 Error: Function with poll-error attribute contains polling points:
+	inserted poll at File "poll_attr_prologue.ml", lines 14-17, characters 23-38
 	function call at File "poll_attr_prologue.ml", line 17, characters 15-38
-	(plus compiler-inserted polling point(s) in prologue and/or loop back edges)
 

flambda-backend/testsuite/tests/asmcomp/poll_attr_user.compilers.reference

@@ -1,4 +1,11 @@
-File "poll_attr_user.ml", line 1:
+File "poll_attr_user.ml", lines 16-22, characters 19-13:
+16 | ...................x =
+17 |   let y = Sys.opaque_identity(ref 42) in
+18 |     let x2 = v x in
+19 |       for c = 0 to x2 do
+20 |         ignore(Sys.opaque_identity(ref 42))
+21 |       done;
+22 |       x2 + !y
 Error: Function with poll-error attribute contains polling points:
 	allocation at File "poll_attr_user.ml", line 17, characters 29-37
 	function call at File "poll_attr_user.ml", line 18, characters 13-16

ocaml/testsuite/tests/polling/polling.compilers.reference

@@ -0,0 +1,30 @@
+Lines 8-11, characters 28-6:
+ 8 | ............................x =
+ 9 |   for _ = 0 to x do
+10 |     ignore(Sys.opaque_identity(ref 42))
+11 |   done
+Error: Function with poll-error attribute contains polling points:
+	allocation at Line 10, characters 30-38
+
+Lines 2-5, characters 31-6:
+2 | ...............................x =
+3 |   for _ = 0 to x do
+4 |     ignore(Sys.opaque_identity 42)
+5 |   done
+Error: Function with poll-error attribute contains polling points (inserted by the compiler)
+	inserted poll
+
+Lines 2-4, characters 29-11:
+2 | .............................x =
+3 |   ignore(Sys.opaque_identity(ref 42));
+4 |   tailrec x
+Error: Function with poll-error attribute contains polling points:
+	allocation at Line 3, characters 28-36
+
+Lines 2-3, characters 38-20:
+2 | ......................................x =
+3 |   tailrec_no_alloc x
+Error: Function with poll-error attribute contains polling points (inserted by the compiler)
+	inserted poll
+
+

ocaml/testsuite/tests/polling/polling.ml

@@ -0,0 +1,27 @@
+(* TEST
+ {
+   poll-insertion;
+   toplevel.opt;
+ }
+*)
+
+let[@poll error] loop_alloc x =
+  for _ = 0 to x do
+    ignore(Sys.opaque_identity(ref 42))
+  done
+;;
+
+let[@poll error] loop_no_alloc x =
+  for _ = 0 to x do
+    ignore(Sys.opaque_identity 42)
+  done
+;;
+
+let[@poll error] rec tailrec x =
+  ignore(Sys.opaque_identity(ref 42));
+  tailrec x
+;;
+
+let[@poll error] rec tailrec_no_alloc x =
+  tailrec_no_alloc x
+;;

testsuite/tests/asmcomp/poll_attr_both.compilers.reference

@@ -1,6 +1,13 @@
-File "poll_attr_both.ml", line 1:
+File "poll_attr_both.ml", lines 16-22, characters 19-13:
+16 | ...................x =
+17 |   let y = Sys.opaque_identity(ref 42) in
+18 |     let x2 = v x in
+19 |       for c = 0 to x2 do
+20 |         ignore(Sys.opaque_identity(42))
+21 |       done;
+22 |       x2 + !y
 Error: Function with poll-error attribute contains polling points:
+	inserted poll
 	allocation at File "poll_attr_both.ml", line 17, characters 29-37
 	function call at File "poll_attr_both.ml", line 18, characters 13-16
-	(plus compiler-inserted polling point(s) in prologue and/or loop back edges)
 

testsuite/tests/asmcomp/poll_attr_inserted.compilers.reference

@@ -1,3 +1,8 @@
-File "poll_attr_inserted.ml", line 1:
+File "poll_attr_inserted.ml", lines 16-19, characters 19-6:
+16 | ...................x =
+17 |   for c = 0 to 2 do
+18 |     ignore(Sys.opaque_identity(42))
+19 |   done
 Error: Function with poll-error attribute contains polling points (inserted by the compiler)
+	inserted poll
 

testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference

@@ -1,5 +1,9 @@
-File "poll_attr_prologue.ml", line 1:
+File "poll_attr_prologue.ml", lines 14-17, characters 23-38:
+14 | .......................x l =
+15 |   match l with
+16 |   | [] -> 0
+17 |   | _ :: tl -> (d[@tailcall]) (x+1) tl
 Error: Function with poll-error attribute contains polling points:
+	inserted poll at File "poll_attr_prologue.ml", lines 14-17, characters 23-38
 	function call at File "poll_attr_prologue.ml", line 17, characters 15-38
-	(plus compiler-inserted polling point(s) in prologue and/or loop back edges)
 

testsuite/tests/asmcomp/poll_attr_user.compilers.reference

@@ -1,4 +1,11 @@
-File "poll_attr_user.ml", line 1:
+File "poll_attr_user.ml", lines 16-22, characters 19-13:
+16 | ...................x =
+17 |   let y = Sys.opaque_identity(ref 42) in
+18 |     let x2 = v x in
+19 |       for c = 0 to x2 do
+20 |         ignore(Sys.opaque_identity(ref 42))
+21 |       done;
+22 |       x2 + !y
 Error: Function with poll-error attribute contains polling points:
 	allocation at File "poll_attr_user.ml", line 17, characters 29-37
 	function call at File "poll_attr_user.ml", line 18, characters 13-16

toplevel/native/opttopdirs.ml

@@ -213,7 +213,10 @@ let _ =
              (Directive_string (parse_warnings std_out false));
 
   Hashtbl.add directive_table "warn_error"
-             (Directive_string (parse_warnings std_out true))
+             (Directive_string (parse_warnings std_out true));
+
+  Hashtbl.add directive_table "reset_location"
+             (Directive_bool (fun b -> reset_location := b))
 
 let section_options = "Compiler options"
 

toplevel/native/opttoploop.ml

@@ -711,6 +711,8 @@ let initialize_toplevel_env () =
 
 exception PPerror
 
+let reset_location = ref true
+
 let loop ppf =
   Location.formatter_for_warnings := ppf;
   if not !Clflags.noversion then
@@ -726,8 +728,10 @@ let loop ppf =
   while true do
     let snap = Btype.snapshot () in
     try
-      Lexing.flush_input lb;
-      Location.reset();
+      if !reset_location then begin
+        Lexing.flush_input lb;
+        Location.reset();
+      end;
       first_line := true;
       let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
       let phr = preprocess_phrase ppf phr  in

toplevel/native/opttoploop.mli

@@ -21,6 +21,7 @@ val set_paths : unit -> unit
 
 (* The interactive toplevel loop *)
 
+val reset_location : bool ref
 val loop : formatter -> unit
 
 (* Read and execute a script from the given file *)