From def877e3511bc61853876b2c2d7a319595837233 Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Sat, 6 Jun 2020 11:24:29 +0200 Subject: [PATCH 1/3] matching: [minor] inline the single-use split_and_precompile This comes from a suggestion by Florian Angeletti in https://github.com/ocaml/ocaml/pull/9447#discussion_r408910756 --- lambda/matching.ml | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/lambda/matching.ml b/lambda/matching.ml index 4be5dd4c1..d90bb3a98 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -1637,12 +1637,6 @@ let split_and_precompile_half_simplified ~arg pm = dbg_split_and_precompile pm next nexts; (next, nexts) -let split_and_precompile ~arg pm = - let pm = - { pm with cases = List.map (half_simplify_clause ~arg) pm.cases } - in - split_and_precompile_half_simplified ~arg pm - (* General divide functions *) type cell = { @@ -3787,7 +3781,10 @@ let do_for_multiple_match ~scopes loc paraml pat_act_list partial = } ) in try - let next, nexts = split_and_precompile ~arg pm1 in + let pm1_half = + { pm1 with cases = List.map (half_simplify_clause ~arg) pm1.cases } + in + let next, nexts = split_and_precompile_half_simplified ~arg pm1_half in let size = List.length paraml and idl = List.map (function | Lvar id -> id From 7d777f20af8ec5c351302a659125feaefa535651 Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Sat, 6 Jun 2020 15:18:51 +0200 Subject: [PATCH 2/3] matching: factorize the code handling toplevel matching failures --- Changes | 4 +- lambda/matching.ml | 98 +++++++++++++++++----------------------------- 2 files changed, 38 insertions(+), 64 deletions(-) diff --git a/Changes b/Changes index 997ec2ec1..2a29324c9 100644 --- a/Changes +++ b/Changes @@ -19,8 +19,8 @@ Working version ### Internal/compiler-libs changes: -- #9650: keep refactoring the pattern-matching compiler - (Gabriel Scherer, review by Thomas Refis) +- #9650, #9651: keep refactoring the pattern-matching compiler + (Gabriel Scherer, review by Thomas Refis and Florian Angeletti) ### Build system: diff --git a/lambda/matching.ml b/lambda/matching.ml index d90bb3a98..1e23f00b3 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -3452,36 +3452,32 @@ let check_total ~scopes loc ~failer total lambda i = Lstaticcatch (lambda, (i, []), 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 partial = check_partial pat_act_list partial in - match partial with - | Partial -> ( - let raise_num = next_raise_count () in - let 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 args = [ (arg, Strict) ] in + let rows = map_on_rows (fun pat -> (pat, [])) pat_act_list in + toplevel_handler ~scopes loc ~failer partial args rows (fun partial pm -> + compile_match_nonempty ~scopes repr partial (Context.start 1) pm) let for_function ~scopes loc repr param pat_act_list partial = 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 repr = None in - let partial = check_partial pat_act_list partial in - let raise_num, arg, pm1 = - let raise_num, default = - match partial with - | Partial -> - let raise_num = next_raise_count () in - ( raise_num, - Default_environment.(cons [ [ Patterns.omega ] ] raise_num empty) - ) - | 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 arg = + let sloc = Scoped_location.of_location ~scopes loc in + Lprim (Pmakeblock (0, Immutable, None), paraml, sloc) in + let handler = + let partial = check_partial pat_act_list partial in + let rows = map_on_rows (fun p -> (p, [])) pat_act_list in + toplevel_handler ~scopes loc ~failer:Raise_match_failure + partial [ (arg, Strict) ] rows in + handler (fun partial pm1 -> 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 let next, nexts = split_and_precompile_half_simplified ~arg pm1_half in 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 (Context.start size) flat_next flat_nexts in - List.fold_right2 (bind Strict) idl paraml - ( 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 () *) + List.fold_right2 (bind Strict) idl paraml lam, total + ) (* PR#4828: Believe it or not, the 'paraml' argument below may not be side effect free. *) From 67ba8c36ccd7b270eb84681dc8dba011d283ddf2 Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Sat, 6 Jun 2020 16:19:55 +0200 Subject: [PATCH 3/3] matching: use toplevel_handler in for_tupled_function This appears to change the function behavior with respect to the Unused exception, but we believe that the change is correct. It makes the code more consistent with other toplevel compilation functions. --- lambda/matching.ml | 25 ++++++++----------------- 1 file changed, 8 insertions(+), 17 deletions(-) diff --git a/lambda/matching.ml b/lambda/matching.ml index 1e23f00b3..65ffb2316 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -3662,23 +3662,14 @@ let for_let ~scopes loc param pat body = (* Easy case since variables are available *) let for_tupled_function ~scopes loc paraml pats_act_list partial = let partial = check_partial_list pats_act_list partial in - let raise_num = next_raise_count () in - let omega_params = [ Patterns.omega_list paraml ] in - let pm = - { cases = pats_act_list; - args = List.map (fun id -> (Lvar id, Strict)) paraml; - default = Default_environment.(cons omega_params raise_num empty) - } - in - try - let lambda, total = - compile_match ~scopes None partial - (Context.start (List.length paraml)) pm - in - check_total ~scopes loc ~failer:Raise_match_failure - total lambda raise_num - with Unused -> - failure_handler ~scopes loc ~failer:Raise_match_failure () + let args = List.map (fun id -> (Lvar id, Strict)) paraml in + let handler = + toplevel_handler ~scopes loc ~failer:Raise_match_failure + partial args pats_act_list in + handler (fun partial pm -> + compile_match ~scopes None partial + (Context.start (List.length paraml)) pm + ) let flatten_pattern size p = match p.pat_desc with