Merge pull request #8766 from trefis/pattern_head

Parmatch: introduce a type for simplified pattern heads

2 files changed, 530 insertions, 388 deletions

diff --git a/Changes b/Changes
index 918bdf579f..e095136a78 100644
--- a/Changes
+++ b/Changes
@@ -26,6 +26,10 @@ Working version
 - #8677: Use unsigned comparisons in amd64 and i386 emitter of Lcondbranch3.
   (Greta Yorsh, review by Xavier Leroy)
 
+- #8766: Parmatch: introduce a type for simplified pattern heads
+  (Gabriel Scherer and Thomas Refis, review by Stephen Dolan and
+   Florian Angeletti)
+
 ### Code generation and optimizations:
 
 - #8672: Optimise Switch code generation on booleans.
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index d7a9d7e2c0..1d2453b044 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -42,7 +42,158 @@ let rec omegas i =
 
 let omega_list l = List.map (fun _ -> omega) l
 
-let zero = make_pat (Tpat_constant (Const_int 0)) Ctype.none Env.empty
+module Pattern_head : sig
+  type desc =
+    | Any
+    | Construct of constructor_description
+    | Constant of constant
+    | Tuple of int
+    | Record of label_description list
+    | Variant of
+        { tag: label; has_arg: bool;
+          cstr_row: row_desc ref;
+          type_row : unit -> row_desc; }
+          (* the row of the type may evolve if [close_variant] is called,
+             hence the (unit -> ...) delay *)
+    | Array of int
+    | Lazy
+
+  type t
+
+  val desc : t -> desc
+  val env : t -> Env.t
+  val loc : t -> Location.t
+  val typ : t -> Types.type_expr
+
+  (** [deconstruct p] returns the head of [p] and the list of sub patterns.
+
+      @raises [Invalid_arg _] if [p] is an or- or an exception-pattern.  *)
+  val deconstruct : pattern -> t * pattern list
+
+  (** reconstructs a pattern, putting wildcards as sub-patterns. *)
+  val to_omega_pattern : t -> pattern
+
+  val make
+    :  loc:Location.t
+    -> typ:Types.type_expr
+    -> env:Env.t
+    -> desc
+    -> t
+
+  val omega : t
+
+end = struct
+  type desc =
+    | Any
+    | Construct of constructor_description
+    | Constant of constant
+    | Tuple of int
+    | Record of label_description list
+    | Variant of
+        { tag: label;
+          has_arg: bool;
+          cstr_row: row_desc ref;
+          type_row: unit -> row_desc; }
+    | Array of int
+    | Lazy
+
+  type t = {
+    desc: desc;
+    typ : Types.type_expr;
+    loc : Location.t;
+    env : Env.t;
+    attributes : attributes;
+  }
+
+  let desc { desc } = desc
+  let env { env } = env
+  let loc { loc } = loc
+  let typ { typ } = typ
+
+  let deconstruct q =
+    let rec deconstruct_desc = function
+      | Tpat_any
+      | Tpat_var _ -> Any, []
+      | Tpat_constant c -> Constant c, []
+      | Tpat_alias (p,_,_) -> deconstruct_desc p.pat_desc
+      | Tpat_tuple args ->
+          Tuple (List.length args), args
+      | Tpat_construct (_, c, args) ->
+          Construct c, args
+      | Tpat_variant (tag, arg, cstr_row) ->
+          let has_arg, pats =
+            match arg with
+            | None -> false, []
+            | Some a -> true, [a]
+          in
+          let type_row () =
+            match Ctype.expand_head q.pat_env q.pat_type with
+              | {desc = Tvariant type_row} -> Btype.row_repr type_row
+              | _ -> assert false
+          in
+          Variant {tag; has_arg; cstr_row; type_row}, pats
+      | Tpat_array args ->
+          Array (List.length args), args
+      | Tpat_record (largs, _) ->
+          let lbls = List.map (fun (_,lbl,_) -> lbl) largs in
+          let pats = List.map (fun (_,_,pat) -> pat) largs in
+          Record lbls, pats
+      | Tpat_lazy p ->
+          Lazy, [p]
+      | Tpat_or _ -> invalid_arg "Parmatch.Pattern_head.deconstruct: (P | Q)"
+      | Tpat_exception _ ->
+          invalid_arg "Parmatch.Pattern_head.deconstruct: (exception P)"
+    in
+    let desc, pats = deconstruct_desc q.pat_desc in
+    { desc; typ = q.pat_type; loc = q.pat_loc;
+      env = q.pat_env; attributes = q.pat_attributes }, pats
+
+  let to_omega_pattern t =
+    let pat_desc =
+      match t.desc with
+      | Any -> Tpat_any
+      | Lazy -> Tpat_lazy omega
+      | Constant c -> Tpat_constant c
+      | Tuple n -> Tpat_tuple (omegas n)
+      | Array n -> Tpat_array (omegas n)
+      | Construct c ->
+          let lid_loc = Location.mkloc (Longident.Lident c.cstr_name) t.loc in
+          Tpat_construct (lid_loc, c, omegas c.cstr_arity)
+      | Variant { tag; has_arg; cstr_row } ->
+          let arg_opt = if has_arg then Some omega else None in
+          Tpat_variant (tag, arg_opt, cstr_row)
+      | Record lbls ->
+          let lst =
+            List.map (fun lbl ->
+              let lid_loc =
+                Location.mkloc (Longident.Lident lbl.lbl_name) t.loc
+              in
+              (lid_loc, lbl, omega)
+            ) lbls
+          in
+          Tpat_record (lst, Closed)
+    in
+    { pat_desc; pat_type = t.typ; pat_loc = t.loc; pat_extra = [];
+      pat_env = t.env; pat_attributes = t.attributes }
+
+  let make ~loc ~typ ~env desc =
+    { desc; loc; typ; env; attributes = [] }
+
+  let omega =
+    { desc = Any
+    ; loc = Location.none
+    ; typ = Ctype.none
+    ; env = Env.empty
+    ; attributes = []
+    }
+end
+
+(*
+  Normalize a pattern ->
+   all arguments are omega (simple pattern) and no more variables
+*)
+
+let normalize_pat p = Pattern_head.(to_omega_pattern @@ fst @@ deconstruct p)
 
 (*******************)
 (* Coherence check *)
@@ -121,14 +272,11 @@ let zero = make_pat (Tpat_constant (Const_int 0)) Ctype.none Env.empty
 *)
 let all_coherent column =
   let coherent_heads hp1 hp2 =
-    match hp1.pat_desc, hp2.pat_desc with
-    | (Tpat_var _ | Tpat_alias _ | Tpat_or _), _
-    | _, (Tpat_var _ | Tpat_alias _ | Tpat_or _) ->
-      assert false
-    | Tpat_construct (_, c, _), Tpat_construct (_, c', _) ->
+    match Pattern_head.desc hp1, Pattern_head.desc hp2 with
+    | Construct c, Construct c' ->
       c.cstr_consts = c'.cstr_consts
       && c.cstr_nonconsts = c'.cstr_nonconsts
-    | Tpat_constant c1, Tpat_constant c2 -> begin
+    | Constant c1, Constant c2 -> begin
         match c1, c2 with
         | Const_char _, Const_char _
         | Const_int _, Const_int _
@@ -145,22 +293,21 @@ let all_coherent column =
           | Const_float _
           | Const_string _), _ -> false
       end
-    | Tpat_tuple l1, Tpat_tuple l2 -> List.length l1 = List.length l2
-    | Tpat_record ((_, lbl1, _) :: _, _), Tpat_record ((_, lbl2, _) :: _, _) ->
+    | Tuple l1, Tuple l2 -> l1 = l2
+    | Record (lbl1 :: _), Record (lbl2 :: _) ->
       Array.length lbl1.lbl_all = Array.length lbl2.lbl_all
-    | Tpat_any, _
-    | _, Tpat_any
-    | Tpat_record ([], _), Tpat_record ([], _)
-    | Tpat_variant _, Tpat_variant _
-    | Tpat_array _, Tpat_array _
-    | Tpat_lazy _, Tpat_lazy _ -> true
+    | Any, _
+    | _, Any
+    | Record [], Record []
+    | Variant _, Variant _
+    | Array _, Array _
+    | Lazy, Lazy -> true
     | _, _ -> false
   in
   match
     List.find (fun head_pat ->
-      match head_pat.pat_desc with
-      | Tpat_var _ | Tpat_alias _ | Tpat_or _ -> assert false
-      | Tpat_any -> false
+      match Pattern_head.desc head_pat with
+      | Any -> false
       | _ -> true
     ) column
   with
@@ -171,7 +318,7 @@ let all_coherent column =
     List.for_all (coherent_heads discr_pat) column
 
 let first_column simplified_matrix =
-  List.map fst simplified_matrix
+  List.map (fun ((head, _args), _rest) -> head) simplified_matrix
 
 (***********************)
 (* Compatibility check *)
@@ -239,9 +386,10 @@ let first_column simplified_matrix =
 
 let is_absent tag row = Btype.row_field tag !row = Rabsent
 
-let is_absent_pat p = match p.pat_desc with
-| Tpat_variant (tag, _, row) -> is_absent tag row
-| _ -> false
+let is_absent_pat d =
+  match Pattern_head.desc d with
+  | Variant { tag; cstr_row; _ } -> is_absent tag cstr_row
+  | _ -> false
 
 let const_compare x y =
   match x,y with
@@ -358,93 +506,58 @@ let get_constructor_type_path ty tenv =
 (****************************)
 
 (* Check top matching *)
-let simple_match p1 p2 =
-  match p1.pat_desc, p2.pat_desc with
-  | Tpat_construct(_, c1, _), Tpat_construct(_, c2, _) ->
+let simple_match d h =
+  match Pattern_head.desc d, Pattern_head.desc h with
+  | Construct c1, Construct c2 ->
       Types.equal_tag c1.cstr_tag c2.cstr_tag
-  | Tpat_variant(l1, _, _), Tpat_variant(l2, _, _) ->
-      l1 = l2
-  | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
-  | Tpat_lazy _, Tpat_lazy _ -> true
-  | Tpat_record _ , Tpat_record _ -> true
-  | Tpat_tuple p1s, Tpat_tuple p2s
-  | Tpat_array p1s, Tpat_array p2s -> List.length p1s = List.length p2s
-  | _, (Tpat_any | Tpat_var(_)) -> true
+  | Variant { tag = t1; _ }, Variant { tag = t2 } ->
+      t1 = t2
+  | Constant c1, Constant c2 -> const_compare c1 c2 = 0
+  | Lazy, Lazy -> true
+  | Record _, Record _ -> true
+  | Tuple len1, Tuple len2
+  | Array len1, Array len2 -> len1 = len2
+  | _, Any -> true
   | _, _ -> false
 
 
 
-
 (* extract record fields as a whole *)
-let record_arg p = match p.pat_desc with
-| Tpat_any -> []
-| Tpat_record (args,_) -> args
+let record_arg ph = match Pattern_head.desc ph with
+| Any -> []
+| Record args -> args
 | _ -> fatal_error "Parmatch.as_record"
 
 
-(* Raise Not_found when pos is not present in arg *)
-let get_field pos arg =
-  let _,_, p = List.find (fun (_,lbl,_) -> pos = lbl.lbl_pos) arg in
-  p
-
-let extract_fields omegas arg =
-  List.map
-    (fun (_,lbl,_) ->
-      try
-        get_field lbl.lbl_pos arg
-      with Not_found -> omega)
-    omegas
+let extract_fields lbls arg =
+  let get_field pos arg =
+    match List.find (fun (lbl,_) -> pos = lbl.lbl_pos) arg with
+    | _, p -> p
+    | exception Not_found -> omega
+  in
+  List.map (fun lbl -> get_field lbl.lbl_pos arg) lbls
 
 (* Build argument list when p2 >= p1, where p1 is a simple pattern *)
-let rec simple_match_args p1 p2 = match p2.pat_desc with
-| Tpat_alias (p2,_,_) -> simple_match_args p1 p2
-| Tpat_construct(_, _, args) -> args
-| Tpat_variant(_, Some arg, _) -> [arg]
-| Tpat_tuple(args)  -> args
-| Tpat_record(args,_) ->  extract_fields (record_arg p1) args
-| Tpat_array(args) -> args
-| Tpat_lazy arg -> [arg]
-| (Tpat_any | Tpat_var(_)) ->
-    begin match p1.pat_desc with
-      Tpat_construct(_, _,args) -> omega_list args
-    | Tpat_variant(_, Some _, _) -> [omega]
-    | Tpat_tuple(args) -> omega_list args
-    | Tpat_record(args,_) ->  omega_list args
-    | Tpat_array(args) ->  omega_list args
-    | Tpat_lazy _ -> [omega]
-    | _ -> []
+let simple_match_args discr head args = match Pattern_head.desc head with
+| Constant _ -> []
+| Construct _
+| Variant _
+| Tuple _
+| Array _
+| Lazy -> args
+| Record lbls ->  extract_fields (record_arg discr) (List.combine lbls args)
+| Any ->
+    begin match Pattern_head.desc discr with
+    | Construct cstr -> omegas cstr.cstr_arity
+    | Variant { has_arg = true }
+    | Lazy -> [omega]
+    | Record lbls ->  omega_list lbls
+    | Array len
+    | Tuple len -> omegas len
+    | Variant { has_arg = false }
+    | Any
+    | Constant _ -> []
     end
-| _ -> []
-
-(*
-  Normalize a pattern ->
-   all arguments are omega (simple pattern) and no more variables
-*)
-
-let rec normalize_pat q = match q.pat_desc with
-  | Tpat_any | Tpat_constant _ -> q
-  | Tpat_var _ -> make_pat Tpat_any q.pat_type q.pat_env
-  | Tpat_alias (p,_,_) -> normalize_pat p
-  | Tpat_tuple (args) ->
-      make_pat (Tpat_tuple (omega_list args)) q.pat_type q.pat_env
-  | Tpat_construct  (lid, c,args) ->
-      make_pat
-        (Tpat_construct (lid, c,omega_list args))
-        q.pat_type q.pat_env
-  | Tpat_variant (l, arg, row) ->
-      make_pat (Tpat_variant (l, Option.map (fun _ -> omega) arg, row))
-        q.pat_type q.pat_env
-  | Tpat_array (args) ->
-      make_pat (Tpat_array (omega_list args))  q.pat_type q.pat_env
-  | Tpat_record (largs, closed) ->
-      make_pat
-        (Tpat_record (List.map (fun (lid,lbl,_) ->
-                                 lid, lbl,omega) largs, closed))
-        q.pat_type q.pat_env
-  | Tpat_lazy _ ->
-      make_pat (Tpat_lazy omega) q.pat_type q.pat_env
-  | Tpat_or _
-  | Tpat_exception _ -> fatal_error "Parmatch.normalize_pat"
 
 (* Consider a pattern matrix whose first column has been simplified to contain
    only _ or a head constructor
@@ -456,14 +569,14 @@ let rec normalize_pat q = match q.pat_desc with
    We build a normalized /discriminating/ pattern from a pattern [q] by folding
    over the first column of the matrix, "refining" [q] as we go:
 
-   - when we encounter a row starting with [Tpat_tuple] or [Tpat_lazy] then we
-   can stop and return that pattern, as we cannot refine any further. Indeed,
+   - when we encounter a row starting with [Tuple] or [Lazy] then we
+   can stop and return that head, as we cannot refine any further. Indeed,
    these constructors are alone in their signature, so they will subsume
-   whatever other pattern we might find, as well as the pattern we're threading
+   whatever other head we might find, as well as the head we're threading
    along.
 
-   - when we find a [Tpat_record] then it is a bit more involved: it is also
-   alone in its signature, however it might only be matching a subset of the
+   - when we find a [Record] then it is a bit more involved: it is also alone
+   in its signature, however it might only be matching a subset of the
    record fields. We use these fields to refine our accumulator and keep going
    as another row might match on different fields.
 
@@ -476,40 +589,38 @@ let rec normalize_pat q = match q.pat_desc with
 let discr_pat q pss =
   let rec refine_pat acc = function
     | [] -> acc
-    | (head, _) :: rows ->
-      match head.pat_desc with
-      | Tpat_or _ | Tpat_var _ | Tpat_alias _ -> assert false
-      | Tpat_any -> refine_pat acc rows
-      | Tpat_tuple _ | Tpat_lazy _ -> normalize_pat head
-      | Tpat_record (largs, closed) ->
+    | ((head, _), _) :: rows ->
+      match Pattern_head.desc head with
+      | Any -> refine_pat acc rows
+      | Tuple _ | Lazy -> head
+      | Record lbls ->
         (* N.B. we could make this case "simpler" by refining the record case
            using [all_record_args].
            In which case we wouldn't need to fold over the first column for
            records.
            However it makes the witness we generate for the exhaustivity warning
            less pretty. *)
-        let new_omegas =
-          List.fold_right
-            (fun (lid, lbl,_) r ->
-               try
-                 let _ = get_field lbl.lbl_pos r in
-                 r
-               with Not_found ->
-                 (lid, lbl,omega)::r)
-            largs (record_arg acc)
+        let fields =
+          List.fold_right (fun lbl r ->
+            if List.exists (fun l -> l.lbl_pos = lbl.lbl_pos) r then
+              r
+            else
+              lbl :: r
+          ) lbls (record_arg acc)
         in
-        let new_acc =
-          make_pat (Tpat_record (new_omegas, closed)) head.pat_type head.pat_env
+        let d =
+          let open Pattern_head in
+          make ~loc:(loc head) ~typ:(typ head) ~env:(env head) (Record fields)
         in
-        refine_pat new_acc rows
+        refine_pat d rows
       | _ -> acc
   in
-  let q = normalize_pat q in
-  (* short-circuiting: clearly if we have anything other than [Tpat_record] or
-     [Tpat_any] to start with, we're not going to be able refine at all. So
+  let q, _ = Pattern_head.deconstruct q in
+  match Pattern_head.desc q with
+  (* short-circuiting: clearly if we have anything other than [Record] or
+     [Any] to start with, we're not going to be able refine at all. So
      there's no point going over the matrix. *)
-  match q.pat_desc with
-  | Tpat_any | Tpat_record _ -> refine_pat q pss
+  | Any | Record _ -> refine_pat q pss
   | _ -> q
 
 (*
@@ -585,10 +696,8 @@ and set_args_erase_mutable q r = do_set_args true q r
    p3 :: r3...
 
    Simplify the first column [p1 p2 p3] by splitting all or-patterns.
-   The result is a list of couples
-     (simple pattern, rest of row)
-   where a "simple pattern" starts with either the catch-all pattern omega (_)
-   or a head constructor.
+   The result is a list of pairs
+     ((pattern head, arguments), rest of row)
 
    For example,
      x :: r1
@@ -596,19 +705,21 @@ and set_args_erase_mutable q r = do_set_args true q r
      (None as x) as y :: r3
      (Some x | (None as x)) :: r4
    becomes
-     (_, r1)
-     (Some _, r2)
-     (None, r3)
-     (Some x, r4)
-     (None, r4)
+     ((   _ , [ ] ), r1)
+     (( Some, [_] ), r2)
+     (( None, [ ] ), r3)
+     (( Some, [x] ), r4)
+     (( None, [ ] ), r4)
  *)
 let simplify_head_pat ~add_column p ps k =
   let rec simplify_head_pat p ps k =
     match p.pat_desc with
-    | Tpat_alias (p,_,_) -> simplify_head_pat p ps k
-    | Tpat_var (_,_) -> add_column omega ps k
+    | Tpat_alias (p,_,_) ->
+        (* We have to handle aliases here, because there can be or-patterns
+           underneath, that [Pattern_head.deconstruct] won't handle. *)
+        simplify_head_pat p ps k
     | Tpat_or (p1,p2,_) -> simplify_head_pat p1 ps (simplify_head_pat p2 ps k)
-    | _ -> add_column p ps k
+    | _ -> add_column (Pattern_head.deconstruct p) ps k
   in simplify_head_pat p ps k
 
 let rec simplify_first_col = function
@@ -619,23 +730,20 @@ let rec simplify_first_col = function
       simplify_head_pat ~add_column p ps (simplify_first_col rows)
 
 
-(* Builds the specialized matrix of [pss] according to pattern [q].
+(* Builds the specialized matrix of [pss] according to the discriminating
+   pattern head [d].
    See section 3.1 of http://moscova.inria.fr/~maranget/papers/warn/warn.pdf
 
    NOTES:
-   - expects [pss] to be a "simplified matrix", cf. [simplify_first_col]
-   - [q] was produced by [discr_pat]
    - we are polymorphic on the type of matrices we work on, in particular a row
    might not simply be a [pattern list]. That's why we have the [extend_row]
    parameter.
 *)
-let build_specialized_submatrix ~extend_row q pss =
+let build_specialized_submatrix ~extend_row discr pss =
   let rec filter_rec = function
-    | ({pat_desc = (Tpat_alias _ | Tpat_or _ | Tpat_var _) }, _) :: _ ->
-        assert false
-    | (p, ps) :: pss ->
-        if simple_match q p
-        then extend_row (simple_match_args q p) ps :: filter_rec pss
+    | ((head, args), ps) :: pss ->
+        if simple_match discr head
+        then extend_row (simple_match_args discr head args) ps :: filter_rec pss
         else filter_rec pss
     | _ -> [] in
   filter_rec pss
@@ -645,7 +753,7 @@ let build_specialized_submatrix ~extend_row q pss =
 *)
 type 'matrix specialized_matrices = {
   default : 'matrix;
-  constrs : (pattern * 'matrix) list;
+  constrs : (Pattern_head.t * 'matrix) list;
 }
 
 (* Consider a pattern matrix whose first column has been simplified
@@ -673,50 +781,52 @@ type 'matrix specialized_matrices = {
    See the documentation of [build_specialized_submatrix] for an explanation of
    the [extend_row] parameter.
 *)
-let build_specialized_submatrices ~extend_row q rows =
-  let extend_group discr p r rs =
-    let r = extend_row (simple_match_args discr p) r in
+let build_specialized_submatrices ~extend_row discr rows =
+  let extend_group discr p args r rs =
+    let r = extend_row (simple_match_args discr p args) r in
     (discr, r :: rs)
   in
 
   (* insert a row of head [p] and rest [r] into the right group *)
-  let rec insert_constr p r = function
+  let rec insert_constr head args r = function
     | [] ->
       (* if no group matched this row, it has a head constructor that
          was never seen before; add a new sub-matrix for this head *)
-      [extend_group (normalize_pat p) p r []]
+      [extend_group head head args r []]
     | (q0,rs) as bd::env ->
-      if simple_match q0 p
-      then extend_group q0 p r rs :: env
-      else bd :: insert_constr p r env
+      if simple_match q0 head
+      then extend_group q0 head args r rs :: env
+      else bd :: insert_constr head args r env
   in
 
   (* insert a row of head omega into all groups *)
   let insert_omega r env =
-    List.map (fun (q0,rs) -> extend_group q0 omega r rs) env
+    List.map (fun (q0,rs) -> extend_group q0 Pattern_head.omega [] r rs) env
   in
 
   let rec form_groups constr_groups omega_tails = function
     | [] -> (constr_groups, omega_tails)
-    | ({pat_desc=(Tpat_var _|Tpat_alias _|Tpat_or _)},_)::_ -> assert false
-    | ({pat_desc=Tpat_any}, tail) :: rest ->
-       (* note that calling insert_omega here would be wrong
-          as some groups may not have been formed yet, if the
-          first row with this head pattern comes after in the list *)
-       form_groups constr_groups (tail :: omega_tails) rest
-    | (p,r) :: rest ->
-      form_groups (insert_constr p r constr_groups) omega_tails rest
+    | ((head, args), tail) :: rest ->
+        match Pattern_head.desc head with
+        | Any ->
+            (* note that calling insert_omega here would be wrong
+               as some groups may not have been formed yet, if the
+               first row with this head pattern comes after in the list *)
+            form_groups constr_groups (tail :: omega_tails) rest
+        | _ ->
+            form_groups
+              (insert_constr head args tail constr_groups) omega_tails rest
   in
 
   let constr_groups, omega_tails =
     let initial_constr_group =
-      match q.pat_desc with
-      | Tpat_record(_) | Tpat_tuple(_) | Tpat_lazy(_) ->
-        (* [q] comes from [discr_pat], and in this case subsumes any of the
+      match Pattern_head.desc discr with
+      | Record _ | Tuple _ | Lazy ->
+        (* [discr] comes from [discr_pat], and in this case subsumes any of the
            patterns we could find on the first column of [rows]. So it is better
            to use it for our initial environment than any of the normalized
            pattern we might obtain from the first column. *)
-        [q,[]]
+        [discr,[]]
       | _ -> []
     in
     form_groups initial_constr_group [] rows
@@ -737,18 +847,16 @@ let set_last a =
     | x::l -> x :: loop l
   in
   function
-  | (_, []) -> (a, [])
+  | (_, []) -> (Pattern_head.deconstruct a, [])
   | (first, row) -> (first, loop row)
 
-(* mark constructor lines for failure when they are incomplete
-
-   Precondition: the input matrix has been simplified so that its
-   first column only contains _ or head constructors. *)
+(* mark constructor lines for failure when they are incomplete *)
 let mark_partial =
-  List.map (function
-    | ({pat_desc=(Tpat_var _|Tpat_alias _|Tpat_or _)},_) -> assert false
-    | ({pat_desc = Tpat_any }, _) as ps -> ps
-    | ps -> set_last zero ps
+  let zero = make_pat (Tpat_constant (Const_int 0)) Ctype.none Env.empty in
+  List.map (fun ((hp, _), _ as ps) ->
+    match Pattern_head.desc hp with
+    | Any -> ps
+    | _ -> set_last zero ps
   )
 
 let close_variant env row =
@@ -771,56 +879,51 @@ let close_variant env row =
                     row_closed = true; row_name = nm}))
   end
 
-let row_of_pat pat =
-  match Ctype.expand_head pat.pat_env pat.pat_type with
-    {desc = Tvariant row} -> Btype.row_repr row
-  | _ -> assert false
-
 (*
   Check whether the first column of env makes up a complete signature or
-  not. We work on the discriminating patterns of each sub-matrix: they
-  are simplified, and are not omega/Tpat_any.
+  not. We work on the discriminating pattern heads of each sub-matrix: they
+  are not omega/Any.
 *)
 let full_match closing env =  match env with
-| ({pat_desc = (Tpat_any | Tpat_var _ | Tpat_alias _
-               | Tpat_or _ | Tpat_exception _)},_) :: _ ->
-    (* discriminating patterns are simplified *)
-    assert false
 | [] -> false
-| ({pat_desc = Tpat_construct(_,c,_)},_) :: _ ->
-    if c.cstr_consts < 0 then false (* extensions *)
-    else List.length env = c.cstr_consts + c.cstr_nonconsts
-| ({pat_desc = Tpat_variant _} as p,_) :: _ ->
-    let fields =
-      List.map
-        (function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag
-          | _ -> assert false)
-        env
-    in
-    let row = row_of_pat p in
-    if closing && not (Btype.row_fixed row) then
-      (* closing=true, we are considering the variant as closed *)
-      List.for_all
-        (fun (tag,f) ->
-          match Btype.row_field_repr f with
-            Rabsent | Reither(_, _, false, _) -> true
-          | Reither (_, _, true, _)
-              (* m=true, do not discard matched tags, rather warn *)
-          | Rpresent _ -> List.mem tag fields)
-        row.row_fields
-    else
-      row.row_closed &&
-      List.for_all
-        (fun (tag,f) ->
-          Btype.row_field_repr f = Rabsent || List.mem tag fields)
-        row.row_fields
-| ({pat_desc = Tpat_constant(Const_char _)},_) :: _ ->
-    List.length env = 256
-| ({pat_desc = Tpat_constant(_)},_) :: _ -> false
-| ({pat_desc = Tpat_tuple(_)},_) :: _ -> true
-| ({pat_desc = Tpat_record(_)},_) :: _ -> true
-| ({pat_desc = Tpat_array(_)},_) :: _ -> false
-| ({pat_desc = Tpat_lazy(_)},_) :: _ -> true
+| (discr, _) :: _ ->
+  match Pattern_head.desc discr with
+  | Any -> assert false
+  | Construct { cstr_tag = Cstr_extension _ ; _ } -> false
+  | Construct c -> List.length env = c.cstr_consts + c.cstr_nonconsts
+  | Variant { type_row; _ } ->
+      let fields =
+        List.map
+          (fun (d, _) ->
+            match Pattern_head.desc d with
+            | Variant { tag } -> tag
+            | _ -> assert false)
+          env
+      in
+      let row = type_row () in
+      if closing && not (Btype.row_fixed row) then
+        (* closing=true, we are considering the variant as closed *)
+        List.for_all
+          (fun (tag,f) ->
+            match Btype.row_field_repr f with
+              Rabsent | Reither(_, _, false, _) -> true
+            | Reither (_, _, true, _)
+                (* m=true, do not discard matched tags, rather warn *)
+            | Rpresent _ -> List.mem tag fields)
+          row.row_fields
+      else
+        row.row_closed &&
+        List.for_all
+          (fun (tag,f) ->
+            Btype.row_field_repr f = Rabsent || List.mem tag fields)
+          row.row_fields
+  | Constant Const_char _ ->
+      List.length env = 256
+  | Constant _
+  | Array _ -> false
+  | Tuple _
+  | Record _
+  | Lazy -> true
 
 (* Written as a non-fragile matching, PR#7451 originated from a fragile matching
    below. *)
@@ -829,18 +932,15 @@ let should_extend ext env = match ext with
 | Some ext -> begin match env with
   | [] -> assert false
   | (p,_)::_ ->
-      begin match p.pat_desc with
-      | Tpat_construct
-          (_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},_) ->
-            let path = get_constructor_type_path p.pat_type p.pat_env in
-            Path.same path ext
-      | Tpat_construct
-          (_, {cstr_tag=(Cstr_extension _)},_) -> false
-      | Tpat_constant _|Tpat_tuple _|Tpat_variant _
-      | Tpat_record  _|Tpat_array _ | Tpat_lazy _
-        -> false
-      | Tpat_any|Tpat_var _|Tpat_alias _|Tpat_or _|Tpat_exception _
-        -> assert false
+      begin match Pattern_head.desc p with
+      | Construct {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)} ->
+          let path =
+            get_constructor_type_path (Pattern_head.typ p) (Pattern_head.env p)
+          in
+          Path.same path ext
+      | Construct {cstr_tag=(Cstr_extension _)} -> false
+      | Constant _ | Tuple _ | Variant _ | Record _ | Array _ | Lazy -> false
+      | Any -> assert false
       end
 end
 
@@ -888,6 +988,7 @@ let rec orify_many = function
 
 (* build an or-pattern from a constructor list *)
 let pat_of_constrs ex_pat cstrs =
+  let ex_pat = Pattern_head.to_omega_pattern ex_pat in
   if cstrs = [] then raise Empty else
   orify_many (List.map (pat_of_constr ex_pat) cstrs)
 
@@ -932,10 +1033,9 @@ let rec get_variant_constructors env ty =
 
 (* Sends back a pattern that complements constructor tags all_tag *)
 let complete_constrs p all_tags =
-  let c =
-    match p.pat_desc with Tpat_construct (_, c, _) -> c | _ -> assert false in
+  let c = match Pattern_head.desc p with Construct c -> c | _ -> assert false 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 (Pattern_head.env p) c.cstr_res in
   let others =
     List.filter
       (fun cnstr -> ConstructorTagHashtbl.mem not_tags cnstr.cstr_tag)
@@ -945,23 +1045,30 @@ let complete_constrs p all_tags =
   const @ nonconst
 
 let build_other_constrs env p =
-  match p.pat_desc with
-    Tpat_construct (_, {cstr_tag=Cstr_constant _|Cstr_block _}, _) ->
-      let get_tag = function
-        | {pat_desc = Tpat_construct (_,c,_)} -> c.cstr_tag
+  match Pattern_head.desc p with
+  | Construct { cstr_tag = Cstr_constant _ | Cstr_block _ } ->
+      let get_tag q =
+        match Pattern_head.desc q 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)
   | _ -> extra_pat
 
+let complete_constrs p all_tags =
+  (* This wrapper is here for [Matching], which (indirectly) calls this function
+     from [combine_constructor], and nowhere else.
+     So we know patterns have been fully simplified. *)
+  complete_constrs (fst @@ Pattern_head.deconstruct p) all_tags
+
 (* Auxiliary for build_other *)
 
 let build_other_constant proj make first next p env =
-  let all = List.map (fun (p, _) -> proj p.pat_desc) env in
+  let all = List.map (fun (p, _) -> proj (Pattern_head.desc p)) env in
   let rec try_const i =
     if List.mem i all
     then try_const (next i)
-    else make_pat (make i) p.pat_type p.pat_env
+    else make_pat (make i) (Pattern_head.typ p) (Pattern_head.env p)
   in try_const first
 
 (*
@@ -971,133 +1078,146 @@ let build_other_constant proj make first next p env =
 
 let some_private_tag = "<some private tag>"
 
-let build_other ext env = match env with
-| ({pat_desc = Tpat_construct (lid, {cstr_tag=Cstr_extension _},_)},_) :: _ ->
-        (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *)
-        make_pat (Tpat_var (Ident.create_local "*extension*",
-                            {lid with txt="*extension*"})) Ctype.none Env.empty
-| ({pat_desc = Tpat_construct _} as p,_) :: _ ->
-    begin match ext with
-    | Some ext ->
-        if Path.same ext (get_constructor_type_path p.pat_type p.pat_env) then
-          extra_pat
-        else
-          build_other_constrs env p
-    | _ ->
-        build_other_constrs env p
-    end
-| ({pat_desc = Tpat_variant (_,_,r)} as p,_) :: _ ->
-    let tags =
-      List.map
-        (function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag
+let build_other ext env =
+  match env with
+  | [] -> omega
+  | (d, _) :: _ ->
+      match Pattern_head.desc d with
+      | Construct { cstr_tag = Cstr_extension _ } ->
+          (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *)
+          make_pat
+            (Tpat_var (Ident.create_local "*extension*",
+                       {txt="*extension*"; loc = Pattern_head.loc d}))
+            Ctype.none Env.empty
+      | Construct _ ->
+          begin match ext with
+          | Some ext ->
+              if Path.same ext
+                   (get_constructor_type_path
+                      (Pattern_head.typ d) (Pattern_head.env d))
+              then
+                extra_pat
+              else
+                build_other_constrs env d
+          | _ ->
+              build_other_constrs env d
+          end
+      | Variant { cstr_row; type_row } ->
+          let tags =
+            List.map
+              (fun (d, _) ->
+                match Pattern_head.desc d with
+                | Variant { tag } -> tag
                 | _ -> assert false)
-        env
-    in
-    let row = row_of_pat p in
-    let make_other_pat tag const =
-      let arg = if const then None else Some omega in
-      make_pat (Tpat_variant(tag, arg, r)) p.pat_type p.pat_env in
-    begin match
-      List.fold_left
-        (fun others (tag,f) ->
-          if List.mem tag tags then others else
-          match Btype.row_field_repr f with
-            Rabsent (* | Reither _ *) -> others
-          (* This one is called after erasing pattern info *)
-          | Reither (c, _, _, _) -> make_other_pat tag c :: others
-          | Rpresent arg -> make_other_pat tag (arg = None) :: others)
-        [] row.row_fields
-    with
-      [] ->
-        let tag =
-          if Btype.row_fixed row then some_private_tag else
-          let rec mktag tag =
-            if List.mem tag tags then mktag (tag ^ "'") else tag in
-          mktag "AnyOtherTag"
-        in make_other_pat tag true
-    | pat::other_pats ->
-        List.fold_left
-          (fun p_res pat ->
-            make_pat (Tpat_or (pat, p_res, None)) p.pat_type p.pat_env)
-          pat other_pats
-    end
-| ({pat_desc = Tpat_constant(Const_char _)} as p,_) :: _ ->
-    let all_chars =
-      List.map
-        (fun (p,_) -> match p.pat_desc with
-        | Tpat_constant (Const_char c) -> c
-        | _ -> assert false)
-        env in
-
-    let rec find_other i imax =
-      if i > imax then raise Not_found
-      else
-        let ci = Char.chr i in
-        if List.mem ci all_chars then
-          find_other (i+1) imax
-        else
-          make_pat (Tpat_constant (Const_char ci)) p.pat_type p.pat_env in
-    let rec try_chars = function
-      | [] -> omega
-      | (c1,c2) :: rest ->
-          try
-            find_other (Char.code c1) (Char.code c2)
-          with
-          | Not_found -> try_chars rest in
-
-    try_chars
-      [ 'a', 'z' ; 'A', 'Z' ; '0', '9' ;
-        ' ', '~' ; Char.chr 0 , Char.chr 255]
-
-| ({pat_desc=(Tpat_constant (Const_int _))} as p,_) :: _ ->
-    build_other_constant
-      (function Tpat_constant(Const_int i) -> i | _ -> assert false)
-      (function i -> Tpat_constant(Const_int i))
-      0 succ p env
-| ({pat_desc=(Tpat_constant (Const_int32 _))} as p,_) :: _ ->
-    build_other_constant
-      (function Tpat_constant(Const_int32 i) -> i | _ -> assert false)
-      (function i -> Tpat_constant(Const_int32 i))
-      0l Int32.succ p env
-| ({pat_desc=(Tpat_constant (Const_int64 _))} as p,_) :: _ ->
-    build_other_constant
-      (function Tpat_constant(Const_int64 i) -> i | _ -> assert false)
-      (function i -> Tpat_constant(Const_int64 i))
-      0L Int64.succ p env
-| ({pat_desc=(Tpat_constant (Const_nativeint _))} as p,_) :: _ ->
-    build_other_constant
-      (function Tpat_constant(Const_nativeint i) -> i | _ -> assert false)
-      (function i -> Tpat_constant(Const_nativeint i))
-      0n Nativeint.succ p env
-| ({pat_desc=(Tpat_constant (Const_string _))} as p,_) :: _ ->
-    build_other_constant
-      (function Tpat_constant(Const_string (s, _)) -> String.length s
+              env
+            in
+            let make_other_pat tag const =
+              let arg = if const then None else Some omega in
+              make_pat (Tpat_variant(tag, arg, cstr_row))
+                (Pattern_head.typ d) (Pattern_head.env d)
+            in
+            let row = type_row () in
+            begin match
+              List.fold_left
+                (fun others (tag,f) ->
+                  if List.mem tag tags then others else
+                  match Btype.row_field_repr f with
+                    Rabsent (* | Reither _ *) -> others
+                  (* This one is called after erasing pattern info *)
+                  | Reither (c, _, _, _) -> make_other_pat tag c :: others
+                  | Rpresent arg -> make_other_pat tag (arg = None) :: others)
+                [] row.row_fields
+            with
+              [] ->
+                let tag =
+                  if Btype.row_fixed row then some_private_tag else
+                  let rec mktag tag =
+                    if List.mem tag tags then mktag (tag ^ "'") else tag in
+                  mktag "AnyOtherTag"
+                in make_other_pat tag true
+            | pat::other_pats ->
+                List.fold_left
+                  (fun p_res pat ->
+                    make_pat (Tpat_or (pat, p_res, None))
+                      (Pattern_head.typ d) (Pattern_head.env d))
+                  pat other_pats
+            end
+      | Constant Const_char _ ->
+          let all_chars =
+            List.map
+              (fun (p,_) -> match Pattern_head.desc p with
+              | Constant (Const_char c) -> c
               | _ -> assert false)
-      (function i -> Tpat_constant(Const_string(String.make i '*', None)))
-      0 succ p env
-| ({pat_desc=(Tpat_constant (Const_float _))} as p,_) :: _ ->
-    build_other_constant
-      (function Tpat_constant(Const_float f) -> float_of_string f
+              env
+          in
+          let rec find_other i imax =
+            if i > imax then raise Not_found
+            else
+              let ci = Char.chr i in
+              if List.mem ci all_chars then
+                find_other (i+1) imax
+              else
+                make_pat (Tpat_constant (Const_char ci))
+                  (Pattern_head.typ d) (Pattern_head.env d)
+          in
+          let rec try_chars = function
+            | [] -> omega
+            | (c1,c2) :: rest ->
+                try
+                  find_other (Char.code c1) (Char.code c2)
+                with
+                | Not_found -> try_chars rest
+          in
+          try_chars
+            [ 'a', 'z' ; 'A', 'Z' ; '0', '9' ;
+              ' ', '~' ; Char.chr 0 , Char.chr 255]
+      | Constant Const_int _ ->
+          build_other_constant
+            (function Constant(Const_int i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_int i))
+            0 succ d env
+      | Constant Const_int32 _ ->
+          build_other_constant
+            (function Constant(Const_int32 i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_int32 i))
+            0l Int32.succ d env
+      | Constant Const_int64 _ ->
+          build_other_constant
+            (function Constant(Const_int64 i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_int64 i))
+            0L Int64.succ d env
+      | Constant Const_nativeint _ ->
+          build_other_constant
+            (function Constant(Const_nativeint i) -> i | _ -> assert false)
+            (function i -> Tpat_constant(Const_nativeint i))
+            0n Nativeint.succ d env
+      | Constant Const_string _ ->
+          build_other_constant
+            (function Constant(Const_string (s, _)) -> String.length s
+                    | _ -> assert false)
+            (function i -> Tpat_constant(Const_string(String.make i '*', None)))
+            0 succ d env
+      | Constant Const_float _ ->
+          build_other_constant
+            (function Constant(Const_float f) -> float_of_string f
+                    | _ -> assert false)
+            (function f -> Tpat_constant(Const_float (string_of_float f)))
+            0.0 (fun f -> f +. 1.0) d env
+      | Array _ ->
+          let all_lengths =
+            List.map
+              (fun (p,_) -> match Pattern_head.desc p with
+              | Array len -> len
               | _ -> assert false)
-      (function f -> Tpat_constant(Const_float (string_of_float f)))
-      0.0 (fun f -> f +. 1.0) p env
-
-| ({pat_desc = Tpat_array _} as p,_)::_ ->
-    let all_lengths =
-      List.map
-        (fun (p,_) -> match p.pat_desc with
-        | Tpat_array args -> List.length args
-        | _ -> assert false)
-        env in
-    let rec try_arrays l =
-      if List.mem l all_lengths then try_arrays (l+1)
-      else
-        make_pat
-          (Tpat_array (omegas l))
-          p.pat_type p.pat_env in
-    try_arrays 0
-| [] -> omega
-| _ -> omega
+              env in
+          let rec try_arrays l =
+            if List.mem l all_lengths then try_arrays (l+1)
+            else
+              make_pat
+                (Tpat_array (omegas l))
+                (Pattern_head.typ d) (Pattern_head.env d) in
+          try_arrays 0
+      | _ -> omega
 
 let rec has_instance p = match p.pat_desc with
   | Tpat_variant (l,_,r) when is_absent l r -> false
@@ -1162,18 +1282,20 @@ let rec satisfiable pss qs = match pss with
             List.exists
               (fun (p,pss) ->
                  not (is_absent_pat p) &&
-                 satisfiable pss (simple_match_args p omega @ qs))
+                 satisfiable pss
+                   (simple_match_args p Pattern_head.omega [] @ qs))
               constrs
         end
     | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> false
     | q::qs ->
         let pss = simplify_first_col pss in
-        if not (all_coherent (q :: first_column pss)) then
+        let hq, qargs = Pattern_head.deconstruct q in
+        if not (all_coherent (hq :: first_column pss)) then
           false
         else begin
           let q0 = discr_pat q pss in
           satisfiable (build_specialized_submatrix ~extend_row:(@) q0 pss)
-            (simple_match_args q0 q @ qs)
+            (simple_match_args q0 hq qargs @ qs)
         end
 
 (* While [satisfiable] only checks whether the last row of [pss + qs] is
@@ -1220,15 +1342,16 @@ let rec list_satisfying_vectors pss qs =
                       else
                         let witnesses =
                           list_satisfying_vectors pss
-                            (simple_match_args p omega @ qs)
+                            (simple_match_args p Pattern_head.omega [] @ qs)
                         in
+                        let p = Pattern_head.to_omega_pattern p in
                         List.map (set_args p) witnesses
                     ) constrs
                   )
                 in
                 if full_match false constrs then for_constrs () else
-                begin match p.pat_desc with
-                | Tpat_construct _ ->
+                begin match Pattern_head.desc p with
+                | Construct _ ->
                     (* activate this code for checking non-gadt constructors *)
                     wild default (build_other_constrs constrs p)
                     @ for_constrs ()
@@ -1238,15 +1361,16 @@ let rec list_satisfying_vectors pss qs =
           end
       | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> []
       | q::qs ->
+          let hq, qargs = Pattern_head.deconstruct q in
           let pss = simplify_first_col pss in
-          if not (all_coherent (q :: first_column pss)) then
+          if not (all_coherent (hq :: first_column pss)) then
             []
           else begin
             let q0 = discr_pat q pss in
-            List.map (set_args q0)
+            List.map (set_args (Pattern_head.to_omega_pattern q0))
               (list_satisfying_vectors
                  (build_specialized_submatrix ~extend_row:(@) q0 pss)
-                 (simple_match_args q0 q @ qs))
+                 (simple_match_args q0 hq qargs @ qs))
           end
 
 (******************************************)
@@ -1275,13 +1399,16 @@ let rec do_match pss qs = match qs with
       in
       do_match (remove_first_column pss) qs
   | _ ->
-      let q0 = normalize_pat q in
+      (* [q] is generated by us, it doesn't come from the source. So we know
+         it's not of the form [P as name].
+         Therefore there is no risk of [deconstruct] raising. *)
+      let q0, qargs = Pattern_head.deconstruct q in
       let pss = simplify_first_col pss in
       (* [pss] will (or won't) match [q0 :: qs] regardless of the coherence of
          its first column. *)
       do_match
         (build_specialized_submatrix ~extend_row:(@) q0 pss)
-        (simple_match_args q0 q @ qs)
+        (qargs @ qs)
 
 
 type 'a exhaust_result =
@@ -1353,7 +1480,9 @@ let rec exhaust (ext:Path.t option) pss n = match pss with
       | { default; constrs = [] } ->
           (* first column of pss is made of variables only *)
           begin match exhaust ext default (n-1) with
-          | Witnesses r -> Witnesses (List.map (fun row -> q0::row) r)
+          | Witnesses r ->
+              let q0 = Pattern_head.to_omega_pattern q0 in
+              Witnesses (List.map (fun row -> q0::row) r)
           | r -> r
         end
       | { default; constrs } ->
@@ -1363,10 +1492,13 @@ let rec exhaust (ext:Path.t option) pss n = match pss with
             else
               match
                 exhaust
-                  ext pss (List.length (simple_match_args p omega) + n - 1)
+                  ext pss
+                  (List.length (simple_match_args p Pattern_head.omega [])
+                   + n - 1)
               with
               | Witnesses r ->
-                  Witnesses (List.map (fun row ->  (set_args p row)) r)
+                  let p = Pattern_head.to_omega_pattern p in
+                  Witnesses (List.map (set_args p) r)
               | r       -> r in
           let before = try_many try_non_omega constrs in
           if
@@ -1455,12 +1587,16 @@ let rec pressure_variants tdefs = function
                 end
               in
               begin match constrs, tdefs with
-                ({pat_desc=Tpat_variant _} as p,_):: _, Some env ->
-                  let row = row_of_pat p in
+              | [], _
+              | _, None -> ()
+              | (d, _) :: _, Some env ->
+                match Pattern_head.desc d with
+                | Variant { type_row; _ } ->
+                  let row = type_row () in
                   if Btype.row_fixed row
                   || pressure_variants None default then ()
                   else close_variant env row
-              | _ -> ()
+                | _ -> ()
               end;
               ok
       end
@@ -1656,16 +1792,17 @@ let rec every_satisfiables pss qs = match qs.active with
     | _ ->
 (* standard case, filter matrix *)
         let pss = simplify_first_usefulness_col pss in
+        let huq, args = Pattern_head.deconstruct uq in
         (* The handling of incoherent matrices is kept in line with
            [satisfiable] *)
-        if not (all_coherent (uq :: first_column pss)) then
+        if not (all_coherent (huq :: first_column pss)) then
           Unused
         else begin
           let q0 = discr_pat q pss in
           every_satisfiables
             (build_specialized_submatrix q0 pss
               ~extend_row:(fun ps r -> { r with active = ps @ r.active }))
-            {qs with active=simple_match_args q0 q @ rem}
+            {qs with active=simple_match_args q0 huq args @ rem}
         end
     end
 
@@ -2296,12 +2433,13 @@ let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k =
       let rest_of_the_row =
         { row = ps; varsets = Ident.Set.add x head_bound_variables :: varsets; }
       in
-      add_column omega rest_of_the_row k
+      add_column (Pattern_head.deconstruct omega) rest_of_the_row k
     | Tpat_or (p1,p2,_) ->
       simpl head_bound_variables varsets p1 ps
         (simpl head_bound_variables varsets p2 ps k)
     | _ ->
-      add_column p { row = ps; varsets = head_bound_variables :: varsets; } k
+      add_column (Pattern_head.deconstruct p)
+        { row = ps; varsets = head_bound_variables :: varsets; } k
   in simpl head_bound_variables varsets p ps k
 
 (*