apc.ml

   1 open Format
   2
   3 let (|>) x f = f x
   4 let (|<) f x = f x
   5
   6 let font = Glut.BITMAP_HELVETICA_12
   7 let draw_string ?(font=font) x y s =
   8   GlPix.raster_pos ~x ~y ();
   9   String.iter (fun c -> Glut.bitmapCharacter ~font ~c:(Char.code c)) s
  10 ;;
  11
  12 type stats =
  13     { all : float
  14     ; user : float
  15     ; nice : float
  16     ; sys : float
  17     ; idle : float
  18     ; iowait : float
  19     ; intr : float
  20     ; softirq : float
  21     }
  22 ;;
  23
  24 let zero_stat =
  25   { all = 0.0
  26   ; user = 0.0
  27   ; nice = 0.0
  28   ; sys = 0.0
  29   ; idle = 0.0
  30   ; iowait = 0.0
  31   ; intr = 0.0
  32   ; softirq = 0.0
  33   }
  34 ;;
  35
  36 let neg_stat a =
  37   { all = -.a.all
  38   ; user = -.a.user
  39   ; nice = -.a.nice
  40   ; sys = -.a.sys
  41   ; idle = -.a.idle
  42   ; iowait = -.a.iowait
  43   ; intr = -.a.intr
  44   ; softirq = -.a.softirq
  45   }
  46 ;;
  47
  48 let scale_stat a s =
  49   { all = a.all *. s
  50   ; user = a.user *. s
  51   ; nice = a.nice *. s
  52   ; sys = a.sys *. s
  53   ; idle = a.idle *. s
  54   ; iowait = a.iowait *. s
  55   ; intr = a.intr *. s
  56   ; softirq = a.softirq *. s
  57   }
  58 ;;
  59
  60 let add_stat a b =
  61   { all = a.all +. b.all
  62   ; user = a.user +. b.user
  63   ; nice = a.nice +. b.nice
  64   ; sys = a.sys +. b.sys
  65   ; idle = a.idle +. b.idle
  66   ; iowait = a.iowait +. b.iowait
  67   ; intr = a.intr +. b.intr
  68   ; softirq = a.softirq +. b.softirq
  69   }
  70 ;;
  71
  72 module NP =
  73 struct
  74   type sysinfo =
  75       { uptime: int64
  76       ; loads: int64 * int64 * int64
  77       ; totalram: int64
  78       ; freeram: int64
  79       ; sharedram: int64
  80       ; bufferram: int64
  81       ; totalswap: int64
  82       ; freeswap: int64
  83       ; procs: int64
  84       }
  85   ;;
  86
  87   type os =
  88       | Linux
  89       | Windows
  90       | Solaris
  91       | MacOSX
  92   ;;
  93
  94   external get_nprocs : unit -> int = "ml_get_nprocs"
  95   external idletimeofday : Unix.file_descr -> int -> float array
  96     = "ml_idletimeofday"
  97   external sysinfo : unit -> sysinfo = "ml_sysinfo"
  98   external waitalrm : unit -> unit = "ml_waitalrm"
  99   external get_hz : unit -> int = "ml_get_hz"
 100   external setnice : int -> unit = "ml_nice"
 101   external delay : float -> unit = "ml_delay"
 102   external os_type : unit -> os = "ml_os_type"
 103   external solaris_kstat : int -> float array = "ml_solaris_kstat"
 104   external macosx_host_processor_info : int -> float array =
 105       "ml_macosx_host_processor_info"
 106   external windows_processor_times : int -> float array =
 107       "ml_windows_processor_times"
 108
 109   let os_type = os_type ()
 110
 111   let winnt   = os_type = Windows
 112   let solaris = os_type = Solaris
 113   let linux   = os_type = Linux
 114   let macosx  = os_type = MacOSX
 115
 116   let user    = 0
 117   let nice    = 1
 118   let sys     = 2
 119   let idle    = 3
 120   let iowait  = 4
 121   let intr    = 5
 122   let softirq = 6
 123
 124   let hz = get_hz () |> float
 125
 126   let parse_uptime () =
 127     let ic = open_in "/proc/uptime" in
 128     let vals = Scanf.fscanf ic "%f %f" (fun u i -> (u, i)) in
 129       close_in ic;
 130       vals
 131   ;;
 132
 133   let nprocs = get_nprocs ()
 134
 135   let rec parse_int_cont s pos =
 136     let jiffies_to_sec j =
 137       float j /. hz
 138     in
 139     let slen = String.length s in
 140     let pos =
 141       let rec skipws pos =
 142         if pos = slen
 143         then
 144           pos
 145         else
 146           begin
 147             if String.get s pos = ' '
 148             then
 149               succ pos |> skipws
 150             else
 151               pos
 152           end
 153       in skipws pos
 154     in
 155     let endpos =
 156       try String.index_from s pos ' '
 157       with Not_found -> slen
 158     in
 159     let i = endpos - pos |> String.sub s pos
 160                          |> int_of_string
 161                          |> jiffies_to_sec in
 162       if endpos = slen
 163       then
 164         `last i
 165       else
 166         `more (i, fun () -> succ endpos |> parse_int_cont s)
 167   ;;
 168
 169   let parse_cpul s =
 170     let rec tolist accu = function
 171       | `last i -> i :: accu
 172       | `more (i, f) -> f () |> tolist (i :: accu)
 173     in
 174     let index = String.index s ' ' in
 175     let cpuname = String.sub s 0 index in
 176     let vals = parse_int_cont s (succ index) |> tolist [] in
 177     let vals = List.rev |<
 178         if List.length vals < 7
 179         then
 180           0.0 :: 0.0 :: 0.0 :: 0.0 :: vals
 181         else
 182           vals
 183     in
 184       cpuname, Array.of_list vals
 185   ;;
 186
 187   let parse_stat () =
 188     match os_type with
 189       | Windows ->
 190           (fun () ->
 191             let iukw = windows_processor_times nprocs in
 192             let rec create n ai ak au ad ar accu =
 193               if n = nprocs
 194               then
 195                 ("cpu", [| au; ad; ak; ai; 0.0; ar; 0.0 |]) :: List.rev accu
 196               else
 197                 let hdr = "cpu" ^ string_of_int n in
 198                 let o = n * 5 in
 199                 let i = Array.get iukw (o + 0) in
 200                 let k = Array.get iukw (o + 1) in
 201                 let u = Array.get iukw (o + 2) in
 202                 let d = Array.get iukw (o + 3) in
 203                 let r = Array.get iukw (o + 4) in
 204                 let ai = ai +. i in
 205                 let au = au +. u in
 206                 let ak = ak +. k in
 207                 let ad = ad +. d in
 208                 let ar = ar +. r in
 209                 let accu = (hdr, [| u; d; k; i; 0.0; r; 0.0 |]) :: accu in
 210                   create (succ n) ai ak au ad ar accu
 211             in
 212               create 0 0.0 0.0 0.0 0.0 0.0 []
 213           )
 214
 215       | Linux ->
 216           (fun () ->
 217             let ic = open_in "/proc/stat" in
 218             let rec loop i accu =
 219               if i = -1
 220               then
 221                 List.rev accu
 222               else
 223                 (input_line ic |> parse_cpul) :: accu |> loop (pred i)
 224             in
 225             let ret = loop nprocs [] in
 226               close_in ic;
 227               ret
 228           )
 229
 230       | Solaris ->
 231           (fun () ->
 232             let iukw = solaris_kstat nprocs in
 233             let rec create n ai au ak aw accu =
 234               if n = nprocs
 235               then
 236                 ("cpu", [| au; 0.0; ak; ai; aw; 0.0; 0.0 |]) :: List.rev accu
 237               else
 238                 let hdr = "cpu" ^ string_of_int n in
 239                 let o = n * 4 in
 240                 let i = Array.get iukw (o + 0) /. hz in
 241                 let u = Array.get iukw (o + 1) /. hz in
 242                 let k = Array.get iukw (o + 2) /. hz in
 243                 let w = Array.get iukw (o + 3) /. hz in
 244                 let ai = ai +. i in
 245                 let au = au +. u in
 246                 let ak = ak +. k in
 247                 let aw = aw +. w in
 248                 let accu = (hdr, [| u; 0.0; k; i; w; 0.0; 0.0 |]) :: accu in
 249                   create (succ n) ai au ak aw accu
 250             in
 251               create 0 0.0 0.0 0.0 0.0 []
 252           )
 253
 254       | MacOSX ->
 255           (fun () ->
 256             let iukn = macosx_host_processor_info nprocs in
 257             let rec create c ai au ak an accu =
 258               if c = nprocs
 259               then
 260                 ("cpu", [| au; an; ak; ai; 0.0; 0.0; 0.0 |]) :: List.rev accu
 261               else
 262                 let hdr = "cpu" ^ string_of_int c in
 263                 let o = c * 4 in
 264                 let i = Array.get iukn (o + 0) /. hz in
 265                 let u = Array.get iukn (o + 1) /. hz in
 266                 let k = Array.get iukn (o + 2) /. hz in
 267                 let n = Array.get iukn (o + 3) /. hz in
 268                 let ai = ai +. i in
 269                 let au = au +. u in
 270                 let ak = ak +. k in
 271                 let an = an +. n in
 272                 let accu = (hdr, [| u; n; k; i; 0.0; 0.0; 0.0 |]) :: accu in
 273                   create (succ c) ai au ak an accu
 274             in
 275               create 0 0.0 0.0 0.0 0.0 []
 276           )
 277   ;;
 278
 279   let getselfdir () =
 280     try
 281       Filename.dirname |< Unix.readlink "/proc/self/exe"
 282     with exn ->
 283       "./"
 284   ;;
 285 end
 286
 287 module Args =
 288 struct
 289   let banner =
 290     [ "Amazing Piece of Code by insanely gifted programmer, Version 1.00"
 291     ; "Motivation by: gzh and afs"
 292     ; "usage: "
 293     ] |> String.concat "\n"
 294
 295   let freq     = ref 1.0
 296   let interval = ref 15.0
 297   let devpath  = NP.getselfdir () |> Filename.concat |< "itc" |> ref
 298   let pgrid    = ref 10
 299   let sgrid    = ref 10
 300   let w        = ref 400
 301   let h        = ref 200
 302   let verbose  = ref false
 303   let delay    = ref 0.04
 304   let ksampler = ref true
 305   let isampler = ref true
 306   let barw     = ref 100
 307   let bars     = ref 50
 308   let sigway   = ref (NP.os_type != NP.MacOSX)
 309   let niceval  = ref 0
 310   let gzh      = ref false
 311   let scalebar = ref false
 312   let timer    = ref 100
 313   let debug    = ref false
 314   let poly     = ref false
 315   let uptime   = ref false
 316   let icon     = ref false
 317   let labels   = ref true
 318   let mgrid    = ref false
 319   let sepstat  = ref true
 320
 321   let pad n s =
 322     let l = String.length s in
 323       if l >= n
 324       then
 325         s
 326       else
 327         let d = String.make n ' ' in
 328           StringLabels.blit ~src:s ~dst:d
 329             ~src_pos:0 ~len:l
 330             ~dst_pos:0;
 331           d
 332   ;;
 333
 334   let sooo b = if b then "on" else "off"
 335   let dA tos s {contents=v} = s ^ " (" ^ tos v ^ ")"
 336   let dF = dA |< sprintf "%4.2f"
 337   let dB = dA sooo
 338   let dcB = dA sooo
 339   let dI = dA string_of_int
 340   let dS = dA (fun s -> "`" ^ String.escaped s ^ "'")
 341
 342   let sF opt r doc =
 343     "-" ^ opt, Arg.Set_float r, pad 9 "<float> " ^ doc |> dF |< r
 344   ;;
 345
 346   let sI opt r doc =
 347     "-" ^ opt, Arg.Set_int r, pad 9 "<int> " ^ doc |> dI |< r
 348   ;;
 349
 350   let sB opt r doc =
 351     "-" ^ opt, Arg.Set r, pad 9 "" ^ doc |> dB |< r
 352   ;;
 353
 354   let sS opt r doc =
 355     "-" ^ opt, Arg.Set_string r, pad 9 "<string> " ^ doc |> dS |< r
 356   ;;
 357
 358   let fB opt r doc =
 359     if r.contents
 360     then
 361       "-" ^ opt, Arg.Clear r, pad 9 "" ^ doc |> dB |< r
 362     else
 363       "-" ^ opt, Arg.Set r, pad 9 "" ^ doc |> dcB |< r
 364   ;;
 365
 366   let commonopts =
 367     [ sF "f" freq "sampling frequency in seconds"
 368     ; sF "D" delay "refresh delay in seconds"
 369     ; sF "i" interval "history interval in seconds"
 370     ; sI "p" pgrid "percent grid items"
 371     ; sI "s" sgrid "history grid items"
 372     ; sI "w" w "width"
 373     ; sI "h" h "height"
 374     ; sI "b" barw "bar width"
 375     ; sI "B" bars "number of CPU bars"
 376     ; sB "v" verbose "verbose"
 377     ; fB "C" sepstat "separate sys/nice/intr/iowait values (kernel sampler)"
 378     ; fB "c" scalebar "constant bar width"
 379     ; fB "P" poly "filled area instead of lines"
 380     ; fB "l" labels "labels"
 381     ; fB "m" mgrid "moving grid"
 382     ]
 383   ;;
 384
 385   let add_opts tail =
 386     let add_linux opts =
 387       sI "t" timer "timer frequency in herz"
 388       :: fB "I" icon "icon (hack)"
 389       :: sS "d" devpath "path to itc device"
 390       :: (fB "k" ksampler |< "kernel sampler (`/proc/[stat|uptime]')")
 391       :: (fB "M" isampler |< "idle sampler")
 392       :: (fB "u" uptime
 393              "`uptime' instead of `stat' as kernel sampler (UP only)")
 394       :: sI "n" niceval "value to renice self on init"
 395       :: fB "g" gzh "gzh way (does not quite work yet)"
 396       :: fB "S" sigway "sigwait delay method"
 397       :: opts
 398     in
 399     let add_solaris opts =
 400       isampler := false;
 401       fB "I" icon "icon (hack)"
 402       :: opts
 403     in
 404     let add_windows opts =
 405       isampler := false;
 406       (fB "k" ksampler |< "kernel sampler (ZwQuerySystemInformation)")
 407       :: (fB "M" isampler |< "idle sampler (PMC based)")
 408       :: opts
 409     in
 410     let add_macosx opts =
 411       isampler := false;
 412       fB "g" gzh "gzh way (does not quite work yet)"
 413       :: opts
 414     in
 415       match NP.os_type with
 416         | NP.Linux -> add_linux tail
 417         | NP.Windows -> add_windows tail
 418         | NP.Solaris -> add_solaris tail
 419         | NP.MacOSX -> add_macosx tail
 420   ;;
 421
 422   let init () =
 423     let opts = add_opts commonopts in
 424       Arg.parse opts
 425         (fun s ->
 426           raise (Arg.Bad
 427                     ("Invocation error: Don't know what to do with " ^ s));
 428         )
 429         banner
 430       ;
 431       let cp {contents=v} s =
 432         if v <= 0
 433         then (prerr_string s; prerr_endline " must be positive"; exit 1)
 434       in
 435       let cpf {contents=v} s =
 436         if v <= 0.0
 437         then (prerr_string s; prerr_endline " must be positive"; exit 1)
 438       in
 439         cp w "Width";
 440         cp h "Height";
 441         cp pgrid "Number of percent grid items";
 442         cp sgrid "Number of history grid items";
 443         cp bars "Number of CPU bars";
 444         cp timer "Timer frequency";
 445         cpf freq "Frequency";
 446         cpf delay "Delay";
 447         cpf interval "Interval";
 448         if not (!isampler || !ksampler)
 449         then
 450           barw := 0
 451         ;
 452   ;;
 453 end
 454
 455 module Gzh =
 456 struct
 457   let lim = ref 0
 458   let stop = ref false
 459   let refdt = ref 0.0
 460
 461   let rec furious_cycle i =
 462     if not !stop && i > 0
 463     then
 464       pred i |> furious_cycle
 465     else
 466       (i, Unix.gettimeofday ())
 467   ;;
 468
 469   let init verbose =
 470     let t = 0.5 in
 471     let it = { Unix.it_interval = t; it_value = t } in
 472     let tries = 1 in
 473     let handler =
 474       let n = ref tries in
 475         fun _ ->
 476           decr n;
 477           stop := !n = 0;
 478     in
 479     let sign = Sys.sigalrm in
 480     let oldh = Sys.signal sign |< Sys.Signal_handle handler in
 481     let oldi = Unix.setitimer Unix.ITIMER_REAL it in
 482     let oldbp = Unix.sigprocmask Unix.SIG_BLOCK [sign] in
 483     let () = NP.waitalrm () in
 484     let () = stop := false in
 485     let oldup = Unix.sigprocmask Unix.SIG_UNBLOCK [sign] in
 486     let t1 = Unix.gettimeofday () in
 487     let n, t2 = furious_cycle max_int in
 488     let () = refdt := t2 -. t1 in
 489     let () = lim := tries * (max_int - n) in
 490     let () =
 491       if verbose
 492       then
 493         printf "Completed %d iterations in %f seconds@." !lim !refdt
 494     in
 495     let _ = Unix.sigprocmask Unix.SIG_UNBLOCK oldup in
 496     let _ = Unix.setitimer Unix.ITIMER_REAL oldi in
 497     let _ = Unix.sigprocmask Unix.SIG_BLOCK oldbp in
 498     let _ = Sys.signal sign oldh in
 499       ()
 500   ;;
 501
 502   let gen f =
 503     let thf () =
 504       NP.setnice 20;
 505       stop := false;
 506       let l = ref 0 in
 507       let rec loop t1 =
 508         let _, t2 = furious_cycle !lim in
 509         let dt = t2 -. t1 in
 510           incr l;
 511           if !Args.debug && !l > 10
 512           then
 513             begin
 514               printf "Completed %d iterations in %f seconds load %f@."
 515                 !lim dt |< !refdt /. dt;
 516               l := 0;
 517             end
 518           ;
 519           !refdt /. dt |> f;
 520           loop t2
 521       in
 522         Unix.gettimeofday () |> loop
 523     in
 524     let _ = Thread.create thf () in
 525       ()
 526   ;;
 527 end
 528
 529 let oohz oohz fn =
 530   let prev = ref 0.0 in
 531     fun () ->
 532       let a = !prev in
 533       let b = Unix.gettimeofday () in
 534         if b -. a > oohz
 535         then
 536           begin
 537             prev := b;
 538             fn ()
 539           end
 540 ;;
 541
 542 module Delay =
 543 struct
 544   let sighandler signr = ()
 545
 546   let winfreq = ref 0.0
 547
 548   let init freq gzh =
 549     if NP.winnt
 550     then
 551       winfreq := 1.0 /. float freq
 552     else
 553       let () =
 554         Sys.Signal_handle sighandler |> Sys.set_signal Sys.sigalrm;
 555         if !Args.sigway
 556         then
 557           let l =
 558             if gzh
 559             then
 560               [Sys.sigprof; Sys.sigvtalrm]
 561             else
 562               []
 563           in
 564             Unix.sigprocmask Unix.SIG_BLOCK |< Sys.sigalrm :: l |> ignore;
 565       ;
 566       in
 567       let v = 1.0 /. float freq in
 568       let t = { Unix.it_interval = v; it_value = v } in
 569       let _ = Unix.setitimer Unix.ITIMER_REAL t in
 570         ()
 571   ;;
 572
 573   let delay () =
 574     if NP.winnt
 575     then
 576       NP.delay !winfreq
 577     else
 578       begin
 579         if !Args.sigway
 580         then
 581           NP.waitalrm ()
 582         else
 583           begin
 584             try let _ = Unix.select [] [] [] ~-.1.0 in ()
 585             with Unix.Unix_error (Unix.EINTR, _, _) -> ()
 586           end
 587       end
 588   ;;
 589 end
 590
 591 type sampler =
 592     { color : Gl.rgb;
 593       getyielder : unit -> unit -> float option;
 594       update : float -> float -> unit;
 595     }
 596 ;;
 597
 598 module Sampler (T : sig val nsamples : int val freq : float end) =
 599 struct
 600   let nsamples = T.nsamples + 1
 601   let samples = Array.create nsamples 0.0
 602   let head = ref 0
 603   let tail = ref 0
 604   let active = ref 0
 605
 606   let update v n =
 607     let n = min nsamples n in
 608     let rec loop i j =
 609       if j = 0
 610       then
 611         ()
 612       else
 613         let i =
 614           if i = nsamples
 615           then
 616             0
 617           else
 618             i
 619         in
 620           Array.set samples i v;
 621           loop (succ i) (pred j)
 622     in
 623     let () = loop !head n in
 624     let () = head := (!head + n) mod nsamples in
 625     let () = active := min (!active + n) nsamples in
 626       ();
 627   ;;
 628
 629   let getyielder () =
 630     let tail =
 631       let d = !head - !active in
 632         if d < 0
 633         then
 634           nsamples + d
 635         else
 636           d
 637     in
 638     let ry = ref (fun () -> assert false) in
 639     let rec yield i () =
 640       if i = !active
 641       then
 642         None
 643       else
 644         begin
 645           ry := succ i |> yield;
 646           Some ((i + tail) mod nsamples |> Array.get samples)
 647         end
 648     in
 649       ry := yield 0;
 650       (fun () -> !ry ());
 651   ;;
 652
 653   let update dt di =
 654     let isamples = dt /. T.freq |> truncate in
 655     let l = 1.0 -. (di /. dt) in
 656     let l = max 0.0 l in
 657       update l isamples;
 658   ;;
 659 end
 660
 661 module type ViewSampler =
 662 sig
 663   val getyielder : unit -> unit -> float option
 664   val update : float -> float -> float -> float -> unit
 665 end
 666
 667 module type View =
 668 sig
 669   val x : int
 670   val y : int
 671   val w : int
 672   val h : int
 673   val sgrid : int
 674   val pgrid : int
 675   val freq : float
 676   val interval : float
 677   val samplers : sampler list
 678 end
 679
 680 module View (V: sig val w : int val h : int end) =
 681 struct
 682   let ww = ref 0
 683   let wh = ref 0
 684   let funcs = ref []
 685
 686   let keyboard ~key ~x ~y =
 687     if key = 27 || key = Char.code 'q'
 688     then
 689       exit 0;
 690   ;;
 691
 692   let add dri =
 693     funcs := dri :: !funcs
 694   ;;
 695
 696   let display () =
 697     GlClear.clear [`color];
 698     List.iter (fun (display, _, _) -> display ()) !funcs;
 699     Glut.swapBuffers ();
 700   ;;
 701
 702   let reshape ~w ~h =
 703     ww := w;
 704     wh := h;
 705     List.iter (fun (_, reshape, _) -> reshape w h) !funcs;
 706     GlClear.clear [`color];
 707     GlMat.mode `modelview;
 708     GlMat.load_identity ();
 709     GlMat.mode `projection;
 710     GlMat.load_identity ();
 711     GlMat.rotate ~y:1.0 ~angle:180.0 ();
 712     GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
 713     GlMat.scale ~x:2.0 ~y:2.0 ();
 714     Glut.postRedisplay ();
 715   ;;
 716
 717   let init () =
 718     let () =
 719       Glut.initDisplayMode ~double_buffer:true ();
 720       Glut.initWindowSize V.w V.h
 721     in
 722     let winid = Glut.createWindow "APC" in
 723       Glut.displayFunc display;
 724       Glut.reshapeFunc reshape;
 725       Glut.keyboardFunc keyboard;
 726       GlDraw.color (1.0, 1.0, 0.0);
 727       winid;
 728   ;;
 729
 730   let inc () = List.iter (fun (_, _, inc) -> inc ()) !funcs
 731   let update = Glut.postRedisplay
 732   let func = Glut.idleFunc
 733   let run = Glut.mainLoop
 734 end
 735
 736 module type BarInfo =
 737 sig
 738   val x : int
 739   val y : int
 740   val w : int
 741   val h : int
 742   val getl : stats -> ((float * float * float) * float) list
 743 end
 744
 745 module Bar (I: BarInfo) =
 746 struct
 747   let w = ref I.w
 748   let h = ref I.h
 749   let wratio = float I.w /. float !Args.w
 750   let load = ref zero_stat
 751   let nrcpuscale = 1.0 /. float NP.nprocs
 752   let fh = 12
 753   let strw = Glut.bitmapLength ~font ~str:"55.55"
 754   let sepsl =
 755     let base = GlList.gen_lists ~len:1 in
 756       GlList.nth base ~pos:0
 757   ;;
 758
 759   let seps () =
 760     let hh = !h - 26 in
 761     let () =
 762       GlDraw.viewport I.x (I.y + 15) !w hh;
 763       GlMat.push ();
 764       GlMat.load_identity ();
 765       GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
 766       GlMat.scale ~y:(2.0 /. (float hh)) ~x:1.0 ();
 767     in
 768     let seph = 1 in
 769     let barh = float (hh - (!Args.bars - 1) * seph) /. float !Args.bars in
 770     let barh = ceil barh |> truncate in
 771     let rec loop i yb =
 772       if yb > hh
 773       then
 774         ()
 775       else
 776         let yt = yb + seph in
 777         let yn = yt + barh in
 778         let yb = float yb
 779         and yt = float yt in
 780           GlDraw.vertex2 (0.0, yb);
 781           GlDraw.vertex2 (0.0, yt);
 782           GlDraw.vertex2 (2.0, yt);
 783           GlDraw.vertex2 (2.0, yb);
 784           succ i |> loop |< yn
 785     in
 786       GlDraw.color (0.0, 0.0, 0.0);
 787       GlDraw.begins `quads;
 788       loop 0 barh;
 789       GlDraw.ends ();
 790       GlMat.pop ();
 791   ;;
 792
 793   let reshape w' h' =
 794     w :=
 795       if !Args.scalebar
 796       then
 797         (float w' *. wratio |> truncate)
 798       else
 799         !w
 800     ;
 801     h := h';
 802     GlList.begins sepsl `compile;
 803     seps ();
 804     GlList.ends ();
 805   ;;
 806
 807   let display () =
 808     let load = scale_stat !load nrcpuscale in
 809     let load_all = min (1.0 -. load.all) 1.0 |> max 0.0 in
 810     let () = GlMat.push () in
 811     let () =
 812       GlDraw.viewport I.x (I.y + 2) !w !h;
 813       GlDraw.color (1.0, 1.0, 1.0);
 814       let load_all = 100.0 *. load_all in
 815       let str = sprintf "%5.2f" load_all in
 816       let () =
 817         GlMat.load_identity ();
 818         let strw =
 819           if false
 820           then
 821             Glut.bitmapLength ~font ~str:str
 822           else
 823             strw
 824         in
 825         let x = -. (float strw /. float !w) in
 826           GlMat.translate ~y:~-.1.0 ~x ();
 827       in
 828       let () = draw_string 0.0 0.0 str in
 829         ()
 830     in
 831       GlDraw.viewport I.x (I.y + 15) !w (!h - 26);
 832       GlMat.load_identity ();
 833       GlMat.translate ~x:~-.1. ~y:~-.1.();
 834       let drawquad yb yt =
 835         GlDraw.begins `quads;
 836         GlDraw.vertex2 (0.0, yb);
 837         GlDraw.vertex2 (0.0, yt);
 838         GlDraw.vertex2 (2.0, yt);
 839         GlDraw.vertex2 (2.0, yb);
 840         GlDraw.ends ()
 841       in
 842       let fold yb (color, load) =
 843         if load > 0.0
 844         then
 845           let () = GlDraw.color color in
 846           let yt = yb +. 2.0*.load in
 847           let () = drawquad yb yt in
 848             yt
 849         else
 850           yb
 851       in
 852       let cl = I.getl load in
 853       let yb = List.fold_left fold 0.0 cl in
 854       let () = GlDraw.color (0.5, 0.5, 0.5) in
 855       let () = drawquad yb 2.0 in
 856       let () = GlList.call sepsl in
 857         GlMat.pop ();
 858         GlList.call sepsl;
 859   ;;
 860
 861   let update delta' load' =
 862     let delta = 1.0 /. delta' in
 863       load := scale_stat load' delta;
 864   ;;
 865 end
 866
 867 module Graph (V: View) =
 868 struct
 869   let ox = if !Args.scalebar then 0 else !Args.barw
 870   let sw = float V.w /. float (!Args.w - ox)
 871   let sh = float V.h /. float !Args.h
 872   let sx = float (V.x - ox)  /. float V.w
 873   let sy = float V.y /. float V.h
 874   let vw = ref 0
 875   let vh = ref 0
 876   let vx = ref 0
 877   let vy = ref 0
 878   let scale = V.freq /. V.interval
 879   let gscale = 1.0 /. float V.sgrid
 880   let nsamples = ref 0
 881
 882   let fw, fh =
 883     if !Args.labels
 884     then
 885       3 * Glut.bitmapWidth font (Char.code '%'), 20
 886     else
 887       0, 10
 888   ;;
 889
 890   let gridlist =
 891     let base = GlList.gen_lists ~len:1 in
 892       GlList.nth base ~pos:0
 893
 894   let viewport typ =
 895     let ox = if !Args.scalebar then 0 else !Args.barw in
 896     let x, y, w, h =
 897       match typ with
 898         | `labels -> (!vx + ox, !vy + 5, fw, !vh - fh)
 899         | `graph  -> (!vx + fw + 5 + ox, !vy + 5, !vw - fw - 10, !vh - fh)
 900     in
 901       GlDraw.viewport x y w h;
 902   ;;
 903
 904   let sgrid () =
 905     for i = 0 to V.sgrid
 906     do
 907       let x = if i = 0 then 0.0009 else float i *. gscale in
 908         GlDraw.vertex ~x ~y:0.0 ();
 909         GlDraw.vertex ~x ~y:1.0 ();
 910     done;
 911   ;;
 912
 913   let grid () =
 914     viewport `graph;
 915     GlDraw.line_width 1.0;
 916     GlDraw.color (0.0, 1.0, 0.0);
 917     GlDraw.begins `lines;
 918     if !Args.mgrid
 919     then
 920       begin
 921         GlDraw.vertex2 (0.0009, 0.0);
 922         GlDraw.vertex2 (0.0009, 1.0);
 923         GlDraw.vertex2 (1.0000, 0.0);
 924         GlDraw.vertex2 (1.0000, 1.0);
 925       end
 926     else
 927       sgrid ()
 928     ;
 929     let () =
 930       let lim = 100 / V.pgrid in
 931         for i = 0 to lim
 932         do
 933           let y = (i * V.pgrid |> float) /. 100.0 in
 934           let y = if i = lim then y -. 0.0009 else y in
 935             GlDraw.vertex ~x:0.0 ~y ();
 936             GlDraw.vertex ~x:1.0 ~y ();
 937         done;
 938     in
 939     let () = GlDraw.ends () in
 940       if !Args.labels
 941       then
 942         begin
 943           viewport `labels;
 944           GlDraw.color (1.0, 1.0, 1.0);
 945           let ohp = 100.0 in
 946             for i = 0 to 100 / V.pgrid
 947             do
 948               let p = i * V.pgrid in
 949               let y = float p /. ohp in
 950               let s = Printf.sprintf "%3d%%" p in
 951                 draw_string 1.0 y s
 952             done
 953         end
 954   ;;
 955
 956   let reshape w h =
 957     let wxsw = float (w - ox) *. sw
 958     and hxsh = float h *. sh in
 959       vw := wxsw |> truncate;
 960       vh := hxsh |> truncate;
 961       vx := wxsw *. sx |> truncate;
 962       vy := hxsh *. sy |> truncate;
 963       GlList.begins gridlist `compile;
 964       grid ();
 965       GlList.ends ();
 966   ;;
 967
 968   let swap =
 969     Glut.swapBuffers |> oohz !Args.delay;
 970   ;;
 971
 972   let inc () = incr nsamples
 973
 974   let mgrid () =
 975     GlDraw.line_width 1.0;
 976     GlDraw.color (0.0, 1.0, 0.0);
 977     GlDraw.begins `lines;
 978     let offset =
 979       ((pred !nsamples |> float) *. scale /. gscale |> modf |> fst) *. gscale
 980     in
 981       for i = 0 to pred V.sgrid
 982       do
 983         let x = offset +. float i *. gscale in
 984           GlDraw.vertex ~x ~y:0.0 ();
 985           GlDraw.vertex ~x ~y:1.0 ();
 986       done;
 987       GlDraw.ends ();
 988   ;;
 989
 990   let display () =
 991     GlList.call gridlist;
 992     viewport `graph;
 993     if !Args.mgrid then mgrid ();
 994     GlDraw.line_width 2.0;
 995     let sample sampler =
 996       GlDraw.color sampler.color;
 997       let () =
 998         if not !Args.poly
 999         then GlDraw.begins `line_strip
1000         else
1001           begin
1002             GlDraw.begins `polygon;
1003             GlDraw.vertex2 (0.0, 0.0);
1004           end
1005       in
1006       let yield = sampler.getyielder () in
1007       let rec loop last i =
1008         match yield () with
1009           | Some y as opty ->
1010               let x = scale *. float i in
1011                 GlDraw.vertex ~x ~y ();
1012                 loop opty (succ i)
1013
1014           | None ->
1015               if !Args.poly
1016               then
1017                 match last with
1018                   | None -> ()
1019                   | Some y ->
1020                       let x = scale *. float (pred i) in
1021                         GlDraw.vertex ~x ~y:0.0 ()
1022       in
1023         loop None 0;
1024         GlDraw.ends ();
1025     in
1026       List.iter sample V.samplers;
1027   ;;
1028
1029   let funcs = display, reshape, inc
1030 end
1031
1032 let getplacements w h n barw =
1033   let sr = float n |> sqrt |> ceil |> truncate in
1034   let d = n / sr in
1035   let r = if n mod sr = 0 then 0 else 1 in
1036   let x, y =
1037     if w - barw > h
1038     then
1039       sr + r, d
1040     else
1041       d, sr + r
1042   in
1043   let w' = w - barw in
1044   let h' = h in
1045   let vw = w' / x in
1046   let vh = h' / y in
1047   let rec loop accu i =
1048     if i = n
1049     then
1050       accu
1051     else
1052       let yc = i / x in
1053       let xc = i mod x in
1054       let xc = xc * vw + barw in
1055       let yc = yc * vh in
1056         (i, xc, yc) :: accu |> loop |< succ i
1057   in
1058     loop [] 0, vw, vh
1059 ;;
1060
1061 let create fd w h =
1062   let module S =
1063       struct
1064         let freq = !Args.freq
1065         let nsamples = !Args.interval /. freq |> ceil |> truncate
1066       end
1067   in
1068   let placements, vw, vh = getplacements w h NP.nprocs !Args.barw in
1069
1070   let iget () =
1071     if !Args.isampler then NP.idletimeofday fd NP.nprocs else [||]
1072   in
1073   let is = iget () in
1074
1075   let kget () =
1076     let gks = NP.parse_stat () in
1077       gks () |> Array.of_list
1078   in
1079   let ks = kget () in
1080
1081   let crgraph (kaccu, iaccu, gaccu) (i, x, y) =
1082     let module Si = Sampler (S) in
1083     let isampler =
1084       { getyielder = Si.getyielder
1085       ; color = (1.0, 1.0, 0.0)
1086       ; update = Si.update
1087       }
1088     in
1089     let module Sk = Sampler (S) in
1090     let ksampler =
1091       { getyielder = Sk.getyielder
1092       ; color = (1.0, 0.0, 0.0)
1093       ; update = Sk.update
1094       }
1095     in
1096     let module V = struct
1097       let x = x
1098       let y = y
1099       let w = vw
1100       let h = vh
1101       let freq = S.freq
1102       let interval = !Args.interval
1103       let pgrid = !Args.pgrid
1104       let sgrid = !Args.sgrid
1105       let samplers =
1106         if !Args.isampler
1107         then
1108           isampler :: (if !Args.ksampler then [ksampler] else [])
1109         else
1110           if !Args.ksampler then [ksampler] else []
1111     end
1112     in
1113     let module Graph = Graph (V) in
1114     let kaccu =
1115       if !Args.ksampler
1116       then
1117         let calc =
1118           if !Args.gzh
1119           then
1120             let d = ref 0.0 in
1121             let f d' = d := d' in
1122             let () = Gzh.gen f in
1123               fun _ _ _ ->
1124                 let d = !d in
1125                   { zero_stat with
1126                     all = d; iowait = d; user = 1.0 -. d; idle = d }
1127           else
1128             if !Args.uptime
1129             then
1130               let (u1, i1) = NP.parse_uptime () in
1131               let u1 = ref u1
1132               and i1 = ref i1 in
1133                 fun _ _ _ ->
1134                   let (u2, i2) = NP.parse_uptime () in
1135                   let du = u2 -. !u1
1136                   and di = i2 -. !i1 in
1137                   let d = di /. du in
1138                     u1 := u2;
1139                     i1 := i2;
1140                     { zero_stat with
1141                       all = d; iowait = d; user = 1.0 -. d; idle = d }
1142           else
1143             let i' = if i = NP.nprocs then 0 else succ i in
1144             let g ks n = Array.get ks i' |> snd |> Array.get |< n in
1145             let gall ks =
1146               let user = g ks NP.user
1147               and nice = g ks NP.nice
1148               and sys = g ks NP.sys
1149               and idle = g ks NP.idle
1150               and iowait = g ks NP.idle
1151               and intr = g ks NP.intr
1152               and softirq = g ks NP.softirq in
1153               let () =
1154                 if !Args.debug
1155                 then
1156                   eprintf
1157                     "user=%f nice=%f sys=%f iowait=%f intr=%f softirq=%f@."
1158                     user
1159                     nice
1160                     sys
1161                     iowait
1162                     intr
1163                     softirq
1164                 ;
1165               in
1166                 { all = idle
1167                 ; user = user
1168                 ; nice = nice
1169                 ; sys = sys
1170                 ; idle = idle
1171                 ; iowait = iowait
1172                 ; intr = intr
1173                 ; softirq = softirq
1174                 }
1175             in
1176             let i1 = ref (gall ks) in
1177               fun ks _ _ ->
1178                 let i2 = gall ks in
1179                 let diff = add_stat i2 (neg_stat !i1) in
1180                   i1 := i2;
1181                   diff
1182         in
1183           (i, calc, ksampler) :: kaccu
1184       else
1185         kaccu
1186     in
1187     let iaccu =
1188       if !Args.isampler
1189       then
1190         let calc =
1191           let i1 = Array.get is i |> ref in
1192             fun is t1 t2 ->
1193               let i2 = Array.get is i in
1194                 if classify_float i2 = FP_infinite
1195                 then
1196                   { zero_stat with all = t2 -. t1 }
1197                 else
1198                   let i1' = !i1 in
1199                     i1 := i2;
1200                     { zero_stat with all = i2 -. i1' }
1201         in
1202           (i, calc, isampler) :: iaccu
1203       else
1204         iaccu
1205     in
1206       kaccu, iaccu, Graph.funcs :: gaccu
1207   in
1208   let kl, il, gl = List.fold_left crgraph ([], [], []) placements in
1209     ((if kl == [] then (fun () -> [||]) else kget), kl), (iget, il), gl
1210 ;;
1211
1212 let opendev path =
1213   if not NP.linux
1214   then
1215     (* gross hack but we are not particularly picky today *)
1216     Unix.stdout
1217   else
1218     try
1219       if (Unix.stat path).Unix.st_kind != Unix.S_CHR
1220       then
1221         begin
1222           eprintf "File %S is not an ITC device@." path;
1223           exit 100
1224         end
1225       ;
1226       Unix.openfile path [Unix.O_RDONLY] 0
1227     with
1228       | Unix.Unix_error ((Unix.ENODEV | Unix.ENXIO) as err , s1, s2) ->
1229           eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1230             path s1 s2 |< Unix.error_message err;
1231           eprintf "(perhaps the module is not loaded?)@.";
1232           exit 100
1233
1234       | Unix.Unix_error (Unix.EALREADY, s1, s2) ->
1235           eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1236             path s1 s2 |< Unix.error_message Unix.EALREADY;
1237           eprintf "(perhaps modules is already in use?)@.";
1238           exit 100
1239
1240       | Unix.Unix_error (error, s1, s2) ->
1241           eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1242             path s1 s2 |< Unix.error_message error;
1243           exit 100
1244
1245       | exn ->
1246           eprintf "Could not open ITC device %S:\n%s@."
1247             path |< Printexc.to_string exn;
1248           exit 100
1249 ;;
1250
1251 let seticon () =
1252   let module X =
1253       struct
1254         external seticon : string -> unit = "ml_seticon"
1255       end
1256   in
1257   let len = 32*4 in
1258   let data = String.create |< 32*len + 2*4 in
1259   let line r g b a =
1260     let r = Char.chr r
1261     and g = Char.chr g
1262     and b = Char.chr b
1263     and a = Char.chr a in
1264     let s = String.create len in
1265     let rec fill x =
1266       if x = len
1267       then
1268         s
1269       else
1270         begin
1271           x + 0 |> String.set s |< b;
1272           x + 1 |> String.set s |< g;
1273           x + 2 |> String.set s |< r;
1274           x + 3 |> String.set s |< a;
1275           x + 4 |> fill
1276         end
1277     in
1278       fill 0
1279   in
1280   let el = line 0x00 0x00 0x00 0xff
1281   and kl = line 0xff 0x00 0x00 0xff
1282   and il = line 0xff 0xff 0x00 0xff in
1283   let fill l sy ey =
1284     let src = l and dst = data and src_pos = 0 in
1285     let rec loop n dst_pos =
1286       if n > 0
1287       then
1288         begin
1289           StringLabels.blit ~src ~src_pos ~dst ~dst_pos ~len;
1290           pred n |> loop |< dst_pos + len
1291         end
1292     in
1293       (ey - sy) |> loop |< (32 - ey) * len + 4*2
1294   in
1295     fun ~iload ~kload ->
1296       let iy = iload *. 32.0 |> ceil |> truncate |> max 0 |> min 32
1297       and ky = kload *. 32.0 |> ceil |> truncate |> max 0 |> min 32 in
1298       let ey =
1299         if ky < iy
1300         then
1301           (fill kl 0 ky; fill il ky iy; iy)
1302         else
1303           (fill kl 0 ky; ky)
1304       in
1305         fill el ey 32;
1306         X.seticon data;
1307 ;;
1308
1309 let create_bars h kactive iactive =
1310   let getlk kload =
1311     if !Args.sepstat
1312     then
1313       let sum = kload.user +. kload.nice +. kload.sys
1314         +. kload.intr +. kload.softirq
1315       in
1316         [ (1.0, 1.0, 0.0), kload.user
1317         ; (0.0, 0.0, 1.0), kload.nice
1318         ; (1.0, 0.0, 0.0), kload.sys
1319         ; (1.0, 1.0, 1.0), kload.intr
1320         ; (0.75, 0.5, 0.5), (1.0 -. kload.iowait) -. sum
1321         ; (0.0, 1.0, 0.0), kload.all -. kload.iowait -. kload.softirq
1322         ]
1323     else
1324       [ (1.0, 0.0, 0.0), 1.0 -. kload.idle ]
1325   in
1326   let getli iload =
1327     [ (1.0, 1.0, 0.0), 1.0 -. iload.all ]
1328   in
1329   let barw = !Args.barw in
1330   let nfuncs =
1331     (fun () -> ()), (fun _ _ -> ()), (fun _ _ -> ())
1332   in
1333   let kd, kr, ku =
1334     if kactive
1335     then
1336       let module Bar =
1337         Bar (struct
1338           let x = 3
1339           let y = 0
1340           let w = (if iactive then barw / 2 else barw) - 3
1341           let h = h
1342           let getl = getlk
1343         end)
1344       in
1345         Bar.display, Bar.reshape, Bar.update
1346     else
1347       nfuncs
1348   in
1349   let id, ir, iu =
1350     if iactive
1351     then
1352       let module Bar =
1353         Bar (struct
1354           let x = (if kactive then barw / 2 else 0) + 3
1355           let y = 0
1356           let w = (if kactive then barw / 2 else barw) - 3
1357           let h = h
1358           let getl = getli
1359         end)
1360       in
1361         Bar.display, Bar.reshape, Bar.update
1362     else
1363       nfuncs
1364   in
1365     if kactive
1366     then
1367       begin
1368       if iactive
1369       then
1370         let d () = kd (); id () in
1371         let r w h = kr w h; ir w h in
1372         let u d k i = ku d k; iu d i in
1373           d, r, u
1374       else
1375         kd, kr, (fun d k _ -> ku d k)
1376       end
1377     else
1378       begin
1379         if iactive
1380         then
1381           id, ir, (fun d _ i -> iu d i)
1382         else
1383           (fun () -> ()), (fun _ _ -> ()), (fun _ _ _ -> ())
1384       end
1385 ;;
1386
1387 let main () =
1388   let _ = Glut.init [|""|] in
1389   let () = Args.init () in
1390   let () =
1391     if !Args.verbose
1392     then
1393       "detected " ^ string_of_int NP.nprocs ^ " CPUs" |> print_endline
1394   in
1395   let () = if !Args.gzh then Gzh.init !Args.verbose else () in
1396   let () = Delay.init !Args.timer !Args.gzh in
1397   let () = if !Args.niceval != 0 then NP.setnice !Args.niceval else () in
1398   let w = !Args.w
1399   and h = !Args.h in
1400   let fd = opendev !Args.devpath in
1401   let module FullV = View (struct let w = w let h = h end) in
1402   let _winid = FullV.init () in
1403   let (kget, kfuncs), (iget, ifuncs), gl = create fd w h in
1404   let bar_update =
1405     List.iter FullV.add gl;
1406     if !Args.barw > 0
1407     then
1408       let (display, reshape, update) =
1409         create_bars h !Args.ksampler !Args.isampler
1410       in
1411         FullV.add (display, reshape, fun _ -> ());
1412         update
1413     else
1414       fun _ _ _ -> ()
1415   in
1416   let seticon = if !Args.icon then seticon () else fun ~iload ~kload -> () in
1417   let rec loop t1 () =
1418     let t2 = Unix.gettimeofday () in
1419     let dt = t2 -. t1 in
1420       if dt >= !Args.freq
1421       then
1422         let is = iget () in
1423         let ks = kget () in
1424         let rec loop2 load sample = function
1425           | [] -> load
1426           | (nr, calc, sampler) :: rest ->
1427               let cpuload = calc sample t1 t2 in
1428               let () =
1429                 let thisload = 1.0 -. (cpuload.all /. dt) in
1430                 let thisload = max 0.0 thisload in
1431                 if !Args.verbose
1432                 then
1433                   ("cpu load(" ^ string_of_int nr ^ "): "
1434                     ^ (thisload *. 100.0 |> string_of_float)
1435                   |> print_endline)
1436               in
1437               let load = add_stat load cpuload in
1438                 sampler.update dt cpuload.all;
1439                 loop2 load sample rest
1440         in
1441         let iload = loop2 zero_stat is ifuncs in
1442         let kload = loop2 zero_stat ks kfuncs in
1443           if !Args.debug
1444           then
1445             begin
1446               iload.all |> string_of_float |> prerr_endline;
1447               kload.all |> string_of_float |> prerr_endline;
1448             end
1449           ;
1450           seticon ~iload:iload.all ~kload:kload.all;
1451           bar_update dt kload iload;
1452           FullV.inc ();
1453           FullV.update ();
1454           FullV.func (Some (loop t2))
1455       else
1456         Delay.delay ()
1457   in
1458     FullV.func (Some (Unix.gettimeofday () |> loop));
1459     FullV.run ()
1460 ;;
1461
1462 let _ =
1463   try
1464     main ()
1465   with
1466     | Unix.Unix_error (e, s1, s2) ->
1467         Unix.error_message e |> eprintf "main failure: %s(%s): %s@." s1 s2
1468
1469     | exn ->
1470         Printexc.to_string exn |> eprintf "main failure: %s@."
1471 ;;