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