(***********************************************************************) (* *) (* 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$ *) (* 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. *) let pretty_pat p = Parmatch.top_pretty Format.str_formatter p ; prerr_string (Format.flush_str_formatter ()) type matrix = pattern list list let pretty_line ps = List.iter (fun p -> Parmatch.top_pretty Format.str_formatter p ; prerr_string " <" ; prerr_string (Format.flush_str_formatter ()) ; prerr_string ">") ps let pretty_matrix pss = prerr_endline "begin matrix" ; List.iter (fun ps -> pretty_line ps ; prerr_endline "") pss ; prerr_endline "end matrix" 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 Unused let filter_matrix matcher pss = let rec filter_rec = function | (p::ps)::rem -> begin match p.pat_desc with | Tpat_or (p1,p2,_) -> filter_rec ((p1::ps)::(p2::ps)::rem) | 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 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} (* Matching against a constant *) 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 let matcher_const cst p rem = match p.pat_desc with | 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 q rem = match q.pat_desc with | 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 matcher_variant_const lab p rem = match p.pat_desc with | 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_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 (* 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 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 (get_args_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 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 (get_args_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_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 ()