Patch for PR#5788

(Exception binding fools pattern matching optimisations)

Hopefully it's complete...





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

3 files changed, 181 insertions, 29 deletions

diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index b5ba51001..42e761a91 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -21,6 +21,8 @@ open Lambda
 open Parmatch
 open Printf
 
+let dbg = false
+
 (*  See Peyton-Jones, ``The Implementation of functional programming
     languages'', chapter 5. *)
 (*
@@ -161,11 +163,23 @@ 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)
+      begin match cstr.cstr_tag with
+      | Cstr_exception _ -> (* exception matching *)
+          let nargs = List.length omegas in
+          (fun q rem -> match q.pat_desc with
+          | Tpat_construct (_, cstr',args,_)
+            when List.length args = nargs ->
+                p,args @ rem
+          | Tpat_any -> p,omegas @ rem
+          | _ -> raise NoMatch)
+      | _ ->
+          (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)
+      end
   | Tpat_constant cst ->
       (fun q rem -> match q.pat_desc with
       | Tpat_constant cst' when const_compare cst cst' = 0 ->
@@ -412,6 +426,7 @@ let rec pretty_precompiled = function
   | PmOr x ->
       prerr_endline "++++ OR ++++" ;
       pretty_pm x.body ;
+      pretty_matrix x.or_matrix ;
       List.iter
         (fun (_,i,_,pm) ->
           eprintf "++ Handler %d ++\n" i ;
@@ -483,12 +498,35 @@ let up_ok_action act1 act2 =
   with
   | Not_simple -> false
 
+(* Nothing is kown about exeception patterns, because of potential rebind *)
+let rec exc_inside p = match p.pat_desc with
+  | Tpat_construct (_,{cstr_tag=Cstr_exception _},_,_) -> true
+  | Tpat_any|Tpat_constant _|Tpat_var _
+  | Tpat_construct (_,_,[],_)
+  | Tpat_variant (_,None,_)
+    -> false
+  | Tpat_construct (_,_,ps,_) 
+  | Tpat_tuple ps
+  | Tpat_array ps
+      -> exc_insides ps
+  | Tpat_variant (_, Some q,_)
+  | Tpat_alias (q,_,_)
+  | Tpat_lazy q
+    -> exc_inside q
+  | Tpat_record (lps,_) ->
+      List.exists (fun (_,_,p) -> exc_inside p) lps
+  | Tpat_or (p1,p2,_) -> exc_inside p1 || exc_inside p2
+
+and exc_insides ps = List.exists exc_inside ps
+
 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
+  if exc_insides ps then match l with [] -> true | _::_ -> false
+  else
+    List.for_all
+      (fun (qs,act_q) ->
+        up_ok_action act_p act_q ||
+        not (Parmatch.compats ps qs))
+      l
 
 
 (*
@@ -584,6 +622,16 @@ let rec what_is_cases cases = match cases with
 (* A few operation on default environments *)
 let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases)
 
+(* For exception matching, record no imformation in matrix *)
+let as_matrix_omega cases =
+  get_mins le_pats
+    (List.map
+       (fun (ps,_) ->
+         match ps with
+         | [] -> assert false
+         | _::ps -> omega::ps)
+       cases)
+
 let cons_default matrix raise_num default =
   match matrix with
   | [] -> default
@@ -658,13 +706,16 @@ let pm_free_variables {cases=cases} =
 
 
 (* Basic grouping predicates *)
+let pat_as_constr = function
+  | {pat_desc=Tpat_construct (_, cstr,_,_)} -> cstr
+  | _ -> fatal_error "Matching.pat_as_constr"
 
 let group_constant = function
   | {pat_desc= Tpat_constant _} -> true
   | _                           -> false
 
 and group_constructor = function
-  | {pat_desc = Tpat_construct _} -> true
+  | {pat_desc = Tpat_construct (_,_,_,_)} -> true
   | _ -> false
 
 and group_variant = function
@@ -847,10 +898,75 @@ let rec split_or argo cls args def =
 
   do_split [] [] [] cls
 
+(* Ultra-naive spliting, close to semantics,
+   used for exception, as potential rebind prevents any kind of
+   optimisation *)
+
+and split_naive cls args def k =
+
+  let rec split_exc cstr0 yes = function
+    | [] ->
+        let yes = List.rev yes in
+        { me = Pm {cases=yes; args=args; default=def;} ;
+          matrix = as_matrix_omega yes ;
+          top_default=def},
+        k
+    | (p::_,_ as cl)::rem ->
+        if group_constructor p then
+          let cstr = pat_as_constr p in
+          if cstr = cstr0 then split_exc cstr0 (cl::yes) rem
+          else
+            let yes = List.rev yes in
+            let {me=next ; matrix=matrix ; top_default=def}, nexts =
+              split_exc cstr [cl] rem in
+            let idef = next_raise_count () in
+            let def = cons_default matrix idef def in
+            { me = Pm {cases=yes; args=args; default=def} ;
+              matrix = as_matrix_omega yes ;
+              top_default = def; },
+            (idef,next)::nexts
+        else
+          let yes = List.rev yes in
+          let {me=next ; matrix=matrix ; top_default=def}, nexts =
+              split_noexc [cl] rem in
+            let idef = next_raise_count () in
+            let def = cons_default matrix idef def in
+            { me = Pm {cases=yes; args=args; default=def} ;
+              matrix = as_matrix_omega yes ;
+              top_default = def; },
+            (idef,next)::nexts
+    | _ -> assert false
+
+  and split_noexc yes = function
+    | [] -> precompile_var args (List.rev yes) def k
+    | (p::_,_ as cl)::rem ->
+        if group_constructor p then
+          let yes= List.rev yes in
+          let {me=next; matrix=matrix; top_default=def;},nexts =
+            split_exc (pat_as_constr p) [cl] rem in
+          let idef = next_raise_count () in
+          precompile_var
+            args yes
+            (cons_default matrix idef def)
+            ((idef,next)::nexts)
+        else split_noexc (cl::yes) rem
+    | _ -> assert false in
+
+  match cls with
+  | [] -> assert false
+  | (p::_,_ as cl)::rem ->
+      if group_constructor p then
+        split_exc (pat_as_constr p) [cl] rem
+      else 
+        split_noexc [cl] rem
+  | _ -> assert false
+
 and split_constr cls args def k =
   let ex_pat = what_is_cases cls in
   match ex_pat.pat_desc with
   | Tpat_any -> precompile_var args cls def k
+  | Tpat_construct (_,{cstr_tag=Cstr_exception _},_,_) ->
+      split_naive cls args def k
   | _ ->
 
       let group = get_group ex_pat in
@@ -956,12 +1072,21 @@ and dont_precompile_var args cls def k =
     matrix=as_matrix cls ;
     top_default=def},k
 
+and is_exc p = match p.pat_desc with
+| Tpat_or (p1,p2,_) -> is_exc p1 || is_exc p2
+| Tpat_alias (p,v,_) -> is_exc p
+| Tpat_construct (_,{cstr_tag = Cstr_exception _},_,_) -> true
+| _ -> false
+
 and precompile_or argo cls ors args def k = match ors with
 | [] -> split_constr cls args def k
 | _  ->
     let rec do_cases = function
       | ({pat_desc=Tpat_or _} as orp::patl, action)::rem ->
-          let others,rem = get_equiv orp rem in
+          let do_opt = not (is_exc orp) in
+          let others,rem =
+            if do_opt then get_equiv orp rem
+            else [],rem in
           let orpm =
             {cases =
               (patl, action)::
@@ -971,7 +1096,7 @@ and precompile_or argo cls ors args def k = match ors with
                   | _ -> assert false)
                 others ;
               args = (match args with _::r -> r | _ -> assert false) ;
-              default = default_compat orp def} in
+              default = default_compat (if do_opt then orp else omega) def} in
           let vars =
             IdentSet.elements
               (IdentSet.inter
@@ -984,17 +1109,19 @@ and precompile_or argo cls ors args def k = match ors with
             Lstaticraise
               (or_num, List.map (fun v -> Lvar v) vs) in
 
-          let body,handlers = do_cases rem in
+          let do_optrec,body,handlers = do_cases rem in
+          do_opt && do_optrec,
           explode_or_pat
             argo new_patl mk_new_action body vars [] orp,
-          (([[orp]], or_num, vars , orpm):: handlers)
+          let mat = if do_opt then [[orp]] else [[omega]] in
+          ((mat, or_num, vars , orpm):: handlers)
       | cl::rem ->
-          let new_ord,new_to_catch = do_cases rem in
-          cl::new_ord,new_to_catch
-      | [] -> [],[] in
+          let b,new_ord,new_to_catch = do_cases rem in
+          b,cl::new_ord,new_to_catch
+      | [] -> true,[],[] in
 
-    let end_body, handlers = do_cases ors in
-    let matrix = as_matrix (cls@ors)
+    let do_opt,end_body, handlers = do_cases ors in
+    let matrix = (if do_opt then as_matrix else as_matrix_omega) (cls@ors)
     and body = {cases=cls@end_body ; args=args ; default=def} in
     {me = PmOr {body=body ; handlers=handlers ; or_matrix=matrix} ;
       matrix=matrix ;
@@ -1003,13 +1130,12 @@ and precompile_or argo cls ors args def k = match ors with
 
 let split_precompile argo pm =
   let {me=next}, nexts = split_or argo pm.cases pm.args pm.default  in
-(*
-  if nexts <> [] || (match next with PmOr _ -> true | _ -> false) then begin
+  if dbg && (nexts <> [] || (match next with PmOr _ -> true | _ -> false))
+  then begin
     prerr_endline "** SPLIT **" ;
     pretty_pm pm ;
     pretty_precompiled_res  next nexts
   end ;
-*)
   next, nexts
 
 
@@ -1136,10 +1262,6 @@ let get_args_constr p rem = match p with
 | {pat_desc=Tpat_construct (_, _, args, _)} -> args @ rem
 | _ -> assert false
 
-let pat_as_constr = function
-  | {pat_desc=Tpat_construct (_, cstr,_,_)} -> cstr
-  | _ -> fatal_error "Matching.pat_as_constr"
-
 
 let matcher_constr cstr = match cstr.cstr_arity with
 | 0 ->
@@ -1920,6 +2042,11 @@ let mk_failaction_neg partial ctx def = match partial with
 
 (* Conforme a l'article et plus simple qu'avant *)
 and mk_failaction_pos partial seen ctx defs  =
+  if dbg then begin
+    prerr_endline "**POS**" ;
+    pretty_def defs ;
+    ()
+  end ;
   let rec scan_def env to_test defs = match to_test,defs with
   | ([],_)|(_,[]) ->
       List.fold_left
@@ -2385,8 +2512,6 @@ let arg_to_var arg cls = match arg with
    Output: a lambda term, a jump summary {..., exit number -> context, .. }
 *)
 
-let dbg = false
-
 let rec compile_match repr partial ctx m = match m with
 | { cases = [] } -> comp_exit ctx m
 | { cases = ([], action) :: rem } ->
diff --git a/testsuite/tests/basic/patmatch.ml b/testsuite/tests/basic/patmatch.ml
index fbb0870a1..b5977b24e 100644
--- a/testsuite/tests/basic/patmatch.ml
+++ b/testsuite/tests/basic/patmatch.ml
@@ -131,3 +131,28 @@ let () =
   printf "PR#5992=Ok\n"
 
 
+(* PR #5788, was giving wrong result 3 *)
+exception Foo
+exception Bar = Foo
+
+let test e b =
+  match e, b with
+  | Foo, true -> 1
+  | Bar, false -> 2
+  | _, _ -> 3
+
+let () =
+  let r = test Bar false in
+  if r = 2 then printf "PR#5788=Ok\n"
+
+let test e b =
+  match e, b with
+  | Bar, false -> 0
+  | (Foo|Bar), true -> 1
+  | Foo, false -> 2
+  | _, _ -> 3
+
+
+let () =
+  let r = test Foo false in
+  if r = 0 then printf "PR#5788=Ok\n"
diff --git a/testsuite/tests/basic/patmatch.reference b/testsuite/tests/basic/patmatch.reference
index 3cae3a361..069400b10 100644
--- a/testsuite/tests/basic/patmatch.reference
+++ b/testsuite/tests/basic/patmatch.reference
@@ -67,3 +67,5 @@ l([|1|]) = 2
 l([|2;3|]) = 5
 l([|4;5;6|]) = 15
 PR#5992=Ok
+PR#5788=Ok
+PR#5788=Ok