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