apc.ml

   1 open Format
   2
   3 let (|>) x f = f x
   4 let (|<) f x = f x
   5
   6 let font = Glut.BITMAP_HELVETICA_12
   7 let draw_string ?(font=font) x y s =
   8   GlPix.raster_pos ~x ~y ();
   9   String.iter (fun c -> Glut.bitmapCharacter ~font ~c:(Char.code c)) s
  10 ;;
  11
  12 type stats =
  13     { all : float
  14     ; user : float
  15     ; nice : float
  16     ; sys : float
  17     ; idle : float
  18     ; iowait : float
  19     ; intr : float
  20     ; softirq : float
  21     }
  22 ;;
  23
  24 let zero_stat =
  25   { all = 0.0
  26   ; user = 0.0
  27   ; nice = 0.0
  28   ; sys = 0.0
  29   ; idle = 0.0
  30   ; iowait = 0.0
  31   ; intr = 0.0
  32   ; softirq = 0.0
  33   }
  34 ;;
  35
  36 let neg_stat a =
  37   { all = -.a.all
  38   ; user = -.a.user
  39   ; nice = -.a.nice
  40   ; sys = -.a.sys
  41   ; idle = -.a.idle
  42   ; iowait = -.a.iowait
  43   ; intr = -.a.intr
  44   ; softirq = -.a.softirq
  45   }
  46 ;;
  47
  48 let scale_stat a s =
  49   { all = a.all *. s
  50   ; user = a.user *. s
  51   ; nice = a.nice *. s
  52   ; sys = a.sys *. s
  53   ; idle = a.idle *. s
  54   ; iowait = a.iowait *. s
  55   ; intr = a.intr *. s
  56   ; softirq = a.softirq *. s
  57   }
  58 ;;
  59
  60 let add_stat a b =
  61   { all = a.all +. b.all
  62   ; user = a.user +. b.user
  63   ; nice = a.nice +. b.nice
  64   ; sys = a.sys +. b.sys
  65   ; idle = a.idle +. b.idle
  66   ; iowait = a.iowait +. b.iowait
  67   ; intr = a.intr +. b.intr
  68   ; softirq = a.softirq +. b.softirq
  69   }
  70 ;;
  71
  72 module NP =
  73 struct
  74   type sysinfo =
  75       { uptime: int64
  76       ; loads: int64 * int64 * int64
  77       ; totalram: int64
  78       ; freeram: int64
  79       ; sharedram: int64
  80       ; bufferram: int64
  81       ; totalswap: int64
  82       ; freeswap: int64
  83       ; procs: int64
  84       }
  85   ;;
  86
  87   type os =
  88       | Linux
  89       | Windows
  90       | Solaris
  91       | MacOSX
  92   ;;
  93
  94   external get_nprocs : unit -> int = "ml_get_nprocs"
  95   external idletimeofday : Unix.file_descr -> int -> float array
  96     = "ml_idletimeofday"
  97   external sysinfo : unit -> sysinfo = "ml_sysinfo"
  98   external waitalrm : unit -> unit = "ml_waitalrm"
  99   external get_hz : unit -> int = "ml_get_hz"
 100   external setnice : int -> unit = "ml_nice"
 101   external delay : float -> unit = "ml_delay"
 102   external os_type : unit -> os = "ml_os_type"
 103   external solaris_kstat : int -> float array = "ml_solaris_kstat"
 104   external macosx_host_processor_info : int -> float array =
 105       "ml_macosx_host_processor_info"
 106   external windows_processor_times : int -> float array =
 107       "ml_windows_processor_times"
 108   external fixwindow : int -> unit = "ml_fixwindow"
 109   external testpmc : unit -> bool = "ml_testpmc"
 110
 111   let os_type = os_type ()
 112
 113   let winnt   = os_type = Windows
 114   let solaris = os_type = Solaris
 115   let linux   = os_type = Linux
 116   let macosx  = os_type = MacOSX
 117
 118   let user    = 0
 119   let nice    = 1
 120   let sys     = 2
 121   let idle    = 3
 122   let iowait  = 4
 123   let intr    = 5
 124   let softirq = 6
 125
 126   let hz = get_hz () |> float
 127
 128   let parse_uptime () =
 129     let ic = open_in "/proc/uptime" in
 130     let vals = Scanf.fscanf ic "%f %f" (fun u i -> (u, i)) in
 131       close_in ic;
 132       vals
 133   ;;
 134
 135   let nprocs = get_nprocs ()
 136
 137   let rec parse_int_cont s pos =
 138     let jiffies_to_sec j =
 139       float j /. hz
 140     in
 141     let slen = String.length s in
 142     let pos =
 143       let rec skipws pos =
 144         if pos = slen
 145         then
 146           pos
 147         else
 148           begin
 149             if String.get s pos = ' '
 150             then
 151               succ pos |> skipws
 152             else
 153               pos
 154           end
 155       in skipws pos
 156     in
 157     let endpos =
 158       try String.index_from s pos ' '
 159       with Not_found -> slen
 160     in
 161     let i = endpos - pos |> String.sub s pos
 162                          |> int_of_string
 163                          |> jiffies_to_sec in
 164       if endpos = slen
 165       then
 166         `last i
 167       else
 168         `more (i, fun () -> succ endpos |> parse_int_cont s)
 169   ;;
 170
 171   let parse_cpul s =
 172     let rec tolist accu = function
 173       | `last i -> i :: accu
 174       | `more (i, f) -> f () |> tolist (i :: accu)
 175     in
 176     let index = String.index s ' ' in
 177     let cpuname = String.sub s 0 index in
 178     let vals = parse_int_cont s (succ index) |> tolist [] in
 179     let vals = List.rev |<
 180         if List.length vals < 7
 181         then
 182           0.0 :: 0.0 :: 0.0 :: 0.0 :: vals
 183         else
 184           vals
 185     in
 186       cpuname, Array.of_list vals
 187   ;;
 188
 189   let parse_stat () =
 190     match os_type with
 191       | Windows ->
 192           (fun () ->
 193             let iukw = windows_processor_times nprocs in
 194             let rec create n ai ak au ad ar accu =
 195               if n = nprocs
 196               then
 197                 ("cpu", [| au; ad; ak; ai; 0.0; ar; 0.0 |]) :: List.rev accu
 198               else
 199                 let hdr = "cpu" ^ string_of_int n in
 200                 let o = n * 5 in
 201                 let i = Array.get iukw (o + 0) in
 202                 let k = Array.get iukw (o + 1) in
 203                 let u = Array.get iukw (o + 2) in
 204                 let d = Array.get iukw (o + 3) in
 205                 let r = Array.get iukw (o + 4) in
 206                 let ai = ai +. i in
 207                 let au = au +. u in
 208                 let ak = ak +. k in
 209                 let ad = ad +. d in
 210                 let ar = ar +. r in
 211                 let accu = (hdr, [| u; d; k; i; 0.0; r; 0.0 |]) :: accu in
 212                   create (succ n) ai ak au ad ar accu
 213             in
 214               create 0 0.0 0.0 0.0 0.0 0.0 []
 215           )
 216
 217       | Linux ->
 218           (fun () ->
 219             let ic = open_in "/proc/stat" in
 220             let rec loop i accu =
 221               if i = -1
 222               then
 223                 List.rev accu
 224               else
 225                 (input_line ic |> parse_cpul) :: accu |> loop (pred i)
 226             in
 227             let ret = loop nprocs [] in
 228               close_in ic;
 229               ret
 230           )
 231
 232       | Solaris ->
 233           (fun () ->
 234             let iukw = solaris_kstat nprocs in
 235             let rec create n ai au ak aw accu =
 236               if n = nprocs
 237               then
 238                 ("cpu", [| au; 0.0; ak; ai; aw; 0.0; 0.0 |]) :: List.rev accu
 239               else
 240                 let hdr = "cpu" ^ string_of_int n in
 241                 let o = n * 4 in
 242                 let i = Array.get iukw (o + 0) /. hz in
 243                 let u = Array.get iukw (o + 1) /. hz in
 244                 let k = Array.get iukw (o + 2) /. hz in
 245                 let w = Array.get iukw (o + 3) /. hz in
 246                 let ai = ai +. i in
 247                 let au = au +. u in
 248                 let ak = ak +. k in
 249                 let aw = aw +. w in
 250                 let accu = (hdr, [| u; 0.0; k; i; w; 0.0; 0.0 |]) :: accu in
 251                   create (succ n) ai au ak aw accu
 252             in
 253               create 0 0.0 0.0 0.0 0.0 []
 254           )
 255
 256       | MacOSX ->
 257           (fun () ->
 258             let iukn = macosx_host_processor_info nprocs in
 259             let rec create c ai au ak an accu =
 260               if c = nprocs
 261               then
 262                 ("cpu", [| au; an; ak; ai; 0.0; 0.0; 0.0 |]) :: List.rev accu
 263               else
 264                 let hdr = "cpu" ^ string_of_int c in
 265                 let o = c * 4 in
 266                 let i = Array.get iukn (o + 0) /. hz in
 267                 let u = Array.get iukn (o + 1) /. hz in
 268                 let k = Array.get iukn (o + 2) /. hz in
 269                 let n = Array.get iukn (o + 3) /. hz in
 270                 let ai = ai +. i in
 271                 let au = au +. u in
 272                 let ak = ak +. k in
 273                 let an = an +. n in
 274                 let accu = (hdr, [| u; n; k; i; 0.0; 0.0; 0.0 |]) :: accu in
 275                   create (succ c) ai au ak an accu
 276             in
 277               create 0 0.0 0.0 0.0 0.0 []
 278           )
 279   ;;
 280
 281   let getselfdir () =
 282     try
 283       Filename.dirname |< Unix.readlink "/proc/self/exe"
 284     with exn ->
 285       "./"
 286   ;;
 287 end
 288
 289 module Args =
 290 struct
 291   let banner =
 292     [ "Amazing Piece of Code by insanely gifted programmer, Version 1.01"
 293     ; "Motivation by: gzh and afs"
 294     ; "usage: "
 295     ] |> String.concat "\n"
 296
 297   let freq     = ref 1.0
 298   let interval = ref 15.0
 299   let devpath  = NP.getselfdir () |> Filename.concat |< "itc" |> ref
 300   let pgrid    = ref 10
 301   let sgrid    = ref 15
 302   let w        = ref 400
 303   let h        = ref 200
 304   let verbose  = ref false
 305   let delay    = ref 0.04
 306   let ksampler = ref true
 307   let isampler = ref true
 308   let barw     = ref 100
 309   let bars     = ref 50
 310   let sigway   = ref (NP.os_type != NP.MacOSX)
 311   let niceval  = ref 0
 312   let gzh      = ref false
 313   let scalebar = ref false
 314   let timer    = ref 100
 315   let debug    = ref false
 316   let poly     = ref false
 317   let uptime   = ref false
 318   let icon     = ref false
 319   let labels   = ref true
 320   let mgrid    = ref false
 321   let sepstat  = ref true
 322   let grid_green = ref 0.75
 323
 324   let pad n s =
 325     let l = String.length s in
 326       if l >= n
 327       then
 328         s
 329       else
 330         let d = String.make n ' ' in
 331           StringLabels.blit ~src:s ~dst:d
 332             ~src_pos:0 ~len:l
 333             ~dst_pos:0;
 334           d
 335   ;;
 336
 337   let sooo b = if b then "on" else "off"
 338   let dA tos s {contents=v} = s ^ " (" ^ tos v ^ ")"
 339   let dF = dA |< sprintf "%4.2f"
 340   let dB = dA sooo
 341   let dcB = dA sooo
 342   let dI = dA string_of_int
 343   let dS = dA (fun s -> "`" ^ String.escaped s ^ "'")
 344
 345   let sF opt r doc =
 346     "-" ^ opt, Arg.Set_float r, pad 9 "<float> " ^ doc |> dF |< r
 347   ;;
 348
 349   let sI opt r doc =
 350     "-" ^ opt, Arg.Set_int r, pad 9 "<int> " ^ doc |> dI |< r
 351   ;;
 352
 353   let sB opt r doc =
 354     "-" ^ opt, Arg.Set r, pad 9 "" ^ doc |> dB |< r
 355   ;;
 356
 357   let sS opt r doc =
 358     "-" ^ opt, Arg.Set_string r, pad 9 "<string> " ^ doc |> dS |< r
 359   ;;
 360
 361   let fB opt r doc =
 362     if r.contents
 363     then
 364       "-" ^ opt, Arg.Clear r, pad 9 "" ^ doc |> dB |< r
 365     else
 366       "-" ^ opt, Arg.Set r, pad 9 "" ^ doc |> dcB |< r
 367   ;;
 368
 369   let commonopts =
 370     [ sF "f" freq "sampling frequency in seconds"
 371     ; sF "D" delay "refresh delay in seconds"
 372     ; sF "i" interval "history interval in seconds"
 373     ; sI "p" pgrid "percent grid items"
 374     ; sI "s" sgrid "history grid items"
 375     ; sI "w" w "width"
 376     ; sI "h" h "height"
 377     ; sI "b" barw "bar width"
 378     ; sI "B" bars "number of CPU bars"
 379     ; sB "v" verbose "verbose"
 380     ; fB "C" sepstat "separate sys/nice/intr/iowait values (kernel sampler)"
 381     ; fB "c" scalebar "constant bar width"
 382     ; fB "P" poly "filled area instead of lines"
 383     ; fB "l" labels "labels"
 384     ; fB "m" mgrid "moving grid"
 385     ]
 386   ;;
 387
 388   let add_opts tail =
 389     let add_linux opts =
 390       sI "t" timer "timer frequency in herz"
 391       :: fB "I" icon "icon (hack)"
 392       :: sS "d" devpath "path to itc device"
 393       :: (fB "k" ksampler |< "kernel sampler (`/proc/[stat|uptime]')")
 394       :: (fB "M" isampler |< "idle sampler")
 395       :: (fB "u" uptime
 396              "`uptime' instead of `stat' as kernel sampler (UP only)")
 397       :: sI "n" niceval "value to renice self on init"
 398       :: fB "g" gzh "gzh way (does not quite work yet)"
 399       :: fB "S" sigway "sigwait delay method"
 400       :: opts
 401     in
 402     let add_solaris opts =
 403       isampler := false;
 404       fB "I" icon "icon (hack)"
 405       :: opts
 406     in
 407     let add_windows opts =
 408       isampler := false;
 409       (fB "k" ksampler |< "kernel sampler (ZwQuerySystemInformation)")
 410       :: (fB "M" isampler |< "idle sampler (PMC based)")
 411       :: opts
 412     in
 413     let add_macosx opts =
 414       isampler := false;
 415       fB "g" gzh "gzh way (does not quite work yet)"
 416       :: opts
 417     in
 418       match NP.os_type with
 419         | NP.Linux -> add_linux tail
 420         | NP.Windows -> add_windows tail
 421         | NP.Solaris -> add_solaris tail
 422         | NP.MacOSX -> add_macosx tail
 423   ;;
 424
 425   let init () =
 426     let opts = add_opts commonopts in
 427       Arg.parse opts
 428         (fun s ->
 429           raise (Arg.Bad
 430                     ("Invocation error: Don't know what to do with " ^ s));
 431         )
 432         banner
 433       ;
 434       let cp {contents=v} s =
 435         if v <= 0
 436         then (prerr_string s; prerr_endline " must be positive"; exit 1)
 437       in
 438       let cpf {contents=v} s =
 439         if v <= 0.0
 440         then (prerr_string s; prerr_endline " must be positive"; exit 1)
 441       in
 442         cp w "Width";
 443         cp h "Height";
 444         cp pgrid "Number of percent grid items";
 445         cp sgrid "Number of history grid items";
 446         cp bars "Number of CPU bars";
 447         cp timer "Timer frequency";
 448         cpf freq "Frequency";
 449         cpf delay "Delay";
 450         cpf interval "Interval";
 451         if not (!isampler || !ksampler)
 452         then
 453           barw := 0
 454         ;
 455         if NP.winnt && !isampler
 456         then
 457           isampler := NP.testpmc ()
 458         ;
 459   ;;
 460 end
 461
 462 module Gzh =
 463 struct
 464   let lim = ref 0
 465   let stop = ref false
 466   let refdt = ref 0.0
 467
 468   let rec furious_cycle i =
 469     if not !stop && i > 0
 470     then
 471       pred i |> furious_cycle
 472     else
 473       (i, Unix.gettimeofday ())
 474   ;;
 475
 476   let init verbose =
 477     let t = 0.5 in
 478     let it = { Unix.it_interval = t; it_value = t } in
 479     let tries = 1 in
 480     let handler =
 481       let n = ref tries in
 482         fun _ ->
 483           decr n;
 484           stop := !n = 0;
 485     in
 486     let sign = Sys.sigalrm in
 487     let oldh = Sys.signal sign |< Sys.Signal_handle handler in
 488     let oldi = Unix.setitimer Unix.ITIMER_REAL it in
 489     let oldbp = Unix.sigprocmask Unix.SIG_BLOCK [sign] in
 490     let () = NP.waitalrm () in
 491     let () = stop := false in
 492     let oldup = Unix.sigprocmask Unix.SIG_UNBLOCK [sign] in
 493     let t1 = Unix.gettimeofday () in
 494     let n, t2 = furious_cycle max_int in
 495     let () = refdt := t2 -. t1 in
 496     let () = lim := tries * (max_int - n) in
 497     let () =
 498       if verbose
 499       then
 500         printf "Completed %d iterations in %f seconds@." !lim !refdt
 501     in
 502     let _ = Unix.sigprocmask Unix.SIG_UNBLOCK oldup in
 503     let _ = Unix.setitimer Unix.ITIMER_REAL oldi in
 504     let _ = Unix.sigprocmask Unix.SIG_BLOCK oldbp in
 505     let _ = Sys.signal sign oldh in
 506       ()
 507   ;;
 508
 509   let gen f =
 510     let thf () =
 511       NP.setnice 20;
 512       stop := false;
 513       let l = ref 0 in
 514       let rec loop t1 =
 515         let _, t2 = furious_cycle !lim in
 516         let dt = t2 -. t1 in
 517           incr l;
 518           if !Args.debug && !l > 10
 519           then
 520             begin
 521               printf "Completed %d iterations in %f seconds load %f@."
 522                 !lim dt |< !refdt /. dt;
 523               l := 0;
 524             end
 525           ;
 526           !refdt /. dt |> f;
 527           loop t2
 528       in
 529         Unix.gettimeofday () |> loop
 530     in
 531     let _ = Thread.create thf () in
 532       ()
 533   ;;
 534 end
 535
 536 let oohz oohz fn =
 537   let prev = ref 0.0 in
 538     fun () ->
 539       let a = !prev in
 540       let b = Unix.gettimeofday () in
 541         if b -. a > oohz
 542         then
 543           begin
 544             prev := b;
 545             fn ()
 546           end
 547 ;;
 548
 549 module Delay =
 550 struct
 551   let sighandler signr = ()
 552
 553   let winfreq = ref 0.0
 554
 555   let init freq gzh =
 556     if NP.winnt
 557     then
 558       winfreq := 1.0 /. float freq
 559     else
 560       let () =
 561         Sys.Signal_handle sighandler |> Sys.set_signal Sys.sigalrm;
 562         if !Args.sigway
 563         then
 564           let l =
 565             if gzh
 566             then
 567               [Sys.sigprof; Sys.sigvtalrm]
 568             else
 569               []
 570           in
 571             Unix.sigprocmask Unix.SIG_BLOCK |< Sys.sigalrm :: l |> ignore;
 572       ;
 573       in
 574       let v = 1.0 /. float freq in
 575       let t = { Unix.it_interval = v; it_value = v } in
 576       let _ = Unix.setitimer Unix.ITIMER_REAL t in
 577         ()
 578   ;;
 579
 580   let delay () =
 581     if NP.winnt
 582     then
 583       NP.delay !winfreq
 584     else
 585       begin
 586         if !Args.sigway
 587         then
 588           NP.waitalrm ()
 589         else
 590           begin
 591             try let _ = Unix.select [] [] [] ~-.1.0 in ()
 592             with Unix.Unix_error (Unix.EINTR, _, _) -> ()
 593           end
 594       end
 595   ;;
 596 end
 597
 598 type sampler =
 599     { color : Gl.rgb;
 600       getyielder : unit -> unit -> float option;
 601       update : float -> float -> unit;
 602     }
 603 ;;
 604
 605 module Sampler (T : sig val nsamples : int val freq : float end) =
 606 struct
 607   let nsamples = T.nsamples + 1
 608   let samples = Array.create nsamples 0.0
 609   let head = ref 0
 610   let tail = ref 0
 611   let active = ref 0
 612
 613   let update v n =
 614     let n = min nsamples n in
 615     let rec loop i j =
 616       if j = 0
 617       then
 618         ()
 619       else
 620         let i =
 621           if i = nsamples
 622           then
 623             0
 624           else
 625             i
 626         in
 627           Array.set samples i v;
 628           loop (succ i) (pred j)
 629     in
 630     let () = loop !head n in
 631     let () = head := (!head + n) mod nsamples in
 632     let () = active := min (!active + n) nsamples in
 633       ();
 634   ;;
 635
 636   let getyielder () =
 637     let tail =
 638       let d = !head - !active in
 639         if d < 0
 640         then
 641           nsamples + d
 642         else
 643           d
 644     in
 645     let ry = ref (fun () -> assert false) in
 646     let rec yield i () =
 647       if i = !active
 648       then
 649         None
 650       else
 651         begin
 652           ry := succ i |> yield;
 653           Some ((i + tail) mod nsamples |> Array.get samples)
 654         end
 655     in
 656       ry := yield 0;
 657       (fun () -> !ry ());
 658   ;;
 659
 660   let update dt di =
 661     let isamples = dt /. T.freq |> truncate in
 662     let l = 1.0 -. (di /. dt) in
 663     let l = max 0.0 l in
 664       update l isamples;
 665   ;;
 666 end
 667
 668 module type ViewSampler =
 669 sig
 670   val getyielder : unit -> unit -> float option
 671   val update : float -> float -> float -> float -> unit
 672 end
 673
 674 module type View =
 675 sig
 676   val x : int
 677   val y : int
 678   val w : int
 679   val h : int
 680   val sgrid : int
 681   val pgrid : int
 682   val freq : float
 683   val interval : float
 684   val samplers : sampler list
 685 end
 686
 687 module View (V: sig val w : int val h : int end) =
 688 struct
 689   let ww = ref 0
 690   let wh = ref 0
 691   let funcs = ref []
 692
 693   let keyboard ~key ~x ~y =
 694     if key = 27 || key = Char.code 'q'
 695     then
 696       exit 0;
 697   ;;
 698
 699   let add dri =
 700     funcs := dri :: !funcs
 701   ;;
 702
 703   let display () =
 704     GlClear.clear [`color];
 705     List.iter (fun (display, _, _) -> display ()) !funcs;
 706     Glut.swapBuffers ();
 707   ;;
 708
 709   let reshape ~w ~h =
 710     ww := w;
 711     wh := h;
 712     List.iter (fun (_, reshape, _) -> reshape w h) !funcs;
 713     GlClear.clear [`color];
 714     GlMat.mode `modelview;
 715     GlMat.load_identity ();
 716     GlMat.mode `projection;
 717     GlMat.load_identity ();
 718     GlMat.rotate ~y:1.0 ~angle:180.0 ();
 719     GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
 720     GlMat.scale ~x:2.0 ~y:2.0 ();
 721     Glut.postRedisplay ();
 722   ;;
 723
 724   let init () =
 725     let () =
 726       Glut.initDisplayMode ~double_buffer:true ();
 727       Glut.initWindowSize V.w V.h
 728     in
 729     let winid = Glut.createWindow "APC" in
 730       Glut.displayFunc display;
 731       Glut.reshapeFunc reshape;
 732       Glut.keyboardFunc keyboard;
 733       GlDraw.color (1.0, 1.0, 0.0);
 734       winid;
 735   ;;
 736
 737   let inc () = List.iter (fun (_, _, inc) -> inc ()) !funcs
 738   let update = Glut.postRedisplay
 739   let func = Glut.idleFunc
 740   let run = Glut.mainLoop
 741 end
 742
 743 module type BarInfo =
 744 sig
 745   val x : int
 746   val y : int
 747   val w : int
 748   val h : int
 749   val getl : stats -> ((float * float * float) * float) list
 750 end
 751
 752 module Bar (I: BarInfo) =
 753 struct
 754   let w = ref I.w
 755   let dontdraw = ref false
 756   let h = ref I.h
 757   let xoffset = ref I.x
 758   let xratio = float I.x /. float !Args.w
 759   let wratio = float I.w /. float !Args.w
 760   let load = ref zero_stat
 761   let nrcpuscale = 1.0 /. float NP.nprocs
 762   let fh = 12
 763   let strw = Glut.bitmapLength ~font ~str:"55.55"
 764   let sepsl =
 765     let base = GlList.gen_lists ~len:1 in
 766       GlList.nth base ~pos:0
 767   ;;
 768
 769   let seps () =
 770     let hh = !h - 26 in
 771     let () =
 772       GlDraw.viewport !xoffset (I.y + 15) !w hh;
 773       GlMat.push ();
 774       GlMat.load_identity ();
 775       GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
 776       GlMat.scale ~y:(2.0 /. (float hh)) ~x:1.0 ();
 777     in
 778     let seph = 1 in
 779     let barh = float (hh - (!Args.bars - 1) * seph) /. float !Args.bars in
 780     let barh = ceil barh |> truncate in
 781     let rec loop i yb =
 782       if yb > hh
 783       then
 784         ()
 785       else
 786         let yt = yb + seph in
 787         let yn = yt + barh in
 788         let yb = float yb
 789         and yt = float yt in
 790           GlDraw.vertex2 (0.0, yb);
 791           GlDraw.vertex2 (0.0, yt);
 792           GlDraw.vertex2 (2.0, yt);
 793           GlDraw.vertex2 (2.0, yb);
 794           succ i |> loop |< yn
 795     in
 796       GlDraw.color (0.0, 0.0, 0.0);
 797       GlDraw.begins `quads;
 798       loop 0 barh;
 799       GlDraw.ends ();
 800       GlMat.pop ();
 801   ;;
 802
 803   let reshape w' h' =
 804     if !Args.scalebar
 805     then
 806       begin
 807         w := float w' *. wratio |> truncate;
 808         xoffset := float w' *. xratio |> truncate;
 809       end
 810     else
 811       begin
 812         w := I.w;
 813         xoffset := I.x;
 814       end
 815     ;
 816     h := h';
 817     GlList.begins sepsl `compile;
 818     seps ();
 819     GlList.ends ();
 820     dontdraw :=
 821       !h < 20 || !w < 20 || !xoffset < 0
 822     ;
 823   ;;
 824
 825   let display_aux () =
 826     let load = scale_stat !load nrcpuscale in
 827     let load_all = min (1.0 -. load.all) 1.0 |> max 0.0 in
 828     let () = GlMat.push () in
 829     let () =
 830       GlDraw.viewport !xoffset (I.y + 2) !w !h;
 831       GlDraw.color (1.0, 1.0, 1.0);
 832       let load_all = 100.0 *. load_all in
 833       let str = sprintf "%5.2f" load_all in
 834       let () =
 835         GlMat.load_identity ();
 836         let strw =
 837           if false
 838           then
 839             Glut.bitmapLength ~font ~str:str
 840           else
 841             strw
 842         in
 843         let x = -. (float strw /. float !w) in
 844           GlMat.translate ~y:~-.1.0 ~x ();
 845       in
 846       let () = draw_string 0.0 0.0 str in
 847         ()
 848     in
 849       GlDraw.viewport !xoffset (I.y + 15) !w (!h - 26);
 850       GlMat.load_identity ();
 851       GlMat.translate ~x:~-.1. ~y:~-.1.();
 852       let drawquad yb yt =
 853         GlDraw.begins `quads;
 854         GlDraw.vertex2 (0.0, yb);
 855         GlDraw.vertex2 (0.0, yt);
 856         GlDraw.vertex2 (2.0, yt);
 857         GlDraw.vertex2 (2.0, yb);
 858         GlDraw.ends ()
 859       in
 860       let fold yb (color, load) =
 861         if load > 0.0
 862         then
 863           let () = GlDraw.color color in
 864           let yt = yb +. 2.0*.load in
 865           let () = drawquad yb yt in
 866             yt
 867         else
 868           yb
 869       in
 870       let cl = I.getl load in
 871       let yb = List.fold_left fold 0.0 cl in
 872       let () = GlDraw.color (0.5, 0.5, 0.5) in
 873       let () = drawquad yb 2.0 in
 874       let () = GlList.call sepsl in
 875         GlMat.pop ();
 876         GlList.call sepsl;
 877   ;;
 878
 879   let display () =
 880     if !dontdraw
 881     then
 882       ()
 883     else
 884       display_aux ()
 885     ;
 886   ;;
 887
 888   let update delta' load' =
 889     let delta = 1.0 /. delta' in
 890       load := scale_stat load' delta;
 891   ;;
 892 end
 893
 894 module Graph (V: View) =
 895 struct
 896   let ox = if !Args.scalebar then 0 else !Args.barw
 897   let sw = float V.w /. float (!Args.w - ox)
 898   let sh = float V.h /. float !Args.h
 899   let sx = float (V.x - ox)  /. float V.w
 900   let sy = float V.y /. float V.h
 901   let vw = ref 0
 902   let vh = ref 0
 903   let vx = ref 0
 904   let vy = ref 0
 905   let scale = V.freq /. V.interval
 906   let gscale = 1.0 /. float V.sgrid
 907   let nsamples = ref 0
 908   let dontdraw = ref false
 909
 910   let fw, fh =
 911     if !Args.labels
 912     then
 913       3 * Glut.bitmapWidth font (Char.code '%'), 20
 914     else
 915       0, 10
 916   ;;
 917
 918   let gridlist =
 919     let base = GlList.gen_lists ~len:1 in
 920       GlList.nth base ~pos:0
 921   ;;
 922
 923   let getviewport typ =
 924     let ox = if !Args.scalebar then 0 else !Args.barw in
 925       match typ with
 926         | `labels -> (!vx + ox, !vy + 5, fw, !vh - fh)
 927         | `graph  -> (!vx + fw + 5 + ox, !vy + 5, !vw - fw - 10, !vh - fh)
 928   ;;
 929
 930   let viewport typ =
 931     let x, y, w, h = getviewport typ in
 932       GlDraw.viewport x y w h;
 933   ;;
 934
 935   let sgrid () =
 936     for i = 0 to V.sgrid
 937     do
 938       let x = if i = 0 then 0.0009 else float i *. gscale in
 939         GlDraw.vertex ~x ~y:0.0 ();
 940         GlDraw.vertex ~x ~y:1.0 ();
 941     done;
 942   ;;
 943
 944   let grid () =
 945     viewport `graph;
 946     GlDraw.line_width 1.0;
 947     GlDraw.color (0.0, !Args.grid_green, 0.0);
 948     GlDraw.begins `lines;
 949     if !Args.mgrid
 950     then
 951       begin
 952         GlDraw.vertex2 (0.0009, 0.0);
 953         GlDraw.vertex2 (0.0009, 1.0);
 954         GlDraw.vertex2 (1.0000, 0.0);
 955         GlDraw.vertex2 (1.0000, 1.0);
 956       end
 957     else
 958       sgrid ()
 959     ;
 960     let () =
 961       let lim = 100 / V.pgrid in
 962         for i = 0 to lim
 963         do
 964           let y = (i * V.pgrid |> float) /. 100.0 in
 965           let y = if i = lim then y -. 0.0009 else y in
 966             GlDraw.vertex ~x:0.0 ~y ();
 967             GlDraw.vertex ~x:1.0 ~y ();
 968         done;
 969     in
 970     let () = GlDraw.ends () in
 971       if !Args.labels
 972       then
 973         begin
 974           viewport `labels;
 975           GlDraw.color (1.0, 1.0, 1.0);
 976           let ohp = 100.0 in
 977             for i = 0 to 100 / V.pgrid
 978             do
 979               let p = i * V.pgrid in
 980               let y = float p /. ohp in
 981               let s = sprintf "%3d%%" p in
 982                 draw_string 1.0 y s
 983             done
 984         end
 985   ;;
 986
 987   let reshape w h =
 988     let wxsw = float (w - ox) *. sw
 989     and hxsh = float h *. sh in
 990       vw := wxsw |> truncate;
 991       vh := hxsh |> truncate;
 992       vx := wxsw *. sx |> truncate;
 993       vy := hxsh *. sy |> truncate;
 994       dontdraw :=
 995         (
 996           let x0, y0, w0, h0 = getviewport `labels in
 997           let x1, y1, w1, h1 = getviewport `graph in
 998             w0 < 20 || h0 < 20 || x0 < 0 || y0 < 0 ||
 999             w1 < 20 || h1 < 20 || x1 < 0 || y1 < 0
1000         )
1001       ;
1002       if not !dontdraw
1003       then
1004         begin
1005           GlList.begins gridlist `compile;
1006           grid ();
1007           GlList.ends ();
1008         end
1009   ;;
1010
1011   let swap =
1012     Glut.swapBuffers |> oohz !Args.delay;
1013   ;;
1014
1015   let inc () = incr nsamples
1016
1017   let mgrid () =
1018     GlDraw.line_width 1.0;
1019     GlDraw.color (0.0, !Args.grid_green, 0.0);
1020     GlDraw.begins `lines;
1021     let offset =
1022       ((pred !nsamples |> float) *. scale /. gscale |> modf |> fst) *. gscale
1023     in
1024       for i = 0 to pred V.sgrid
1025       do
1026         let x = offset +. float i *. gscale in
1027           GlDraw.vertex ~x ~y:0.0 ();
1028           GlDraw.vertex ~x ~y:1.0 ();
1029       done;
1030       GlDraw.ends ();
1031   ;;
1032
1033   let display_aux () =
1034     GlList.call gridlist;
1035     viewport `graph;
1036     if !Args.mgrid then mgrid ();
1037     GlDraw.line_width 2.0;
1038     let sample sampler =
1039       GlDraw.color sampler.color;
1040       let () =
1041         if not !Args.poly
1042         then GlDraw.begins `line_strip
1043         else
1044           begin
1045             GlDraw.begins `polygon;
1046             GlDraw.vertex2 (0.0, 0.0);
1047           end
1048       in
1049       let yield = sampler.getyielder () in
1050       let rec loop last i =
1051         match yield () with
1052           | Some y as opty ->
1053               let x = scale *. float i in
1054                 GlDraw.vertex ~x ~y ();
1055                 loop opty (succ i)
1056
1057           | None ->
1058               if !Args.poly
1059               then
1060                 match last with
1061                   | None -> ()
1062                   | Some y ->
1063                       let x = scale *. float (pred i) in
1064                         GlDraw.vertex ~x ~y:0.0 ()
1065       in
1066         loop None 0;
1067         GlDraw.ends ();
1068     in
1069       List.iter sample V.samplers;
1070   ;;
1071
1072   let display () =
1073     if not !dontdraw
1074     then
1075       display_aux ()
1076     else
1077       ()
1078     ;
1079   ;;
1080
1081   let funcs = display, reshape, inc
1082 end
1083
1084 let getplacements w h n barw =
1085   let sr = float n |> sqrt |> ceil |> truncate in
1086   let d = n / sr in
1087   let r = if n mod sr = 0 then 0 else 1 in
1088   let x, y =
1089     if w - barw > h
1090     then
1091       sr + r, d
1092     else
1093       d, sr + r
1094   in
1095   let w' = w - barw in
1096   let h' = h in
1097   let vw = w' / x in
1098   let vh = h' / y in
1099   let rec loop accu i =
1100     if i = n
1101     then
1102       accu
1103     else
1104       let yc = i / x in
1105       let xc = i mod x in
1106       let xc = xc * vw + barw in
1107       let yc = yc * vh in
1108         (i, xc, yc) :: accu |> loop |< succ i
1109   in
1110     loop [] 0, vw, vh
1111 ;;
1112
1113 let create fd w h =
1114   let module S =
1115       struct
1116         let freq = !Args.freq
1117         let nsamples = !Args.interval /. freq |> ceil |> truncate
1118       end
1119   in
1120   let placements, vw, vh = getplacements w h NP.nprocs !Args.barw in
1121
1122   let iget () =
1123     if !Args.isampler then NP.idletimeofday fd NP.nprocs else [||]
1124   in
1125   let is = iget () in
1126
1127   let kget () =
1128     let gks = NP.parse_stat () in
1129       gks () |> Array.of_list
1130   in
1131   let ks = kget () in
1132
1133   let crgraph (kaccu, iaccu, gaccu) (i, x, y) =
1134     let module Si = Sampler (S) in
1135     let isampler =
1136       { getyielder = Si.getyielder
1137       ; color = (1.0, 1.0, 0.0)
1138       ; update = Si.update
1139       }
1140     in
1141     let module Sk = Sampler (S) in
1142     let ksampler =
1143       { getyielder = Sk.getyielder
1144       ; color = (1.0, 0.0, 0.0)
1145       ; update = Sk.update
1146       }
1147     in
1148     let module V = struct
1149       let x = x
1150       let y = y
1151       let w = vw
1152       let h = vh
1153       let freq = S.freq
1154       let interval = !Args.interval
1155       let pgrid = !Args.pgrid
1156       let sgrid = !Args.sgrid
1157       let samplers =
1158         if !Args.isampler
1159         then
1160           isampler :: (if !Args.ksampler then [ksampler] else [])
1161         else
1162           if !Args.ksampler then [ksampler] else []
1163     end
1164     in
1165     let module Graph = Graph (V) in
1166     let kaccu =
1167       if !Args.ksampler
1168       then
1169         let calc =
1170           if !Args.gzh
1171           then
1172             let d = ref 0.0 in
1173             let f d' = d := d' in
1174             let () = Gzh.gen f in
1175               fun _ _ _ ->
1176                 let d = !d in
1177                   { zero_stat with
1178                     all = d; iowait = d; user = 1.0 -. d; idle = d }
1179           else
1180             if !Args.uptime
1181             then
1182               let (u1, i1) = NP.parse_uptime () in
1183               let u1 = ref u1
1184               and i1 = ref i1 in
1185                 fun _ _ _ ->
1186                   let (u2, i2) = NP.parse_uptime () in
1187                   let du = u2 -. !u1
1188                   and di = i2 -. !i1 in
1189                   let d = di /. du in
1190                     u1 := u2;
1191                     i1 := i2;
1192                     { zero_stat with
1193                       all = d; iowait = d; user = 1.0 -. d; idle = d }
1194           else
1195             let i' = if i = NP.nprocs then 0 else succ i in
1196             let g ks n = Array.get ks i' |> snd |> Array.get |< n in
1197             let gall ks =
1198               let user = g ks NP.user
1199               and nice = g ks NP.nice
1200               and sys = g ks NP.sys
1201               and idle = g ks NP.idle
1202               and iowait = g ks NP.idle
1203               and intr = g ks NP.intr
1204               and softirq = g ks NP.softirq in
1205               let () =
1206                 if !Args.debug
1207                 then
1208                   eprintf
1209                     "user=%f nice=%f sys=%f iowait=%f intr=%f softirq=%f@."
1210                     user
1211                     nice
1212                     sys
1213                     iowait
1214                     intr
1215                     softirq
1216                 ;
1217               in
1218                 { all = idle
1219                 ; user = user
1220                 ; nice = nice
1221                 ; sys = sys
1222                 ; idle = idle
1223                 ; iowait = iowait
1224                 ; intr = intr
1225                 ; softirq = softirq
1226                 }
1227             in
1228             let i1 = ref (gall ks) in
1229               fun ks _ _ ->
1230                 let i2 = gall ks in
1231                 let diff = add_stat i2 (neg_stat !i1) in
1232                   i1 := i2;
1233                   diff
1234         in
1235           (i, calc, ksampler) :: kaccu
1236       else
1237         kaccu
1238     in
1239     let iaccu =
1240       if !Args.isampler
1241       then
1242         let calc =
1243           let i1 = Array.get is i |> ref in
1244             fun is t1 t2 ->
1245               let i2 = Array.get is i in
1246                 if classify_float i2 = FP_infinite
1247                 then
1248                   { zero_stat with all = t2 -. t1 }
1249                 else
1250                   let i1' = !i1 in
1251                     i1 := i2;
1252                     { zero_stat with all = i2 -. i1' }
1253         in
1254           (i, calc, isampler) :: iaccu
1255       else
1256         iaccu
1257     in
1258       kaccu, iaccu, Graph.funcs :: gaccu
1259   in
1260   let kl, il, gl = List.fold_left crgraph ([], [], []) placements in
1261     ((if kl == [] then (fun () -> [||]) else kget), kl), (iget, il), gl
1262 ;;
1263
1264 let opendev path =
1265   if not NP.linux
1266   then
1267     (* gross hack but we are not particularly picky today *)
1268     Unix.stdout
1269   else
1270     try
1271       if (Unix.stat path).Unix.st_kind != Unix.S_CHR
1272       then
1273         begin
1274           eprintf "File %S is not an ITC device@." path;
1275           exit 100
1276         end
1277       ;
1278       Unix.openfile path [Unix.O_RDONLY] 0
1279     with
1280       | Unix.Unix_error ((Unix.ENODEV | Unix.ENXIO) as err , s1, s2) ->
1281           eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1282             path s1 s2 |< Unix.error_message err;
1283           eprintf "(perhaps the module is not loaded?)@.";
1284           exit 100
1285
1286       | Unix.Unix_error (Unix.EALREADY, s1, s2) ->
1287           eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1288             path s1 s2 |< Unix.error_message Unix.EALREADY;
1289           eprintf "(perhaps modules is already in use?)@.";
1290           exit 100
1291
1292       | Unix.Unix_error (error, s1, s2) ->
1293           eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1294             path s1 s2 |< Unix.error_message error;
1295           exit 100
1296
1297       | exn ->
1298           eprintf "Could not open ITC device %S:\n%s@."
1299             path |< Printexc.to_string exn;
1300           exit 100
1301 ;;
1302
1303 let seticon () =
1304   let module X =
1305       struct
1306         external seticon : string -> unit = "ml_seticon"
1307       end
1308   in
1309   let len = 32*4 in
1310   let data = String.create |< 32*len + 2*4 in
1311   let line r g b a =
1312     let r = Char.chr r
1313     and g = Char.chr g
1314     and b = Char.chr b
1315     and a = Char.chr a in
1316     let s = String.create len in
1317     let rec fill x =
1318       if x = len
1319       then
1320         s
1321       else
1322         begin
1323           x + 0 |> String.set s |< b;
1324           x + 1 |> String.set s |< g;
1325           x + 2 |> String.set s |< r;
1326           x + 3 |> String.set s |< a;
1327           x + 4 |> fill
1328         end
1329     in
1330       fill 0
1331   in
1332   let el = line 0x00 0x00 0x00 0xff
1333   and kl = line 0xff 0x00 0x00 0xff
1334   and il = line 0xff 0xff 0x00 0xff in
1335   let fill l sy ey =
1336     let src = l and dst = data and src_pos = 0 in
1337     let rec loop n dst_pos =
1338       if n > 0
1339       then
1340         begin
1341           StringLabels.blit ~src ~src_pos ~dst ~dst_pos ~len;
1342           pred n |> loop |< dst_pos + len
1343         end
1344     in
1345       (ey - sy) |> loop |< (32 - ey) * len + 4*2
1346   in
1347     fun ~iload ~kload ->
1348       let iy = iload *. 32.0 |> ceil |> truncate |> max 0 |> min 32
1349       and ky = kload *. 32.0 |> ceil |> truncate |> max 0 |> min 32 in
1350       let ey =
1351         if ky < iy
1352         then
1353           (fill kl 0 ky; fill il ky iy; iy)
1354         else
1355           (fill kl 0 ky; ky)
1356       in
1357         fill el ey 32;
1358         X.seticon data;
1359 ;;
1360
1361 let create_bars h kactive iactive =
1362   let getlk kload =
1363     if !Args.sepstat
1364     then
1365       let sum = kload.user +. kload.nice +. kload.sys
1366         +. kload.intr +. kload.softirq
1367       in
1368         [ (1.0, 1.0, 0.0), kload.user
1369         ; (0.0, 0.0, 1.0), kload.nice
1370         ; (1.0, 0.0, 0.0), kload.sys
1371         ; (1.0, 1.0, 1.0), kload.intr
1372         ; (0.75, 0.5, 0.5), (1.0 -. kload.iowait) -. sum
1373         ; (0.0, 1.0, 0.0), kload.all -. kload.iowait -. kload.softirq
1374         ]
1375     else
1376       [ (1.0, 0.0, 0.0), 1.0 -. kload.idle ]
1377   in
1378   let getli iload =
1379     [ (1.0, 1.0, 0.0), 1.0 -. iload.all ]
1380   in
1381   let barw = !Args.barw in
1382   let nfuncs =
1383     (fun () -> ()), (fun _ _ -> ()), (fun _ _ -> ())
1384   in
1385   let kd, kr, ku =
1386     if kactive
1387     then
1388       let module Bar =
1389         Bar (struct
1390           let x = 3
1391           let y = 0
1392           let w = (if iactive then barw / 2 else barw) - 3
1393           let h = h
1394           let getl = getlk
1395         end)
1396       in
1397         Bar.display, Bar.reshape, Bar.update
1398     else
1399       nfuncs
1400   in
1401   let id, ir, iu =
1402     if iactive
1403     then
1404       let module Bar =
1405         Bar (struct
1406           let x = (if kactive then barw / 2 else 0) + 3
1407           let y = 0
1408           let w = (if kactive then barw / 2 else barw) - 3
1409           let h = h
1410           let getl = getli
1411         end)
1412       in
1413         Bar.display, Bar.reshape, Bar.update
1414     else
1415       nfuncs
1416   in
1417     if kactive
1418     then
1419       begin
1420       if iactive
1421       then
1422         let d () = kd (); id () in
1423         let r w h = kr w h; ir w h in
1424         let u d k i = ku d k; iu d i in
1425           d, r, u
1426       else
1427         kd, kr, (fun d k _ -> ku d k)
1428       end
1429     else
1430       begin
1431         if iactive
1432         then
1433           id, ir, (fun d _ i -> iu d i)
1434         else
1435           (fun () -> ()), (fun _ _ -> ()), (fun _ _ _ -> ())
1436       end
1437 ;;
1438
1439 let main () =
1440   let _ = Glut.init [|""|] in
1441   let () = Args.init () in
1442   let () =
1443     if !Args.verbose
1444     then
1445       "detected " ^ string_of_int NP.nprocs ^ " CPUs" |> print_endline
1446   in
1447   let () = if !Args.gzh then Gzh.init !Args.verbose else () in
1448   let () = Delay.init !Args.timer !Args.gzh in
1449   let () = if !Args.niceval != 0 then NP.setnice !Args.niceval else () in
1450   let w = !Args.w
1451   and h = !Args.h in
1452   let fd = opendev !Args.devpath in
1453   let module FullV = View (struct let w = w let h = h end) in
1454   let winid = FullV.init () in
1455   let () = NP.fixwindow winid in
1456   let (kget, kfuncs), (iget, ifuncs), gl = create fd w h in
1457   let bar_update =
1458     List.iter FullV.add gl;
1459     if !Args.barw > 0
1460     then
1461       let (display, reshape, update) =
1462         create_bars h !Args.ksampler !Args.isampler
1463       in
1464         FullV.add (display, reshape, fun _ -> ());
1465         update
1466     else
1467       fun _ _ _ -> ()
1468   in
1469   let seticon = if !Args.icon then seticon () else fun ~iload ~kload -> () in
1470   let rec loop t1 () =
1471     let t2 = Unix.gettimeofday () in
1472     let dt = t2 -. t1 in
1473       if dt >= !Args.freq
1474       then
1475         let is = iget () in
1476         let ks = kget () in
1477         let rec loop2 load sample = function
1478           | [] -> load
1479           | (nr, calc, sampler) :: rest ->
1480               let cpuload = calc sample t1 t2 in
1481               let () =
1482                 let thisload = 1.0 -. (cpuload.all /. dt) in
1483                 let thisload = max 0.0 thisload in
1484                 if !Args.verbose
1485                 then
1486                   ("cpu load(" ^ string_of_int nr ^ "): "
1487                     ^ (thisload *. 100.0 |> string_of_float)
1488                   |> print_endline)
1489               in
1490               let load = add_stat load cpuload in
1491                 sampler.update dt cpuload.all;
1492                 loop2 load sample rest
1493         in
1494         let iload = loop2 zero_stat is ifuncs in
1495         let kload = loop2 zero_stat ks kfuncs in
1496           if !Args.debug
1497           then
1498             begin
1499               iload.all |> string_of_float |> prerr_endline;
1500               kload.all |> string_of_float |> prerr_endline;
1501             end
1502           ;
1503           seticon ~iload:iload.all ~kload:kload.all;
1504           bar_update dt kload iload;
1505           FullV.inc ();
1506           FullV.update ();
1507           FullV.func (Some (loop t2))
1508       else
1509         Delay.delay ()
1510   in
1511     FullV.func (Some (Unix.gettimeofday () |> loop));
1512     FullV.run ()
1513 ;;
1514
1515 let _ =
1516   try
1517     main ()
1518   with
1519     | Unix.Unix_error (e, s1, s2) ->
1520         Unix.error_message e |> eprintf "main failure: %s(%s): %s@." s1 s2
1521
1522     | exn ->
1523         Printexc.to_string exn |> eprintf "main failure: %s@."
1524 ;;