matching: factorize the code handling toplevel matching failures
parent
def877e351
commit
7d777f20af
4
Changes
4
Changes
|
@ -19,8 +19,8 @@ Working version
|
||||||
|
|
||||||
### Internal/compiler-libs changes:
|
### Internal/compiler-libs changes:
|
||||||
|
|
||||||
- #9650: keep refactoring the pattern-matching compiler
|
- #9650, #9651: keep refactoring the pattern-matching compiler
|
||||||
(Gabriel Scherer, review by Thomas Refis)
|
(Gabriel Scherer, review by Thomas Refis and Florian Angeletti)
|
||||||
|
|
||||||
### Build system:
|
### Build system:
|
||||||
|
|
||||||
|
|
|
@ -3452,36 +3452,32 @@ let check_total ~scopes loc ~failer total lambda i =
|
||||||
Lstaticcatch (lambda, (i, []),
|
Lstaticcatch (lambda, (i, []),
|
||||||
failure_handler ~scopes loc ~failer ())
|
failure_handler ~scopes loc ~failer ())
|
||||||
|
|
||||||
|
let toplevel_handler ~scopes loc ~failer partial args cases compile_fun =
|
||||||
|
match partial with
|
||||||
|
| Total ->
|
||||||
|
let default = Default_environment.empty in
|
||||||
|
let pm = { args; cases; default } in
|
||||||
|
let (lam, total) = compile_fun Total pm in
|
||||||
|
assert (Jumps.is_empty total);
|
||||||
|
lam
|
||||||
|
| Partial ->
|
||||||
|
let raise_num = next_raise_count () in
|
||||||
|
let default =
|
||||||
|
Default_environment.cons [ Patterns.omega_list args ] raise_num
|
||||||
|
Default_environment.empty in
|
||||||
|
let pm = { args; cases; default } in
|
||||||
|
begin match compile_fun Partial pm with
|
||||||
|
| exception Unused -> assert false
|
||||||
|
| (lam, total) ->
|
||||||
|
check_total ~scopes loc ~failer total lam raise_num
|
||||||
|
end
|
||||||
|
|
||||||
let compile_matching ~scopes loc ~failer repr arg pat_act_list partial =
|
let compile_matching ~scopes loc ~failer repr arg pat_act_list partial =
|
||||||
let partial = check_partial pat_act_list partial in
|
let partial = check_partial pat_act_list partial in
|
||||||
match partial with
|
let args = [ (arg, Strict) ] in
|
||||||
| Partial -> (
|
let rows = map_on_rows (fun pat -> (pat, [])) pat_act_list in
|
||||||
let raise_num = next_raise_count () in
|
toplevel_handler ~scopes loc ~failer partial args rows (fun partial pm ->
|
||||||
let pm =
|
compile_match_nonempty ~scopes repr partial (Context.start 1) pm)
|
||||||
{ cases = List.map (fun (pat, act) -> ([ pat ], act)) pat_act_list;
|
|
||||||
args = [ (arg, Strict) ];
|
|
||||||
default =
|
|
||||||
Default_environment.(cons [ [ Patterns.omega ] ] raise_num empty)
|
|
||||||
}
|
|
||||||
in
|
|
||||||
try
|
|
||||||
let lambda, total =
|
|
||||||
compile_match ~scopes repr partial (Context.start 1) pm in
|
|
||||||
check_total ~scopes loc ~failer total lambda raise_num
|
|
||||||
with Unused -> assert false
|
|
||||||
(* ; handler_fun() *)
|
|
||||||
)
|
|
||||||
| Total ->
|
|
||||||
let pm =
|
|
||||||
{ cases = List.map (fun (pat, act) -> ([ pat ], act)) pat_act_list;
|
|
||||||
args = [ (arg, Strict) ];
|
|
||||||
default = Default_environment.empty
|
|
||||||
}
|
|
||||||
in
|
|
||||||
let lambda, total =
|
|
||||||
compile_match ~scopes repr partial (Context.start 1) pm in
|
|
||||||
assert (Jumps.is_empty total);
|
|
||||||
lambda
|
|
||||||
|
|
||||||
let for_function ~scopes loc repr param pat_act_list partial =
|
let for_function ~scopes loc repr param pat_act_list partial =
|
||||||
compile_matching ~scopes loc ~failer:Raise_match_failure
|
compile_matching ~scopes loc ~failer:Raise_match_failure
|
||||||
|
@ -3760,29 +3756,17 @@ let compile_flattened ~scopes repr partial ctx pmh =
|
||||||
|
|
||||||
let do_for_multiple_match ~scopes loc paraml pat_act_list partial =
|
let do_for_multiple_match ~scopes loc paraml pat_act_list partial =
|
||||||
let repr = None in
|
let repr = None in
|
||||||
let partial = check_partial pat_act_list partial in
|
let arg =
|
||||||
let raise_num, arg, pm1 =
|
let sloc = Scoped_location.of_location ~scopes loc in
|
||||||
let raise_num, default =
|
Lprim (Pmakeblock (0, Immutable, None), paraml, sloc) in
|
||||||
match partial with
|
let handler =
|
||||||
| Partial ->
|
let partial = check_partial pat_act_list partial in
|
||||||
let raise_num = next_raise_count () in
|
let rows = map_on_rows (fun p -> (p, [])) pat_act_list in
|
||||||
( raise_num,
|
toplevel_handler ~scopes loc ~failer:Raise_match_failure
|
||||||
Default_environment.(cons [ [ Patterns.omega ] ] raise_num empty)
|
partial [ (arg, Strict) ] rows in
|
||||||
)
|
handler (fun partial pm1 ->
|
||||||
| Total -> (-1, Default_environment.empty)
|
|
||||||
in
|
|
||||||
let loc = Scoped_location.of_location ~scopes loc in
|
|
||||||
let arg = Lprim (Pmakeblock (0, Immutable, None), paraml, loc) in
|
|
||||||
( raise_num,
|
|
||||||
arg,
|
|
||||||
{ cases = List.map (fun (pat, act) -> ([ pat ], act)) pat_act_list;
|
|
||||||
args = [ (arg, Strict) ];
|
|
||||||
default
|
|
||||||
} )
|
|
||||||
in
|
|
||||||
try
|
|
||||||
let pm1_half =
|
let pm1_half =
|
||||||
{ pm1 with cases = List.map (half_simplify_clause ~arg) pm1.cases }
|
{ pm1 with cases = List.map (half_simplify_nonempty ~arg) pm1.cases }
|
||||||
in
|
in
|
||||||
let next, nexts = split_and_precompile_half_simplified ~arg pm1_half in
|
let next, nexts = split_and_precompile_half_simplified ~arg pm1_half in
|
||||||
let size = List.length paraml
|
let size = List.length paraml
|
||||||
|
@ -3798,18 +3782,8 @@ let do_for_multiple_match ~scopes loc paraml pat_act_list partial =
|
||||||
comp_match_handlers (compile_flattened ~scopes repr) partial
|
comp_match_handlers (compile_flattened ~scopes repr) partial
|
||||||
(Context.start size) flat_next flat_nexts
|
(Context.start size) flat_next flat_nexts
|
||||||
in
|
in
|
||||||
List.fold_right2 (bind Strict) idl paraml
|
List.fold_right2 (bind Strict) idl paraml lam, total
|
||||||
( match partial with
|
)
|
||||||
| Partial ->
|
|
||||||
let failer = Raise_match_failure in
|
|
||||||
check_total ~scopes loc ~failer total lam raise_num
|
|
||||||
| Total ->
|
|
||||||
assert (Jumps.is_empty total);
|
|
||||||
lam
|
|
||||||
)
|
|
||||||
with Unused -> assert false
|
|
||||||
|
|
||||||
(* ; partial_function loc () *)
|
|
||||||
|
|
||||||
(* PR#4828: Believe it or not, the 'paraml' argument below
|
(* PR#4828: Believe it or not, the 'paraml' argument below
|
||||||
may not be side effect free. *)
|
may not be side effect free. *)
|
||||||
|
|
Loading…
Reference in New Issue