summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--bytecomp/bytegen.ml63
-rw-r--r--bytecomp/lambda.ml14
-rw-r--r--bytecomp/lambda.mli6
-rw-r--r--bytecomp/matching.ml809
-rw-r--r--bytecomp/printlambda.ml10
-rw-r--r--bytecomp/simplif.ml25
-rw-r--r--typing/parmatch.ml195
-rw-r--r--typing/parmatch.mli6
8 files changed, 744 insertions, 384 deletions
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index c190affee..cb31467cb 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -202,6 +202,9 @@ let add_event ev =
let lbl_staticfail = ref None
and sz_staticfail = ref 0
+(* Same information as a stack for Lstaticraise *)
+let sz_static_raises = ref []
+
(* Function bodies that remain to be compiled *)
type function_to_compile =
@@ -507,13 +510,25 @@ let rec comp_expr env exp sz cont =
lbl_staticfail := saved_lbl_staticfail;
sz_staticfail := saved_sz_staticfail;
cont3
- | Lstaticfail ->
+ | Lstaticfail -> comp_static_fail sz cont
+ | Lstaticcatch (body, i, handler) ->
+ let branch1, cont1 = make_branch cont in
+ let lbl_handler, cont2 =
+ label_code (comp_expr env handler sz cont1) in
+ sz_static_raises := (i, (lbl_handler, sz)) :: !sz_static_raises ;
+ let cont3 = comp_expr env body sz (branch1 :: cont2) in
+ sz_static_raises := List.tl !sz_static_raises ;
+ cont3
+ | Lstaticraise i ->
let cont = discard_dead_code cont in
- begin match !lbl_staticfail with
- None -> cont
- | Some label ->
- add_pop (sz - !sz_staticfail) (Kbranch label :: cont)
- end
+ let label, size =
+ try
+ List.assoc i !sz_static_raises
+ with
+ | Not_found ->
+ Misc.fatal_error
+ ("exit("^string_of_int i^") outside appropriated catch") in
+ add_pop (sz-size) (Kbranch label :: cont)
| Ltrywith(body, id, handler) ->
let (branch1, cont1) = make_branch cont in
let lbl_handler = new_label() in
@@ -556,19 +571,27 @@ let rec comp_expr env exp sz cont =
List.iter (fun (n, act) -> act_blocks.(n) <- act) sw.sw_blocks;
let lbl_consts = Array.create sw.sw_numconsts 0 in
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) =
- label_code(comp_expr env act_blocks.(i) sz (branch :: !c)) in
+ let (lbl, c1) = comp_nofail act_blocks.(i) !c in
lbl_blocks.(i) <- lbl;
c := discard_dead_code c1
done;
for i = sw.sw_numconsts - 1 downto 0 do
- let (lbl, c1) =
- label_code(comp_expr env act_consts.(i) sz (branch :: !c)) in
+ let (lbl, c1) = comp_nofail act_consts.(i) !c in
lbl_consts.(i) <- lbl;
c := discard_dead_code c1
done;
- if sw.sw_checked then c := comp_expr env Lstaticfail sz !c;
+ 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
@@ -626,6 +649,16 @@ 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) (Kbranch 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. *)
@@ -648,18 +681,18 @@ and comp_binary_test env cond ifso ifnot sz cont =
let (lbl_end, cont1) = label_code cont in
Kstrictbranchifnot lbl_end :: comp_expr env ifso sz cont1
end else
- if ifso = Lstaticfail && (sz = !sz_staticfail || !lbl_staticfail = None)
+ if ifso = Lstaticfail && sz = !sz_staticfail
then
let cont = comp_expr env ifnot sz cont in
match !lbl_staticfail with
- None -> cont
+ | None -> Misc.fatal_error "exit outside appropriated catch"
| Some label -> Kbranchif label :: cont
else
- if ifnot = Lstaticfail && (sz = !sz_staticfail || !lbl_staticfail = None)
+ if ifnot = Lstaticfail && sz = !sz_staticfail
then
let cont = comp_expr env ifso sz cont in
match !lbl_staticfail with
- None -> cont
+ | None -> Misc.fatal_error "exit outside appropriated catch"
| Some label -> Kbranchifnot label :: cont
else begin
let (branch_end, cont1) = make_branch cont in
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 79ed91d98..e54ec3d0b 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -125,6 +125,8 @@ type lambda =
| Lswitch of lambda * lambda_switch
| Lstaticfail
| Lcatch of lambda * lambda
+ | Lstaticraise of int
+ | Lstaticcatch of lambda * int * lambda
| Ltrywith of lambda * Ident.t * lambda
| Lifthenelse of lambda * lambda * lambda
| Lsequence of lambda * lambda
@@ -140,7 +142,8 @@ and lambda_switch =
sw_consts: (int * lambda) list;
sw_numblocks: int;
sw_blocks: (int * lambda) list;
- sw_checked: bool }
+ sw_checked: bool ;
+ sw_nofail: bool }
and lambda_event =
{ lev_loc: int;
@@ -201,9 +204,12 @@ let free_variables l =
freevars arg;
List.iter (fun (key, case) -> freevars case) sw.sw_consts;
List.iter (fun (key, case) -> freevars case) sw.sw_blocks
- | Lstaticfail -> ()
+ | Lstaticfail -> ()
| Lcatch(e1, e2) ->
freevars e1; freevars e2
+ | Lstaticraise _ -> ()
+ | Lstaticcatch(e1, _, e2) ->
+ freevars e1; freevars e2
| Ltrywith(e1, exn, e2) ->
freevars e1; freevars e2; fv := IdentSet.remove exn !fv
| Lifthenelse(e1, e2, e3) ->
@@ -270,8 +276,10 @@ let subst_lambda s lam =
Lswitch(subst arg,
{sw with sw_consts = List.map subst_case sw.sw_consts;
sw_blocks = List.map subst_case sw.sw_blocks})
- | Lstaticfail -> Lstaticfail
+ | Lstaticfail as l -> l
| Lcatch(e1, e2) -> Lcatch(subst e1, subst e2)
+ | Lstaticraise i as l -> l
+ | 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)
| Lsequence(e1, e2) -> Lsequence(subst e1, subst e2)
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index dc4c0216e..e4eac31b6 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -134,6 +134,8 @@ type lambda =
| Lswitch of lambda * lambda_switch
| Lstaticfail
| Lcatch of lambda * lambda
+ | Lstaticraise of int
+ | Lstaticcatch of lambda * int * lambda
| Ltrywith of lambda * Ident.t * lambda
| Lifthenelse of lambda * lambda * lambda
| Lsequence of lambda * lambda
@@ -149,8 +151,8 @@ 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_checked: bool ; (* True if bound checks needed *)
+ sw_nofail: bool} (* True if should not fail *)
and lambda_event =
{ lev_loc: int;
lev_kind: lambda_event_kind;
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 1c06ffdb4..0ca62055f 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -21,6 +21,7 @@ open Primitive
open Types
open Typedtree
open Lambda
+open Parmatch
(* See Peyton-Jones, ``The Implementation of functional programming
languages'', chapter 5. *)
@@ -68,40 +69,173 @@ let any_pat =
{ pat_desc = Tpat_any; pat_loc = Location.none;
pat_type = Ctype.none; pat_env = Env.empty }
-let simplify_matching m =
- match m.args with
- [] -> m
- | (arg, mut) :: argl ->
+exception Var
+;;
+
+let simplify_or p =
+ let rec simpl_rec = function
+ | {pat_desc = Tpat_any} -> raise Var
+ | {pat_desc = Tpat_or (p1,p2)} ->
+ simpl_rec p1 ; simpl_rec p2
+ | _ -> () in
+ try
+ simpl_rec p ; p
+ with
+ | Var -> any_pat
+
+let simplify_matching m = match m.args with
+| [] -> m
+| (arg, mut) :: argl ->
let rec simplify = function
(pat :: patl, action as patl_action) :: rem ->
begin match pat.pat_desc with
- Tpat_var id ->
+ | Tpat_var id ->
(any_pat :: patl, bind Alias id arg action) ::
simplify rem
| Tpat_alias(p, id) ->
simplify ((p :: patl, bind Alias id arg action) :: rem)
+ | Tpat_record [] ->
+ (any_pat :: patl, action) :: simplify rem
+ | Tpat_or (_,_) ->
+ (simplify_or pat :: patl, action) ::
+ simplify rem
| _ ->
patl_action :: simplify rem
end
| cases -> cases in
{ args = m.args; cases = simplify m.cases }
+let rec what_is_or = function
+ | {pat_desc = Tpat_or (p1,_)} -> what_is_or p1
+ | {pat_desc = (Tpat_alias (_,_)|Tpat_var _|Tpat_any)} ->
+ Misc.fatal_error "Mathing.what_is_or"
+ | p -> p
+
+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 raise_count = ref 0
+
+let next_raise_count () =
+ incr raise_count ; (* Done before, since 0 is for partial matches *)
+ !raise_count
+
+let rec group_or group = function
+ | {pat_desc = Tpat_or (p1, p2)} -> group_or group p1 && group_or group p2
+ | p -> group p
+
+let rec explode_or_pat patl action rem = function
+ | {pat_desc = Tpat_or (p1,p2)} ->
+ explode_or_pat
+ patl action
+ (explode_or_pat patl action rem p1)
+ p2
+ | p -> (p::patl,action)::rem
+
+let more group ({cases=cl ; args = al} as m) = match al with
+| [] -> assert false
+| _ ->
+ 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) ->
+ begin match action with
+ | Lstaticraise _ | Lstaticfail
+ when 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 patl action new_yes p,
+ new_to_catch,
+ new_others
+ | _ ->
+ let raise_num = next_raise_count () in
+ let new_patl = Parmatch.omega_list patl
+ and new_action = Lstaticraise raise_num in
+ let new_yes,new_to_catch,new_others =
+ add_or (p::prev) rem in
+ explode_or_pat new_patl new_action new_yes p,
+ ((raise_num, {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
+
+
+(* General divide functions *)
+let divide group make get_key get_args ({args=al} as pm) =
+ let rec divide_rec = function
+ | (p::patl,action) :: rem
+ when group p ->
+ 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
+
+let divide_line group make get_args ({args=al} as 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
+
(* Matching against a constant *)
-let make_constant_matching = function
+let group_constant = function
+ | {pat_desc= Tpat_constant _} -> true
+ | _ -> false
+
+let make_constant_matching _ = function
[] -> fatal_error "Matching.make_constant_matching"
| (arg :: argl) -> {cases = []; args = argl}
-let divide_constant {cases = cl; args = al} =
- let rec divide = function
- ({pat_desc = Tpat_constant cst} :: patl, action) :: rem ->
- let (constants, others) = divide rem in
- (add make_constant_matching constants cst (patl, action) al, others)
- | cl ->
- ([], {cases = cl; args = al})
- in divide cl
+let get_key_constant = function
+ | {pat_desc= Tpat_constant cst} -> cst
+ | _ -> assert false
+
+let get_args_constant _ rem = rem
+
+let divide_constant m =
+ divide
+ group_constant make_constant_matching
+ get_key_constant get_args_constant
+ 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 =
@@ -110,9 +244,22 @@ let make_field_args binding_kind arg first_pos last_pos argl =
else (Lprim(Pfield pos, [arg]), binding_kind) :: make_args (pos + 1)
in make_args first_pos
-let make_constr_matching cstr = function
+let get_key_constr = function
+ | {pat_desc=Tpat_construct (cstr,_)} -> cstr.cstr_tag
+ | _ -> assert false
+
+let get_args_constr p rem = match p with
+ | {pat_desc=Tpat_construct (_,args)} -> args @ rem
+ | _ -> assert false
+
+let pat_as_constr = function
+ | {pat_desc=Tpat_construct (cstr,_)} -> cstr
+ | _ -> assert false
+
+let make_constr_matching p = function
[] -> fatal_error "Matching.make_constr_matching"
| ((arg, mut) :: argl) ->
+ let cstr = pat_as_constr p in
let newargs =
match cstr.cstr_tag with
Cstr_constant _ | Cstr_block _ ->
@@ -121,18 +268,17 @@ let make_constr_matching cstr = function
make_field_args Alias arg 1 cstr.cstr_arity argl in
{cases = []; args = newargs}
-let divide_constructor {cases = cl; args = al} =
- let rec divide = function
- ({pat_desc = Tpat_construct(cstr, args)} :: patl, action) :: rem ->
- let (constructs, others) = divide rem in
- (add (make_constr_matching cstr) constructs
- cstr.cstr_tag (args @ patl, action) al,
- others)
- | cl ->
- ([], {cases = cl; args = al})
- in divide cl
+
+let divide_constructor pm =
+ divide
+ group_constructor make_constr_matching
+ get_key_constr get_args_constr
+ pm
(* Matching against a variant *)
+let group_variant = function
+ | {pat_desc = Tpat_variant (_, _, _)} -> true
+ | _ -> false
let make_variant_matching_constant = function
[] -> fatal_error "Matching.make_variant_matching_constant"
@@ -144,44 +290,46 @@ let make_variant_matching_nonconst = function
| ((arg, mut) :: argl) ->
{cases = []; args = (Lprim(Pfield 1, [arg]), Alias) :: argl}
-let divide_variant row {cases = cl; args = al} =
+let divide_variant row ({cases = cl; args = al} as pm) =
let row = Btype.row_repr row in
let rec divide = function
({pat_desc = Tpat_variant(lab, pato, _)} :: patl, action) :: rem ->
- let (variants, others) = divide rem in
+ let variants = divide rem in
if try Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent
with Not_found -> true
then
- (variants, others)
+ variants
else begin
let tag = Btype.hash_variant lab in
match pato with
None ->
- (add make_variant_matching_constant variants
- (Cstr_constant tag) (patl, action) al,
- others)
+ add make_variant_matching_constant variants
+ (Cstr_constant tag) (patl, action) al
| Some pat ->
- (add make_variant_matching_nonconst variants
- (Cstr_block tag) (pat :: patl, action) al,
- others)
+ add make_variant_matching_nonconst variants
+ (Cstr_block tag) (pat :: patl, action) al
end
- | cl ->
- ([], {cases = cl; args = al})
- in divide cl
-
+ | cl -> []
+ in
+ let yes, to_catch, others = more group_variant pm in
+ divide yes, to_catch, others
(* Matching against a variable *)
+let group_var = function
+ | {pat_desc=Tpat_any} -> true
+ | _ -> false
-let divide_var {cases = cl; args = al} =
- let rec divide = function
- ({pat_desc = Tpat_any} :: patl, action) :: rem ->
- let (vars, others) = divide rem in
- (add_line (patl, action) vars, others)
- | cl ->
- (make_constant_matching al, {cases = cl; args = al})
- in divide cl
+let get_args_var _ rem = rem
+
+let divide_var pm =
+ divide_line
+ group_var (make_constant_matching Tpat_any)
+ get_args_var 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
[] -> fatal_error "Matching.make_tuple_matching"
@@ -192,22 +340,42 @@ let make_tuple_matching num_comps = function
else (Lprim(Pfield pos, [arg]), Alias) :: make_args (pos + 1) in
{cases = []; args = make_args 0}
-let divide_tuple arity {cases = cl; args = al} =
- let rec divide = function
- ({pat_desc = Tpat_tuple args} :: patl, action) :: rem ->
- let (tuples, others) = divide rem in
- (add_line (args @ patl, action) tuples, others)
- | ({pat_desc = Tpat_any} :: patl, action) :: rem ->
- let (tuples, others) = divide rem in
- (add_line (replicate_list any_pat arity @ patl, action) tuples, others)
- | cl ->
- (make_tuple_matching arity al, {cases = cl; args = al})
- in divide cl
+
+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
+
+
+let divide_tuple arity pm =
+ divide_line
+ group_tuple (make_tuple_matching arity)
+ (get_args_tuple arity)
+ 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
+ List.iter (fun (lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list;
+ Array.to_list patv
+
+let get_args_record num_fields p rem = match p with
+| {pat_desc=Tpat_any} ->
+ record_matching_line num_fields [] @ rem
+| {pat_desc=Tpat_record lbl_pat_list} ->
+ record_matching_line num_fields lbl_pat_list @ rem
+| _ -> assert false
+
+
let make_record_matching all_labels = function
- [] -> fatal_error "Matching.make_tuple_matching"
+ [] -> fatal_error "Matching.make_record_matching"
| ((arg, mut) :: argl) ->
let rec make_args pos =
if pos >= Array.length all_labels then argl else begin
@@ -224,23 +392,12 @@ let make_record_matching all_labels = function
end in
{cases = []; args = make_args 0}
-let divide_record all_labels {cases = cl; args = al} =
- let num_fields = Array.length all_labels in
- let record_matching_line lbl_pat_list =
- let patv = Array.create num_fields any_pat in
- List.iter (fun (lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list;
- Array.to_list patv in
- let rec divide = function
- ({pat_desc = Tpat_record lbl_pat_list} :: patl, action) :: rem ->
- let (records, others) = divide rem in
- (add_line (record_matching_line lbl_pat_list @ patl, action) records,
- others)
- | ({pat_desc = Tpat_any} :: patl, action) :: rem ->
- let (records, others) = divide rem in
- (add_line (record_matching_line [] @ patl, action) records, others)
- | cl ->
- (make_record_matching all_labels al, {cases = cl; args = al})
- in divide cl
+let divide_record all_labels pm =
+ divide_line
+ group_record
+ (make_record_matching all_labels)
+ (get_args_record (Array.length all_labels))
+ pm
(* Matching against an or pattern. *)
@@ -258,6 +415,17 @@ let divide_orpat = function
fatal_error "Matching.divide_orpat"
(* 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
+ | _ -> assert false
+
+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"
@@ -269,39 +437,75 @@ let make_array_matching kind len = function
StrictOpt) :: make_args (pos + 1) in
{cases = []; args = make_args 0}
-let divide_array kind {cases = cl; args = al} =
- let rec divide = function
- ({pat_desc = Tpat_array(args)} :: patl, action) :: rem ->
- let len = List.length args in
- let (constructs, others) = divide rem in
- (add (make_array_matching kind len) constructs len
- (args @ patl, action) al,
- others)
- | cl ->
- ([], {cases = cl; args = al})
- in divide cl
-
+let divide_array kind pm =
+ divide
+ group_array
+ (fun p -> make_array_matching kind (get_key_array p))
+ get_key_array get_args_array pm
+
(* To combine sub-matchings together *)
+let rec raw_action = function
+ | Llet(Alias,_,_, body) -> raw_action body
+ | l -> l
+
+let same_actions = function
+ | [] -> None
+ | [_,act] -> Some act
+ | (_,act0) :: rem ->
+ let raw_act0 = raw_action act0 in
+ match raw_act0 with
+ | Lstaticfail | Lstaticraise _ ->
+ let rec s_rec = function
+ | [] -> Some raw_act0
+ | (_,act)::rem ->
+ if raw_act0 = raw_action act then
+ s_rec rem
+ else
+ None in
+ s_rec rem
+ | _ -> None
+
+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,(handler_i,total_i))::rem ->
+ do_rec
+ (match raw_action r with
+ | Lstaticraise j when i=j -> handler_i
+ | _ -> Lstaticcatch(r,i,handler_i))
+ (total_i && total_r) rem in
+
+ do_rec lambda1 total1 c_catch
+
let combine_var (lambda1, total1) (lambda2, total2) =
if total1 then (lambda1, true)
else if lambda2 = Lstaticfail then (lambda1, total1)
else (Lcatch(lambda1, lambda2), total2)
+let combine_line (lambda1, total1) c_catch =
+ add_catch (lambda1, total1) c_catch
+
let rec cut n l =
if n = 0 then [],l
else match l with
[] -> raise (Invalid_argument "cut")
| a::l -> let l1,l2 = cut (n-1) l in a::l1, l2
-let make_test_sequence check tst lt_tst arg const_lambda_list =
+let make_test_sequence nofail check 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 then act else
+ if rem = Lstaticfail && (not check || nofail) then act else
Lifthenelse(Lprim(tst, [arg; Lconst(Const_base c)]), act, rem))
const_lambda_list
Lstaticfail
@@ -313,81 +517,95 @@ let make_test_sequence check tst lt_tst arg const_lambda_list =
in make_test_sequence
(Sort.list (fun (c1,_) (c2,_) -> c1 < c2) const_lambda_list)
-let make_switch_or_test_sequence check arg const_lambda_list int_lambda_list =
+
+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
+ 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
+ if List.length int_lambda_list <= 1 + max_key / 4 - min_key / 4 then
(* Sparse matching -- use a sequence of tests *)
- make_test_sequence check (Pintcomp Ceq) (Pintcomp Clt)
- arg const_lambda_list
- else begin
+ make_test_sequence nofail check (Pintcomp Ceq) (Pintcomp Clt)
+ arg const_lambda_list
+ else begin
(* Dense matching -- use a jump table
(2 bytecode instructions + 1 word per entry in the table) *)
- 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 =
- if min_key = 0 then arg else Lprim(Poffsetint(-min_key), [arg]) in
- Lswitch(offsetarg,
- {sw_numconsts = numcases; sw_consts = cases;
- sw_numblocks = 0; sw_blocks = []; sw_checked = check})
- end
+ 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 =
+ if min_key = 0 then arg else Lprim(Poffsetint(-min_key), [arg]) in
+ Lswitch(offsetarg,
+ {sw_numconsts = numcases; sw_consts = cases;
+ sw_numblocks = 0; sw_blocks = []; sw_checked = check ;
+ sw_nofail = nofail})
+ end
let make_test_sequence_variant_constant check arg int_lambda_list =
- make_test_sequence check (Pintcomp Ceq) (Pintcomp Clt) arg
+ make_test_sequence false check (Pintcomp Ceq) (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 check (Pintcomp Ceq) (Pintcomp Clt) (Lvar v)
+ make_test_sequence false check (Pintcomp Ceq) (Pintcomp Clt) (Lvar v)
(List.map (fun (n, l) -> (Const_int n, l)) int_lambda_list))
-let make_bitvect_check arg int_lambda_list =
+let make_bitvect_check arg int_lambda_list lambda =
let bv = String.make 32 '\000' in
List.iter
- (fun (n, l) ->
+ (fun (n, _) ->
bv.[n lsr 3] <- Char.chr(Char.code bv.[n lsr 3] lor (1 lsl (n land 7))))
int_lambda_list;
Lifthenelse(Lprim(Pbittest, [Lconst(Const_base(Const_string bv)); arg]),
- lambda_unit, Lstaticfail)
+ lambda, Lstaticfail)
let prim_string_equal =
Pccall{prim_name = "string_equal";
prim_arity = 2; prim_alloc = false;
prim_native_name = ""; prim_native_float = false}
-let combine_constant arg cst (const_lambda_list, total1) (lambda2, total2) =
- let lambda1 =
- match cst with
- Const_int _ ->
- let int_lambda_list =
- List.map (function Const_int n, l -> n,l | _ -> assert false)
- const_lambda_list in
- make_switch_or_test_sequence true arg const_lambda_list int_lambda_list
+let combine_constant arg cst partial (const_lambda_list, total1) c_catch =
+ let nofail = partial=Total
+ and one_action = same_actions const_lambda_list in
+ match nofail,one_action with
+ | true, Some act -> act,total1
+ | _, _ ->
+ let lambda1 =
+ match cst with
+ Const_int _ ->
+ let int_lambda_list =
+ List.map (function Const_int n, l -> n,l | _ -> assert false)
+ const_lambda_list in
+ make_switch_or_test_sequence
+ nofail true arg const_lambda_list int_lambda_list
| Const_char _ ->
let int_lambda_list =
List.map (function Const_char c, l -> (Char.code c, l)
| _ -> assert false)
const_lambda_list in
- if List.for_all (fun (c, l) -> l = lambda_unit) const_lambda_list then
- make_bitvect_check arg int_lambda_list
- else
- make_switch_or_test_sequence true arg
+ 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 true prim_string_equal Praise arg const_lambda_list
+ make_test_sequence
+ nofail true prim_string_equal Praise arg const_lambda_list
| Const_float _ ->
- make_test_sequence true (Pfloatcomp Ceq) (Pfloatcomp Clt)
- arg const_lambda_list
- in (Lcatch(lambda1, lambda2), total2)
+ make_test_sequence
+ nofail
+ true (Pfloatcomp Ceq) (Pfloatcomp Clt)
+ arg const_lambda_list in
+ add_catch (lambda1, nofail) c_catch
let rec split_cases = function
[] -> ([], [])
@@ -398,10 +616,18 @@ let rec split_cases = function
| Cstr_block n -> (consts, (n, act) :: nonconsts)
| _ -> assert false
-let combine_constructor arg cstr (tag_lambda_list, total1) (lambda2, total2) =
+let combine_constructor arg cstr partial (tag_lambda_list, total1) c_catch =
+ let nofail = partial=Total in
if cstr.cstr_consts < 0 then begin
- (* Special cases for exceptions *)
+ (* Special cases for exceptions *)
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
List.fold_right
(fun (ex, act) rem ->
match ex with
@@ -410,35 +636,57 @@ let combine_constructor arg cstr (tag_lambda_list, total1) (lambda2, total2) =
[Lprim(Pfield 0, [arg]); transl_path path]),
act, rem)
| _ -> assert false)
- tag_lambda_list Lstaticfail
- in (Lcatch(lambda1, lambda2), total2)
+ tests default
+ in add_catch (lambda1, nofail) c_catch
end else begin
(* Regular concrete type *)
- let (consts, nonconsts) = split_cases tag_lambda_list in
+ let sig_complete =
+ List.length tag_lambda_list = cstr.cstr_consts + cstr.cstr_nonconsts
+ and one_action = same_actions tag_lambda_list in
+ let total_loc = sig_complete || nofail in
let lambda1 =
- match (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) with
- (1, 0, [0, act], []) -> act
- | (0, 1, [], [0, act]) -> act
- | (1, 1, [0, act1], [0, act2]) ->
- Lifthenelse(arg, act2, act1)
- | (1, 1, [0, act1], []) ->
- Lifthenelse(arg, Lstaticfail, act1)
- | (1, 1, [], [0, act2]) ->
- Lifthenelse(arg, act2, Lstaticfail)
- | (_, _, _, _) ->
- Lswitch(arg, {sw_numconsts = cstr.cstr_consts;
- sw_consts = consts;
- sw_numblocks = cstr.cstr_nonconsts;
- sw_blocks = nonconsts;
- sw_checked = false}) in
- if total1
- && List.length tag_lambda_list = cstr.cstr_consts + cstr.cstr_nonconsts
- then (lambda1, true)
- else (Lcatch(lambda1, lambda2), total2)
+ match total_loc, one_action with
+ | true, Some act -> act
+ | _,_ ->
+ let (consts, nonconsts) = split_cases tag_lambda_list in
+ match (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) with
+ (1, 0, [0, act], []) -> act
+ | (0, 1, [], [0, act]) -> act
+ | (2, 0, [(n1, act1) ; (n2, act2)], []) ->
+ let act_true, act_false =
+ if n1=0 then act2, act1 else act1, act2 in
+ Lifthenelse (arg, act_true, act_false)
+ | (2, 0, [(n, act) ], []) ->
+ if total_loc then
+ act
+ else
+ let act_true, act_false =
+ if n=0 then Lstaticfail , act else act, Lstaticfail in
+ Lifthenelse (arg, act_true, act_false)
+ | (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)
+ | (_, _, _, _) ->
+ 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
end
let combine_variant row arg partial (tag_lambda_list, total1)
- (lambda2, total2) =
+ c_catch =
let row = Btype.row_repr row in
let num_constr = ref 0 in
if row.row_closed then
@@ -451,48 +699,38 @@ let combine_variant row arg partial (tag_lambda_list, total1)
else
num_constr := max_int;
let (consts, nonconsts) = split_cases tag_lambda_list in
- let total =
- total1 && (partial = Total || List.length tag_lambda_list = !num_constr) in
let test_int_or_block arg if_int if_block =
Lifthenelse(Lprim (Pisint, [arg]), if_int, if_block) in
- let lambda1 =
- if total &&
- List.for_all (fun (_, act) -> act = lambda_unit) tag_lambda_list
- then
- lambda_unit
- else
+ 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
+ | _,_ ->
match (consts, nonconsts) with
- ([n, act], []) when total -> act
- | ([], [n, act]) when total -> act
- | ([n, act1], [m, act2]) when total ->
+ | ([n, act1], [m, act2]) when total_loc ->
test_int_or_block arg act1 act2
| ([n, act], []) ->
- make_test_sequence_variant_constant (not total) arg consts
+ make_test_sequence_variant_constant (not total_loc) arg consts
| (_, []) ->
let lam = make_test_sequence_variant_constant
- (not total) arg consts in
- if total then lam else test_int_or_block arg lam Lstaticfail
+ (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_constr
- (not total) arg nonconsts in
- if total then lam else test_int_or_block arg Lstaticfail lam
+ (not total_loc) arg nonconsts in
+ if total_loc then lam else test_int_or_block arg Lstaticfail lam
| (_, _) ->
let lam_const = make_test_sequence_variant_constant
- (not total) arg consts in
+ (not total_loc) arg consts in
let lam_nonconst = make_test_sequence_variant_constr
- (not total) arg nonconsts in
+ (not total_loc) arg nonconsts in
test_int_or_block arg lam_const lam_nonconst
in
- if total then (lambda1, true)
- else (Lcatch(lambda1, lambda2), total2)
-
-let combine_orpat (lambda1, total1) (lambda2, total2) (lambda3, total3) =
- if total1 & total2 then
- (Lsequence(lambda1, lambda2), true)
- else
- (Lcatch(Lsequence(lambda1, lambda2), lambda3), total3)
+ add_catch (lambda1, total1 && total_loc) c_catch
-let combine_array kind arg (len_lambda_list, total1) (lambda2, total2) =
+let combine_array arg kind _ (len_lambda_list, total1) c_catch =
let lambda1 =
match len_lambda_list with
[] -> Lstaticfail (* does not happen? *)
@@ -506,8 +744,9 @@ let combine_array kind arg (len_lambda_list, total1) (lambda2, total2) =
List.fold_left (fun m (n, act) -> max m n) 0 len_lambda_list in
Lswitch(Lprim(Parraylength kind, [arg]),
{sw_numblocks = 0; sw_blocks = []; sw_checked = true;
- sw_numconsts = max_len + 1; sw_consts = len_lambda_list}) in
- (Lcatch(lambda1, lambda2), total2)
+ sw_numconsts = max_len + 1; sw_consts = len_lambda_list;
+ sw_nofail=false}) in
+ add_catch (lambda1,false) c_catch
(* Insertion of debugging events *)
@@ -523,123 +762,136 @@ let rec event_branch repr lam =
lev_env = ev.lev_env})
| (Llet(str, id, lam, body), _) ->
Llet(str, id, lam, event_branch repr body)
+ | Lstaticraise _,_ -> lam
| (_, Some r) ->
-(* incr r;
- Levent(lam, {lev_loc = -1;
- lev_kind = Lev_before;
- lev_repr = repr;
- lev_env = Env.Env_empty})
-*) fatal_error "Matching.event_branch"
+ Printlambda.lambda Format.str_formatter lam ;
+ fatal_error
+ ("Matching.event_branch: "^Format.flush_str_formatter ())
end
-(* The main compilation function.
- Input: a pattern matching.
- Output: a lambda term, a "total" flag (true if we're sure that the
- matching covers all cases; this is an approximation). *)
+(*
+ The main compilation function.
+ Input:
+ partial=exhaustiveness information from Parmatch
+ pm=a pattern matching
-let rec compile_match repr partial m =
+ Output: a lambda term, a "total" flag
+ (true if the lambda term does not raise ``exit'')
+*)
- let rec compile_list partial = function
+let rec compile_list compile_fun = function
[] -> ([], true)
| (key, pm) :: rem ->
- let (lambda1, total1) = compile_match repr partial pm in
- let (list2, total2) = compile_list partial rem in
- ((key, lambda1) :: list2, total1 & total2) in
-
- match m with
+ 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,m)::rem ->
+ let c_catch, c_others = c_rec rem in
+ (i, 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)
+
+
+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 } in
- (Lcatch(event_branch repr action, 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 } ->
+ | { args = (arg, str)::argl ; cases = (pat::_, _)::_ } ->
let v = name_pattern "match" m.cases in
let newarg = Lvar v in
let pm =
simplify_matching
{ cases = m.cases; args = (newarg, Alias) :: argl } in
let (lam, total) =
- match pm.cases with
- (pat :: patl, action) :: _ ->
- begin match pat.pat_desc with
- Tpat_any ->
- let (vars, others) = divide_var pm in
- let partial' =
- if others.cases = [] then partial else Partial in
- combine_var (compile_match repr partial' vars)
- (compile_match repr partial others)
- | Tpat_constant cst ->
- let (constants, others) = divide_constant pm in
- let partial' =
- if others.cases = [] then partial else Partial in
- combine_constant newarg cst
- (compile_list partial' constants)
- (compile_match repr partial others)
- | Tpat_tuple patl ->
- let (tuples, others) = divide_tuple (List.length patl) pm in
- let partial' =
- if others.cases = [] then partial else Partial in
- combine_var (compile_match repr partial' tuples)
- (compile_match repr partial others)
- | Tpat_construct(cstr, patl) ->
- let (constrs, others) = divide_constructor pm in
- let partial' =
- if others.cases = [] then partial else Partial in
- combine_constructor newarg cstr
- (compile_list partial' constrs)
- (compile_match repr partial others)
- | Tpat_variant(lab, _, row) ->
- let (constrs, others) = divide_variant row pm in
- let partial' =
- if others.cases = [] then partial else Partial in
- combine_variant row newarg partial'
- (compile_list partial' constrs)
- (compile_match repr partial others)
- | Tpat_record((lbl, _) :: _) ->
- let (records, others) = divide_record lbl.lbl_all pm in
- let partial' =
- if others.cases = [] then partial else Partial in
- combine_var (compile_match repr partial' records)
- (compile_match repr partial others)
- | Tpat_array(patl) ->
- let kind = Typeopt.array_pattern_kind pat in
- let (arrays, others) = divide_array kind pm in
- combine_array kind newarg
- (compile_list Partial arrays)
- (compile_match repr partial others)
- | Tpat_or(pat1, pat2) ->
- (* Avoid duplicating the code of the action *)
- let (or_match, remainder_line, others) = divide_orpat pm in
- let partial' =
- if others.cases = [] then partial else Partial in
- if partial' = Total then
- or_match.cases <- [[{ pat_desc = Tpat_any;
- pat_loc = pat.pat_loc;
- pat_type = pat.pat_type;
- pat_env = pat.pat_env }],
- lambda_unit];
- combine_orpat (compile_match None Partial or_match)
- (compile_match repr partial' remainder_line)
- (compile_match repr partial others)
- | _ ->
- fatal_error "Matching.compile_match1"
- end
- | _ -> fatal_error "Matching.compile_match2" in
- (bind str v arg lam, total)
+ do_compile_matching
+ repr partial newarg
+ (upper_left_pattern pm)
+ pm in
+ bind str v arg lam, total
| _ -> assert false
+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
+| _ ->
+ Location.prerr_warning pat.pat_loc (Warnings.Other "ICI") ;
+ 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 *)
-let compile_matching repr handler_fun arg pat_act_list partial =
+
+(*
+ Use the match-compiler infered exhaustiveness information,
+*)
+
+let check_total loc partial total lambda handler_fun =
+ if total then
+ lambda
+ else
+ Lcatch(lambda, handler_fun())
+
+let compile_matching loc repr handler_fun arg pat_act_list partial =
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
- if total then lambda else Lcatch(lambda, handler_fun())
+ check_total loc partial total lambda handler_fun
let partial_function loc () =
Lprim(Praise, [Lprim(Pmakeblock(0, Immutable),
@@ -650,14 +902,15 @@ let partial_function loc () =
Const_base(Const_int loc.loc_end)]))])])
let for_function loc repr param pat_act_list partial =
- compile_matching repr (partial_function loc) param pat_act_list partial
+ compile_matching loc repr (partial_function loc) param pat_act_list partial
+(* In the following two cases, exhaustiveness info is not available! *)
let for_trywith param pat_act_list =
- compile_matching None (fun () -> Lprim(Praise, [param]))
+ compile_matching Location.none None (fun () -> Lprim(Praise, [param]))
param pat_act_list Partial
let for_let loc param pat body =
- compile_matching None (partial_function loc) param [pat, body] Partial
+ compile_matching loc None (partial_function loc) param [pat, body] Partial
(* Handling of tupled functions and matches *)
@@ -679,7 +932,7 @@ let for_tupled_function loc paraml pats_act_list partial =
{ cases = pats_act_list;
args = List.map (fun id -> (Lvar id, Strict)) paraml } in
let (lambda, total) = compile_match None partial pm in
- if total then lambda else Lcatch(lambda, partial_function loc ())
+ check_total loc partial total lambda (partial_function loc)
let for_multiple_match loc paraml pat_act_list partial =
let pm1 =
@@ -693,9 +946,9 @@ let for_multiple_match loc paraml pat_act_list partial =
{ cases = flatten_cases (List.length paraml) pm2.cases;
args = List.map (fun id -> (Lvar id, Alias)) idl } in
let (lambda, total) = compile_match None partial pm3 in
- let lambda2 =
- if total then lambda else Lcatch(lambda, partial_function loc ()) in
+ let lambda2 = check_total loc partial total lambda (partial_function loc) in
List.fold_right2 (bind Strict) idl paraml lambda2
with Cannot_flatten ->
let (lambda, total) = compile_match None partial pm2 in
- if total then lambda else Lcatch(lambda, partial_function loc ())
+ check_total loc partial total lambda (partial_function loc)
+
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 2ab20f872..07dd4b264 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -230,13 +230,19 @@ let rec lam ppf = function
fprintf ppf "@[<hv 1>case tag %i:@ %a@]" n lam l)
sw.sw_blocks in
fprintf ppf
- "@[<1>(%s%a@ @[<v 0>%a@])@]"
- (if sw.sw_checked then "switch-checked " else "switch ")
+ "@[<1>(%s%s%a@ @[<v 0>%a@])@]"
+ (if sw.sw_checked then "switch-checked" else "switch")
+ (if sw.sw_nofail then "* " else " ")
lam larg switch sw
| Lstaticfail ->
fprintf ppf "exit"
+ | Lstaticraise i ->
+ fprintf ppf "exit(%d)" i
| Lcatch(lbody, lhandler) ->
fprintf ppf "@[<2>(catch@ %a@;<1 -1>with@ %a)@]" lam lbody lam lhandler
+ | Lstaticcatch(lbody, i, lhandler) ->
+ fprintf ppf "@[<2>(catch@ %a@;<1 -1>with(%d)@ %a)@]"
+ lam lbody i lam lhandler
| Ltrywith(lbody, param, lhandler) ->
fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]"
lam lbody Ident.print param lam lhandler
diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index 379fc813c..6dc12c245 100644
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -53,11 +53,13 @@ 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})
- | Lstaticfail ->
- Lstaticfail
+ 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)
+ | Lstaticcatch(e1, i, e2) ->
+ Lstaticcatch(eliminate_ref id e1, i, eliminate_ref id e2)
| Ltrywith(e1, v, e2) ->
Ltrywith(eliminate_ref id e1, v, eliminate_ref id e2)
| Lifthenelse(e1, e2, e3) ->
@@ -124,7 +126,9 @@ let simplify_lambda lam =
List.iter (fun (n, l) -> count l) sw.sw_consts;
List.iter (fun (n, l) -> count l) sw.sw_blocks
| Lstaticfail -> ()
+ | Lstaticraise _ -> ()
| Lcatch(l1, l2) -> count l1; count l2
+ | Lstaticcatch(l1, _, l2) -> count l1; count l2
| Ltrywith(l1, v, l2) -> count l1; count l2
| Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3
| Lsequence(l1, l2) -> count l1; count l2
@@ -182,14 +186,15 @@ let simplify_lambda lam =
Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
| Lprim(p, ll) -> Lprim(p, List.map simplif ll)
| Lswitch(l, sw) ->
- Lswitch(simplif l,
- {sw_numconsts = sw.sw_numconsts;
- sw_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts;
- sw_numblocks = sw.sw_numblocks;
- sw_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks;
- sw_checked = sw.sw_checked})
- | Lstaticfail -> Lstaticfail
+ 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
+ Lswitch
+ (new_l,{sw with sw_consts = new_consts ; sw_blocks = new_blocks})
+ | Lstaticfail as l -> l
+ | Lstaticraise _ as l -> l
| Lcatch(l1, l2) -> Lcatch(simplif l1, simplif l2)
+ | Lstaticcatch(l1, i, l2) -> Lstaticcatch(simplif l1, i, simplif l2)
| Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2)
| Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3)
| Lsequence(Lifused(v, l1), l2) ->
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index 76254ad86..eb8ce8af6 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -92,6 +92,11 @@ let record_arg p = match p.pat_desc with
(* Raise Not_found when pos is not present in arg *)
+let sort_fields args =
+ Sort.list
+ (fun (lbl1,_) (lbl2,_) -> lbl1.lbl_pos <= lbl2.lbl_pos)
+ args
+
let get_field pos arg =
let _,p = List.find (fun (lbl,_) -> pos = lbl.lbl_pos) arg in
p
@@ -105,14 +110,27 @@ let extract_fields omegas arg =
with Not_found -> omega)
omegas
+let records_args l1 l2 =
+ let l1 = sort_fields l1
+ and l2 = sort_fields l2 in
+ let rec combine r1 r2 l1 l2 = match l1,l2 with
+ | [],[] -> r1,r2
+ | [],(_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
+ | (_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
+ | (lbl1,p1)::rem1, (lbl2,p2)::rem2 ->
+ if lbl1.lbl_pos < lbl2.lbl_pos then
+ combine (p1::r1) (omega::r2) rem1 l2
+ else if lbl1.lbl_pos > lbl2.lbl_pos then
+ combine (omega::r1) (p2::r2) l1 rem2
+ else (* same label on both sides *)
+ combine (p1::r1) (p2::r2) rem1 rem2 in
+ combine [] [] l1 l2
+;;
+
let sort_record p = match p.pat_desc with
| Tpat_record args ->
make_pat
- (Tpat_record
- (Sort.list
- (fun (lbl1,_) (lbl2,_) ->
- lbl1.lbl_pos <= lbl2.lbl_pos)
- args))
+ (Tpat_record (sort_fields args))
p.pat_type p.pat_env
| _ -> p
@@ -377,21 +395,11 @@ let full_match tdefs force env = match env with
ok && List.mem_assoc tag fields)
true row.row_fields
end else
- if row.row_closed then
- List.for_all
- (fun (tag,f) ->
- Btype.row_field_repr f = Rabsent || List.mem_assoc tag fields)
- row.row_fields
- else begin
- List.iter
- (fun (tag,f) ->
- match Btype.row_field_repr f with
- | Reither(true, [], e) -> e := Some (Rpresent None)
- | Reither(false, [t], e) -> e := Some (Rpresent (Some t))
- | _ -> ())
- row.row_fields;
- false
- end
+ row.row_closed &&
+ List.for_all
+ (fun (tag,f) ->
+ Btype.row_field_repr f = Rabsent || List.mem_assoc tag fields)
+ row.row_fields
| ({pat_desc = Tpat_constant(Const_char _)},_) :: _ ->
List.length env = 256
| ({pat_desc = Tpat_constant(_)},_) :: _ -> false
@@ -666,11 +674,11 @@ let rec initial_matrix = function
let rec le_pat p q =
match (p.pat_desc, q.pat_desc) with
- (Tpat_var _ | Tpat_any), _ -> true
+ | 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 or le_pat p2 q
- | _, Tpat_or(q1,q2) -> le_pat p q1 & le_pat p q2
+ | 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) ->
c1.cstr_tag = c2.cstr_tag && le_pats ps qs
@@ -700,8 +708,35 @@ let get_mins ps =
else select_rec (p::r) ps in
select_rec [] (select_rec [] ps)
-
-
+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
+| (Tpat_any|Tpat_var _),_ -> true
+| _,(Tpat_any|Tpat_var _) -> true
+| Tpat_or (p1,p2),_ -> compat p1 q || compat p2 q
+| _,Tpat_or (q1,q2) -> compat p q1 || compat p q2
+| Tpat_constant c1, Tpat_constant c2 -> c1=c2
+| Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
+| Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) ->
+ c1.cstr_tag = c2.cstr_tag && compats ps1 ps2
+| Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
+ l1=l2 && compat p1 p2
+| Tpat_variant (l1,None,_), Tpat_variant(l2,None,_) -> l1 = l2
+| Tpat_variant (_, None, _), Tpat_variant (_,Some _, _) -> false
+| Tpat_variant (_, Some _, _), Tpat_variant (_, None, _) -> false
+| Tpat_record l1,Tpat_record l2 ->
+ let ps,qs = records_args l1 l2 in
+ compats ps qs
+| Tpat_array ps, Tpat_array qs ->
+ List.length ps = List.length qs &&
+ compats ps qs
+| _,_ -> assert false
+
+and compats ps qs = match ps,qs with
+| [], [] -> true
+| p::ps, q::qs -> compat p q && compats ps qs
+| _,_ -> assert false
+
(*************************************)
(* Values as patterns pretty printer *)
(*************************************)
@@ -805,63 +840,75 @@ let top_pretty ppf v =
(******************************)
-(* Exported functions *)
+(* Entry points *)
(* - Partial match *)
(* - Unused match case *)
(******************************)
let check_partial tdefs loc casel =
- let pss = get_mins (initial_matrix casel) in
- let r = match pss with
- | [] -> begin match casel with
- | [] -> Rnone
- | (p,_) :: _ -> Rsome [p]
- end
- | ps::_ -> satisfiable tdefs true pss (omega_list ps) in
- match r with
- | Rnone -> Total
- | Rok ->
- Location.prerr_warning loc (Warnings.Partial_match "");
- Partial
- | Rsome [v] ->
- let errmsg =
- try
- let buf = Buffer.create 16 in
- let fmt = formatter_of_buffer buf in
- top_pretty fmt v;
- Buffer.contents buf
- with _ ->
- "" in
- Location.prerr_warning loc (Warnings.Partial_match errmsg);
- Partial
- | _ ->
- fatal_error "Parmatch.check_partial"
+ if not (Warnings.is_active (Warnings.Partial_match "")) then
+ Partial
+ else
+ let pss = get_mins (initial_matrix casel) in
+ match pss with
+ | [] ->
+ (*
+ This can occur
+ - For empty matches generated by ocamlp4
+ - when all patterns have guards
+ Then match should be considered non-exhaustive
+ (cf. matching.ml) no warning is issued,
+ users should know what they do
+ *)
+ Partial
+ | ps::_ ->
+ match satisfiable tdefs true pss (omega_list ps) with
+ | Rnone -> Total
+ | Rok ->
+ Location.prerr_warning loc (Warnings.Partial_match "");
+ Partial
+ | Rsome [v] ->
+ let errmsg =
+ try
+ let buf = Buffer.create 16 in
+ let fmt = formatter_of_buffer buf in
+ top_pretty fmt v;
+ Buffer.contents buf
+ with _ ->
+ "" in
+ Location.prerr_warning loc (Warnings.Partial_match errmsg);
+ Partial
+ | _ ->
+ fatal_error "Parmatch.check_partial"
let location_of_clause = function
pat :: _ -> pat.pat_loc
| _ -> fatal_error "Parmatch.location_of_clause"
let check_unused tdefs casel =
- let prefs =
- List.fold_right
- (fun (pat,act as clause) r ->
- if has_guard act
- then ([], ([pat], act)) :: r
- else ([], ([pat], act)) ::
- List.map (fun (pss,clause) -> [pat]::pss,clause) r)
- casel [] in
- List.iter
- (fun (pss, ((qs, _) as clause)) ->
- try
- if
- (match satisfiable tdefs false pss qs with
- | Rnone -> true
- | Rok -> false
- | _ -> assert false)
- then
- Location.prerr_warning (location_of_clause qs) Warnings.Unused_match
- with e ->
- Location.prerr_warning (location_of_clause qs)
- (Warnings.Other "Fatal Error") ;
- raise e)
- prefs
+ if Warnings.is_active Warnings.Unused_match then begin
+ let prefs =
+ List.fold_right
+ (fun (pat,act as clause) r ->
+ if has_guard act
+ then ([], ([pat], act)) :: r
+ else ([], ([pat], act)) ::
+ List.map (fun (pss,clause) -> [pat]::pss,clause) r)
+ casel [] in
+ List.iter
+ (fun (pss, ((qs, _) as clause)) ->
+ try
+ if
+ (match satisfiable tdefs false pss qs with
+ | Rnone -> true
+ | Rok -> false
+ | _ -> assert false)
+ then
+ Location.prerr_warning
+ (location_of_clause qs) Warnings.Unused_match
+ with e ->
+ Location.prerr_warning (location_of_clause qs)
+ (Warnings.Other "Fatal Error") ;
+ raise e)
+ prefs
+ end
diff --git a/typing/parmatch.mli b/typing/parmatch.mli
index 157b91dae..cbec9892f 100644
--- a/typing/parmatch.mli
+++ b/typing/parmatch.mli
@@ -16,6 +16,12 @@
open Typedtree
+val omega_list : 'a list -> pattern list
+
+val compat : pattern -> pattern -> bool
+val compats : pattern list -> pattern list -> bool
+
val check_partial:
Env.t -> Location.t -> (pattern * expression) list -> partial
val check_unused: Env.t -> (pattern * expression) list -> unit
+
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-26 16:42:47 +0000