match lbls with

| [] -> fatal_error "Matching.all_record_args"

| (_, { lbl_all }, _) :: _ ->

let t =

Array.map

(fun lbl ->

(mknoloc (Longident.Lident "?temp?"), lbl, Patterns.omega))

lbl_all

in

List.iter (fun ((_, lbl, _) as x) -> t.(lbl.lbl_pos) <- x) lbls;

let open Patterns.Head in

match h.pat_desc with

| Record [] -> fatal_error "Matching.expand_record_head"

| Record ({ lbl_all } :: _) ->

{ h with pat_desc = Record (Array.to_list lbl_all) }

include Patterns.General

type nonrec clause = pattern Non_empty_row.t clause

include module type of Patterns.Half_simple

(** Half-simplified patterns are patterns where:

type nonrec clause = pattern Non_empty_row.t clause

val of_clause : arg:lambda -> General.clause -> clause

end = struct

include Patterns.Half_simple

type nonrec clause = pattern Non_empty_row.t clause

let rec simpl_under_orpat p =

match p.pat_desc with

| Tpat_any

| Tpat_var _ ->

p

| Tpat_alias (q, id, s, uid, ty) ->

{ p with pat_desc = Tpat_alias (simpl_under_orpat q, id, s, uid, ty) }

| Tpat_or (p1, p2, o) ->

let p1, p2 = (simpl_under_orpat p1, simpl_under_orpat p2) in

if le_pat p1 p2 then

p1

else

{ p with pat_desc = Tpat_or (p1, p2, o) }

| Tpat_record (lbls, closed) ->

let all_lbls = all_record_args lbls in

{ p with pat_desc = Tpat_record (all_lbls, closed) }

| _ -> p

(* Explode or-patterns and turn aliases into bindings in actions *)

let of_clause ~arg cl =

let rec aux (((p, patl), action) : General.clause) : clause =

let continue p (view : General.view) : clause =

aux (({ p with pat_desc = view }, patl), action)

in

let stop p (view : view) : clause =

(({ p with pat_desc = view }, patl), action)

in

match p.pat_desc with

| `Any -> stop p `Any

| `Var (id, s, uid) ->

continue p (`Alias (Patterns.omega, id, s, uid, p.pat_type))

| `Alias (p, id, _, _, _) ->

aux

( (General.view p, patl),

bind_alias p id ~arg ~action )

| `Record ([], _) as view -> stop p view

| `Record (lbls, closed) ->

let full_view = `Record (all_record_args lbls, closed) in

stop p full_view

| `Or _ -> (

let orpat = General.view (simpl_under_orpat (General.erase p)) in

match orpat.pat_desc with

| `Or _ as or_view -> stop orpat or_view

| other_view -> continue orpat other_view

)

| ( `Constant _ | `Tuple _ | `Construct _ | `Variant _ | `Array _

| `Lazy _ ) as view ->

stop p view

in

aux cl

include module type of Patterns.Simple

type nonrec clause = pattern Non_empty_row.t clause

val head : pattern -> Patterns.Head.t

val explode_or_pat :

arg:lambda ->

Half_simple.pattern ->

mk_action:(vars:Ident.t list -> lambda) ->

patbound_action_vars:Ident.t list ->

(pattern * lambda) list

end = struct

include Patterns.Simple

type nonrec clause = pattern Non_empty_row.t clause

let head p = fst (Patterns.Head.deconstruct p)

let alpha env (p : pattern) : pattern =

let alpha_pat env p = Typedtree.alpha_pat env p in

let pat_desc =

match p.pat_desc with

| `Any -> `Any

| `Constant cst -> `Constant cst

| `Tuple ps ->

`Tuple (List.map (fun (label, p) -> label, alpha_pat env p) ps)

| `Construct (cstr, cst_descr, args) ->

`Construct (cstr, cst_descr, List.map (alpha_pat env) args)

| `Variant (cstr, argo, row_desc) ->

`Variant (cstr, Option.map (alpha_pat env) argo, row_desc)

| `Record (fields, closed) ->

let alpha_field env (lid, l, p) = (lid, l, alpha_pat env p) in

`Record (List.map (alpha_field env) fields, closed)

| `Array (am, ps) -> `Array (am, List.map (alpha_pat env) ps)

| `Lazy p -> `Lazy (alpha_pat env p)

in

{ p with pat_desc }

(* Consider the following matching problem involving a half-simple pattern,

let explode_or_pat ~arg (p : Half_simple.pattern)

~mk_action ~patbound_action_vars

: (pattern * lambda) list =

let rec explode p aliases rem =

let split_explode p aliases rem = explode (General.view p) aliases rem in

match p.pat_desc with

| `Or (p1, p2, _) ->

split_explode p1 aliases (split_explode p2 aliases rem)

| `Alias (p, id, _, _, _) -> split_explode p (id :: aliases) rem

| `Var (id, str, uid) ->

explode

{ p with pat_desc =

`Alias (Patterns.omega, id, str, uid, p.pat_type) }

aliases rem

| #view as view ->

(* We are doing two things here:

let rec fresh_clause arg_id action_vars renaming_env = function

| [] ->

let fresh_pat = alpha renaming_env { p with pat_desc = view } in

let fresh_action = mk_action ~vars:(List.rev action_vars) in

(fresh_pat, fresh_action)

| pat_id :: rem_vars ->

if not (List.mem pat_id aliases) then begin

let fresh_id = Ident.rename pat_id in

let action_vars = fresh_id :: action_vars in

let renaming_env = ((pat_id, fresh_id) :: renaming_env) in

fresh_clause arg_id action_vars renaming_env rem_vars

end else begin match arg_id, arg with

| Some id, _

| None, Lvar id ->

let action_vars = id :: action_vars in

fresh_clause arg_id action_vars renaming_env rem_vars

| None, _ ->

(* [pat_id] is a name used locally to refer to the argument,

let id = Ident.rename pat_id in

let action_vars = (id :: action_vars) in

let pat, action =

fresh_clause (Some id) action_vars renaming_env rem_vars

in

pat, bind_alias pat id ~arg ~action

end

in

fresh_clause None [] [] patbound_action_vars :: rem

in

explode (p : Half_simple.pattern :> General.pattern) [] []

fun p ->

match p.pat_desc with

| `Record (l, _) -> { p with pat_desc = `Record (all_record_args l, Closed) }

if n <= 0 then

([], ps)

else

match ps with

| p :: rem ->

let left, right = rev_split_at (n - 1) rem in

(p :: left, right)

let discr = expand_record_head discr in

let p = expand_record_simple p in

let omegas = Patterns.(omegas (Head.arity discr)) in

let ph, args = Patterns.Head.deconstruct p in

let yes () = args @ rem in

let no () = raise NoMatch in

let yesif b =

if b then

yes ()

else

no ()

in

let open Patterns.Head in

match (discr.pat_desc, ph.pat_desc) 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;

yesif (Data_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 (am1, n1), Array (am2, n2) -> yesif (am1 = am2 && 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 _)

->

type t

val empty : t

val is_empty : t -> bool

val start : int -> t

val pp : Format.formatter -> t -> unit

val specialize : Patterns.Head.t -> t -> t

val lshift : t -> t

val rshift : t -> t

val rshift_num : int -> t -> t

val lub : pattern -> t -> t

val erase_first_col : t -> t

val matches : t -> matrix -> bool

val combine : t -> t

val select_columns : matrix -> t -> t

val union : t -> t -> t

end = struct

module Row = struct

type t = { left : pattern list; right : pattern list }

(* Static knowledge on a frontier of nodes (subtrees) in the matched values.

let pp ppf { left; right } =

Format.fprintf ppf

"@[LEFT@ %aRIGHT@ %a@]"

pretty_line left

pretty_line right

let le c1 c2 = le_pats c1.left c2.left && le_pats c1.right c2.right

let lshift { left; right } =

match right with

| x :: xs -> { left = x :: left; right = xs }

| _ -> assert false

let lforget { left; right } =

match right with

| _ :: xs -> { left = Patterns.omega :: left; right = xs }

| _ -> assert false

let erase_first_col { left; right } =

match right with

| _ :: right -> { left; right = Patterns.omega :: right }

| _ -> assert false

let rshift { left; right } =

match left with

| p :: ps -> { left = ps; right = p :: right }

| _ -> assert false

let rshift_num n { left; right } =

let shifted, left = rev_split_at n left in

{ left; right = shifted @ right }

(** Recombination of contexts.

let combine { left; right } =

match left with

| p :: ps -> { left = ps; right = set_args p right }

| _ -> assert false

end

type t = Row.t list

(* A union/disjunction of possible context "rows". What we know is that

let empty = []

let start n : t = [ { left = []; right = Patterns.omegas n } ]

let is_empty = function

| [] -> true

| _ -> false

let pp ppf ctx =

Format.pp_print_list ~pp_sep:Format.pp_print_cut

Row.pp ppf ctx

let lshift ctx =

if List.length ctx < !Clflags.match_context_rows then

List.map Row.lshift ctx

else

(* Context pruning *)

get_mins Row.le (List.map Row.lforget ctx)

let rshift ctx = List.map Row.rshift ctx

let erase_first_col ctx = List.map Row.erase_first_col ctx

let rshift_num n ctx = List.map (Row.rshift_num n) ctx

let combine ctx = List.map Row.combine ctx

let specialize head ctx =

let non_empty = function

| { Row.left = _; right = [] } ->

fatal_error "Matching.Context.specialize"

| { Row.left; right = p :: ps } -> (left, p, ps)

in

let ctx = List.map non_empty ctx in

let rec filter_rec = function

| [] -> []

| (left, p, right) :: rem -> (

let p = General.view p in

match p.pat_desc with

| `Or (p1, p2, _) ->

filter_rec ((left, p1, right) :: (left, p2, right) :: rem)

| `Alias (p, _, _, _, _) -> filter_rec ((left, p, right) :: rem)

| `Var _ -> filter_rec ((left, Patterns.omega, right) :: rem)

| #Simple.view as view -> (

let p = { p with pat_desc = view } in

match matcher head p right with

| exception NoMatch -> filter_rec rem

| right ->

let left = Patterns.Head.to_omega_pattern head :: left in

{ Row.left; right }

:: filter_rec rem

)

)

in

filter_rec ctx

let select_columns pss ctx =

let n = ncols pss in

let lub_row ps { Row.left; right } =

let transfer, right = rev_split_at n right in

match lubs transfer ps with

| exception Empty -> None

| inter -> Some { Row.left = inter @ left; right }

in

let lub_with_ctx ps = List.filter_map (lub_row ps) ctx in

List.flatten (List.map lub_with_ctx pss)

let lub p ctx =

List.filter_map

(fun { Row.left; right } ->

match right with

| q :: rem -> (

try Some { Row.left; right = lub p q :: rem } with Empty -> None

)

| _ -> fatal_error "Matching.Context.lub")

ctx

let matches ctx pss =

List.exists

(fun { Row.right = qs } -> List.exists (fun ps -> may_compats qs ps) pss)

ctx

let union pss qss = get_mins Row.le (pss @ qss)

match p.pat_desc with

| Tpat_any | Tpat_var _ -> Patterns.omegas size :: k

| Tpat_tuple args -> (List.map snd args) :: k

| Tpat_or (p1, p2, _) ->

flatten_pat_line size p1 (flatten_pat_line size p2 k)

| Tpat_alias (p, _, _, _, _) ->

(* Note: we are only called from flatten_matrix,

flatten_pat_line size p k

List.fold_right

(fun ps r ->

match ps with

| [ p ] -> flatten_pat_line size p r

| _ -> fatal_error "Matching.flatten_matrix")

type t

val pop : t -> ((int * matrix) * t) option

val empty : final_exit:int -> t

val raise_final_exit : t -> lambda

val cons : matrix -> int -> t -> t

val specialize : Patterns.Head.t -> t -> t

val pop_column : t -> t

val pop_compat : pattern -> t -> t

val flatten : int -> t -> t

val pp : Format.formatter -> t -> unit

val pp_section : Format.formatter -> t -> unit

end = struct

type t = {

env: (int * matrix) list;

final_exit: int;

}

(** All matrices in the list should have the same arity -- their rows should

let empty ~final_exit = { env = []; final_exit; }

let raise_final_exit { final_exit; _ } =

Lstaticraise (final_exit, [])

let cons matrix raise_num default =

match matrix with

| [] -> default

| _ ->

{ default with env = (raise_num, matrix) :: default.env }

let specialize_matrix arity matcher pss =

let rec filter_rec = function

| [] -> []

| (p, ps) :: rem -> (

let p = General.view p in

match p.pat_desc with

| `Alias (p, _, _, _, _) -> filter_rec ((p, ps) :: rem)

| `Var _ -> filter_rec ((Patterns.omega, ps) :: rem)

| `Or (p1, p2, _) -> filter_rec_or p1 p2 ps rem

| #Simple.view as view -> (

let p = { p with pat_desc = view } in

match matcher p ps with

| exception NoMatch -> filter_rec rem

| specialized ->

assert (List.length specialized = List.length ps + arity);

specialized :: filter_rec rem

)

)

(* Filter just one row, without a `rem` accumulator

and filter_one p ps =

filter_rec [ (p, ps) ]

and filter_rec_or p1 p2 ps rem =

match arity with

| 0 -> (

(* if K has arity 0, specializing ((K|K)::rem) returns just (rem):

match filter_one p1 ps with

| [] -> filter_rec ((p2, ps) :: rem)

| matches -> matches @ filter_rec rem

)

| 1 -> (

(* if K has arity 1, ((K p | K q) :: rem) can be expressed

match (filter_one p1 ps, filter_one p2 ps) with

| [], row

| row, [] ->

row @ filter_rec rem

| [ (arg1 :: _) ], [ (arg2 :: _) ] ->

(* By the row shape property,

(* The output below is a single row,

({ arg1 with

pat_desc = Tpat_or (arg1, arg2, None);

pat_loc = Location.none

}

:: ps

)

:: filter_rec rem

| (_ :: _ :: _), _

| _, (_ :: _ :: _) ->

(* Cannot happen from the row count property. *)

assert false

| [ [] ], _

| _, [ [] ] ->

(* Cannot happen from the row shape property. *)

assert false

)

| _ ->

(* we cannot preserve the or-pattern as in the arity-1 case,

filter_rec ((p1, ps) :: (p2, ps) :: rem)

in

filter_rec pss

let specialize_ arity matcher def =

let rec make_rec = function

| [] -> []

| (i, ([] :: _)) :: _ -> [ (i, [ [] ]) ]

| (i, pss) :: rem -> (

(* we already handled the empty-row case

let non_empty = function

| [] -> assert false

| p :: ps -> (p, ps)

in

let pss = List.map non_empty pss in

match specialize_matrix arity matcher pss with

| [] -> make_rec rem

| [] :: _ -> [ (i, [ [] ]) ]

| pss -> (i, pss) :: make_rec rem

)

in

{ def with env = make_rec def.env }

let specialize head def =

specialize_ (Patterns.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 =

if may_compat p (General.erase q) then

rem

else

raise NoMatch

in

specialize_ 0 compat_matcher def

let pop def = match def.env with

| [] -> None

| i_mat :: rem -> Some (i_mat, { def with env = rem })

let pp ppf def =

Format.fprintf ppf

"@[<v 2>Default environment:%a@]"

(fun ppf li ->

if li = [] then Format.fprintf ppf " empty"

else begin

Format.fprintf ppf "@,";

Format.pp_print_list ~pp_sep:Format.pp_print_cut

(fun ppf (i, pss) ->

Format.fprintf ppf

"Matrix for %d:@,\

i

pretty_matrix pss

) ppf li

end

) def.env

let pp_section ppf def =

if def.env = [] then ()

else Format.fprintf ppf "@,%a" pp def

let flatten size def =

{ def with

env = List.map (fun (i, pss) -> (i, flatten_matrix size pss)) def.env;

}

type t

val partial : t -> partial

val empty : partial -> t

(** [empty Total] is the jump summary of exhaustive matching code

val singleton : int -> Context.t -> t

val add : int -> Context.t -> t -> t

val union : t -> t -> t

val unions : t list -> t

val map : (Context.t -> Context.t) -> t -> t

val remove : int -> t -> t

(** [extract exit jumps] returns the context at the given exit

val extract : int -> t -> Context.t * t

val pp : Format.formatter -> t -> unit

val pp_section : Format.formatter -> t -> unit

end = struct

type t = {

env : (int * Context.t) list;

partial : partial;

}

let partial { partial = p; _ } = p

let pp ppf ({ env; partial } : t) =

Format.fprintf ppf "@[<v 2>JUMPS:%t@]"

(fun ppf ->

if env = [] then

Format.fprintf ppf " empty (%a)"

pp_partial partial

else begin

Format.fprintf ppf " (%a)@," pp_partial partial;

Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf (i, ctx) ->

Format.fprintf ppf

"jump for %d@,\

i

Context.pp ctx

) ppf env

end)

let pp_section ppf jumps =

Format.fprintf ppf "@,%a" pp jumps

let extract i jumps =

let rec extract i = function

| [] -> (Context.empty, [])

| ((j, ctx) as x) :: rem as all ->

if i = j then

(ctx, rem)

else if j < i then

(Context.empty, all)

else

let r, rem = extract i rem in

(r, x :: rem)

in

let (ctx, rem) = extract i jumps.env in

(ctx, { jumps with env = rem })

let remove i jumps =

let rec remove i = function

| [] -> []

| (j, _) :: rem when i = j -> rem

| x :: rem -> x :: remove i rem

in

{ jumps with env = remove i jumps.env }

let empty partial = { env = []; partial; }

let add i ctx jumps =

let rec add = function

| [] -> [ (i, ctx) ]

| ((j, qss) as x) :: rem as all ->

if j > i then

x :: add rem

else if j < i then

(i, ctx) :: all

else

(i, Context.union ctx qss) :: rem

in

if Context.is_empty ctx then

jumps

else

{ jumps with env = add jumps.env }