summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorLuc Maranget <luc.maranget@inria.fr>2001-02-19 20:27:52 +0000
committerLuc Maranget <luc.maranget@inria.fr>2001-02-19 20:27:52 +0000
commiteb7578b8db11dbed6960a35abab066ca514592ff (patch)
treead68142169fee502c7f60d073af69121c726495d
parenta9c4a16caaac6a3fe6907dd87cc63366fc492ef8 (diff)
optimsation pm a donf
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3427 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
Diffstat
-rw-r--r--bytecomp/bytegen.ml91
-rw-r--r--bytecomp/lambda.ml48
-rw-r--r--bytecomp/lambda.mli19
-rw-r--r--bytecomp/matching.ml2291
-rw-r--r--bytecomp/matching.mli1
-rw-r--r--bytecomp/printlambda.ml26
-rw-r--r--bytecomp/simplif.ml107
-rw-r--r--bytecomp/switch.ml209
-rw-r--r--bytecomp/switch.mli9
-rw-r--r--bytecomp/translcore.ml10
-rw-r--r--byterun/fix_code.c4
-rw-r--r--byterun/interp.c6
-rw-r--r--driver/optmain.ml4
-rw-r--r--tools/dumpobj.ml1
-rw-r--r--typing/parmatch.ml220
-rw-r--r--typing/parmatch.mli22
-rw-r--r--utils/clflags.ml2
17 files changed, 2039 insertions, 1031 deletions
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index 26b93d7e8..c71c1eac6 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -19,6 +19,7 @@ open Asttypes
open Primitive
open Types
open Lambda
+open Switch
open Instruct
(**** Label generation ****)
@@ -224,12 +225,8 @@ let add_event ev =
(**** Compilation of a lambda expression ****)
-(* The label to which Lstaticfail branches, and the stack size at that point.*)
+(* association staticraise numbers -> (lbl,size of stack *)
-let lbl_staticfail = ref None
-and sz_staticfail = ref 0
-
-(* Same information as a stack for Lstaticraise *)
let sz_static_raises = ref []
let find_raise_label i =
try
@@ -241,13 +238,6 @@ let find_raise_label i =
(* Will the translation of l lead to a jump to label ? *)
let code_as_jump l sz = match l with
-| Lstaticfail ->
- if sz = !sz_staticfail then
- match !lbl_staticfail with
- | Some label -> Some label
- | None -> Misc.fatal_error "exit outside appropriated catch"
- else
- None
| Lstaticraise (i,[]) ->
let label,size = find_raise_label i in
if sz = size then
@@ -574,20 +564,6 @@ let rec comp_expr env exp sz cont =
comp_args env args sz (comp_primitive p args :: cont)
| Lprim(p, args) ->
comp_args env args sz (comp_primitive p args :: cont)
- | Lcatch(body, Lstaticfail) ->
- comp_expr env body sz cont
- | Lcatch(body, handler) ->
- let (branch1, cont1) = make_branch cont in
- let (lbl_handler, cont2) = label_code (comp_expr env handler sz cont1) in
- let saved_lbl_staticfail = !lbl_staticfail
- and saved_sz_staticfail = !sz_staticfail in
- lbl_staticfail := Some lbl_handler;
- sz_staticfail := sz;
- let cont3 = comp_expr env body sz (branch1 :: cont2) in
- lbl_staticfail := saved_lbl_staticfail;
- sz_staticfail := saved_sz_staticfail;
- cont3
- | Lstaticfail -> comp_static_fail sz cont
| Lstaticcatch (body, (i, vars) , handler) ->
let branch1, cont1 = make_branch cont
and nvars = List.length vars in
@@ -642,33 +618,37 @@ let rec comp_expr env exp sz cont =
| Lswitch(arg, sw) ->
let (branch, cont1) = make_branch cont in
let c = ref (discard_dead_code cont1) in
- let act_consts = Array.create sw.sw_numconsts Lstaticfail in
- List.iter (fun (n, act) -> act_consts.(n) <- act) sw.sw_consts;
- let act_blocks = Array.create sw.sw_numblocks Lstaticfail in
- List.iter (fun (n, act) -> act_blocks.(n) <- act) sw.sw_blocks;
- let lbl_consts = Array.create sw.sw_numconsts 0 in
+(* Build indirection vectors *)
+ let store = mk_store (=) in
+ let act_consts = Array.create sw.sw_numconsts 0
+ and act_blocks = Array.create sw.sw_numblocks 0 in
+ begin match sw.sw_failaction with (* default is index 0 *)
+ | Some fail -> ignore (store.act_store fail)
+ | None -> ()
+ end ;
+ List.iter
+ (fun (n, act) -> act_consts.(n) <- store.act_store act) sw.sw_consts;
+ List.iter
+ (fun (n, act) -> act_blocks.(n) <- store.act_store act) sw.sw_blocks;
+
+(* Compile and label actions *)
+ let acts = store.act_get () in
+ let lbls = Array.create (Array.length acts) 0 in
+ for i = Array.length acts-1 downto 0 do
+ let lbl,c1 = label_code (comp_expr env acts.(i) sz (branch :: !c)) in
+ lbls.(i) <- lbl ;
+ c := discard_dead_code c1
+ done ;
+
+(* Build label vectors *)
let lbl_blocks = Array.create sw.sw_numblocks 0 in
- let comp_nofail =
- if sw.sw_nofail then
- fun l c -> match l with
- | Lstaticfail -> label_code c
- | _ -> label_code(comp_expr env l sz (branch :: c))
- else
- fun l c ->
- label_code(comp_expr env l sz (branch :: c)) in
-
for i = sw.sw_numblocks - 1 downto 0 do
- let (lbl, c1) = comp_nofail act_blocks.(i) !c in
- lbl_blocks.(i) <- lbl;
- c := discard_dead_code c1
+ lbl_blocks.(i) <- lbls.(act_blocks.(i))
done;
+ let lbl_consts = Array.create sw.sw_numconsts 0 in
for i = sw.sw_numconsts - 1 downto 0 do
- let (lbl, c1) = comp_nofail act_consts.(i) !c in
- lbl_consts.(i) <- lbl;
- c := discard_dead_code c1
+ lbl_consts.(i) <- lbls.(act_consts.(i))
done;
- if sw.sw_checked && not sw.sw_nofail then
- c := comp_expr env Lstaticfail sz !c;
comp_expr env arg sz (Kswitch(lbl_consts, lbl_blocks) :: !c)
| Lassign(id, expr) ->
begin try
@@ -726,16 +706,6 @@ let rec comp_expr env exp sz cont =
| Lifused (_, exp) ->
comp_expr env exp sz cont
-(* compile a static failure, fails if not enclosing catch *)
-and comp_static_fail sz cont =
- let cont = discard_dead_code cont in
- begin match !lbl_staticfail with
- | None ->
- Misc.fatal_error "exit outside appropriated catch"
- | Some label ->
- add_pop (sz - !sz_staticfail) (branch_to label cont)
- end
-
(* Compile a list of arguments [e1; ...; eN] to a primitive operation.
The values of eN ... e2 are pushed on the stack, e2 at top of stack,
then e3, then ... The value of e1 is left in the accumulator. *)
@@ -809,8 +779,6 @@ let comp_remainder cont =
let compile_implementation modulename expr =
Stack.clear functions_to_compile;
label_counter := 0;
- lbl_staticfail := None;
- sz_staticfail := 0;
sz_static_raises := [] ;
compunit_name := modulename;
let init_code = comp_expr empty_env expr 0 [] in
@@ -823,8 +791,7 @@ let compile_implementation modulename expr =
let compile_phrase expr =
Stack.clear functions_to_compile;
label_counter := 0;
- lbl_staticfail := None;
- sz_staticfail := 0;
+ sz_static_raises := [] ;
let init_code = comp_expr empty_env expr 1 [Kreturn 1] in
let fun_code = comp_remainder [] in
(init_code, fun_code)
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 7153dbe72..c80f20d87 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -125,8 +125,6 @@ type lambda =
| Lletrec of (Ident.t * lambda) list * lambda
| Lprim of primitive * lambda list
| Lswitch of lambda * lambda_switch
- | Lstaticfail
- | Lcatch of lambda * lambda
| Lstaticraise of int * lambda list
| Lstaticcatch of lambda * (int * Ident.t list) * lambda
| Ltrywith of lambda * Ident.t * lambda
@@ -144,8 +142,7 @@ and lambda_switch =
sw_consts: (int * lambda) list;
sw_numblocks: int;
sw_blocks: (int * lambda) list;
- sw_checked: bool ;
- sw_nofail: bool }
+ sw_failaction : lambda option}
and lambda_event =
{ lev_loc: int;
@@ -205,10 +202,11 @@ let free_variables l =
| Lswitch(arg, sw) ->
freevars arg;
List.iter (fun (key, case) -> freevars case) sw.sw_consts;
- List.iter (fun (key, case) -> freevars case) sw.sw_blocks
- | Lstaticfail -> ()
- | Lcatch(e1, e2) ->
- freevars e1; freevars e2
+ List.iter (fun (key, case) -> freevars case) sw.sw_blocks;
+ begin match sw.sw_failaction with
+ | None -> ()
+ | Some l -> freevars l
+ end
| Lstaticraise (_,args) ->
List.iter freevars args
| Lstaticcatch(e1, (_,vars), e2) ->
@@ -235,13 +233,30 @@ let free_variables l =
in freevars l; !fv
(* Check if an action has a "when" guard *)
+let raise_count = ref 0
+
+let next_raise_count () =
+ incr raise_count ;
+ !raise_count
+
+(* Anticipated staticraise, for guards *)
+let staticfail = Lstaticraise (0,[])
let rec is_guarded = function
- Lifthenelse(cond, body, Lstaticfail) -> true
+ | Lifthenelse( cond, body, Lstaticraise (0,[])) -> true
| Llet(str, id, lam, body) -> is_guarded body
| Levent(lam, ev) -> is_guarded lam
| _ -> false
+let rec patch_guarded patch = function
+ | Lifthenelse (cond, body, Lstaticraise (0,[])) ->
+ Lifthenelse (cond, body, patch)
+ | Llet(str, id, lam, body) ->
+ Llet (str, id, lam, patch_guarded patch body)
+ | Levent(lam, ev) ->
+ Levent (patch_guarded patch lam, ev)
+ | _ -> fatal_error "Lambda.patch_guarded"
+
(* Translate an access path *)
let rec transl_path = function
@@ -279,10 +294,13 @@ let subst_lambda s lam =
| Lswitch(arg, sw) ->
Lswitch(subst arg,
{sw with sw_consts = List.map subst_case sw.sw_consts;
- sw_blocks = List.map subst_case sw.sw_blocks})
- | Lstaticfail as l -> l
- | Lcatch(e1, e2) -> Lcatch(subst e1, subst e2)
- | Lstaticraise _ as l -> l
+ sw_blocks = List.map subst_case sw.sw_blocks;
+ sw_failaction =
+ match sw.sw_failaction with
+ | None -> None
+ | Some l -> Some (subst l)})
+
+ | Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args)
| Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2)
| Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2)
| Lifthenelse(e1, e2, e3) -> Lifthenelse(subst e1, subst e2, subst e3)
@@ -315,8 +333,4 @@ and negate_comparison = function
| Clt -> Cge | Cle -> Cgt
| Cgt -> Cle | Cge -> Clt
-let raise_count = ref 0
-let next_raise_count () =
- incr raise_count ; (* Done before, since 0 is for partial matches *)
- !raise_count
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index 18cebad34..6d2086e74 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -134,8 +134,6 @@ type lambda =
| Lletrec of (Ident.t * lambda) list * lambda
| Lprim of primitive * lambda list
| Lswitch of lambda * lambda_switch
- | Lstaticfail
- | Lcatch of lambda * lambda
| Lstaticraise of int * lambda list
| Lstaticcatch of lambda * (int * Ident.t list) * lambda
| Ltrywith of lambda * Ident.t * lambda
@@ -153,8 +151,7 @@ and lambda_switch =
sw_consts: (int * lambda) list; (* Integer cases *)
sw_numblocks: int; (* Number of tag block cases *)
sw_blocks: (int * lambda) list; (* Tag block cases *)
- sw_checked: bool ; (* True if bound checks needed *)
- sw_nofail: bool} (* True if should not fail *)
+ sw_failaction : lambda option} (* Action to take if failure *)
and lambda_event =
{ lev_loc: int;
lev_kind: lambda_event_kind;
@@ -171,6 +168,7 @@ val lambda_unit: lambda
val name_lambda: lambda -> (Ident.t -> lambda) -> lambda
val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda
val is_guarded: lambda -> bool
+val patch_guarded : lambda -> lambda -> lambda
module IdentSet: Set.S with type elt = Ident.t
val free_variables: lambda -> IdentSet.t
@@ -184,4 +182,17 @@ val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda
val commute_comparison : comparison -> comparison
val negate_comparison : comparison -> comparison
+(***********************)
+(* For static failures *)
+(***********************)
+
+(* Get a new static failure ident *)
val next_raise_count : unit -> int
+
+
+val staticfail : lambda (* Anticipated static failure *)
+
+(* Check anticipated failure, substitute its final value *)
+val is_guarded: lambda -> bool
+val patch_guarded : lambda -> lambda -> lambda
+
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 2b82f7e33..d833ce92c 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -24,25 +24,377 @@ 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' ->
+ 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 =
+ prerr_endline "begin jumps" ;
+ List.iter
+ (fun (i,ctx) ->
+ Printf.fprintf stderr "jump for %d\n" i ;
+ pretty_ctx ctx)
+ env ;
+ prerr_endline "end jumps"
+
+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 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 }
+ 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 pm = List.assoc key division in
- pm.cases <- patl_action :: pm.cases;
+ let cell = List.assoc key division in
+ cell.pm.cases <- patl_action :: cell.pm.cases;
division
with Not_found ->
- let pm = make_matching_fun args in
- pm.cases <- patl_action :: pm.cases;
- (key, pm) :: division
+ 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 *)
@@ -58,10 +410,6 @@ let rec name_pattern default = function
(* To remove aliases and bind named components *)
-let any_pat =
- { pat_desc = Tpat_any; pat_loc = Location.none;
- pat_type = Ctype.none; pat_env = Env.empty }
-
exception Var of pattern
@@ -82,53 +430,181 @@ let simplify_or p =
with
| Var p -> p
-
+exception Not_simple
+
+let rec raw_rec env = function
+ | Llet(Alias,x,ex, body) -> raw_rec ((x,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 test_up cases =
+ let rec test_rec seen = function
+ | ({pat_desc = Tpat_any}::_,_) as clause::rem ->
+ test_rec (clause::seen) rem
+ | (patl,act) as clause::rem ->
+ if up_ok clause seen
+ then
+ clause::List.rev_append seen rem
+ else
+ test_rec (clause::seen) rem
+ | [] -> raise Same in
+ match cases with
+ | ({pat_desc = Tpat_any}::_,_) as clause::rem ->
+ begin try
+ test_rec [clause] rem
+ with
+ | Same -> cases
+ end
+ | _ -> cases
+
+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
+
let simplify_matching m = match m.args with
-| [] -> m
+| [] -> omega,m
| (arg, _) :: _ ->
- let rec simplify = function
- (pat :: patl, action as patl_action) :: rem ->
+ 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 ->
- (any_pat :: patl, bind Alias id arg action) :: simplify rem
+ (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 [] ->
- (any_pat :: patl, action) :: simplify rem
+ (omega :: patl, action)::
+ simplify rem
+ | Tpat_record lbls ->
+ record_ex_pat pat ;
+ let all_lbls = all_record_args lbls in
+ ({pat with pat_desc=Tpat_record all_lbls}::patl,action)::
+ simplify rem
| Tpat_or (_,_) ->
let pat_simple = simplify_or pat in
begin match pat_simple.pat_desc with
| Tpat_or (_,_) ->
+ record_ex_pat (what_is_or pat_simple) ;
(pat_simple :: patl, action) ::
simplify rem
| _ ->
simplify ((pat_simple::patl,action) :: rem)
end
| _ ->
+ record_ex_pat pat ;
patl_action :: simplify rem
end
- | cases -> cases in
- {m with cases = simplify m.cases }
-
-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
+ | [] -> []
+ | _ -> assert false in
+ let cases = simplify m.cases in
+ let p,pm =
+ match !ex_pat with
+ | None -> omega, {m with cases=cases}
+ | Some p -> p,{m with cases = cases} in
+(*
+ prerr_endline "<-------- Simplify" ;
+ prerr_string "pat=" ;
+ pretty_pat p ;
+ prerr_endline "" ;
+ pretty_pm cases ;
+*)
+ p,pm
-let rec upper_left_pattern pm = match pm.cases with
-| ({pat_desc=Tpat_or (pat,_)} :: _, _) :: _ -> what_is_or pat
-| (pat :: _, _) :: _ -> pat
-| _ -> assert false
-(* Optimize breaks *)
+let rec what_is_cases cases = match cases with
+| ({pat_desc=Tpat_any} :: _, _) :: rem -> what_is_cases rem
+| (p::_,_)::_ -> p
+| _ -> omega
-let rec group_or group = function
- | {pat_desc = Tpat_or (p1, p2)} -> group_or group p1 && group_or group p2
- | {pat_desc = Tpat_alias (p,_)} -> group_or group p
- | p -> group p
+(* 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
@@ -161,13 +637,12 @@ let mk_alpha_env arg aliases ids =
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 p1)
- vars aliases p2
+ (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 ->
@@ -175,127 +650,333 @@ let rec explode_or_pat arg patl mk_action rem vars aliases = function
(alpha_pat env p::patl,mk_action (List.map snd env))::rem
-let more group ({cases=cl ; args = al} as m) = match al with
-| (Lvar arg,_)::_ ->
- let rec more_rec yes no = function
- | (pat::_ as patl, action) as full :: rem ->
- if
- group pat &&
- not
- (List.exists
- (fun (qs,_) -> compats qs patl)
- no)
- then begin
- more_rec (full::yes) no rem
- end else
- more_rec yes (full::no) rem
- | [] -> yes, List.rev no
- | _ -> assert false in
- let yes,no = more_rec [] [] cl in
-
- let rec add_or prev = function
- | ({pat_desc=Tpat_or (_,_)} as p::patl, action)::rem
- when group_or group p
- && not (List.exists (fun q -> Parmatch.compat q p) prev) ->
- let vars =
- IdentSet.elements
- (IdentSet.inter
- (extract_vars IdentSet.empty p)
- (free_variables action)) in
- begin match action with
- | Lstaticraise (_,[]) | Lstaticfail
- when
- vars = [] &&
- List.for_all
- (function {pat_desc=Tpat_any} -> true
- | _ -> false)
- patl ->
- let new_yes,new_to_catch,new_others =
- add_or (p::prev) rem in
- explode_or_pat
- (Some arg) patl (fun _ -> action) new_yes vars [] p,
- new_to_catch,
- new_others
- | _ ->
- let raise_num = next_raise_count () in
- let new_patl = Parmatch.omega_list patl in
+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
+ 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
(* Compilation assigne, pas bo
- let mk_new_action vs =
- List.fold_right2
- (fun dest src lambda ->
- Lsequence (Lassign (dest, Lvar src),lambda))
- vars vs
- (Lstaticraise (raise_num,[])) in
+ let mk_new_action vs =
+ List.fold_right2
+ (fun dest src lambda ->
+ Lsequence (Lassign (dest, Lvar src),lambda))
+ vars vs
+ (Lstaticraise (raise_num,[])) 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)
+ | 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 mk_new_action vs =
- Lstaticraise
- (raise_num, List.map (fun v -> Lvar v) vs) in
-
- let new_yes,new_to_catch,new_others =
- add_or (p::prev) rem in
- explode_or_pat
- (Some arg) new_patl mk_new_action new_yes vars [] p,
- ((raise_num, vars ,
- {cases=[patl, action] ; args = List.tl al})::
- new_to_catch),
- new_others
- end
- | rem ->
- yes,
- [],
- {cases=rem ; args = al} in
- let yes,to_catch,others = add_or [] no in
- List.rev yes, to_catch, others
-| _ -> assert 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 equiv_pat p q then (* attempt insert *)
+ 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
+ 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 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 group make get_key get_args ({args=al} as pm) =
+
+
+let divide make get_key get_args ctx pm =
+
let rec divide_rec = function
- | (p::patl,action) :: rem
- when group p ->
+ | (p::patl,action) :: rem ->
let this_match = divide_rec rem in
- add (make p) this_match (get_key p) (get_args p patl,action) al
- | cl -> [] in
- let yes, to_catch, others = more group pm in
- divide_rec yes, to_catch, others
+ add
+ (make p pm.default ctx)
+ this_match (get_key p) (get_args p patl,action) pm.args
+ | _ -> [] in
-let divide_line group make get_args ({args=al} as pm) =
+ divide_rec pm.cases
+
+
+let divide_line make_ctx make get_args pat ctx pm =
let rec divide_rec = function
- | (p::patl,action) :: rem
- when group p ->
- let this_match = divide_rec rem in
- add_line (get_args p patl, action) this_match
- | cl -> make al in
- let yes, to_catch, others = more group pm in
- divide_rec yes, to_catch, others
+ | (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 group_constant = function
- | {pat_desc= Tpat_constant _} -> true
- | _ -> false
+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 _ = function
+let make_constant_matching p def ctx = function
[] -> fatal_error "Matching.make_constant_matching"
- | (arg :: argl) -> {cases = []; args = argl}
+ | (_ :: 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 get_key_constant = function
- | {pat_desc= Tpat_constant cst} -> cst
- | _ -> assert false
-let get_args_constant _ rem = rem
-let divide_constant m =
+
+let divide_constant ctx m =
divide
- group_constant make_constant_matching
- get_key_constant get_args_constant
- m
+ make_constant_matching (get_key_constant "divide")
+ get_args_constant
+ ctx m
(* Matching against a constructor *)
-let group_constructor = function
- | {pat_desc = Tpat_construct (_, _)} -> true
- | _ -> false
+
let make_field_args binding_kind arg first_pos last_pos argl =
let rec make_args pos =
@@ -314,9 +995,17 @@ let get_args_constr p rem = match p with
let pat_as_constr = function
| {pat_desc=Tpat_construct (cstr,_)} -> cstr
- | _ -> assert false
+ | _ -> fatal_error "Matching.pat_as_constr"
-let make_constr_matching p = function
+
+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
@@ -326,34 +1015,62 @@ let make_constr_matching p = function
make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl
| Cstr_exception _ ->
make_field_args Alias arg 1 cstr.cstr_arity argl in
- {cases = []; args = newargs}
+ {pm=
+ {cases = []; args = newargs;
+ default = make_default (matcher_constr cstr) def} ;
+ ctx = filter_ctx p ctx ;
+ pat=normalize_pat p}
-let divide_constructor pm =
+let divide_constructor ctx pm =
divide
- group_constructor make_constr_matching
+ make_constr_matching
get_key_constr get_args_constr
- pm
+ ctx pm
(* Matching against a variant *)
-let group_variant = function
- | {pat_desc = Tpat_variant (_, _, _)} -> true
- | _ -> false
-let make_variant_matching_constant = function
+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) ->
- { cases = []; args = 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 = function
+
+let make_variant_matching_nonconst p lab def ctx = function
[] -> fatal_error "Matching.make_variant_matching_nonconst"
| ((arg, mut) :: argl) ->
- {cases = []; args = (Lprim(Pfield 1, [arg]), Alias) :: argl}
-
-let divide_variant row ({cases = cl; args = al} as pm) =
+ 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, _)} :: patl, action) :: rem ->
+ ({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
@@ -363,66 +1080,63 @@ let divide_variant row ({cases = cl; args = al} as pm) =
let tag = Btype.hash_variant lab in
match pato with
None ->
- add make_variant_matching_constant variants
+ add (make_variant_matching_constant p lab def ctx) variants
(Cstr_constant tag) (patl, action) al
| Some pat ->
- add make_variant_matching_nonconst variants
+ add (make_variant_matching_nonconst p lab def ctx) variants
(Cstr_block tag) (pat :: patl, action) al
end
| cl -> []
in
- let yes, to_catch, others = more group_variant pm in
- divide yes, to_catch, others
+ divide cl
(* Matching against a variable *)
-let group_var = function
- | {pat_desc=Tpat_any} -> true
- | _ -> false
let get_args_var _ rem = rem
-let divide_var pm =
- divide_line
- group_var (make_constant_matching Tpat_any)
- get_args_var pm
+
+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 group_tuple = function
- | {pat_desc = (Tpat_tuple _|Tpat_any)} -> true
- | _ -> false
-let make_tuple_matching num_comps = function
+
+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 >= num_comps
+ if pos >= arity
then argl
else (Lprim(Pfield pos, [arg]), Alias) :: make_args (pos + 1) in
- {cases = []; args = make_args 0}
-
-
-let get_args_tuple arity p rem = match p with
- | {pat_desc = Tpat_any} ->
- replicate_list any_pat arity @ rem
- | {pat_desc = Tpat_tuple args} ->
- args @ rem
- | _ -> assert false
+ {cases = []; args = make_args 0 ;
+ default=make_default (get_args_tuple arity) def}
-let divide_tuple arity pm =
+let divide_tuple arity p ctx pm =
divide_line
- group_tuple (make_tuple_matching arity)
- (get_args_tuple arity)
- pm
+ (filter_ctx p)
+ (make_tuple_matching arity)
+ (get_args_tuple arity) p ctx pm
(* Matching against a record pattern *)
-let group_record = function
- | {pat_desc = (Tpat_record _|Tpat_any)} -> true
- | _ -> false
let record_matching_line num_fields lbl_pat_list =
- let patv = Array.create num_fields any_pat in
+ 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
@@ -433,8 +1147,7 @@ let get_args_record num_fields p rem = match p with
record_matching_line num_fields lbl_pat_list @ rem
| _ -> assert false
-
-let make_record_matching all_labels = function
+let make_record_matching all_labels def = function
[] -> fatal_error "Matching.make_record_matching"
| ((arg, mut) :: argl) ->
let rec make_args pos =
@@ -450,19 +1163,20 @@ let make_record_matching all_labels = function
| Mutable -> StrictOpt in
(Lprim(access, [arg]), str) :: make_args(pos + 1)
end in
- {cases = []; args = make_args 0}
+ 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 pm =
+
+let divide_record all_labels p ctx pm =
+ let get_args = get_args_record (Array.length all_labels) in
divide_line
- group_record
+ (filter_ctx p)
(make_record_matching all_labels)
- (get_args_record (Array.length all_labels))
- pm
+ get_args
+ p ctx pm
(* Matching against an array pattern *)
-let group_array = function
- | {pat_desc=Tpat_array _} -> true
- | _ -> false
let get_key_array = function
| {pat_desc=Tpat_array patl} -> List.length patl
@@ -472,111 +1186,41 @@ let get_args_array p rem = match p with
| {pat_desc=Tpat_array patl} -> patl@rem
| _ -> assert false
-let make_array_matching kind len = function
- [] -> fatal_error "Matching.make_array_matching"
+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
- {cases = []; args = make_args 0}
+ 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 pm =
+let divide_array kind ctx pm =
divide
- group_array
- (fun p -> make_array_matching kind (get_key_array p))
- get_key_array get_args_array pm
+ (make_array_matching kind)
+ get_key_array get_args_array ctx pm
(* To combine sub-matchings together *)
-exception Not_simple
-
-let rec raw_rec env = function
- | Llet(Alias,x,ex, body) -> raw_rec ((x,ex)::env) body
- | Lstaticfail as l -> l
- | 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 sort_lambda_list l =
List.sort
- (fun (x,_) (y,_) -> x - y)
+ (fun (x,_) (y,_) -> Pervasives.compare x y)
l
-let add_catch (lambda1,total1) (c_catch,(lambda_default,total_default)) =
- let rec do_rec r total_r = function
- | [] ->
- if total_r then
- (r,true)
- else begin match lambda_default with
- | Lstaticfail -> r,total_r
- | _ -> Lcatch (r,lambda_default),total_default
- end
- | (i,vars,(handler_i,total_i))::rem ->
-(* Compilation assign, pas bo
- do_rec
- (List.fold_right
- (fun v lambda ->
- bind StrictOpt v (Lconst const_unit) lambda)
- vars (Lstaticcatch (r,(i,[]), handler_i)))
- (total_i && total_r) rem in
-*)
- match raw_action r with
- | Lstaticraise (j,args) ->
- if j <> i then
- do_rec r total_r rem
- else if args=[] then
- do_rec handler_i total_i rem
- else
- do_rec
- (Lstaticcatch (r,(i,vars), handler_i))
- (total_i && total_r) rem
- | _ ->
- do_rec
- (Lstaticcatch (r,(i,vars), handler_i))
- (total_i && total_r) rem in
- do_rec lambda1 total1 c_catch
-let combine_line (lambda1, total1) c_catch =
- add_catch (lambda1, total1) c_catch
let rec cut n l =
if n = 0 then [],l
@@ -584,70 +1228,44 @@ let rec cut n l =
[] -> raise (Invalid_argument "cut")
| a::l -> let l1,l2 = cut (n-1) l in a::l1, l2
-let make_test_sequence nofail check tst lt_tst arg const_lambda_list =
+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
- List.fold_right
- (fun (c, act) rem ->
- if rem = Lstaticfail && (not check || nofail) then act else
- Lifthenelse(Lprim(tst, [arg; Lconst(Const_base c)]), rem, act))
- const_lambda_list
- Lstaticfail
+ 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.list (fun (c1,_) (c2,_) -> c1 < c2) const_lambda_list)
+ 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 make_switch_offset nofail check arg min_key max_key int_lambda_list =
- 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_checked = check ;
- sw_nofail = nofail})
-
-let make_switch_or_test_sequence
- nofail check arg const_lambda_list int_lambda_list =
- if const_lambda_list = [] then
- if check then Lstaticfail else lambda_unit
- else
- let min_key =
- List.fold_right (fun (k, l) m -> min k m) int_lambda_list max_int in
- let max_key =
- List.fold_right (fun (k, l) m -> max k m) int_lambda_list min_int in
- (* min_key and max_key can be arbitrarily large, so watch out for
- overflow in the following comparison *)
- if List.length int_lambda_list <= 1 + max_key / 4 - min_key / 4 then
- (* Sparse matching -- use a sequence of tests *)
- make_test_sequence nofail check (Pintcomp Cneq) (Pintcomp Clt)
- arg const_lambda_list
- else begin
- (* Dense matching -- use a jump table
- (2 bytecode instructions + 1 word per entry in the table) *)
- make_switch_offset nofail check arg min_key max_key int_lambda_list
- end
-
-let make_test_sequence_variant_constant check arg int_lambda_list =
- make_test_sequence false check (Pintcomp Cneq) (Pintcomp Clt) arg
- (List.map (fun (n, l) -> (Const_int n, l)) int_lambda_list)
-
-let make_test_sequence_variant_constr check arg int_lambda_list =
- let v = Ident.create "variant" in
- Llet(Alias, v, Lprim(Pfield 0, [arg]),
- make_test_sequence false check (Pintcomp Cneq) (Pintcomp Clt) (Lvar v)
- (List.map (fun (n, l) -> (Const_int n, l)) int_lambda_list))
+(* OLD CODE
let make_bitvect_check arg int_lambda_list lambda =
let bv = String.make 32 '\000' in
List.iter
@@ -656,42 +1274,106 @@ let make_bitvect_check arg int_lambda_list lambda =
int_lambda_list;
Lifthenelse(Lprim(Pbittest, [Lconst(Const_base(Const_string bv)); arg]),
lambda, Lstaticfail)
+*)
let prim_string_notequal =
Pccall{prim_name = "string_notequal";
prim_arity = 2; prim_alloc = false;
prim_native_name = ""; prim_native_float = false}
-let is_default act = match raw_action act with
-| Lstaticfail -> true
-| _ -> 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 is_default acts.(act) then
+ 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) []
+ 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 min_key, max_key, clauses = as_int_list cases acts in
- make_switch_offset false false arg 0 (max_key-min_key) clauses
+ let min_key, max_key, clauses, default = as_int_list cases acts in
+ make_switch_offset arg 0 (max_key-min_key) clauses default
+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
@@ -704,8 +1386,6 @@ module SArg = struct
type act = Lambda.lambda
- let default = Lstaticfail
-(* let equal_action = equal_action *)
let make_prim p args = Lprim (p,args)
let make_offset arg n = match n with
| 0 -> arg
@@ -728,34 +1408,9 @@ open Switch
let lambda_of_int i = Lconst (Const_base (Const_int i))
-(* Store for actions in object style *)
-exception Found of int
-type t_store =
- {get : unit -> lambda array ; store : lambda -> int}
-
-let mk_store () =
- let r_acts = ref [] in
- let store act =
- let rec store_rec i = function
- | [] -> i,[act]
- | act0::rem ->
- if equal_action act act0 then raise (Found i)
- else
- let i,rem = store_rec (i+1) rem in
- i,act0::rem in
- try
- let i,acts = store_rec 0 !r_acts in
- r_acts := acts ;
- i
- with
- | Found i -> i
-
- and get () = Array.of_list !r_acts in
- {store=store ; get=get}
-
-let as_interval_canfail low high l =
- let store = mk_store () in
+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
| [] -> begin match high with
| TooMuch -> [cur_low,cur_high,cur_act]
@@ -766,11 +1421,11 @@ let as_interval_canfail low high l =
[(cur_low,cur_high,cur_act) ; (cur_high+1,h, 0)]
end
| ((i,act_i)::rem) as all ->
- let act_index = store.store act_i in
+ 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 is_default act_i then
+ 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
@@ -781,33 +1436,35 @@ let as_interval_canfail low high l =
and fail_rec cur_low cur_high = function
| [] -> [(cur_low, cur_high, 0)]
| (i,act_i)::rem ->
- if is_default act_i then fail_rec cur_low 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 (store.store act_i) rem in
+ nofail_rec i i index rem in
let rec init_rec = function
| [] -> []
| (i,act_i)::rem as all ->
- if is_default act_i then
- match low with
- | TooMuch -> init_rec rem
- | Int low -> fail_rec low i rem
- else begin match low with
- | TooMuch -> nofail_rec i i (store.store act_i) rem
- | Int low ->
- if low < i then
- (low,i-1,0)::nofail_rec i i (store.store act_i) rem
+ let index = store.act_store act_i in
+ if index=0 then
+ match low with
+ | TooMuch -> init_rec rem
+ | Int low -> fail_rec low i rem
+ else begin match low with
+ | TooMuch -> nofail_rec i i index rem
+ | Int low ->
+ if low < i then
+ (low,i-1,0)::nofail_rec i i index rem
else
- nofail_rec i i (store.store act_i) rem
+ nofail_rec i i index rem
end in
- ignore (store.store Lstaticfail) ; (* Lstaticfail has action index 0 *)
+ ignore (store.act_store fail) ; (* fail has action index 0 *)
let r = init_rec (sort_lambda_list l) in
- low, high, Array.of_list r, store.get ()
+ low, high, Array.of_list r, store.act_get ()
let as_interval_nofail l =
- let store = mk_store ()
+ let store = mk_store equal_action
and high = ref (-1)
and low = ref (-1) in
@@ -816,7 +1473,7 @@ let as_interval_nofail l =
high := cur_high ;
[cur_low, cur_high, cur_act]
| (i,act)::rem ->
- let act_index = store.store act in
+ let act_index = store.act_store act in
if act_index = cur_act then
i_rec cur_low i cur_act rem
else
@@ -825,26 +1482,183 @@ let as_interval_nofail l =
let inters = match sort_lambda_list l with
| (i,act)::rem ->
low := i ;
- let act_index = store.store act in
+ let act_index = store.act_store act in
i_rec i i act_index rem
| _ -> assert false in
- Int !low, Int !high, Array.of_list inters, store.get ()
+ Int !low, Int !high, Array.of_list inters, store.act_get ()
-let as_interval nofail low high l =
- if nofail then
- as_interval_nofail l
- else
- as_interval_canfail low high l
+let as_interval fail low high l = match fail with
+| None -> as_interval_nofail l
+| Some act -> as_interval_canfail act low high l
-let call_switcher konst nofail arg low high int_lambda_list =
+let call_switcher konst fail arg low high int_lambda_list =
let real_low, real_high, cases, actions =
- as_interval nofail low high int_lambda_list in
+ as_interval fail low high int_lambda_list in
Switcher.zyva
konst arg real_low real_high cases actions
-let combine_constant arg cst partial (const_lambda_list, total1) c_catch =
- let nofail = partial=Total in
+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)}
+
+
+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
+
+
+let mk_failaction get_key complete partial seen ctx (exit,def) =
+ match partial with
+ | Total -> None, [], jumps_empty
+ | Partial ->
+
+ let add i b keys env = match keys with
+ | [] -> env
+ | _ -> (i,b,keys)::env in
+
+ let rec mk_rec env seen = function
+ | [] -> mk_res get_key env [] (-1) true ctx
+ | (pss,idef)::rem ->
+ try
+ let pats_here = extract_mat seen pss in
+ let keep, forget =
+ List.partition
+ (fun p -> exists_ctx (compat p) ctx)
+ pats_here in
+ let keep =
+ List.filter
+ (fun p -> ctx_match (ctx_lub p ctx) pss)
+ keep in
+ mk_rec (add idef false keep env) (keep@forget@seen) rem
+ with
+ (* pss a priori catches everything left *)
+ | All ->
+ let pats = complete seen in
+ if pats = [] || group_var (List.hd pats) then
+ mk_res get_key env pats idef (all_vars pss) ctx
+ else begin
+ let keep, forget =
+ List.partition
+ (fun p -> exists_ctx (compat p) ctx) pats in
+ let keep =
+ List.filter
+ (fun p -> ctx_match (ctx_lub p ctx) pss)
+ keep in
+ mk_rec (add idef (all_vars pss) keep env)
+ (keep@forget@seen) rem
+ end in
+ mk_rec [] seen def
+
+let mk_failaction_neg get_key partial seen ctx def =
+ mk_failaction
+ get_key (fun _ -> [omega])
+ partial seen ctx def
+
+and mk_failaction_pos partial seen ctx def =
+ match
+ mk_failaction
+ get_key_constr complete_pats_constrs
+ partial seen ctx def
+ with
+ | None,klist,jumps -> klist, jumps
+ | _,_,_ -> fatal_error "Matching.failaction_pos"
+
+
+(* OPT
+let rec ok_pat ok p = match p.pat_desc with
+| Tpat_or (p1,p2) -> ok_pat ok p1 || ok_pat ok p2
+| Tpat_alias (p,_) -> ok_pat ok p
+| _ -> ok p
+
+let ok_const csts =
+ ok_pat
+ (function
+ | {pat_desc=Tpat_constant cst} -> not (List.mem cst csts)
+ | _ -> true)
+*)
+
+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 _ ->
@@ -852,7 +1666,7 @@ let combine_constant arg cst partial (const_lambda_list, total1) c_catch =
List.map (function Const_int n, l -> n,l | _ -> assert false)
const_lambda_list in
call_switcher
- lambda_of_int nofail arg
+ lambda_of_int fail arg
Switch.TooMuch Switch.TooMuch
int_lambda_list
| Const_char _ ->
@@ -862,27 +1676,19 @@ let combine_constant arg cst partial (const_lambda_list, total1) c_catch =
const_lambda_list in
call_switcher
(fun i -> Lconst (Const_base (Const_int i)))
- nofail arg
+ fail arg
(Switch.Int 0) (Switch.Int 255)
int_lambda_list
-(*
- begin match one_action with
- | Some lambda when List.length int_lambda_list > 8 ->
- make_bitvect_check arg int_lambda_list lambda
- | _ ->
- make_switch_or_test_sequence nofail true arg
- const_lambda_list int_lambda_list
- end
- *)
| Const_string _ ->
make_test_sequence
- nofail true prim_string_notequal Praise arg const_lambda_list
+ fail prim_string_notequal Praise arg const_lambda_list
| Const_float _ ->
make_test_sequence
- nofail
- true (Pfloatcomp Cneq) (Pfloatcomp Clt)
+ fail
+ (Pfloatcomp Cneq) (Pfloatcomp Clt)
arg const_lambda_list in
- add_catch (lambda1, nofail) c_catch
+ lambda1,jumps_union local_jumps total
+
let split_cases tag_lambda_list =
@@ -899,131 +1705,102 @@ let split_cases tag_lambda_list =
sort_lambda_list nonconst
-let prerr_c l =
- List.iter (fun (i,_) -> Printf.fprintf stderr "%d " i) l
-let prerr_i l =
- List.iter (fun i -> Printf.fprintf stderr "%d " i) l
-
-let rec interval min max k =
- if min >= max then k
- else min::interval (min+1) max k
-
-let find_missing n l =
- let rec find_rec = function
- | [] -> []
- | [n1,_] -> interval (n1+1) n []
- | (n1,_)::((n2,_)::_ as rem) ->
- interval (n1+1) n2 (find_rec rem) in
-
- let r = match l with
- | [] -> interval 0 n []
- | (n1,_)::_ ->
- interval 0 n1 (find_rec l) in
-(*
- Printf.fprintf stderr "Find missing %d " n;
- prerr_c l ;
- prerr_string " -> " ;
- prerr_i r ;
- prerr_endline "" ;
+(* OPT
+let ok_constr cstrs =
+ ok_pat
+ (function
+ | {pat_desc=Tpat_construct (cstr,_)} ->
+ not (List.mem cstr.cstr_tag cstrs)
+ | _ -> true)
*)
- r
-
-let test_fail arg cstr const nonconst =
- let miss_const =
- find_missing cstr.cstr_consts const
- and miss_nonconst =
- find_missing cstr.cstr_nonconsts nonconst
- in
- match const, miss_const, nonconst, miss_nonconst with
- | _,[n],_,[] ->
- Some (Lprim (Pintcomp Ceq, [arg ; Lconst (Const_base (Const_int n))]))
- | [n,_],_,[],_ ->
- Some (Lprim (Pintcomp Cneq, [arg ; Lconst (Const_base (Const_int n))]))
- | _,[],[],_::_ -> Some (Lprim (Pnot, [Lprim (Pisint, [arg])]))
- | [],_::_,_,[] -> Some (Lprim (Pisint, [arg]))
- | _, _, _, _ -> None
-
-let combine_constructor arg cstr partial (tag_lambda_list, total1) c_catch =
- let nofail = partial=Total in
+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 =
- if nofail then
- match tag_lambda_list with
- | (_, act)::rem -> act,rem
- | _ -> assert false
- else
- Lstaticfail, tag_lambda_list in
+ 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 add_catch (lambda1, nofail) c_catch
+ 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 one_action = same_actions tag_lambda_list in
- let total_loc = sig_complete || nofail in
+ 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 total_loc, one_action, test_fail arg cstr consts nonconsts with
- | true, Some act, _ -> act
- | false, Some act, Some (Lprim (Pnot,[test])) ->
- Lifthenelse (test, act, Lstaticfail)
- | false, Some act, Some test ->
- Lifthenelse (test, Lstaticfail, act)
- | _,_, _ ->
- match (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) with
- | (1, 1, [0, act1], [0, act2]) ->
- Lifthenelse(arg, act2, act1)
- | (1, 1, [0, act1], []) ->
- if total_loc then
- act1
- else
- Lifthenelse(arg, Lstaticfail, act1)
- | (1, 1, [], [0, act2]) ->
- if total_loc then
- act2
- else
- Lifthenelse(arg, act2, Lstaticfail)
- | n,m,l,[] ->
- if total_loc || m=0 then
+ 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,0,_,[] ->
call_switcher
(fun i -> Lconst (Const_base (Const_int i)))
- nofail arg
+ None arg
(Switch.Int 0) (Switch.Int (n-1))
- l
- else
- Lifthenelse
- (Lprim (Pisint,[arg]),
- call_switcher
- (fun i -> Lconst (Const_base (Const_int i)))
- nofail arg
- (Switch.Int 0) (Switch.Int (n-1))
- l,
- Lstaticfail)
-
- | (_, _, _, _) ->
- Lswitch(arg, {sw_numconsts = cstr.cstr_consts;
- sw_consts = consts;
- sw_numblocks = cstr.cstr_nonconsts;
- sw_blocks = nonconsts;
- sw_checked = false ;
- sw_nofail = nofail}) in
- add_catch (lambda1,total1 && total_loc) c_catch
+ 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
+ (Switch.Int 0) (Switch.Int (n-1))
+ consts,
+ act) in
+ lambda1, jumps_union local_jumps total1
end
-let combine_variant row arg partial (tag_lambda_list, total1)
- c_catch =
+let make_test_sequence_variant_constant fail arg int_lambda_list =
+ make_test_sequence fail (Pintcomp Cneq) (Pintcomp Clt) arg
+ (List.map (fun (n, l) -> (Const_int n, l)) int_lambda_list)
+
+let make_test_sequence_variant_constr fail arg int_lambda_list =
+ let v = Ident.create "variant" in
+ Llet(Alias, v, Lprim(Pfield 0, [arg]),
+ make_test_sequence fail (Pintcomp Cneq) (Pintcomp Clt) (Lvar v)
+ (List.map (fun (n, l) -> (Const_int n, l)) 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
@@ -1039,46 +1816,71 @@ let combine_variant row arg partial (tag_lambda_list, total1)
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 nofail = partial=Total
and one_action = same_actions tag_lambda_list in
- let total_loc = nofail || sig_complete in
- let lambda1 = match sig_complete || nofail, one_action with
- | true, Some act -> act
+ let fail, to_add, local_jumps =
+ if sig_complete 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 lambda1 = match fail, one_action with
+ | None, Some act -> act
| _,_ ->
match (consts, nonconsts) with
- | ([n, act1], [m, act2]) when total_loc ->
+ | ([n, act1], [m, act2]) when fail=None ->
test_int_or_block arg act1 act2
| ([n, act], []) ->
- make_test_sequence_variant_constant (not total_loc) arg consts
+ make_test_sequence_variant_constant fail arg consts
| (_, []) ->
- let lam = make_test_sequence_variant_constant
- (not total_loc) arg consts in
- if total_loc then lam else test_int_or_block arg lam Lstaticfail
+ let lam =
+ make_test_sequence_variant_constant
+ fail arg consts in
+ begin match fail with
+ | None -> lam
+ | Some fail -> test_int_or_block arg lam fail
+ end
| ([], _) ->
let lam = make_test_sequence_variant_constr
- (not total_loc) arg nonconsts in
- if total_loc then lam else test_int_or_block arg Lstaticfail lam
+ fail arg nonconsts in
+ begin match fail with
+ | None -> lam
+ | Some fail -> test_int_or_block arg fail lam
+ end
| (_, _) ->
- let lam_const = make_test_sequence_variant_constant
- (not total_loc) arg consts in
- let lam_nonconst = make_test_sequence_variant_constr
- (not total_loc) arg nonconsts in
+ let lam_const =
+ make_test_sequence_variant_constant
+ fail arg consts
+ and lam_nonconst =
+ make_test_sequence_variant_constr
+ fail arg nonconsts in
test_int_or_block arg lam_const lam_nonconst
in
- add_catch (lambda1, total1 && total_loc) c_catch
-
-let combine_array arg kind _ (len_lambda_list, total1) c_catch =
+ lambda1, jumps_union local_jumps total1
+
+(* OPT
+let ok_array lens =
+ ok_pat
+ (function
+ | {pat_desc=Tpat_array ps} -> not (List.mem (List.length ps) lens)
+ | _ -> true)
+*)
+
+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
- false (Lvar newvar)
+ fail (Lvar newvar)
(Switch.Int 0) Switch.TooMuch
len_lambda_list in
bind
Alias newvar (Lprim(Parraylength kind, [arg])) switch in
- add_catch (lambda1,false) c_catch
+ lambda1, jumps_union local_jumps total1
(* Insertion of debugging events *)
@@ -1110,39 +1912,79 @@ let rec event_branch repr lam =
Output: a lambda term, a "total" flag
(true if the lambda term does not raise ``exit'')
*)
+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
+
+(* Compilation assign, pas bo
+ do_rec
+ (List.fold_right
+ (fun v lambda ->
+ bind StrictOpt v (Lconst const_unit) lambda)
+ vars (Lstaticcatch (r,(i,[]), handler_i)))
+ (total_i && total_r) rem in
+*)
+
+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 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
-let rec compile_list compile_fun = function
- [] -> ([], true)
- | (key, pm) :: rem ->
- let (lambda1, total1) = compile_fun pm in
- let (list2, total2) = compile_list compile_fun rem in
- ((key, lambda1) :: list2, total1 && total2)
-
-let compile_catch compile_fun repr partial to_catch others =
- let partial_catch =
- if others.cases = [] then partial else Partial in
- let rec c_rec = function
- | [] -> [],compile_fun repr partial others
- | (i,vars,m)::rem ->
- let c_catch, c_others = c_rec rem in
- (i, vars, compile_fun repr partial_catch m)::c_catch,
- c_others in
- c_rec to_catch
-
-let compile_test compile_match repr partial divide combine pm =
- let (this_match, to_catch, others) = divide pm in
- let partial' =
- if others.cases=[] then partial else Partial in
- combine partial'
- (compile_list (compile_match repr partial') this_match)
- (compile_catch compile_match repr partial to_catch others)
(* Attempt to avoid some useless bindinds by lowering them *)
(* Approximation of v present in lam *)
let rec approx_present v = function
| Lconst _ -> false
- | Lstaticfail -> false
| Lstaticraise (_,args) ->
List.exists (fun lam -> approx_present v lam) args
| Lprim (_,args) ->
@@ -1188,93 +2030,140 @@ let bind_check str v arg lam = match str,arg with
| Alias,_ -> lower_bind v arg lam
| _,_ -> bind str v arg lam
-let rec compile_match repr partial m = match m with
- { cases = [] } ->
- (Lstaticfail, false)
- | { cases = ([], action) :: rem; args = argl } ->
- if is_guarded action then begin
- let (lambda, total) =
- compile_match None partial { cases = rem; args = argl }
- and lambda_in = event_branch repr action in
- match lambda with
- | Lstaticfail -> lambda_in, false
- | _ -> Lcatch(lambda_in , lambda), total
- end else
- (event_branch repr action, true)
- | { args = (arg, str)::argl ; cases = (pat::_, _)::_ } ->
- let v,newarg =
- match arg with
- | Lvar v -> v,arg
- | _ ->
- let v = name_pattern "match" m.cases in
- v,Lvar v in
- let pm =
- simplify_matching
- { cases = m.cases; args = (newarg, Alias) :: argl } in
- let (lam, total) =
- do_compile_matching
- repr partial newarg
- (upper_left_pattern pm)
- pm in
- bind_check str v arg lam, total
- | _ -> assert false
+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
+ | (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
+
+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
+
+
+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=ctx } = divide ctx to_match in
+ let lambda,total = compile_match repr partial ctx this_match in
+ let total = jumps_map up_ctx total in
+ compile_orhandlers (compile_match repr partial) lambda total ctx to_catch
+
-and do_compile_matching repr partial newarg pat pm = match pat.pat_desc with
-| Tpat_any ->
- compile_no_test divide_var repr partial pm
-| Tpat_tuple patl ->
- compile_no_test
- (divide_tuple (List.length patl)) repr partial pm
-| Tpat_record((lbl, _) :: _) ->
- compile_no_test
- (divide_record lbl.lbl_all) repr partial pm
-| Tpat_constant cst ->
- compile_test
- compile_match repr partial
- divide_constant (combine_constant newarg cst)
- pm
-| Tpat_construct (cstr, _) ->
- compile_test compile_match repr partial
- divide_constructor (combine_constructor newarg cstr)
- pm
-| Tpat_array _ ->
- let kind = Typeopt.array_pattern_kind pat in
- compile_test compile_match repr partial
- (divide_array kind) (combine_array newarg kind)
- pm
-| Tpat_variant(lab, _, row) ->
- compile_test compile_match repr partial
- (divide_variant row)
- (combine_variant row newarg)
- pm
-| _ ->
- fatal_error "Matching.do_compile_matching"
-and compile_no_test divide repr partial pm =
- let (this_match, to_catch, others) = divide pm in
- let partial' =
- if others.cases=[] then partial else Partial in
- combine_line
- (compile_match repr partial' this_match)
- (compile_catch compile_match repr partial to_catch others)
(* The entry points *)
(* had toplevel handler when appropriate *)
-let check_total loc total lambda handler_fun =
- if total then
- lambda
- else
- Lcatch(lambda, handler_fun())
+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 =
+ let raise_num = next_raise_count () in
let pm =
{ cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
- args = [arg, Strict] } in
- let (lambda, total) = compile_match repr partial pm in
- check_total loc total lambda handler_fun
+ args = [arg, Strict] ;
+ default = raise_num,[[[omega]],raise_num]} in
+ let (lambda, total) = compile_match repr partial (start_ctx 1) pm in
+ check_total total lambda raise_num handler_fun
let partial_function loc () =
Lprim(Praise, [Lprim(Pmakeblock(0, Immutable),
@@ -1301,61 +2190,97 @@ let for_let loc param pat body =
let flatten_pattern size p =
match p.pat_desc with
Tpat_tuple args -> args
- | Tpat_any -> replicate_list any_pat size
+ | 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 =
- let rec flat_rec = function
- | [] -> [],[]
- | ({pat_desc=Tpat_or (_,_)} as pat :: _, act) :: rem ->
- let vars =
- IdentSet.elements
- (IdentSet.inter
- (extract_vars IdentSet.empty pat)
- (free_variables act)) in
- let raise_num = next_raise_count () in
- let mk_new_action vs =
- Lstaticraise
- (raise_num, List.map (fun v -> Lvar v) vs) in
- let new_cases,to_catch =
- flat_rec
- (explode_or_pat None [] mk_new_action rem vars [] pat) in
- new_cases,
- (raise_num,vars,(act,true))::to_catch
- | (pat :: _, act)::rem ->
- let new_cases, to_catch = flat_rec rem in
- (flatten_pattern size pat, act)::new_cases,
- to_catch
- | _ -> assert false in
- flat_rec 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 } in
- let (lambda, total) = compile_match None partial pm in
- check_total loc total lambda (partial_function loc)
+ args = List.map (fun id -> (Lvar id, Strict)) paraml ;
+ default = raise_num,[omegas,raise_num]
+ } in
+ let (lambda, total) = compile_match None partial
+ (start_ctx (List.length paraml)) pm in
+ check_total total lambda raise_num (partial_function loc)
let for_multiple_match loc paraml pat_act_list partial =
+ let repr = None in
+ let raise_num = next_raise_count () in
let pm1 =
{ cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
- args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] } in
- let pm2 =
- simplify_matching pm1 in
+ args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] ;
+ default = raise_num,[[[omega]],raise_num] } in
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 new_cases, to_catch = flatten_cases (List.length paraml) pm2.cases in
- let pm3 =
- { cases = new_cases ;
- args = List.map (fun id -> (Lvar id, Alias)) idl } in
- let (lambda, total) =
- add_catch
- (compile_match None partial pm3)
- (to_catch,(Lstaticfail,true)) in
- let lambda2 =
- check_total loc total lambda (partial_function loc) in
- List.fold_right2 (bind Strict) idl paraml lambda2
+ 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
+ (check_total total lambda raise_num (partial_function loc))
+
+
with Cannot_flatten ->
- let (lambda, total) = compile_match None partial pm2 in
- check_total loc total lambda (partial_function loc)
+ prerr_endline "Cannot flatten" ;
+ let (lambda, total) = compile_match None partial (start_ctx 1) pm1 in
+ check_total total lambda raise_num (partial_function loc)
+
diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli
index 438366081..763f8fe03 100644
--- a/bytecomp/matching.mli
+++ b/bytecomp/matching.mli
@@ -27,6 +27,7 @@ val for_let:
val for_multiple_match:
Location.t -> lambda list -> (pattern * lambda) list -> partial ->
lambda
+
val for_tupled_function:
Location.t -> Ident.t list -> (pattern list * lambda) list ->
partial -> lambda
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index dd0098b1d..568ef83c2 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -225,24 +225,26 @@ let rec lam ppf = function
if !spc then fprintf ppf "@ " else spc := true;
fprintf ppf "@[<hv 1>case int %i:@ %a@]" n lam l)
sw.sw_consts;
- List.iter
- (fun (n, l) ->
- if !spc then fprintf ppf "@ " else spc := true;
- fprintf ppf "@[<hv 1>case tag %i:@ %a@]" n lam l)
- sw.sw_blocks in
+ List.iter
+ (fun (n, l) ->
+ if !spc then fprintf ppf "@ " else spc := true;
+ fprintf ppf "@[<hv 1>case tag %i:@ %a@]" n lam l)
+ sw.sw_blocks ;
+ begin match sw.sw_failaction with
+ | None -> ()
+ | Some l ->
+ if !spc then fprintf ppf "@ " else spc := true;
+ fprintf ppf "@[<hv 1>default:@ %a@]" lam l
+ end in
+
fprintf ppf
- "@[<1>(%s%s%a@ @[<v 0>%a@])@]"
- (if sw.sw_checked then "switch-checked" else "switch")
- (if sw.sw_nofail then "* " else " ")
+ "@[<1>(%s %a@ @[<v 0>%a@])@]"
+ (match sw.sw_failaction with None -> "switch*" | _ -> "switch")
lam larg switch sw
- | Lstaticfail ->
- fprintf ppf "exit"
| Lstaticraise (i, ls) ->
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls;
- | Lcatch(lbody, lhandler) ->
- fprintf ppf "@[<2>(catch@ %a@;<1 -1>with@ %a)@]" lam lbody lam lhandler
| Lstaticcatch(lbody, (i, vars), lhandler) ->
fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]"
lam lbody i
diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index bf1d65b59..2c2af6317 100644
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -53,11 +53,11 @@ let rec eliminate_ref id = function
sw_numblocks = sw.sw_numblocks;
sw_blocks =
List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks;
- sw_checked = sw.sw_checked; sw_nofail = sw.sw_nofail})
- | Lstaticfail as l -> l
- | Lstaticraise _ as l -> l
- | Lcatch(e1, e2) ->
- Lcatch(eliminate_ref id e1, eliminate_ref id e2)
+ sw_failaction = match sw.sw_failaction with
+ | None -> None
+ | Some l -> Some (eliminate_ref id l)})
+ | Lstaticraise (i,args) ->
+ Lstaticraise (i,List.map (eliminate_ref id) args)
| Lstaticcatch(e1, i, e2) ->
Lstaticcatch(eliminate_ref id e1, i, eliminate_ref id e2)
| Ltrywith(e1, v, e2) ->
@@ -101,22 +101,19 @@ let simplify_lambda lam =
with Not_found ->
Hashtbl.add occ v (ref 1) in
- (* Also count occurrences of (exit n) statements with no arguments *)
+ (* Also count occurrences of (exit n) statements *)
let exits = Hashtbl.create 17 in
let count_exit i =
try
!(Hashtbl.find exits i)
with
| Not_found -> 0
+
and incr_exit i =
try
incr(Hashtbl.find exits i)
with
| Not_found -> Hashtbl.add exits i (ref 1) in
- (* And occurences of Lstaticfail, in every staticcatch scope *)
- let count_fail = ref (ref 0) in
- let at_catch = ref [] in
-
let rec count = function
| Lvar v -> incr_var v
@@ -142,29 +139,22 @@ let simplify_lambda lam =
count body
| Lprim(p, ll) -> List.iter count ll
| Lswitch(l, sw) ->
- (* switch may generate Lstaticfail *)
- if
- (not sw.sw_nofail) &&
- (sw.sw_numconsts > List.length sw.sw_consts ||
- sw.sw_numblocks > List.length sw.sw_blocks)
- then
- !count_fail := !(!count_fail) + 2 ;
+ count_default sw ;
count l;
- List.iter (fun (n, l) -> count l) sw.sw_consts;
- List.iter (fun (n, l) -> count l) sw.sw_blocks ;
- | Lstaticfail -> incr !count_fail
+ List.iter (fun (_, l) -> count l) sw.sw_consts;
+ List.iter (fun (_, l) -> count l) sw.sw_blocks
| Lstaticraise (i,ls) -> incr_exit i ; List.iter count ls
- | Lcatch(l1, l2) as l ->
- let save_count_fail = !count_fail in
- count_fail := ref 0 ;
- count l1;
- let this_count = !(!count_fail) in
- at_catch := (l,!(!count_fail)) :: !at_catch ;
- count_fail := save_count_fail ;
- (* If l1 does not contain staticfail,
- l2 will be removed, so don't count its variables *)
- if this_count > 0 then
- count l2
+ | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) ->
+ (* i will be replaced by j in l1, so each occurence of i in l1
+ increases j's ref count *)
+ count l1 ;
+ let ic = count_exit i in
+ begin try
+ let r = Hashtbl.find exits j in r := !r + ic
+ with
+ | Not_found ->
+ Hashtbl.add exits j (ref ic)
+ end
| Lstaticcatch(l1, (i,_), l2) ->
count l1;
(* If l1 does not contain (exit i),
@@ -184,6 +174,20 @@ let simplify_lambda lam =
| Levent(l, _) -> count l
| Lifused(v, l) ->
if count_var v > 0 then count l
+
+ and count_default sw = match sw.sw_failaction with
+ | None -> ()
+ | Some al ->
+ let nconsts = List.length sw.sw_consts
+ and nblocks = List.length sw.sw_blocks in
+ if
+ nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks
+ then begin (* default action will occur twice in native code *)
+ count al ; count al
+ end else begin (* default action will occur once *)
+ assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ;
+ count al
+ end
in
count lam;
(* Second pass: remove Lalias bindings of unused variables,
@@ -193,8 +197,8 @@ let simplify_lambda lam =
- if (exit i) occurs exactly once in body,
substitute it with handler *)
let subst = Hashtbl.create 83
- and subst_exit = Hashtbl.create 17
- and subst_fail = ref Lstaticfail in
+ and subst_exit = Hashtbl.create 17 in
+
let rec simplif = function
Lvar v as l ->
@@ -237,10 +241,14 @@ let simplify_lambda lam =
| Lswitch(l, sw) ->
let new_l = simplif l
and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts
- and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks in
+ and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks
+ and new_fail = match sw.sw_failaction with
+ | None -> None
+ | Some l -> Some (simplif l) in
Lswitch
- (new_l,{sw with sw_consts = new_consts ; sw_blocks = new_blocks})
- | Lstaticfail as l -> !subst_fail
+ (new_l,
+ {sw with sw_consts = new_consts ; sw_blocks = new_blocks;
+ sw_failaction = new_fail})
| Lstaticraise (i,[]) as l ->
begin try
Hashtbl.find subst_exit i
@@ -248,29 +256,10 @@ let simplify_lambda lam =
| Not_found -> l
end
| Lstaticraise (i,ls) ->
- Lstaticraise (i, List.map simplif ls)
- | Lcatch(l1, l2) as l ->
- let nfail =
- try
- List.assq l !at_catch
- with
- | Not_found -> Misc.fatal_error "Simplif: catch" in
- begin match nfail with
- | 0 -> simplif l1
- | 1 ->
- let new_l2 = simplif l2 in
- let save_subst_fail = !subst_fail in
- subst_fail := new_l2 ;
- let r = simplif l1 in
- subst_fail := save_subst_fail ;
- r
- | _ ->
- let save_subst_fail = !subst_fail in
- subst_fail := Lstaticfail ;
- let r = simplif l1 in
- subst_fail := save_subst_fail ;
- Lcatch (r,simplif l2)
- end
+ Lstaticraise (i, List.map simplif ls)
+ | Lstaticcatch (l1,(i,[]),(Lstaticraise (j,[]) as l2)) ->
+ Hashtbl.add subst_exit i (simplif l2) ;
+ simplif l1
| Lstaticcatch (l1,(i,[]),l2) ->
begin match count_exit i with
| 0 -> simplif l1
diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml
index e4851a4de..0e635c6ec 100644
--- a/bytecomp/switch.ml
+++ b/bytecomp/switch.ml
@@ -12,6 +12,33 @@
type iext = TooMuch | Int of int
+(* Store for actions in object style *)
+exception Found of int
+
+type 'a t_store =
+ {act_get : unit -> 'a array ; act_store : 'a -> int}
+
+let mk_store same =
+ let r_acts = ref [] in
+ let store act =
+ let rec store_rec i = function
+ | [] -> i,[act]
+ | act0::rem ->
+ if same act0 act then raise (Found i)
+ else
+ let i,rem = store_rec (i+1) rem in
+ i,act0::rem in
+ try
+ let i,acts = store_rec 0 !r_acts in
+ r_acts := acts ;
+ i
+ with
+ | Found i -> i
+
+ and get () = Array.of_list !r_acts in
+ {act_store=store ; act_get=get}
+
+
module type S =
sig
type primitive
@@ -23,7 +50,6 @@ module type S =
val gtint : primitive
type act
- val default : act
val bind : act -> (act -> act) -> act
val make_offset : act -> int -> act
val make_prim : primitive -> act list -> act
@@ -73,20 +99,22 @@ module Make (Arg : S) =
(string_of_iext i.low) (string_of_iext i.high) ;
prerr_icases i.icases
- let inter_default _ = function
- | 0 -> true
- | _ -> false
+let inter_default _ = function
+ | 0 -> true
+ | _ -> false
- let is_closed i = match i.low, i.high with
- | Int _, Int _ -> true
- | _,_ -> false
+let is_closed i = match i.low, i.high with
+ | Int _, Int _ -> true
+ | _,_ -> false
- type 'a t_ctx =
- {ctx_low : iext ; ctx_high : iext ; off : int ;
- arg : 'a}
+type 'a t_ctx =
+ {ctx_low : iext ; ctx_high : iext ; off : int ;
+ arg : 'a}
let find_staticfail _ = 0
+let arg_default i ctx = i.iacts.(0) ctx
+
(*
let as_checked i = match i.low, i.high with
| Int _, Int _ ->
@@ -320,35 +348,39 @@ let make_inters_ifs konst arg ({iacts = acts} as i) =
if_rec arg l
with
| NoSuch -> assert false
-
+
- let make_linear_ifs l_status konst arg ({iacts = acts} as i) =
- match l_status with
- | Linter -> make_inters_ifs konst arg i
- | Lsimple ->
- let cases,low,high = i.icases,arg.ctx_low,arg.ctx_high in
- let n = Array.length cases-1 in
- let rec do_rec arg i =
- if i=n then
- let _,_,act = cases.(i) in
- acts.(act) arg
- else
- let _,high,act = cases.(i) in
- make_if_test konst
- Arg.leint arg high (acts.(act) arg)
- (do_rec arg (i+1)) in
- match low,high with
- | TooMuch, TooMuch ->
- let l = min_key i
- and h = max_key i in
- make_if_inter konst arg l h (fun arg -> do_rec arg 0) Arg.default
- | TooMuch,_ ->
- let l = min_key i in
- make_if_test konst Arg.ltint arg l Arg.default (do_rec arg 0)
- | _, TooMuch ->
- let h = max_key i in
- make_if_test konst Arg.gtint arg h Arg.default (do_rec arg 0)
- | _,_ -> do_rec arg 0
+let make_linear_ifs l_status konst arg ({iacts = acts} as i) =
+ match l_status with
+ | Linter -> make_inters_ifs konst arg i
+ | Lsimple ->
+ let cases,low,high = i.icases,arg.ctx_low,arg.ctx_high in
+ let n = Array.length cases-1 in
+ let rec do_rec arg i =
+ if i=n then
+ let _,_,act = cases.(i) in
+ acts.(act) arg
+ else
+ let _,high,act = cases.(i) in
+ make_if_test konst
+ Arg.leint arg high (acts.(act) arg)
+ (do_rec arg (i+1)) in
+ match low,high with
+ | TooMuch, TooMuch ->
+ let l = min_key i
+ and h = max_key i in
+ make_if_inter
+ konst arg l h (fun arg -> do_rec arg 0)
+ (arg_default i arg)
+ | TooMuch,_ ->
+ let l = min_key i in
+ make_if_test
+ konst Arg.ltint arg l (arg_default i arg) (do_rec arg 0)
+ | _, TooMuch ->
+ let h = max_key i in
+ make_if_test
+ konst Arg.gtint arg h (arg_default i arg) (do_rec arg 0)
+ | _,_ -> do_rec arg 0
let special_case i = match i.low, i.high with
| Int 0, Int 2 -> begin match i.icases with
@@ -361,20 +393,17 @@ end
exception Ends
exception NoCut of t_status
-(*
-let debug = ref false
-*)
+
+
+let limit_switch = 4
+and limit_tree = 3
let cut_here i =
let c_if, l_status = count_tests i in
-(*
- if !debug then
- Printf.fprintf stderr "Attempt: %d as %s\n" c_if
- (string_of_status (Linear l_status)) ;
-*)
+
if c_if=0 then raise (NoCut Empty) ;
if special_case i then raise (NoCut Switch) ;
- if c_if - count_bornes i <= !Clflags.limit_switch then
+ if c_if - count_bornes i <= limit_switch then
raise (NoCut (Linear l_status)) ;
let icases = i.icases in
let len = Array.length icases
@@ -440,12 +469,7 @@ let explode_linear i k =
explode_rec 1
let rec do_cluster i k =
-(*
- if !debug then begin
- prerr_string "++++++++++++++++\nCluster " ; prerr_inter i ;
- prerr_endline ""
- end ;
-*)
+
let cases = i.icases in
if i.high = TooMuch && inter_default i (low_action i) then
let l0,h0,act0 = cases.(0) in
@@ -475,12 +499,7 @@ let rec do_cluster i k =
else
sub_cases 0 j cases,
sub_cases j (Array.length cases-j) cases in
-(*
- if !debug then begin
- prerr_string "Left = " ; prerr_icases left ; prerr_endline "" ;
- prerr_string "Right = " ; prerr_icases right ; prerr_endline ""
- end ;
-*)
+
do_cluster
{i with high = Int (c_low-1) ; icases=left}
(do_cluster
@@ -489,13 +508,7 @@ let rec do_cluster i k =
let left = sub_cases 0 j cases
and center = [| cases.(j) |]
and right = sub_cases (j+1) (Array.length cases-j-1) cases in
-(*
- if !debug then begin
- prerr_string "Left = " ; prerr_icases left ; prerr_endline "" ;
- prerr_string "Center = " ; prerr_icases center ; prerr_endline "" ;
- prerr_string "Right = " ; prerr_icases right ; prerr_endline ""
- end ;
-*)
+
if j=0 then
{i with low=i.low ; high = Int c_high ;
icases = center ; status=Empty}::
@@ -517,10 +530,7 @@ let rec do_cluster i k =
end
with
| NoCut status ->
-(*
- if !debug then
- Printf.fprintf stderr "%s\n" (string_of_status status) ;
-*)
+
begin match status with
| Linear _ -> explode_linear i k
| _ -> {i with status=status}::k
@@ -532,15 +542,6 @@ with
and center = sub_cases 1 (len-2) cases
and ln,_,actn = cases.(len-1) in
-(*
- if !debug then begin
- prerr_string "Left = " ; prerr_icases [| cases.(0) |] ;
- prerr_endline "" ;
- prerr_string "Center = " ; prerr_icases center ; prerr_endline "" ;
- prerr_string "Right = " ; prerr_icases [| cases.(len-1) |] ;
- prerr_endline ""
- end ;
-*)
{i with high = Int h0 ; status = Empty ; icases = [| cases.(0) |]}::
do_cluster
@@ -561,23 +562,7 @@ let merge_clusters i1 i2 = match i1.status, i2.status with
| Linear _, Linear _ -> do_merge_clusters i1 i2
| _,_ -> raise NoMerge
-let simpl_clusters l =
- match l with
- | [] -> l
- | [_] -> l
- | _ ->
-(*
- if !debug then begin
- prerr_endline "------------------- Clusters --------------" ;
- List.iter
- (fun i -> prerr_inter i ; prerr_endline "") l
- end ;
-*)
- l
-
-let cluster i =
-
- simpl_clusters (do_cluster i [])
+let cluster i = do_cluster i []
@@ -684,16 +669,7 @@ let final_tests konst arg cl =
let rec comp_tree cl =
let n,status = count_tests cl in
-(*
- if !debug then begin
- prerr_inter cl ;
- Printf.fprintf stderr "\nFinally : %d tests as %s\n" n
- (string_of_status (Linear status)) ;
- flush stderr
- end ;
-*)
-
- if n <= !Clflags.limit_tree then
+ if n <= limit_tree then
comp_leaf konst
{arg with ctx_low = cl.low ; ctx_high = cl.high}
{cl with status = Linear status}
@@ -730,21 +706,8 @@ let zyva konst arg low high cases acts =
icases = cases ;
iacts=Array.map (fun act -> (fun _ -> act)) acts ;
status = ToCluster} in
-(*
- let old_debug = !debug in
- if fst (count_tests cl) > 2 then debug := true ;
- if !debug then begin
- prerr_endline "******** zyva **********" ;
- prerr_inter cl ;
- prerr_endline ""
- end ;
-*)
- let r = comp_inter konst
- {ctx_low=low ; ctx_high=high ; off=0 ; arg=arg} cl in
-(*
- if !debug then prerr_endline "************************" ;
- debug := old_debug ;
-*)
- r
+ comp_inter konst
+ {ctx_low=low ; ctx_high=high ; off=0 ; arg=arg} cl
+
- end
+end
diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli
index 67d85298c..456d32003 100644
--- a/bytecomp/switch.mli
+++ b/bytecomp/switch.mli
@@ -15,11 +15,16 @@
of if tests and switches.
*)
-
(* integer plus infinity, for interval limits *)
type iext = TooMuch | Int of int
+(* For detecting action sharing, object style *)
+
+type 'a t_store =
+ {act_get : unit -> 'a array ; act_store : 'a -> int}
+val mk_store : ('a -> 'a -> bool) -> 'a t_store
+
(* Arguments to the Make functor *)
module type S =
sig
@@ -34,8 +39,6 @@ module type S =
val gtint : primitive
(* type of actions *)
type act
- (* default action *)
- val default : act
(* Various constructors, for making a binder,
adding one integer, etc. *)
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 5a34ee6d6..1ce0ec847 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -402,8 +402,10 @@ let rec push_defaults loc bindings pat_expr_list partial =
(* Insertion of debugging events *)
-let event_before exp lam =
- if !Clflags.debug && lam <> Lstaticfail
+let event_before exp lam = match lam with
+| Lstaticraise (_,_) -> lam
+| _ ->
+ if !Clflags.debug
then Levent(lam, {lev_loc = exp.exp_loc.Location.loc_start;
lev_kind = Lev_before;
lev_repr = None;
@@ -575,7 +577,7 @@ let rec transl_exp e =
| Texp_when(cond, body) ->
event_before cond
(Lifthenelse(transl_exp cond, event_before body (transl_exp body),
- Lstaticfail))
+ staticfail))
| Texp_send(expr, met) ->
let met_id =
match met with
@@ -761,7 +763,7 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr =
then begin
(* Allocate new record with given fields (and remaining fields
taken from init_expr if any *)
- let lv = Array.create (Array.length all_labels) Lstaticfail in
+ let lv = Array.create (Array.length all_labels) staticfail in
let init_id = Ident.create "init" in
begin match opt_init_expr with
None -> ()
diff --git a/byterun/fix_code.c b/byterun/fix_code.c
index 42df6333e..4916af8eb 100644
--- a/byterun/fix_code.c
+++ b/byterun/fix_code.c
@@ -115,10 +115,12 @@ void thread_code (code_t code, asize_t len)
for (p = code; p < code + len; /*nothing*/) {
opcode_t instr = *p;
if (instr < 0 || instr > STOP){
+ /*
fatal_error_arg ("Fatal error in fix_code: bad opcode (%lx)\n",
(char *)(long)instr);
+ */
+ instr = STOP;
}
-
*p++ = (opcode_t)(instr_table[instr] - instr_base);
if (instr == SWITCH) {
uint32 sizes = *p++;
diff --git a/byterun/interp.c b/byterun/interp.c
index 537c2a4b5..b19cd18c8 100644
--- a/byterun/interp.c
+++ b/byterun/interp.c
@@ -745,10 +745,8 @@ value interprete(code_t prog, asize_t prog_size)
pc += pc[(sizes & 0xFFFF) + index];
} else {
long index = Long_val(accu);
- if ((unsigned long) index < (sizes & 0xFFFF))
- pc += pc[index];
- else
- pc += (sizes & 0xFFFF) + (sizes >> 16);
+ Assert ((unsigned long) index < (sizes & 0xFFFF)) ;
+ pc += pc[index];
}
Next;
}
diff --git a/driver/optmain.ml b/driver/optmain.ml
index 19b1941d2..6a3854f88 100644
--- a/driver/optmain.ml
+++ b/driver/optmain.ml
@@ -150,10 +150,6 @@ let main () =
"-dscheduling", Arg.Set dump_scheduling, " (undocumented)";
"-dlinear", Arg.Set dump_linear, " (undocumented)";
"-dstartup", Arg.Set keep_startup_file, " (undocumented)";
-
- "-switch", Arg.Int (fun i -> limit_switch := i), " (undocumented)";
- "-tree", Arg.Int (fun i -> limit_tree := i), " (undocumented)";
-
"-", Arg.String (process_file ppf),
"<file> Treat <file> as a file name (even if it starts with `-')"
] (process_file ppf) usage;
diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml
index 1f08490c7..dacc4c1a9 100644
--- a/tools/dumpobj.ml
+++ b/tools/dumpobj.ml
@@ -367,6 +367,7 @@ let op_shapes = [
opGEINT, Nothing;
opOFFSETINT, Sint;
opOFFSETREF, Sint;
+ opISINT, Nothing;
opGETMETHOD, Nothing;
opBEQ, Sint_Disp;
opBNEQ, Sint_Disp;
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index d868440d5..508a26822 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -24,6 +24,8 @@ open Typedtree
(* and record label names *)
(****************************************)
+exception Empty (* Empty pattern *)
+
let get_type_descr ty tenv =
let ty = Ctype.repr (Ctype.expand_head tenv ty) in
match ty.desc with
@@ -84,6 +86,7 @@ let simple_match p1 p2 =
+
(* extract record fields as a whole *)
let record_arg p = match p.pat_desc with
| Tpat_any -> []
@@ -134,6 +137,18 @@ let sort_record p = match p.pat_desc with
p.pat_type p.pat_env
| _ -> p
+let all_record_args lbls = match lbls with
+| ({lbl_all=lbl_all},_)::_ ->
+ let t =
+ Array.map
+ (fun lbl -> lbl,omega) lbl_all in
+ List.iter
+ (fun ((lbl,_) as x) -> t.(lbl.lbl_pos) <- x)
+ lbls ;
+ Array.to_list t
+| _ -> fatal_error "Parmatch.all_record_args"
+
+
(* Build argument list when p2 >= p1, where p1 is a simple pattern *)
let simple_match_args p1 p2 =
match p2.pat_desc with
@@ -159,7 +174,7 @@ let simple_match_args p1 p2 =
*)
let rec normalize_pat q = match q.pat_desc with
- | Tpat_any | Tpat_constant _ | Tpat_construct (_,[]) -> q
+ | Tpat_any | Tpat_constant _ -> q
| Tpat_var _ -> make_pat Tpat_any q.pat_type q.pat_env
| Tpat_alias (p,_) -> normalize_pat q
| Tpat_tuple (args) ->
@@ -257,8 +272,8 @@ let set_args q r = match q with
make_pat
(Tpat_array args) q.pat_type q.pat_env::
rest
-| {pat_desc=Tpat_constant c} ->
- q::r
+| {pat_desc=Tpat_constant _|Tpat_any} ->
+ q::r (* case any is used in matching.ml *)
| _ -> fatal_error "Parmatch.set_args"
@@ -408,6 +423,7 @@ let full_match tdefs force env = match env with
| ({pat_desc = Tpat_array(_)},_) :: _ -> false
| _ -> fatal_error "Parmatch.full_match"
+(* complement constructor tags *)
let complete_tags nconsts nconstrs tags =
let seen_const = Array.create nconsts false
and seen_constr = Array.create nconstrs false in
@@ -428,12 +444,45 @@ let complete_tags nconsts nconstrs tags =
done ;
!r
+(* build a pattern from a constructor list *)
+let pat_of_constr ex_pat cstr =
+ {ex_pat with pat_desc = Tpat_construct (cstr,omegas cstr.cstr_arity)}
+
+let rec pat_of_constrs ex_pat = function
+| [] -> raise Empty
+| [cstr] -> pat_of_constr ex_pat cstr
+| cstr::rem ->
+ {ex_pat with
+ pat_desc=
+ Tpat_or
+ (pat_of_constr ex_pat cstr,
+ pat_of_constrs ex_pat rem)}
+
+(* Sends back a pattern that complements constructor tags all_tag *)
+let complete_constrs p all_tags = match p.pat_desc with
+| Tpat_construct (c,_) ->
+ begin try
+ let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
+ List.map
+ (fun tag ->
+ let _,targs = get_constr tag p.pat_type p.pat_env in
+ {c with
+ cstr_tag = tag ;
+ cstr_args = targs ;
+ cstr_arity = List.length targs})
+ not_tags
+with
+| Datarepr.Constr_not_found ->
+ fatal_error "Parmatch.complete_constr: constr_not_found"
+ end
+| _ -> fatal_error "Parmatch.complete_constr"
+
+
(*
Builds a pattern that is incompatible with all patterns in
in the first column of env
*)
-
let build_other env = match env with
| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _} as c,_)},_) as p
::_ ->
@@ -444,40 +493,12 @@ let build_other env = match env with
(Path.Pident (Ident.create "*exception*")))},
[]))
Ctype.none Env.empty
-| ({pat_desc = Tpat_construct (c,_)} as p,_) :: _ ->
- begin try
-
+| ({pat_desc = Tpat_construct (_,_)} as p,_) :: _ ->
let get_tag = function
| {pat_desc = Tpat_construct (c,_)} -> c.cstr_tag
| _ -> fatal_error "Parmatch.get_tag" in
- let all_tags =
- List.map (fun (p,_) -> get_tag p) env in
-
- let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
- let make_other_pat tag =
- let _,targs = get_constr tag p.pat_type p.pat_env in
- make_pat
- (Tpat_construct
- ({c with
- cstr_tag = tag ;
- cstr_args = targs ;
- cstr_arity = List.length targs},
- omega_list targs))
- p.pat_type p.pat_env in
- begin match not_tags with
- | [] -> omega (* should not occur, because full_match env is true *)
- | t::rest ->
- List.fold_left
- (fun p_res tag ->
- make_pat
- (Tpat_or (make_other_pat tag, p_res))
- p.pat_type p.pat_env)
- (make_other_pat t)
- rest
- end
- with
- | Datarepr.Constr_not_found -> omega
- end
+ let all_tags = List.map (fun (p,_) -> get_tag p) env in
+ pat_of_constrs p (complete_constrs p all_tags)
| ({pat_desc = Tpat_variant(_,_,row)} as p,_) :: _ ->
let tags =
List.map
@@ -644,7 +665,13 @@ let rec satisfiable tdefs build pss qs =
match satisfiable tdefs build (filter_extra pss) qs with
| Rnone -> try_many try_non_omega constrs
| Rok -> Rok
- | Rsome r -> Rsome (build_other constrs::r)
+ | Rsome r ->
+ try
+ Rsome (build_other constrs::r)
+ with
+ (* cannot occur, since constructors don't make a full signature *)
+ | Empty -> fatal_error "Parmatch.satisfiable"
+
end
| q::qs ->
let q0 = discr_pat q pss in
@@ -674,12 +701,12 @@ let rec initial_matrix = function
then initial_matrix rem
else [pat] :: initial_matrix rem
+(* p less_equal means, forall B, V matches q implies V mactches p *)
let rec le_pat p q =
match (p.pat_desc, q.pat_desc) with
| Tpat_var _,_ -> true | Tpat_any, _ -> true
| Tpat_alias(p,_), _ -> le_pat p q
| _, Tpat_alias(q,_) -> le_pat p q
- | Tpat_or(p1,p2), _ -> le_pat p1 q || le_pat p2 q
| _, Tpat_or(q1,q2) -> le_pat p q1 && le_pat p q2
| Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2
| Tpat_construct(c1,ps), Tpat_construct(c2,qs) ->
@@ -689,23 +716,28 @@ let rec le_pat p q =
| Tpat_variant(l1,None,_), Tpat_variant(l2,None,_) -> l1 = l2
| Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
| Tpat_record l1, Tpat_record l2 ->
- let ps = List.map (fun (_,p) -> p) l1
- and qs = extract_fields l1 l2 in
+ let ps,qs = records_args l1 l2 in
le_pats ps qs
| Tpat_array(ps), Tpat_array(qs) ->
List.length ps = List.length qs && le_pats ps qs
- | _, _ -> false
+(* In all other cases, enumeration is performed *)
+ | _,_ ->
+ begin match satisfiable Env.empty false [[p]] [q] with
+ | Rnone -> true
+ | _ -> false
+ end
+
and le_pats ps qs =
match ps,qs with
p::ps, q::qs -> le_pat p q && le_pats ps qs
| _, _ -> true
-let get_mins ps =
+let get_mins le ps =
let rec select_rec r = function
[] -> r
| p::ps ->
- if List.exists (fun p0 -> le_pats p0 p) ps
+ if List.exists (fun p0 -> le p0 p) ps
then select_rec r ps
else select_rec (p::r) ps in
select_rec [] (select_rec [] ps)
@@ -731,7 +763,8 @@ let is_cons tag v = match get_constr_name tag v.pat_type v.pat_env with
let rec pretty_val ppf v = match v.pat_desc with
- | Tpat_any | Tpat_var _ -> fprintf ppf "_"
+ | Tpat_any -> fprintf ppf "_"
+ | Tpat_var x -> Ident.print ppf x
| Tpat_constant (Const_int i) -> fprintf ppf "%d" i
| Tpat_constant (Const_char c) ->
fprintf ppf "'%s'" (Char.escaped c)
@@ -758,7 +791,7 @@ let rec pretty_val ppf v = match v.pat_desc with
| Tpat_variant (l, None, _) ->
fprintf ppf "`%s" l
| Tpat_variant (l, Some w, _) ->
- fprintf ppf "@[<2`%s@ %a@]" l pretty_arg w
+ fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w
| Tpat_record lvs ->
fprintf ppf "@[{%a}@]"
(pretty_lvals (get_record_labels v.pat_type v.pat_env))
@@ -768,7 +801,8 @@ let rec pretty_val ppf v = match v.pat_desc with
| _ -> true) lvs)
| Tpat_array vs ->
fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
- | Tpat_alias (v,_) -> pretty_val ppf v
+ | Tpat_alias (v,x) ->
+ fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
| Tpat_or (v,w) ->
fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w
@@ -812,6 +846,8 @@ let top_pretty ppf v =
fprintf ppf "@[%a@]@?" pretty_val v
+(* p and q compatible means, there exists V that matches both *)
+
let rec compat p q = match p.pat_desc,q.pat_desc with
| Tpat_alias (p,_),_ -> compat p q
| _,Tpat_alias (q,_) -> compat p q
@@ -845,21 +881,96 @@ and compats ps qs = match ps,qs with
| [], [] -> true
| p::ps, q::qs -> compat p q && compats ps qs
| _,_ -> assert false
-
+(*
+ lub p q is a pattern that matches all values matched by p and q
+ may raise Empty, when p and q and not compatible
+ Exact
+*)
+
+let rec lub p q = match p.pat_desc,q.pat_desc with
+| Tpat_alias (p,_),_ -> lub p q
+| _,Tpat_alias (q,_) -> lub p q
+| (Tpat_any|Tpat_var _),_ -> q
+| _,(Tpat_any|Tpat_var _) -> p
+| Tpat_or (p1,p2),_ -> orlub p1 p2 q
+| _,Tpat_or (q1,q2) -> orlub q1 q2 p (* Thanks god, lub is commutative *)
+| Tpat_constant c1, Tpat_constant c2 when c1=c2 -> p
+| Tpat_tuple ps, Tpat_tuple qs ->
+ let rs = lubs ps qs in
+ make_pat (Tpat_tuple rs) p.pat_type p.pat_env
+| Tpat_construct (c1,ps1), Tpat_construct (c2,ps2)
+ when c1.cstr_tag = c2.cstr_tag ->
+ let rs = lubs ps1 ps2 in
+ make_pat (Tpat_construct (c1,rs)) p.pat_type p.pat_env
+| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_)
+ when l1=l2 ->
+ let r=lub p1 p2 in
+ make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env
+| Tpat_variant (l1,None,_), Tpat_variant(l2,None,_)
+ when l1 = l2 -> p
+| Tpat_record l1,Tpat_record l2 ->
+ let rs = record_lubs l1 l2 in
+ make_pat (Tpat_record rs) p.pat_type p.pat_env
+| Tpat_array ps, Tpat_array qs
+ when List.length ps = List.length qs ->
+ let rs = lubs ps qs in
+ make_pat (Tpat_array rs) p.pat_type p.pat_env
+| _,_ ->
+ raise Empty
+
+and orlub p1 p2 q =
+ try
+ let r1 = lub p1 q in
+ try
+ {q with pat_desc=(Tpat_or (r1,lub p2 q))}
+ with
+ | Empty -> r1
+ with
+ | Empty -> lub p2 q
+
+and record_lubs l1 l2 =
+ let l1 = sort_fields l1 and l2 = sort_fields l2 in
+ let rec lub_rec l1 l2 = match l1,l2 with
+ | [],_ -> l2
+ | _,[] -> l1
+ | (lbl1,p1)::rem1, (lbl2,p2)::rem2 ->
+ if lbl1.lbl_pos < lbl2.lbl_pos then
+ (lbl1,p1)::lub_rec rem1 l2
+ else if lbl2.lbl_pos < lbl1.lbl_pos then
+ (lbl2,p2)::lub_rec l1 rem2
+ else
+ (lbl1,lub p1 p2)::lub_rec rem1 rem2 in
+ lub_rec l1 l2
+
+and lubs ps qs = match ps,qs with
+| p::ps, q::qs -> lub p q :: lubs ps qs
+| _,_ -> []
+
+
(******************************)
(* Entry points *)
(* - Partial match *)
(* - Unused match case *)
(******************************)
+
+(*
+ A small cvs commit/commit discussion....
+ JG:
+ Exhaustiveness of matching MUST be checked, even
+ when the warning is excluded explicitely by user.
+ LM:
+ Why such a strange thing ?
+ JG:
+ Because the typing of variants depends on it.
+ LM:
+ Ok, note that by contrast, unused clause check still can be avoided at
+ user request.
+*)
+
let check_partial tdefs loc casel =
- (* This must be checked: typing of variants depend of this
- * if not (Warnings.is_active (Warnings.Partial_match "")) then
- * Partial
- * else
- *)
- let pss = get_mins (initial_matrix casel) in
+ let pss = get_mins le_pats (initial_matrix casel) in
match pss with
| [] ->
(*
@@ -895,6 +1006,7 @@ let location_of_clause = function
pat :: _ -> pat.pat_loc
| _ -> fatal_error "Parmatch.location_of_clause"
+
let check_unused tdefs casel =
if Warnings.is_active Warnings.Unused_match then
let prefs =
@@ -921,3 +1033,7 @@ let check_unused tdefs casel =
(Warnings.Other "Fatal Error") ;
raise e)
prefs
+
+
+
+
diff --git a/typing/parmatch.mli b/typing/parmatch.mli
index cbec9892f..d08f20bda 100644
--- a/typing/parmatch.mli
+++ b/typing/parmatch.mli
@@ -13,15 +13,35 @@
(* $Id$ *)
(* Detection of partial matches and unused match cases. *)
-
+open Types
open Typedtree
+val omega : pattern
+val omegas : int -> pattern list
val omega_list : 'a list -> pattern list
+val normalize_pat : pattern -> pattern
+val all_record_args :
+ (label_description * pattern) list -> (label_description * pattern) list
+val le_pat : pattern -> pattern -> bool
+val le_pats : pattern list -> pattern list -> bool
val compat : pattern -> pattern -> bool
val compats : pattern list -> pattern list -> bool
+exception Empty
+val lub : pattern -> pattern -> pattern
+val lubs : pattern list -> pattern list -> pattern list
+
+val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list
+
+val set_args : pattern -> pattern list -> pattern list
+
+val pat_of_constr : pattern -> constructor_description -> pattern
+val complete_constrs :
+ pattern -> constructor_tag list -> constructor_description list
val check_partial:
Env.t -> Location.t -> (pattern * expression) list -> partial
val check_unused: Env.t -> (pattern * expression) list -> unit
+
+val top_pretty : Format.formatter -> pattern -> unit
diff --git a/utils/clflags.ml b/utils/clflags.ml
index 71c7aba5b..722e343ed 100644
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -71,5 +71,3 @@ let native_code = ref false (* set to true under ocamlopt *)
let inline_threshold = ref 10
-let limit_tree = ref 3
-and limit_switch = ref 2
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-24 06:34:30 +0000