(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)

(* $Id: matching.ml,v 1.52 2002/08/09 11:43:21 maranget Exp $ *)

(* Compilation of pattern matching *)

open Misc
open Asttypes
open Primitive
open Types
open Typedtree
open Lambda
open Parmatch

(*  See Peyton-Jones, ``The Implementation of functional programming
    languages'', chapter 5. *)
(*
  Bon, au commencement du monde c'etait vrai.
*)

type matrix = pattern list list

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

let pretty_ctx ctx =
  List.iter
    (fun {left=left ; right=right} ->
      prerr_string "LEFT:" ;
      pretty_line left ;
      prerr_string " RIGHT:" ;
      pretty_line right ;
      prerr_endline "")
    ctx

let le_ctx c1 c2 =
  le_pats c1.left c2.left &&
  le_pats c1.right c2.right
  
let lshift {left=left ; right=right} = match right with
| x::xs -> {left=x::left ; right=xs}
| _ ->  assert false

let lforget {left=left ; right=right} = match right with
| x::xs -> {left=omega::left ; right=xs}
|  _ -> assert false

let rec small_enough n = function
  | [] -> true
  | _::rem ->
      if n <= 0 then false
      else small_enough (n-1) rem

let ctx_lshift ctx =
  if small_enough 31 ctx then
    List.map lshift ctx
  else (* Context pruning *) begin      
    get_mins le_ctx (List.map lforget ctx)
  end

let  rshift {left=left ; right=right} = match left with
| p::ps -> {left=ps ; right=p::right}
| _ -> assert false

let ctx_rshift ctx = List.map rshift ctx

let rec nchars n ps =
  if n <= 0 then [],ps
  else match ps with
  | p::rem ->
    let chars, cdrs = nchars (n-1) rem in
    p::chars,cdrs
  | _ -> assert false
      
let  rshift_num n {left=left ; right=right} =
  let shifted,left = nchars n left in
  {left=left ; right = shifted@right}

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

let combine {left=left ; right=right} = match left with
| p::ps -> {left=ps ; right=set_args p right}
| _ -> assert false

let ctx_combine ctx = List.map combine ctx

let ncols = function
  | [] -> 0
  | ps::_ -> List.length ps


exception NoMatch
exception OrPat
exception Unused

let filter_matrix matcher pss =

  let rec filter_rec = function
    | (p::ps)::rem ->
        begin match p.pat_desc with
        | Tpat_alias (p,_) ->
            filter_rec ((p::ps)::rem)
        | Tpat_var _ ->
            filter_rec ((omega::ps)::rem)
        | _ ->
            begin
              let rem = filter_rec rem in
              try
                matcher p ps::rem
              with
              | NoMatch -> rem
              | OrPat   ->
                match p.pat_desc with
                | Tpat_or (p1,p2,_) -> filter_rec [(p1::ps) ;(p2::ps)]@rem
                | _ -> assert false
            end
        end
    | [] -> []
    | _ ->
        pretty_matrix pss ;
        fatal_error "Matching.filter_matrix" in
  filter_rec pss

let ctx_matcher p =
  let p = normalize_pat p in
  match p.pat_desc with
  | Tpat_construct (cstr,omegas) ->
      (fun q rem -> match q.pat_desc with
      | Tpat_construct (cstr',args) when cstr.cstr_tag=cstr'.cstr_tag ->
          p,args @ rem
      | Tpat_any -> p,omegas @ rem
      | _ -> raise NoMatch)
  | Tpat_constant cst ->
      (fun q rem -> match q.pat_desc with
      | Tpat_constant cst' when cst=cst' ->
          p,rem
      | Tpat_any -> p,rem
      | _ -> raise NoMatch)
  | Tpat_variant (lab,Some omega,_) ->
      (fun q rem -> match q.pat_desc with
      | Tpat_variant (lab',Some arg,_) when lab=lab' ->
          p,arg::rem
      | Tpat_any -> p,omega::rem
      | _ -> raise NoMatch)
  | Tpat_variant (lab,None,_) ->
      (fun q rem -> match q.pat_desc with
      | Tpat_variant (lab',None,_) when lab=lab' ->
          p,rem
      | Tpat_any -> p,rem
      | _ -> raise NoMatch)
  | Tpat_array omegas ->
      let len = List.length omegas in
      (fun q rem -> match q.pat_desc with
      | Tpat_array args when List.length args=len ->
          p,args @ rem
      | Tpat_any -> p, omegas @ rem
      | _ -> raise NoMatch)
  | Tpat_tuple omegas ->
      (fun q rem -> match q.pat_desc with
      | Tpat_tuple args -> p,args @ rem
      | _          -> p, omegas @ rem)
  | Tpat_record l -> (* Records are normalized *)
      (fun q rem -> match q.pat_desc with
      | Tpat_record l' ->
          let l' = all_record_args l' in
          p, List.fold_right (fun (_,p) r -> p::r) l' rem
      | _ -> p,List.fold_right (fun (_,p) r -> p::r) l rem)
  | _ -> fatal_error "Matching.ctx_matcher"




let filter_ctx q ctx =

  let matcher = ctx_matcher q in

  let rec filter_rec = function
    | ({right=p::ps} as l)::rem ->
        begin match p.pat_desc with
        | Tpat_or (p1,p2,_) ->
            filter_rec ({l with right=p1::ps}::{l with right=p2::ps}::rem)
        | Tpat_alias (p,_) ->
            filter_rec ({l with right=p::ps}::rem)
        | Tpat_var _ ->
            filter_rec ({l with right=omega::ps}::rem)
        | _ ->
            begin let rem = filter_rec rem in
            try
              let to_left, right = matcher p ps in
              {left=to_left::l.left ; right=right}::rem
            with
            | NoMatch -> rem
            end
        end
    | [] -> []
    | _ ->  fatal_error "Matching.filter_ctx" in

  filter_rec ctx

let select_columns pss ctx =
  let n = ncols pss in
  List.fold_right
    (fun ps r ->
      List.fold_right
        (fun {left=left ; right=right} r ->
          let transfert, right = nchars n right in
          try
            {left = lubs transfert ps @ left ; right=right}::r
          with
          | Empty -> r)
        ctx r)
    pss []

let ctx_lub p ctx =
  List.fold_right
    (fun {left=left ; right=right} r ->
      match right with
      | q::rem ->
          begin try
            {left=left ; right = lub p q::rem}::r
          with
          | Empty -> r
          end
      | _ -> fatal_error "Matching.ctx_lub")
    ctx []

let ctx_match ctx pss =
  List.exists
    (fun {right=qs} ->
      List.exists
        (fun ps -> compats qs ps)
        pss)
    ctx

type jumps = (int * ctx ) list

let pretty_jumps env = match env with
| [] -> ()
| _ ->
    List.iter
      (fun (i,ctx) ->
        Printf.fprintf stderr "jump for %d\n" i ;
        pretty_ctx ctx)
      env


let rec jumps_extract i = function
  | [] -> [],[]
  | (j,pss) as x::rem as all ->
      if i=j then pss,rem
      else if j < i then [],all
      else
        let r,rem = jumps_extract i rem in
        r,(x::rem)

let rec jumps_remove i = function
  | [] -> []
  | (j,_)::rem when i=j -> rem
  | x::rem -> x::jumps_remove i rem 

let jumps_empty = []
and jumps_is_empty = function
  |  [] -> true
  |  _ -> false

let jumps_singleton i = function
  | []  -> []
  | ctx ->  [i,ctx]

let jumps_add i pss jumps = match pss with
| [] -> jumps
| _  ->
    let rec add = function
      | [] -> [i,pss]
      | (j,qss) as x::rem as all ->
          if j > i then x::add rem
      else if j < i then (i,pss)::all
      else (i,(get_mins le_ctx (pss@qss)))::rem in
    add jumps


let rec jumps_union env1 env2 = match env1,env2 with
| [],_ -> env2
| _,[] -> env1
| ((i1,pss1) as x1::rem1), ((i2,pss2) as x2::rem2) ->
    if i1=i2 then
      (i1,get_mins le_ctx (pss1@pss2))::jumps_union rem1 rem2
    else if i1 > i2 then
      x1::jumps_union rem1 env2
    else
      x2::jumps_union env1 rem2


let rec merge = function
  | env1::env2::rem ->  jumps_union env1 env2::merge rem
  | envs -> envs

let rec jumps_unions envs = match envs with
  | [] -> []
  | [env] -> env
  | _ -> jumps_unions (merge envs)

let rec jumps_map f env =
  List.map
    (fun (i,pss) -> i,f pss)
    env

type pattern_matching =
  { mutable cases : (pattern list * lambda) list;
    args : (lambda * let_kind) list ;
    default : int * (matrix * int) list}

type pattern_matching_ext =
  {to_match : pattern_matching ;
  to_catch : (matrix * int * Ident.t list * pattern_matching) list}



let pretty_cases cases =
  List.iter
    (fun ((ps),_) ->
      List.iter
        (fun p ->
          Parmatch.top_pretty Format.str_formatter p ;
          prerr_string " " ;
          prerr_string (Format.flush_str_formatter ()))
        ps ;
      prerr_endline "")
    cases

let pretty_pm pm = pretty_cases pm.cases

let pretty_ext m =
  prerr_endline "++++++++ To Match ++++++++" ;
  pretty_pm m.to_match ;
  match m.to_catch with
  | [] ->
      prerr_endline "++++++++ No Catch ++++++++"
  | to_catch ->
      prerr_endline "++++++++ To Catch ++++++++" ;
      List.iter
        (fun (p,i,_,pm) ->
          Printf.fprintf stderr "Handler %d: " i ;
          prerr_endline "" ;
          pretty_pm pm)
        to_catch ;
      prerr_endline "+++++++++++++++++++++"

let pretty_def def =
  List.iter
    (fun (pss,i) ->
      Printf.fprintf stderr "Matrix for %d\n"  i ;
      pretty_matrix pss)
    def

        

(* To group lines of patterns with identical keys *)

let add_line patl_action pm =
  pm.cases <- patl_action :: pm.cases; pm

type cell =
  {pm : pattern_matching ;
  ctx : ctx list ;
  pat : pattern}

let add make_matching_fun division key patl_action args =
  try
    let cell = List.assoc key division in
    cell.pm.cases <- patl_action :: cell.pm.cases;
    division
  with Not_found ->
    let cell = make_matching_fun args in
    cell.pm.cases <- [patl_action] ;
    (key, cell) :: division



(* To find reasonable names for let-bound and lambda-bound idents *)

let rec name_pattern default = function
    (pat :: patl, action) :: rem ->
      begin match pat.pat_desc with
        Tpat_var id -> id
      | Tpat_alias(p, id) -> id
      | _ -> name_pattern default rem
      end
  | _ -> Ident.create default


exception Not_simple

let rec raw_rec env = function
  | Llet(Alias,x,ex, body) -> raw_rec ((x,raw_rec env ex)::env) body
  | Lvar id as l ->
      begin try List.assoc id env with
      | Not_found -> l
      end
  | Lprim (Pfield i,args) ->
      Lprim (Pfield i, List.map (raw_rec env) args)
  | Lconst _ as l -> l
  | Lstaticraise (i,args) ->
        Lstaticraise (i, List.map (raw_rec env) args)
  | _ -> raise Not_simple

let raw_action l = try raw_rec [] l with Not_simple -> l

let same_actions = function
  | [] -> None
  | [_,act] -> Some act
  | (_,act0) :: rem ->
      try
        let raw_act0 = raw_rec [] act0 in
        let rec s_rec = function
          | [] -> Some act0
          | (_,act)::rem ->
              if raw_act0 = raw_rec [] act then
                s_rec rem
              else
                None in
        s_rec rem
      with
      | Not_simple -> None

let equal_action act1 act2 =
  try
    let raw1 = raw_rec [] act1
    and raw2 = raw_rec [] act2 in
    raw1 = raw2
  with
  | Not_simple -> false

let up_ok_action act1 act2 =
  try
    let raw1 = raw_rec [] act1
    and raw2 = raw_rec [] act2 in
    match raw1, raw2 with
    | Lstaticraise (i1,_), Lstaticraise (i2,_) -> i1=i2
    | _,_ -> raw1 = raw2
  with
  | Not_simple -> false

let up_ok (ps,act_p) l =
  List.for_all
    (fun (qs,act_q) ->
      up_ok_action act_p act_q ||
      not (Parmatch.compats ps qs))
    l

exception Same

let rec what_is_or = function
  | {pat_desc = Tpat_or (p,_,_)} -> what_is_or p
  | {pat_desc = (Tpat_alias (p,_))} -> what_is_or p        
  | {pat_desc=(Tpat_var _|Tpat_any)} -> fatal_error "Matching.what_is_or"
  | p -> p


(*
   Simplify fonction normalize the first column of the match
   - records are expanded so that they posses all fields
   - or-patterns equivalent to variables are replaced by those variables
*)

exception Var of pattern


let simplify_or p =
  let rec simpl_rec p = match p with
    | {pat_desc = Tpat_any|Tpat_var _} -> raise (Var p)
    | {pat_desc = Tpat_alias (q,id)} -> 
        begin try
          {p with pat_desc = Tpat_alias (simpl_rec q,id)}
        with
        | Var q -> raise (Var {p with pat_desc = Tpat_alias (q,id)})
        end
    | {pat_desc = Tpat_or (p1,p2,_)} ->
        {p with pat_desc = Tpat_or (simpl_rec p1, simpl_rec p2, None)}
    | {pat_desc = Tpat_record lbls} ->
        let all_lbls = all_record_args lbls in
        {p with pat_desc=Tpat_record all_lbls}        
    | _ -> p in
  try
    simpl_rec p
  with
  | Var p -> p


let simplify_matching m = match m.args with
| [] -> omega,m
| (arg, _) :: _ ->
    let ex_pat = ref None in
    let record_ex_pat p = match !ex_pat with
      | None -> ex_pat := Some p
      | _    -> () in

    let rec simplify = function
      | (pat :: patl, action as patl_action) :: rem ->
          begin match pat.pat_desc with
          | Tpat_var id ->
              (omega :: patl, bind Alias id arg action) ::
              simplify rem
          | Tpat_any ->
              patl_action :: simplify rem
          | Tpat_alias(p, id) ->
              simplify ((p :: patl, bind Alias id arg action) :: rem)
          | Tpat_record [] ->
              (omega :: patl, action)::
              simplify rem
          | Tpat_record lbls ->
              let all_lbls = all_record_args lbls in
              let full_pat = {pat with pat_desc=Tpat_record all_lbls} in
              record_ex_pat full_pat ;
              (full_pat::patl,action)::
              simplify rem
          | Tpat_or _ ->
              let pat_simple  = simplify_or pat in
              begin match pat_simple.pat_desc with
              | Tpat_or _ ->
                  let ex_pat = what_is_or pat_simple in
                  record_ex_pat ex_pat ;
                  (pat_simple :: patl, action) ::
                  simplify rem
              | _ ->
                  simplify ((pat_simple::patl,action) :: rem)
              end
          | _ ->
              record_ex_pat pat ;
              patl_action :: simplify rem
          end
      | [] -> []
      | _  -> assert false in
      let cases =  simplify m.cases in
      match !ex_pat with
      | None -> omega, {m with cases=cases}
      | Some p -> p,{m with cases = cases}



let rec what_is_cases cases = match cases with
| ({pat_desc=Tpat_any} :: _, _) :: rem -> what_is_cases rem
| (p::_,_)::_ -> p
| _ -> omega 



(* Optimize breaks *)
let as_matrix cases =
  get_mins le_pats (List.map (fun (ps,_) -> ps) cases)


let cons_default  matrix raise_num (_,default) =
  match matrix with
  | [] -> raise_num,default
  | _ -> raise_num,((matrix,raise_num)::default)

let default_compat p (exit,def) =
  exit,
  List.fold_right
    (fun (pss,i) r ->
      let qss =
        List.fold_right
          (fun qs r -> match qs with
            | q::rem when Parmatch.compat p q -> rem::r
            | _ -> r)
          pss [] in
      match qss with
      | [] -> r
      | _  -> (qss,i)::r)
    def []

let rec extract_vars r p = match p.pat_desc with
| Tpat_var id -> IdentSet.add id r
| Tpat_alias (p, id) ->
    extract_vars (IdentSet.add id r) p
| Tpat_tuple pats ->
    List.fold_left extract_vars r pats
| Tpat_record lpats ->
    List.fold_left
      (fun r (_,p) -> extract_vars r p)
      r lpats
| Tpat_construct (_,pats) ->
    List.fold_left extract_vars r pats
| Tpat_array pats ->
    List.fold_left extract_vars r pats
| Tpat_variant (_,Some p, _) -> extract_vars r p
| Tpat_or (p,_,_) -> extract_vars r p
| Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> r

exception Cannot_flatten

let mk_alpha_env arg aliases ids =
  List.map
    (fun id -> id,
      if List.mem id aliases then
        match arg with
        | Some v -> v
        | _      -> raise Cannot_flatten
      else 
        Ident.create (Ident.name id))
    ids

let rec explode_or_pat arg patl mk_action rem vars aliases = function
  | {pat_desc = Tpat_or (p1,p2,_)} ->
      explode_or_pat
        arg patl mk_action
        (explode_or_pat arg patl mk_action rem vars aliases p2)
        vars aliases p1
  | {pat_desc = Tpat_alias (p,id)} ->
      explode_or_pat arg patl mk_action rem vars (id::aliases) p
  | p ->
      let env = mk_alpha_env arg aliases vars in      
      (alpha_pat env p::patl,mk_action (List.map snd env))::rem

let equiv_pat p q = le_pat p q && le_pat q p

let rec get_equiv p l = match l with
  | (q::_,_) as cl::rem ->
      if equiv_pat p q then
        let others,rem = get_equiv p rem in
        cl::others,rem
      else
        [],l
  | _ -> [],l

let pm_free_variables {cases=cases} =
  List.fold_right
    (fun (_,act) r -> IdentSet.union (free_variables act) r)
    cases IdentSet.empty

let compile_or argo cl clor al def = match clor with
| [] ->
    {to_match = {cases=cl ; args=al ; default=def} ;
      to_catch = []}
| _  ->
    let rec do_cases = function
      | ({pat_desc=Tpat_or _} as orp::patl, action)::rem ->
          let others,rem = get_equiv orp rem in          
          let orpm =
            {cases =
              (patl, action)::
              List.map
                (function
                  | (_::ps,action) -> ps,action
                  | _ -> assert false)
                others ;
              args = List.tl al ;
              default = default_compat orp def} in
          begin match patl,action with
          | [],Lstaticraise (_,[]) ->
              let new_ord,new_to_catch = do_cases rem in
              let mk_new_action _ = action in
              explode_or_pat
                argo [] mk_new_action new_ord [] [] orp,
              new_to_catch
          | _,_ ->
          let vars =
            IdentSet.elements
              (IdentSet.inter
                 (extract_vars IdentSet.empty orp)
                 (pm_free_variables orpm)) in
          let or_num = next_raise_count () in
          let new_patl = Parmatch.omega_list patl in

          let mk_new_action vs =
            Lstaticraise
              (or_num, List.map (fun v -> Lvar v) vs) in

          let new_ord,new_to_catch = do_cases rem in
          explode_or_pat
            argo new_patl mk_new_action new_ord vars [] orp,
          (([[orp]], or_num, vars , orpm):: new_to_catch)
          end
      | cl::rem ->
          let new_ord,new_to_catch = do_cases rem in
          cl::new_ord,new_to_catch
      | [] -> [],[] in

    let to_match,to_catch = do_cases clor in
    {to_match = {args=al ; cases=cl@to_match ; default=def} ;
      to_catch = to_catch}


(* Basic grouping predicates *)

let group_constant = function
  | {pat_desc= Tpat_constant _} -> true
  | _                           -> false

and group_constructor = function
  | {pat_desc = Tpat_construct (_, _)} -> true
  | _ -> false

and group_variant = function
  | {pat_desc = Tpat_variant (_, _, _)} -> true
  | _ -> false

and group_var = function
  | {pat_desc=Tpat_any} -> true
  | _ -> false

and group_tuple = function
  | {pat_desc = (Tpat_tuple _|Tpat_any)} -> true
  | _ -> false

and group_record = function
  | {pat_desc = (Tpat_record _|Tpat_any)} -> true
  | _ -> false

and group_array = function
  | {pat_desc=Tpat_array _} -> true
  | _ -> false

let get_group p = match p.pat_desc with
| Tpat_any -> group_var
| Tpat_constant _ -> group_constant
| Tpat_construct (_, _) -> group_constructor
| Tpat_tuple _ -> group_tuple
| Tpat_record _ -> group_record
| Tpat_array _ -> group_array
| Tpat_variant (_,_,_) -> group_variant
|  _ -> fatal_error "Matching.get_group"


let all_vars pss = match pss with
| ps::_ -> List.for_all group_var ps
| _ -> false
(*
let all_vars _ = false
*)

let is_or p = match p.pat_desc with
| Tpat_or _ -> true
| _ -> false

(* Conditions for appending to the Or matrix *)
let conda p q = not (compat p q)
and condb act ps qs =  not (is_guarded act) && Parmatch.le_pats qs ps

let or_ok p ps l =
  List.for_all
    (function
      | ({pat_desc=Tpat_or _} as q::qs,act) ->
          conda p q || condb act ps qs
      | _ -> true)
    l

(* Insert or append a or-pattern in the Or matrix *)

let insert_or_append p ps act ors no =
  let rec attempt seen = function
    | (q::qs,act_q) as cl::rem ->
        if is_or q then begin
          if compat p q then
            if
              IdentSet.is_empty (extract_vars IdentSet.empty p) &&
              IdentSet.is_empty (extract_vars IdentSet.empty q) &&
              equiv_pat p q
            then (* attempt insert, for equivalent orpats with no variables *)
              let _, not_e = get_equiv q rem in
              if
                or_ok p ps not_e && (* check append condition for head of O *)
                List.for_all        (* check insert condition for tail of O *)
                  (fun cl -> match cl with
                  | (q::_,_) -> not (compat p q)
                  | _        -> assert false)
                  seen
              then (* insert *)
                List.rev_append seen ((p::ps,act)::cl::rem), no
              else (* fail to insert or append *)
                ors,(p::ps,act)::no
            else if condb act_q ps qs then (* check condition (b) for append *)
              attempt (cl::seen) rem 
            else
              ors,(p::ps,act)::no
          else (* p # q, go on with append/insert *)
            attempt (cl::seen) rem
        end else (* q is not a or-pat, go on with append/insert *)
          attempt (cl::seen) rem
    | _  -> (* [] in fact *)
        (p::ps,act)::ors,no in (* success in appending *)
  attempt [] ors


let separe argo pm =
  let ex_pat,pm = simplify_matching pm in
  match pm.cases with
  | [[{pat_desc=Tpat_any}],_] ->
      compile_or argo pm.cases [] pm.args pm.default,[]
  | _ -> 
      let next,nexts =
        match ex_pat.pat_desc with
        | Tpat_any -> compile_or argo pm.cases [] pm.args pm.default,[]
        | _ -> 
            let group = get_group ex_pat in

            let rec sep_ex yes ors no = function
              | ((p::ps,act) as cl)::rem ->
                  if group p then begin
                    if up_ok cl no then
                      if up_ok cl ors then
                        sep_ex (cl::yes) ors no rem
                      else if or_ok p ps ors then
                        sep_ex yes (cl::ors) no rem
                      else
                        sep_ex yes ors (cl::no) rem
                    else
                      sep_ex yes ors (cl::no) rem
                  end else if is_or p then begin
                    if up_ok cl no then
                      let ors,no = insert_or_append p ps act ors no in
                      sep_ex yes ors no rem 
                    else
                      sep_ex yes ors (cl::no) rem 
                  end else (* p is a variable *)
                    sep_ex yes ors (cl::no) rem
              | _ -> (* [] in fact *)
                  cons_next (List.rev yes) (List.rev ors) (List.rev no)
                    
            and sep_noex yes no = function
              | [ps,_ as cl]
                  when List.for_all group_var ps && yes <> [] ->
                    cons_next (List.rev yes) [] (List.rev (cl::no))
              | ((p::_,_) as cl)::rem ->
                  if group_var p && up_ok cl no then
                    sep_noex (cl::yes) no rem
                  else
                    sep_noex yes (cl::no) rem
              | _ -> (* [] in fact *)
                  cons_next (List.rev yes) [] (List.rev no)

            and sep_next cl rem = match cl with
            | ((p::_),_) ->
                if group p then
                  sep_ex [cl] [] [] rem
                else if is_or p then
                  sep_ex [] [cl] [] rem
                else
                  sep_noex [cl] [] rem
            | _ -> assert false

            and cons_next yes yesor = function
              | [] ->
                  as_matrix (yes@yesor),
                  compile_or argo yes yesor pm.args pm.default,[]
              | cl::rem ->
                  let matrix,next,nexts = sep_next cl rem in
                  begin match next with
                  (* Optimisation of jumps to jumps *)
                  | {to_match =
                      {cases=[ps,Lstaticraise (idef,[])]} ;
                      to_catch=[]}
                      when  List.for_all group_var ps ->
                      let newdef =
                        cons_default matrix idef next.to_match.default in
                      as_matrix (yes@yesor),
                      compile_or argo yes yesor pm.args newdef,
                      (-1,next)::nexts
                  | _ -> 
                      let idef = next_raise_count () in
                      let newdef =
                        cons_default matrix idef next.to_match.default in
                      as_matrix (yes@yesor),
                      compile_or argo yes yesor pm.args newdef,
                      (idef,next)::nexts
                  end in
            match pm.cases with
            | ((_::_),_) as cl::rem ->
                let _,next,nexts = sep_next cl rem in
                next, nexts
            | _                     ->
                compile_or argo pm.cases [] pm.args  pm.default,[] in
      (next,nexts)
  

        
(* General divide functions *)


let divide make get_key get_args ctx pm =

  let rec divide_rec = function
    | (p::patl,action) :: rem ->
        let this_match = divide_rec rem in
        add
          (make p pm.default ctx)
          this_match (get_key p) (get_args p patl,action) pm.args
    | _ -> [] in

  divide_rec pm.cases


let divide_line make_ctx make get_args pat ctx pm =
  let rec divide_rec = function
    | (p::patl,action) :: rem ->
        let this_match = divide_rec rem in
        add_line (get_args p patl, action) this_match
    | _ -> make pm.default pm.args in

  {pm = divide_rec pm.cases ;
  ctx=make_ctx ctx ;
  pat=pat}


let make_default matcher (exit,l) =
  let rec make_rec = function
    | [] -> []
    | ([[]],i)::_ -> [[[]],i]
    | (pss,i)::rem ->
        let rem = make_rec rem in
        match filter_matrix matcher pss with
        | [] -> rem
        | ([]::_) -> ([[]],i)::rem
        | pss -> (pss,i)::rem in
  exit,make_rec l

(* Then come various functions,
   There is one set of functions per match style
   (constants, constructors etc.

  - matcher function are arguments to make_default (for defaukt handlers)
    They may raise NoMatch or OrPat and perform the full
    matching (selection + arguments).

  
  - get_args and get_key are for the compiled matrices, note that
    selection and geting arguments are separed.

  - make_*_matching combines the previous functions for produicing
    new  ``pattern_matching'' records.
*)


let rec matcher_const cst p rem = match p.pat_desc with
| Tpat_or (p1,p2,_) ->
    begin try
      matcher_const cst p1 rem with
    | NoMatch -> matcher_const cst p2 rem
    end
| Tpat_constant c1 when c1=cst -> rem
| Tpat_any                     -> rem
| _ -> raise NoMatch

let get_key_constant caller = function
  | {pat_desc= Tpat_constant cst} as p -> cst
  | p ->
      prerr_endline ("BAD: "^caller) ;
      pretty_pat p ;
      
      assert false

let get_args_constant _ rem = rem

let make_constant_matching p def ctx = function
    [] -> fatal_error "Matching.make_constant_matching"
  | (_ :: argl) ->
      let def =
        make_default
          (matcher_const (get_key_constant "make" p)) def
      and ctx = 
        filter_ctx p  ctx in
      {pm = {cases = []; args = argl ; default = def} ;
       ctx = ctx ;
      pat = normalize_pat p}




let divide_constant ctx m =
  divide
    make_constant_matching (get_key_constant "divide")
    get_args_constant
    ctx m

(* Matching against a constructor *)


let make_field_args binding_kind arg first_pos last_pos argl =
  let rec make_args pos =
    if pos > last_pos
    then argl
    else (Lprim(Pfield pos, [arg]), binding_kind) :: make_args (pos + 1)
  in make_args first_pos

let get_key_constr = function
  | {pat_desc=Tpat_construct (cstr,_)} -> cstr.cstr_tag
  | _ -> assert false

let get_args_constr p rem = match p with
  | {pat_desc=Tpat_construct (_,args)} -> args @ rem
  | _ -> assert false

let pat_as_constr = function
  | {pat_desc=Tpat_construct (cstr,_)} -> cstr
  | _ -> fatal_error "Matching.pat_as_constr"


let matcher_constr cstr = match cstr.cstr_arity with
| 0 ->
    let rec matcher_rec q rem = match q.pat_desc with
    | Tpat_or (p1,p2,_) ->
        begin
          try
            matcher_rec p1 rem
          with
          | NoMatch -> matcher_rec p2 rem
        end
    | Tpat_construct (cstr1, []) when cstr.cstr_tag = cstr1.cstr_tag ->
        rem
    | Tpat_any -> rem
    | _ -> raise NoMatch in
    matcher_rec
| 1 ->
    let rec matcher_rec q rem = match q.pat_desc with
    | Tpat_or (p1,p2,_) ->
        let r1 = try Some (matcher_rec p1 rem) with NoMatch -> None
        and r2 = try Some (matcher_rec p2 rem) with NoMatch -> None in
        begin match r1,r2 with
        | None, None -> raise NoMatch
        | Some r1, None -> r1
        | None, Some r2 -> r2
        | Some (a1::rem1), Some (a2::_) ->
            {a1 with
              pat_loc = Location.none ;
              pat_desc = Tpat_or (a1, a2, None)}::
            rem
        | _, _ -> assert false
        end
    | Tpat_construct (cstr1, [arg]) when cstr.cstr_tag = cstr1.cstr_tag ->
        arg::rem
    | Tpat_any -> omega::rem
    | _ -> raise NoMatch in
    matcher_rec
| _ ->
    fun q rem -> match q.pat_desc with
    | Tpat_or (_,_,_) -> raise OrPat
    | Tpat_construct (cstr1, args)
        when cstr.cstr_tag = cstr1.cstr_tag -> args @ rem
    | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem
    | _        -> raise NoMatch

let make_constr_matching p def ctx = function
    [] -> fatal_error "Matching.make_constr_matching"
  | ((arg, mut) :: argl) ->
      let cstr = pat_as_constr p in
      let newargs =
        match cstr.cstr_tag with
          Cstr_constant _ | Cstr_block _ ->
            make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl
        | Cstr_exception _ ->
            make_field_args Alias arg 1 cstr.cstr_arity argl in
      {pm=
        {cases = []; args = newargs;
          default = make_default (matcher_constr cstr) def} ;
      ctx =  filter_ctx p ctx ;
      pat=normalize_pat p}


let divide_constructor ctx pm =
  divide
    make_constr_matching
    get_key_constr get_args_constr
    ctx pm

(* Matching against a variant *)

let rec matcher_variant_const lab p rem = match p.pat_desc with
| Tpat_or (p1, p2, _) ->
    begin
      try
        matcher_variant_const lab p1 rem
      with
      | NoMatch -> matcher_variant_const lab p2 rem
    end
| Tpat_variant (lab1,_,_) when lab1=lab -> rem
| Tpat_any -> rem
| _   -> raise NoMatch

    
let make_variant_matching_constant p lab def ctx = function
    [] -> fatal_error "Matching.make_variant_matching_constant"
  | ((arg, mut) :: argl) ->
      let def = make_default (matcher_variant_const lab) def
      and ctx = filter_ctx p ctx in
      {pm={ cases = []; args = argl ; default=def} ;
      ctx=ctx ;
      pat = normalize_pat p}

let matcher_variant_nonconst lab p rem = match p.pat_desc with
| Tpat_or (_,_,_) -> raise OrPat
| Tpat_variant (lab1,Some arg,_) when lab1=lab -> arg::rem
| Tpat_any -> omega::rem
| _   -> raise NoMatch


let make_variant_matching_nonconst p lab def ctx = function
    [] -> fatal_error "Matching.make_variant_matching_nonconst"
  | ((arg, mut) :: argl) ->
      let def = make_default (matcher_variant_nonconst lab) def
      and ctx = filter_ctx p ctx in
      {pm=
        {cases = []; args = (Lprim(Pfield 1, [arg]), Alias) :: argl;
          default=def} ;
        ctx=ctx ;
        pat = normalize_pat p}

let get_key_variant p = match p.pat_desc with
| Tpat_variant(lab, Some _ , _) ->  Cstr_block (Btype.hash_variant lab)
| Tpat_variant(lab, None , _) -> Cstr_constant (Btype.hash_variant lab)
|  _ -> assert false

let divide_variant row ctx ({cases = cl; args = al; default=def} as pm) =
  let row = Btype.row_repr row in
  let rec divide = function
      ({pat_desc = Tpat_variant(lab, pato, _)} as p:: patl, action) :: rem ->
        let variants = divide rem in
        if try Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent
           with Not_found -> true
        then
          variants
        else begin
          let tag = Btype.hash_variant lab in
          match pato with
            None ->
              add (make_variant_matching_constant p lab def ctx) variants
                   (Cstr_constant tag) (patl, action) al               
          | Some pat ->
              add (make_variant_matching_nonconst p lab def ctx) variants
                   (Cstr_block tag) (pat :: patl, action) al
        end
    | cl -> []
  in
  divide cl

(*
  Three ``no-test'' cases
*)

(* Matching against a variable *)

let get_args_var _ rem = rem


let make_var_matching def = function
  | [] ->  fatal_error "Matching.make_var_matching"
  | _::argl ->
      {cases=[] ;
        args = argl ;
        default= make_default get_args_var def}

let divide_var ctx pm =
  divide_line ctx_lshift make_var_matching get_args_var omega ctx pm

(* Matching against a tuple pattern *)


let get_args_tuple arity p rem = match p with
  | {pat_desc = Tpat_any} -> omegas arity @ rem
  | {pat_desc = Tpat_tuple args} ->
      args @ rem
  | _ ->  assert false

let matcher_tuple arity p rem = match p.pat_desc with
| Tpat_or (_,_,_)     -> raise OrPat
| Tpat_var _          -> get_args_tuple arity omega rem
| _                   ->  get_args_tuple arity p rem
  
let make_tuple_matching arity def = function
    [] -> fatal_error "Matching.make_tuple_matching"
  | (arg, mut) :: argl ->
      let rec make_args pos =
        if pos >= arity
        then argl
        else (Lprim(Pfield pos, [arg]), Alias) :: make_args (pos + 1) in
      {cases = []; args = make_args 0 ;
        default=make_default (matcher_tuple arity) def}


let divide_tuple arity p ctx pm =
  divide_line
    (filter_ctx p)
    (make_tuple_matching arity)
    (get_args_tuple  arity) p ctx pm

(* Matching against a record pattern *)


let record_matching_line num_fields lbl_pat_list =
  let patv = Array.create num_fields omega in
  List.iter (fun (lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list;
  Array.to_list patv

let get_args_record num_fields p rem = match p with
| {pat_desc=Tpat_any} ->
    record_matching_line num_fields [] @ rem
| {pat_desc=Tpat_record lbl_pat_list} ->
    record_matching_line num_fields lbl_pat_list @ rem
| _ -> assert false

let matcher_record num_fields p rem = match p.pat_desc with
| Tpat_or (_,_,_) -> raise OrPat
| Tpat_var _      -> get_args_record num_fields omega rem
| _               -> get_args_record num_fields p rem

let make_record_matching all_labels def = function
    [] -> fatal_error "Matching.make_record_matching"
  | ((arg, mut) :: argl) ->
      let rec make_args pos =
        if pos >= Array.length all_labels then argl else begin
          let lbl = all_labels.(pos) in
          let access =
            match lbl.lbl_repres with
              Record_regular -> Pfield lbl.lbl_pos
            | Record_float -> Pfloatfield lbl.lbl_pos in
          let str =
            match lbl.lbl_mut with
              Immutable -> Alias
            | Mutable -> StrictOpt in
          (Lprim(access, [arg]), str) :: make_args(pos + 1)
        end in
      let nfields = Array.length all_labels in
      let def= make_default (matcher_record nfields) def in
      {cases = []; args = make_args 0 ; default = def}


let divide_record all_labels p ctx pm =
  let get_args = get_args_record (Array.length all_labels) in
  divide_line
    (filter_ctx p)
    (make_record_matching all_labels)
    get_args
    p ctx pm

(* Matching against an array pattern *)

let get_key_array = function
  | {pat_desc=Tpat_array patl} -> List.length patl
  | _ -> assert false

let get_args_array p rem = match p with
  | {pat_desc=Tpat_array patl} -> patl@rem
  | _ -> assert false

let matcher_array len p rem = match p.pat_desc with
| Tpat_or (_,_,_) -> raise OrPat
| Tpat_array args when List.length args=len -> args @ rem
| Tpat_any -> Parmatch.omegas len @ rem
| _ -> raise NoMatch

let make_array_matching kind p def ctx = function
  | [] -> fatal_error "Matching.make_array_matching"
  | ((arg, mut) :: argl) ->
      let len = get_key_array p in
      let rec make_args pos =
        if pos >= len
        then argl
        else (Lprim(Parrayrefu kind, [arg; Lconst(Const_base(Const_int pos))]),
              StrictOpt) :: make_args (pos + 1) in
      let def = make_default (matcher_array len) def
      and ctx = filter_ctx p ctx in
      {pm={cases = []; args = make_args 0 ; default = def} ;
      ctx=ctx ;
      pat = normalize_pat p}

let divide_array kind ctx pm =
  divide
    (make_array_matching kind)
    get_key_array get_args_array ctx pm
  
(* To combine sub-matchings together *)

let sort_lambda_list l =
  List.sort
    (fun (x,_) (y,_) -> Pervasives.compare x y)
    l


let rec cut n l =
    if n = 0 then [],l
    else match l with
      [] -> raise (Invalid_argument "cut")
    | a::l -> let l1,l2 = cut (n-1) l in a::l1, l2

let rec do_tests_fail fail tst arg = function
  | [] -> fail
  | (c, act)::rem ->
      Lifthenelse
        (Lprim (tst, [arg ; Lconst (Const_base c)]),
         do_tests_fail fail tst arg rem,
         act)

let rec do_tests_nofail tst arg = function
  | [] -> fatal_error "Matching.do_tests_nofail"
  | [_,act] -> act
  | (c,act)::rem ->
      Lifthenelse
        (Lprim (tst, [arg ; Lconst (Const_base c)]),
         do_tests_nofail tst arg rem,
         act)

let make_test_sequence fail tst lt_tst arg const_lambda_list =
  let rec make_test_sequence const_lambda_list =
    if List.length const_lambda_list >= 4 && lt_tst <> Praise then
      split_sequence const_lambda_list
    else match fail with
    | None -> do_tests_nofail tst arg const_lambda_list
    | Some fail -> do_tests_fail fail tst arg const_lambda_list

  and split_sequence const_lambda_list =
    let list1, list2 =
          cut (List.length const_lambda_list / 2) const_lambda_list in
    Lifthenelse(Lprim(lt_tst,[arg; Lconst(Const_base (fst(List.hd list2)))]),
                make_test_sequence list1, make_test_sequence list2)
  in make_test_sequence (sort_lambda_list const_lambda_list)


let make_offset x arg = if x=0 then arg else Lprim(Poffsetint(x), [arg])



let prim_string_notequal =
  Pccall{prim_name = "string_notequal";
         prim_arity = 2; prim_alloc = false;
         prim_native_name = ""; prim_native_float = false}

let rec explode_inter offset i j act k =
  if i <= j then
    explode_inter offset i (j-1) act ((j-offset,act)::k)
  else
    k

let max_vals cases acts =
  let vals = Array.create (Array.length acts) 0 in
  for i=Array.length cases-1 downto 0 do
    let l,h,act = cases.(i) in
    vals.(act) <- h - l + 1 + vals.(act)
  done ;
  let max = ref 0 in
  for i = Array.length vals-1 downto 0 do
    if vals.(i) >= vals.(!max) then
      max := i
  done ;
  if vals.(!max) > 1 then
    !max
  else
    -1

let as_int_list cases acts =
  let default = max_vals cases acts in
  let min_key,_,_ = cases.(0)
  and _,max_key,_ = cases.(Array.length cases-1) in
  let offset = max_key-min_key in
  let rec do_rec i k =
    if i >= 0 then
      let low, high, act =  cases.(i) in
      if act = default then
        do_rec (i-1) k
      else
        do_rec (i-1) (explode_inter min_key low high acts.(act) k)
    else
      k in
  min_key, max_key,do_rec (Array.length cases-1) [],
  (if default >= 0 then Some acts.(default) else None)


let make_switch_offset arg min_key max_key int_lambda_list default  =
  let numcases = max_key - min_key + 1 in
  let cases =
    List.map (fun (key, l) -> (key - min_key, l)) int_lambda_list in
  let offsetarg = make_offset (-min_key) arg in
  Lswitch(offsetarg,
          {sw_numconsts = numcases; sw_consts = cases;
          sw_numblocks = 0; sw_blocks = [];
          sw_failaction = default})

let make_switch_switcher arg cases acts =
  let l = ref [] in
  for i = Array.length cases-1 downto 0 do
    l := (i,acts.(cases.(i))) ::  !l
  done ;    
  Lswitch(arg,
          {sw_numconsts = Array.length cases ; sw_consts = !l ;
           sw_numblocks = 0 ; sw_blocks =  []  ;
           sw_failaction = None})
           
let full sw =
  List.length sw.sw_consts = sw.sw_numconsts &&
  List.length sw.sw_blocks = sw.sw_numblocks
  
let make_switch (arg,sw) = match sw.sw_failaction with
| None ->
    let t = Hashtbl.create 17 in
    let seen l = match l with
    | Lstaticraise (i,[]) ->
      let old = try Hashtbl.find t i with Not_found -> 0 in
      Hashtbl.replace t i (old+1)
    | _ -> () in
    List.iter (fun (_,lam) -> seen lam) sw.sw_consts ;
    List.iter (fun (_,lam) -> seen lam) sw.sw_blocks ;
    let i_max = ref (-1)
    and max = ref (-1) in
    Hashtbl.iter
      (fun i c ->
        if c > !max then begin
          i_max := i ;
          max := c
        end) t ;
    if !i_max >= 0 then
      let default = !i_max in
      let rec remove = function
        | [] -> []
        | (_,Lstaticraise (j,[]))::rem when j=default ->
            remove rem
        | x::rem -> x::remove rem in
       Lswitch
        (arg,
         {sw with
         sw_consts = remove sw.sw_consts ;
         sw_blocks = remove sw.sw_blocks ;
         sw_failaction = Some (Lstaticraise (default,[]))})
    else
       Lswitch (arg,sw)
| _ -> Lswitch (arg,sw)
      
module SArg = struct
  type primitive = Lambda.primitive

  let eqint = Pintcomp Ceq
  let neint = Pintcomp Cneq
  let leint = Pintcomp Cle
  let ltint = Pintcomp Clt
  let geint = Pintcomp Cge
  let gtint = Pintcomp Cgt

  type act = Lambda.lambda

  let make_prim p args = Lprim (p,args)
  let make_offset arg n = match n with
  | 0 -> arg
  | _ -> Lprim (Poffsetint n,[arg])
  let bind arg body =
    let newvar,newarg = match arg with
    | Lvar v -> v,arg
    | _      ->
        let newvar = Ident.create "switcher" in
        newvar,Lvar newvar in
    bind Alias newvar arg (body newarg)

  let make_isout h arg = Lprim (Pisout, [h ; arg])
  let make_isin h arg = Lprim (Pnot,[make_isout h arg])
  let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot)
  let make_switch = make_switch_switcher
end

module Switcher = Switch.Make(SArg)
open Switch

let lambda_of_int i =  Lconst (Const_base (Const_int i))

let rec last def = function
| [] -> def
| [x,_] -> x
| _::rem -> last def rem

let get_edges low high l = match l with
| [] -> low, high
| (x,_)::_ -> x, last high l

  
let as_interval_canfail fail low high l =
  let store = mk_store equal_action in
  let rec nofail_rec cur_low cur_high cur_act = function
    | [] ->
        if cur_high = high then
          [cur_low,cur_high,cur_act]
        else
          [(cur_low,cur_high,cur_act) ; (cur_high+1,high, 0)]
    | ((i,act_i)::rem) as all ->
        let act_index = store.act_store act_i in
        if cur_high+1= i then
          if act_index=cur_act then
            nofail_rec cur_low i cur_act rem
          else if act_index=0 then
            (cur_low,i-1, cur_act)::fail_rec i i rem
          else
            (cur_low, i-1, cur_act)::nofail_rec i i act_index rem
        else
          (cur_low, cur_high, cur_act)::
          fail_rec ((cur_high+1)) (cur_high+1) all

  and fail_rec cur_low cur_high = function
    | [] -> [(cur_low, cur_high, 0)]
    | (i,act_i)::rem ->
        let index = store.act_store act_i in
        if index=0 then fail_rec cur_low i rem
        else
          (cur_low,i-1,0)::
          nofail_rec i i index rem in

  let rec init_rec = function
    | [] -> []
    | (i,act_i)::rem as all ->
        let index = store.act_store act_i in
        if index=0 then
          fail_rec low i rem
        else
          if low < i then
            (low,i-1,0)::nofail_rec i i index rem
          else
            nofail_rec i i index rem in

  ignore (store.act_store fail) ; (* fail has action index 0 *)
  let r = init_rec l in
  Array.of_list r,  store.act_get ()

let as_interval_nofail l =
  let store = mk_store equal_action in

  let rec i_rec cur_low cur_high cur_act = function
    | [] ->
        [cur_low, cur_high, cur_act]
    | (i,act)::rem ->
        let act_index = store.act_store act in
        if act_index = cur_act then
          i_rec cur_low i cur_act rem
        else
          (cur_low, cur_high, cur_act)::
          i_rec i i act_index rem in
  let inters = match l with
  | (i,act)::rem ->
      let act_index = store.act_store act in
      i_rec i i act_index rem
  | _ -> assert false in

  Array.of_list inters, store.act_get ()

let as_interval fail low high l =
  let l = sort_lambda_list l in
  get_edges low high l,
  (match fail with
  | None -> as_interval_nofail l
  | Some act -> as_interval_canfail act low high l)

let call_switcher konst fail arg low high int_lambda_list =
  let edges, (cases, actions) =
    as_interval fail low high int_lambda_list in
  Switcher.zyva edges konst arg cases actions


let exists_ctx ok ctx =
  List.exists
    (function
      | {right=p::_} -> ok p
      | _ -> assert false)
    ctx

let rec list_as_pat = function
  | [] -> fatal_error "Matching.list_as_pat"
  | [pat] -> pat
  | pat::rem ->
      {pat with pat_desc = Tpat_or (pat,list_as_pat rem,None)}


let rec pat_as_list k = function
  | {pat_desc=Tpat_or (p1,p2,_)} ->
      pat_as_list (pat_as_list k p2) p1
  | p -> p::k

(* Extracting interesting patterns *)
exception All

let rec extract_pat seen k p = match p.pat_desc with
| Tpat_or (p1,p2,_) ->
    let k1,seen1 = extract_pat seen k p1 in
    extract_pat seen1 k1 p2
| Tpat_alias (p,_) ->
    extract_pat  seen k p
| Tpat_var _|Tpat_any ->
    raise All
| _ ->
    let q = normalize_pat p in
    if  List.exists (compat q) seen then
      k, seen
    else
      q::k, q::seen

let extract_mat seen pss =
  let r,_ =
    List.fold_left
      (fun (k,seen) ps -> match ps with
      | p::_ -> extract_pat seen k p
      | _ -> assert false)
      ([],seen)
      pss in
  r



let complete_pats_constrs = function
  | p::_ as pats ->
      List.map
        (pat_of_constr p)
        (complete_constrs p (List.map get_key_constr pats))
  | _ -> assert false


let mk_res get_key env last_choice idef cant_fail ctx =

  let env,fail,jumps_fail = match last_choice with
  | [] ->
      env, None, jumps_empty
  | [p] when group_var p ->
      env,
      Some (Lstaticraise (idef,[])),
      jumps_singleton idef ctx
  | _ ->
      (idef,cant_fail,last_choice)::env,
      None, jumps_empty in
  let klist,jumps =
    List.fold_right
      (fun (i,cant_fail,pats) (klist,jumps) ->
        let act = Lstaticraise (i,[])
        and pat = list_as_pat pats in
        let klist =
          List.fold_right
            (fun pat klist -> (get_key pat,act)::klist)
            pats klist              
        and ctx = if cant_fail then ctx else ctx_lub pat ctx in
        klist,jumps_add i ctx jumps)
      env ([],jumps_fail) in
  fail, klist, jumps
      

(* Aucune optimisation, reflechir apres la release *)
let mk_failaction_neg get_key partial seen ctx (_,def) = match partial with
| Partial -> begin match def with
  | (_,idef)::_ ->
      Some (Lstaticraise (idef,[])),[],jumps_singleton idef ctx
  | __ -> assert false
end
| Total ->
    None, [], jumps_empty
    
  
(* Conforme a l'article et plus simple qu'avant *)
and mk_failaction_pos partial seen ctx (_,defs)  =
  let rec scan_def env to_test defs = match to_test,defs with
  | ([],_)|(_,[]) ->
      List.fold_left
        (fun  (klist,jumps) (pats,i)->
          let action = Lstaticraise (i,[]) in
          let klist =
            List.fold_right
              (fun pat r -> (get_key_constr pat,action)::r)
              pats klist
          and jumps =
            jumps_add i (ctx_lub (list_as_pat pats) ctx) jumps in
          klist,jumps)
        ([],jumps_empty) env
  | _,(pss,idef)::rem ->
      let now, later =
        List.partition
          (fun (p,p_ctx) -> ctx_match p_ctx pss) to_test in
      match now with
      | [] -> scan_def env to_test rem
      | _  -> scan_def ((List.map fst now,idef)::env) later rem in

  scan_def
    []
    (List.map
      (fun pat -> pat, ctx_lub pat ctx)
      (complete_pats_constrs seen))
    defs

      
let combine_constant arg cst partial ctx def 
    (const_lambda_list, total, pats) =
  let fail, to_add, local_jumps =
    mk_failaction_neg
      (get_key_constant "combine_constant")
      partial pats ctx def in
  let const_lambda_list = to_add@const_lambda_list in
  let lambda1 =
    match cst with
    | Const_int _ ->
        let int_lambda_list =
          List.map (function Const_int n, l -> n,l | _ -> assert false)
            const_lambda_list in
        call_switcher
          lambda_of_int fail arg min_int max_int int_lambda_list
    | Const_char _ ->
        let int_lambda_list =
          List.map (function Const_char c, l -> (Char.code c, l)
            | _ -> assert false)
            const_lambda_list in
        call_switcher
          (fun i -> Lconst (Const_base (Const_int i)))
          fail arg 0 255 int_lambda_list
    | Const_string _ ->
        make_test_sequence
          fail prim_string_notequal Praise arg const_lambda_list
    | Const_float _ ->
        make_test_sequence
          fail
          (Pfloatcomp Cneq) (Pfloatcomp Clt)
          arg const_lambda_list in
  lambda1,jumps_union local_jumps total



let split_cases tag_lambda_list =
  let rec split_rec = function
      [] -> ([], [])
    | (cstr, act) :: rem ->
        let (consts, nonconsts) = split_rec rem in
        match cstr with
          Cstr_constant n -> ((n, act) :: consts, nonconsts)
        | Cstr_block n    -> (consts, (n, act) :: nonconsts)
        | _ -> assert false in
  let const, nonconst = split_rec tag_lambda_list in
  sort_lambda_list const,
  sort_lambda_list nonconst
  

let combine_constructor arg ex_pat cstr partial ctx def
    (tag_lambda_list, total1, pats) =
  if cstr.cstr_consts < 0 then begin
    (* Special cases for exceptions *)    
    let cstrs = List.map fst tag_lambda_list in
    let fail, to_add, local_jumps =
      mk_failaction_neg get_key_constr partial pats ctx def in
    let tag_lambda_list = to_add@tag_lambda_list in
    let lambda1 =
      let default, tests =
        match fail with
        | None ->
            begin match tag_lambda_list with
            | (_, act)::rem -> act,rem
            | _ -> assert false
            end
        | Some fail -> fail, tag_lambda_list in
      List.fold_right
        (fun (ex, act) rem ->
          match ex with
          | Cstr_exception path ->
              Lifthenelse(Lprim(Pintcomp Ceq,
                                [Lprim(Pfield 0, [arg]); transl_path path]),
                          act, rem)
          | _ -> assert false)
        tests default in
    lambda1, jumps_union local_jumps total1
  end else begin
    (* Regular concrete type *)
    let ncases = List.length tag_lambda_list
    and nconstrs =  cstr.cstr_consts + cstr.cstr_nonconsts in
    let sig_complete = ncases = nconstrs
    and cstrs = List.map fst tag_lambda_list in
    let fails,local_jumps =
      if sig_complete then [],jumps_empty
      else
        mk_failaction_pos
          partial pats ctx def in

    let tag_lambda_list = fails @ tag_lambda_list in
    let (consts, nonconsts) = split_cases tag_lambda_list in
    let lambda1 =
      match same_actions tag_lambda_list with
      | Some act -> act
      | _ ->
          match
            (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts)
          with
          | (1, 1, [0, act1], [0, act2]) ->
              Lifthenelse(arg, act2, act1)
          | (n,_,_,[])  ->
              call_switcher
                (fun i -> Lconst (Const_base (Const_int i)))
                None arg 0 (n-1) consts
          | (n, _, _, _) ->
              match same_actions nonconsts with
              | None ->
                 make_switch(arg, {sw_numconsts = cstr.cstr_consts;
                                 sw_consts = consts;
                                 sw_numblocks = cstr.cstr_nonconsts;
                                 sw_blocks = nonconsts;
                                 sw_failaction = None})
              | Some act ->
                  Lifthenelse
                    (Lprim (Pisint, [arg]),
                     call_switcher
                       (fun i -> Lconst (Const_base (Const_int i)))
                       None arg
                       0 (n-1) consts,
                     act) in
    lambda1, jumps_union local_jumps total1
  end

let make_test_sequence_variant_constant fail arg int_lambda_list =
  let _, (cases, actions) =
    as_interval fail min_int max_int int_lambda_list in
  Switcher.test_sequence
    (fun i -> Lconst (Const_base (Const_int i))) arg cases actions

let call_switcher_variant_constant fail arg int_lambda_list =
  call_switcher
    (fun i -> Lconst (Const_base (Const_int i)))
    fail arg min_int max_int int_lambda_list


let call_switcher_variant_constr fail arg int_lambda_list =
  let v = Ident.create "variant" in
  Llet(Alias, v, Lprim(Pfield 0, [arg]),
       call_switcher
         (fun i -> Lconst (Const_base (Const_int i)))
         fail (Lvar v) min_int max_int int_lambda_list)

let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) =
  let row = Btype.row_repr row in
  let num_constr = ref 0 in
  if row.row_closed then
    List.iter
      (fun (_, f) ->
        match Btype.row_field_repr f with
          Rabsent | Reither(true, _::_, _, _) -> ()
        | _ -> incr num_constr)
      row.row_fields
  else
    num_constr := max_int;
  let test_int_or_block arg if_int if_block =
    Lifthenelse(Lprim (Pisint, [arg]), if_int, if_block) in
  let sig_complete =  List.length tag_lambda_list = !num_constr
  and one_action = same_actions tag_lambda_list in
  let fail, to_add, local_jumps =
    if sig_complete || (match partial with Total -> true | _ -> false) then
      None, [], jumps_empty
    else
      mk_failaction_neg get_key_variant
        partial pats ctx def in
  let tag_lambda_list = to_add@tag_lambda_list in
  let (consts, nonconsts) = split_cases tag_lambda_list in
  let lambda1 = match fail, one_action with
  | None, Some act -> act
  | _,_ ->
      match (consts, nonconsts) with
      | ([n, act1], [m, act2]) when fail=None ->
          test_int_or_block arg act1 act2
      | (_, []) -> (* One can compare integers and pointers *)
          make_test_sequence_variant_constant fail arg consts
      | ([], _) ->
          let lam = call_switcher_variant_constr
                       fail arg nonconsts in
          (* One must not dereference integers *)
          begin match fail with
          | None -> lam
          | Some fail -> test_int_or_block arg fail lam
          end
      | (_, _) ->
          let lam_const =
            call_switcher_variant_constant
              fail arg consts
          and lam_nonconst =
            call_switcher_variant_constr
              fail arg nonconsts in
          test_int_or_block arg lam_const lam_nonconst
  in
  lambda1, jumps_union local_jumps total1

    
let combine_array arg kind partial ctx def
    (len_lambda_list, total1, pats)  =
  let fail, to_add, local_jumps =
    mk_failaction_neg get_key_array partial pats ctx def in
  let len_lambda_list = to_add @ len_lambda_list in
  let lambda1 =
    let newvar = Ident.create "len" in
    let switch =
      call_switcher
        lambda_of_int
        fail (Lvar newvar)
        0 max_int len_lambda_list in
    bind
      Alias newvar (Lprim(Parraylength kind, [arg])) switch in
  lambda1, jumps_union local_jumps total1

(* Insertion of debugging events *)

let rec event_branch repr lam =
  begin match lam, repr with
    (_, None) ->
      lam
  | (Levent(lam', ev), Some r) ->
      incr r;
      Levent(lam', {lev_loc = ev.lev_loc;
                    lev_kind = ev.lev_kind;
                    lev_repr = repr;
                    lev_env = ev.lev_env})
  | (Llet(str, id, lam, body), _) ->
      Llet(str, id, lam, event_branch repr body)
  | Lstaticraise _,_ -> lam
  | (_, Some r) ->
      Printlambda.lambda Format.str_formatter lam ;
      fatal_error
        ("Matching.event_branch: "^Format.flush_str_formatter ())
  end


exception Unused 

let compile_list compile_fun division = 

  let rec c_rec totals = function
  | [] -> [], jumps_unions totals, []
  | (key, cell) :: rem ->
      begin match cell.ctx with
      | [] -> c_rec totals rem
      | _  ->
          try
            let (lambda1, total1) = compile_fun cell.ctx cell.pm in            
            let c_rem, total, new_pats =
              c_rec
                (jumps_map ctx_combine total1::totals) rem in
            ((key,lambda1)::c_rem), total, (cell.pat::new_pats)
          with
          | Unused -> c_rec totals rem
      end in
  c_rec [] division


let compile_orhandlers compile_fun lambda1 total1 ctx to_catch =
  let rec do_rec r total_r = function
    | [] -> r,total_r
    | (mat,i,vars,pm)::rem ->
        begin try
          let ctx = select_columns mat ctx in
          let handler_i, total_i = compile_fun ctx pm in
          match raw_action r with
          | Lstaticraise (j,args) ->
              if i=j then
                List.fold_right2 (bind Alias) vars args handler_i,
                jumps_map (ctx_rshift_num (ncols mat)) total_i
              else
                do_rec r total_r rem
          | _ ->
              do_rec
                (Lstaticcatch (r,(i,vars), handler_i))
                (jumps_union
                   (jumps_remove i total_r)
                   (jumps_map (ctx_rshift_num (ncols mat)) total_i))
              rem
        with
        | Unused ->
            do_rec (Lstaticcatch (r, (i,vars), lambda_unit)) total_r rem
        end in
  do_rec lambda1 total1 to_catch


let compile_test compile_fun divide combine ctx to_match to_catch =
  let division = divide ctx to_match in
  let c_div = compile_list compile_fun division in
  match c_div with
  | [],_,_ -> raise Unused
  | _ ->
      let lambda1,total1 = 
        combine ctx to_match.default c_div in
      compile_orhandlers compile_fun  lambda1 total1 ctx to_catch


(* Attempt to avoid some useless bindinds by lowering them *)

(* Approximation of v present in lam *)
let rec approx_present v = function
  | Lconst _ -> false
  | Lstaticraise (_,args) ->
      List.exists (fun lam -> approx_present v lam) args
  | Lprim (_,args) ->
      List.exists (fun lam -> approx_present v lam) args
  | Llet (Alias, _, l1, l2) ->
      approx_present v l1 || approx_present v l2
  | Lvar vv -> Ident.same v vv
  | _ -> true

let string_of_lam lam =
  Printlambda.lambda Format.str_formatter lam ;
  Format.flush_str_formatter ()

let rec lower_bind v arg lam = match lam with
| Lifthenelse (cond, ifso, ifnot) ->
    let pcond = approx_present v cond
    and pso = approx_present v ifso
    and pnot = approx_present v ifnot in
    begin match pcond, pso, pnot with
    | false, false, false -> lam
    | false, true, false ->        
        Lifthenelse (cond, lower_bind v arg ifso, ifnot)
    | false, false, true ->
        Lifthenelse (cond, ifso, lower_bind v arg ifnot)
    | _,_,_ -> bind Alias v arg lam
    end
| Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw))
    when not (approx_present v ls) ->
      Lswitch (ls, {sw with sw_consts = [i,lower_bind v arg act]})
| Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw))
    when not (approx_present v ls) ->
      Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]})
| Llet (Alias, vv, lv, l) ->
    if approx_present v lv then
      bind Alias v arg lam
    else
      Llet (Alias, vv, lv, lower_bind v arg l)
| _ -> 
    bind Alias v arg lam

let bind_check str v arg lam = match str,arg with
| _, Lvar _ ->bind str v arg lam
| Alias,_ -> lower_bind v arg lam 
| _,_     -> bind str v arg lam

let rec comp_exit ctx m =
  match m.default with
  | exit,(_,i)::_ ->
      Lstaticraise (i,[]), jumps_singleton i ctx
  | _        -> fatal_error "Matching.comp_exit"

        

let comp_match_handlers comp_fun partial ctx arg first_match next_matchs =
  match next_matchs with
  | [] -> comp_fun partial ctx arg first_match
  | rem ->
      let rec c_rec body total_body = function
        | [] -> body, total_body
        (* Hum, -1 means never taken, needed for ``partial'' to be correct *)
        | (-1,pm)::rem -> c_rec body total_body rem
        | (i,pm)::rem -> 
            let ctx_i,total_rem = jumps_extract i total_body in
            begin match ctx_i with
            | [] -> c_rec body total_body rem
            | _ ->
                try
                  let li,total_i =
                    comp_fun
                      (match rem with [] -> partial | _ -> Partial)
                      ctx_i arg pm in
                  c_rec
                    (Lstaticcatch (body,(i,[]),li))
                    (jumps_union total_i total_rem)
                    rem
                with
                | Unused ->
                    c_rec (Lstaticcatch (body,(i,[]),lambda_unit))
                      total_rem  rem
            end in

      let first_lam,total =
        comp_fun Partial ctx arg first_match in
      c_rec first_lam total rem

(*
  The main compilation function.
   Input:
      repr=used for inserting debug events
      partial=exhaustiveness information from Parmatch
      ctx=a context
      m=a pattern matching

   Output: a lambda term, a jump summary {..., exit number -> context, .. }
*)


let rec compile_match repr partial ctx m = match m with
| { cases = [] } -> comp_exit ctx m
| { cases = ([], action) :: rem } ->
    if is_guarded action then begin
      let (lambda, total) =
        compile_match None partial ctx { m with cases = rem } in
      event_branch repr (patch_guarded lambda action), total
    end else
      (event_branch repr action, jumps_empty)
| { args = (arg, str)::argl } ->
    let v,newarg =
      match arg with
      | Lvar v -> v,arg
      | _ ->
          let v = name_pattern "match" m.cases in
          v,Lvar v in
    let first_match,rem =
      separe (Some v)
        { m with args = (newarg, Alias) :: argl } in
    let (lam, total) =
      comp_match_handlers
        (do_compile_matching repr) partial ctx newarg first_match rem in
    bind_check str v arg lam, total
| _ -> assert false


(* verbose version of do_compile_matching, for debug *)
and do_compile_matching_pr repr partial ctx arg x =
  prerr_endline "COMPILE" ;
  prerr_endline "MATCH" ;
  pretty_ext x ;
  prerr_endline "CTX" ;
  pretty_ctx ctx ;
  let (_, jumps) as r =  do_compile_matching repr partial ctx arg x in
  prerr_endline "JUMPS" ;
  pretty_jumps jumps ;    
  r

and do_compile_matching repr partial ctx arg
    {to_match=to_match; to_catch=to_catch} =

  let pat = what_is_cases to_match.cases in
  match pat.pat_desc with
  | Tpat_any ->
      assert (to_catch=[]) ;
      compile_no_test  divide_var ctx_rshift repr partial ctx to_match to_catch
  | Tpat_tuple patl ->
      compile_no_test
        (divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine
        repr partial ctx to_match to_catch
  | Tpat_record ((lbl,_)::_) ->
      compile_no_test
        (divide_record lbl.lbl_all (normalize_pat pat))
        ctx_combine repr partial ctx to_match to_catch
  | Tpat_constant cst ->
      compile_test
        (compile_match repr partial)
        divide_constant
        (combine_constant arg cst partial)
        ctx to_match to_catch
  | Tpat_construct (cstr, _) ->
      compile_test
        (compile_match repr partial)
        divide_constructor (combine_constructor arg pat cstr partial)
        ctx to_match to_catch
  | Tpat_array _ ->    
      let kind = Typeopt.array_pattern_kind pat in
      compile_test (compile_match repr partial)
        (divide_array kind) (combine_array arg kind partial)
        ctx to_match to_catch
  | Tpat_variant(lab, _, row) ->
      compile_test (compile_match repr partial)
        (divide_variant row)
        (combine_variant row arg partial)
        ctx to_match to_catch
  | _ ->
      fatal_error "Matching.do_compile_matching"

and compile_no_test divide up_ctx repr partial ctx to_match to_catch =
  let {pm=this_match ; ctx=this_ctx } = divide ctx to_match in
  let lambda,total = compile_match repr partial this_ctx this_match in
  let total = jumps_map up_ctx total in
  compile_orhandlers (compile_match repr partial) lambda total ctx to_catch




(* The entry points *)


(* had toplevel handler when appropriate *)

let start_ctx n = [{left=[] ; right = omegas n}]

let check_total total lambda i handler_fun =
  if jumps_is_empty total then
    lambda
  else begin
    Lstaticcatch(lambda, (i,[]), handler_fun())
  end

let compile_matching loc repr handler_fun arg pat_act_list partial =
  match partial with
  | Partial ->
      let raise_num = next_raise_count () in
      let pm =
        { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
          args = [arg, Strict] ;
          default = raise_num,[[[omega]],raise_num]} in
      begin try
        let (lambda, total) = compile_match repr partial (start_ctx 1) pm in
        check_total total lambda raise_num handler_fun
      with
      | Unused -> handler_fun()
      end
  | Total ->
      let pm =
        { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
          args = [arg, Strict] ;
          default = (-1,[])} in
      let (lambda, total) = compile_match repr partial (start_ctx 1) pm in
      assert (jumps_is_empty total) ;
      lambda

let partial_function loc () =
  Lprim(Praise, [Lprim(Pmakeblock(0, Immutable),
          [transl_path Predef.path_match_failure;
           Lconst(Const_block(0,
              [Const_base(Const_string !Location.input_name);
               Const_base(Const_int loc.Location.loc_start);
               Const_base(Const_int loc.Location.loc_end)]))])])

let for_function loc repr param pat_act_list partial =
  compile_matching loc repr (partial_function loc) param pat_act_list partial

(* In the following two cases, exhaustiveness info is not available! *)
let for_trywith param pat_act_list =
  compile_matching Location.none None (fun () -> Lprim(Praise, [param]))
    param pat_act_list Partial

let for_let loc param pat body =
  compile_matching loc None (partial_function loc) param [pat, body] Partial

(* Handling of tupled functions and matches *)


let flatten_pattern size p =
  match p.pat_desc with
    Tpat_tuple args -> args
  | Tpat_any -> omegas size  
  | _ -> raise Cannot_flatten



let rec flatten_pat_line size p k = match p.pat_desc with
| Tpat_any ->  omegas size::k
| Tpat_tuple args -> args::k
| Tpat_or (p1,p2,_) ->
    flatten_pat_line size p1 (flatten_pat_line size p2 k)
| _ -> fatal_error "Matching.flatten_pat_line"

let flatten_cases size cases =
  List.map
    (fun (ps,action) -> match ps with
    | [p] -> flatten_pattern size p,action
    | _ -> fatal_error "Matching.flatten_case")
    cases

let flatten_matrix size pss =
 List.fold_right
    (fun ps r -> match ps with
    | [p] -> flatten_pat_line size p r
    | _   -> fatal_error "Matching.flatten_matrix")
    pss []

let flatten_def size (exit,def) =
  exit,
  List.map
    (fun (pss,i) -> flatten_matrix size pss,i)
    def

let flatten_pm size al pm =
  {args = al ; cases = flatten_cases size pm.cases ;
  default = flatten_def size pm.default}

let flatten_extended size idl ext =
  {to_match = flatten_pm size idl ext.to_match ;
  to_catch = 
   List.map
      (fun (mat,i,vars,pm) -> flatten_matrix size mat,i,vars,pm)
      ext.to_catch}

let compile_flattened repr partial ctx _ 
    {to_match=to_match ; to_catch=to_catch} =
  let lambda,total = compile_match repr partial ctx to_match in
  compile_orhandlers (compile_match repr partial) lambda total ctx to_catch

let for_tupled_function loc paraml pats_act_list partial =
  let raise_num = next_raise_count () in
  let omegas = [List.map (fun _ -> omega) paraml] in
  let pm =
    { cases = pats_act_list;
      args = List.map (fun id -> (Lvar id, Strict)) paraml ;
      default = raise_num,[omegas,raise_num]
    } in
  try
    let (lambda, total) = compile_match None partial
        (start_ctx (List.length paraml)) pm in
    check_total total lambda raise_num (partial_function loc)
  with
  | Unused -> partial_function loc ()

let for_multiple_match loc paraml pat_act_list partial =
  let repr = None in
  let raise_num,pm1 = match partial with
  | Partial ->
      let raise_num = next_raise_count () in
      raise_num,
      { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
        args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] ;
        default = raise_num,[[[omega]],raise_num] }
  | _ ->
      -1,
      { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
        args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] ;
        default = -1,[] } in
      
  try
  try

    let next,nexts = separe None pm1 in

    let size = List.length paraml in
    let idl = List.map (fun _ -> Ident.create "match") paraml in
    let al =  List.map (fun id -> (Lvar id, Alias)) idl in
    let omegas = [List.map (fun _ -> omega) idl] in
    let flat_next = flatten_extended size al next
    and flat_nexts =
      List.map (fun (i,x) -> i,flatten_extended size al x) nexts in
  

    let lambda,total =
      comp_match_handlers
        (compile_flattened repr)
        partial (start_ctx size) staticfail flat_next flat_nexts in
    List.fold_right2 (bind Strict) idl paraml
      (match partial with
      | Partial ->
          check_total total lambda raise_num (partial_function loc)
      | Total ->
          assert (jumps_is_empty total) ;
          lambda)
          

  with Cannot_flatten ->
    let (lambda, total) = compile_match None partial (start_ctx 1) pm1 in
    begin match partial with
    | Partial ->
        check_total total lambda raise_num (partial_function loc)
    | Total ->
        assert (jumps_is_empty total) ;
        lambda
    end
  with Unused ->
    partial_function loc ()

