Matching: propagate constructor descriptions in complete_pats_constrs
This simplifies this particular interface boundary between Matching and Parmatch. (Suggested by Florian Angeletti)master
parent
d333ac83ec
commit
bf95a24739
1
.depend
1
.depend
|
@ -811,7 +811,6 @@ typing/parmatch.cmx : \
|
||||||
typing/parmatch.cmi : \
|
typing/parmatch.cmi : \
|
||||||
typing/types.cmi \
|
typing/types.cmi \
|
||||||
typing/typedtree.cmi \
|
typing/typedtree.cmi \
|
||||||
typing/patterns.cmi \
|
|
||||||
parsing/parsetree.cmi \
|
parsing/parsetree.cmi \
|
||||||
parsing/location.cmi \
|
parsing/location.cmi \
|
||||||
typing/env.cmi \
|
typing/env.cmi \
|
||||||
|
|
2
Changes
2
Changes
|
@ -76,7 +76,7 @@ Working version
|
||||||
|
|
||||||
### Internal/compiler-libs changes:
|
### 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)
|
(Thomas Refis and Gabriel Scherer, review by Florian Angeletti)
|
||||||
|
|
||||||
### Build system:
|
### Build system:
|
||||||
|
|
|
@ -2498,16 +2498,14 @@ let rec list_as_pat = function
|
||||||
| pat :: rem -> { pat with pat_desc = Tpat_or (pat, list_as_pat rem, None) }
|
| pat :: rem -> { pat with pat_desc = Tpat_or (pat, list_as_pat rem, None) }
|
||||||
|
|
||||||
let complete_pats_constrs = function
|
let complete_pats_constrs = function
|
||||||
| p :: _ as pats ->
|
| constr :: _ as constrs ->
|
||||||
(* We (indirectly) call this function
|
let tag_of_constr constr =
|
||||||
from [combine_constructor], and nowhere else.
|
constr.pat_desc.cstr_tag in
|
||||||
So we know patterns have been fully simplified. *)
|
let pat_of_constr cstr =
|
||||||
let p_simple = match (Patterns.General.view p).pat_desc with
|
let open Patterns.Head in
|
||||||
| #Patterns.Simple.view as simple -> { p with pat_desc = simple }
|
to_omega_pattern { constr with pat_desc = Construct cstr } in
|
||||||
| _ -> invalid_arg "complete_pats_constrs" in
|
List.map pat_of_constr
|
||||||
let tag_of_pat p = (get_key_constr p).cstr_tag in
|
(complete_constrs constr (List.map tag_of_constr constrs))
|
||||||
List.map (pat_of_constr p)
|
|
||||||
(complete_constrs p_simple (List.map tag_of_pat pats))
|
|
||||||
| _ -> assert false
|
| _ -> assert false
|
||||||
|
|
||||||
(*
|
(*
|
||||||
|
@ -2725,10 +2723,14 @@ let combine_constructor loc arg pat_env cstr partial ctx def
|
||||||
if sig_complete then
|
if sig_complete then
|
||||||
(None, [], Jumps.empty)
|
(None, [], Jumps.empty)
|
||||||
else
|
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
|
in
|
||||||
let descr_lambda_list = fails @ descr_lambda_list 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 =
|
let lambda1 =
|
||||||
match (fail_opt, same_actions descr_lambda_list) with
|
match (fail_opt, same_actions descr_lambda_list) with
|
||||||
| None, Some act -> act (* Identical actions, no failure *)
|
| None, Some act -> act (* Identical actions, no failure *)
|
||||||
|
|
|
@ -881,11 +881,10 @@ let rec get_variant_constructors env ty =
|
||||||
| _ -> fatal_error "Parmatch.get_variant_constructors"
|
| _ -> fatal_error "Parmatch.get_variant_constructors"
|
||||||
|
|
||||||
(* Sends back a pattern that complements constructor tags all_tag *)
|
(* Sends back a pattern that complements constructor tags all_tag *)
|
||||||
let complete_constrs p all_tags =
|
let complete_constrs constr all_tags =
|
||||||
let open Patterns.Head in
|
let c = constr.pat_desc in
|
||||||
let c = match p.pat_desc with Construct c -> c | _ -> assert false in
|
|
||||||
let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags 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 =
|
let others =
|
||||||
List.filter
|
List.filter
|
||||||
(fun cnstr -> ConstructorTagHashtbl.mem not_tags cnstr.cstr_tag)
|
(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 build_other_constrs env p =
|
||||||
let open Patterns.Head in
|
let open Patterns.Head in
|
||||||
match p.pat_desc with
|
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 =
|
let get_tag q =
|
||||||
match q.pat_desc with
|
match q.pat_desc with
|
||||||
| Construct c -> c.cstr_tag
|
| Construct c -> c.cstr_tag
|
||||||
| _ -> fatal_error "Parmatch.get_tag" in
|
| _ -> fatal_error "Parmatch.get_tag" in
|
||||||
let all_tags = List.map (fun (p,_) -> get_tag p) env 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
|
| _ -> 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 *)
|
(* Auxiliary for build_other *)
|
||||||
|
|
||||||
let build_other_constant proj make first next p env =
|
let build_other_constant proj make first next p env =
|
||||||
|
|
|
@ -67,7 +67,7 @@ val set_args_erase_mutable : pattern -> pattern list -> pattern list
|
||||||
|
|
||||||
val pat_of_constr : pattern -> constructor_description -> pattern
|
val pat_of_constr : pattern -> constructor_description -> pattern
|
||||||
val complete_constrs :
|
val complete_constrs :
|
||||||
Patterns.Simple.pattern ->
|
constructor_description pattern_data ->
|
||||||
constructor_tag list ->
|
constructor_tag list ->
|
||||||
constructor_description list
|
constructor_description list
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue