Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

pattern-matching compiler: refactor the toplevel handling of partiality #9651

Merged
merged 3 commits into from
Nov 21, 2020
Merged

pattern-matching compiler: refactor the toplevel handling of partiality #9651

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
def877e
matching: [minor] inline the single-use split_and_precompile
gasche Jun 6, 2020
7d777f2
matching: factorize the code handling toplevel matching failures
gasche Jun 6, 2020
67ba8c3
matching: use toplevel_handler in for_tupled_function
gasche Jun 6, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
4 changes: 2 additions & 2 deletions Changes
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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:

Expand Down
128 changes: 45 additions & 83 deletions lambda/matching.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 = {
Expand Down Expand Up @@ -3458,36 +3452,32 @@ let check_total ~scopes loc ~failer total lambda i =
Lstaticcatch (lambda, (i, []),
failure_handler ~scopes loc ~failer ())

let compile_matching ~scopes loc ~failer repr arg pat_act_list partial =
let partial = check_partial pat_act_list partial in
let toplevel_handler ~scopes loc ~failer partial args cases compile_fun =
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
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);
lambda
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
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
Expand Down Expand Up @@ -3672,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
)
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Beyond the removal of the Unused handler that indeed seemed erroneous, this also optimizes the Total case by avoiding creating a default environment and checking if we need to install a match failure handler.


let flatten_pattern size p =
match p.pat_desc with
Expand Down Expand Up @@ -3766,28 +3747,19 @@ 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)
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_nonempty ~arg) pm1.cases }
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 next, nexts = split_and_precompile ~arg pm1 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
Expand All @@ -3801,18 +3773,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. *)
Expand Down