v1.00b
[apc.git] / apc.ml
blob1efeb7d8d12ff22fba3b25af961a79ba51acafc3
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"
109 let os_type = os_type ()
111 let winnt = os_type = Windows
112 let solaris = os_type = Solaris
113 let linux = os_type = Linux
114 let macosx = os_type = MacOSX
116 let user = 0
117 let nice = 1
118 let sys = 2
119 let idle = 3
120 let iowait = 4
121 let intr = 5
122 let softirq = 6
124 let hz = get_hz () |> float
126 let parse_uptime () =
127 let ic = open_in "/proc/uptime" in
128 let vals = Scanf.fscanf ic "%f %f" (fun u i -> (u, i)) in
129 close_in ic;
130 vals
133 let nprocs = get_nprocs ()
135 let rec parse_int_cont s pos =
136 let jiffies_to_sec j =
137 float j /. hz
139 let slen = String.length s in
140 let pos =
141 let rec skipws pos =
142 if pos = slen
143 then
145 else
146 begin
147 if String.get s pos = ' '
148 then
149 succ pos |> skipws
150 else
153 in skipws pos
155 let endpos =
156 try String.index_from s pos ' '
157 with Not_found -> slen
159 let i = endpos - pos |> String.sub s pos
160 |> int_of_string
161 |> jiffies_to_sec in
162 if endpos = slen
163 then
164 `last i
165 else
166 `more (i, fun () -> succ endpos |> parse_int_cont s)
169 let parse_cpul s =
170 let rec tolist accu = function
171 | `last i -> i :: accu
172 | `more (i, f) -> f () |> tolist (i :: accu)
174 let index = String.index s ' ' in
175 let cpuname = String.sub s 0 index in
176 let vals = parse_int_cont s (succ index) |> tolist [] in
177 let vals = List.rev |<
178 if List.length vals < 7
179 then
180 0.0 :: 0.0 :: 0.0 :: 0.0 :: vals
181 else
182 vals
184 cpuname, Array.of_list vals
187 let parse_stat () =
188 match os_type with
189 | Windows ->
190 (fun () ->
191 let iukw = windows_processor_times nprocs in
192 let rec create n ai ak au ad ar accu =
193 if n = nprocs
194 then
195 ("cpu", [| au; ad; ak; ai; 0.0; ar; 0.0 |]) :: List.rev accu
196 else
197 let hdr = "cpu" ^ string_of_int n in
198 let o = n * 5 in
199 let i = Array.get iukw (o + 0) in
200 let k = Array.get iukw (o + 1) in
201 let u = Array.get iukw (o + 2) in
202 let d = Array.get iukw (o + 3) in
203 let r = Array.get iukw (o + 4) in
204 let ai = ai +. i in
205 let au = au +. u in
206 let ak = ak +. k in
207 let ad = ad +. d in
208 let ar = ar +. r in
209 let accu = (hdr, [| u; d; k; i; 0.0; r; 0.0 |]) :: accu in
210 create (succ n) ai ak au ad ar accu
212 create 0 0.0 0.0 0.0 0.0 0.0 []
215 | Linux ->
216 (fun () ->
217 let ic = open_in "/proc/stat" in
218 let rec loop i accu =
219 if i = -1
220 then
221 List.rev accu
222 else
223 (input_line ic |> parse_cpul) :: accu |> loop (pred i)
225 let ret = loop nprocs [] in
226 close_in ic;
230 | Solaris ->
231 (fun () ->
232 let iukw = solaris_kstat nprocs in
233 let rec create n ai au ak aw accu =
234 if n = nprocs
235 then
236 ("cpu", [| au; 0.0; ak; ai; aw; 0.0; 0.0 |]) :: List.rev accu
237 else
238 let hdr = "cpu" ^ string_of_int n in
239 let o = n * 4 in
240 let i = Array.get iukw (o + 0) /. hz in
241 let u = Array.get iukw (o + 1) /. hz in
242 let k = Array.get iukw (o + 2) /. hz in
243 let w = Array.get iukw (o + 3) /. hz in
244 let ai = ai +. i in
245 let au = au +. u in
246 let ak = ak +. k in
247 let aw = aw +. w in
248 let accu = (hdr, [| u; 0.0; k; i; w; 0.0; 0.0 |]) :: accu in
249 create (succ n) ai au ak aw accu
251 create 0 0.0 0.0 0.0 0.0 []
254 | MacOSX ->
255 (fun () ->
256 let iukn = macosx_host_processor_info nprocs in
257 let rec create c ai au ak an accu =
258 if c = nprocs
259 then
260 ("cpu", [| au; an; ak; ai; 0.0; 0.0; 0.0 |]) :: List.rev accu
261 else
262 let hdr = "cpu" ^ string_of_int c in
263 let o = c * 4 in
264 let i = Array.get iukn (o + 0) /. hz in
265 let u = Array.get iukn (o + 1) /. hz in
266 let k = Array.get iukn (o + 2) /. hz in
267 let n = Array.get iukn (o + 3) /. hz in
268 let ai = ai +. i in
269 let au = au +. u in
270 let ak = ak +. k in
271 let an = an +. n in
272 let accu = (hdr, [| u; n; k; i; 0.0; 0.0; 0.0 |]) :: accu in
273 create (succ c) ai au ak an accu
275 create 0 0.0 0.0 0.0 0.0 []
279 let getselfdir () =
281 Filename.dirname |< Unix.readlink "/proc/self/exe"
282 with exn ->
283 "./"
287 module Args =
288 struct
289 let banner =
290 [ "Amazing Piece of Code by insanely gifted programmer, Version 1.00b"
291 ; "Motivation by: gzh and afs"
292 ; "usage: "
293 ] |> String.concat "\n"
295 let freq = ref 1.0
296 let interval = ref 15.0
297 let devpath = NP.getselfdir () |> Filename.concat |< "itc" |> ref
298 let pgrid = ref 10
299 let sgrid = ref 10
300 let w = ref 400
301 let h = ref 200
302 let verbose = ref false
303 let delay = ref 0.04
304 let ksampler = ref true
305 let isampler = ref true
306 let barw = ref 100
307 let bars = ref 50
308 let sigway = ref (NP.os_type != NP.MacOSX)
309 let niceval = ref 0
310 let gzh = ref false
311 let scalebar = ref false
312 let timer = ref 100
313 let debug = ref false
314 let poly = ref false
315 let uptime = ref false
316 let icon = ref false
317 let labels = ref true
318 let mgrid = ref false
319 let sepstat = ref true
321 let pad n s =
322 let l = String.length s in
323 if l >= n
324 then
326 else
327 let d = String.make n ' ' in
328 StringLabels.blit ~src:s ~dst:d
329 ~src_pos:0 ~len:l
330 ~dst_pos:0;
334 let sooo b = if b then "on" else "off"
335 let dA tos s {contents=v} = s ^ " (" ^ tos v ^ ")"
336 let dF = dA |< sprintf "%4.2f"
337 let dB = dA sooo
338 let dcB = dA sooo
339 let dI = dA string_of_int
340 let dS = dA (fun s -> "`" ^ String.escaped s ^ "'")
342 let sF opt r doc =
343 "-" ^ opt, Arg.Set_float r, pad 9 "<float> " ^ doc |> dF |< r
346 let sI opt r doc =
347 "-" ^ opt, Arg.Set_int r, pad 9 "<int> " ^ doc |> dI |< r
350 let sB opt r doc =
351 "-" ^ opt, Arg.Set r, pad 9 "" ^ doc |> dB |< r
354 let sS opt r doc =
355 "-" ^ opt, Arg.Set_string r, pad 9 "<string> " ^ doc |> dS |< r
358 let fB opt r doc =
359 if r.contents
360 then
361 "-" ^ opt, Arg.Clear r, pad 9 "" ^ doc |> dB |< r
362 else
363 "-" ^ opt, Arg.Set r, pad 9 "" ^ doc |> dcB |< r
366 let commonopts =
367 [ sF "f" freq "sampling frequency in seconds"
368 ; sF "D" delay "refresh delay in seconds"
369 ; sF "i" interval "history interval in seconds"
370 ; sI "p" pgrid "percent grid items"
371 ; sI "s" sgrid "history grid items"
372 ; sI "w" w "width"
373 ; sI "h" h "height"
374 ; sI "b" barw "bar width"
375 ; sI "B" bars "number of CPU bars"
376 ; sB "v" verbose "verbose"
377 ; fB "C" sepstat "separate sys/nice/intr/iowait values (kernel sampler)"
378 ; fB "c" scalebar "constant bar width"
379 ; fB "P" poly "filled area instead of lines"
380 ; fB "l" labels "labels"
381 ; fB "m" mgrid "moving grid"
385 let add_opts tail =
386 let add_linux opts =
387 sI "t" timer "timer frequency in herz"
388 :: fB "I" icon "icon (hack)"
389 :: sS "d" devpath "path to itc device"
390 :: (fB "k" ksampler |< "kernel sampler (`/proc/[stat|uptime]')")
391 :: (fB "M" isampler |< "idle sampler")
392 :: (fB "u" uptime
393 "`uptime' instead of `stat' as kernel sampler (UP only)")
394 :: sI "n" niceval "value to renice self on init"
395 :: fB "g" gzh "gzh way (does not quite work yet)"
396 :: fB "S" sigway "sigwait delay method"
397 :: opts
399 let add_solaris opts =
400 isampler := false;
401 fB "I" icon "icon (hack)"
402 :: opts
404 let add_windows opts =
405 isampler := false;
406 (fB "k" ksampler |< "kernel sampler (ZwQuerySystemInformation)")
407 :: (fB "M" isampler |< "idle sampler (PMC based)")
408 :: opts
410 let add_macosx opts =
411 isampler := false;
412 fB "g" gzh "gzh way (does not quite work yet)"
413 :: opts
415 match NP.os_type with
416 | NP.Linux -> add_linux tail
417 | NP.Windows -> add_windows tail
418 | NP.Solaris -> add_solaris tail
419 | NP.MacOSX -> add_macosx tail
422 let init () =
423 let opts = add_opts commonopts in
424 Arg.parse opts
425 (fun s ->
426 raise (Arg.Bad
427 ("Invocation error: Don't know what to do with " ^ s));
429 banner
431 let cp {contents=v} s =
432 if v <= 0
433 then (prerr_string s; prerr_endline " must be positive"; exit 1)
435 let cpf {contents=v} s =
436 if v <= 0.0
437 then (prerr_string s; prerr_endline " must be positive"; exit 1)
439 cp w "Width";
440 cp h "Height";
441 cp pgrid "Number of percent grid items";
442 cp sgrid "Number of history grid items";
443 cp bars "Number of CPU bars";
444 cp timer "Timer frequency";
445 cpf freq "Frequency";
446 cpf delay "Delay";
447 cpf interval "Interval";
448 if not (!isampler || !ksampler)
449 then
450 barw := 0
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 funcs = ref []
686 let keyboard ~key ~x ~y =
687 if key = 27 || key = Char.code 'q'
688 then
689 exit 0;
692 let add dri =
693 funcs := dri :: !funcs
696 let display () =
697 GlClear.clear [`color];
698 List.iter (fun (display, _, _) -> display ()) !funcs;
699 Glut.swapBuffers ();
702 let reshape ~w ~h =
703 ww := w;
704 wh := h;
705 List.iter (fun (_, reshape, _) -> reshape w h) !funcs;
706 GlClear.clear [`color];
707 GlMat.mode `modelview;
708 GlMat.load_identity ();
709 GlMat.mode `projection;
710 GlMat.load_identity ();
711 GlMat.rotate ~y:1.0 ~angle:180.0 ();
712 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
713 GlMat.scale ~x:2.0 ~y:2.0 ();
714 Glut.postRedisplay ();
717 let init () =
718 let () =
719 Glut.initDisplayMode ~double_buffer:true ();
720 Glut.initWindowSize V.w V.h
722 let winid = Glut.createWindow "APC" in
723 Glut.displayFunc display;
724 Glut.reshapeFunc reshape;
725 Glut.keyboardFunc keyboard;
726 GlDraw.color (1.0, 1.0, 0.0);
727 winid;
730 let inc () = List.iter (fun (_, _, inc) -> inc ()) !funcs
731 let update = Glut.postRedisplay
732 let func = Glut.idleFunc
733 let run = Glut.mainLoop
736 module type BarInfo =
738 val x : int
739 val y : int
740 val w : int
741 val h : int
742 val getl : stats -> ((float * float * float) * float) list
745 module Bar (I: BarInfo) =
746 struct
747 let w = ref I.w
748 let h = ref I.h
749 let wratio = float I.w /. float !Args.w
750 let load = ref zero_stat
751 let nrcpuscale = 1.0 /. float NP.nprocs
752 let fh = 12
753 let strw = Glut.bitmapLength ~font ~str:"55.55"
754 let sepsl =
755 let base = GlList.gen_lists ~len:1 in
756 GlList.nth base ~pos:0
759 let seps () =
760 let hh = !h - 26 in
761 let () =
762 GlDraw.viewport I.x (I.y + 15) !w hh;
763 GlMat.push ();
764 GlMat.load_identity ();
765 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
766 GlMat.scale ~y:(2.0 /. (float hh)) ~x:1.0 ();
768 let seph = 1 in
769 let barh = float (hh - (!Args.bars - 1) * seph) /. float !Args.bars in
770 let barh = ceil barh |> truncate in
771 let rec loop i yb =
772 if yb > hh
773 then
775 else
776 let yt = yb + seph in
777 let yn = yt + barh in
778 let yb = float yb
779 and yt = float yt in
780 GlDraw.vertex2 (0.0, yb);
781 GlDraw.vertex2 (0.0, yt);
782 GlDraw.vertex2 (2.0, yt);
783 GlDraw.vertex2 (2.0, yb);
784 succ i |> loop |< yn
786 GlDraw.color (0.0, 0.0, 0.0);
787 GlDraw.begins `quads;
788 loop 0 barh;
789 GlDraw.ends ();
790 GlMat.pop ();
793 let reshape w' h' =
794 w :=
795 if !Args.scalebar
796 then
797 (float w' *. wratio |> truncate)
798 else
801 h := h';
802 GlList.begins sepsl `compile;
803 seps ();
804 GlList.ends ();
807 let display () =
808 let load = scale_stat !load nrcpuscale in
809 let load_all = min (1.0 -. load.all) 1.0 |> max 0.0 in
810 let () = GlMat.push () in
811 let () =
812 GlDraw.viewport I.x (I.y + 2) !w !h;
813 GlDraw.color (1.0, 1.0, 1.0);
814 let load_all = 100.0 *. load_all in
815 let str = sprintf "%5.2f" load_all in
816 let () =
817 GlMat.load_identity ();
818 let strw =
819 if false
820 then
821 Glut.bitmapLength ~font ~str:str
822 else
823 strw
825 let x = -. (float strw /. float !w) in
826 GlMat.translate ~y:~-.1.0 ~x ();
828 let () = draw_string 0.0 0.0 str in
831 GlDraw.viewport I.x (I.y + 15) !w (!h - 26);
832 GlMat.load_identity ();
833 GlMat.translate ~x:~-.1. ~y:~-.1.();
834 let drawquad yb yt =
835 GlDraw.begins `quads;
836 GlDraw.vertex2 (0.0, yb);
837 GlDraw.vertex2 (0.0, yt);
838 GlDraw.vertex2 (2.0, yt);
839 GlDraw.vertex2 (2.0, yb);
840 GlDraw.ends ()
842 let fold yb (color, load) =
843 if load > 0.0
844 then
845 let () = GlDraw.color color in
846 let yt = yb +. 2.0*.load in
847 let () = drawquad yb yt in
849 else
852 let cl = I.getl load in
853 let yb = List.fold_left fold 0.0 cl in
854 let () = GlDraw.color (0.5, 0.5, 0.5) in
855 let () = drawquad yb 2.0 in
856 let () = GlList.call sepsl in
857 GlMat.pop ();
858 GlList.call sepsl;
861 let update delta' load' =
862 let delta = 1.0 /. delta' in
863 load := scale_stat load' delta;
867 module Graph (V: View) =
868 struct
869 let ox = if !Args.scalebar then 0 else !Args.barw
870 let sw = float V.w /. float (!Args.w - ox)
871 let sh = float V.h /. float !Args.h
872 let sx = float (V.x - ox) /. float V.w
873 let sy = float V.y /. float V.h
874 let vw = ref 0
875 let vh = ref 0
876 let vx = ref 0
877 let vy = ref 0
878 let scale = V.freq /. V.interval
879 let gscale = 1.0 /. float V.sgrid
880 let nsamples = ref 0
882 let fw, fh =
883 if !Args.labels
884 then
885 3 * Glut.bitmapWidth font (Char.code '%'), 20
886 else
887 0, 10
890 let gridlist =
891 let base = GlList.gen_lists ~len:1 in
892 GlList.nth base ~pos:0
894 let viewport typ =
895 let ox = if !Args.scalebar then 0 else !Args.barw in
896 let x, y, w, h =
897 match typ with
898 | `labels -> (!vx + ox, !vy + 5, fw, !vh - fh)
899 | `graph -> (!vx + fw + 5 + ox, !vy + 5, !vw - fw - 10, !vh - fh)
901 GlDraw.viewport x y w h;
904 let sgrid () =
905 for i = 0 to V.sgrid
907 let x = if i = 0 then 0.0009 else float i *. gscale in
908 GlDraw.vertex ~x ~y:0.0 ();
909 GlDraw.vertex ~x ~y:1.0 ();
910 done;
913 let grid () =
914 viewport `graph;
915 GlDraw.line_width 1.0;
916 GlDraw.color (0.0, 1.0, 0.0);
917 GlDraw.begins `lines;
918 if !Args.mgrid
919 then
920 begin
921 GlDraw.vertex2 (0.0009, 0.0);
922 GlDraw.vertex2 (0.0009, 1.0);
923 GlDraw.vertex2 (1.0000, 0.0);
924 GlDraw.vertex2 (1.0000, 1.0);
926 else
927 sgrid ()
929 let () =
930 let lim = 100 / V.pgrid in
931 for i = 0 to lim
933 let y = (i * V.pgrid |> float) /. 100.0 in
934 let y = if i = lim then y -. 0.0009 else y in
935 GlDraw.vertex ~x:0.0 ~y ();
936 GlDraw.vertex ~x:1.0 ~y ();
937 done;
939 let () = GlDraw.ends () in
940 if !Args.labels
941 then
942 begin
943 viewport `labels;
944 GlDraw.color (1.0, 1.0, 1.0);
945 let ohp = 100.0 in
946 for i = 0 to 100 / V.pgrid
948 let p = i * V.pgrid in
949 let y = float p /. ohp in
950 let s = Printf.sprintf "%3d%%" p in
951 draw_string 1.0 y s
952 done
956 let reshape w h =
957 let wxsw = float (w - ox) *. sw
958 and hxsh = float h *. sh in
959 vw := wxsw |> truncate;
960 vh := hxsh |> truncate;
961 vx := wxsw *. sx |> truncate;
962 vy := hxsh *. sy |> truncate;
963 GlList.begins gridlist `compile;
964 grid ();
965 GlList.ends ();
968 let swap =
969 Glut.swapBuffers |> oohz !Args.delay;
972 let inc () = incr nsamples
974 let mgrid () =
975 GlDraw.line_width 1.0;
976 GlDraw.color (0.0, 1.0, 0.0);
977 GlDraw.begins `lines;
978 let offset =
979 ((pred !nsamples |> float) *. scale /. gscale |> modf |> fst) *. gscale
981 for i = 0 to pred V.sgrid
983 let x = offset +. float i *. gscale in
984 GlDraw.vertex ~x ~y:0.0 ();
985 GlDraw.vertex ~x ~y:1.0 ();
986 done;
987 GlDraw.ends ();
990 let display () =
991 GlList.call gridlist;
992 viewport `graph;
993 if !Args.mgrid then mgrid ();
994 GlDraw.line_width 2.0;
995 let sample sampler =
996 GlDraw.color sampler.color;
997 let () =
998 if not !Args.poly
999 then GlDraw.begins `line_strip
1000 else
1001 begin
1002 GlDraw.begins `polygon;
1003 GlDraw.vertex2 (0.0, 0.0);
1006 let yield = sampler.getyielder () in
1007 let rec loop last i =
1008 match yield () with
1009 | Some y as opty ->
1010 let x = scale *. float i in
1011 GlDraw.vertex ~x ~y ();
1012 loop opty (succ i)
1014 | None ->
1015 if !Args.poly
1016 then
1017 match last with
1018 | None -> ()
1019 | Some y ->
1020 let x = scale *. float (pred i) in
1021 GlDraw.vertex ~x ~y:0.0 ()
1023 loop None 0;
1024 GlDraw.ends ();
1026 List.iter sample V.samplers;
1029 let funcs = display, reshape, inc
1032 let getplacements w h n barw =
1033 let sr = float n |> sqrt |> ceil |> truncate in
1034 let d = n / sr in
1035 let r = if n mod sr = 0 then 0 else 1 in
1036 let x, y =
1037 if w - barw > h
1038 then
1039 sr + r, d
1040 else
1041 d, sr + r
1043 let w' = w - barw in
1044 let h' = h in
1045 let vw = w' / x in
1046 let vh = h' / y in
1047 let rec loop accu i =
1048 if i = n
1049 then
1050 accu
1051 else
1052 let yc = i / x in
1053 let xc = i mod x in
1054 let xc = xc * vw + barw in
1055 let yc = yc * vh in
1056 (i, xc, yc) :: accu |> loop |< succ i
1058 loop [] 0, vw, vh
1061 let create fd w h =
1062 let module S =
1063 struct
1064 let freq = !Args.freq
1065 let nsamples = !Args.interval /. freq |> ceil |> truncate
1068 let placements, vw, vh = getplacements w h NP.nprocs !Args.barw in
1070 let iget () =
1071 if !Args.isampler then NP.idletimeofday fd NP.nprocs else [||]
1073 let is = iget () in
1075 let kget () =
1076 let gks = NP.parse_stat () in
1077 gks () |> Array.of_list
1079 let ks = kget () in
1081 let crgraph (kaccu, iaccu, gaccu) (i, x, y) =
1082 let module Si = Sampler (S) in
1083 let isampler =
1084 { getyielder = Si.getyielder
1085 ; color = (1.0, 1.0, 0.0)
1086 ; update = Si.update
1089 let module Sk = Sampler (S) in
1090 let ksampler =
1091 { getyielder = Sk.getyielder
1092 ; color = (1.0, 0.0, 0.0)
1093 ; update = Sk.update
1096 let module V = struct
1097 let x = x
1098 let y = y
1099 let w = vw
1100 let h = vh
1101 let freq = S.freq
1102 let interval = !Args.interval
1103 let pgrid = !Args.pgrid
1104 let sgrid = !Args.sgrid
1105 let samplers =
1106 if !Args.isampler
1107 then
1108 isampler :: (if !Args.ksampler then [ksampler] else [])
1109 else
1110 if !Args.ksampler then [ksampler] else []
1113 let module Graph = Graph (V) in
1114 let kaccu =
1115 if !Args.ksampler
1116 then
1117 let calc =
1118 if !Args.gzh
1119 then
1120 let d = ref 0.0 in
1121 let f d' = d := d' in
1122 let () = Gzh.gen f in
1123 fun _ _ _ ->
1124 let d = !d in
1125 { zero_stat with
1126 all = d; iowait = d; user = 1.0 -. d; idle = d }
1127 else
1128 if !Args.uptime
1129 then
1130 let (u1, i1) = NP.parse_uptime () in
1131 let u1 = ref u1
1132 and i1 = ref i1 in
1133 fun _ _ _ ->
1134 let (u2, i2) = NP.parse_uptime () in
1135 let du = u2 -. !u1
1136 and di = i2 -. !i1 in
1137 let d = di /. du in
1138 u1 := u2;
1139 i1 := i2;
1140 { zero_stat with
1141 all = d; iowait = d; user = 1.0 -. d; idle = d }
1142 else
1143 let i' = if i = NP.nprocs then 0 else succ i in
1144 let g ks n = Array.get ks i' |> snd |> Array.get |< n in
1145 let gall ks =
1146 let user = g ks NP.user
1147 and nice = g ks NP.nice
1148 and sys = g ks NP.sys
1149 and idle = g ks NP.idle
1150 and iowait = g ks NP.idle
1151 and intr = g ks NP.intr
1152 and softirq = g ks NP.softirq in
1153 let () =
1154 if !Args.debug
1155 then
1156 eprintf
1157 "user=%f nice=%f sys=%f iowait=%f intr=%f softirq=%f@."
1158 user
1159 nice
1161 iowait
1162 intr
1163 softirq
1166 { all = idle
1167 ; user = user
1168 ; nice = nice
1169 ; sys = sys
1170 ; idle = idle
1171 ; iowait = iowait
1172 ; intr = intr
1173 ; softirq = softirq
1176 let i1 = ref (gall ks) in
1177 fun ks _ _ ->
1178 let i2 = gall ks in
1179 let diff = add_stat i2 (neg_stat !i1) in
1180 i1 := i2;
1181 diff
1183 (i, calc, ksampler) :: kaccu
1184 else
1185 kaccu
1187 let iaccu =
1188 if !Args.isampler
1189 then
1190 let calc =
1191 let i1 = Array.get is i |> ref in
1192 fun is t1 t2 ->
1193 let i2 = Array.get is i in
1194 if classify_float i2 = FP_infinite
1195 then
1196 { zero_stat with all = t2 -. t1 }
1197 else
1198 let i1' = !i1 in
1199 i1 := i2;
1200 { zero_stat with all = i2 -. i1' }
1202 (i, calc, isampler) :: iaccu
1203 else
1204 iaccu
1206 kaccu, iaccu, Graph.funcs :: gaccu
1208 let kl, il, gl = List.fold_left crgraph ([], [], []) placements in
1209 ((if kl == [] then (fun () -> [||]) else kget), kl), (iget, il), gl
1212 let opendev path =
1213 if not NP.linux
1214 then
1215 (* gross hack but we are not particularly picky today *)
1216 Unix.stdout
1217 else
1219 if (Unix.stat path).Unix.st_kind != Unix.S_CHR
1220 then
1221 begin
1222 eprintf "File %S is not an ITC device@." path;
1223 exit 100
1226 Unix.openfile path [Unix.O_RDONLY] 0
1227 with
1228 | Unix.Unix_error ((Unix.ENODEV | Unix.ENXIO) as err , s1, s2) ->
1229 eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1230 path s1 s2 |< Unix.error_message err;
1231 eprintf "(perhaps the module is not loaded?)@.";
1232 exit 100
1234 | Unix.Unix_error (Unix.EALREADY, s1, s2) ->
1235 eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1236 path s1 s2 |< Unix.error_message Unix.EALREADY;
1237 eprintf "(perhaps modules is already in use?)@.";
1238 exit 100
1240 | Unix.Unix_error (error, s1, s2) ->
1241 eprintf "Could not open ITC device %S:\n%s(%s): %s@."
1242 path s1 s2 |< Unix.error_message error;
1243 exit 100
1245 | exn ->
1246 eprintf "Could not open ITC device %S:\n%s@."
1247 path |< Printexc.to_string exn;
1248 exit 100
1251 let seticon () =
1252 let module X =
1253 struct
1254 external seticon : string -> unit = "ml_seticon"
1257 let len = 32*4 in
1258 let data = String.create |< 32*len + 2*4 in
1259 let line r g b a =
1260 let r = Char.chr r
1261 and g = Char.chr g
1262 and b = Char.chr b
1263 and a = Char.chr a in
1264 let s = String.create len in
1265 let rec fill x =
1266 if x = len
1267 then
1269 else
1270 begin
1271 x + 0 |> String.set s |< b;
1272 x + 1 |> String.set s |< g;
1273 x + 2 |> String.set s |< r;
1274 x + 3 |> String.set s |< a;
1275 x + 4 |> fill
1278 fill 0
1280 let el = line 0x00 0x00 0x00 0xff
1281 and kl = line 0xff 0x00 0x00 0xff
1282 and il = line 0xff 0xff 0x00 0xff in
1283 let fill l sy ey =
1284 let src = l and dst = data and src_pos = 0 in
1285 let rec loop n dst_pos =
1286 if n > 0
1287 then
1288 begin
1289 StringLabels.blit ~src ~src_pos ~dst ~dst_pos ~len;
1290 pred n |> loop |< dst_pos + len
1293 (ey - sy) |> loop |< (32 - ey) * len + 4*2
1295 fun ~iload ~kload ->
1296 let iy = iload *. 32.0 |> ceil |> truncate |> max 0 |> min 32
1297 and ky = kload *. 32.0 |> ceil |> truncate |> max 0 |> min 32 in
1298 let ey =
1299 if ky < iy
1300 then
1301 (fill kl 0 ky; fill il ky iy; iy)
1302 else
1303 (fill kl 0 ky; ky)
1305 fill el ey 32;
1306 X.seticon data;
1309 let create_bars h kactive iactive =
1310 let getlk kload =
1311 if !Args.sepstat
1312 then
1313 let sum = kload.user +. kload.nice +. kload.sys
1314 +. kload.intr +. kload.softirq
1316 [ (1.0, 1.0, 0.0), kload.user
1317 ; (0.0, 0.0, 1.0), kload.nice
1318 ; (1.0, 0.0, 0.0), kload.sys
1319 ; (1.0, 1.0, 1.0), kload.intr
1320 ; (0.75, 0.5, 0.5), (1.0 -. kload.iowait) -. sum
1321 ; (0.0, 1.0, 0.0), kload.all -. kload.iowait -. kload.softirq
1323 else
1324 [ (1.0, 0.0, 0.0), 1.0 -. kload.idle ]
1326 let getli iload =
1327 [ (1.0, 1.0, 0.0), 1.0 -. iload.all ]
1329 let barw = !Args.barw in
1330 let nfuncs =
1331 (fun () -> ()), (fun _ _ -> ()), (fun _ _ -> ())
1333 let kd, kr, ku =
1334 if kactive
1335 then
1336 let module Bar =
1337 Bar (struct
1338 let x = 3
1339 let y = 0
1340 let w = (if iactive then barw / 2 else barw) - 3
1341 let h = h
1342 let getl = getlk
1343 end)
1345 Bar.display, Bar.reshape, Bar.update
1346 else
1347 nfuncs
1349 let id, ir, iu =
1350 if iactive
1351 then
1352 let module Bar =
1353 Bar (struct
1354 let x = (if kactive then barw / 2 else 0) + 3
1355 let y = 0
1356 let w = (if kactive then barw / 2 else barw) - 3
1357 let h = h
1358 let getl = getli
1359 end)
1361 Bar.display, Bar.reshape, Bar.update
1362 else
1363 nfuncs
1365 if kactive
1366 then
1367 begin
1368 if iactive
1369 then
1370 let d () = kd (); id () in
1371 let r w h = kr w h; ir w h in
1372 let u d k i = ku d k; iu d i in
1373 d, r, u
1374 else
1375 kd, kr, (fun d k _ -> ku d k)
1377 else
1378 begin
1379 if iactive
1380 then
1381 id, ir, (fun d _ i -> iu d i)
1382 else
1383 (fun () -> ()), (fun _ _ -> ()), (fun _ _ _ -> ())
1387 let main () =
1388 let _ = Glut.init [|""|] in
1389 let () = Args.init () in
1390 let () =
1391 if !Args.verbose
1392 then
1393 "detected " ^ string_of_int NP.nprocs ^ " CPUs" |> print_endline
1395 let () = if !Args.gzh then Gzh.init !Args.verbose else () in
1396 let () = Delay.init !Args.timer !Args.gzh in
1397 let () = if !Args.niceval != 0 then NP.setnice !Args.niceval else () in
1398 let w = !Args.w
1399 and h = !Args.h in
1400 let fd = opendev !Args.devpath in
1401 let module FullV = View (struct let w = w let h = h end) in
1402 let _winid = FullV.init () in
1403 let (kget, kfuncs), (iget, ifuncs), gl = create fd w h in
1404 let bar_update =
1405 List.iter FullV.add gl;
1406 if !Args.barw > 0
1407 then
1408 let (display, reshape, update) =
1409 create_bars h !Args.ksampler !Args.isampler
1411 FullV.add (display, reshape, fun _ -> ());
1412 update
1413 else
1414 fun _ _ _ -> ()
1416 let seticon = if !Args.icon then seticon () else fun ~iload ~kload -> () in
1417 let rec loop t1 () =
1418 let t2 = Unix.gettimeofday () in
1419 let dt = t2 -. t1 in
1420 if dt >= !Args.freq
1421 then
1422 let is = iget () in
1423 let ks = kget () in
1424 let rec loop2 load sample = function
1425 | [] -> load
1426 | (nr, calc, sampler) :: rest ->
1427 let cpuload = calc sample t1 t2 in
1428 let () =
1429 let thisload = 1.0 -. (cpuload.all /. dt) in
1430 let thisload = max 0.0 thisload in
1431 if !Args.verbose
1432 then
1433 ("cpu load(" ^ string_of_int nr ^ "): "
1434 ^ (thisload *. 100.0 |> string_of_float)
1435 |> print_endline)
1437 let load = add_stat load cpuload in
1438 sampler.update dt cpuload.all;
1439 loop2 load sample rest
1441 let iload = loop2 zero_stat is ifuncs in
1442 let kload = loop2 zero_stat ks kfuncs in
1443 if !Args.debug
1444 then
1445 begin
1446 iload.all |> string_of_float |> prerr_endline;
1447 kload.all |> string_of_float |> prerr_endline;
1450 seticon ~iload:iload.all ~kload:kload.all;
1451 bar_update dt kload iload;
1452 FullV.inc ();
1453 FullV.update ();
1454 FullV.func (Some (loop t2))
1455 else
1456 Delay.delay ()
1458 FullV.func (Some (Unix.gettimeofday () |> loop));
1459 FullV.run ()
1462 let _ =
1464 main ()
1465 with
1466 | Unix.Unix_error (e, s1, s2) ->
1467 Unix.error_message e |> eprintf "main failure: %s(%s): %s@." s1 s2
1469 | exn ->
1470 Printexc.to_string exn |> eprintf "main failure: %s@."