Add IRQ accounting but only on PPC
[apc.git] / apc.ml
bloba907d4def4a4b7da6abe63cca1f2ff30d603d2a0
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.0009 else float i *. gscale in
952 GlDraw.vertex ~x ~y:0.0 ();
953 GlDraw.vertex ~x ~y:1.0 ();
954 done;
957 let grid () =
958 viewport `graph;
959 GlDraw.line_width 1.0;
960 GlDraw.color (0.0, !Args.grid_green, 0.0);
961 GlDraw.begins `lines;
962 if !Args.mgrid
963 then
964 begin
965 GlDraw.vertex2 (0.0009, 0.0);
966 GlDraw.vertex2 (0.0009, 1.0);
967 GlDraw.vertex2 (1.0000, 0.0);
968 GlDraw.vertex2 (1.0000, 1.0);
970 else
971 sgrid ()
973 let () =
974 let lim = 100 / V.pgrid in
975 for i = 0 to lim
977 let y = (i * V.pgrid |> float) /. 100.0 in
978 let y = if i = lim then y -. 0.0009 else y in
979 GlDraw.vertex ~x:0.0 ~y ();
980 GlDraw.vertex ~x:1.0 ~y ();
981 done;
983 let () = GlDraw.ends () in
984 if !Args.labels
985 then
986 begin
987 viewport `labels;
988 GlDraw.color (1.0, 1.0, 1.0);
989 let ohp = 100.0 in
990 for i = 0 to 100 / V.pgrid
992 let p = i * V.pgrid in
993 let y = float p /. ohp in
994 let s = sprintf "%3d%%" p in
995 draw_string 1.0 y s
996 done
1000 let reshape w h =
1001 let wxsw = float (w - ox) *. sw
1002 and hxsh = float h *. sh in
1003 vw := wxsw |> truncate;
1004 vh := hxsh |> truncate;
1005 vx := wxsw *. sx |> truncate;
1006 vy := hxsh *. sy |> truncate;
1007 dontdraw :=
1009 let x0, y0, w0, h0 = getviewport `labels in
1010 let x1, y1, w1, h1 = getviewport `graph in
1011 (!Args.labels && (w0 < 20 || h0 < 20 || x0 < 0 || y0 < 0))
1012 || (w1 < 20 || h1 < 20 || x1 < 0 || y1 < 0)
1015 if not !dontdraw
1016 then
1017 begin
1018 GlList.begins gridlist `compile;
1019 grid ();
1020 GlList.ends ();
1024 let swap =
1025 Glut.swapBuffers |> oohz !Args.delay;
1028 let inc () = incr nsamples
1030 let mgrid () =
1031 GlDraw.line_width 1.0;
1032 GlDraw.color (0.0, !Args.grid_green, 0.0);
1033 GlDraw.begins `lines;
1034 let offset =
1035 ((pred !nsamples |> float) *. scale /. gscale |> modf |> fst) *. gscale
1037 for i = 0 to pred V.sgrid
1039 let x = offset +. float i *. gscale in
1040 GlDraw.vertex ~x ~y:0.0 ();
1041 GlDraw.vertex ~x ~y:1.0 ();
1042 done;
1043 GlDraw.ends ();
1046 let display_aux () =
1047 GlList.call gridlist;
1048 viewport `graph;
1049 if !Args.mgrid then mgrid ();
1050 GlDraw.line_width 2.0;
1051 let sample sampler =
1052 GlDraw.color sampler.color;
1053 let () =
1054 if not !Args.poly
1055 then GlDraw.begins `line_strip
1056 else
1057 begin
1058 GlDraw.begins `polygon;
1059 GlDraw.vertex2 (0.0, 0.0);
1062 let yield = sampler.getyielder () in
1063 let rec loop last i =
1064 match yield () with
1065 | Some y as opty ->
1066 let x = scale *. float i in
1067 GlDraw.vertex ~x ~y ();
1068 loop opty (succ i)
1070 | None ->
1071 if !Args.poly
1072 then
1073 match last with
1074 | None -> ()
1075 | Some y ->
1076 let x = scale *. float (pred i) in
1077 GlDraw.vertex ~x ~y:0.0 ()
1079 loop None 0;
1080 GlDraw.ends ();
1082 List.iter sample V.samplers;
1085 let display () =
1086 if not !dontdraw
1087 then
1088 display_aux ()
1089 else
1094 let funcs = display, reshape, inc
1097 let getplacements w h n barw =
1098 let sr = float n |> sqrt |> ceil |> truncate in
1099 let d = n / sr in
1100 let r = if n mod sr = 0 then 0 else 1 in
1101 let x, y =
1102 if w - barw > h
1103 then
1104 sr + r, d
1105 else
1106 d, sr + r
1108 let w' = w - barw in
1109 let h' = h in
1110 let vw = w' / x in
1111 let vh = h' / y in
1112 let rec loop accu i =
1113 if i = n
1114 then
1115 accu
1116 else
1117 let yc = i / x in
1118 let xc = i mod x in
1119 let xc = xc * vw + barw in
1120 let yc = yc * vh in
1121 (i, xc, yc) :: accu |> loop |< succ i
1123 loop [] 0, vw, vh
1126 let create fd w h =
1127 let module S =
1128 struct
1129 let freq = !Args.freq
1130 let nsamples = !Args.interval /. freq |> ceil |> truncate
1133 let placements, vw, vh = getplacements w h NP.nprocs !Args.barw in
1135 let iget () =
1136 if !Args.isampler then NP.idletimeofday fd NP.nprocs else [||]
1138 let is = iget () in
1140 let kget () =
1141 let gks = NP.parse_stat () in
1142 gks () |> Array.of_list
1144 let ks = kget () in
1146 let crgraph (kaccu, iaccu, gaccu) (i, x, y) =
1147 let module Si = Sampler (S) in
1148 let isampler =
1149 { getyielder = Si.getyielder
1150 ; color = (1.0, 1.0, 0.0)
1151 ; update = Si.update
1154 let module Sk = Sampler (S) in
1155 let ksampler =
1156 { getyielder = Sk.getyielder
1157 ; color = (1.0, 0.0, 0.0)
1158 ; update = Sk.update
1161 let module V = struct
1162 let x = x
1163 let y = y
1164 let w = vw
1165 let h = vh
1166 let freq = S.freq
1167 let interval = !Args.interval
1168 let pgrid = !Args.pgrid
1169 let sgrid = !Args.sgrid
1170 let samplers =
1171 if !Args.isampler
1172 then
1173 isampler :: (if !Args.ksampler then [ksampler] else [])
1174 else
1175 if !Args.ksampler then [ksampler] else []
1178 let module Graph = Graph (V) in
1179 let kaccu =
1180 if !Args.ksampler
1181 then
1182 let calc =
1183 if !Args.gzh
1184 then
1185 let d = ref 0.0 in
1186 let f d' = d := d' in
1187 let () = Gzh.gen f in
1188 fun _ _ _ ->
1189 let d = !d in
1190 { zero_stat with
1191 all = d; iowait = d; user = 1.0 -. d; idle = d }
1192 else
1193 if !Args.uptime
1194 then
1195 let (u1, i1) = NP.parse_uptime () in
1196 let u1 = ref u1
1197 and i1 = ref i1 in
1198 fun _ _ _ ->
1199 let (u2, i2) = NP.parse_uptime () in
1200 let du = u2 -. !u1
1201 and di = i2 -. !i1 in
1202 let d = di /. du in
1203 u1 := u2;
1204 i1 := i2;
1205 { zero_stat with
1206 all = d; iowait = d; user = 1.0 -. d; idle = d }
1207 else
1208 let i' = if i = NP.nprocs then 0 else succ i in
1209 let g ks n = Array.get ks i' |> snd |> Array.get |< n in
1210 let gall ks =
1211 let user = g ks NP.user
1212 and nice = g ks NP.nice
1213 and sys = g ks NP.sys
1214 and idle = g ks NP.idle
1215 and iowait = g ks NP.idle
1216 and intr = g ks NP.intr
1217 and softirq = g ks NP.softirq in
1218 let () =
1219 if !Args.debug
1220 then
1221 eprintf
1222 "user=%f nice=%f sys=%f iowait=%f intr=%f softirq=%f@."
1223 user
1224 nice
1226 iowait
1227 intr
1228 softirq
1231 { all = idle
1232 ; user = user
1233 ; nice = nice
1234 ; sys = sys
1235 ; idle = idle
1236 ; iowait = iowait
1237 ; intr = intr
1238 ; softirq = softirq
1241 let i1 = ref (gall ks) in
1242 fun ks _ _ ->
1243 let i2 = gall ks in
1244 let diff = add_stat i2 (neg_stat !i1) in
1245 i1 := i2;
1246 diff
1248 (i, calc, ksampler) :: kaccu
1249 else
1250 kaccu
1252 let iaccu =
1253 if !Args.isampler
1254 then
1255 let calc =
1256 let i1 = Array.get is i |> ref in
1257 fun is t1 t2 ->
1258 let i2 = Array.get is i in
1259 if classify_float i2 = FP_infinite
1260 then
1261 { zero_stat with all = t2 -. t1 }
1262 else
1263 let i1' = !i1 in
1264 i1 := i2;
1265 { zero_stat with all = i2 -. i1' }
1267 (i, calc, isampler) :: iaccu
1268 else
1269 iaccu
1271 kaccu, iaccu, Graph.funcs :: gaccu
1273 let kl, il, gl = List.fold_left crgraph ([], [], []) placements in
1274 ((if kl == [] then (fun () -> [||]) else kget), kl), (iget, il), gl
1277 let opendev path =
1278 if not NP.linux
1279 then
1280 (* gross hack but we are not particularly picky today *)
1281 Unix.stdout
1282 else
1284 if (Unix.stat path).Unix.st_kind != Unix.S_CHR
1285 then
1286 begin
1287 eprintf "File %S is not an ITC device@." path;
1288 exit 100
1291 Unix.openfile path [Unix.O_RDONLY] 0
1292 with
1293 | Unix.Unix_error ((Unix.ENODEV | Unix.ENXIO) as err , s1, s2) ->
1294 eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1295 path s1 s2 |< Unix.error_message err;
1296 eprintf "(perhaps the module is not loaded?)@.";
1297 exit 100
1299 | Unix.Unix_error (Unix.EALREADY, s1, s2) ->
1300 eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1301 path s1 s2 |< Unix.error_message Unix.EALREADY;
1302 eprintf "(perhaps modules is already in use?)@.";
1303 exit 100
1305 | Unix.Unix_error (error, s1, s2) ->
1306 eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1307 path s1 s2 |< Unix.error_message error;
1308 exit 100
1310 | exn ->
1311 eprintf "Could not open ITC device %S:\n%s@."
1312 path |< Printexc.to_string exn;
1313 exit 100
1316 let seticon () =
1317 let module X =
1318 struct
1319 external seticon : string -> unit = "ml_seticon"
1322 let len = 32*4 in
1323 let data = String.create |< 32*len + 2*4 in
1324 let line r g b a =
1325 let r = Char.chr r
1326 and g = Char.chr g
1327 and b = Char.chr b
1328 and a = Char.chr a in
1329 let s = String.create len in
1330 let rec fill x =
1331 if x = len
1332 then
1334 else
1335 begin
1336 x + 0 |> String.set s |< b;
1337 x + 1 |> String.set s |< g;
1338 x + 2 |> String.set s |< r;
1339 x + 3 |> String.set s |< a;
1340 x + 4 |> fill
1343 fill 0
1345 let el = line 0x00 0x00 0x00 0xff
1346 and kl = line 0xff 0x00 0x00 0xff
1347 and il = line 0xff 0xff 0x00 0xff in
1348 let fill l sy ey =
1349 let src = l and dst = data and src_pos = 0 in
1350 let rec loop n dst_pos =
1351 if n > 0
1352 then
1353 begin
1354 StringLabels.blit ~src ~src_pos ~dst ~dst_pos ~len;
1355 pred n |> loop |< dst_pos + len
1358 (ey - sy) |> loop |< (32 - ey) * len + 4*2
1360 fun ~iload ~kload ->
1361 let iy = iload *. 32.0 |> ceil |> truncate |> max 0 |> min 32
1362 and ky = kload *. 32.0 |> ceil |> truncate |> max 0 |> min 32 in
1363 let ey =
1364 if ky < iy
1365 then
1366 (fill kl 0 ky; fill il ky iy; iy)
1367 else
1368 (fill kl 0 ky; ky)
1370 fill el ey 32;
1371 X.seticon data;
1374 let create_bars h kactive iactive =
1375 let getlk kload =
1376 if !Args.sepstat
1377 then
1378 let sum = kload.user +. kload.nice +. kload.sys
1379 +. kload.intr +. kload.softirq
1381 [ (1.0, 1.0, 0.0), kload.user
1382 ; (0.0, 0.0, 1.0), kload.nice
1383 ; (1.0, 0.0, 0.0), kload.sys
1384 ; (1.0, 1.0, 1.0), kload.intr
1385 ; (0.5, 0.8, 1.0), kload.softirq
1386 ; (0.75, 0.5, 0.5), (1.0 -. kload.iowait) -. sum
1387 ; (0.0, 1.0, 0.0), kload.all -. kload.iowait -. kload.softirq
1389 else
1390 [ (1.0, 0.0, 0.0), 1.0 -. kload.idle ]
1392 let getli iload =
1393 [ (1.0, 1.0, 0.0), 1.0 -. iload.all ]
1395 let barw = !Args.barw in
1396 let nfuncs =
1397 (fun () -> ()), (fun _ _ -> ()), (fun _ _ -> ())
1399 let kd, kr, ku =
1400 if kactive
1401 then
1402 let module Bar =
1403 Bar (struct
1404 let x = 3
1405 let y = 0
1406 let w = (if iactive then barw / 2 else barw) - 3
1407 let h = h
1408 let getl = getlk
1409 end)
1411 Bar.display, Bar.reshape, Bar.update
1412 else
1413 nfuncs
1415 let id, ir, iu =
1416 if iactive
1417 then
1418 let module Bar =
1419 Bar (struct
1420 let x = (if kactive then barw / 2 else 0) + 3
1421 let y = 0
1422 let w = (if kactive then barw / 2 else barw) - 3
1423 let h = h
1424 let getl = getli
1425 end)
1427 Bar.display, Bar.reshape, Bar.update
1428 else
1429 nfuncs
1431 if kactive
1432 then
1433 begin
1434 if iactive
1435 then
1436 let d () = kd (); id () in
1437 let r w h = kr w h; ir w h in
1438 let u d k i = ku d k; iu d i in
1439 d, r, u
1440 else
1441 kd, kr, (fun d k _ -> ku d k)
1443 else
1444 begin
1445 if iactive
1446 then
1447 id, ir, (fun d _ i -> iu d i)
1448 else
1449 (fun () -> ()), (fun _ _ -> ()), (fun _ _ _ -> ())
1453 let main () =
1454 let _ = Glut.init [|""|] in
1455 let () = Args.init () in
1456 let () =
1457 if !Args.verbose
1458 then
1459 "detected " ^ string_of_int NP.nprocs ^ " CPUs" |> print_endline
1461 let () = if !Args.gzh then Gzh.init !Args.verbose else () in
1462 let () = Delay.init !Args.timer !Args.gzh in
1463 let () = if !Args.niceval != 0 then NP.setnice !Args.niceval else () in
1464 let w = !Args.w
1465 and h = !Args.h in
1466 let fd = opendev !Args.devpath in
1467 let module FullV = View (struct let w = w let h = h end) in
1468 let winid = FullV.init () in
1469 let () = NP.fixwindow winid in
1470 let (kget, kfuncs), (iget, ifuncs), gl = create fd w h in
1471 let bar_update =
1472 List.iter FullV.add gl;
1473 if !Args.barw > 0
1474 then
1475 let (display, reshape, update) =
1476 create_bars h !Args.ksampler !Args.isampler
1478 FullV.add (display, reshape, fun _ -> ());
1479 update
1480 else
1481 fun _ _ _ -> ()
1483 let seticon = if !Args.icon then seticon () else fun ~iload ~kload -> () in
1484 let rec loop t1 () =
1485 let t2 = Unix.gettimeofday () in
1486 let dt = t2 -. t1 in
1487 if dt >= !Args.freq
1488 then
1489 let is = iget () in
1490 let ks = kget () in
1491 let rec loop2 load sample = function
1492 | [] -> load
1493 | (nr, calc, sampler) :: rest ->
1494 let cpuload = calc sample t1 t2 in
1495 let () =
1496 let thisload = 1.0 -. (cpuload.all /. dt) in
1497 let thisload = max 0.0 thisload in
1498 if !Args.verbose
1499 then
1500 ("cpu load(" ^ string_of_int nr ^ "): "
1501 ^ (thisload *. 100.0 |> string_of_float)
1502 |> print_endline)
1504 let load = add_stat load cpuload in
1505 sampler.update dt cpuload.all;
1506 loop2 load sample rest
1508 let iload = loop2 zero_stat is ifuncs in
1509 let kload = loop2 zero_stat ks kfuncs in
1510 if !Args.debug
1511 then
1512 begin
1513 iload.all |> string_of_float |> prerr_endline;
1514 kload.all |> string_of_float |> prerr_endline;
1517 seticon ~iload:iload.all ~kload:kload.all;
1518 bar_update dt kload iload;
1519 FullV.inc ();
1520 FullV.update ();
1521 FullV.func (Some (loop t2))
1522 else
1523 Delay.delay ()
1525 FullV.func (Some (Unix.gettimeofday () |> loop));
1526 FullV.run ()
1529 let _ =
1531 main ()
1532 with
1533 | Unix.Unix_error (e, s1, s2) ->
1534 Unix.error_message e |> eprintf "main failure: %s(%s): %s@." s1 s2
1536 | exn ->
1537 Printexc.to_string exn |> eprintf "main failure: %s@."