matching: consolidate all matcher_ functions in a single matcher_head

This commit is delicate and needs a careful review.

The `matcher_of_pattern` function is a temporary measure to reduce the
invasiveness of the patch, and make it easier to review.

(Note for reviewers: in the previous version the Record case had
a funny handling of Any, but it is in fact equivalent to just adding
omegas as we now do in all cases.)

There are two obvious directions for improvement:

- Get rid of matcher_of_pattern and pass a head directly to the
  various make_matching_* functions.

- Try to factorize this code with ctx_matcher which, it is now
  obvious, does essentially the same thing.

Another, less immediate area of attack would be to consider
a presentation of Pattern_head.t where the Any case can be statically
ruled out -- maybe the description could have two levels, one
isomorphic to option (Any or not?) and one for non-any heads.

1 files changed, 97 insertions, 106 deletions

diff --git a/lambda/matching.ml b/lambda/matching.ml
index 104ca1a5b0..19d84384cc 100644
--- a/lambda/matching.ml
+++ b/lambda/matching.ml
@@ -128,8 +128,13 @@ let string_of_lam lam =
   Printlambda.lambda Format.str_formatter lam;
   Format.flush_str_formatter ()
 
+let all_record_labels = function
+  | [] -> fatal_error "Matching.all_record_labels"
+  | { lbl_all } :: _ -> Array.to_list lbl_all
+
 let all_record_args lbls =
   match lbls with
+  | [] -> fatal_error "Matching.all_record_args"
   | (_, { lbl_all }, _) :: _ ->
       let t =
         Array.map
@@ -138,7 +143,13 @@ let all_record_args lbls =
       in
       List.iter (fun ((_, lbl, _) as x) -> t.(lbl.lbl_pos) <- x) lbls;
       Array.to_list t
-  | _ -> fatal_error "Matching.all_record_args"
+
+let rec expand_record p =
+  match p.pat_desc with
+  | Tpat_record (l, _) ->
+      { p with pat_desc = Tpat_record (all_record_args l, Closed) }
+  | Tpat_alias (p, _, _) -> expand_record p
+  | _ -> p
 
 type 'a clause = 'a * lambda
 
@@ -490,13 +501,6 @@ end = struct
   let combine ctx = List.map Row.combine ctx
 
   let ctx_matcher p q rem =
-    let rec expand_record p =
-      match p.pat_desc with
-      | Tpat_record (l, _) ->
-          { p with pat_desc = Tpat_record (all_record_args l, Closed) }
-      | Tpat_alias (p, _, _) -> expand_record p
-      | _ -> p
-    in
     let ph, omegas =
       let ph, p_args = Pattern_head.deconstruct (expand_record p) in
       (ph, List.map (fun _ -> omega) p_args)
@@ -590,6 +594,61 @@ end = struct
   let union pss qss = get_mins Row.le (pss @ qss)
 end
 
+let matcher discr p rem =
+  let ph, args =
+    General.erase p |> expand_record |> Pattern_head.deconstruct
+  in
+  let omegas = omegas (Pattern_head.arity discr) in
+  let yes () = args @ rem in
+  let no () = raise NoMatch in
+  let yesif b =
+    if b then
+      yes ()
+    else
+      no ()
+  in
+  match (Pattern_head.desc discr, Pattern_head.desc ph) with
+  | Any, _ -> rem
+  | ( ( Constant _ | Construct _ | Variant _ | Lazy | Array _ | Record _
+      | Tuple _ ),
+      Any ) ->
+      omegas @ rem
+  | Constant cst, Constant cst' -> yesif (const_compare cst cst' = 0)
+  | Constant _, (Construct _ | Variant _ | Lazy | Array _ | Record _ | Tuple _)
+    ->
+      no ()
+  | Construct cstr, Construct cstr' ->
+      (* NB: may_equal_constr considers (potential) constructor rebinding;
+          Types.may_equal_constr does check that the arities are the same,
+          preserving row-size coherence. *)
+      yesif (Types.may_equal_constr cstr cstr')
+  | Construct _, (Constant _ | Variant _ | Lazy | Array _ | Record _ | Tuple _)
+    ->
+      no ()
+  | Variant { tag; has_arg }, Variant { tag = tag'; has_arg = has_arg' } ->
+      yesif (tag = tag' && has_arg = has_arg')
+  | Variant _, (Constant _ | Construct _ | Lazy | Array _ | Record _ | Tuple _)
+    ->
+      no ()
+  | Array n1, Array n2 -> yesif (n1 = n2)
+  | Array _, (Constant _ | Construct _ | Variant _ | Lazy | Record _ | Tuple _)
+    ->
+      no ()
+  | Tuple n1, Tuple n2 -> yesif (n1 = n2)
+  | Tuple _, (Constant _ | Construct _ | Variant _ | Lazy | Array _ | Record _)
+    ->
+      no ()
+  | Record l, Record l' ->
+      (* we already expanded the record fully *)
+      yesif (List.length l = List.length l')
+  | Record _, (Constant _ | Construct _ | Variant _ | Lazy | Array _ | Tuple _)
+    ->
+      no ()
+  | Lazy, Lazy -> yes ()
+  | Lazy, (Constant _ | Construct _ | Variant _ | Array _ | Record _ | Tuple _)
+    ->
+      no ()
+
 let rec flatten_pat_line size p k =
   match p.pat_desc with
   | Tpat_any -> omegas size :: k
@@ -639,8 +698,7 @@ module Default_environment : sig
 
   val cons : matrix -> int -> t -> t
 
-  val specialize :
-    int -> (Simple.pattern -> pattern list -> pattern list) -> t -> t
+  val specialize : Pattern_head.t -> t -> t
 
   val pop_column : t -> t
 
@@ -750,7 +808,7 @@ end = struct
     in
     filter_rec pss
 
-  let specialize arity matcher env =
+  let specialize_ arity matcher env =
     let rec make_rec = function
       | [] -> []
       | (([] :: _), i) :: _ -> [ ([ [] ], i) ]
@@ -770,7 +828,10 @@ end = struct
     in
     make_rec env
 
-  let pop_column def = specialize 0 (fun _p rem -> rem) def
+  let specialize head def =
+    specialize_ (Pattern_head.arity head) (matcher head) def
+
+  let pop_column def = specialize_ 0 (fun _p rem -> rem) def
 
   let pop_compat p def =
     let compat_matcher q rem =
@@ -779,7 +840,7 @@ end = struct
       else
         raise NoMatch
     in
-    specialize 0 compat_matcher def
+    specialize_ 0 compat_matcher def
 
   let pop = function
     | [] -> None
@@ -1631,10 +1692,6 @@ let divide_line make_ctx make get_args discr ctx
    There is one set of functions per matching style
    (constants, constructors etc.)
 
-   - matcher functions are arguments to Default_environment.specialize (for
-   default handlers)
-   They may raise NoMatch and perform the full matching (selection + arguments).
-
    - get_args and get_key are for the compiled matrices, note that
    selection and getting arguments are separated.
 
@@ -1642,12 +1699,6 @@ let divide_line make_ctx make get_args discr ctx
    new  ``pattern_matching'' records.
 *)
 
-let matcher_const cst p rem =
-  match p.pat_desc with
-  | `Constant c1 when const_compare c1 cst = 0 -> rem
-  | `Any -> rem
-  | _ -> raise NoMatch
-
 let get_key_constant caller = function
   | { pat_desc = Tpat_constant cst } -> cst
   | p ->
@@ -1657,13 +1708,12 @@ let get_key_constant caller = function
 
 let get_args_constant _ rem = rem
 
+let matcher_of_pattern p = fst (Pattern_head.deconstruct p)
+
 let make_constant_matching p def ctx = function
   | [] -> fatal_error "Matching.make_constant_matching"
   | _ :: argl ->
-      let def =
-        Default_environment.specialize 0
-          (matcher_const (get_key_constant "make" p))
-          def
+      let def = Default_environment.specialize (matcher_of_pattern p) def
       and ctx = Context.specialize p ctx in
       { pm = { cases = []; args = argl; default = def };
         ctx;
@@ -1696,20 +1746,6 @@ let get_args_constr p rem =
   | { pat_desc = Tpat_construct (_, _, args) } -> args @ rem
   | _ -> assert false
 
-(* NB: matcher_constr applies to default matrices.
-
-       In that context, matching by constructors of extensible
-       types degrades to arity checking, due to potential rebinding.
-       This comparison is performed by Types.may_equal_constr.
-*)
-
-let matcher_constr cstr q rem =
-  match q.pat_desc with
-  | `Construct (_, cstr', args) when Types.may_equal_constr cstr cstr' ->
-      args @ rem
-  | `Any -> Parmatch.omegas cstr.cstr_arity @ rem
-  | _ -> raise NoMatch
-
 let make_constr_matching ~scopes p def ctx = function
   | [] -> fatal_error "Matching.make_constr_matching"
   | (arg, _mut) :: argl ->
@@ -1731,9 +1767,7 @@ let make_constr_matching ~scopes p def ctx = function
       { pm =
           { cases = [];
             args = newargs;
-            default =
-              Default_environment.specialize cstr.cstr_arity
-                (matcher_constr cstr) def
+            default = Default_environment.specialize (matcher_of_pattern p) def
           };
         ctx = Context.specialize p ctx;
         discr = normalize_pat p
@@ -1745,34 +1779,20 @@ let divide_constructor ~scopes ctx pm =
 
 (* Matching against a variant *)
 
-let matcher_variant_const lab p rem =
-  match p.pat_desc with
-  | `Variant (lab1, _, _) when lab1 = lab -> rem
-  | `Any -> rem
-  | _ -> raise NoMatch
-
-let make_variant_matching_constant p lab def ctx = function
+let make_variant_matching_constant p def ctx = function
   | [] -> fatal_error "Matching.make_variant_matching_constant"
   | _ :: argl ->
-      let def =
-        Default_environment.specialize 0 (matcher_variant_const lab) def
+      let def = Default_environment.specialize (matcher_of_pattern p) def
       and ctx = Context.specialize p ctx in
       { pm = { cases = []; args = argl; default = def };
         ctx;
         discr = normalize_pat p
       }
 
-let matcher_variant_nonconst lab p rem =
-  match p.pat_desc with
-  | `Variant (lab1, Some arg, _) when lab1 = lab -> arg :: rem
-  | `Any -> omega :: rem
-  | _ -> raise NoMatch
-
-let make_variant_matching_nonconst ~scopes p lab def ctx = function
+let make_variant_matching_nonconst ~scopes p def ctx = function
   | [] -> fatal_error "Matching.make_variant_matching_nonconst"
   | (arg, _mut) :: argl ->
-      let def =
-        Default_environment.specialize 1 (matcher_variant_nonconst lab) def
+      let def = Default_environment.specialize (matcher_of_pattern p) def
       and ctx = Context.specialize p ctx
       and loc = of_location ~scopes p.pat_loc in
       { pm =
@@ -1807,11 +1827,11 @@ let divide_variant ~scopes row ctx { cases = cl; args; default = def } =
           match pato with
           | None ->
               add_in_div
-                (make_variant_matching_constant p lab def ctx)
+                (make_variant_matching_constant p def ctx)
                 ( = ) (Cstr_constant tag) (patl, action) variants
           | Some pat ->
               add_in_div
-                (make_variant_matching_nonconst ~scopes p lab def ctx)
+                (make_variant_matching_nonconst ~scopes p def ctx)
                 ( = ) (Cstr_block tag)
                 (pat :: patl, action)
                 variants
@@ -1831,7 +1851,7 @@ let make_var_matching def = function
   | _ :: argl ->
       { cases = [];
         args = argl;
-        default = Default_environment.specialize 0 get_args_var def
+        default = Default_environment.specialize Pattern_head.omega def
       }
 
 let divide_var ctx pm =
@@ -1845,12 +1865,6 @@ let get_arg_lazy p rem =
   | { pat_desc = Tpat_lazy arg } -> arg :: rem
   | _ -> assert false
 
-let matcher_lazy p rem =
-  match p.pat_desc with
-  | `Any -> omega :: rem
-  | `Lazy arg -> arg :: rem
-  | _ -> raise NoMatch
-
 (* Inlining the tag tests before calling the primitive that works on
    lazy blocks. This is also used in translcore.ml.
    No other call than Obj.tag when the value has been forced before.
@@ -1984,16 +1998,17 @@ let inline_lazy_force arg loc =
          tables (~ 250 elts); conditionals are better *)
     inline_lazy_force_cond arg loc
 
-let make_lazy_matching def = function
+let make_lazy_matching p def = function
   | [] -> fatal_error "Matching.make_lazy_matching"
   | (arg, _mut) :: argl ->
       { cases = [];
         args = (inline_lazy_force arg Loc_unknown, Strict) :: argl;
-        default = Default_environment.specialize 1 matcher_lazy def
+        default = Default_environment.specialize (matcher_of_pattern p) def
       }
 
 let divide_lazy p ctx pm =
-  divide_line (Context.specialize p) make_lazy_matching get_arg_lazy p ctx pm
+  divide_line (Context.specialize p) (make_lazy_matching p) get_arg_lazy p ctx
+    pm
 
 (* Matching against a tuple pattern *)
 
@@ -2003,13 +2018,7 @@ let get_args_tuple arity p rem =
   | { pat_desc = Tpat_tuple args } -> args @ rem
   | _ -> assert false
 
-let matcher_tuple arity p rem =
-  match p.pat_desc with
-  | `Any -> omegas arity @ rem
-  | `Tuple args when List.length args = arity -> args @ rem
-  | _ -> raise NoMatch
-
-let make_tuple_matching loc arity def = function
+let make_tuple_matching p loc arity def = function
   | [] -> fatal_error "Matching.make_tuple_matching"
   | (arg, _mut) :: argl ->
       let rec make_args pos =
@@ -2020,13 +2029,12 @@ let make_tuple_matching loc arity def = function
       in
       { cases = [];
         args = make_args 0;
-        default =
-          Default_environment.specialize arity (matcher_tuple arity) def
+        default = Default_environment.specialize (matcher_of_pattern p) def
       }
 
 let divide_tuple ~scopes arity p ctx pm =
   divide_line (Context.specialize p)
-    (make_tuple_matching (of_location ~scopes p.pat_loc) arity)
+    (make_tuple_matching p (of_location ~scopes p.pat_loc) arity)
     (get_args_tuple arity) p ctx pm
 
 (* Matching against a record pattern *)
@@ -2043,16 +2051,7 @@ let get_args_record num_fields p rem =
       record_matching_line num_fields lbl_pat_list @ rem
   | _ -> assert false
 
-let matcher_record num_fields p rem =
-  match p.pat_desc with
-  | `Any -> record_matching_line num_fields [] @ rem
-  | `Record ([], _) when num_fields = 0 -> rem
-  | `Record (((_, lbl, _) :: _ as lbl_pat_list), _)
-    when Array.length lbl.lbl_all = num_fields ->
-      record_matching_line num_fields lbl_pat_list @ rem
-  | _ -> raise NoMatch
-
-let make_record_matching loc all_labels def = function
+let make_record_matching p loc all_labels def = function
   | [] -> fatal_error "Matching.make_record_matching"
   | (arg, _mut) :: argl ->
       let rec make_args pos =
@@ -2077,16 +2076,14 @@ let make_record_matching loc all_labels def = function
           in
           (access, str) :: make_args (pos + 1)
       in
-      let nfields = Array.length all_labels in
-      let def =
-        Default_environment.specialize nfields (matcher_record nfields) def
-      in
+      let p = expand_record p in
+      let def = Default_environment.specialize (matcher_of_pattern p) def in
       { cases = []; args = make_args 0; default = def }
 
 let divide_record ~scopes all_labels p ctx pm =
   let get_args = get_args_record (Array.length all_labels) in
   divide_line (Context.specialize p)
-    (make_record_matching (of_location ~scopes p.pat_loc) all_labels)
+    (make_record_matching p (of_location ~scopes p.pat_loc) all_labels)
     get_args p ctx pm
 
 (* Matching against an array pattern *)
@@ -2100,12 +2097,6 @@ let get_args_array p rem =
   | { pat_desc = Tpat_array patl } -> patl @ rem
   | _ -> assert false
 
-let matcher_array len p rem =
-  match p.pat_desc with
-  | `Array args when List.length args = len -> args @ rem
-  | `Any -> Parmatch.omegas len @ rem
-  | _ -> raise NoMatch
-
 let make_array_matching ~scopes kind p def ctx = function
   | [] -> fatal_error "Matching.make_array_matching"
   | (arg, _mut) :: argl ->
@@ -2121,7 +2112,7 @@ let make_array_matching ~scopes kind p def ctx = function
             StrictOpt )
           :: make_args (pos + 1)
       in
-      let def = Default_environment.specialize len (matcher_array len) def
+      let def = Default_environment.specialize (matcher_of_pattern p) def
       and ctx = Context.specialize p ctx in
       { pm = { cases = []; args = make_args 0; default = def };
         ctx;