Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

bug 355 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3507 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Luc Maranget 2001-05-11 18:00:00 +00:00
parent 62cf939f0d
commit 2876eb2bc2
3 changed files with 366 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
bytecomp/matching.ml
View File

@ -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

212
bytecomp/switch.ml
View File

@ -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

211
test/Moretest/morematch.ml
View File

@ -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)