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 0.99"
 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       opts
 407     in
 408     let add_macosx opts =
 409       isampler := false;
 410       fB "g" gzh "gzh way (does not quite work yet)"
 411       :: opts
 412     in
 413       match NP.os_type with
 414         | NP.Linux -> add_linux tail
 415         | NP.Windows -> add_windows tail
 416         | NP.Solaris -> add_solaris tail
 417         | NP.MacOSX -> add_macosx tail
 418   ;;
 419
 420   let init () =
 421     let opts = add_opts commonopts in
 422       Arg.parse opts
 423         (fun s ->
 424           raise (Arg.Bad
 425                     ("Invocation error: Don't know what to do with " ^ s));
 426         )
 427         banner
 428       ;
 429       let cp {contents=v} s =
 430         if v <= 0
 431         then (prerr_string s; prerr_endline " must be positive"; exit 1)
 432       in
 433       let cpf {contents=v} s =
 434         if v <= 0.0
 435         then (prerr_string s; prerr_endline " must be pisitive"; exit 1)
 436       in
 437         cp w "Width";
 438         cp h "Height";
 439         cp pgrid "Number of percent grid items";
 440         cp sgrid "Number of history grid items";
 441         cp bars "Number of CPU bars";
 442         cp timer "Timer frequency";
 443         cpf freq "Frequency";
 444         cpf delay "Delay";
 445         cpf interval "Interval";
 446         if not (!isampler || !ksampler)
 447         then
 448           barw := 0
 449         ;
 450   ;;
 451 end
 452
 453 module Gzh =
 454 struct
 455   let lim = ref 0
 456   let stop = ref false
 457   let refdt = ref 0.0
 458
 459   let rec furious_cycle i =
 460     if not !stop && i > 0
 461     then
 462       pred i |> furious_cycle
 463     else
 464       (i, Unix.gettimeofday ())
 465   ;;
 466
 467   let init verbose =
 468     let t = 0.5 in
 469     let it = { Unix.it_interval = t; it_value = t } in
 470     let tries = 1 in
 471     let handler =
 472       let n = ref tries in
 473         fun _ ->
 474           decr n;
 475           stop := !n = 0;
 476     in
 477     let sign = Sys.sigalrm in
 478     let oldh = Sys.signal sign |< Sys.Signal_handle handler in
 479     let oldi = Unix.setitimer Unix.ITIMER_REAL it in
 480     let oldbp = Unix.sigprocmask Unix.SIG_BLOCK [sign] in
 481     let () = NP.waitalrm () in
 482     let () = stop := false in
 483     let oldup = Unix.sigprocmask Unix.SIG_UNBLOCK [sign] in
 484     let t1 = Unix.gettimeofday () in
 485     let n, t2 = furious_cycle max_int in
 486     let () = refdt := t2 -. t1 in
 487     let () = lim := tries * (max_int - n) in
 488     let () =
 489       if verbose
 490       then
 491         printf "Completed %d iterations in %f seconds@." !lim !refdt
 492     in
 493     let _ = Unix.sigprocmask Unix.SIG_UNBLOCK oldup in
 494     let _ = Unix.setitimer Unix.ITIMER_REAL oldi in
 495     let _ = Unix.sigprocmask Unix.SIG_BLOCK oldbp in
 496     let _ = Sys.signal sign oldh in
 497       ()
 498   ;;
 499
 500   let gen f =
 501     let thf () =
 502       NP.setnice 20;
 503       stop := false;
 504       let l = ref 0 in
 505       let rec loop t1 =
 506         let _, t2 = furious_cycle !lim in
 507         let dt = t2 -. t1 in
 508           incr l;
 509           if !Args.debug && !l > 10
 510           then
 511             begin
 512               printf "Completed %d iterations in %f seconds load %f@."
 513                 !lim dt |< !refdt /. dt;
 514               l := 0;
 515             end
 516           ;
 517           !refdt /. dt |> f;
 518           loop t2
 519       in
 520         Unix.gettimeofday () |> loop
 521     in
 522     let _ = Thread.create thf () in
 523       ()
 524   ;;
 525 end
 526
 527 let oohz oohz fn =
 528   let prev = ref 0.0 in
 529     fun () ->
 530       let a = !prev in
 531       let b = Unix.gettimeofday () in
 532         if b -. a > oohz
 533         then
 534           begin
 535             prev := b;
 536             fn ()
 537           end
 538 ;;
 539
 540 module Delay =
 541 struct
 542   let sighandler signr = ()
 543
 544   let winfreq = ref 0.0
 545
 546   let init freq gzh =
 547     if NP.winnt
 548     then
 549       winfreq := 1.0 /. float freq
 550     else
 551       let () =
 552         Sys.Signal_handle sighandler |> Sys.set_signal Sys.sigalrm;
 553         if !Args.sigway
 554         then
 555           let l =
 556             if gzh
 557             then
 558               [Sys.sigprof; Sys.sigvtalrm]
 559             else
 560               []
 561           in
 562             Unix.sigprocmask Unix.SIG_BLOCK |< Sys.sigalrm :: l |> ignore;
 563       ;
 564       in
 565       let v = 1.0 /. float freq in
 566       let t = { Unix.it_interval = v; it_value = v } in
 567       let _ = Unix.setitimer Unix.ITIMER_REAL t in
 568         ()
 569   ;;
 570
 571   let delay () =
 572     if NP.winnt
 573     then
 574       NP.delay !winfreq
 575     else
 576       begin
 577         if !Args.sigway
 578         then
 579           NP.waitalrm ()
 580         else
 581           begin
 582             try let _ = Unix.select [] [] [] ~-.1.0 in ()
 583             with Unix.Unix_error (Unix.EINTR, _, _) -> ()
 584           end
 585       end
 586   ;;
 587 end
 588
 589 type sampler =
 590     { color : Gl.rgb;
 591       getyielder : unit -> unit -> float option;
 592       update : float -> float -> unit;
 593     }
 594 ;;
 595
 596 module Sampler (T : sig val nsamples : int val freq : float end) =
 597 struct
 598   let nsamples = T.nsamples + 1
 599   let samples = Array.create nsamples 0.0
 600   let head = ref 0
 601   let tail = ref 0
 602   let active = ref 0
 603
 604   let update v n =
 605     let n = min nsamples n in
 606     let rec loop i j =
 607       if j = 0
 608       then
 609         ()
 610       else
 611         let i =
 612           if i = nsamples
 613           then
 614             0
 615           else
 616             i
 617         in
 618           Array.set samples i v;
 619           loop (succ i) (pred j)
 620     in
 621     let () = loop !head n in
 622     let () = head := (!head + n) mod nsamples in
 623     let () = active := min (!active + n) nsamples in
 624       ();
 625   ;;
 626
 627   let getyielder () =
 628     let tail =
 629       let d = !head - !active in
 630         if d < 0
 631         then
 632           nsamples + d
 633         else
 634           d
 635     in
 636     let ry = ref (fun () -> assert false) in
 637     let rec yield i () =
 638       if i = !active
 639       then
 640         None
 641       else
 642         begin
 643           ry := succ i |> yield;
 644           Some ((i + tail) mod nsamples |> Array.get samples)
 645         end
 646     in
 647       ry := yield 0;
 648       (fun () -> !ry ());
 649   ;;
 650
 651   let update dt di =
 652     let isamples = dt /. T.freq |> truncate in
 653     let l = 1.0 -. (di /. dt) in
 654     let l = max 0.0 l in
 655       update l isamples;
 656   ;;
 657 end
 658
 659 module type ViewSampler =
 660 sig
 661   val getyielder : unit -> unit -> float option
 662   val update : float -> float -> float -> float -> unit
 663 end
 664
 665 module type View =
 666 sig
 667   val x : int
 668   val y : int
 669   val w : int
 670   val h : int
 671   val sgrid : int
 672   val pgrid : int
 673   val freq : float
 674   val interval : float
 675   val samplers : sampler list
 676 end
 677
 678 module View (V: sig val w : int val h : int end) =
 679 struct
 680   let ww = ref 0
 681   let wh = ref 0
 682   let funcs = ref []
 683
 684   let keyboard ~key ~x ~y =
 685     if key = 27 || key = Char.code 'q'
 686     then
 687       exit 0;
 688   ;;
 689
 690   let add dri =
 691     funcs := dri :: !funcs
 692   ;;
 693
 694   let display () =
 695     GlClear.clear [`color];
 696     List.iter (fun (display, _, _) -> display ()) !funcs;
 697     Glut.swapBuffers ();
 698   ;;
 699
 700   let reshape ~w ~h =
 701     ww := w;
 702     wh := h;
 703     List.iter (fun (_, reshape, _) -> reshape w h) !funcs;
 704     GlClear.clear [`color];
 705     GlMat.mode `modelview;
 706     GlMat.load_identity ();
 707     GlMat.mode `projection;
 708     GlMat.load_identity ();
 709     GlMat.rotate ~y:1.0 ~angle:180.0 ();
 710     GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
 711     GlMat.scale ~x:2.0 ~y:2.0 ();
 712     Glut.postRedisplay ();
 713   ;;
 714
 715   let init () =
 716     let () =
 717       Glut.initDisplayMode ~double_buffer:true ();
 718       Glut.initWindowSize V.w V.h
 719     in
 720     let winid = Glut.createWindow "APC" in
 721       Glut.displayFunc display;
 722       Glut.reshapeFunc reshape;
 723       Glut.keyboardFunc keyboard;
 724       GlDraw.color (1.0, 1.0, 0.0);
 725       winid;
 726   ;;
 727
 728   let inc () = List.iter (fun (_, _, inc) -> inc ()) !funcs
 729   let update = Glut.postRedisplay
 730   let func = Glut.idleFunc
 731   let run = Glut.mainLoop
 732 end
 733
 734 module type BarInfo =
 735 sig
 736   val x : int
 737   val y : int
 738   val w : int
 739   val h : int
 740   val getl : stats -> ((float * float * float) * float) list
 741 end
 742
 743 module Bar (I: BarInfo) =
 744 struct
 745   let w = ref I.w
 746   let h = ref I.h
 747   let wratio = float I.w /. float !Args.w
 748   let load = ref zero_stat
 749   let nrcpuscale = 1.0 /. float NP.nprocs
 750   let fh = 12
 751   let strw = Glut.bitmapLength ~font ~str:"55.55"
 752   let sepsl =
 753     let base = GlList.gen_lists ~len:1 in
 754       GlList.nth base ~pos:0
 755   ;;
 756
 757   let seps () =
 758     let hh = !h - 26 in
 759     let () =
 760       GlDraw.viewport I.x (I.y + 15) !w hh;
 761       GlMat.push ();
 762       GlMat.load_identity ();
 763       GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
 764       GlMat.scale ~y:(2.0 /. (float hh)) ~x:1.0 ();
 765     in
 766     let seph = 1 in
 767     let barh = float (hh - (!Args.bars - 1) * seph) /. float !Args.bars in
 768     let barh = ceil barh |> truncate in
 769     let rec loop i yb =
 770       if yb > hh
 771       then
 772         ()
 773       else
 774         let yt = yb + seph in
 775         let yn = yt + barh in
 776         let yb = float yb
 777         and yt = float yt in
 778           GlDraw.vertex2 (0.0, yb);
 779           GlDraw.vertex2 (0.0, yt);
 780           GlDraw.vertex2 (2.0, yt);
 781           GlDraw.vertex2 (2.0, yb);
 782           succ i |> loop |< yn
 783     in
 784       GlDraw.color (0.0, 0.0, 0.0);
 785       GlDraw.begins `quads;
 786       loop 0 barh;
 787       GlDraw.ends ();
 788       GlMat.pop ();
 789   ;;
 790
 791   let reshape w' h' =
 792     w :=
 793       if !Args.scalebar
 794       then
 795         (float w' *. wratio |> truncate)
 796       else
 797         !w
 798     ;
 799     h := h';
 800     GlList.begins sepsl `compile;
 801     seps ();
 802     GlList.ends ();
 803   ;;
 804
 805   let display () =
 806     let load = scale_stat !load nrcpuscale in
 807     let load_all = min (1.0 -. load.all) 1.0 |> max 0.0 in
 808     let () = GlMat.push () in
 809     let () =
 810       GlDraw.viewport I.x (I.y + 2) !w !h;
 811       GlDraw.color (1.0, 1.0, 1.0);
 812       let load_all = 100.0 *. load_all in
 813       let str = sprintf "%5.2f" load_all in
 814       let () =
 815         GlMat.load_identity ();
 816         let strw =
 817           if false
 818           then
 819             Glut.bitmapLength ~font ~str:str
 820           else
 821             strw
 822         in
 823         let x = -. (float strw /. float !w) in
 824           GlMat.translate ~y:~-.1.0 ~x ();
 825       in
 826       let () = draw_string 0.0 0.0 str in
 827         ()
 828     in
 829       GlDraw.viewport I.x (I.y + 15) !w (!h - 26);
 830       GlMat.load_identity ();
 831       GlMat.translate ~x:~-.1. ~y:~-.1.();
 832       let drawquad yb yt =
 833         GlDraw.begins `quads;
 834         GlDraw.vertex2 (0.0, yb);
 835         GlDraw.vertex2 (0.0, yt);
 836         GlDraw.vertex2 (2.0, yt);
 837         GlDraw.vertex2 (2.0, yb);
 838         GlDraw.ends ()
 839       in
 840       let fold yb (color, load) =
 841         if load > 0.0
 842         then
 843           let () = GlDraw.color color in
 844           let yt = yb +. 2.0*.load in
 845           let () = drawquad yb yt in
 846             yt
 847         else
 848           yb
 849       in
 850       let cl = I.getl load in
 851       let yb = List.fold_left fold 0.0 cl in
 852       let () = GlDraw.color (0.5, 0.5, 0.5) in
 853       let () = drawquad yb 2.0 in
 854       let () = GlList.call sepsl in
 855         GlMat.pop ();
 856         GlList.call sepsl;
 857   ;;
 858
 859   let update delta' load' =
 860     let delta = 1.0 /. delta' in
 861       load := scale_stat load' delta;
 862   ;;
 863 end
 864
 865 module Graph (V: View) =
 866 struct
 867   let ox = if !Args.scalebar then 0 else !Args.barw
 868   let sw = float V.w /. float (!Args.w - ox)
 869   let sh = float V.h /. float !Args.h
 870   let sx = float (V.x - ox)  /. float V.w
 871   let sy = float V.y /. float V.h
 872   let vw = ref 0
 873   let vh = ref 0
 874   let vx = ref 0
 875   let vy = ref 0
 876   let scale = V.freq /. V.interval
 877   let gscale = 1.0 /. float V.sgrid
 878   let nsamples = ref 0
 879
 880   let fw, fh =
 881     if !Args.labels
 882     then
 883       3 * Glut.bitmapWidth font (Char.code '%'), 20
 884     else
 885       0, 10
 886   ;;
 887
 888   let gridlist =
 889     let base = GlList.gen_lists ~len:1 in
 890       GlList.nth base ~pos:0
 891
 892   let viewport typ =
 893     let ox = if !Args.scalebar then 0 else !Args.barw in
 894     let x, y, w, h =
 895       match typ with
 896         | `labels -> (!vx + ox, !vy + 5, fw, !vh - fh)
 897         | `graph  -> (!vx + fw + 5 + ox, !vy + 5, !vw - fw - 10, !vh - fh)
 898     in
 899       GlDraw.viewport x y w h;
 900   ;;
 901
 902   let sgrid () =
 903     for i = 0 to V.sgrid
 904     do
 905       let x = if i = 0 then 0.0009 else float i *. gscale in
 906         GlDraw.vertex ~x ~y:0.0 ();
 907         GlDraw.vertex ~x ~y:1.0 ();
 908     done;
 909   ;;
 910
 911   let grid () =
 912     viewport `graph;
 913     GlDraw.line_width 1.0;
 914     GlDraw.color (0.0, 1.0, 0.0);
 915     GlDraw.begins `lines;
 916     if !Args.mgrid
 917     then
 918       begin
 919         GlDraw.vertex2 (0.0009, 0.0);
 920         GlDraw.vertex2 (0.0009, 1.0);
 921         GlDraw.vertex2 (1.0000, 0.0);
 922         GlDraw.vertex2 (1.0000, 1.0);
 923       end
 924     else
 925       sgrid ()
 926     ;
 927     let () =
 928       let lim = 100 / V.pgrid in
 929         for i = 0 to lim
 930         do
 931           let y = (i * V.pgrid |> float) /. 100.0 in
 932           let y = if i = lim then y -. 0.0009 else y in
 933             GlDraw.vertex ~x:0.0 ~y ();
 934             GlDraw.vertex ~x:1.0 ~y ();
 935         done;
 936     in
 937     let () = GlDraw.ends () in
 938       if !Args.labels
 939       then
 940         begin
 941           viewport `labels;
 942           GlDraw.color (1.0, 1.0, 1.0);
 943           let ohp = 100.0 in
 944             for i = 0 to 100 / V.pgrid
 945             do
 946               let p = i * V.pgrid in
 947               let y = float p /. ohp in
 948               let s = Printf.sprintf "%3d%%" p in
 949                 draw_string 1.0 y s
 950             done
 951         end
 952   ;;
 953
 954   let reshape w h =
 955     let wxsw = float (w - ox) *. sw
 956     and hxsh = float h *. sh in
 957       vw := wxsw |> truncate;
 958       vh := hxsh |> truncate;
 959       vx := wxsw *. sx |> truncate;
 960       vy := hxsh *. sy |> truncate;
 961       GlList.begins gridlist `compile;
 962       grid ();
 963       GlList.ends ();
 964   ;;
 965
 966   let swap =
 967     Glut.swapBuffers |> oohz !Args.delay;
 968   ;;
 969
 970   let inc () = incr nsamples
 971
 972   let mgrid () =
 973     GlDraw.line_width 1.0;
 974     GlDraw.color (0.0, 1.0, 0.0);
 975     GlDraw.begins `lines;
 976     let offset =
 977       ((pred !nsamples |> float) *. scale /. gscale |> modf |> fst) *. gscale
 978     in
 979       for i = 0 to pred V.sgrid
 980       do
 981         let x = offset +. float i *. gscale in
 982           GlDraw.vertex ~x ~y:0.0 ();
 983           GlDraw.vertex ~x ~y:1.0 ();
 984       done;
 985       GlDraw.ends ();
 986   ;;
 987
 988   let display () =
 989     GlList.call gridlist;
 990     viewport `graph;
 991     if !Args.mgrid then mgrid ();
 992     GlDraw.line_width 2.0;
 993     let sample sampler =
 994       GlDraw.color sampler.color;
 995       let () =
 996         if not !Args.poly
 997         then GlDraw.begins `line_strip
 998         else
 999           begin
1000             GlDraw.begins `polygon;
1001             GlDraw.vertex2 (0.0, 0.0);
1002           end
1003       in
1004       let yield = sampler.getyielder () in
1005       let rec loop last i =
1006         match yield () with
1007           | Some y as opty ->
1008               let x = scale *. float i in
1009                 GlDraw.vertex ~x ~y ();
1010                 loop opty (succ i)
1011
1012           | None ->
1013               if !Args.poly
1014               then
1015                 match last with
1016                   | None -> ()
1017                   | Some y ->
1018                       let x = scale *. float (pred i) in
1019                         GlDraw.vertex ~x ~y:0.0 ()
1020       in
1021         loop None 0;
1022         GlDraw.ends ();
1023     in
1024       List.iter sample V.samplers;
1025   ;;
1026
1027   let funcs = display, reshape, inc
1028 end
1029
1030 let getplacements w h n barw =
1031   let sr = float n |> sqrt |> ceil |> truncate in
1032   let d = n / sr in
1033   let r = if n mod sr = 0 then 0 else 1 in
1034   let x, y =
1035     if w - barw > h
1036     then
1037       sr + r, d
1038     else
1039       d, sr + r
1040   in
1041   let w' = w - barw in
1042   let h' = h in
1043   let vw = w' / x in
1044   let vh = h' / y in
1045   let rec loop accu i =
1046     if i = n
1047     then
1048       accu
1049     else
1050       let yc = i / x in
1051       let xc = i mod x in
1052       let xc = xc * vw + barw in
1053       let yc = yc * vh in
1054         (i, xc, yc) :: accu |> loop |< succ i
1055   in
1056     loop [] 0, vw, vh
1057 ;;
1058
1059 let create fd w h =
1060   let module S =
1061       struct
1062         let freq = !Args.freq
1063         let nsamples = !Args.interval /. freq |> ceil |> truncate
1064       end
1065   in
1066   let placements, vw, vh = getplacements w h NP.nprocs !Args.barw in
1067
1068   let iget () =
1069     if !Args.isampler then NP.idletimeofday fd NP.nprocs else [||]
1070   in
1071   let is = iget () in
1072
1073   let kget () =
1074     let gks = NP.parse_stat () in
1075       gks () |> Array.of_list
1076   in
1077   let ks = kget () in
1078
1079   let crgraph (kaccu, iaccu, gaccu) (i, x, y) =
1080     let module Si = Sampler (S) in
1081     let isampler =
1082       { getyielder = Si.getyielder
1083       ; color = (1.0, 1.0, 0.0)
1084       ; update = Si.update
1085       }
1086     in
1087     let module Sk = Sampler (S) in
1088     let ksampler =
1089       { getyielder = Sk.getyielder
1090       ; color = (1.0, 0.0, 0.0)
1091       ; update = Sk.update
1092       }
1093     in
1094     let module V = struct
1095       let x = x
1096       let y = y
1097       let w = vw
1098       let h = vh
1099       let freq = S.freq
1100       let interval = !Args.interval
1101       let pgrid = !Args.pgrid
1102       let sgrid = !Args.sgrid
1103       let samplers =
1104         if !Args.isampler
1105         then
1106           isampler :: (if !Args.ksampler then [ksampler] else [])
1107         else
1108           if !Args.ksampler then [ksampler] else []
1109     end
1110     in
1111     let module Graph = Graph (V) in
1112     let kaccu =
1113       if !Args.ksampler
1114       then
1115         let calc =
1116           if !Args.gzh
1117           then
1118             let d = ref 0.0 in
1119             let f d' = d := d' in
1120             let () = Gzh.gen f in
1121               fun _ _ _ ->
1122                 let d = !d in
1123                   { zero_stat with
1124                     all = d; iowait = d; user = 1.0 -. d; idle = d }
1125           else
1126             if !Args.uptime
1127             then
1128               let (u1, i1) = NP.parse_uptime () in
1129               let u1 = ref u1
1130               and i1 = ref i1 in
1131                 fun _ _ _ ->
1132                   let (u2, i2) = NP.parse_uptime () in
1133                   let du = u2 -. !u1
1134                   and di = i2 -. !i1 in
1135                   let d = di /. du in
1136                     u1 := u2;
1137                     i1 := i2;
1138                     { zero_stat with
1139                       all = d; iowait = d; user = 1.0 -. d; idle = d }
1140           else
1141             let i' = if i = NP.nprocs then 0 else succ i in
1142             let g ks n = Array.get ks i' |> snd |> Array.get |< n in
1143             let gall ks =
1144               let user = g ks NP.user
1145               and nice = g ks NP.nice
1146               and sys = g ks NP.sys
1147               and idle = g ks NP.idle
1148               and iowait = g ks NP.idle
1149               and intr = g ks NP.intr
1150               and softirq = g ks NP.softirq in
1151               let () =
1152                 if !Args.debug
1153                 then
1154                   eprintf
1155                     "user=%f nice=%f sys=%f iowait=%f intr=%f softirq=%f@."
1156                     user
1157                     nice
1158                     sys
1159                     iowait
1160                     intr
1161                     softirq
1162                 ;
1163               in
1164                 { all = idle
1165                 ; user = user
1166                 ; nice = nice
1167                 ; sys = sys
1168                 ; idle = idle
1169                 ; iowait = iowait
1170                 ; intr = intr
1171                 ; softirq = softirq
1172                 }
1173             in
1174             let i1 = ref (gall ks) in
1175               fun ks _ _ ->
1176                 let i2 = gall ks in
1177                 let diff = add_stat i2 (neg_stat !i1) in
1178                   i1 := i2;
1179                   diff
1180         in
1181           (i, calc, ksampler) :: kaccu
1182       else
1183         kaccu
1184     in
1185     let iaccu =
1186       if !Args.isampler
1187       then
1188         let calc =
1189           let i1 = Array.get is i |> ref in
1190             fun is t1 t2 ->
1191               let i2 = Array.get is i in
1192                 if classify_float i2 = FP_infinite
1193                 then
1194                   { zero_stat with all = t2 -. t1 }
1195                 else
1196                   let i1' = !i1 in
1197                     i1 := i2;
1198                     { zero_stat with all = i2 -. i1' }
1199         in
1200           (i, calc, isampler) :: iaccu
1201       else
1202         iaccu
1203     in
1204       kaccu, iaccu, Graph.funcs :: gaccu
1205   in
1206   let kl, il, gl = List.fold_left crgraph ([], [], []) placements in
1207     ((if kl == [] then (fun () -> [||]) else kget), kl), (iget, il), gl
1208 ;;
1209
1210 let opendev path =
1211   if not NP.linux
1212   then
1213     (* gross hack but we are not particularly picky today *)
1214     Unix.stdout
1215   else
1216     try
1217       if (Unix.stat path).Unix.st_kind != Unix.S_CHR
1218       then
1219         begin
1220           eprintf "File %S is not an ITC device@." path;
1221           exit 100
1222         end
1223       ;
1224       Unix.openfile path [Unix.O_RDONLY] 0
1225     with
1226       | Unix.Unix_error ((Unix.ENODEV | Unix.ENXIO) as err , s1, s2) ->
1227           eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1228             path s1 s2 |< Unix.error_message err;
1229           eprintf "(perhaps the module is not loaded?)@.";
1230           exit 100
1231
1232       | Unix.Unix_error (Unix.EALREADY, s1, s2) ->
1233           eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1234             path s1 s2 |< Unix.error_message Unix.EALREADY;
1235           eprintf "(perhaps modules is already in use?)@.";
1236           exit 100
1237
1238       | Unix.Unix_error (error, s1, s2) ->
1239           eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1240             path s1 s2 |< Unix.error_message error;
1241           exit 100
1242
1243       | exn ->
1244           eprintf "Could not open ITC device %S:\n%s@."
1245             path |< Printexc.to_string exn;
1246           exit 100
1247 ;;
1248
1249 let seticon () =
1250   let module X =
1251       struct
1252         external seticon : string -> unit = "ml_seticon"
1253       end
1254   in
1255   let len = 32*4 in
1256   let data = String.create |< 32*len + 2*4 in
1257   let line r g b a =
1258     let r = Char.chr r
1259     and g = Char.chr g
1260     and b = Char.chr b
1261     and a = Char.chr a in
1262     let s = String.create len in
1263     let rec fill x =
1264       if x = len
1265       then
1266         s
1267       else
1268         begin
1269           x + 0 |> String.set s |< b;
1270           x + 1 |> String.set s |< g;
1271           x + 2 |> String.set s |< r;
1272           x + 3 |> String.set s |< a;
1273           x + 4 |> fill
1274         end
1275     in
1276       fill 0
1277   in
1278   let el = line 0x00 0x00 0x00 0xff
1279   and kl = line 0xff 0x00 0x00 0xff
1280   and il = line 0xff 0xff 0x00 0xff in
1281   let fill l sy ey =
1282     let src = l and dst = data and src_pos = 0 in
1283     let rec loop n dst_pos =
1284       if n > 0
1285       then
1286         begin
1287           StringLabels.blit ~src ~src_pos ~dst ~dst_pos ~len;
1288           pred n |> loop |< dst_pos + len
1289         end
1290     in
1291       (ey - sy) |> loop |< (32 - ey) * len + 4*2
1292   in
1293     fun ~iload ~kload ->
1294       let iy = iload *. 32.0 |> ceil |> truncate |> max 0 |> min 32
1295       and ky = kload *. 32.0 |> ceil |> truncate |> max 0 |> min 32 in
1296       let ey =
1297         if ky < iy
1298         then
1299           (fill kl 0 ky; fill il ky iy; iy)
1300         else
1301           (fill kl 0 ky; ky)
1302       in
1303         fill el ey 32;
1304         X.seticon data;
1305 ;;
1306
1307 let create_bars h kactive iactive =
1308   let getlk kload =
1309     if !Args.sepstat
1310     then
1311       let sum = kload.user +. kload.nice +. kload.sys
1312         +. kload.intr +. kload.softirq
1313       in
1314         [ (1.0, 1.0, 0.0), kload.user
1315         ; (0.0, 0.0, 1.0), kload.nice
1316         ; (1.0, 0.0, 0.0), kload.sys
1317         ; (1.0, 1.0, 1.0), kload.intr
1318         ; (0.75, 0.5, 0.5), (1.0 -. kload.iowait) -. sum
1319         ; (0.0, 1.0, 0.0), kload.all -. kload.iowait -. kload.softirq
1320         ]
1321     else
1322       [ (1.0, 0.0, 0.0), 1.0 -. kload.idle ]
1323   in
1324   let getli iload =
1325     [ (1.0, 1.0, 0.0), 1.0 -. iload.all ]
1326   in
1327   let barw = !Args.barw in
1328   let nfuncs =
1329     (fun () -> ()), (fun _ _ -> ()), (fun _ _ -> ())
1330   in
1331   let kd, kr, ku =
1332     if kactive
1333     then
1334       let module Bar =
1335         Bar (struct
1336           let x = 3
1337           let y = 0
1338           let w = (if iactive then barw / 2 else barw) - 3
1339           let h = h
1340           let getl = getlk
1341         end)
1342       in
1343         Bar.display, Bar.reshape, Bar.update
1344     else
1345       nfuncs
1346   in
1347   let id, ir, iu =
1348     if iactive
1349     then
1350       let module Bar =
1351         Bar (struct
1352           let x = (if kactive then barw / 2 else 0) + 3
1353           let y = 0
1354           let w = (if kactive then barw / 2 else barw) - 3
1355           let h = h
1356           let getl = getli
1357         end)
1358       in
1359         Bar.display, Bar.reshape, Bar.update
1360     else
1361       nfuncs
1362   in
1363     if kactive
1364     then
1365       begin
1366       if iactive
1367       then
1368         let d () = kd (); id () in
1369         let r w h = kr w h; ir w h in
1370         let u d k i = ku d k; iu d i in
1371           d, r, u
1372       else
1373         kd, kr, (fun d k _ -> ku d k)
1374       end
1375     else
1376       begin
1377         if iactive
1378         then
1379           id, ir, (fun d _ i -> iu d i)
1380         else
1381           (fun () -> ()), (fun _ _ -> ()), (fun _ _ _ -> ())
1382       end
1383 ;;
1384
1385 let main () =
1386   let _ = Glut.init [|""|] in
1387   let () = Args.init () in
1388   let () =
1389     if !Args.verbose
1390     then
1391       "detected " ^ string_of_int NP.nprocs ^ " CPUs" |> print_endline
1392   in
1393   let () = if !Args.gzh then Gzh.init !Args.verbose else () in
1394   let () = Delay.init !Args.timer !Args.gzh in
1395   let () = if !Args.niceval != 0 then NP.setnice !Args.niceval else () in
1396   let w = !Args.w
1397   and h = !Args.h in
1398   let fd = opendev !Args.devpath in
1399   let module FullV = View (struct let w = w let h = h end) in
1400   let _winid = FullV.init () in
1401   let (kget, kfuncs), (iget, ifuncs), gl = create fd w h in
1402   let bar_update =
1403     List.iter FullV.add gl;
1404     if !Args.barw > 0
1405     then
1406       let (display, reshape, update) =
1407         create_bars h !Args.ksampler !Args.isampler
1408       in
1409         FullV.add (display, reshape, fun _ -> ());
1410         update
1411     else
1412       fun _ _ _ -> ()
1413   in
1414   let seticon = if !Args.icon then seticon () else fun ~iload ~kload -> () in
1415   let rec loop t1 () =
1416     let t2 = Unix.gettimeofday () in
1417     let dt = t2 -. t1 in
1418       if dt >= !Args.freq
1419       then
1420         let is = iget () in
1421         let ks = kget () in
1422         let rec loop2 load sample = function
1423           | [] -> load
1424           | (nr, calc, sampler) :: rest ->
1425               let cpuload = calc sample t1 t2 in
1426               let () =
1427                 let thisload = 1.0 -. (cpuload.all /. dt) in
1428                 let thisload = max 0.0 thisload in
1429                 if !Args.verbose
1430                 then
1431                   ("cpu load(" ^ string_of_int nr ^ "): "
1432                     ^ (thisload *. 100.0 |> string_of_float)
1433                   |> print_endline)
1434               in
1435               let load = add_stat load cpuload in
1436                 sampler.update dt cpuload.all;
1437                 loop2 load sample rest
1438         in
1439         let iload = loop2 zero_stat is ifuncs in
1440         let kload = loop2 zero_stat ks kfuncs in
1441           if !Args.debug
1442           then
1443             begin
1444               iload.all |> string_of_float |> prerr_endline;
1445               kload.all |> string_of_float |> prerr_endline;
1446             end
1447           ;
1448           seticon ~iload:iload.all ~kload:kload.all;
1449           bar_update dt kload iload;
1450           FullV.inc ();
1451           FullV.update ();
1452           FullV.func (Some (loop t2))
1453       else
1454         Delay.delay ()
1455   in
1456     FullV.func (Some (Unix.gettimeofday () |> loop));
1457     FullV.run ()
1458 ;;
1459
1460 let _ =
1461   try
1462     main ()
1463   with
1464     | Unix.Unix_error (e, s1, s2) ->
1465         Unix.error_message e |> eprintf "main failure: %s(%s): %s@." s1 s2
1466
1467     | exn ->
1468         Printexc.to_string exn |> eprintf "main failure: %s@."
1469 ;;