discard redundant cases in or-patterns

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@5771 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

typing/parmatch.ml

@@ -925,7 +925,7 @@ let rec exhaust variants tdefs pss n = match pss with
 | []    ->  Rsome (omegas n)
 | []::_ ->  Rnone
 | pss   ->
-    let q0 = discr_pat omega pss in     
+    let q0 = discr_pat omega pss in
     begin match filter_all q0 pss with
           (* first column of pss is made of variables only *)
       [] ->
@@ -1270,6 +1270,27 @@ let get_mins le ps =
         else select_rec (p::r) ps in
   select_rec [] (select_rec [] ps)
 
+let rec flatten_or_pat pat =
+  match pat.pat_desc with
+    Tpat_or (p1, p2, _) -> flatten_or_pat p1 @ flatten_or_pat p2
+  | Tpat_alias (p, _) -> flatten_or_pat p
+  | _ -> [pat]
+
+(* Remove redundant cases from or-patterns *)
+let rec simplify_or_pat pat =
+  match pat.pat_desc with
+    Tpat_or (p1, p2, e) ->
+      let pats = flatten_or_pat pat in
+      let pats = List.map simplify_or_pat pats in
+      let pats' = get_mins le_pat pats in
+      List.fold_left
+        (fun orpat p -> {pat with pat_desc = Tpat_or (orpat, p, e)})
+        (List.hd pats') (List.tl pats')
+  | pd ->
+      let pd' = map_pattern_desc simplify_or_pat pat.pat_desc in
+      if pd == pd' then pat
+      else {pat with pat_desc = pd'}
+
 
 (*
   lub p q is a pattern that matches all values matched by p and q
@@ -1454,7 +1475,8 @@ and look_variants = function
 
 let check_partial tdefs loc casel =
   let variant_inside = List.exists (fun (p,_) -> look_variant p) casel in
-  let pss = initial_matrix casel in    
+  let pss = initial_matrix casel in
+  let pss = List.map (List.map simplify_or_pat) pss in
   let pss = get_mins le_pats pss in
   match pss with
   | [] ->

typing/typecore.ml

@@ -543,24 +543,7 @@ let finalize_variant pat =
 
 let rec iter_pattern f p =
   f p;
-  match p.pat_desc with
-    Tpat_any | Tpat_var _ | Tpat_constant _ ->
-      ()
-  | Tpat_alias (p, _) ->
-      iter_pattern f p
-  | Tpat_tuple pl ->
-      List.iter (iter_pattern f) pl
-  | Tpat_construct (_, pl) ->
-      List.iter (iter_pattern f) pl
-  | Tpat_variant (_, p, _) ->
-      may (iter_pattern f) p
-  | Tpat_record fl ->
-      List.iter (fun (_, p) -> iter_pattern f p) fl
-  | Tpat_or (p, p', _) ->
-      iter_pattern f p;
-      iter_pattern f p'
-  | Tpat_array pl ->
-      List.iter (iter_pattern f) pl
+  iter_pattern_desc (iter_pattern f) p.pat_desc
 
 (* Generalization criterion for expressions *)
 

typing/typedtree.ml

@@ -150,25 +150,52 @@ and module_coercion =
 
 (* Auxiliary functions over the a.s.t. *)
 
+let iter_pattern_desc f = function
+  | Tpat_alias(p, id) -> f p
+  | Tpat_tuple patl -> List.iter f patl
+  | Tpat_construct(cstr, patl) -> List.iter f patl
+  | Tpat_variant(_, pat, _) -> may f pat
+  | Tpat_record lbl_pat_list ->
+      List.iter (fun (lbl, pat) -> f pat) lbl_pat_list
+  | Tpat_array patl -> List.iter f patl
+  | Tpat_or(p1, p2, _) -> f p1; f p2
+  | Tpat_any
+  | Tpat_var _
+  | Tpat_constant _ -> ()
+
+let map_pattern_desc f d =
+  match d with
+  | Tpat_alias (p1, id) ->
+      Tpat_alias (f p1, id)
+  | Tpat_tuple pats ->
+      Tpat_tuple (List.map f pats)
+  | Tpat_record lpats ->
+      Tpat_record (List.map (fun (l,p) -> l, f p) lpats)
+  | Tpat_construct (c,pats) ->
+      Tpat_construct (c, List.map f pats)
+  | Tpat_array pats ->
+      Tpat_array (List.map f pats)
+  | Tpat_variant (x1, Some p1, x2) ->
+      Tpat_variant (x1, Some (f p1), x2)
+  | Tpat_or (p1,p2,path) ->
+      Tpat_or (f p1, f p2, path)
+  | Tpat_var _
+  | Tpat_constant _
+  | Tpat_any
+  | Tpat_variant (_,None,_) -> d
+
 (* List the identifiers bound by a pattern or a let *)
 
 let idents = ref([]: Ident.t list)
 
 let rec bound_idents pat =
   match pat.pat_desc with
-    Tpat_any -> ()
   | Tpat_var id -> idents := id :: !idents
   | Tpat_alias(p, id) -> bound_idents p; idents := id :: !idents
-  | Tpat_constant cst -> ()
-  | Tpat_tuple patl -> List.iter bound_idents patl
-  | Tpat_construct(cstr, patl) -> List.iter bound_idents patl
-  | Tpat_variant(_, pat, _) -> may bound_idents pat
-  | Tpat_record lbl_pat_list ->
-      List.iter (fun (lbl, pat) -> bound_idents pat) lbl_pat_list
-  | Tpat_array patl -> List.iter bound_idents patl
   | Tpat_or(p1, _, _) ->
       (* Invariant : both arguments binds the same variables *)
       bound_idents p1
+  | d -> iter_pattern_desc bound_idents d
 
 let pat_bound_idents pat =
   idents := []; bound_idents pat; let res = !idents in idents := []; res
@@ -195,23 +222,5 @@ let rec alpha_pat env p = match p.pat_desc with
     with
     | Not_found -> new_p
     end
-| Tpat_tuple pats ->
-    {p with pat_desc =
-    Tpat_tuple (List.map (alpha_pat env) pats)}
-| Tpat_record lpats ->
-    {p with pat_desc =
-    Tpat_record (List.map (fun (l,p) -> l,alpha_pat env p) lpats)}
-| Tpat_construct (c,pats) ->
-    {p with pat_desc =
-    Tpat_construct (c,List.map (alpha_pat env) pats)}
-| Tpat_array pats ->
-    {p with pat_desc =
-    Tpat_array (List.map (alpha_pat env) pats)}
-| Tpat_variant (x1, Some p1, x2) ->
-    {p with pat_desc =
-    Tpat_variant (x1, Some (alpha_pat env p1), x2)}
-| Tpat_or (p1,p2,path) ->
-    {p with pat_desc =
-    Tpat_or (alpha_pat env p1, alpha_pat env p2, path)}
-| Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> p
-
+| d ->
+    {p with pat_desc = map_pattern_desc (alpha_pat env) d}

typing/typedtree.mli

@@ -151,6 +151,9 @@ and module_coercion =
 
 (* Auxiliary functions over the a.s.t. *)
 
+val iter_pattern_desc : (pattern -> unit) -> pattern_desc -> unit
+val map_pattern_desc : (pattern -> pattern) -> pattern_desc -> pattern_desc
+
 val let_bound_idents: (pattern * expression) list -> Ident.t list
 val rev_let_bound_idents: (pattern * expression) list -> Ident.t list