Module for 3.x kernels
[apc.git] / apc.ml
blob0578611214f52b62d5f7a0fe289f431f066ae186
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 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 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 V = struct
1164 let x = x
1165 let y = y
1166 let w = vw
1167 let h = vh
1168 let freq = S.freq
1169 let interval = !Args.interval
1170 let pgrid = !Args.pgrid
1171 let sgrid = !Args.sgrid
1172 let samplers =
1173 if !Args.isampler
1174 then
1175 isampler :: (if !Args.ksampler then [ksampler] else [])
1176 else
1177 if !Args.ksampler then [ksampler] else []
1180 let module Graph = Graph (V) in
1181 let kaccu =
1182 if !Args.ksampler
1183 then
1184 let calc =
1185 if !Args.gzh
1186 then
1187 let d = ref 0.0 in
1188 let f d' = d := d' in
1189 let () = Gzh.gen f in
1190 fun _ _ _ ->
1191 let d = !d in
1192 { zero_stat with
1193 all = d; iowait = d; user = 1.0 -. d; idle = d }
1194 else
1195 if !Args.uptime
1196 then
1197 let (u1, i1) = NP.parse_uptime () in
1198 let u1 = ref u1
1199 and i1 = ref i1 in
1200 fun _ _ _ ->
1201 let (u2, i2) = NP.parse_uptime () in
1202 let du = u2 -. !u1
1203 and di = i2 -. !i1 in
1204 let d = di /. du in
1205 u1 := u2;
1206 i1 := i2;
1207 { zero_stat with
1208 all = d; iowait = d; user = 1.0 -. d; idle = d }
1209 else
1210 let i' = if i = NP.nprocs then 0 else succ i in
1211 let g ks n = Array.get ks i' |> snd |> Array.get |< n in
1212 let gall ks =
1213 let user = g ks NP.user
1214 and nice = g ks NP.nice
1215 and sys = g ks NP.sys
1216 and idle = g ks NP.idle
1217 and iowait = g ks NP.idle
1218 and intr = g ks NP.intr
1219 and softirq = g ks NP.softirq in
1220 let () =
1221 if !Args.debug
1222 then
1223 eprintf
1224 "user=%f nice=%f sys=%f iowait=%f intr=%f softirq=%f@."
1225 user
1226 nice
1228 iowait
1229 intr
1230 softirq
1233 { all = user +. nice +. sys
1234 ; user = user
1235 ; nice = nice
1236 ; sys = sys
1237 ; idle = idle
1238 ; iowait = iowait
1239 ; intr = intr
1240 ; softirq = softirq
1243 let i1 = ref (gall ks) in
1244 fun ks t1 t2 ->
1245 let i2 = gall ks in
1246 let diff = add_stat i2 (neg_stat !i1) in
1247 let diff = { diff with all = t2 -. t1 -. diff.all } in
1248 i1 := i2;
1249 diff
1251 (i, calc, ksampler) :: kaccu
1252 else
1253 kaccu
1255 let iaccu =
1256 if !Args.isampler
1257 then
1258 let calc =
1259 let i1 = Array.get is i |> ref in
1260 fun is t1 t2 ->
1261 let i2 = Array.get is i in
1262 if classify_float i2 = FP_infinite
1263 then
1264 { zero_stat with all = t2 -. t1 }
1265 else
1266 let i1' = !i1 in
1267 i1 := i2;
1268 { zero_stat with all = i2 -. i1' }
1270 (i, calc, isampler) :: iaccu
1271 else
1272 iaccu
1274 kaccu, iaccu, Graph.funcs :: gaccu
1276 let kl, il, gl = List.fold_left crgraph ([], [], []) placements in
1277 ((if kl == [] then (fun () -> [||]) else kget), kl), (iget, il), gl
1280 let opendev path =
1281 if not NP.linux
1282 then
1283 (* gross hack but we are not particularly picky today *)
1284 Unix.stdout
1285 else
1287 if (Unix.stat path).Unix.st_kind != Unix.S_CHR
1288 then
1289 begin
1290 eprintf "File %S is not an ITC device@." path;
1291 exit 100
1294 Unix.openfile path [Unix.O_RDONLY] 0
1295 with
1296 | Unix.Unix_error ((Unix.ENODEV | Unix.ENXIO) as err , s1, s2) ->
1297 eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1298 path s1 s2 |< Unix.error_message err;
1299 eprintf "(perhaps the module is not loaded?)@.";
1300 exit 100
1302 | Unix.Unix_error (Unix.EALREADY, s1, s2) ->
1303 eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1304 path s1 s2 |< Unix.error_message Unix.EALREADY;
1305 eprintf "(perhaps modules is already in use?)@.";
1306 exit 100
1308 | Unix.Unix_error (error, s1, s2) ->
1309 eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1310 path s1 s2 |< Unix.error_message error;
1311 exit 100
1313 | exn ->
1314 eprintf "Could not open ITC device %S:\n%s@."
1315 path |< Printexc.to_string exn;
1316 exit 100
1319 let seticon () =
1320 let module X =
1321 struct
1322 external seticon : string -> unit = "ml_seticon"
1325 let len = 32*4 in
1326 let data = String.create |< 32*len + 2*4 in
1327 let line r g b a =
1328 let r = Char.chr r
1329 and g = Char.chr g
1330 and b = Char.chr b
1331 and a = Char.chr a in
1332 let s = String.create len in
1333 let rec fill x =
1334 if x = len
1335 then
1337 else
1338 begin
1339 x + 0 |> String.set s |< b;
1340 x + 1 |> String.set s |< g;
1341 x + 2 |> String.set s |< r;
1342 x + 3 |> String.set s |< a;
1343 x + 4 |> fill
1346 fill 0
1348 let el = line 0x00 0x00 0x00 0xff
1349 and kl = line 0xff 0x00 0x00 0xff
1350 and il = line 0xff 0xff 0x00 0xff in
1351 let fill l sy ey =
1352 let src = l and dst = data and src_pos = 0 in
1353 let rec loop n dst_pos =
1354 if n > 0
1355 then
1356 begin
1357 StringLabels.blit ~src ~src_pos ~dst ~dst_pos ~len;
1358 pred n |> loop |< dst_pos + len
1361 (ey - sy) |> loop |< (32 - ey) * len + 4*2
1363 fun ~iload ~kload ->
1364 let iy = iload *. 32.0 |> ceil |> truncate |> max 0 |> min 32
1365 and ky = kload *. 32.0 |> ceil |> truncate |> max 0 |> min 32 in
1366 let ey =
1367 if ky < iy
1368 then
1369 (fill kl 0 ky; fill il ky iy; iy)
1370 else
1371 (fill kl 0 ky; ky)
1373 fill el ey 32;
1374 X.seticon data;
1377 let create_bars h kactive iactive =
1378 let getlk kload =
1379 if !Args.sepstat
1380 then
1381 let sum = kload.user +. kload.nice +. kload.sys
1382 +. kload.intr +. kload.softirq
1384 [ (1.0, 1.0, 0.0), kload.user
1385 ; (0.0, 0.0, 1.0), kload.nice
1386 ; (1.0, 0.0, 0.0), kload.sys
1387 ; (1.0, 1.0, 1.0), kload.intr
1388 ; (0.5, 0.8, 1.0), kload.softirq
1389 ; (0.75, 0.5, 0.5), (1.0 -. kload.iowait) -. sum
1390 ; (0.0, 1.0, 0.0), kload.all -. kload.iowait -. kload.softirq
1392 else
1393 [ (1.0, 0.0, 0.0), 1.0 -. kload.idle ]
1395 let getli iload =
1396 [ (1.0, 1.0, 0.0), 1.0 -. iload.all ]
1398 let barw = !Args.barw in
1399 let nfuncs =
1400 (fun () -> ()), (fun _ _ -> ()), (fun _ _ -> ())
1402 let kd, kr, ku =
1403 if kactive
1404 then
1405 let module Bar =
1406 Bar (struct
1407 let x = 3
1408 let y = 0
1409 let w = (if iactive then barw / 2 else barw) - 3
1410 let h = h
1411 let getl = getlk
1412 end)
1414 Bar.display, Bar.reshape, Bar.update
1415 else
1416 nfuncs
1418 let id, ir, iu =
1419 if iactive
1420 then
1421 let module Bar =
1422 Bar (struct
1423 let x = (if kactive then barw / 2 else 0) + 3
1424 let y = 0
1425 let w = (if kactive then barw / 2 else barw) - 3
1426 let h = h
1427 let getl = getli
1428 end)
1430 Bar.display, Bar.reshape, Bar.update
1431 else
1432 nfuncs
1434 if kactive
1435 then
1436 begin
1437 if iactive
1438 then
1439 let d () = kd (); id () in
1440 let r w h = kr w h; ir w h in
1441 let u d k i = ku d k; iu d i in
1442 d, r, u
1443 else
1444 kd, kr, (fun d k _ -> ku d k)
1446 else
1447 begin
1448 if iactive
1449 then
1450 id, ir, (fun d _ i -> iu d i)
1451 else
1452 (fun () -> ()), (fun _ _ -> ()), (fun _ _ _ -> ())
1456 let main () =
1457 let _ = Glut.init [|""|] in
1458 let () = Args.init () in
1459 let () =
1460 if !Args.verbose
1461 then
1462 "detected " ^ string_of_int NP.nprocs ^ " CPUs" |> print_endline
1464 let () = if !Args.gzh then Gzh.init !Args.verbose else () in
1465 let () = Delay.init !Args.timer !Args.gzh in
1466 let () = if !Args.niceval != 0 then NP.setnice !Args.niceval else () in
1467 let w = !Args.w
1468 and h = !Args.h in
1469 let fd = opendev !Args.devpath in
1470 let module FullV = View (struct let w = w let h = h end) in
1471 let winid = FullV.init () in
1472 let () = NP.fixwindow winid in
1473 let (kget, kfuncs), (iget, ifuncs), gl = create fd w h in
1474 let bar_update =
1475 List.iter FullV.add gl;
1476 if !Args.barw > 0
1477 then
1478 let (display, reshape, update) =
1479 create_bars h !Args.ksampler !Args.isampler
1481 FullV.add (display, reshape, fun _ -> ());
1482 update
1483 else
1484 fun _ _ _ -> ()
1486 let seticon = if !Args.icon then seticon () else fun ~iload ~kload -> () in
1487 let rec loop t1 () =
1488 let t2 = Unix.gettimeofday () in
1489 let dt = t2 -. t1 in
1490 if dt >= !Args.freq
1491 then
1492 let is = iget () in
1493 let ks = kget () in
1494 let rec loop2 load sample = function
1495 | [] -> load
1496 | (nr, calc, sampler) :: rest ->
1497 let cpuload = calc sample t1 t2 in
1498 let () =
1499 let thisload = 1.0 -. (cpuload.all /. dt) in
1500 let thisload = max 0.0 thisload in
1501 if !Args.verbose
1502 then
1503 ("cpu load(" ^ string_of_int nr ^ "): "
1504 ^ (thisload *. 100.0 |> string_of_float)
1505 |> print_endline)
1507 let load = add_stat load cpuload in
1508 sampler.update dt cpuload.all;
1509 loop2 load sample rest
1511 let iload = loop2 zero_stat is ifuncs in
1512 let kload = loop2 zero_stat ks kfuncs in
1513 if !Args.debug
1514 then
1515 begin
1516 iload.all |> string_of_float |> prerr_endline;
1517 kload.all |> string_of_float |> prerr_endline;
1520 seticon ~iload:iload.all ~kload:kload.all;
1521 bar_update dt kload iload;
1522 FullV.inc ();
1523 FullV.update ();
1524 FullV.func (Some (loop t2))
1525 else
1526 Delay.delay ()
1528 FullV.func (Some (Unix.gettimeofday () |> loop));
1529 FullV.run ()
1532 let _ =
1534 main ()
1535 with
1536 | Unix.Unix_error (e, s1, s2) ->
1537 Unix.error_message e |> eprintf "main failure: %s(%s): %s@." s1 s2
1539 | exn ->
1540 Printexc.to_string exn |> eprintf "main failure: %s@."