diff options
| -rw-r--r-- | lambda/matching.ml | 57 |
1 files changed, 30 insertions, 27 deletions
diff --git a/lambda/matching.ml b/lambda/matching.ml index e2a2891908..b409df4247 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -3601,35 +3601,38 @@ let do_for_multiple_match loc paraml pat_act_list partial = } ) in try - try - (* Once for checking that compilation is possible *) - let next, nexts = split_and_precompile ~arg_id:None pm1 in - let size = List.length paraml - and idl = List.map (fun _ -> Ident.create_local "*match*") paraml in - let args = List.map (fun id -> (Lvar id, Alias)) idl in - let flat_next = flatten_precompiled size args next - and flat_nexts = - List.map (fun (e, pm) -> (e, flatten_precompiled size args pm)) nexts - in - let lam, total = - comp_match_handlers (compile_flattened repr) partial - (Context.start size) flat_next flat_nexts - in - List.fold_right2 (bind Strict) idl paraml - ( match partial with - | Partial -> check_total total lam raise_num (partial_function loc) + match split_and_precompile ~arg_id:None pm1 with + | exception Cannot_flatten -> ( + (* One pattern binds the whole tuple, flattening is not possible. + We need to allocate the scrutinee. *) + let lambda, total = compile_match None partial (Context.start 1) pm1 in + match partial with + | Partial -> check_total total lambda raise_num (partial_function loc) | Total -> assert (Jumps.is_empty total); - lam - ) - with Cannot_flatten -> ( - let lambda, total = compile_match None partial (Context.start 1) pm1 in - match partial with - | Partial -> check_total total lambda raise_num (partial_function loc) - | Total -> - assert (Jumps.is_empty total); - lambda - ) + lambda + ) + | next, nexts -> ( + let size = List.length paraml + and idl = List.map (fun _ -> Ident.create_local "*match*") paraml in + let args = List.map (fun id -> (Lvar id, Alias)) idl in + (* This will not raise, since the PM is well typed. *) + let flat_next = flatten_precompiled size args next + and flat_nexts = + List.map (fun (e, pm) -> (e, flatten_precompiled size args pm)) nexts + in + let lam, total = + comp_match_handlers (compile_flattened repr) partial + (Context.start size) flat_next flat_nexts + in + List.fold_right2 (bind Strict) idl paraml + ( match partial with + | Partial -> check_total total lam raise_num (partial_function loc) + | Total -> + assert (Jumps.is_empty total); + lam + ) + ) with Unused -> assert false (* ; partial_function loc () *) |