diff --git a/changes/unreachable-guarded-or-pattern.fix.md b/changes/unreachable-guarded-or-pattern.fix.md new file mode 100644 index 0000000000..0cba29da91 --- /dev/null +++ b/changes/unreachable-guarded-or-pattern.fix.md @@ -0,0 +1 @@ +- Fix a compiler crash ("Fatal error: Matching.comp_exit") on a guarded or-pattern that an earlier case makes unreachable. diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index e96eecb02a..1b6e0e7fe5 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -2484,13 +2484,31 @@ let as_exit_call lam = in go Ident.empty lam +(* Adds the static exits [lam] jumps to to [raised]. Exits cannot leave a + function, so function bodies are skipped. *) +let rec add_raised_exits raised lam = + match lam with + | Lfunction _ -> () + | Lstaticraise (i, _) -> + Hashtbl.replace raised i (); + Lambda_traverse.iter (add_raised_exits raised) lam + | _ -> Lambda_traverse.iter (add_raised_exits raised) lam + let compile_orhandlers compile_fun lambda1 total1 ctx to_catch = + (* The exits of the match and of the handlers compiled so far *) + let raised = Hashtbl.create 16 in + add_raised_exits raised lambda1; let rec do_rec r total_r = function | [] -> (r, total_r) + | (_, i, _, _) :: rem when not (Hashtbl.mem raised i) -> + (* The or-pattern is unreachable, e.g. after a wildcard. Its handler is + not compiled: with a guard and no default, its failure has no exit. *) + do_rec r total_r rem | (mat, i, vars, pm) :: rem -> ( try let ctx = select_columns mat ctx in let handler_i, total_i = compile_fun ctx pm in + add_raised_exits raised handler_i; match as_exit_call r with | Some (j, args) -> if i = j then diff --git a/tests/build_tests/super_errors/expected/warning_11_unreachable_guarded_or_pattern.res.expected b/tests/build_tests/super_errors/expected/warning_11_unreachable_guarded_or_pattern.res.expected new file mode 100644 index 0000000000..a86ac90122 --- /dev/null +++ b/tests/build_tests/super_errors/expected/warning_11_unreachable_guarded_or_pattern.res.expected @@ -0,0 +1,47 @@ + + Warning number 11 + /.../fixtures/warning_11_unreachable_guarded_or_pattern.res:9:5-9 + + 7 ┆ switch x { + 8 ┆ | _ => 2 + 9 ┆ | 1 | 2 if g() => 3 + 10 ┆ } + 11 ┆ + + this match case is unused. + + + Warning number 11 + /.../fixtures/warning_11_unreachable_guarded_or_pattern.res:15:5-13 + + 13 ┆ switch c { + 14 ┆ | _ => "any" + 15 ┆ | 'a' | 'b' if g() => "ab" + 16 ┆ } + 17 ┆ + + this match case is unused. + + + Warning number 11 + /.../fixtures/warning_11_unreachable_guarded_or_pattern.res:21:5-13 + + 19 ┆ switch s { + 20 ┆ | _ => "any" + 21 ┆ | "a" | "b" if g() => "ab" + 22 ┆ } + 23 ┆ + + this match case is unused. + + + Warning number 11 + /.../fixtures/warning_11_unreachable_guarded_or_pattern.res:28:5-19 + + 26 ┆ | (0, _) => "zero" + 27 ┆ | (_, _) => "other" + 28 ┆ | (1, 1) | (2, 2) if g() => "same" + 29 ┆ } + 30 ┆ + + this match case is unused. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/warning_11_unreachable_guarded_or_pattern.res b/tests/build_tests/super_errors/fixtures/warning_11_unreachable_guarded_or_pattern.res new file mode 100644 index 0000000000..e013b1362e --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/warning_11_unreachable_guarded_or_pattern.res @@ -0,0 +1,29 @@ +// Each guarded or-pattern is unreachable after a case that matches +// everything. Compiling them used to fail with +// "Fatal error: Matching.comp_exit" instead of reporting them as unused. +let g = () => true + +let int = x => + switch x { + | _ => 2 + | 1 | 2 if g() => 3 + } + +let char = c => + switch c { + | _ => "any" + | 'a' | 'b' if g() => "ab" + } + +let string = s => + switch s { + | _ => "any" + | "a" | "b" if g() => "ab" + } + +let pair = p => + switch p { + | (0, _) => "zero" + | (_, _) => "other" + | (1, 1) | (2, 2) if g() => "same" + }