bug 355

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

bytecomp/matching.ml

@@ -277,6 +277,11 @@ let rec jumps_extract i = function
         let r,rem = jumps_extract i rem in
         r,(x::rem)
 
+let rec jumps_remove i = function
+  | [] -> []
+  | (j,_)::rem when i=j -> rem
+  | x::rem -> x::jumps_remove i rem 
+
 let jumps_empty = []
 and jumps_is_empty = function
   |  [] -> true
@@ -659,11 +664,11 @@ let pm_free_variables {cases=cases} =
 let compile_or argo cl clor al def = match clor with
 | [] ->
     {to_match = {cases=cl ; args=al ; default=def} ;
-    to_catch = []}
+      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 others,rem = get_equiv orp rem in          
           let orpm =
             {cases =
               (patl, action)::
@@ -672,8 +677,16 @@ let compile_or argo cl clor al def = match clor with
                   | (_::ps,action) -> ps,action
                   | _ -> assert false)
                 others ;
-             args = List.tl al ;
+              args = List.tl al ;
-             default = default_compat orp def} in
+              default = default_compat orp def} in
+          begin match patl,action with
+          | [],Lstaticraise (_,[]) ->
+              let new_ord,new_to_catch = do_cases rem in
+              let mk_new_action _ = action in
+              explode_or_pat
+                argo [] mk_new_action new_ord [] [] orp,
+              new_to_catch
+          | _,_ ->
           let vars =
             IdentSet.elements
               (IdentSet.inter
@@ -690,6 +703,7 @@ let compile_or argo cl clor al def = match clor with
           explode_or_pat
             argo new_patl mk_new_action new_ord vars [] orp,
           (([[orp]], or_num, vars , orpm):: new_to_catch)
+          end
       | cl::rem ->
           let new_ord,new_to_catch = do_cases rem in
           cl::new_ord,new_to_catch
@@ -697,7 +711,7 @@ let compile_or argo cl clor al def = match clor with
 
     let to_match,to_catch = do_cases clor in
     {to_match = {args=al ; cases=cl@to_match ; default=def} ;
-    to_catch = to_catch}
+      to_catch = to_catch}
 
 
 (* Basic grouping predicates *)
@@ -807,7 +821,6 @@ let separe argo pm =
   | [[{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,[]
@@ -865,13 +878,25 @@ let separe argo pm =
                   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
+                  begin match next with
-                  let newdef =
+                  (* Optimisation of jumps to jumps *)
-                    cons_default matrix idef next.to_match.default in
+                  | {to_match =
-                  as_matrix (yes@yesor),
+                      {cases=[ps,Lstaticraise (idef,[])]} ;
-                  compile_or argo yes yesor pm.args newdef,
+                      to_catch=[]}
-                  (idef,next)::nexts in
+                      when  List.for_all group_var ps ->
-
+                      let newdef =
+                        cons_default matrix idef next.to_match.default in
+                      as_matrix (yes@yesor),
+                      compile_or argo yes yesor pm.args newdef,
+                      (-1,next)::nexts
+                  | _ -> 
+                      let idef = next_raise_count () in
+                      let newdef =
+                        cons_default matrix idef next.to_match.default in
+                      as_matrix (yes@yesor),
+                      compile_or argo yes yesor pm.args newdef,
+                      (idef,next)::nexts
+                  end in
             match pm.cases with
             | ((_::_),_) as cl::rem ->
                 let _,next,nexts = sep_next cl rem in
@@ -1862,7 +1887,8 @@ let compile_orhandlers compile_fun lambda1 total1 ctx to_catch =
           | _ ->
               do_rec
                 (Lstaticcatch (r,(i,vars), handler_i))
-                (jumps_union total_r
+                (jumps_union
+                   (jumps_remove i total_r)
                    (jumps_map (ctx_rshift_num (ncols mat)) total_i))
               rem
         with
@@ -1947,6 +1973,8 @@ let comp_match_handlers comp_fun partial ctx arg first_match next_matchs =
   | rem ->
       let rec c_rec body total_body = function
         | [] -> body, total_body
+        (* Hum, -1 means never taken, needed for ``partial'' to be correct *)
+        | (-1,pm)::rem -> c_rec body total_body rem
         | (i,pm)::rem -> 
             let ctx_i,total_rem = jumps_extract i total_body in
             begin match ctx_i with

bytecomp/switch.ml

@@ -89,6 +89,7 @@ module Make (Arg : S) =
 type 'a t_ctx =  {off : int ; arg : 'a}
 
 let cut = ref 8
+and more_cut = ref 16
 
 let pint chan i =
   if i = min_int then Printf.fprintf chan "-oo"
@@ -121,8 +122,8 @@ type ctests = {
 
 let too_much = {n=max_int ; ni=max_int}
 
-let ptests chan {n=n ; ni=ni } =
+let ptests chan {n=n ; ni=ni} =
-  Printf.fprintf chan "{n=%d ; ni=%d }" n ni
+  Printf.fprintf chan "{n=%d ; ni=%d}" n ni
 
 let pta chan t =
   for i =0 to Array.length t-1 do
@@ -157,8 +158,7 @@ let less_tests c1 c2 =
   end else
     false
 
-and eq_tests c1 c2 =
+and eq_tests c1 c2 = c1.n = c2.n && c1.ni=c2.ni
-  c1.n = c2.n && c1.ni=c2.ni
 
 let min_tests c1 c2 = if less_tests c1 c2 then c1 else c2
 
@@ -318,42 +318,49 @@ let same_act t =
 
 
   
-let rec opt_count top cases =
+    let rec opt_count top cases =
-  let key = make_key cases in
+      let key = make_key cases in
-  try
+      try
-    let r = Hashtbl.find t key in
+        let r = Hashtbl.find t key in
-    r
+        r
-  with
+      with
-  | Not_found ->
+      | Not_found ->
-      let r =
+          let r =
-        let lcases = Array.length cases in
+            let lcases = Array.length cases in
-        match lcases with
+            match lcases with
-        | 0 -> assert false
+            | 0 -> assert false
-        | _ when same_act cases -> No, ({n=0; ni=0},{n=0; ni=0})
+            | _ when same_act cases -> No, ({n=0; ni=0},{n=0; ni=0})
-        | _ ->
+            | _ ->
-            if lcases < !cut then
+                if lcases < !cut then
-              enum top cases
+                  enum top cases
-            else
+                else if lcases < !more_cut then
-              heuristic top cases in
+                  heuristic top cases
-      Hashtbl.add t key r ;
+                else
-      r
+                  divide top cases in
+          Hashtbl.add t key r ;
+          r
+
+and divide top cases =
+  let lcases = Array.length cases in
+  let m = lcases/2 in
+  let _,left,right = coupe cases m in
+  let ci = {n=1 ; ni=0}
+  and cm = {n=1 ; ni=0}
+  and _,(cml,cleft) = opt_count false left
+  and _,(cmr,cright) = opt_count false right in
+  add_test ci cleft ;
+  add_test ci cright ;
+  if less_tests cml cmr then
+    add_test cm cmr
+  else
+    add_test cm cml ;
+  Sep m,(cm, ci)
 
 and heuristic top cases =
   let lcases = Array.length cases in
-  let m = lcases/2 in
+
-  let lim,left,right = coupe cases m in
+  let sep,csep = divide false cases
-  let sep,csep =
+
-    let ci = {n=1 ; ni=0}
-    and cm = {n=1 ; ni=0}
-    and _,(cml,cleft) = opt_count false left
-    and _,(cmr,cright) = opt_count false right in
-    add_test ci cleft ;
-    add_test ci cright ;
-    if less_tests cml cmr then
-      add_test cm cmr
-    else
-      add_test cm cml ;
-    Sep m,(cm, ci)
   and inter,cinter =
     let _,_,act0 = cases.(0)
     and _,_,act1 = cases.(lcases-1) in
@@ -378,66 +385,66 @@ and heuristic top cases =
     inter,cinter
 
 
-  and enum top cases =
+and enum top cases =
-    let lcases = Array.length cases in
+  let lcases = Array.length cases in
-    let lim, with_sep =
+  let lim, with_sep =
-      let best = ref (-1) and best_cost = ref (too_much,too_much) in
+    let best = ref (-1) and best_cost = ref (too_much,too_much) in
 
-      for i = 1 to lcases-(1) do
+    for i = 1 to lcases-(1) do
-        let lim,left,right = coupe cases i in
+      let _,left,right = coupe cases i in
-        let ci = {n=1 ; ni=0}
+      let ci = {n=1 ; ni=0}
-        and cm = {n=1 ; ni=0}
+      and cm = {n=1 ; ni=0}
-        and _,(cml,cleft) = opt_count false left
+      and _,(cml,cleft) = opt_count false left
-        and _,(cmr,cright) = opt_count false right in
+      and _,(cmr,cright) = opt_count false right in
-        add_test ci cleft ;
+      add_test ci cleft ;
-        add_test ci cright ;
+      add_test ci cright ;
-        if less_tests cml cmr then
+      if less_tests cml cmr then
-          add_test cm cmr
+        add_test cm cmr
-        else
-          add_test cm cml ;
-        
-        if
-          less2tests (cm,ci) !best_cost
-        then begin
-          if top then
-            Printf.fprintf stderr "Get it: %d\n" i ;
-          best := i ;
-          best_cost := (cm,ci)
-        end
-      done ;
-      !best, !best_cost in
-    let ilow, ihigh, with_inter =
-      if lcases <= 2 then
-        -1,-1,(too_much,too_much)
       else
-        let rlow = ref (-1) and rhigh = ref (-1)
+        add_test cm cml ;
-        and best_cost= ref (too_much,too_much) in
+      
-        for i=1 to lcases-2 do
+      if
-          for j=i to lcases-2 do
+        less2tests (cm,ci) !best_cost
-            let low, high, inside, outside = coupe_inter i j cases in
+      then begin
-            let _,(cmi,cinside) = opt_count false inside
+        if top then
-            and _,(cmo,coutside) = opt_count false outside
+          Printf.fprintf stderr "Get it: %d\n" i ;
-            and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
+        best := i ;
-            and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
+        best_cost := (cm,ci)
-            add_test cij cinside ;
+      end
-            add_test cij coutside ;
+    done ;
-            if less_tests cmi cmo then
+    !best, !best_cost in
-              add_test cmij cmo
+  let ilow, ihigh, with_inter =
-            else
+    if lcases <= 2 then
-              add_test cmij cmi ;
+      -1,-1,(too_much,too_much)
-            if less2tests (cmij,cij) !best_cost then begin
+    else
-              rlow := i ;
+      let rlow = ref (-1) and rhigh = ref (-1)
-              rhigh := j ;
+      and best_cost= ref (too_much,too_much) in
-              best_cost := (cmij,cij)
+      for i=1 to lcases-2 do
-            end
+        for j=i to lcases-2 do
-          done
+          let low, high, inside, outside = coupe_inter i j cases in
-        done ;
+          let _,(cmi,cinside) = opt_count false inside
-        !rlow, !rhigh, !best_cost in
+          and _,(cmo,coutside) = opt_count false outside
-    let r = ref (Inter (ilow,ihigh)) and rc = ref with_inter in
+          and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
-    if less2tests with_sep !rc then begin
+          and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
-      r := Sep lim ; rc := with_sep
+          add_test cij cinside ;
-    end ;
+          add_test cij coutside ;
-    !r, !rc
+          if less_tests cmi cmo then
+            add_test cmij cmo
+          else
+            add_test cmij cmi ;
+          if less2tests (cmij,cij) !best_cost then begin
+            rlow := i ;
+            rhigh := j ;
+            best_cost := (cmij,cij)
+          end
+        done
+      done ;
+      !rlow, !rhigh, !best_cost in
+  let r = ref (Inter (ilow,ihigh)) and rc = ref with_inter in
+  if less2tests with_sep !rc then begin
+    r := Sep lim ; rc := with_sep
+  end ;
+  !r, !rc
 
 let make_if_test konst test arg i ifso ifnot =
   Arg.make_if
@@ -593,14 +600,22 @@ let particular_case cases i j =
   l1+1=l2 && l2+1=l3 && l3=h3 &&
   act1 <> act3)
 
+let approx_count cases i j n_actions =
+  let l = j-i+1 in
+  if l < !cut then
+     let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in
+     ntests
+  else
+    l-1
+
 (* Sends back a boolean that says whether is switch is worth or not *)
+
 let dense ({cases=cases ; actions=actions} as s) i j =
   if i=j then true
   else
     let l,_,_ = cases.(i)
     and _,h,_ = cases.(j) in
-    let _,(_,{n=ntests}) =
+    let ntests =  approx_count cases i j (Array.length actions) in
-      opt_count false (Array.sub cases i (j-i+1)) in
 (*
   (ntests+1) >= theta * (h-l+1)
 *)
@@ -615,7 +630,6 @@ let dense ({cases=cases ; actions=actions} as s) i j =
    S.K. Kannan and T.A. Proebsting
    Software Practice and Exprience Vol. 24(2) 233 (Feb 1994)
 *)
-   
 
 let comp_clusters ({cases=cases ; actions=actions} as s) =
   let len = Array.length cases in
@@ -632,7 +646,7 @@ let comp_clusters ({cases=cases ; actions=actions} as s) =
         k.(i) <- j ;
         min_clusters.(i) <- get_min (j-1) + 1             
       end
-    done
+    done ;
   done ;
   min_clusters.(len-1),k
 

test/Moretest/morematch.ml

@@ -741,3 +741,214 @@ test "escaped" escaped '!' 1 ;
 test "escaped" escaped '#' 1 ;
 ()
 ;;
+
+(* For compilation speed (due to J. Garigue) *)
+exception Unknown_Reply of int
+
+type command_reply =
+   RPL_TRYAGAIN
+ | RPL_TRACEEND
+ | RPL_TRACELOG
+ | RPL_ADMINEMAIL
+ | RPL_ADMINLOC2
+ | RPL_ADMINLOC1
+ | RPL_ADMINME
+ | RPL_LUSERME
+ | RPL_LUSERCHANNELS
+ | RPL_LUSERUNKNOWN
+ | RPL_LUSEROP
+ | RPL_LUSERCLIENT
+ | RPL_STATSDLINE
+ | RPL_STATSDEBUG
+ | RPL_STATSDEFINE
+ | RPL_STATSBLINE
+ | RPL_STATSPING
+ | RPL_STATSSLINE
+ | RPL_STATSHLINE
+ | RPL_STATSOLINE
+ | RPL_STATSUPTIME
+ | RPL_STATSLLINE
+ | RPL_STATSVLINE
+ | RPL_SERVLISTEND
+ | RPL_SERVLIST
+ | RPL_SERVICE
+ | RPL_ENDOFSERVICES
+ | RPL_SERVICEINFO
+ | RPL_UMODEIS
+ | RPL_ENDOFSTATS
+ | RPL_STATSYLINE
+ | RPL_STATSQLINE
+ | RPL_STATSKLINE
+ | RPL_STATSILINE
+ | RPL_STATSNLINE
+ | RPL_STATSCLINE
+ | RPL_STATSCOMMANDS
+ | RPL_STATSLINKINFO
+ | RPL_TRACERECONNECT
+ | RPL_TRACECLASS
+ | RPL_TRACENEWTYPE
+ | RPL_TRACESERVICE
+ | RPL_TRACESERVER
+ | RPL_TRACEUSER
+ | RPL_TRACEOPERATOR
+ | RPL_TRACEUNKNOWN
+ | RPL_TRACEHANDSHAKE
+ | RPL_TRACECONNECTING
+ | RPL_TRACELINK
+ | RPL_NOUSERS
+ | RPL_ENDOFUSERS
+ | RPL_USERS
+ | RPL_USERSSTART
+ | RPL_TIME
+ | RPL_NOTOPERANYMORE
+ | RPL_MYPORTIS
+ | RPL_YOURESERVICE
+ | RPL_REHASHING
+ | RPL_YOUREOPER
+ | RPL_ENDOFMOTD
+ | RPL_MOTDSTART
+ | RPL_ENDOFINFO
+ | RPL_INFOSTART
+ | RPL_MOTD
+ | RPL_INFO
+ | RPL_ENDOFBANLIST
+ | RPL_BANLIST
+ | RPL_ENDOFLINKS
+ | RPL_LINKS
+ | RPL_CLOSEEND
+ | RPL_CLOSING
+ | RPL_KILLDONE
+ | RPL_ENDOFNAMES
+ | RPL_NAMREPLY
+ | RPL_ENDOFWHO
+ | RPL_WHOREPLY
+ | RPL_VERSION
+ | RPL_SUMMONING
+ | RPL_INVITING
+ | RPL_TOPIC
+ | RPL_NOTOPIC
+ | RPL_CHANNELMODEIS
+ | RPL_LISTEND
+ | RPL_LIST
+ | RPL_LISTSTART
+ | RPL_WHOISCHANNELS
+ | RPL_ENDOFWHOIS
+ | RPL_WHOISIDLE
+ | RPL_WHOISCHANOP
+ | RPL_ENDOFWHOWAS
+ | RPL_WHOWASUSER
+ | RPL_WHOISOPERATOR
+ | RPL_WHOISSERVER
+ | RPL_WHOISUSER
+ | RPL_NOWAWAY
+ | RPL_UNAWAY
+ | RPL_TEXT
+ | RPL_ISON
+ | RPL_USERHOST
+ | RPL_AWAY
+ | RPL_NONE
+
+let get_command_reply n =
+match n with
+   263	->	 RPL_TRYAGAIN
+ | 319	->	 RPL_WHOISCHANNELS
+ | 318	->	 RPL_ENDOFWHOIS
+ | 317	->	 RPL_WHOISIDLE
+ | 316	->	 RPL_WHOISCHANOP
+ | 369	->	 RPL_ENDOFWHOWAS
+ | 314	->	 RPL_WHOWASUSER
+ | 313	->	 RPL_WHOISOPERATOR
+ | 312	->	 RPL_WHOISSERVER
+ | 311	->	 RPL_WHOISUSER
+ | 262	->	 RPL_TRACEEND
+ | 261	->	 RPL_TRACELOG
+ | 259	->	 RPL_ADMINEMAIL
+ | 258	->	 RPL_ADMINLOC2
+ | 257	->	 RPL_ADMINLOC1
+ | 256	->	 RPL_ADMINME
+ | 255	->	 RPL_LUSERME
+ | 254	->	 RPL_LUSERCHANNELS
+ | 253	->	 RPL_LUSERUNKNOWN
+ | 252	->	 RPL_LUSEROP
+ | 251	->	 RPL_LUSERCLIENT
+ | 250	->	 RPL_STATSDLINE
+ | 249	->	 RPL_STATSDEBUG
+ | 248	->	 RPL_STATSDEFINE
+ | 247	->	 RPL_STATSBLINE
+ | 246	->	 RPL_STATSPING
+ | 245	->	 RPL_STATSSLINE
+ | 244	->	 RPL_STATSHLINE
+ | 243	->	 RPL_STATSOLINE
+ | 242	->	 RPL_STATSUPTIME
+ | 241	->	 RPL_STATSLLINE
+ | 240	->	 RPL_STATSVLINE
+ | 235	->	 RPL_SERVLISTEND
+ | 234	->	 RPL_SERVLIST
+ | 233	->	 RPL_SERVICE
+ | 232	->	 RPL_ENDOFSERVICES
+ | 231	->	 RPL_SERVICEINFO
+ | 221	->	 RPL_UMODEIS
+ | 219	->	 RPL_ENDOFSTATS
+ | 218	->	 RPL_STATSYLINE
+ | 217	->	 RPL_STATSQLINE
+ | 216	->	 RPL_STATSKLINE
+ | 215	->	 RPL_STATSILINE
+ | 214	->	 RPL_STATSNLINE
+ | 213	->	 RPL_STATSCLINE
+ | 212	->	 RPL_STATSCOMMANDS
+ | 211	->	 RPL_STATSLINKINFO
+ | 210	->	 RPL_TRACERECONNECT
+ | 209	->	 RPL_TRACECLASS
+ | 208	->	 RPL_TRACENEWTYPE
+ | 207	->	 RPL_TRACESERVICE
+ | 206	->	 RPL_TRACESERVER
+ | 205	->	 RPL_TRACEUSER
+ | 204	->	 RPL_TRACEOPERATOR
+ | 203	->	 RPL_TRACEUNKNOWN
+ | 202	->	 RPL_TRACEHANDSHAKE
+ | 201	->	 RPL_TRACECONNECTING
+ | 200	->	 RPL_TRACELINK
+ | 395	->	 RPL_NOUSERS
+ | 394	->	 RPL_ENDOFUSERS
+ | 393	->	 RPL_USERS
+ | 392	->	 RPL_USERSSTART
+ | 391	->	 RPL_TIME
+ | 385	->	 RPL_NOTOPERANYMORE
+ | 384	->	 RPL_MYPORTIS
+ | 383	->	 RPL_YOURESERVICE
+ | 382	->	 RPL_REHASHING
+ | 381	->	 RPL_YOUREOPER
+ | 376	->	 RPL_ENDOFMOTD
+ | 375	->	 RPL_MOTDSTART
+ | 374	->	 RPL_ENDOFINFO
+ | 373	->	 RPL_INFOSTART
+ | 372	->	 RPL_MOTD
+ | 371	->	 RPL_INFO
+ | 368	->	 RPL_ENDOFBANLIST
+ | 367	->	 RPL_BANLIST
+ | 365	->	 RPL_ENDOFLINKS
+ | 364	->	 RPL_LINKS
+ | 363	->	 RPL_CLOSEEND
+ | 362	->	 RPL_CLOSING
+ | 361	->	 RPL_KILLDONE
+ | 366	->	 RPL_ENDOFNAMES
+ | 353	->	 RPL_NAMREPLY
+ | 315	->	 RPL_ENDOFWHO
+ | 352	->	 RPL_WHOREPLY
+ | 351	->	 RPL_VERSION
+ | 342	->	 RPL_SUMMONING
+ | 341	->	 RPL_INVITING
+ | 332	->	 RPL_TOPIC
+ | 331	->	 RPL_NOTOPIC
+ | 324	->	 RPL_CHANNELMODEIS
+ | 323	->	 RPL_LISTEND
+ | 322	->	 RPL_LIST
+ | 321	->	 RPL_LISTSTART
+ | 306	->	 RPL_NOWAWAY
+ | 305	->	 RPL_UNAWAY
+ | 304	->	 RPL_TEXT
+ | 303	->	 RPL_ISON
+ | 302	->	 RPL_USERHOST
+ | 301	->	 RPL_AWAY
+ | 300	->	 RPL_NONE
+ | _ -> raise (Unknown_Reply n)