From 2876eb2bc2335999b7a9f2150085e244b395cb9e Mon Sep 17 00:00:00 2001 From: Luc Maranget Date: Fri, 11 May 2001 18:00:00 +0000 Subject: [PATCH] bug 355 git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3507 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- bytecomp/matching.ml | 56 +++++++--- bytecomp/switch.ml | 212 ++++++++++++++++++++----------------- test/Moretest/morematch.ml | 211 ++++++++++++++++++++++++++++++++++++ 3 files changed, 366 insertions(+), 113 deletions(-) diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 145226897..27b15c6bb 100644 --- a/bytecomp/matching.ml +++ b/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 ; - default = default_compat orp def} in + args = List.tl al ; + 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 - 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 - + begin match next with + (* Optimisation of jumps to jumps *) + | {to_match = + {cases=[ps,Lstaticraise (idef,[])]} ; + to_catch=[]} + 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 diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml index 63d3f8008..7d500c08b 100644 --- a/bytecomp/switch.ml +++ b/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 } = - Printf.fprintf chan "{n=%d ; ni=%d }" n ni +let ptests chan {n=n ; ni=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 = - c1.n = c2.n && c1.ni=c2.ni +and eq_tests c1 c2 = 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 key = make_key cases in - try - let r = Hashtbl.find t key in - r - with - | Not_found -> - let r = - let lcases = Array.length cases in - match lcases with - | 0 -> assert false - | _ when same_act cases -> No, ({n=0; ni=0},{n=0; ni=0}) - | _ -> - if lcases < !cut then - enum top cases - else - heuristic top cases in - Hashtbl.add t key r ; - r + let rec opt_count top cases = + let key = make_key cases in + try + let r = Hashtbl.find t key in + r + with + | Not_found -> + let r = + let lcases = Array.length cases in + match lcases with + | 0 -> assert false + | _ when same_act cases -> No, ({n=0; ni=0},{n=0; ni=0}) + | _ -> + if lcases < !cut then + enum top cases + else if lcases < !more_cut then + heuristic top cases + else + 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 = - 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) + + let sep,csep = divide false cases + 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 = - let lcases = Array.length cases in - let lim, with_sep = - let best = ref (-1) and best_cost = ref (too_much,too_much) in +and enum top cases = + let lcases = Array.length cases in + let lim, with_sep = + let best = ref (-1) and best_cost = ref (too_much,too_much) in - for i = 1 to lcases-(1) do - let lim,left,right = coupe cases i 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 ; - - 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) + for i = 1 to lcases-(1) do + let _,left,right = coupe cases i 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 - let rlow = ref (-1) and rhigh = ref (-1) - and best_cost= ref (too_much,too_much) in - for i=1 to lcases-2 do - for j=i to lcases-2 do - let low, high, inside, outside = coupe_inter i j cases in - let _,(cmi,cinside) = opt_count false inside - and _,(cmo,coutside) = opt_count false outside - and cmij = {n=1 ; ni=(if low=high then 0 else 1)} - and cij = {n=1 ; ni=(if low=high then 0 else 1)} in - add_test cij cinside ; - add_test cij coutside ; - 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 + 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) + and best_cost= ref (too_much,too_much) in + for i=1 to lcases-2 do + for j=i to lcases-2 do + let low, high, inside, outside = coupe_inter i j cases in + let _,(cmi,cinside) = opt_count false inside + and _,(cmo,coutside) = opt_count false outside + and cmij = {n=1 ; ni=(if low=high then 0 else 1)} + and cij = {n=1 ; ni=(if low=high then 0 else 1)} in + add_test cij cinside ; + add_test cij coutside ; + 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}) = - opt_count false (Array.sub cases i (j-i+1)) in + let ntests = approx_count cases i j (Array.length actions) 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 diff --git a/test/Moretest/morematch.ml b/test/Moretest/morematch.ml index e27834aa5..7408aba48 100644 --- a/test/Moretest/morematch.ml +++ b/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)