From bf95a247395ef89036578e04194e517063eb1244 Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Thu, 21 May 2020 11:37:13 +0200 Subject: [PATCH] Matching: propagate constructor descriptions in complete_pats_constrs This simplifies this particular interface boundary between Matching and Parmatch. (Suggested by Florian Angeletti) --- .depend | 1 - Changes | 2 +- lambda/matching.ml | 26 ++++++++++++++------------ typing/parmatch.ml | 21 ++++++--------------- typing/parmatch.mli | 2 +- 5 files changed, 22 insertions(+), 30 deletions(-) diff --git a/.depend b/.depend index cf0694a8a..2f54b7384 100644 --- a/.depend +++ b/.depend @@ -811,7 +811,6 @@ typing/parmatch.cmx : \ typing/parmatch.cmi : \ typing/types.cmi \ typing/typedtree.cmi \ - typing/patterns.cmi \ parsing/parsetree.cmi \ parsing/location.cmi \ typing/env.cmi \ diff --git a/Changes b/Changes index 8cf89e191..e728b5381 100644 --- a/Changes +++ b/Changes @@ -76,7 +76,7 @@ Working version ### Internal/compiler-libs changes: -- #9493, #9520, #9563: refactor the pattern-matching compiler +- #9493, #9520, #9563, #9599: refactor the pattern-matching compiler (Thomas Refis and Gabriel Scherer, review by Florian Angeletti) ### Build system: diff --git a/lambda/matching.ml b/lambda/matching.ml index 0bc1ffce3..f1fe713e8 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -2498,16 +2498,14 @@ let rec list_as_pat = function | pat :: rem -> { pat with pat_desc = Tpat_or (pat, list_as_pat rem, None) } let complete_pats_constrs = function - | p :: _ as pats -> - (* We (indirectly) call this function - from [combine_constructor], and nowhere else. - So we know patterns have been fully simplified. *) - let p_simple = match (Patterns.General.view p).pat_desc with - | #Patterns.Simple.view as simple -> { p with pat_desc = simple } - | _ -> invalid_arg "complete_pats_constrs" in - let tag_of_pat p = (get_key_constr p).cstr_tag in - List.map (pat_of_constr p) - (complete_constrs p_simple (List.map tag_of_pat pats)) + | constr :: _ as constrs -> + let tag_of_constr constr = + constr.pat_desc.cstr_tag in + let pat_of_constr cstr = + let open Patterns.Head in + to_omega_pattern { constr with pat_desc = Construct cstr } in + List.map pat_of_constr + (complete_constrs constr (List.map tag_of_constr constrs)) | _ -> assert false (* @@ -2725,10 +2723,14 @@ let combine_constructor loc arg pat_env cstr partial ctx def if sig_complete then (None, [], Jumps.empty) else - mk_failaction_pos partial pats ctx def + let constrs = + List.map2 (fun (constr, _act) p -> { p with pat_desc = constr }) + descr_lambda_list pats in + mk_failaction_pos partial constrs ctx def in let descr_lambda_list = fails @ descr_lambda_list in - let consts, nonconsts = split_cases (List.map tag_lambda descr_lambda_list) in + let consts, nonconsts = + split_cases (List.map tag_lambda descr_lambda_list) in let lambda1 = match (fail_opt, same_actions descr_lambda_list) with | None, Some act -> act (* Identical actions, no failure *) diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 8f6ea188e..0d2f0663c 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -881,11 +881,10 @@ let rec get_variant_constructors env ty = | _ -> fatal_error "Parmatch.get_variant_constructors" (* Sends back a pattern that complements constructor tags all_tag *) -let complete_constrs p all_tags = - let open Patterns.Head in - let c = match p.pat_desc with Construct c -> c | _ -> assert false in +let complete_constrs constr all_tags = + let c = constr.pat_desc in let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in - let constrs = get_variant_constructors p.pat_env c.cstr_res in + let constrs = get_variant_constructors constr.pat_env c.cstr_res in let others = List.filter (fun cnstr -> ConstructorTagHashtbl.mem not_tags cnstr.cstr_tag) @@ -897,24 +896,16 @@ let complete_constrs p all_tags = let build_other_constrs env p = let open Patterns.Head in match p.pat_desc with - | Construct { cstr_tag = Cstr_constant _ | Cstr_block _ } -> + | Construct ({ cstr_tag = Cstr_constant _ | Cstr_block _ } as c) -> + let constr = { p with pat_desc = c } in let get_tag q = match q.pat_desc with | Construct c -> c.cstr_tag | _ -> fatal_error "Parmatch.get_tag" in let all_tags = List.map (fun (p,_) -> get_tag p) env in - pat_of_constrs p (complete_constrs p all_tags) + pat_of_constrs p (complete_constrs constr all_tags) | _ -> extra_pat -let complete_constrs p all_tags = - (* This wrapper is here for [Matching]. - - TODO: instead of a simple pattern, it would be nicer to pass - a constructor payload directly: - [Types.constructor_description pattern_data]. - *) - complete_constrs (fst (Patterns.Head.deconstruct p)) all_tags - (* Auxiliary for build_other *) let build_other_constant proj make first next p env = diff --git a/typing/parmatch.mli b/typing/parmatch.mli index 0040f0daf..8736ed2e3 100644 --- a/typing/parmatch.mli +++ b/typing/parmatch.mli @@ -67,7 +67,7 @@ val set_args_erase_mutable : pattern -> pattern list -> pattern list val pat_of_constr : pattern -> constructor_description -> pattern val complete_constrs : - Patterns.Simple.pattern -> + constructor_description pattern_data -> constructor_tag list -> constructor_description list