diff --git a/backend/cfg/cfg_polling.ml b/backend/cfg/cfg_polling.ml index da19ee3e7f9..84a0558a6bd 100644 --- a/backend/cfg/cfg_polling.ml +++ b/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 diff --git a/backend/polling.ml b/backend/polling.ml index 89076a75bb7..bb8afd290c3 100644 --- a/backend/polling.ml +++ b/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 ) diff --git a/backend/polling.mli b/backend/polling.mli index e5bf7b4fd91..6ace1631967 100644 --- a/backend/polling.mli +++ b/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 diff --git a/native_toplevel/opttopdirs.ml b/native_toplevel/opttopdirs.ml index e8f094fa491..2ea2cd9ce0b 100644 --- a/native_toplevel/opttopdirs.ml +++ b/native_toplevel/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" diff --git a/native_toplevel/opttoploop.ml b/native_toplevel/opttoploop.ml index d241e5a1327..672b030b13a 100644 --- a/native_toplevel/opttoploop.ml +++ b/native_toplevel/opttoploop.ml @@ -709,6 +709,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 @@ -724,8 +726,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 diff --git a/native_toplevel/opttoploop.mli b/native_toplevel/opttoploop.mli index 10a4cff5f40..c6d5cdbfc61 100644 --- a/native_toplevel/opttoploop.mli +++ b/native_toplevel/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 *) diff --git a/ocaml/testsuite/tests/asmcomp/poll_attr_both.compilers.reference b/ocaml/testsuite/tests/asmcomp/poll_attr_both.compilers.reference index 11072d1d052..9d549ca219a 100644 --- a/ocaml/testsuite/tests/asmcomp/poll_attr_both.compilers.reference +++ b/ocaml/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) diff --git a/ocaml/testsuite/tests/asmcomp/poll_attr_inserted.compilers.reference b/ocaml/testsuite/tests/asmcomp/poll_attr_inserted.compilers.reference index 826cd527eed..8b02c70cbf8 100644 --- a/ocaml/testsuite/tests/asmcomp/poll_attr_inserted.compilers.reference +++ b/ocaml/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 diff --git a/ocaml/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference b/ocaml/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference index b8fac05d786..494feb19fc6 100644 --- a/ocaml/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference +++ b/ocaml/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) diff --git a/ocaml/testsuite/tests/asmcomp/poll_attr_user.compilers.reference b/ocaml/testsuite/tests/asmcomp/poll_attr_user.compilers.reference index 0d4319f175d..4bcb9d585e2 100644 --- a/ocaml/testsuite/tests/asmcomp/poll_attr_user.compilers.reference +++ b/ocaml/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 diff --git a/ocaml/testsuite/tests/polling/polling.compilers.reference b/ocaml/testsuite/tests/polling/polling.compilers.reference new file mode 100644 index 00000000000..934bd69ecb7 --- /dev/null +++ b/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 + + diff --git a/ocaml/testsuite/tests/polling/polling.ml b/ocaml/testsuite/tests/polling/polling.ml new file mode 100644 index 00000000000..beb769a8623 --- /dev/null +++ b/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 +;; diff --git a/testsuite/tests/asmcomp/poll_attr_both.compilers.reference b/testsuite/tests/asmcomp/poll_attr_both.compilers.reference index 11072d1d052..9d549ca219a 100644 --- a/testsuite/tests/asmcomp/poll_attr_both.compilers.reference +++ b/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) diff --git a/testsuite/tests/asmcomp/poll_attr_inserted.compilers.reference b/testsuite/tests/asmcomp/poll_attr_inserted.compilers.reference index 826cd527eed..8b02c70cbf8 100644 --- a/testsuite/tests/asmcomp/poll_attr_inserted.compilers.reference +++ b/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 diff --git a/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference b/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference index b8fac05d786..494feb19fc6 100644 --- a/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference +++ b/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) diff --git a/testsuite/tests/asmcomp/poll_attr_user.compilers.reference b/testsuite/tests/asmcomp/poll_attr_user.compilers.reference index 0d4319f175d..4bcb9d585e2 100644 --- a/testsuite/tests/asmcomp/poll_attr_user.compilers.reference +++ b/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