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