Erm...
[apc.git] / apc.ml
blob37b2a3f80124b8b5e26b4426159468e8778a7cd2
1 open Format
3 let (|>) x f = f x
4 let (|<) f x = f x
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
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
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
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
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
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
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
87 type os =
88 | Linux
89 | Windows
90 | Solaris
91 | MacOSX
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 external fixwindow : int -> unit = "ml_fixwindow"
109 external testpmc : unit -> bool = "ml_testpmc"
111 let os_type = os_type ()
113 let winnt = os_type = Windows
114 let solaris = os_type = Solaris
115 let linux = os_type = Linux
116 let macosx = os_type = MacOSX
118 let user = 0
119 let nice = 1
120 let sys = 2
121 let idle = 3
122 let iowait = 4
123 let intr = 5
124 let softirq = 6
126 let hz = get_hz () |> float
128 let parse_uptime () =
129 let ic = open_in "/proc/uptime" in
130 let vals = Scanf.fscanf ic "%f %f" (fun u i -> (u, i)) in
131 close_in ic;
132 vals
135 let nprocs = get_nprocs ()
137 let rec parse_int_cont s pos =
138 let jiffies_to_sec j =
139 float j /. hz
141 let slen = String.length s in
142 let pos =
143 let rec skipws pos =
144 if pos = slen
145 then
147 else
148 begin
149 if String.get s pos = ' '
150 then
151 succ pos |> skipws
152 else
155 in skipws pos
157 let endpos =
158 try String.index_from s pos ' '
159 with Not_found -> slen
161 let i = endpos - pos |> String.sub s pos
162 |> int_of_string
163 |> jiffies_to_sec in
164 if endpos = slen
165 then
166 `last i
167 else
168 `more (i, fun () -> succ endpos |> parse_int_cont s)
171 let parse_cpul s =
172 let rec tolist accu = function
173 | `last i -> i :: accu
174 | `more (i, f) -> f () |> tolist (i :: accu)
176 let index = String.index s ' ' in
177 let cpuname = String.sub s 0 index in
178 let vals = parse_int_cont s (succ index) |> tolist [] in
179 let vals = List.rev |<
180 if List.length vals < 7
181 then
182 0.0 :: 0.0 :: 0.0 :: 0.0 :: vals
183 else
184 vals
186 cpuname, Array.of_list vals
189 let parse_stat () =
190 match os_type with
191 | Windows ->
192 (fun () ->
193 let iukw = windows_processor_times nprocs in
194 let rec create n ai ak au ad ar accu =
195 if n = nprocs
196 then
197 ("cpu", [| au; ad; ak; ai; 0.0; ar; 0.0 |]) :: List.rev accu
198 else
199 let hdr = "cpu" ^ string_of_int n in
200 let o = n * 5 in
201 let i = Array.get iukw (o + 0) in
202 let k = Array.get iukw (o + 1) in
203 let u = Array.get iukw (o + 2) in
204 let d = Array.get iukw (o + 3) in
205 let r = Array.get iukw (o + 4) in
206 let ai = ai +. i in
207 let au = au +. u in
208 let ak = ak +. k in
209 let ad = ad +. d in
210 let ar = ar +. r in
211 let accu = (hdr, [| u; d; k; i; 0.0; r; 0.0 |]) :: accu in
212 create (succ n) ai ak au ad ar accu
214 create 0 0.0 0.0 0.0 0.0 0.0 []
217 | Linux ->
218 (fun () ->
219 let ic = open_in "/proc/stat" in
220 let rec loop i accu =
221 if i = -1
222 then
223 List.rev accu
224 else
225 (input_line ic |> parse_cpul) :: accu |> loop (pred i)
227 let ret = loop nprocs [] in
228 close_in ic;
232 | Solaris ->
233 (fun () ->
234 let iukw = solaris_kstat nprocs in
235 let rec create n ai au ak aw accu =
236 if n = nprocs
237 then
238 ("cpu", [| au; 0.0; ak; ai; aw; 0.0; 0.0 |]) :: List.rev accu
239 else
240 let hdr = "cpu" ^ string_of_int n in
241 let o = n * 4 in
242 let i = Array.get iukw (o + 0) /. hz in
243 let u = Array.get iukw (o + 1) /. hz in
244 let k = Array.get iukw (o + 2) /. hz in
245 let w = Array.get iukw (o + 3) /. hz in
246 let ai = ai +. i in
247 let au = au +. u in
248 let ak = ak +. k in
249 let aw = aw +. w in
250 let accu = (hdr, [| u; 0.0; k; i; w; 0.0; 0.0 |]) :: accu in
251 create (succ n) ai au ak aw accu
253 create 0 0.0 0.0 0.0 0.0 []
256 | MacOSX ->
257 (fun () ->
258 let iukn = macosx_host_processor_info nprocs in
259 let rec create c ai au ak an accu =
260 if c = nprocs
261 then
262 ("cpu", [| au; an; ak; ai; 0.0; 0.0; 0.0 |]) :: List.rev accu
263 else
264 let hdr = "cpu" ^ string_of_int c in
265 let o = c * 4 in
266 let i = Array.get iukn (o + 0) /. hz in
267 let u = Array.get iukn (o + 1) /. hz in
268 let k = Array.get iukn (o + 2) /. hz in
269 let n = Array.get iukn (o + 3) /. hz in
270 let ai = ai +. i in
271 let au = au +. u in
272 let ak = ak +. k in
273 let an = an +. n in
274 let accu = (hdr, [| u; n; k; i; 0.0; 0.0; 0.0 |]) :: accu in
275 create (succ c) ai au ak an accu
277 create 0 0.0 0.0 0.0 0.0 []
282 module Args =
283 struct
284 let banner =
285 [ "Amazing Piece of Code by insanely gifted programmer, Version 1.03"
286 ; "Motivation by: gzh and afs"
287 ; "usage: "
288 ] |> String.concat "\n"
290 let freq = ref 1.0
291 let interval = ref 15.0
292 let devpath = ref "/dev/itc"
293 let pgrid = ref 10
294 let sgrid = ref 15
295 let w = ref 400
296 let h = ref 200
297 let verbose = ref false
298 let delay = ref 0.04
299 let ksampler = ref true
300 let isampler = ref true
301 let barw = ref 100
302 let bars = ref 50
303 let sigway = ref (NP.os_type != NP.MacOSX)
304 let niceval = ref 0
305 let gzh = ref false
306 let scalebar = ref false
307 let timer = ref 100
308 let debug = ref false
309 let poly = ref false
310 let uptime = ref false
311 let icon = ref false
312 let labels = ref true
313 let mgrid = ref false
314 let sepstat = ref true
315 let grid_green = ref 0.75
317 let pad n s =
318 let l = String.length s in
319 if l >= n
320 then
322 else
323 let d = String.make n ' ' in
324 StringLabels.blit ~src:s ~dst:d
325 ~src_pos:0 ~len:l
326 ~dst_pos:0;
330 let sooo b = if b then "on" else "off"
331 let dA tos s {contents=v} = s ^ " (" ^ tos v ^ ")"
332 let dF = dA |< sprintf "%4.2f"
333 let dB = dA sooo
334 let dcB = dA sooo
335 let dI = dA string_of_int
336 let dS = dA (fun s -> "`" ^ String.escaped s ^ "'")
338 let sF opt r doc =
339 "-" ^ opt, Arg.Set_float r, pad 9 "<float> " ^ doc |> dF |< r
342 let sI opt r doc =
343 "-" ^ opt, Arg.Set_int r, pad 9 "<int> " ^ doc |> dI |< r
346 let sB opt r doc =
347 "-" ^ opt, Arg.Set r, pad 9 "" ^ doc |> dB |< r
350 let sS opt r doc =
351 "-" ^ opt, Arg.Set_string r, pad 9 "<string> " ^ doc |> dS |< r
354 let fB opt r doc =
355 if r.contents
356 then
357 "-" ^ opt, Arg.Clear r, pad 9 "" ^ doc |> dB |< r
358 else
359 "-" ^ opt, Arg.Set r, pad 9 "" ^ doc |> dcB |< r
362 let commonopts =
363 [ sF "f" freq "sampling frequency in seconds"
364 ; sF "D" delay "refresh delay in seconds"
365 ; sF "i" interval "history interval in seconds"
366 ; sI "p" pgrid "percent grid items"
367 ; sI "s" sgrid "history grid items"
368 ; sI "w" w "width"
369 ; sI "h" h "height"
370 ; sI "b" barw "bar width"
371 ; sI "B" bars "number of CPU bars"
372 ; sB "v" verbose "verbose"
373 ; fB "C" sepstat "separate sys/nice/intr/iowait values (kernel sampler)"
374 ; fB "c" scalebar "constant bar width"
375 ; fB "P" poly "filled area instead of lines"
376 ; fB "l" labels "labels"
377 ; fB "m" mgrid "moving grid"
381 let add_opts tail =
382 let add_linux opts =
383 sI "t" timer "timer frequency in herz"
384 :: fB "I" icon "icon (hack)"
385 :: sS "d" devpath "path to itc device"
386 :: (fB "k" ksampler |< "kernel sampler (`/proc/[stat|uptime]')")
387 :: (fB "M" isampler |< "idle sampler")
388 :: (fB "u" uptime
389 "`uptime' instead of `stat' as kernel sampler (UP only)")
390 :: sI "n" niceval "value to renice self on init"
391 :: fB "g" gzh "gzh way (does not quite work yet)"
392 :: fB "S" sigway "sigwait delay method"
393 :: opts
395 let add_solaris opts =
396 isampler := false;
397 fB "I" icon "icon (hack)"
398 :: opts
400 let add_windows opts =
401 isampler := false;
402 (fB "k" ksampler |< "kernel sampler (ZwQuerySystemInformation)")
403 :: (fB "M" isampler |< "idle sampler (PMC based)")
404 :: opts
406 let add_macosx opts =
407 isampler := false;
408 fB "g" gzh "gzh way (does not quite work yet)"
409 :: opts
411 match NP.os_type with
412 | NP.Linux -> add_linux tail
413 | NP.Windows -> add_windows tail
414 | NP.Solaris -> add_solaris tail
415 | NP.MacOSX -> add_macosx tail
418 let init () =
419 let opts = add_opts commonopts in
420 Arg.parse opts
421 (fun s ->
422 raise (Arg.Bad
423 ("Invocation error: Don't know what to do with " ^ s));
425 banner
427 let cp {contents=v} s =
428 if v <= 0
429 then (prerr_string s; prerr_endline " must be positive"; exit 1)
431 let cpf {contents=v} s =
432 if v <= 0.0
433 then (prerr_string s; prerr_endline " must be positive"; exit 1)
435 cp w "Width";
436 cp h "Height";
437 cp pgrid "Number of percent grid items";
438 cp sgrid "Number of history grid items";
439 cp bars "Number of CPU bars";
440 cp timer "Timer frequency";
441 cpf freq "Frequency";
442 cpf delay "Delay";
443 cpf interval "Interval";
444 if not (!isampler || !ksampler)
445 then
446 barw := 0
448 if NP.winnt && !isampler
449 then
450 isampler := NP.testpmc ()
455 module Gzh =
456 struct
457 let lim = ref 0
458 let stop = ref false
459 let refdt = ref 0.0
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 ())
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;
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
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
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;
519 !refdt /. dt |> f;
520 loop t2
522 Unix.gettimeofday () |> loop
524 let _ = Thread.create thf () in
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 ()
542 module Delay =
543 struct
544 let sighandler signr = ()
546 let winfreq = ref 0.0
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
564 Unix.sigprocmask Unix.SIG_BLOCK |< Sys.sigalrm :: l |> ignore;
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
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, _, _) -> ()
591 type sampler =
592 { color : Gl.rgb;
593 getyielder : unit -> unit -> float option;
594 update : float -> float -> unit;
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
606 let update v n =
607 let n = min nsamples n in
608 let rec loop i j =
609 if j = 0
610 then
612 else
613 let i =
614 if i = nsamples
615 then
617 else
620 Array.set samples i v;
621 loop (succ i) (pred j)
623 let () = loop !head n in
624 let () = head := (!head + n) mod nsamples in
625 let () = active := min (!active + n) nsamples in
629 let getyielder () =
630 let tail =
631 let d = !head - !active in
632 if d < 0
633 then
634 nsamples + d
635 else
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)
649 ry := yield 0;
650 (fun () -> !ry ());
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;
661 module type ViewSampler =
663 val getyielder : unit -> unit -> float option
664 val update : float -> float -> float -> float -> unit
667 module type View =
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
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 oldwidth = ref !Args.w
685 let barmode = ref false
686 let funcs = ref []
688 let keyboard ~key ~x ~y =
689 if key = 27 || key = Char.code 'q'
690 then
691 exit 0
693 if key = Char.code 'b' && not !barmode
694 then
695 begin
696 let h = Glut.get Glut.WINDOW_HEIGHT in
697 oldwidth := Glut.get Glut.WINDOW_WIDTH;
698 Glut.reshapeWindow ~w:(!Args.barw + 4) ~h;
699 barmode := true;
702 if key = Char.code 'a' && !barmode
703 then
704 begin
705 let h = Glut.get Glut.WINDOW_HEIGHT in
706 Glut.reshapeWindow ~w:!oldwidth ~h;
707 barmode := false;
712 let add dri =
713 funcs := dri :: !funcs
716 let display () =
717 GlClear.clear [`color];
718 List.iter (fun (display, _, _) -> display ()) !funcs;
719 Glut.swapBuffers ();
722 let reshape ~w ~h =
723 ww := w;
724 wh := h;
725 List.iter (fun (_, reshape, _) -> reshape w h) !funcs;
726 GlClear.clear [`color];
727 GlMat.mode `modelview;
728 GlMat.load_identity ();
729 GlMat.mode `projection;
730 GlMat.load_identity ();
731 GlMat.rotate ~y:1.0 ~angle:180.0 ();
732 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
733 GlMat.scale ~x:2.0 ~y:2.0 ();
734 Glut.postRedisplay ();
737 let init () =
738 let () =
739 Glut.initDisplayMode ~double_buffer:true ();
740 Glut.initWindowSize V.w V.h
742 let winid = Glut.createWindow "APC" in
743 Glut.displayFunc display;
744 Glut.reshapeFunc reshape;
745 Glut.keyboardFunc keyboard;
746 GlDraw.color (1.0, 1.0, 0.0);
747 winid;
750 let inc () = List.iter (fun (_, _, inc) -> inc ()) !funcs
751 let update = Glut.postRedisplay
752 let func = Glut.idleFunc
753 let run = Glut.mainLoop
756 module type BarInfo =
758 val x : int
759 val y : int
760 val w : int
761 val h : int
762 val getl : stats -> ((float * float * float) * float) list
765 module Bar (I: BarInfo) =
766 struct
767 let w = ref I.w
768 let dontdraw = ref false
769 let h = ref I.h
770 let xoffset = ref I.x
771 let xratio = float I.x /. float !Args.w
772 let wratio = float I.w /. float !Args.w
773 let load = ref zero_stat
774 let nrcpuscale = 1.0 /. float NP.nprocs
775 let fh = 12
776 let strw = Glut.bitmapLength ~font ~str:"55.55"
777 let sepsl =
778 let base = GlList.gen_lists ~len:1 in
779 GlList.nth base ~pos:0
782 let seps () =
783 let hh = !h - 26 in
784 let () =
785 GlDraw.viewport !xoffset (I.y + 15) !w hh;
786 GlMat.push ();
787 GlMat.load_identity ();
788 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
789 GlMat.scale ~y:(2.0 /. (float hh)) ~x:1.0 ();
791 let seph = 1 in
792 let barh = float (hh - (!Args.bars - 1) * seph) /. float !Args.bars in
793 let barh = ceil barh |> truncate in
794 let rec loop i yb =
795 if yb > hh
796 then
798 else
799 let yt = yb + seph in
800 let yn = yt + barh in
801 let yb = float yb
802 and yt = float yt in
803 GlDraw.vertex2 (0.0, yb);
804 GlDraw.vertex2 (0.0, yt);
805 GlDraw.vertex2 (2.0, yt);
806 GlDraw.vertex2 (2.0, yb);
807 succ i |> loop |< yn
809 GlDraw.color (0.0, 0.0, 0.0);
810 GlDraw.begins `quads;
811 loop 0 barh;
812 GlDraw.ends ();
813 GlMat.pop ();
816 let reshape w' h' =
817 if !Args.scalebar
818 then
819 begin
820 w := float w' *. wratio |> truncate;
821 xoffset := float w' *. xratio |> truncate;
823 else
824 begin
825 w := I.w;
826 xoffset := I.x;
829 h := h';
830 GlList.begins sepsl `compile;
831 seps ();
832 GlList.ends ();
833 dontdraw :=
834 !h < 20 || !w < 20 || !xoffset < 0
838 let display_aux () =
839 let load = scale_stat !load nrcpuscale in
840 let load_all = min (1.0 -. load.all) 1.0 |> max 0.0 in
841 let () = GlMat.push () in
842 let () =
843 GlDraw.viewport !xoffset (I.y + 2) !w !h;
844 GlDraw.color (1.0, 1.0, 1.0);
845 let load_all = 100.0 *. load_all in
846 let str = sprintf "%5.2f" load_all in
847 let () =
848 GlMat.load_identity ();
849 let strw =
850 if false
851 then
852 Glut.bitmapLength ~font ~str:str
853 else
854 strw
856 let x = -. (float strw /. float !w) in
857 GlMat.translate ~y:~-.1.0 ~x ();
859 let () = draw_string 0.0 0.0 str in
862 GlDraw.viewport !xoffset (I.y + 15) !w (!h - 26);
863 GlMat.load_identity ();
864 GlMat.translate ~x:~-.1. ~y:~-.1.();
865 let drawquad yb yt =
866 GlDraw.begins `quads;
867 GlDraw.vertex2 (0.0, yb);
868 GlDraw.vertex2 (0.0, yt);
869 GlDraw.vertex2 (2.0, yt);
870 GlDraw.vertex2 (2.0, yb);
871 GlDraw.ends ()
873 let fold yb (color, load) =
874 if load > 0.0
875 then
876 let () = GlDraw.color color in
877 let yt = yb +. 2.0*.load in
878 let () = drawquad yb yt in
880 else
883 let cl = I.getl load in
884 let yb = List.fold_left fold 0.0 cl in
885 let () = GlDraw.color (0.5, 0.5, 0.5) in
886 let () = drawquad yb 2.0 in
887 let () = GlList.call sepsl in
888 GlMat.pop ();
889 GlList.call sepsl;
892 let display () =
893 if !dontdraw
894 then
896 else
897 display_aux ()
901 let update delta' load' =
902 let delta = 1.0 /. delta' in
903 load := scale_stat load' delta;
907 module Graph (V: View) =
908 struct
909 let ox = if !Args.scalebar then 0 else !Args.barw
910 let sw = float V.w /. float (!Args.w - ox)
911 let sh = float V.h /. float !Args.h
912 let sx = float (V.x - ox) /. float V.w
913 let sy = float V.y /. float V.h
914 let vw = ref 0
915 let vh = ref 0
916 let vx = ref 0
917 let vy = ref 0
918 let scale = V.freq /. V.interval
919 let gscale = 1.0 /. float V.sgrid
920 let nsamples = ref 0
921 let dontdraw = ref false
923 let fw, fh =
924 if !Args.labels
925 then
926 3 * Glut.bitmapWidth font (Char.code '%'), 20
927 else
928 0, 10
931 let gridlist =
932 let base = GlList.gen_lists ~len:1 in
933 GlList.nth base ~pos:0
936 let getviewport typ =
937 let ox = if !Args.scalebar then 0 else !Args.barw in
938 match typ with
939 | `labels -> (!vx + ox, !vy + 5, fw, !vh - fh)
940 | `graph -> (!vx + fw + 5 + ox, !vy + 5, !vw - fw - 10, !vh - fh)
943 let viewport typ =
944 let x, y, w, h = getviewport typ in
945 GlDraw.viewport x y w h;
948 let sgrid () =
949 for i = 0 to V.sgrid
951 let x = if i = 0 then 0.00009 else float i *. gscale in
952 let x = if i = V.sgrid then x -. 0.0009 else x in
953 GlDraw.vertex ~x ~y:0.0 ();
954 GlDraw.vertex ~x ~y:1.0 ();
955 done;
958 let grid () =
959 viewport `graph;
960 GlDraw.line_width 1.0;
961 GlDraw.color (0.0, !Args.grid_green, 0.0);
962 GlDraw.begins `lines;
963 if !Args.mgrid
964 then
965 begin
966 GlDraw.vertex2 (0.0009, 0.0);
967 GlDraw.vertex2 (0.0009, 1.0);
968 GlDraw.vertex2 (1.0000, 0.0);
969 GlDraw.vertex2 (1.0000, 1.0);
971 else
972 sgrid ()
974 let () =
975 let lim = 100 / V.pgrid in
976 for i = 0 to lim
978 let y = (i * V.pgrid |> float) /. 100.0 in
979 let y = if i = lim then y -. 0.0009 else y in
980 let y = if i = 0 then 0.0009 else y in
981 GlDraw.vertex ~x:0.0 ~y ();
982 GlDraw.vertex ~x:1.0 ~y ();
983 done;
985 let () = GlDraw.ends () in
986 if !Args.labels
987 then
988 begin
989 viewport `labels;
990 GlDraw.color (1.0, 1.0, 1.0);
991 let ohp = 100.0 in
992 for i = 0 to 100 / V.pgrid
994 let p = i * V.pgrid in
995 let y = float p /. ohp in
996 let s = sprintf "%3d%%" p in
997 draw_string 1.0 y s
998 done
1002 let reshape w h =
1003 let wxsw = float (w - ox) *. sw
1004 and hxsh = float h *. sh in
1005 vw := wxsw |> truncate;
1006 vh := hxsh |> truncate;
1007 vx := wxsw *. sx |> truncate;
1008 vy := hxsh *. sy |> truncate;
1009 dontdraw :=
1011 let x0, y0, w0, h0 = getviewport `labels in
1012 let x1, y1, w1, h1 = getviewport `graph in
1013 (!Args.labels && (w0 < 20 || h0 < 20 || x0 < 0 || y0 < 0))
1014 || (w1 < 20 || h1 < 20 || x1 < 0 || y1 < 0)
1017 if not !dontdraw
1018 then
1019 begin
1020 GlList.begins gridlist `compile;
1021 grid ();
1022 GlList.ends ();
1026 let swap =
1027 Glut.swapBuffers |> oohz !Args.delay;
1030 let inc () = incr nsamples
1032 let mgrid () =
1033 GlDraw.line_width 1.0;
1034 GlDraw.color (0.0, !Args.grid_green, 0.0);
1035 GlDraw.begins `lines;
1036 let offset =
1037 ((pred !nsamples |> float) *. scale /. gscale |> modf |> fst) *. gscale
1039 for i = 0 to pred V.sgrid
1041 let x = offset +. float i *. gscale in
1042 GlDraw.vertex ~x ~y:0.0 ();
1043 GlDraw.vertex ~x ~y:1.0 ();
1044 done;
1045 GlDraw.ends ();
1048 let display_aux () =
1049 GlList.call gridlist;
1050 viewport `graph;
1051 if !Args.mgrid then mgrid ();
1052 GlDraw.line_width 2.0;
1053 let sample sampler =
1054 GlDraw.color sampler.color;
1055 let () =
1056 if not !Args.poly
1057 then GlDraw.begins `line_strip
1058 else
1059 begin
1060 GlDraw.begins `polygon;
1061 GlDraw.vertex2 (0.0, 0.0);
1064 let yield = sampler.getyielder () in
1065 let rec loop last i =
1066 match yield () with
1067 | Some y as opty ->
1068 let x = scale *. float i in
1069 GlDraw.vertex ~x ~y ();
1070 loop opty (succ i)
1072 | None ->
1073 if !Args.poly
1074 then
1075 match last with
1076 | None -> ()
1077 | Some y ->
1078 let x = scale *. float (pred i) in
1079 GlDraw.vertex ~x ~y:0.0 ()
1081 loop None 0;
1082 GlDraw.ends ();
1084 List.iter sample V.samplers;
1087 let display () =
1088 if not !dontdraw
1089 then
1090 display_aux ()
1091 else
1096 let funcs = display, reshape, inc
1099 let getplacements w h n barw =
1100 let sr = float n |> sqrt |> ceil |> truncate in
1101 let d = n / sr in
1102 let r = if n mod sr = 0 then 0 else 1 in
1103 let x, y =
1104 if w - barw > h
1105 then
1106 sr + r, d
1107 else
1108 d, sr + r
1110 let w' = w - barw in
1111 let h' = h in
1112 let vw = w' / x in
1113 let vh = h' / y in
1114 let rec loop accu i =
1115 if i = n
1116 then
1117 accu
1118 else
1119 let yc = i / x in
1120 let xc = i mod x in
1121 let xc = xc * vw + barw in
1122 let yc = yc * vh in
1123 (i, xc, yc) :: accu |> loop |< succ i
1125 loop [] 0, vw, vh
1128 let create fd w h =
1129 let module S =
1130 struct
1131 let freq = !Args.freq
1132 let nsamples = !Args.interval /. freq |> ceil |> truncate
1135 let placements, vw, vh = getplacements w h NP.nprocs !Args.barw in
1137 let iget () =
1138 if !Args.isampler then NP.idletimeofday fd NP.nprocs else [||]
1140 let is = iget () in
1142 let kget () =
1143 let gks = NP.parse_stat () in
1144 gks () |> Array.of_list
1146 let ks = kget () in
1148 let crgraph (kaccu, iaccu, gaccu) (i, x, y) =
1149 let module Si = Sampler (S) in
1150 let isampler =
1151 { getyielder = Si.getyielder
1152 ; color = (1.0, 1.0, 0.0)
1153 ; update = Si.update
1156 let module Sk = Sampler (S) in
1157 let ksampler =
1158 { getyielder = Sk.getyielder
1159 ; color = (1.0, 0.0, 0.0)
1160 ; update = Sk.update
1163 let module Sk2 = Sampler (S) in
1164 let ksampler2 =
1165 { getyielder = Sk2.getyielder
1166 ; color = (1.0, 1.0, 1.0)
1167 ; update = Sk2.update
1170 let module V = struct
1171 let x = x
1172 let y = y
1173 let w = vw
1174 let h = vh
1175 let freq = S.freq
1176 let interval = !Args.interval
1177 let pgrid = !Args.pgrid
1178 let sgrid = !Args.sgrid
1179 let samplers =
1180 ksampler2 ::
1181 if !Args.isampler
1182 then
1183 isampler :: (if !Args.ksampler then [ksampler] else [])
1184 else
1185 if !Args.ksampler then [ksampler] else []
1188 let module Graph = Graph (V) in
1189 let kaccu =
1190 if !Args.ksampler
1191 then
1192 let calc =
1193 if !Args.gzh
1194 then
1195 let d = ref 0.0 in
1196 let f d' = d := d' in
1197 let () = Gzh.gen f in
1198 fun _ _ _ ->
1199 let d = !d in
1200 { zero_stat with
1201 all = d; iowait = d; user = 1.0 -. d; idle = d }
1202 else
1203 if !Args.uptime
1204 then
1205 let (u1, i1) = NP.parse_uptime () in
1206 let u1 = ref u1
1207 and i1 = ref i1 in
1208 fun _ _ _ ->
1209 let (u2, i2) = NP.parse_uptime () in
1210 let du = u2 -. !u1
1211 and di = i2 -. !i1 in
1212 let d = di /. du in
1213 u1 := u2;
1214 i1 := i2;
1215 { zero_stat with
1216 all = d; iowait = d; user = 1.0 -. d; idle = d }
1217 else
1218 let i' = if i = NP.nprocs then 0 else succ i in
1219 let g ks n = Array.get ks i' |> snd |> Array.get |< n in
1220 let gall ks =
1221 let user = g ks NP.user
1222 and nice = g ks NP.nice
1223 and sys = g ks NP.sys
1224 and idle = g ks NP.idle
1225 and iowait = g ks NP.idle
1226 and intr = g ks NP.intr
1227 and softirq = g ks NP.softirq in
1228 let () =
1229 if !Args.debug
1230 then
1231 eprintf
1232 "user=%f nice=%f sys=%f iowait=%f intr=%f softirq=%f@."
1233 user
1234 nice
1236 iowait
1237 intr
1238 softirq
1241 { all = user +. nice +. sys
1242 ; user = user
1243 ; nice = nice
1244 ; sys = sys
1245 ; idle = idle
1246 ; iowait = iowait
1247 ; intr = intr
1248 ; softirq = softirq
1251 let i1 = ref (gall ks) in
1252 fun ks t1 t2 ->
1253 let i2 = gall ks in
1254 let diff = add_stat i2 (neg_stat !i1) in
1255 let diff = { diff with all = t2 -. t1 -. diff.all } in
1256 i1 := i2;
1257 diff
1259 let calc2 =
1260 let idle1 = ref 0.0 in
1261 fun ks (t1 : float) (t2 : float) ->
1262 let i' = if i = NP.nprocs then 0 else succ i in
1263 let g ks n = Array.get ks i' |> snd |> Array.get |< n in
1264 let idle2 = g ks NP.idle in
1265 let diff = idle2 -. !idle1 in
1266 let diff = { zero_stat with all = diff } in
1267 idle1 := idle2;
1268 diff
1270 (i, calc, ksampler)
1271 (* :: (i, calc2, ksampler2) *)
1272 :: kaccu
1273 else
1274 kaccu
1276 let iaccu =
1277 if !Args.isampler
1278 then
1279 let calc =
1280 let i1 = Array.get is i |> ref in
1281 fun is t1 t2 ->
1282 let i2 = Array.get is i in
1283 if classify_float i2 = FP_infinite
1284 then
1285 { zero_stat with all = t2 -. t1 }
1286 else
1287 let i1' = !i1 in
1288 i1 := i2;
1289 { zero_stat with all = i2 -. i1' }
1291 (i, calc, isampler) :: iaccu
1292 else
1293 iaccu
1295 kaccu, iaccu, Graph.funcs :: gaccu
1297 let kl, il, gl = List.fold_left crgraph ([], [], []) placements in
1298 ((if kl == [] then (fun () -> [||]) else kget), kl), (iget, il), gl
1301 let opendev path =
1302 if not NP.linux
1303 then
1304 (* gross hack but we are not particularly picky today *)
1305 Unix.stdout
1306 else
1308 if (Unix.stat path).Unix.st_kind != Unix.S_CHR
1309 then
1310 begin
1311 eprintf "File %S is not an ITC device@." path;
1312 exit 100
1315 Unix.openfile path [Unix.O_RDONLY] 0
1316 with
1317 | Unix.Unix_error ((Unix.ENODEV | Unix.ENXIO) as err , s1, s2) ->
1318 eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1319 path s1 s2 |< Unix.error_message err;
1320 eprintf "(perhaps the module is not loaded?)@.";
1321 exit 100
1323 | Unix.Unix_error (Unix.EALREADY, s1, s2) ->
1324 eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1325 path s1 s2 |< Unix.error_message Unix.EALREADY;
1326 eprintf "(perhaps modules is already in use?)@.";
1327 exit 100
1329 | Unix.Unix_error (error, s1, s2) ->
1330 eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1331 path s1 s2 |< Unix.error_message error;
1332 exit 100
1334 | exn ->
1335 eprintf "Could not open ITC device %S:\n%s@."
1336 path |< Printexc.to_string exn;
1337 exit 100
1340 let seticon () =
1341 let module X =
1342 struct
1343 external seticon : string -> unit = "ml_seticon"
1346 let len = 32*4 in
1347 let data = String.create |< 32*len + 2*4 in
1348 let line r g b a =
1349 let r = Char.chr r
1350 and g = Char.chr g
1351 and b = Char.chr b
1352 and a = Char.chr a in
1353 let s = String.create len in
1354 let rec fill x =
1355 if x = len
1356 then
1358 else
1359 begin
1360 x + 0 |> String.set s |< b;
1361 x + 1 |> String.set s |< g;
1362 x + 2 |> String.set s |< r;
1363 x + 3 |> String.set s |< a;
1364 x + 4 |> fill
1367 fill 0
1369 let el = line 0x00 0x00 0x00 0xff
1370 and kl = line 0xff 0x00 0x00 0xff
1371 and il = line 0xff 0xff 0x00 0xff in
1372 let fill l sy ey =
1373 let src = l and dst = data and src_pos = 0 in
1374 let rec loop n dst_pos =
1375 if n > 0
1376 then
1377 begin
1378 StringLabels.blit ~src ~src_pos ~dst ~dst_pos ~len;
1379 pred n |> loop |< dst_pos + len
1382 (ey - sy) |> loop |< (32 - ey) * len + 4*2
1384 fun ~iload ~kload ->
1385 let iy = iload *. 32.0 |> ceil |> truncate |> max 0 |> min 32
1386 and ky = kload *. 32.0 |> ceil |> truncate |> max 0 |> min 32 in
1387 let ey =
1388 if ky < iy
1389 then
1390 (fill kl 0 ky; fill il ky iy; iy)
1391 else
1392 (fill kl 0 ky; ky)
1394 fill el ey 32;
1395 X.seticon data;
1398 let create_bars h kactive iactive =
1399 let getlk kload =
1400 if !Args.sepstat
1401 then
1402 let sum = kload.user +. kload.nice +. kload.sys
1403 +. kload.intr +. kload.softirq
1405 [ (1.0, 1.0, 0.0), kload.user
1406 ; (0.0, 0.0, 1.0), kload.nice
1407 ; (1.0, 0.0, 0.0), kload.sys
1408 ; (1.0, 1.0, 1.0), kload.intr
1409 ; (0.5, 0.8, 1.0), kload.softirq
1410 ; (0.75, 0.5, 0.5), (1.0 -. kload.iowait) -. sum
1411 (* ; (0.0, 1.0, 0.0), kload.all -. kload.iowait -. kload.softirq *)
1413 else
1414 [ (1.0, 0.0, 0.0), 1.0 -. kload.idle ]
1416 let getli iload =
1417 [ (1.0, 1.0, 0.0), 1.0 -. iload.all ]
1419 let barw = !Args.barw in
1420 let nfuncs =
1421 (fun () -> ()), (fun _ _ -> ()), (fun _ _ -> ())
1423 let kd, kr, ku =
1424 if kactive
1425 then
1426 let module Bar =
1427 Bar (struct
1428 let x = 3
1429 let y = 0
1430 let w = (if iactive then barw / 2 else barw) - 3
1431 let h = h
1432 let getl = getlk
1433 end)
1435 Bar.display, Bar.reshape, Bar.update
1436 else
1437 nfuncs
1439 let id, ir, iu =
1440 if iactive
1441 then
1442 let module Bar =
1443 Bar (struct
1444 let x = (if kactive then barw / 2 else 0) + 3
1445 let y = 0
1446 let w = (if kactive then barw / 2 else barw) - 3
1447 let h = h
1448 let getl = getli
1449 end)
1451 Bar.display, Bar.reshape, Bar.update
1452 else
1453 nfuncs
1455 if kactive
1456 then
1457 begin
1458 if iactive
1459 then
1460 let d () = kd (); id () in
1461 let r w h = kr w h; ir w h in
1462 let u d k i = ku d k; iu d i in
1463 d, r, u
1464 else
1465 kd, kr, (fun d k _ -> ku d k)
1467 else
1468 begin
1469 if iactive
1470 then
1471 id, ir, (fun d _ i -> iu d i)
1472 else
1473 (fun () -> ()), (fun _ _ -> ()), (fun _ _ _ -> ())
1477 let main () =
1478 let _ = Glut.init [|""|] in
1479 let () = Args.init () in
1480 let () =
1481 if !Args.verbose
1482 then
1483 "detected " ^ string_of_int NP.nprocs ^ " CPUs" |> print_endline
1485 let () = if !Args.gzh then Gzh.init !Args.verbose else () in
1486 let () = Delay.init !Args.timer !Args.gzh in
1487 let () = if !Args.niceval != 0 then NP.setnice !Args.niceval else () in
1488 let w = !Args.w
1489 and h = !Args.h in
1490 let fd = opendev !Args.devpath in
1491 let module FullV = View (struct let w = w let h = h end) in
1492 let winid = FullV.init () in
1493 let () = NP.fixwindow winid in
1494 let (kget, kfuncs), (iget, ifuncs), gl = create fd w h in
1495 let bar_update =
1496 List.iter FullV.add gl;
1497 if !Args.barw > 0
1498 then
1499 let (display, reshape, update) =
1500 create_bars h !Args.ksampler !Args.isampler
1502 FullV.add (display, reshape, fun _ -> ());
1503 update
1504 else
1505 fun _ _ _ -> ()
1507 let seticon = if !Args.icon then seticon () else fun ~iload ~kload -> () in
1508 let rec loop t1 () =
1509 let t2 = Unix.gettimeofday () in
1510 let dt = t2 -. t1 in
1511 if dt >= !Args.freq
1512 then
1513 let is = iget () in
1514 let ks = kget () in
1515 let rec loop2 load sample = function
1516 | [] -> load
1517 | (nr, calc, sampler) :: rest ->
1518 let cpuload = calc sample t1 t2 in
1519 let () =
1520 let thisload = 1.0 -. (cpuload.all /. dt) in
1521 let thisload = max 0.0 thisload in
1522 if !Args.verbose
1523 then
1524 ("cpu load(" ^ string_of_int nr ^ "): "
1525 ^ (thisload *. 100.0 |> string_of_float)
1526 |> print_endline)
1528 let load = add_stat load cpuload in
1529 sampler.update dt cpuload.all;
1530 loop2 load sample rest
1532 let iload = loop2 zero_stat is ifuncs in
1533 let kload = loop2 zero_stat ks kfuncs in
1534 if !Args.debug
1535 then
1536 begin
1537 iload.all |> string_of_float |> prerr_endline;
1538 kload.all |> string_of_float |> prerr_endline;
1541 seticon ~iload:iload.all ~kload:kload.all;
1542 bar_update dt kload iload;
1543 FullV.inc ();
1544 FullV.update ();
1545 FullV.func (Some (loop t2))
1546 else
1547 Delay.delay ()
1549 FullV.func (Some (Unix.gettimeofday () |> loop));
1550 FullV.run ()
1553 let _ =
1555 main ()
1556 with
1557 | Unix.Unix_error (e, s1, s2) ->
1558 Unix.error_message e |> eprintf "main failure: %s(%s): %s@." s1 s2
1560 | exn ->
1561 Printexc.to_string exn |> eprintf "main failure: %s@."