diff options
| author | Xavier Leroy <xavier.leroy@inria.fr> | 2014-06-05 13:59:33 +0000 |
|---|---|---|
| committer | Xavier Leroy <xavier.leroy@inria.fr> | 2014-06-05 13:59:33 +0000 |
| commit | 18d23e3a3def856ad1c5696ea2ebe079306cb9d3 (patch) | |
| tree | 7241a24675859c949de7f71cf22391d043cd3d44 | |
| parent | d1b1fbee667b5ce1c3b466d438418d4e9ff45e81 (diff) | |
Reflecting commit 14963 on version/4.02:
PR#2719: wrong scheduling of bound checks within a try...with Invalid_argument -> _ ...
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14964 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
| -rw-r--r-- | Changes | 2 | ||||
| -rw-r--r-- | asmcomp/schedgen.ml | 35 | ||||
| -rw-r--r-- | testsuite/makefiles/Makefile.common | 2 | ||||
| -rw-r--r-- | testsuite/tests/basic-more/pr2719.ml | 17 | ||||
| -rw-r--r-- | testsuite/tests/basic-more/pr2719.reference | 4 |
5 files changed, 47 insertions, 13 deletions
@@ -152,6 +152,8 @@ OCamldoc: (Maxence Guesdon, report by Anil Madhavapeddy) Bug fixes: +- PR#2719: wrong scheduling of bound checks within a + try...with Invalid_argument -> _ ... (Xavier Leroy) - PR#4719: Sys.executable_name wrong if executable name contains dots (Windows) (Alain Frisch, report by Bart Jacobs) - PR#4855: 'camlp4 -I +dir' accepted, dir is relative to 'camlp4 -where' diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml index 89fee29b6..f7af44367 100644 --- a/asmcomp/schedgen.ml +++ b/asmcomp/schedgen.ml @@ -138,6 +138,8 @@ let some_load = (Iload(Cmm.Word, Arch.identity_addressing)) class virtual scheduler_generic = object (self) +val mutable trywith_nesting = 0 + (* Determine whether an operation ends a basic block or not. Can be overridden for some processors to signal specific instructions that terminate a basic block. *) @@ -154,9 +156,16 @@ method oper_in_basic_block = function (* Determine whether an instruction ends a basic block or not *) -method private instr_in_basic_block instr = +(* PR#2719: it is generally incorrect to schedule checkbound instructions + within a try ... with Invalid_argument _ -> ... + Hence, a checkbound instruction within a try...with block ends the + current basic block. *) + +method private instr_in_basic_block instr try_nesting = match instr.desc with - Lop op -> self#oper_in_basic_block op + Lop op -> + self#oper_in_basic_block op && + not (try_nesting > 0 && self#is_checkbound op) | Lreloadretaddr -> true | _ -> false @@ -345,19 +354,21 @@ method private reschedule ready_queue date cont = method schedule_fundecl f = - let rec schedule i = + let rec schedule i try_nesting = match i.desc with - Lend -> i + | Lend -> i + | Lpushtrap -> { i with next = schedule i.next (try_nesting + 1) } + | Lpoptrap -> { i with next = schedule i.next (try_nesting - 1) } | _ -> - if self#instr_in_basic_block i then begin + if self#instr_in_basic_block i try_nesting then begin clear_code_dag(); - schedule_block [] i + schedule_block [] i try_nesting end else - { i with next = schedule i.next } + { i with next = schedule i.next try_nesting } - and schedule_block ready_queue i = - if self#instr_in_basic_block i then - schedule_block (self#add_instruction ready_queue i) i.next + and schedule_block ready_queue i try_nesting = + if self#instr_in_basic_block i try_nesting then + schedule_block (self#add_instruction ready_queue i) i.next try_nesting else begin let critical_outputs = match i.desc with @@ -366,11 +377,11 @@ method schedule_fundecl f = | Lreturn -> [||] | _ -> i.arg in List.iter (fun x -> ignore (longest_path critical_outputs x)) ready_queue; - self#reschedule ready_queue 0 (schedule i) + self#reschedule ready_queue 0 (schedule i try_nesting) end in if f.fun_fast then begin - let new_body = schedule f.fun_body in + let new_body = schedule f.fun_body 0 in clear_code_dag(); { fun_name = f.fun_name; fun_body = new_body; diff --git a/testsuite/makefiles/Makefile.common b/testsuite/makefiles/Makefile.common index ae6aceaa2..5fdf5a184 100644 --- a/testsuite/makefiles/Makefile.common +++ b/testsuite/makefiles/Makefile.common @@ -110,7 +110,7 @@ defaultclean: .cmxa.so: @$(OCAMLOPT) -o $@ -shared -linkall $(ADD_COMPFLAGS) $< -.mly.ml: +%.ml %.mli: %.mly @$(OCAMLYACC) -q $< 2> /dev/null .mll.ml: diff --git a/testsuite/tests/basic-more/pr2719.ml b/testsuite/tests/basic-more/pr2719.ml new file mode 100644 index 000000000..f0a9d6a4f --- /dev/null +++ b/testsuite/tests/basic-more/pr2719.ml @@ -0,0 +1,17 @@ +open Printf + +let bug () = + let mat = [| [|false|] |] + and test = ref false in + printf "Value of test at the beginning : %b\n" !test; flush stdout; + (try let _ = mat.(0).(-1) in + (test := true; + printf "Am I going through this block of instructions ?\n"; + flush stdout) + with Invalid_argument _ -> printf "Value of test now : %b\n" !test + ); + (try if mat.(0).(-1) then () + with Invalid_argument _ -> () + ) + +let () = bug () diff --git a/testsuite/tests/basic-more/pr2719.reference b/testsuite/tests/basic-more/pr2719.reference new file mode 100644 index 000000000..073d0916d --- /dev/null +++ b/testsuite/tests/basic-more/pr2719.reference @@ -0,0 +1,4 @@ +Value of test at the beginning : false +Value of test now : false + +All tests succeeded. |