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