Merge pull request #9599 from trefis/rematch-complete-constrs

pattern-matching refactoring: refine the type of `complete_constrs`

.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 \

Changes

@@ -80,7 +80,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:

lambda/matching.ml

@@ -1656,7 +1656,7 @@ let divide_constant ctx m =
 (* Matching against a constructor *)
 
 let get_key_constr = function
-  | { pat_desc = Tpat_construct (_, cstr, _) } -> cstr.cstr_tag
+  | { pat_desc = Tpat_construct (_, cstr, _) } -> cstr
   | _ -> assert false
 
 let get_pat_args_constr p rem =
@@ -1693,7 +1693,7 @@ let get_expr_args_constr ~scopes head (arg, _mut) rem =
 let divide_constructor ~scopes ctx pm =
   divide
     (get_expr_args_constr ~scopes)
-    ( = )
+    (fun cstr1 cstr2 -> Types.equal_tag cstr1.cstr_tag cstr2.cstr_tag)
     get_key_constr
     get_pat_args_constr
     ctx pm
@@ -2498,15 +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
-      List.map (pat_of_constr p)
-        (complete_constrs p_simple (List.map get_key_constr 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
 
 (*
@@ -2648,9 +2647,9 @@ let combine_constant loc arg cst partial ctx def
 let split_cases tag_lambda_list =
   let rec split_rec = function
     | [] -> ([], [])
-    | (cstr, act) :: rem -> (
+    | (cstr_tag, act) :: rem -> (
         let consts, nonconsts = split_rec rem in
-        match cstr with
+        match cstr_tag with
         | Cstr_constant n -> ((n, act) :: consts, nonconsts)
         | Cstr_block n -> (consts, (n, act) :: nonconsts)
         | Cstr_unboxed -> (consts, (0, act) :: nonconsts)
@@ -2663,9 +2662,9 @@ let split_cases tag_lambda_list =
 let split_extension_cases tag_lambda_list =
   let rec split_rec = function
     | [] -> ([], [])
-    | (cstr, act) :: rem -> (
+    | (cstr_tag, act) :: rem -> (
         let consts, nonconsts = split_rec rem in
-        match cstr with
+        match cstr_tag with
         | Cstr_extension (path, true) -> ((path, act) :: consts, nonconsts)
         | Cstr_extension (path, false) -> (consts, (path, act) :: nonconsts)
         | _ -> assert false
@@ -2674,13 +2673,15 @@ let split_extension_cases tag_lambda_list =
   split_rec tag_lambda_list
 
 let combine_constructor loc arg pat_env cstr partial ctx def
-    (tag_lambda_list, total1, pats) =
+    (descr_lambda_list, total1, pats) =
+  let tag_lambda (cstr, act) = (cstr.cstr_tag, act) in
   match cstr.cstr_tag with
   | Cstr_extension _ ->
       (* Special cases for extensions *)
       let fail, local_jumps = mk_failaction_neg partial ctx def in
       let lambda1 =
-        let consts, nonconsts = split_extension_cases tag_lambda_list in
+        let consts, nonconsts =
+          split_extension_cases (List.map tag_lambda descr_lambda_list) in
         let default, consts, nonconsts =
           match fail with
           | None -> (
@@ -2715,19 +2716,23 @@ let combine_constructor loc arg pat_env cstr partial ctx def
       (lambda1, Jumps.union local_jumps total1)
   | _ ->
       (* Regular concrete type *)
-      let ncases = List.length tag_lambda_list
+      let ncases = List.length descr_lambda_list
       and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in
       let sig_complete = ncases = nconstrs in
       let fail_opt, fails, local_jumps =
         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 tag_lambda_list = fails @ tag_lambda_list in
-      let consts, nonconsts = split_cases tag_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 lambda1 =
-        match (fail_opt, same_actions tag_lambda_list) with
+        match (fail_opt, same_actions descr_lambda_list) with
         | None, Some act -> act (* Identical actions, no failure *)
         | _ -> (
             match

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 =

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