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