l4/pkg/ocaml/contrib/bytecomp/switch.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Luc Maranget, projet Moscova, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 2000 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* Store for actions in object style *)
  14 exception Found of int
  15
  16 type 'a t_store =
  17     {act_get : unit -> 'a array ; act_store : 'a -> int}
  18
  19 let mk_store same =
  20   let r_acts = ref [] in
  21   let store act =
  22     let rec store_rec i = function
  23       | [] -> i,[act]
  24       | act0::rem ->
  25           if same act0 act then raise (Found i)
  26           else
  27             let i,rem = store_rec (i+1) rem in
  28             i,act0::rem in
  29     try
  30       let i,acts = store_rec 0 !r_acts in
  31       r_acts := acts ;
  32       i
  33     with
  34     | Found i -> i
  35
  36   and get () = Array.of_list !r_acts in
  37   {act_store=store ; act_get=get}
  38
  39
  40
  41 module type S =
  42  sig
  43    type primitive
  44    val eqint : primitive
  45    val neint : primitive
  46    val leint : primitive
  47    val ltint : primitive
  48    val geint : primitive
  49    val gtint : primitive
  50    type act
  51
  52    val bind : act -> (act -> act) -> act
  53    val make_offset : act -> int -> act
  54    val make_prim : primitive -> act list -> act
  55    val make_isout : act -> act -> act
  56    val make_isin : act -> act -> act
  57    val make_if : act -> act -> act -> act
  58    val make_switch :
  59       act -> int array -> act array -> act
  60  end
  61
  62 (* The module will ``produce good code for the case statement'' *)
  63 (*
  64   Adaptation of
  65    R.L. Berstein
  66    ``Producing good code for the case statement''
  67    Sofware Practice and Experience, 15(10) (1985)
  68  and
  69    D.L. Spuler
  70     ``Two-Way Comparison Search Trees, a Generalisation of Binary Search Trees
  71       and Split Trees''
  72     ``Compiler Code Generation for Multiway Branch Statement as
  73       a Static Search Problem''
  74    Technical Reports, James Cook University
  75 *)
  76 (*
  77   Main adaptation is considering interval tests
  78  (implemented as one addition + one unsigned test and branch)
  79   which leads to exhaustive search for finding the optimal
  80   test sequence in small cases and heuristics otherwise.
  81 *)
  82 module Make (Arg : S) =
  83   struct
  84
  85     type 'a inter =
  86         {cases : (int * int * int) array ;
  87           actions : 'a array}
  88
  89 type 'a t_ctx =  {off : int ; arg : 'a}
  90
  91 let cut = ref 8
  92 and more_cut = ref 16
  93
  94 let pint chan i =
  95   if i = min_int then Printf.fprintf chan "-oo"
  96   else if i=max_int then Printf.fprintf chan "oo"
  97   else Printf.fprintf chan "%d" i
  98
  99 let pcases chan cases =
 100   for i =0 to Array.length cases-1 do
 101     let l,h,act = cases.(i) in
 102     if l=h then
 103       Printf.fprintf chan "%d:%d " l act
 104     else
 105       Printf.fprintf chan "%a..%a:%d " pint l pint h act
 106   done
 107
 108     let prerr_inter i = Printf.fprintf stderr
 109         "cases=%a" pcases i.cases
 110
 111 let get_act cases i =
 112   let _,_,r = cases.(i) in
 113   r
 114 and get_low cases i =
 115   let r,_,_ = cases.(i) in
 116   r
 117
 118 type ctests = {
 119     mutable n : int ;
 120     mutable ni : int ;
 121   }
 122
 123 let too_much = {n=max_int ; ni=max_int}
 124
 125 let ptests chan {n=n ; ni=ni} =
 126   Printf.fprintf chan "{n=%d ; ni=%d}" n ni
 127
 128 let pta chan t =
 129   for i =0 to Array.length t-1 do
 130     Printf.fprintf chan "%d: %a\n" i ptests t.(i)
 131   done
 132
 133 let count_tests s =
 134   let r =
 135     Array.init
 136       (Array.length s.actions)
 137       (fun _ -> {n=0 ; ni=0 }) in
 138   let c = s.cases in
 139   let imax = Array.length c-1 in
 140   for i=0 to imax do
 141     let l,h,act = c.(i) in
 142     let x = r.(act) in
 143     x.n <- x.n+1 ;
 144     if l < h && i<> 0 && i<>imax then
 145       x.ni <- x.ni+1 ;
 146   done ;
 147   r
 148
 149
 150 let less_tests c1 c2 =
 151   if c1.n < c2.n then
 152     true
 153   else if c1.n = c2.n then begin
 154     if c1.ni < c2.ni then
 155       true
 156     else
 157       false
 158   end else
 159     false
 160
 161 and eq_tests c1 c2 = c1.n = c2.n && c1.ni=c2.ni
 162
 163 let min_tests c1 c2 = if less_tests c1 c2 then c1 else c2
 164
 165 let less2tests (c1,d1) (c2,d2) =
 166   if eq_tests c1 c2 then
 167     less_tests d1 d2
 168   else
 169     less_tests c1 c2
 170
 171 let add_test t1 t2 =
 172   t1.n <- t1.n + t2.n ;
 173   t1.ni <- t1.ni + t2.ni ;
 174
 175 type t_ret = Inter of int * int  | Sep of int | No
 176
 177 let pret chan = function
 178   | Inter (i,j)-> Printf.fprintf chan "Inter %d %d" i j
 179   | Sep i -> Printf.fprintf chan "Sep %d" i
 180   | No -> Printf.fprintf chan "No"
 181
 182 let coupe cases i =
 183   let l,_,_ = cases.(i) in
 184   l,
 185   Array.sub cases 0 i,
 186   Array.sub cases i (Array.length cases-i)
 187
 188
 189 let case_append c1 c2 =
 190   let len1 = Array.length c1
 191   and len2 = Array.length c2 in
 192   match len1,len2 with
 193   | 0,_ -> c2
 194   | _,0 -> c1
 195   | _,_ ->
 196       let l1,h1,act1 = c1.(Array.length c1-1)
 197       and l2,h2,act2 = c2.(0) in
 198       if act1 = act2 then
 199         let r = Array.create (len1+len2-1) c1.(0) in
 200         for i = 0 to len1-2 do
 201           r.(i) <- c1.(i)
 202         done ;
 203
 204         let l =
 205           if len1-2 >= 0 then begin
 206             let _,h,_ = r.(len1-2) in
 207             if h+1 < l1 then
 208               h+1
 209             else
 210               l1
 211           end else
 212             l1
 213         and h =
 214           if 1 < len2-1 then begin
 215             let l,_,_ = c2.(1) in
 216             if h2+1 < l then
 217               l-1
 218             else
 219               h2
 220           end else
 221             h2 in
 222         r.(len1-1) <- (l,h,act1) ;
 223         for i=1 to len2-1  do
 224           r.(len1-1+i) <- c2.(i)
 225         done ;
 226         r
 227       else if h1 > l1 then
 228         let r = Array.create (len1+len2) c1.(0) in
 229         for i = 0 to len1-2 do
 230           r.(i) <- c1.(i)
 231         done ;
 232         r.(len1-1) <- (l1,l2-1,act1) ;
 233         for i=0 to len2-1  do
 234           r.(len1+i) <- c2.(i)
 235         done ;
 236         r
 237       else if h2 > l2 then
 238         let r = Array.create (len1+len2) c1.(0) in
 239         for i = 0 to len1-1 do
 240           r.(i) <- c1.(i)
 241         done ;
 242         r.(len1) <- (h1+1,h2,act2) ;
 243         for i=1 to len2-1  do
 244           r.(len1+i) <- c2.(i)
 245         done ;
 246         r
 247       else
 248         Array.append c1 c2
 249
 250
 251 let coupe_inter i j cases =
 252   let lcases = Array.length cases in
 253   let low,_,_ = cases.(i)
 254   and _,high,_ = cases.(j) in
 255   low,high,
 256   Array.sub cases i (j-i+1),
 257   case_append (Array.sub cases 0 i) (Array.sub cases (j+1) (lcases-(j+1)))
 258
 259 type kind = Kvalue of int | Kinter of int | Kempty
 260
 261 let pkind chan = function
 262   | Kvalue i ->Printf.fprintf chan "V%d" i
 263   | Kinter i -> Printf.fprintf chan "I%d" i
 264   | Kempty -> Printf.fprintf chan "E"
 265
 266 let rec pkey chan  = function
 267   | [] -> ()
 268   | [k] -> pkind chan k
 269   | k::rem ->
 270       Printf.fprintf chan "%a %a" pkey rem pkind k
 271
 272 let t = Hashtbl.create 17
 273
 274 let make_key  cases =
 275   let seen = ref []
 276   and count = ref 0 in
 277   let rec got_it act = function
 278     | [] ->
 279         seen := (act,!count):: !seen ;
 280         let r = !count in
 281         incr count ;
 282         r
 283     | (act0,index) :: rem ->
 284         if act0 = act then
 285           index
 286         else
 287           got_it act rem in
 288
 289   let make_one l h act =
 290     if l=h then
 291       Kvalue (got_it act !seen)
 292     else
 293       Kinter (got_it act !seen) in
 294
 295   let rec make_rec i pl =
 296     if i < 0 then
 297       []
 298     else
 299       let l,h,act = cases.(i) in
 300       if pl = h+1 then
 301         make_one l h act::make_rec (i-1) l
 302       else
 303         Kempty::make_one l h act::make_rec (i-1) l in
 304
 305   let l,h,act = cases.(Array.length cases-1) in
 306   make_one l h act::make_rec (Array.length cases-2) l
 307
 308
 309     let same_act t =
 310       let len = Array.length t in
 311       let a = get_act t (len-1) in
 312       let rec do_rec i =
 313         if i < 0 then true
 314         else
 315           let b = get_act t i in
 316           b=a && do_rec (i-1) in
 317       do_rec (len-2)
 318
 319
 320 (*
 321   Intervall test x in [l,h] works by checking x-l in [0,h-l]
 322    * This may be false for arithmetic modulo 2^31
 323    * Subtracting l may change the relative ordering of values
 324      and invalid the invariant that matched values are given in
 325      increasing order
 326
 327    To avoid this, interval check is allowed only when the
 328    integers indeed present in the whole case interval are
 329    in [-2^16 ; 2^16]
 330
 331    This condition is checked by zyva
 332 *)
 333
 334 let inter_limit = 1 lsl 16
 335
 336 let ok_inter = ref false
 337
 338 let rec opt_count top cases =
 339   let key = make_key cases in
 340   try
 341     let r = Hashtbl.find t key in
 342     r
 343   with
 344   | Not_found ->
 345       let r =
 346         let lcases = Array.length cases in
 347         match lcases with
 348         | 0 -> assert false
 349         | _ when same_act cases -> No, ({n=0; ni=0},{n=0; ni=0})
 350         | _ ->
 351             if lcases < !cut then
 352               enum top cases
 353             else if lcases < !more_cut then
 354               heuristic top cases
 355             else
 356               divide top cases in
 357       Hashtbl.add t key r ;
 358       r
 359
 360 and divide top cases =
 361   let lcases = Array.length cases in
 362   let m = lcases/2 in
 363   let _,left,right = coupe cases m in
 364   let ci = {n=1 ; ni=0}
 365   and cm = {n=1 ; ni=0}
 366   and _,(cml,cleft) = opt_count false left
 367   and _,(cmr,cright) = opt_count false right in
 368   add_test ci cleft ;
 369   add_test ci cright ;
 370   if less_tests cml cmr then
 371     add_test cm cmr
 372   else
 373     add_test cm cml ;
 374   Sep m,(cm, ci)
 375
 376 and heuristic top cases =
 377   let lcases = Array.length cases in
 378
 379   let sep,csep = divide false cases
 380
 381   and inter,cinter =
 382     if !ok_inter then begin
 383       let _,_,act0 = cases.(0)
 384       and _,_,act1 = cases.(lcases-1) in
 385       if act0 = act1 then begin
 386         let low, high, inside, outside = coupe_inter 1 (lcases-2) cases in
 387         let _,(cmi,cinside) = opt_count false inside
 388         and _,(cmo,coutside) = opt_count false outside
 389         and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
 390         and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
 391         add_test cij cinside ;
 392         add_test cij coutside ;
 393         if less_tests cmi cmo then
 394           add_test cmij cmo
 395         else
 396           add_test cmij cmi ;
 397         Inter (1,lcases-2),(cmij,cij)
 398       end else
 399         Inter (-1,-1),(too_much, too_much)
 400     end else
 401       Inter (-1,-1),(too_much, too_much) in
 402   if less2tests csep cinter then
 403     sep,csep
 404   else
 405     inter,cinter
 406
 407
 408 and enum top cases =
 409   let lcases = Array.length cases in
 410   let lim, with_sep =
 411     let best = ref (-1) and best_cost = ref (too_much,too_much) in
 412
 413     for i = 1 to lcases-(1) do
 414       let _,left,right = coupe cases i in
 415       let ci = {n=1 ; ni=0}
 416       and cm = {n=1 ; ni=0}
 417       and _,(cml,cleft) = opt_count false left
 418       and _,(cmr,cright) = opt_count false right in
 419       add_test ci cleft ;
 420       add_test ci cright ;
 421       if less_tests cml cmr then
 422         add_test cm cmr
 423       else
 424         add_test cm cml ;
 425
 426       if
 427         less2tests (cm,ci) !best_cost
 428       then begin
 429         if top then
 430           Printf.fprintf stderr "Get it: %d\n" i ;
 431         best := i ;
 432         best_cost := (cm,ci)
 433       end
 434     done ;
 435     !best, !best_cost in
 436
 437   let ilow, ihigh, with_inter =
 438     if not !ok_inter then
 439       let rlow = ref (-1) and rhigh = ref (-1)
 440       and best_cost= ref (too_much,too_much) in
 441       for i=1 to lcases-2 do
 442         let low, high, inside, outside = coupe_inter i i cases in
 443          if low=high then begin
 444            let _,(cmi,cinside) = opt_count false inside
 445            and _,(cmo,coutside) = opt_count false outside
 446            and cmij = {n=1 ; ni=0}
 447            and cij = {n=1 ; ni=0} in
 448            add_test cij cinside ;
 449            add_test cij coutside ;
 450            if less_tests cmi cmo then
 451              add_test cmij cmo
 452            else
 453              add_test cmij cmi ;
 454            if less2tests (cmij,cij) !best_cost then begin
 455              rlow := i ;
 456              rhigh := i ;
 457              best_cost := (cmij,cij)
 458            end
 459          end
 460       done ;
 461       !rlow, !rhigh, !best_cost
 462     else
 463       let rlow = ref (-1) and rhigh = ref (-1)
 464       and best_cost= ref (too_much,too_much) in
 465       for i=1 to lcases-2 do
 466         for j=i to lcases-2 do
 467           let low, high, inside, outside = coupe_inter i j cases in
 468           let _,(cmi,cinside) = opt_count false inside
 469           and _,(cmo,coutside) = opt_count false outside
 470           and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
 471           and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
 472           add_test cij cinside ;
 473           add_test cij coutside ;
 474           if less_tests cmi cmo then
 475             add_test cmij cmo
 476           else
 477             add_test cmij cmi ;
 478           if less2tests (cmij,cij) !best_cost then begin
 479             rlow := i ;
 480             rhigh := j ;
 481             best_cost := (cmij,cij)
 482           end
 483         done
 484       done ;
 485       !rlow, !rhigh, !best_cost in
 486   let r = ref (Inter (ilow,ihigh)) and rc = ref with_inter in
 487   if less2tests with_sep !rc then begin
 488     r := Sep lim ; rc := with_sep
 489   end ;
 490   !r, !rc
 491
 492     let make_if_test konst test arg i ifso ifnot =
 493       Arg.make_if
 494         (Arg.make_prim test [arg ; konst i])
 495         ifso ifnot
 496
 497     let make_if_lt konst arg i  ifso ifnot = match i with
 498     | 1 ->
 499         make_if_test konst Arg.leint arg 0 ifso ifnot
 500     | _ ->
 501         make_if_test konst Arg.ltint arg i ifso ifnot
 502
 503     and make_if_le konst arg i ifso ifnot = match i with
 504     | -1 ->
 505         make_if_test konst Arg.ltint arg 0 ifso ifnot
 506     | _ ->
 507         make_if_test konst Arg.leint arg i ifso ifnot
 508
 509     and make_if_gt konst arg i  ifso ifnot = match i with
 510     | -1 ->
 511         make_if_test konst Arg.geint arg 0 ifso ifnot
 512     | _ ->
 513         make_if_test konst Arg.gtint arg i ifso ifnot
 514
 515     and make_if_ge konst arg i  ifso ifnot = match i with
 516     | 1 ->
 517         make_if_test konst Arg.gtint arg 0 ifso ifnot
 518     | _ ->
 519         make_if_test konst Arg.geint arg i ifso ifnot
 520
 521     and make_if_eq  konst arg i ifso ifnot =
 522       make_if_test konst Arg.eqint arg i ifso ifnot
 523
 524     and make_if_ne  konst arg i ifso ifnot =
 525       make_if_test konst Arg.neint arg i ifso ifnot
 526
 527     let do_make_if_out h arg ifso ifno =
 528       Arg.make_if (Arg.make_isout h arg) ifso ifno
 529
 530     let make_if_out konst ctx l d mk_ifso mk_ifno = match l with
 531     | 0 ->
 532         do_make_if_out
 533           (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx)
 534     | _ ->
 535         Arg.bind
 536           (Arg.make_offset ctx.arg (-l))
 537           (fun arg ->
 538             let ctx = {off= (-l+ctx.off) ; arg=arg} in
 539             do_make_if_out
 540               (konst d) arg (mk_ifso ctx) (mk_ifno ctx))
 541
 542     let do_make_if_in h arg ifso ifno =
 543       Arg.make_if (Arg.make_isin h arg) ifso ifno
 544
 545     let make_if_in konst ctx l d mk_ifso mk_ifno = match l with
 546     | 0 ->
 547         do_make_if_in
 548           (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx)
 549     | _ ->
 550         Arg.bind
 551           (Arg.make_offset ctx.arg (-l))
 552           (fun arg ->
 553             let ctx = {off= (-l+ctx.off) ; arg=arg} in
 554             do_make_if_in
 555               (konst d) arg (mk_ifso ctx) (mk_ifno ctx))
 556
 557
 558     let rec c_test konst ctx ({cases=cases ; actions=actions} as s) =
 559       let lcases = Array.length cases in
 560       assert(lcases > 0) ;
 561       if lcases = 1 then
 562         actions.(get_act cases 0) ctx
 563       else begin
 564
 565         let w,c = opt_count false cases in
 566 (*
 567   Printf.fprintf stderr
 568   "off=%d tactic=%a for %a\n"
 569   ctx.off pret w pcases cases ;
 570   *)
 571     match w with
 572     | No -> actions.(get_act cases 0) ctx
 573     | Inter (i,j) ->
 574         let low,high,inside, outside = coupe_inter i j cases in
 575         let _,(cinside,_) = opt_count false inside
 576         and _,(coutside,_) = opt_count false outside in
 577 (* Costs are retrieved to put the code with more remaining tests
 578    in the privileged (positive) branch of ``if'' *)
 579         if low=high then begin
 580           if less_tests coutside cinside then
 581             make_if_eq
 582               konst ctx.arg
 583               (low+ctx.off)
 584               (c_test konst ctx {s with cases=inside})
 585               (c_test konst ctx {s with cases=outside})
 586           else
 587             make_if_ne
 588               konst ctx.arg
 589               (low+ctx.off)
 590               (c_test konst ctx {s with cases=outside})
 591               (c_test konst ctx {s with cases=inside})
 592         end else begin
 593           if less_tests coutside cinside then
 594             make_if_in
 595               konst ctx
 596               (low+ctx.off)
 597               (high-low)
 598               (fun ctx -> c_test konst ctx {s with cases=inside})
 599               (fun ctx -> c_test konst ctx {s with cases=outside})
 600           else
 601             make_if_out
 602               konst ctx
 603               (low+ctx.off)
 604               (high-low)
 605               (fun ctx -> c_test konst ctx {s with cases=outside})
 606               (fun ctx -> c_test konst ctx {s with cases=inside})
 607         end
 608     | Sep i ->
 609         let lim,left,right = coupe cases i in
 610         let _,(cleft,_) = opt_count false left
 611         and _,(cright,_) = opt_count false right in
 612         let left = {s with cases=left}
 613         and right = {s with cases=right} in
 614
 615         if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then
 616           make_if_ne konst
 617             ctx.arg 0
 618             (c_test konst ctx right) (c_test konst ctx left)
 619         else if less_tests cright cleft then
 620           make_if_lt konst
 621             ctx.arg (lim+ctx.off)
 622             (c_test konst ctx left) (c_test konst ctx right)
 623         else
 624           make_if_ge konst
 625              ctx.arg (lim+ctx.off)
 626             (c_test konst ctx right) (c_test konst ctx left)
 627
 628   end
 629
 630
 631 (* Minimal density of switches *)
 632 let theta = ref 0.33333
 633
 634 (* Minmal number of tests to make a switch *)
 635 let switch_min = ref 3
 636
 637 (* Particular case 0, 1, 2 *)
 638 let particular_case cases i j =
 639   j-i = 2 &&
 640   (let l1,h1,act1 = cases.(i)
 641   and  l2,h2,act2 = cases.(i+1)
 642   and  l3,h3,act3 = cases.(i+2) in
 643   l1+1=l2 && l2+1=l3 && l3=h3 &&
 644   act1 <> act3)
 645
 646 let approx_count cases i j n_actions =
 647   let l = j-i+1 in
 648   if l < !cut then
 649      let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in
 650      ntests
 651   else
 652     l-1
 653
 654 (* Sends back a boolean that says whether is switch is worth or not *)
 655
 656 let dense {cases=cases ; actions=actions} i j =
 657   if i=j then true
 658   else
 659     let l,_,_ = cases.(i)
 660     and _,h,_ = cases.(j) in
 661     let ntests =  approx_count cases i j (Array.length actions) in
 662 (*
 663   (ntests+1) >= theta * (h-l+1)
 664 *)
 665     particular_case cases i j ||
 666     (ntests >= !switch_min &&
 667     float_of_int ntests +. 1.0 >=
 668     !theta *. (float_of_int h -. float_of_int l +. 1.0))
 669
 670 (* Compute clusters by dynamic programming
 671    Adaptation of the correction to Bernstein
 672    ``Correction to `Producing Good Code for the Case Statement' ''
 673    S.K. Kannan and T.A. Proebsting
 674    Software Practice and Exprience Vol. 24(2) 233 (Feb 1994)
 675 *)
 676
 677 let comp_clusters ({cases=cases ; actions=actions} as s) =
 678   let len = Array.length cases in
 679   let min_clusters = Array.create len max_int
 680   and k = Array.create len 0 in
 681   let get_min i = if i < 0 then 0 else min_clusters.(i) in
 682
 683   for i = 0 to len-1 do
 684     for j = 0 to i do
 685       if
 686         dense s j i &&
 687         get_min (j-1) + 1 < min_clusters.(i)
 688       then begin
 689         k.(i) <- j ;
 690         min_clusters.(i) <- get_min (j-1) + 1
 691       end
 692     done ;
 693   done ;
 694   min_clusters.(len-1),k
 695
 696 (* Assume j > i *)
 697 let make_switch  {cases=cases ; actions=actions} i j =
 698   let ll,_,_ = cases.(i)
 699   and _,hh,_ = cases.(j) in
 700   let tbl = Array.create (hh-ll+1) 0
 701   and t = Hashtbl.create 17
 702   and index = ref 0 in
 703   let get_index act =
 704     try
 705       Hashtbl.find t act
 706     with
 707     | Not_found ->
 708         let i = !index in
 709         incr index ;
 710         Hashtbl.add t act i ;
 711         i in
 712
 713   for k=i to j do
 714     let l,h,act = cases.(k) in
 715     let index = get_index act in
 716     for kk=l-ll to h-ll do
 717       tbl.(kk) <- index
 718     done
 719   done ;
 720   let acts = Array.create !index actions.(0) in
 721   Hashtbl.iter
 722     (fun act i -> acts.(i) <- actions.(act))
 723     t ;
 724   (fun ctx ->
 725     match -ll-ctx.off with
 726     | 0 -> Arg.make_switch ctx.arg tbl acts
 727     | _ ->
 728         Arg.bind
 729           (Arg.make_offset ctx.arg (-ll-ctx.off))
 730           (fun arg -> Arg.make_switch arg tbl acts))
 731
 732
 733 let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k =
 734   let len = Array.length cases in
 735   let r = Array.create n_clusters (0,0,0)
 736   and t = Hashtbl.create 17
 737   and index = ref 0
 738   and bidon = ref (Array.length actions) in
 739   let get_index act =
 740     try
 741       let i,_ = Hashtbl.find t act in
 742       i
 743     with
 744     | Not_found ->
 745         let i = !index in
 746         incr index ;
 747         Hashtbl.add
 748           t act
 749           (i,(fun _ -> actions.(act))) ;
 750         i
 751   and add_index act =
 752     let i = !index in
 753     incr index ;
 754     incr bidon ;
 755     Hashtbl.add t !bidon (i,act) ;
 756     i in
 757
 758   let rec zyva j ir =
 759     let i = k.(j) in
 760     begin if i=j then
 761       let l,h,act = cases.(i) in
 762       r.(ir) <- (l,h,get_index act)
 763     else (* assert i < j *)
 764       let l,_,_ = cases.(i)
 765       and _,h,_ = cases.(j) in
 766       r.(ir) <- (l,h,add_index (make_switch s i j))
 767     end ;
 768     if i > 0 then zyva (i-1) (ir-1) in
 769
 770   zyva (len-1) (n_clusters-1) ;
 771   let acts = Array.create !index (fun _ -> assert false) in
 772   Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ;
 773   {cases = r ; actions = acts}
 774 ;;
 775
 776
 777 let zyva (low,high) konst arg cases actions =
 778   let old_ok = !ok_inter in
 779   ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ;
 780   if !ok_inter <> old_ok then Hashtbl.clear t ;
 781
 782   let s = {cases=cases ; actions=actions} in
 783 (*
 784   Printf.eprintf "ZYVA: %b\n" !ok_inter ;
 785   pcases stderr cases ;
 786   prerr_endline "" ;
 787 *)
 788   let n_clusters,k = comp_clusters s in
 789   let clusters = make_clusters s n_clusters k in
 790   let r = c_test konst {arg=arg ; off=0} clusters in
 791   r
 792
 793
 794
 795 and test_sequence konst arg cases actions =
 796   let old_ok = !ok_inter in
 797   ok_inter := false ;
 798   if !ok_inter <> old_ok then Hashtbl.clear t ;
 799   let s =
 800     {cases=cases ;
 801     actions=Array.map (fun act -> (fun _ -> act)) actions} in
 802 (*
 803   Printf.eprintf "SEQUENCE: %b\n" !ok_inter ;
 804   pcases stderr cases ;
 805   prerr_endline "" ;
 806 *)
 807   let r = c_test konst {arg=arg ; off=0} s in
 808   r
 809 ;;
 810
 811 end