v0.97c
[apc.git] / apc.ml
bloba44451ccc77f3b0616020277f69da98675103608
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
11 module NP = struct
12 type sysinfo =
13 { uptime: int64
14 ; loads: int64 * int64 * int64
15 ; totalram: int64
16 ; freeram: int64
17 ; sharedram: int64
18 ; bufferram: int64
19 ; totalswap: int64
20 ; freeswap: int64
21 ; procs: int64
24 external get_nprocs : unit -> int = "ml_get_nprocs"
25 external idletimeofday : Unix.file_descr -> int -> float array
26 = "ml_idletimeofday"
27 external sysinfo : unit -> sysinfo = "ml_sysinfo"
28 external waitalrm : unit -> unit = "ml_waitalrm"
29 external get_hz : unit -> int = "ml_get_hz"
30 external setnice : int -> unit = "ml_nice"
31 external delay : float -> unit = "ml_delay"
32 external is_winnt : unit -> bool = "ml_is_winnt"
34 let winnt = is_winnt ()
36 let user = 0
37 let nice = 1
38 let sys = 2
39 let idle = 3
40 let iowait = 4
41 let intr = 5
42 let softirq = 6
44 let hz = get_hz () |> float
46 let jiffies_to_sec j =
47 float j /. hz
49 let parse_uptime () =
50 let ic = open_in "/proc/uptime" in
51 let vals = Scanf.fscanf ic "%f %f" (fun u i -> (u, i)) in
52 close_in ic;
53 vals
55 let nprocs = get_nprocs ()
57 let rec parse_int_cont s pos =
58 let slen = String.length s in
59 let pos =
60 let rec skipws pos =
61 if pos = slen
62 then pos
63 else
64 if String.get s pos = ' '
65 then succ pos |> skipws
66 else pos
67 in skipws pos
69 let endpos =
70 try String.index_from s pos ' '
71 with Not_found -> slen
73 let i = endpos - pos |> String.sub s pos
74 |> int_of_string
75 |> jiffies_to_sec in
76 if endpos = slen
77 then
78 `last i
79 else
80 `more (i, fun () -> succ endpos |> parse_int_cont s)
82 let parse_cpul s =
83 let rec tolist accu = function
84 | `last i -> i :: accu
85 | `more (i, f) -> f () |> tolist (i :: accu)
87 let index = String.index s ' ' in
88 let cpuname = String.sub s 0 index in
89 let vals = parse_int_cont s (succ index) |> tolist [] in
90 let vals = List.rev |<
91 if List.length vals < 7
92 then
93 0.0 :: 0.0 :: 0.0 :: 0.0 :: vals
94 else
95 vals
97 cpuname, Array.of_list vals
99 let parse_stat () =
100 if winnt
101 then
102 fun () ->
103 let ia = idletimeofday Unix.stdin nprocs in
104 let rec convert accu total n =
105 if n = nprocs
106 then
107 let t = total in
108 let a = "cpu", Array.make 7 t in
109 a :: List.rev accu
110 else
111 let i = Array.get ia n in
112 let total = total +. i in
113 let v = "cpu" ^ string_of_int n, Array.make 7 i in
114 convert |< v :: accu |< total |< succ n
116 convert [] 0.0 0
117 else
118 fun () ->
119 let ic = open_in "/proc/stat" in
120 let rec loop i accu =
121 if i = -1
122 then List.rev accu
123 else (input_line ic |> parse_cpul) :: accu |> loop (pred i)
125 let ret = loop nprocs [] in
126 close_in ic;
129 let getselfdir () =
131 Filename.dirname |< Unix.readlink "/proc/self/exe"
132 with exn ->
133 "./"
136 module Args = struct
137 let banner =
138 [ "Amazing Piece of Code by insanely gifted programmer, Version 0.97c"
139 ; "Motivation by: gzh and afs"
140 ; "usage: "
141 ] |> String.concat "\n"
143 let freq = ref 1.0
144 let interval = ref 15.0
145 let devpath = NP.getselfdir () |> Filename.concat |< "itc" |> ref
146 let pgrid = ref 10
147 let sgrid = ref 10
148 let w = ref 400
149 let h = ref 200
150 let verbose = ref false
151 let delay = ref 0.04
152 let ksampler = ref true
153 let barw = ref 100
154 let bars = ref 50
155 let sigway = ref true
156 let niceval = ref 0
157 let gzh = ref false
158 let scalebar = ref false
159 let timer = ref 100
160 let debug = ref false
161 let poly = ref false
162 let uptime = ref false
163 let icon = ref false
164 let labels = ref true
165 let mgrid = ref false
167 let pad n s =
168 let l = String.length s in
169 if l >= n
170 then
172 else
173 let d = String.make n ' ' in
174 StringLabels.blit ~src:s ~dst:d
175 ~src_pos:0 ~len:l
176 ~dst_pos:0;
179 let sooo b = if b then "on" else "off"
180 let dA tos s {contents=v} = s ^ " (" ^ tos v ^ ")"
181 let dF = dA |< sprintf "%4.2f"
182 let dB = dA sooo
183 let dcB = dA sooo
184 let dI = dA string_of_int
185 let dS = dA (fun s -> "`" ^ String.escaped s ^ "'")
187 let sF opt r doc =
188 "-" ^ opt, Arg.Set_float r, pad 9 "<float> " ^ doc |> dF |< r
190 let sI opt r doc =
191 "-" ^ opt, Arg.Set_int r, pad 9 "<int> " ^ doc |> dI |< r
193 let sB opt r doc =
194 "-" ^ opt, Arg.Set r, pad 9 "" ^ doc |> dB |< r
196 let sS opt r doc =
197 "-" ^ opt, Arg.Set_string r, pad 9 "<string> " ^ doc |> dS |< r
199 let fB opt r doc =
200 if r.contents
201 then
202 "-" ^ opt, Arg.Clear r, pad 9 "" ^ doc |> dB |< r
203 else
204 "-" ^ opt, Arg.Set r, pad 9 "" ^ doc |> dcB |< r
206 let init () =
207 let opts =
208 [ sF "f" freq "sampling frequency in seconds"
209 ; sF "D" delay "refresh delay in seconds"
210 ; sF "i" interval "history interval in seconds"
211 ; sI "p" pgrid "percent grid items"
212 ; sI "s" sgrid "history grid items"
213 ; sI "w" w "width"
214 ; sI "h" h "height"
215 ; sI "b" barw "bar width"
216 ; sI "B" bars "number of CPU bars"
217 ; sI "n" niceval "value to renice self on init"
218 ; sI "t" timer "timer frequency in herz"
219 ; sS "d" devpath "path to itc device"
220 ; fB "k" ksampler |< "kernel sampler"
221 ^ (if NP.winnt then "" else " (`/proc/[stat|uptime]')")
222 ; fB "g" gzh "gzh way (does not quite work yet)"
223 ; fB "u" uptime
224 "`uptime' instead of `stat' as kernel sampler (UP only)"
225 ; sB "v" verbose "verbose"
226 ; fB "S" sigway "sigwait delay method"
227 ; fB "c" scalebar "constant bar width"
228 ; fB "P" poly "filled area instead of lines"
229 ; fB "I" icon "icon (hack)"
230 ; fB "l" labels "labels"
231 ; fB "m" mgrid "moving grid"
234 let opts =
235 if NP.winnt
236 then
237 begin
238 let nixopts = ["-n"; "-u"; "-d"; "-I"; "-S"; "-g"] in
239 prerr_endline "Only kernel sampler is available on Windows";
240 List.filter (fun (s, _, _) -> List.mem s nixopts |> not) opts
242 else
243 opts
245 Arg.parse opts
246 (fun s ->
247 "don't know what to do with " ^ s |> prerr_endline;
248 exit 100
250 banner
253 module Gzh = struct
254 let lim = ref 0
255 let stop = ref false
256 let refdt = ref 0.0
258 let rec furious_cycle i =
259 if not !stop && i > 0
260 then pred i |> furious_cycle
261 else (i, Unix.gettimeofday ())
263 let init verbose =
264 let t = 0.5 in
265 let it = { Unix.it_interval = t; it_value = t } in
266 let tries = 1 in
267 let handler =
268 let n = ref tries in
269 fun _ ->
270 decr n;
271 stop := !n = 0;
273 let sign = Sys.sigalrm in
274 let oldh = Sys.signal sign |< Sys.Signal_handle handler in
275 let oldi = Unix.setitimer Unix.ITIMER_REAL it in
276 let oldbp = Unix.sigprocmask Unix.SIG_BLOCK [sign] in
277 let () = NP.waitalrm () in
278 let () = stop := false in
279 let oldup = Unix.sigprocmask Unix.SIG_UNBLOCK [sign] in
280 let t1 = Unix.gettimeofday () in
281 let n, t2 = furious_cycle max_int in
282 let () = refdt := t2 -. t1 in
283 let () = lim := tries * (max_int - n) in
284 let () = if verbose then
285 begin
286 printf "Completed %d iterations in %f seconds@." !lim !refdt
287 end in
288 let _ = Unix.sigprocmask Unix.SIG_UNBLOCK oldup in
289 let _ = Unix.setitimer Unix.ITIMER_REAL oldi in
290 let _ = Unix.sigprocmask Unix.SIG_BLOCK oldbp in
291 let _ = Sys.signal sign oldh in
295 let gen f =
296 let thf () =
297 NP.setnice 20;
298 stop := false;
299 let l = ref 0 in
300 let rec loop t1 =
301 let _, t2 = furious_cycle !lim in
302 let dt = t2 -. t1 in
303 incr l;
304 if !Args.debug && !l > 10
305 then
306 begin
307 printf "Completed %d iterations in %f seconds load %f@."
308 !lim dt |< !refdt /. dt;
309 l := 0;
312 !refdt /. dt |> f;
313 loop t2
315 Unix.gettimeofday () |> loop
317 let _ = Thread.create thf () in
322 let oohz oohz fn =
323 let prev = ref 0.0 in
324 fun () ->
325 let a = !prev in
326 let b = Unix.gettimeofday () in
327 if b -. a > oohz
328 then
329 begin
330 prev := b;
331 fn ()
334 module Delay = struct
335 let sighandler signr = ()
337 let winfreq = ref 0.0
339 let init freq gzh =
340 if NP.winnt
341 then
342 winfreq := 1.0 /. float freq
343 else
344 let () =
345 Sys.Signal_handle sighandler |> Sys.set_signal Sys.sigalrm;
346 if !Args.sigway
347 then
348 let l = if gzh then [Sys.sigprof; Sys.sigvtalrm] else [] in
349 Unix.sigprocmask Unix.SIG_BLOCK |< Sys.sigalrm :: l |> ignore;
352 let v = 1.0 /. float freq in
353 let t = { Unix.it_interval = v; it_value = v } in
354 let _ = Unix.setitimer Unix.ITIMER_REAL t in
357 let delay () =
358 if NP.winnt
359 then
360 NP.delay !winfreq
361 else
362 begin
363 if !Args.sigway
364 then
365 NP.waitalrm ()
366 else
367 begin
368 try let _ = Unix.select [] [] [] ~-.1.0 in ()
369 with Unix.Unix_error (Unix.EINTR, _, _) -> ()
374 type sampler =
375 { color : Gl.rgb;
376 getyielder : unit -> unit -> float option;
377 update : float -> float -> float -> float -> unit;
380 module Sampler(T : sig val nsamples : int val freq : float end) =
381 struct
382 let nsamples = T.nsamples + 1
383 let samples = Array.create nsamples 0.0
384 let head = ref 0
385 let tail = ref 0
386 let active = ref 0
388 let update v n =
389 let n = min nsamples n in
390 let rec loop i j =
391 if j = 0
392 then ()
393 else
394 let i = if i = nsamples then 0 else i in
395 Array.set samples i v;
396 loop (succ i) (pred j)
398 let () = loop !head n in
399 let () = head := (!head + n) mod nsamples in
400 let () = active := min (!active + n) nsamples in
404 let getyielder () =
405 let tail =
406 let d = !head - !active in
407 if d < 0
408 then nsamples + d
409 else d
411 let ry = ref (fun () -> assert false) in
412 let rec yield i () =
413 if i = !active
414 then None
415 else
416 begin
417 ry := succ i |> yield;
418 Some ((i + tail) mod nsamples |> Array.get samples)
421 ry := yield 0;
422 (fun () -> !ry ());
425 let update t1 t2 i1 i2 =
426 let d = t2 -. t1 in
427 let i = i2 -. i1 in
428 let isamples = d /. T.freq |> truncate in
429 let l = 1.0 -. (i /. d) in
430 update l isamples;
434 module type ViewSampler =
436 val getyielder : unit -> unit -> float option
437 val update : float -> float -> float -> float -> unit
440 module type View =
442 val x : int
443 val y : int
444 val w : int
445 val h : int
446 val sgrid : int
447 val pgrid : int
448 val freq : float
449 val interval : float
450 val samplers : sampler list
453 module View(V: sig val w : int val h : int end) = struct
454 let ww = ref 0
455 let wh = ref 0
456 let funcs = ref []
458 let keyboard ~key ~x ~y =
459 if key = 27 || key = Char.code 'q'
460 then exit 0
462 let add dri =
463 funcs := dri :: !funcs
465 let display () =
466 GlClear.clear [`color];
467 List.iter (fun (display, _, _) -> display ()) !funcs;
468 Glut.swapBuffers ()
470 let reshape ~w ~h =
471 ww := w;
472 wh := h;
473 List.iter (fun (_, reshape, _) -> reshape w h) !funcs;
474 GlClear.clear [`color];
475 GlMat.mode `modelview;
476 GlMat.load_identity ();
477 GlMat.mode `projection;
478 GlMat.load_identity ();
479 GlMat.rotate ~y:1.0 ~angle:180.0 ();
480 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
481 GlMat.scale ~x:2.0 ~y:2.0 ();
482 Glut.postRedisplay ()
484 let init () =
485 let () =
486 Glut.initDisplayMode ~double_buffer:true ();
487 Glut.initWindowSize V.w V.h
489 let winid = Glut.createWindow "APC" in
490 Glut.displayFunc display;
491 Glut.reshapeFunc reshape;
492 Glut.keyboardFunc keyboard;
493 GlDraw.color (1.0, 1.0, 0.0);
494 winid;
497 let inc () = List.iter (fun (_, _, inc) -> inc ()) !funcs
498 let update = Glut.postRedisplay
499 let func = Glut.idleFunc
500 let run = Glut.mainLoop
503 module Bar(T: sig val barw : int val bars : int end) = struct
504 let nbars = T.bars
505 let kload = ref 0.0
506 let iload = ref 0.0
507 let vw = ref 0
508 let vh = ref 0
509 let sw = float T.barw /. float !Args.w
510 let bw = ref 0
511 let m = 1
512 let fw = 3 * Glut.bitmapWidth font (Char.code 'W')
513 let ksepsl, isepsl =
514 let base = GlList.gen_lists ~len:2 in
515 GlList.nth base ~pos:0,
516 GlList.nth base ~pos:1
518 let getlr = function
519 | `k -> 0.01, 0.49
520 | `i -> 0.51, 0.99
522 let seps ki =
523 let xl, xr = getlr ki in
524 let y = 18 in
525 let h = !vh - 15 - y in
526 let () = GlDraw.viewport m y !bw h in
527 let () =
528 GlMat.push ();
529 GlMat.load_identity ();
530 GlMat.rotate ~y:1.0 ~angle:180.0 ();
531 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
532 GlMat.scale ~x:2.0 ~y:(2.0 /. float h) ()
534 let barm = 1 in
535 let mspace = barm * nbars in
536 let barh = (h + 66 - mspace / 2) / nbars |> float in
537 let barm = float barm in
538 let rec loop i yb =
539 if i = T.bars
540 then ()
541 else
542 let yt = yb +. barm in
543 let yn = yt +. barh in
544 GlDraw.vertex2 (xl, yb);
545 GlDraw.vertex2 (xl, yt);
546 GlDraw.vertex2 (xr, yt);
547 GlDraw.vertex2 (xr, yb);
548 succ i |> loop |< yn
550 GlDraw.color (0.0, 0.0, 0.0);
551 GlDraw.begins `quads;
552 loop 0 barh;
553 GlDraw.ends ();
554 GlMat.pop ();
557 let reshape w h =
558 vw := w;
559 vh := h;
560 bw :=
561 if !Args.scalebar
562 then
563 (float w *. sw |> truncate) - m
564 else
565 T.barw - m
568 GlList.begins ksepsl `compile;
569 seps `k;
570 GlList.ends ();
572 GlList.begins isepsl `compile;
573 seps `i;
574 GlList.ends ();
577 let drawseps = function
578 | `k -> GlList.call ksepsl
579 | `i -> GlList.call isepsl
582 let display () =
583 let kload = min !kload 1.0 |> max 0.0 in
584 let iload = min !iload 1.0 |> max 0.0 in
585 let () = GlDraw.viewport m 0 !bw 15 in
586 let () =
587 GlDraw.color (1.0, 1.0, 1.0);
588 let kload = 100.0 *. kload in
589 let iload = 100.0 *. iload in
590 let () =
591 GlMat.push ();
592 GlMat.load_identity ();
593 GlMat.scale ~x:(1.0/.float !bw) ~y:(1.0/.30.0) ()
595 let ix = !bw / 2 - fw |> float in
596 let kx = - (fw + !bw / 2) |> float in
597 let () = sprintf "%5.2f" iload |> draw_string ix 0.0 in
598 let () = sprintf "%5.2f" kload |> draw_string kx 0.0 in
599 let () = GlMat.pop () in ()
602 let y = 18 in
603 let h = !vh - 15 - y in
604 let () = GlDraw.viewport m y !bw h in
605 let () =
606 GlMat.push ();
607 GlMat.load_identity ();
608 GlMat.rotate ~y:1.0 ~angle:180.0 ();
609 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
610 GlMat.scale ~x:2.0 ~y:(2.0 /. float h) ()
612 let drawbar load ki =
613 let xl, xr = getlr ki in
614 let drawquad yb yt =
615 GlDraw.begins `quads;
616 GlDraw.vertex2 (xl, yb);
617 GlDraw.vertex2 (xl, yt);
618 GlDraw.vertex2 (xr, yt);
619 GlDraw.vertex2 (xr, yb);
620 GlDraw.ends ()
622 let yt = float h *. load in
623 let yb = 0.0 in
624 let () = drawquad yb yt in
625 let () = GlDraw.color (0.5, 0.5, 0.5) in
626 let yb = yt in
627 let yt = float h in
628 let () = drawquad yb yt in
629 drawseps ki
631 GlDraw.color (1.0, 1.0, 0.0);
632 drawbar iload `k;
633 GlDraw.color (1.0, 0.0, 0.0);
634 drawbar kload `i;
635 GlMat.pop ();
638 let update kload' iload' =
639 kload := kload' /. float NP.nprocs;
640 iload := iload' /. float NP.nprocs;
644 module Graph (V: View) = struct
645 let ox = if !Args.scalebar then 0 else !Args.barw
646 let sw = float V.w /. float (!Args.w - ox)
647 let sh = float V.h /. float !Args.h
648 let sx = float (V.x - ox) /. float V.w
649 let sy = float V.y /. float V.h
650 let vw = ref 0
651 let vh = ref 0
652 let vx = ref 0
653 let vy = ref 0
654 let scale = V.freq /. V.interval
655 let gscale = 1.0 /. float V.sgrid
656 let nsamples = ref 0
658 let fw, fh =
659 if !Args.labels
660 then 3 * Glut.bitmapWidth font (Char.code '%'), 20
661 else 0, 10
663 let gridlist =
664 let base = GlList.gen_lists ~len:1 in
665 GlList.nth base ~pos:0
667 let viewport typ =
668 let ox = if !Args.scalebar then 0 else !Args.barw in
669 let x, y, w, h =
670 match typ with
671 | `labels -> (!vx + ox, !vy + 5, fw, !vh - fh)
672 | `graph -> (!vx + fw + 5 + ox, !vy + 5, !vw - fw - 10, !vh - fh)
674 GlDraw.viewport x y w h;
677 let sgrid () =
678 for i = 0 to V.sgrid
680 let x = if i = 0 then 0.0009 else float i *. gscale in
681 GlDraw.vertex ~x ~y:0.0 ();
682 GlDraw.vertex ~x ~y:1.0 ();
683 done;
686 let grid () =
687 viewport `graph;
688 GlDraw.line_width 1.0;
689 GlDraw.color (0.0, 1.0, 0.0);
690 GlDraw.begins `lines;
691 if !Args.mgrid
692 then
693 begin
694 GlDraw.vertex2 (0.0009, 0.0);
695 GlDraw.vertex2 (0.0009, 1.0);
696 GlDraw.vertex2 (1.0000, 0.0);
697 GlDraw.vertex2 (1.0000, 1.0);
699 else
700 sgrid ()
702 let () =
703 let lim = 100 / V.pgrid in
704 for i = 0 to lim
706 let y = (i * V.pgrid |> float) /. 100.0 in
707 let y = if i = lim then y -. 0.0009 else y in
708 GlDraw.vertex ~x:0.0 ~y ();
709 GlDraw.vertex ~x:1.0 ~y ();
710 done;
712 let () = GlDraw.ends () in
713 if !Args.labels
714 then
715 begin
716 viewport `labels;
717 GlDraw.color (1.0, 1.0, 1.0);
718 let ohp = 100.0 in
719 for i = 0 to 100 / V.pgrid
721 let p = i * V.pgrid in
722 let y = float p /. ohp in
723 let s = Printf.sprintf "%3d%%" p in
724 draw_string 1.0 y s
725 done
729 let reshape w h =
730 let wxsw = float (w - ox) *. sw
731 and hxsh = float h *. sh in
732 vw := wxsw |> truncate;
733 vh := hxsh |> truncate;
734 vx := wxsw *. sx |> truncate;
735 vy := hxsh *. sy |> truncate;
736 GlList.begins gridlist `compile;
737 grid ();
738 GlList.ends ();
741 let swap =
742 Glut.swapBuffers |> oohz !Args.delay;
745 let inc () = incr nsamples
747 let mgrid () =
748 GlDraw.line_width 1.0;
749 GlDraw.color (0.0, 1.0, 0.0);
750 GlDraw.begins `lines;
751 let offset =
752 ((pred !nsamples |> float) *. scale /. gscale |> modf |> fst) *. gscale
754 for i = 0 to pred V.sgrid
756 let x = offset +. float i *. gscale in
757 GlDraw.vertex ~x ~y:0.0 ();
758 GlDraw.vertex ~x ~y:1.0 ();
759 done;
760 GlDraw.ends ();
763 let display () =
764 GlList.call gridlist;
765 viewport `graph;
766 if !Args.mgrid then mgrid ();
767 GlDraw.line_width 1.5;
769 let sample sampler =
770 GlDraw.color sampler.color;
771 let () =
772 if not !Args.poly
773 then GlDraw.begins `line_strip
774 else
775 begin
776 GlDraw.begins `polygon;
777 GlDraw.vertex2 (0.0, 0.0);
780 let yield = sampler.getyielder () in
781 let rec loop last i =
782 match yield () with
783 | Some y as opty ->
784 let x = float i *. scale in
785 GlDraw.vertex ~x ~y ();
786 loop opty (succ i)
787 | None ->
788 if !Args.poly
789 then
790 match last with
791 | None -> ()
792 | Some y ->
793 let x = float (pred i) *. scale in
794 GlDraw.vertex ~x ~y:0.0 ()
796 loop None 0;
797 GlDraw.ends ();
799 List.iter sample V.samplers;
802 let funcs = display, reshape, inc
805 let getplacements w h n barw =
806 let sr = float n |> sqrt |> ceil |> truncate in
807 let d = n / sr in
808 let r = if n mod sr = 0 then 0 else 1 in
809 let x, y =
810 if w - barw > h
811 then
812 sr + r, d
813 else
814 d, sr + r
816 let w' = w - barw in
817 let h' = h in
818 let vw = w' / x in
819 let vh = h' / y in
820 let rec loop accu i =
821 if i = n
822 then accu
823 else
824 let yc = i / x in
825 let xc = i mod x in
826 let xc = xc * vw + barw in
827 let yc = yc * vh in
828 (i, xc, yc) :: accu |> loop |< succ i
830 loop [] 0, vw, vh
832 let create fd w h =
833 let module S =
834 struct
835 let freq = !Args.freq
836 let nsamples = !Args.interval /. freq |> ceil |> truncate
839 let placements, vw, vh = getplacements w h NP.nprocs !Args.barw in
841 let iget () = NP.idletimeofday fd NP.nprocs in
842 let is = iget () in
844 let kget () =
845 let gks = NP.parse_stat () in
846 gks () |> Array.of_list
848 let ks = kget () in
850 let crgraph (kaccu, iaccu, gaccu) (i, x, y) =
851 let module Si = Sampler (S) in
852 let isampler =
853 { getyielder = Si.getyielder
854 ; color = (1.0, 1.0, 0.0)
855 ; update = Si.update
858 let (kcalc, ksampler) =
859 let module Sc = Sampler (S) in
860 let sampler =
861 { getyielder = Sc.getyielder
862 ; color = (1.0, 0.0, 0.0)
863 ; update = Sc.update
866 let calc =
867 if !Args.gzh
868 then
869 let d = ref 0.0 in
870 let f d' = d := d' in
871 let () = Gzh.gen f in
872 fun _ _ _ -> (0.0, !d)
873 else
874 if !Args.uptime
875 then
876 let (u1, i1) = NP.parse_uptime () in
877 let u1 = ref u1
878 and i1 = ref i1 in
879 fun _ _ _ ->
880 let (u2, i2) = NP.parse_uptime () in
881 let du = u2 -. !u1
882 and di = i2 -. !i1 in
883 u1 := u2;
884 i1 := i2;
885 (0.0, di /. du)
886 else
887 let i' = if i = NP.nprocs then 0 else succ i in
888 let n = NP.idle in
889 let g ks = Array.get ks i' |> snd |> Array.get |< n in
890 let i1 = g ks |> ref in
891 fun ks t1 t2 ->
892 let i2 = g ks in
893 let i1' = !i1
894 and i2' = i2 in
895 i1 := i2;
896 (i1', i2')
898 calc, sampler
900 let module V =
901 struct
902 let x = x
903 let y = y
904 let w = vw
905 let h = vh
906 let freq = S.freq
907 let interval = !Args.interval
908 let pgrid = !Args.pgrid
909 let sgrid = !Args.sgrid
910 let samplers =
911 if !Args.ksampler
912 then [isampler; ksampler]
913 else [isampler]
916 let module Graph = Graph (V) in
917 let icalc =
918 let i1 = Array.get is i |> ref in
919 fun is t1 t2 ->
920 let i2 = Array.get is i in
921 if classify_float i2 = FP_infinite
922 then
923 (t1, t2)
924 else
925 let i1' = !i1 in
926 i1 := i2;
927 (i1', i2)
929 let kaccu =
930 if !Args.ksampler
931 then (i, kcalc, ksampler) :: kaccu
932 else kaccu
934 kaccu, (i, icalc, isampler) :: iaccu, Graph.funcs :: gaccu
936 let kl, il, gl = List.fold_left crgraph ([], [], []) placements in
937 ((if kl == [] then (fun () -> [||]) else kget), kl), (iget, il), gl
939 let opendev path =
940 if NP.winnt
941 then
942 Unix.stdout
943 else
945 Unix.openfile path [Unix.O_RDONLY] 0
946 with
947 | Unix.Unix_error (Unix.ENODEV, s1, s2) ->
948 eprintf "Could not open ITC device %S:\n%s(%s): %s)\n"
949 path s1 s2 |< Unix.error_message Unix.ENODEV;
950 eprintf "(perhaps the module is not loaded?)@.";
951 exit 100
953 | Unix.Unix_error (Unix.ENOENT, s1, s2) ->
954 eprintf "Could not open ITC device %S:\n%s(%s): %s\n"
955 path s1 s2 |< Unix.error_message Unix.ENOENT;
956 exit 100
958 | exn ->
959 eprintf "Could not open ITC device %S:\n%s\n"
960 path |< Printexc.to_string exn;
961 exit 100
963 let seticon () =
964 let module X = struct external seticon : string -> unit = "ml_seticon" end in
965 let len = 32*4 in
966 let data = String.create |< 32*len + 2*4 in
967 let line r g b a =
968 let r = Char.chr r
969 and g = Char.chr g
970 and b = Char.chr b
971 and a = Char.chr a in
972 let s = String.create len in
973 let rec fill x =
974 if x = len
975 then s
976 else
977 begin
978 x + 0 |> String.set s |< b;
979 x + 1 |> String.set s |< g;
980 x + 2 |> String.set s |< r;
981 x + 3 |> String.set s |< a;
982 x + 4 |> fill
985 fill 0
987 let el = line 0x00 0x00 0x00 0xff
988 and kl = line 0xff 0x00 0x00 0xff
989 and il = line 0xff 0xff 0x00 0xff in
990 let fill l sy ey =
991 let src = l and dst = data and src_pos = 0 in
992 let rec loop n dst_pos =
993 if n > 0
994 then
995 begin
996 StringLabels.blit ~src ~src_pos ~dst ~dst_pos ~len;
997 pred n |> loop |< dst_pos + len
1000 (ey - sy) |> loop |< (32 - ey) * len + 4*2
1002 fun ~iload ~kload ->
1003 let iy = iload *. 32.0 |> ceil |> truncate |> max 0 |> min 32
1004 and ky = kload *. 32.0 |> ceil |> truncate |> max 0 |> min 32 in
1005 let ey =
1006 if ky < iy
1007 then (fill kl 0 ky; fill il ky iy; iy)
1008 else (fill kl 0 ky; ky)
1010 fill el ey 32;
1011 X.seticon data;
1014 let main () =
1015 let _ = Glut.init [|""|] in
1016 let () = Args.init () in
1017 let () =
1018 if !Args.verbose
1019 then
1020 "detected " ^ string_of_int NP.nprocs ^ " CPUs" |> print_endline
1022 let () = if !Args.gzh then Gzh.init !Args.verbose in
1023 let () = Delay.init !Args.timer !Args.gzh in
1024 let () = if !Args.niceval != 0 then NP.setnice !Args.niceval in
1025 let w = !Args.w
1026 and h = !Args.h in
1027 let fd = opendev !Args.devpath in
1028 let module FullV = View (struct let w = w let h = h end) in
1029 let _winid = FullV.init () in
1030 let (kget, kfuncs), (iget, ifuncs), gl = create fd w h in
1031 let bar_update =
1032 List.iter FullV.add gl;
1033 if !Args.barw > 0
1034 then
1035 let module Bar =
1036 Bar (struct let barw = !Args.barw let bars = !Args.bars end)
1038 FullV.add (Bar.display, Bar.reshape, fun _ -> ());
1039 Bar.update
1040 else
1041 fun _ _ -> ()
1043 let seticon = if !Args.icon then seticon () else fun ~iload ~kload -> () in
1044 let rec loop t1 () =
1045 let t2 = Unix.gettimeofday () in
1046 let dt = t2 -. t1 in
1047 if dt >= !Args.freq
1048 then
1049 let is = iget () in
1050 let ks = kget () in
1051 let rec loop2 load s = function
1052 | [] -> load
1053 | (nr, calc, sampler) :: rest ->
1054 let i1, i2 = calc s t1 t2 in
1055 let thisload = 1.0 -. ((i2 -. i1) /. dt) in
1056 let thisload = max 0.0 thisload in
1057 let () =
1058 if !Args.verbose
1059 then
1060 ("cpu load(" ^ string_of_int nr ^ "): "
1061 ^ (thisload *. 100.0 |> string_of_float)
1062 |> print_endline)
1064 let load = load +. thisload in
1065 sampler.update t1 t2 i1 i2;
1066 loop2 load s rest
1068 let iload = loop2 0.0 is ifuncs in
1069 let kload = loop2 0.0 ks kfuncs in
1070 if !Args.debug
1071 then
1072 begin
1073 iload |> string_of_float |> prerr_endline;
1074 kload |> string_of_float |> prerr_endline;
1077 seticon ~iload ~kload;
1078 bar_update kload iload;
1079 FullV.inc ();
1080 FullV.update ();
1081 FullV.func (Some (loop t2))
1082 else
1083 Delay.delay ()
1085 FullV.func (Some (Unix.gettimeofday () |> loop));
1086 FullV.run ()
1088 let _ =
1089 try main ()
1090 with
1091 | Unix.Unix_error (e, s1, s2) ->
1092 eprintf "%s(%s): %s@." s1 s2 |< Unix.error_message e
1094 | exn ->
1095 Printexc.to_string exn |> eprintf "Exception: %s@."