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 module NP = struct
  12   type sysinfo =
  13       { uptime: int64
  14       ; loads: int64 * int64 * int64
  15       ; totalram: int64
  16       ; freeram: int64
  17       ; sharedram: int64
  18       ; bufferram: int64
  19       ; totalswap: int64
  20       ; freeswap: int64
  21       ; procs: int64
  22       }
  23
  24   external get_nprocs : unit -> int = "ml_get_nprocs"
  25   external idletimeofday : Unix.file_descr -> int -> float array
  26     = "ml_idletimeofday"
  27   external sysinfo : unit -> sysinfo = "ml_sysinfo"
  28   external waitalrm : unit -> unit = "ml_waitalrm"
  29   external get_hz : unit -> int = "ml_get_hz"
  30   external setnice : int -> unit = "ml_nice"
  31   external delay : float -> unit = "ml_delay"
  32   external is_winnt : unit -> bool = "ml_is_winnt"
  33
  34   let winnt = is_winnt ()
  35
  36   let user    = 0
  37   let nice    = 1
  38   let sys     = 2
  39   let idle    = 3
  40   let iowait  = 4
  41   let intr    = 5
  42   let softirq = 6
  43
  44   let hz = get_hz () |> float
  45
  46   let jiffies_to_sec j =
  47     float j /. hz
  48
  49   let parse_uptime () =
  50     let ic = open_in "/proc/uptime" in
  51     let vals = Scanf.fscanf ic "%f %f" (fun u i -> (u, i)) in
  52       close_in ic;
  53       vals
  54
  55   let nprocs = get_nprocs ()
  56
  57   let rec parse_int_cont s pos =
  58     let slen = String.length s in
  59     let pos =
  60       let rec skipws pos =
  61         if pos = slen
  62         then pos
  63         else
  64           if String.get s pos = ' '
  65           then succ pos |> skipws
  66           else pos
  67       in skipws pos
  68     in
  69     let endpos =
  70       try String.index_from s pos ' '
  71       with Not_found -> slen
  72     in
  73     let i = endpos - pos |> String.sub s pos |> int_of_string in
  74       if endpos = slen
  75       then
  76         `last i
  77       else
  78         `more (i, fun () -> succ endpos |> parse_int_cont s)
  79
  80   let parse_cpul s =
  81     let rec tolist accu = function
  82       | `last i -> i :: accu
  83       | `more (i, f) -> f () |> tolist (i :: accu)
  84     in
  85     let index = String.index s ' ' in
  86     let cpuname = String.sub s 0 index in
  87     let vals = parse_int_cont s (succ index) |> tolist [] in
  88     let vals = List.rev |<
  89         if List.length vals < 7
  90         then
  91           0 :: 0 :: 0 :: 0 :: vals
  92         else
  93           vals
  94     in
  95       cpuname, Array.of_list vals
  96
  97   let parse_stat () =
  98     if winnt
  99     then
 100       fun () ->
 101         let ia = idletimeofday Unix.stdin nprocs in
 102         let rec convert accu total n =
 103           if n = nprocs
 104           then
 105             let t = total *. hz |> truncate in
 106             let a = "cpu", Array.make 7 t in
 107               a :: List.rev accu
 108           else
 109             let i = Array.get ia n in
 110             let total = total +. i in
 111             let t = i *. hz |> truncate in
 112             let v = "cpu" ^ string_of_int n, Array.make 7 t in
 113               convert |< v :: accu |< total |< succ n
 114         in
 115           convert [] 0.0 0
 116     else
 117       fun () ->
 118         let ic = open_in "/proc/stat" in
 119         let rec loop i accu =
 120           if i = -1
 121           then List.rev accu
 122           else (input_line ic |> parse_cpul) :: accu |> loop (pred i)
 123         in
 124         let ret = loop nprocs [] in
 125           close_in ic;
 126           ret
 127
 128   let getselfdir () =
 129     try
 130       Filename.dirname |< Unix.readlink "/proc/self/exe"
 131     with exn ->
 132       "./"
 133 end
 134
 135 module Args = struct
 136   let banner =
 137     [ "Amazing Piece of Code by insanely gifted programmer, Version 0.95"
 138     ; "Motivation by: gzh and afs"
 139     ; "usage: "
 140     ] |> String.concat "\n"
 141
 142   let freq     = ref 1.0
 143   let interval = ref 15.0
 144   let devpath  = NP.getselfdir () |> Filename.concat |< "itc" |> ref
 145   let pgrid    = ref 10
 146   let sgrid    = ref 10
 147   let w        = ref 400
 148   let h        = ref 200
 149   let verbose  = ref false
 150   let delay    = ref 0.04
 151   let ksampler = ref true
 152   let barw     = ref 100
 153   let bars     = ref 50
 154   let sigway   = ref true
 155   let niceval  = ref 0
 156   let gzh      = ref false
 157   let scalebar = ref false
 158   let timer    = ref 100
 159   let debug    = ref false
 160   let poly     = ref false
 161   let uptime   = ref false
 162   let icon     = ref false
 163   let labels   = ref true
 164   let mgrid    = ref false
 165
 166   let pad n s =
 167     let l = String.length s in
 168       if l >= n
 169       then
 170         s
 171       else
 172         let d = String.make n ' ' in
 173           StringLabels.blit ~src:s ~dst:d
 174             ~src_pos:0 ~len:l
 175             ~dst_pos:0;
 176           d
 177
 178   let dA tos s {contents=v} = s ^ " (" ^ tos v ^ ")"
 179   let dF = dA |< sprintf "%4.2f"
 180   let dB = dA string_of_bool
 181   let dcB = dA (fun b -> not b |> string_of_bool)
 182   let dI = dA string_of_int
 183   let dS = dA (fun s -> "`" ^ String.escaped s ^ "'")
 184
 185   let sF opt r doc =
 186     "-" ^ opt, Arg.Set_float r, pad 9 "<float> " ^ doc |> dF |< r
 187
 188   let sI opt r doc =
 189     "-" ^ opt, Arg.Set_int r, pad 9 "<int> " ^ doc |> dI |< r
 190
 191   let sB opt r doc =
 192     "-" ^ opt, Arg.Set r, pad 9 "" ^ doc |> dB |< r
 193
 194   let cB opt r doc =
 195     "-" ^ opt, Arg.Clear r, pad 9 "" ^ doc |> dcB |< r
 196
 197   let sS opt r doc =
 198     "-" ^ opt, Arg.Set_string r, pad 9 "<string> " ^ doc |> dS |< r
 199
 200   let init () =
 201     let opts =
 202       [ sF "f" freq "sampling frequency in seconds"
 203       ; sF "D" delay "refresh delay in seconds"
 204       ; sF "i" interval "history interval in seconds"
 205       ; sI "p" pgrid "percent grid"
 206       ; sI "s" sgrid "history grid"
 207       ; sI "w" w "width"
 208       ; sI "h" h "height"
 209       ; sI "b" barw "bar width"
 210       ; sI "B" bars "number of CPU bars"
 211       ; sI "n" niceval "value to renice self on init"
 212       ; sI "t" timer "timer frequency in herz"
 213       ; sS "d" devpath "path to itc device"
 214       ; cB "k" ksampler |< "do not use kernel sampler"
 215         ^ (if NP.winnt then "" else " (`/proc/[stat|uptime]')")
 216       ; sB "g" gzh "gzh way (does not quite work yet)"
 217       ; sB "u" uptime
 218         "use `uptime' instead of `stat' as kernel sampler (UP only)"
 219       ; sB "v" verbose "verbose"
 220       ; sB "S" sigway "sigwait delay method"
 221       ; sB "c" scalebar "constant bar width"
 222       ; sB "P" poly "use filled area instead of lines"
 223       ; sB "I" icon "use icon (hack)"
 224       ; cB "l" labels "do not draw labels"
 225       ; sB "m" mgrid "moving grid"
 226       ]
 227     in
 228     let opts =
 229       if NP.winnt
 230       then
 231         begin
 232           let nixopts = ["-n"; "-u"; "-d"; "-I"; "-S"; "-g"] in
 233             prerr_endline "Only kernel sampler is available on Windows";
 234             List.filter (fun (s, _, _) -> List.mem s nixopts |> not) opts
 235         end
 236       else
 237         opts
 238     in
 239       Arg.parse opts
 240         (fun s ->
 241           "don't know what to do with " ^ s |> prerr_endline;
 242           exit 100
 243         )
 244         banner
 245 end
 246
 247 module Gzh = struct
 248   let lim = ref 0
 249   let stop = ref false
 250   let refdt = ref 0.0
 251
 252   let rec furious_cycle i =
 253     if not !stop && i > 0
 254     then pred i |> furious_cycle
 255     else (i, Unix.gettimeofday ())
 256
 257   let init verbose =
 258     let t = 0.5 in
 259     let it = { Unix.it_interval = t; it_value = t } in
 260     let tries = 1 in
 261     let handler =
 262       let n = ref tries in
 263         fun _ ->
 264           decr n;
 265           stop := !n = 0;
 266     in
 267     let sign = Sys.sigalrm in
 268     let oldh = Sys.signal sign |< Sys.Signal_handle handler in
 269     let oldi = Unix.setitimer Unix.ITIMER_REAL it in
 270     let oldbp = Unix.sigprocmask Unix.SIG_BLOCK [sign] in
 271     let () = NP.waitalrm () in
 272     let () = stop := false in
 273     let oldup = Unix.sigprocmask Unix.SIG_UNBLOCK [sign] in
 274     let t1 = Unix.gettimeofday () in
 275     let n, t2 = furious_cycle max_int in
 276     let () = refdt := t2 -. t1 in
 277     let () = lim := tries * (max_int - n) in
 278     let () = if verbose then
 279         begin
 280           printf "Completed %d iterations in %f seconds@." !lim !refdt
 281         end in
 282     let _ = Unix.sigprocmask Unix.SIG_UNBLOCK oldup in
 283     let _ = Unix.setitimer Unix.ITIMER_REAL oldi in
 284     let _ = Unix.sigprocmask Unix.SIG_BLOCK oldbp in
 285     let _ = Sys.signal sign oldh in
 286       ()
 287   ;;
 288
 289   let gen f =
 290     let thf () =
 291       NP.setnice 20;
 292       stop := false;
 293       let l = ref 0 in
 294       let rec loop t1 =
 295         let _, t2 = furious_cycle !lim in
 296         let dt = t2 -. t1 in
 297           incr l;
 298           if !Args.debug && !l > 10
 299           then
 300             begin
 301               printf "Completed %d iterations in %f seconds load %f@."
 302                 !lim dt |< !refdt /. dt;
 303               l := 0;
 304             end
 305           ;
 306           !refdt /. dt |> f;
 307           loop t2
 308       in
 309         Unix.gettimeofday () |> loop
 310     in
 311     let _ = Thread.create thf () in
 312       ()
 313   ;;
 314 end
 315
 316 let oohz oohz fn =
 317   let prev = ref 0.0 in
 318     fun () ->
 319       let a = !prev in
 320       let b = Unix.gettimeofday () in
 321         if b -. a > oohz
 322         then
 323           begin
 324             prev := b;
 325             fn ()
 326           end
 327
 328 module Delay = struct
 329   let sighandler signr = ()
 330
 331   let winfreq = ref 0.0
 332
 333   let init freq gzh =
 334     if NP.winnt
 335     then
 336       winfreq := 1.0 /. float freq
 337     else
 338       let () =
 339         Sys.Signal_handle sighandler |> Sys.set_signal Sys.sigalrm;
 340         if !Args.sigway
 341         then
 342           let l = if gzh then [Sys.sigprof; Sys.sigvtalrm] else [] in
 343             Unix.sigprocmask Unix.SIG_BLOCK |< Sys.sigalrm :: l |> ignore;
 344       ;
 345       in
 346       let v = 1.0 /. float freq in
 347       let t = { Unix.it_interval = v; it_value = v } in
 348       let _ = Unix.setitimer Unix.ITIMER_REAL t in
 349         ()
 350
 351   let delay () =
 352     if NP.winnt
 353     then
 354       NP.delay !winfreq
 355     else
 356       begin
 357         if !Args.sigway
 358         then
 359           NP.waitalrm ()
 360         else
 361           begin
 362             try let _ = Unix.select [] [] [] ~-.1.0 in ()
 363             with Unix.Unix_error (Unix.EINTR, _, _) -> ()
 364           end
 365       end
 366 end
 367
 368 type sampler =
 369     { color : Gl.rgb;
 370       getyielder : unit -> unit -> float option;
 371       update : float -> float -> float -> float -> unit;
 372     }
 373
 374 module Sampler(T : sig val nsamples : int val freq : float end) =
 375 struct
 376   let nsamples = T.nsamples + 1
 377   let samples = Array.create nsamples 0.0
 378   let head = ref 0
 379   let tail = ref 0
 380   let active = ref 0
 381
 382   let update v n =
 383     let n = min nsamples n in
 384     let rec loop i j =
 385       if j = 0
 386       then ()
 387       else
 388         let i = if i = nsamples then 0 else i in
 389           Array.set samples i v;
 390           loop (succ i) (pred j)
 391     in
 392     let () = loop !head n in
 393     let () = head := (!head + n) mod nsamples in
 394     let () = active := min (!active + n) nsamples in
 395       ();
 396   ;;
 397
 398   let getyielder () =
 399     let tail =
 400       let d = !head - !active in
 401         if d < 0
 402         then nsamples + d
 403         else d
 404     in
 405     let ry = ref (fun () -> assert false) in
 406     let rec yield i () =
 407       if i = !active
 408       then None
 409       else
 410         begin
 411           ry := succ i |> yield;
 412           Some ((i + tail) mod nsamples |> Array.get samples)
 413         end
 414     in
 415       ry := yield 0;
 416       (fun () -> !ry ());
 417   ;;
 418
 419   let update t1 t2 i1 i2 =
 420     let d = t2 -. t1 in
 421     let i = i2 -. i1 in
 422     let isamples = d /. T.freq |> truncate in
 423     let l = 1.0 -. (i /. d) in
 424       update l isamples;
 425   ;;
 426 end
 427
 428 module type ViewSampler =
 429 sig
 430   val getyielder : unit -> unit -> float option
 431   val update : float -> float -> float -> float -> unit
 432 end
 433
 434 module type View =
 435 sig
 436   val x : int
 437   val y : int
 438   val w : int
 439   val h : int
 440   val sgrid : int
 441   val pgrid : int
 442   val freq : float
 443   val interval : float
 444   val samplers : sampler list
 445 end
 446
 447 module View(V: sig val w : int val h : int end) = struct
 448   let ww = ref 0
 449   let wh = ref 0
 450   let funcs = ref []
 451
 452   let keyboard ~key ~x ~y =
 453     if key = 27 || key = Char.code 'q'
 454     then exit 0
 455
 456   let add dri =
 457     funcs := dri :: !funcs
 458
 459   let display () =
 460     GlClear.clear [`color];
 461     List.iter (fun (display, _, _) -> display ()) !funcs;
 462     Glut.swapBuffers ()
 463
 464   let reshape ~w ~h =
 465     ww := w;
 466     wh := h;
 467     List.iter (fun (_, reshape, _) -> reshape w h) !funcs;
 468     GlClear.clear [`color];
 469     GlMat.mode `modelview;
 470     GlMat.load_identity ();
 471     GlMat.mode `projection;
 472     GlMat.load_identity ();
 473     GlMat.rotate ~y:1.0 ~angle:180.0 ();
 474     GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
 475     GlMat.scale ~x:2.0 ~y:2.0 ();
 476     Glut.postRedisplay ()
 477
 478   let init () =
 479     let () =
 480       Glut.initDisplayMode ~double_buffer:true ();
 481       Glut.initWindowSize V.w V.h
 482     in
 483     let winid = Glut.createWindow "APC" in
 484       Glut.displayFunc display;
 485       Glut.reshapeFunc reshape;
 486       Glut.keyboardFunc keyboard;
 487       GlDraw.color (1.0, 1.0, 0.0);
 488       winid;
 489   ;;
 490
 491   let inc () = List.iter (fun (_, _, inc) -> inc ()) !funcs
 492   let update = Glut.postRedisplay
 493   let func = Glut.idleFunc
 494   let run = Glut.mainLoop
 495 end
 496
 497 module Bar(T: sig val barw : int val bars : int end) = struct
 498   let nbars = T.bars
 499   let kload = ref 0.0
 500   let iload = ref 0.0
 501   let vw = ref 0
 502   let vh = ref 0
 503   let sw = float T.barw /. float !Args.w
 504   let bw = ref 0
 505   let m = 1
 506   let fw = 3 * Glut.bitmapWidth font (Char.code 'W')
 507   let ksepsl, isepsl =
 508     let base = GlList.gen_lists ~len:2 in
 509       GlList.nth base ~pos:0,
 510       GlList.nth base ~pos:1
 511
 512   let getlr = function
 513     | `k -> 0.01, 0.49
 514     | `i -> 0.51, 0.99
 515
 516   let seps ki =
 517     let xl, xr = getlr ki in
 518     let y = 18 in
 519     let h = !vh - 15 - y in
 520     let () = GlDraw.viewport m y !bw h in
 521     let () =
 522       GlMat.push ();
 523       GlMat.load_identity ();
 524       GlMat.rotate ~y:1.0 ~angle:180.0 ();
 525       GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
 526       GlMat.scale ~x:2.0 ~y:(2.0 /. float h) ()
 527     in
 528     let barm = 1 in
 529     let mspace = barm * nbars in
 530     let barh = (h + 66 - mspace / 2) / nbars |> float in
 531     let barm = float barm in
 532     let rec loop i yb =
 533       if i = T.bars
 534       then ()
 535       else
 536         let yt = yb +. barm in
 537         let yn = yt +. barh in
 538           GlDraw.vertex2 (xl, yb);
 539           GlDraw.vertex2 (xl, yt);
 540           GlDraw.vertex2 (xr, yt);
 541           GlDraw.vertex2 (xr, yb);
 542           succ i |> loop |< yn
 543     in
 544       GlDraw.color (0.0, 0.0, 0.0);
 545       GlDraw.begins `quads;
 546       loop 0 barh;
 547       GlDraw.ends ();
 548       GlMat.pop ();
 549   ;;
 550
 551   let reshape w h =
 552     vw := w;
 553     vh := h;
 554     bw :=
 555       if !Args.scalebar
 556       then
 557         (float w *. sw |> truncate) - m
 558       else
 559         T.barw - m
 560     ;
 561
 562     GlList.begins ksepsl `compile;
 563     seps `k;
 564     GlList.ends ();
 565
 566     GlList.begins isepsl `compile;
 567     seps `i;
 568     GlList.ends ();
 569   ;;
 570
 571   let drawseps = function
 572     | `k -> GlList.call ksepsl
 573     | `i -> GlList.call isepsl
 574   ;;
 575
 576   let display () =
 577     let kload = min !kload 1.0 |> max 0.0 in
 578     let iload = min !iload 1.0 |> max 0.0 in
 579     let () = GlDraw.viewport m 0 !bw 15 in
 580     let () =
 581       GlDraw.color (1.0, 1.0, 1.0);
 582       let kload = 100.0 *. kload in
 583       let iload = 100.0 *. iload in
 584       let () =
 585         GlMat.push ();
 586         GlMat.load_identity ();
 587         GlMat.scale ~x:(1.0/.float !bw) ~y:(1.0/.30.0) ()
 588       in
 589       let ix = !bw / 2 - fw |> float in
 590       let kx = - (fw + !bw / 2) |> float in
 591       let () = sprintf "%5.2f" iload |> draw_string ix 0.0 in
 592       let () = sprintf "%5.2f" kload |> draw_string kx 0.0 in
 593       let () = GlMat.pop () in ()
 594     in
 595
 596     let y = 18 in
 597     let h = !vh - 15 - y in
 598     let () = GlDraw.viewport m y !bw h in
 599     let () =
 600       GlMat.push ();
 601       GlMat.load_identity ();
 602       GlMat.rotate ~y:1.0 ~angle:180.0 ();
 603       GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
 604       GlMat.scale ~x:2.0 ~y:(2.0 /. float h) ()
 605     in
 606     let drawbar load ki =
 607       let xl, xr = getlr ki in
 608       let drawquad yb yt =
 609         GlDraw.begins `quads;
 610         GlDraw.vertex2 (xl, yb);
 611         GlDraw.vertex2 (xl, yt);
 612         GlDraw.vertex2 (xr, yt);
 613         GlDraw.vertex2 (xr, yb);
 614         GlDraw.ends ()
 615       in
 616       let yt = float h *. load in
 617       let yb = 0.0 in
 618       let () = drawquad yb yt in
 619       let () = GlDraw.color (0.5, 0.5, 0.5) in
 620       let yb = yt in
 621       let yt = float h in
 622       let () = drawquad yb yt in
 623         drawseps ki
 624     in
 625       GlDraw.color (1.0, 1.0, 0.0);
 626       drawbar iload `k;
 627       GlDraw.color (1.0, 0.0, 0.0);
 628       drawbar kload `i;
 629       GlMat.pop ();
 630   ;;
 631
 632   let update kload' iload' =
 633     kload := kload' /. float NP.nprocs;
 634     iload := iload' /. float NP.nprocs;
 635   ;;
 636 end
 637
 638 module Graph (V: View) = struct
 639   let ox = if !Args.scalebar then 0 else !Args.barw
 640   let sw = float V.w /. float (!Args.w - ox)
 641   let sh = float V.h /. float !Args.h
 642   let sx = float (V.x - ox)  /. float V.w
 643   let sy = float V.y /. float V.h
 644   let vw = ref 0
 645   let vh = ref 0
 646   let vx = ref 0
 647   let vy = ref 0
 648   let scale = V.freq /. V.interval
 649   let gscale = 1.0 /. float V.sgrid
 650   let nsamples = ref 0
 651
 652   let fw, fh =
 653     if !Args.labels
 654     then 3 * Glut.bitmapWidth font (Char.code '%'), 20
 655     else 0, 10
 656
 657   let gridlist =
 658     let base = GlList.gen_lists ~len:1 in
 659       GlList.nth base ~pos:0
 660
 661   let viewport typ =
 662     let ox = if !Args.scalebar then 0 else !Args.barw in
 663     let x, y, w, h =
 664       match typ with
 665         | `labels -> (!vx + ox, !vy + 5, fw, !vh - fh)
 666         | `graph  -> (!vx + fw + 5 + ox, !vy + 5, !vw - fw - 10, !vh - fh)
 667     in
 668       GlDraw.viewport x y w h;
 669   ;;
 670
 671   let sgrid () =
 672     for i = 0 to V.sgrid
 673     do
 674       let x = if i = 0 then 0.0009 else float i *. gscale in
 675         GlDraw.vertex ~x ~y:0.0 ();
 676         GlDraw.vertex ~x ~y:1.0 ();
 677     done;
 678   ;;
 679
 680   let grid () =
 681     viewport `graph;
 682     GlDraw.line_width 1.0;
 683     GlDraw.color (0.0, 1.0, 0.0);
 684     GlDraw.begins `lines;
 685     if !Args.mgrid
 686     then
 687       begin
 688         GlDraw.vertex2 (0.0009, 0.0);
 689         GlDraw.vertex2 (0.0009, 1.0);
 690         GlDraw.vertex2 (1.0000, 0.0);
 691         GlDraw.vertex2 (1.0000, 1.0);
 692       end
 693     else
 694       sgrid ()
 695     ;
 696     let () =
 697       let lim = 100 / V.pgrid in
 698         for i = 0 to lim
 699         do
 700           let y = (i * V.pgrid |> float) /. 100.0 in
 701           let y = if i = lim then y -. 0.0009 else y in
 702             GlDraw.vertex ~x:0.0 ~y ();
 703             GlDraw.vertex ~x:1.0 ~y ();
 704         done;
 705     in
 706     let () = GlDraw.ends () in
 707       if !Args.labels
 708       then
 709         begin
 710           viewport `labels;
 711           GlDraw.color (1.0, 1.0, 1.0);
 712           let ohp = 100.0 in
 713             for i = 0 to 100 / V.pgrid
 714             do
 715               let p = i * V.pgrid in
 716               let y = float p /. ohp in
 717               let s = Printf.sprintf "%3d%%" p in
 718                 draw_string 1.0 y s
 719             done
 720         end
 721   ;;
 722
 723   let reshape w h =
 724     let wxsw = float (w - ox) *. sw
 725     and hxsh = float h *. sh in
 726       vw := wxsw |> truncate;
 727       vh := hxsh |> truncate;
 728       vx := wxsw *. sx |> truncate;
 729       vy := hxsh *. sy |> truncate;
 730       GlList.begins gridlist `compile;
 731       grid ();
 732       GlList.ends ();
 733   ;;
 734
 735   let swap =
 736     Glut.swapBuffers |> oohz !Args.delay;
 737   ;;
 738
 739   let inc () = incr nsamples
 740
 741   let mgrid () =
 742     GlDraw.line_width 1.0;
 743     GlDraw.color (0.0, 1.0, 0.0);
 744     GlDraw.begins `lines;
 745     let offset =
 746       ((pred !nsamples |> float) *. scale /. gscale |> modf |> fst) *. gscale
 747     in
 748       for i = 0 to pred V.sgrid
 749       do
 750         let x = offset +. float i *. gscale in
 751           GlDraw.vertex ~x ~y:0.0 ();
 752           GlDraw.vertex ~x ~y:1.0 ();
 753       done;
 754       GlDraw.ends ();
 755   ;;
 756
 757   let display () =
 758     GlList.call gridlist;
 759     viewport `graph;
 760     if !Args.mgrid then mgrid ();
 761     GlDraw.line_width 1.5;
 762
 763     let sample sampler =
 764       GlDraw.color sampler.color;
 765       let () =
 766         if not !Args.poly
 767         then GlDraw.begins `line_strip
 768         else
 769           begin
 770             GlDraw.begins `polygon;
 771             GlDraw.vertex2 (0.0, 0.0);
 772           end
 773       in
 774       let yield = sampler.getyielder () in
 775       let rec loop last i =
 776         match yield () with
 777           | Some y as opty ->
 778               let x = float i *. scale in
 779                 GlDraw.vertex ~x ~y ();
 780                 loop opty (succ i)
 781           | None ->
 782               if !Args.poly
 783               then
 784                 match last with
 785                   | None -> ()
 786                   | Some y ->
 787                       let x = float (pred i) *. scale in
 788                         GlDraw.vertex ~x ~y:0.0 ()
 789       in
 790         loop None 0;
 791         GlDraw.ends ();
 792     in
 793       List.iter sample V.samplers;
 794   ;;
 795
 796   let funcs = display, reshape, inc
 797 end
 798
 799 let getplacements w h n barw =
 800   let sr = float n |> sqrt |> ceil |> truncate in
 801   let d = n / sr in
 802   let r = if n mod sr = 0 then 0 else 1 in
 803   let x, y =
 804     if w - barw > h
 805     then
 806       sr + r, d
 807     else
 808       d, sr + r
 809   in
 810   let w' = w - barw in
 811   let h' = h in
 812   let vw = w' / x in
 813   let vh = h' / y in
 814   let rec loop accu i =
 815     if i = n
 816     then accu
 817     else
 818       let yc = i / x in
 819       let xc = i mod x in
 820       let xc = xc * vw + barw in
 821       let yc = yc * vh in
 822         (i, xc, yc) :: accu |> loop |< succ i
 823   in
 824     loop [] 0, vw, vh
 825
 826 let create fd w h =
 827   let module S =
 828       struct
 829         let freq = !Args.freq
 830         let nsamples = !Args.interval /. freq |> ceil |> truncate
 831       end
 832   in
 833   let placements, vw, vh = getplacements w h NP.nprocs !Args.barw in
 834
 835   let iget () = NP.idletimeofday fd NP.nprocs in
 836   let is = iget () in
 837
 838   let kget () =
 839     let gks = NP.parse_stat () in
 840       gks () |> Array.of_list
 841   in
 842   let ks = kget () in
 843
 844   let crgraph (kaccu, iaccu, gaccu) (i, x, y) =
 845     let module Si = Sampler (S) in
 846     let isampler =
 847       { getyielder = Si.getyielder
 848       ; color = (1.0, 1.0, 0.0)
 849       ; update = Si.update
 850       }
 851     in
 852     let (kcalc, ksampler) =
 853       let module Sc = Sampler (S) in
 854       let sampler =
 855         { getyielder = Sc.getyielder
 856         ; color = (1.0, 0.0, 0.0)
 857         ; update = Sc.update
 858         }
 859       in
 860       let calc =
 861         if !Args.gzh
 862         then
 863           let d = ref 0.0 in
 864           let f d' = d := d' in
 865           let () = Gzh.gen f in
 866             fun _ _ _ -> (0.0, !d)
 867         else
 868           if !Args.uptime
 869           then
 870             let (u1, i1) = NP.parse_uptime () in
 871             let u1 = ref u1
 872             and i1 = ref i1 in
 873               fun _ _ _ ->
 874                 let (u2, i2) = NP.parse_uptime () in
 875                 let du = u2 -. !u1
 876                 and di = i2 -. !i1 in
 877                   u1 := u2;
 878                   i1 := i2;
 879                   (0.0, di /. du)
 880           else
 881             let i' = if i = NP.nprocs then 0 else succ i in
 882             let n = NP.idle in
 883             let g ks = Array.get ks i' |> snd |> Array.get |< n in
 884             let i1 = g ks |> ref in
 885               fun ks t1 t2 ->
 886                 let i2 = g ks in
 887                 let i1' = NP.jiffies_to_sec !i1
 888                 and i2' = NP.jiffies_to_sec i2 in
 889                   i1 := i2;
 890                   (i1', i2')
 891       in
 892         calc, sampler
 893     in
 894     let module V =
 895         struct
 896           let x = x
 897           let y = y
 898           let w = vw
 899           let h = vh
 900           let freq = S.freq
 901           let interval = !Args.interval
 902           let pgrid = !Args.pgrid
 903           let sgrid = !Args.sgrid
 904           let samplers =
 905             if !Args.ksampler
 906             then [isampler; ksampler]
 907             else [isampler]
 908         end
 909     in
 910     let module Graph = Graph (V) in
 911     let icalc =
 912       let i1 = Array.get is i |> ref in
 913         fun is t1 t2 ->
 914           let i2 = Array.get is i in
 915           let i1' = !i1 in
 916             i1 := i2;
 917             (i1', i2)
 918     in
 919     let kaccu =
 920       if !Args.ksampler
 921       then (i, kcalc, ksampler) :: kaccu
 922       else kaccu
 923     in
 924       kaccu, (i, icalc, isampler) :: iaccu, Graph.funcs :: gaccu
 925   in
 926   let kl, il, gl = List.fold_left crgraph ([], [], []) placements in
 927     ((if kl == [] then (fun () -> [||]) else kget), kl), (iget, il), gl
 928
 929 let opendev path =
 930   if NP.winnt
 931   then
 932     Unix.stdout
 933   else
 934     try
 935       Unix.openfile path [Unix.O_RDONLY] 0
 936     with
 937       | Unix.Unix_error (Unix.ENODEV, s1, s2) ->
 938           eprintf "Could not open ITC device %S:\n%s(%s): %s)\n"
 939             path s1 s2 |< Unix.error_message Unix.ENODEV;
 940           eprintf "(perhaps the module is not loaded?)@.";
 941           exit 100
 942
 943       | Unix.Unix_error (Unix.ENOENT, s1, s2) ->
 944           eprintf "Could not open ITC device %S:\n%s(%s): %s\n"
 945             path s1 s2 |< Unix.error_message Unix.ENOENT;
 946           exit 100
 947
 948       | exn ->
 949           eprintf "Could not open ITC device %S:\n%s\n"
 950             path |< Printexc.to_string exn;
 951           exit 100
 952
 953 let seticon () =
 954   let module X = struct external seticon : string -> unit = "ml_seticon" end in
 955   let len = 32*4 in
 956   let data = String.create |< 32*len + 2*4 in
 957   let line r g b a =
 958     let r = Char.chr r
 959     and g = Char.chr g
 960     and b = Char.chr b
 961     and a = Char.chr a in
 962     let s = String.create len in
 963     let rec fill x =
 964       if x = len
 965       then s
 966       else
 967         begin
 968           x + 0 |> String.set s |< b;
 969           x + 1 |> String.set s |< g;
 970           x + 2 |> String.set s |< r;
 971           x + 3 |> String.set s |< a;
 972           x + 4 |> fill
 973         end
 974     in
 975       fill 0
 976   in
 977   let el = line 0x00 0x00 0x00 0xff
 978   and kl = line 0xff 0x00 0x00 0xff
 979   and il = line 0xff 0xff 0x00 0xff in
 980   let fill l sy ey =
 981     let src = l and dst = data and src_pos = 0 in
 982     let rec loop n dst_pos =
 983       if n > 0
 984       then
 985         begin
 986           StringLabels.blit ~src ~src_pos ~dst ~dst_pos ~len;
 987           pred n |> loop |< dst_pos + len
 988         end
 989     in
 990       (ey - sy) |> loop |< (32 - ey) * len + 4*2
 991   in
 992     fun ~iload ~kload ->
 993       let iy = iload *. 32.0 |> ceil |> truncate |> max 0 |> min 32
 994       and ky = kload *. 32.0 |> ceil |> truncate |> max 0 |> min 32 in
 995       let ey =
 996         if ky < iy
 997         then (fill kl 0 ky; fill il ky iy; iy)
 998         else (fill kl 0 ky; ky)
 999       in
1000         fill el ey 32;
1001         X.seticon data;
1002 ;;
1003
1004 let main () =
1005   let _ = Glut.init [|""|] in
1006   let () = Args.init () in
1007   let () = if !Args.gzh then Gzh.init !Args.verbose in
1008   let () = Delay.init !Args.timer !Args.gzh in
1009   let () = if !Args.niceval != 0 then NP.setnice !Args.niceval in
1010   let w = !Args.w
1011   and h = !Args.h in
1012   let fd = opendev !Args.devpath in
1013   let module FullV = View (struct let w = w let h = h end) in
1014   let _winid = FullV.init () in
1015   let (kget, kfuncs), (iget, ifuncs), gl = create fd w h in
1016   let bar_update =
1017     List.iter FullV.add gl;
1018     if !Args.barw > 0
1019     then
1020       let module Bar =
1021         Bar (struct let barw = !Args.barw let bars = !Args.bars end)
1022       in
1023         FullV.add (Bar.display, Bar.reshape, fun _ -> ());
1024         Bar.update
1025     else
1026       fun _ _ -> ()
1027   in
1028   let seticon = if !Args.icon then seticon () else fun ~iload ~kload -> () in
1029   let rec loop t1 () =
1030     let t2 = Unix.gettimeofday () in
1031     let dt = t2 -. t1 in
1032       if dt >= !Args.freq
1033       then
1034         let is = iget () in
1035         let ks = kget () in
1036         let rec loop2 load s = function
1037           | [] -> load
1038           | (nr, calc, sampler) :: rest ->
1039               let i1, i2 = calc s t1 t2 in
1040               let thisload = 1.0 -. ((i2 -. i1) /. dt) in
1041               let thisload = max 0.0 thisload in
1042               let () =
1043                 if !Args.verbose
1044                 then
1045                   ("cpu load(" ^ string_of_int nr ^ "): "
1046                     ^ (thisload *. 100.0 |> string_of_float)
1047                   |> print_endline)
1048               in
1049               let load = load +. thisload in
1050                 sampler.update t1 t2 i1 i2;
1051                 loop2 load s rest
1052         in
1053         let iload = loop2 0.0 is ifuncs in
1054         let kload = loop2 0.0 ks kfuncs in
1055           if !Args.debug
1056           then
1057             begin
1058               iload |> string_of_float |> prerr_endline;
1059               kload |> string_of_float |> prerr_endline;
1060             end
1061           ;
1062           seticon ~iload ~kload;
1063           bar_update kload iload;
1064           FullV.inc ();
1065           FullV.update ();
1066           FullV.func (Some (loop t2))
1067       else
1068         Delay.delay ()
1069   in
1070     FullV.func (Some (Unix.gettimeofday () |> loop));
1071     FullV.run ()
1072
1073 let _ =
1074   try main ()
1075   with
1076     | Unix.Unix_error (e, s1, s2) ->
1077         eprintf "%s(%s): %s@." s1 s2 |< Unix.error_message e
1078
1079     | exn ->
1080         Printexc.to_string exn |> eprintf "Exception: %s@."