v0.94
[apc.git] / apc.ml
blobccc8d67cc04aa72f3109b93263b1938ea1823d43
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"
32 let user = 0
33 let nice = 1
34 let sys = 2
35 let idle = 3
36 let iowait = 4
37 let intr = 5
38 let softirq = 6
40 let hz = get_hz () |> float
42 let jiffies_to_sec j =
43 float j /. hz
45 let parse_uptime () =
46 let ic = open_in "/proc/uptime" in
47 let vals = Scanf.fscanf ic "%f %f" (fun u i -> (u, i)) in
48 close_in ic;
49 vals
51 let nprocs = get_nprocs ()
53 let rec parse_int_cont s pos =
54 let slen = String.length s in
55 let pos =
56 let rec skipws pos =
57 if pos = slen
58 then pos
59 else
60 if String.get s pos = ' '
61 then succ pos |> skipws
62 else pos
63 in skipws pos
65 let endpos =
66 try String.index_from s pos ' '
67 with Not_found -> slen
69 let i = endpos - pos |> String.sub s pos |> int_of_string in
70 if endpos = slen
71 then
72 `last i
73 else
74 `more (i, fun () -> succ endpos |> parse_int_cont s)
76 let parse_cpul s =
77 let rec tolist accu = function
78 | `last i -> i :: accu
79 | `more (i, f) -> f () |> tolist (i :: accu)
81 let index = String.index s ' ' in
82 let cpuname = String.sub s 0 index in
83 let vals = parse_int_cont s (succ index) |> tolist [] in
84 let vals = List.rev |<
85 if List.length vals < 7
86 then
87 0 :: 0 :: 0 :: 0 :: vals
88 else
89 vals
91 cpuname, Array.of_list vals
93 let parse_stat () =
94 fun () ->
95 let ic = open_in "/proc/stat" in
96 let rec loop i accu =
97 if i = -1
98 then List.rev accu
99 else (input_line ic |> parse_cpul) :: accu |> loop (pred i)
101 let ret = loop nprocs [] in
102 close_in ic;
105 let getselfdir () =
107 Filename.dirname |< Unix.readlink "/proc/self/exe"
108 with exn ->
109 "./"
112 module Args = struct
113 let banner =
114 [ "Amazing Piece of Code by insanely gifted programmer, Version 0.94"
115 ; "Motivation by: gzh and afs"
116 ; "usage: "
117 ] |> String.concat "\n"
119 let freq = ref 1.0
120 let interval = ref 15.0
121 let devpath = NP.getselfdir () |> Filename.concat |< "itc" |> ref
122 let pgrid = ref 10
123 let sgrid = ref 10
124 let w = ref 400
125 let h = ref 200
126 let verbose = ref false
127 let delay = ref 0.04
128 let ksampler = ref true
129 let barw = ref 100
130 let bars = ref 50
131 let sigway = ref true
132 let niceval = ref 0
133 let gzh = ref false
134 let scalebar = ref false
135 let timer = ref 100
136 let debug = ref false
137 let poly = ref false
138 let uptime = ref false
139 let icon = ref false
140 let labels = ref true
141 let mgrid = ref false
143 let pad n s =
144 let l = String.length s in
145 if l >= n
146 then
148 else
149 let d = String.make n ' ' in
150 StringLabels.blit ~src:s ~dst:d
151 ~src_pos:0 ~len:l
152 ~dst_pos:0;
155 let dA tos s {contents=v} = s ^ " (" ^ tos v ^ ")"
156 let dF = dA |< sprintf "%4.2f"
157 let dB = dA string_of_bool
158 let dcB = dA (fun b -> not b |> string_of_bool)
159 let dI = dA string_of_int
160 let dS = dA (fun s -> "`" ^ String.escaped s ^ "'")
162 let sF opt r doc =
163 "-" ^ opt, Arg.Set_float r, pad 9 "<float> " ^ doc |> dF |< r
165 let sI opt r doc =
166 "-" ^ opt, Arg.Set_int r, pad 9 "<int> " ^ doc |> dI |< r
168 let sB opt r doc =
169 "-" ^ opt, Arg.Set r, pad 9 "" ^ doc |> dB |< r
171 let cB opt r doc =
172 "-" ^ opt, Arg.Clear r, pad 9 "" ^ doc |> dcB |< r
174 let sS opt r doc =
175 "-" ^ opt, Arg.Set_string r, pad 9 "<string> " ^ doc |> dS |< r
177 let init () =
178 Arg.parse
179 [ sF "f" freq "sampling frequency in seconds"
180 ; sF "D" delay "refresh delay in seconds"
181 ; sF "i" interval "history interval in seconds"
182 ; sI "p" pgrid "percent grid"
183 ; sI "s" sgrid "history grid"
184 ; sI "w" w "width"
185 ; sI "h" h "height"
186 ; sI "b" barw "bar width"
187 ; sI "B" bars "number of CPU bars"
188 ; sI "n" niceval "value to renice self on init"
189 ; sI "t" timer "timer frequency in herz"
190 ; sS "d" devpath "path to itc device"
191 ; cB "k" ksampler "do not use `/proc/stat'"
192 ; sB "g" gzh "gzh way (does not quite work yet)"
193 ; sB "u" uptime "use `/proc/uptime' instead of `/proc/stat` (UP only)"
194 ; sB "v" verbose "verbose"
195 ; sB "S" sigway "sigwait delay method"
196 ; sB "c" scalebar "constant bar width"
197 ; sB "P" poly "use filled area instead of lines"
198 ; sB "I" icon "use icon (hack)"
199 ; cB "l" labels "do not draw labels"
200 ; sB "m" mgrid "moving grid"
202 (fun s ->
203 "don't know what to do with " ^ s |> prerr_endline;
204 exit 100
206 banner
209 module Gzh = struct
210 let lim = ref 0
211 let stop = ref false
212 let refdt = ref 0.0
214 let rec furious_cycle i =
215 if not !stop && i > 0
216 then pred i |> furious_cycle
217 else (i, Unix.gettimeofday ())
219 let init verbose =
220 let t = 0.5 in
221 let it = { Unix.it_interval = t; it_value = t } in
222 let tries = 1 in
223 let handler =
224 let n = ref tries in
225 fun _ ->
226 decr n;
227 stop := !n = 0;
229 let sign = Sys.sigalrm in
230 let oldh = Sys.signal sign |< Sys.Signal_handle handler in
231 let oldi = Unix.setitimer Unix.ITIMER_REAL it in
232 let oldbp = Unix.sigprocmask Unix.SIG_BLOCK [sign] in
233 let () = NP.waitalrm () in
234 let () = stop := false in
235 let oldup = Unix.sigprocmask Unix.SIG_UNBLOCK [sign] in
236 let t1 = Unix.gettimeofday () in
237 let n, t2 = furious_cycle max_int in
238 let () = refdt := t2 -. t1 in
239 let () = lim := tries * (max_int - n) in
240 let () = if verbose then
241 begin
242 printf "Completed %d iterations in %f seconds@." !lim !refdt
243 end in
244 let _ = Unix.sigprocmask Unix.SIG_UNBLOCK oldup in
245 let _ = Unix.setitimer Unix.ITIMER_REAL oldi in
246 let _ = Unix.sigprocmask Unix.SIG_BLOCK oldbp in
247 let _ = Sys.signal sign oldh in
251 let gen f =
252 let thf () =
253 NP.setnice 20;
254 stop := false;
255 let l = ref 0 in
256 let rec loop t1 =
257 let _, t2 = furious_cycle !lim in
258 let dt = t2 -. t1 in
259 incr l;
260 if !Args.debug && !l > 10
261 then
262 begin
263 printf "Completed %d iterations in %f seconds load %f@."
264 !lim dt |< !refdt /. dt;
265 l := 0;
268 !refdt /. dt |> f;
269 loop t2
271 Unix.gettimeofday () |> loop
273 let _ = Thread.create thf () in
278 let oohz oohz fn =
279 let prev = ref 0.0 in
280 fun () ->
281 let a = !prev in
282 let b = Unix.gettimeofday () in
283 if b -. a > oohz
284 then
285 begin
286 prev := b;
287 fn ()
290 module Delay = struct
291 let sighandler signr = ()
293 let init freq gzh =
294 let () =
295 Sys.Signal_handle sighandler |> Sys.set_signal Sys.sigalrm;
296 if !Args.sigway
297 then
298 let l = if gzh then [Sys.sigprof; Sys.sigvtalrm] else [] in
299 Unix.sigprocmask Unix.SIG_BLOCK |< Sys.sigalrm :: l |> ignore;
302 let v = 1.0 /. float freq in
303 let t = { Unix.it_interval = v; it_value = v } in
304 let _ = Unix.setitimer Unix.ITIMER_REAL t in
307 let delay () =
308 if !Args.sigway
309 then NP.waitalrm ()
310 else
311 try let _ = Unix.select [] [] [] ~-.1.0 in ()
312 with Unix.Unix_error (Unix.EINTR, _, _) -> ()
315 type sampler =
316 { color : Gl.rgb;
317 getyielder : unit -> unit -> float option;
318 update : float -> float -> float -> float -> unit;
321 module Sampler(T : sig val nsamples : int val freq : float end) =
322 struct
323 let nsamples = T.nsamples + 1
324 let samples = Array.create nsamples 0.0
325 let head = ref 0
326 let tail = ref 0
327 let active = ref 0
329 let update v n =
330 let n = min nsamples n in
331 let rec loop i j =
332 if j = 0
333 then ()
334 else
335 let i = if i = nsamples then 0 else i in
336 Array.set samples i v;
337 loop (succ i) (pred j)
339 let () = loop !head n in
340 let () = head := (!head + n) mod nsamples in
341 let () = active := min (!active + n) nsamples in
345 let getyielder () =
346 let tail =
347 let d = !head - !active in
348 if d < 0
349 then nsamples + d
350 else d
352 let ry = ref (fun () -> assert false) in
353 let rec yield i () =
354 if i = !active
355 then None
356 else
357 begin
358 ry := succ i |> yield;
359 Some ((i + tail) mod nsamples |> Array.get samples)
362 ry := yield 0;
363 (fun () -> !ry ());
366 let update t1 t2 i1 i2 =
367 let d = t2 -. t1 in
368 let i = i2 -. i1 in
369 let isamples = d /. T.freq |> truncate in
370 let l = 1.0 -. (i /. d) in
371 update l isamples;
375 module type ViewSampler =
377 val getyielder : unit -> unit -> float option
378 val update : float -> float -> float -> float -> unit
381 module type View =
383 val x : int
384 val y : int
385 val w : int
386 val h : int
387 val sgrid : int
388 val pgrid : int
389 val freq : float
390 val interval : float
391 val samplers : sampler list
394 module View(V: sig val w : int val h : int end) = struct
395 let ww = ref 0
396 let wh = ref 0
397 let funcs = ref []
399 let keyboard ~key ~x ~y =
400 if key = 27 || key = Char.code 'q'
401 then exit 0
403 let add dri =
404 funcs := dri :: !funcs
406 let display () =
407 GlClear.clear [`color];
408 List.iter (fun (display, _, _) -> display ()) !funcs;
409 Glut.swapBuffers ()
411 let reshape ~w ~h =
412 ww := w;
413 wh := h;
414 List.iter (fun (_, reshape, _) -> reshape w h) !funcs;
415 GlClear.clear [`color];
416 GlMat.mode `modelview;
417 GlMat.load_identity ();
418 GlMat.mode `projection;
419 GlMat.load_identity ();
420 GlMat.rotate ~y:1.0 ~angle:180.0 ();
421 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
422 GlMat.scale ~x:2.0 ~y:2.0 ();
423 Glut.postRedisplay ()
425 let init () =
426 let () =
427 Glut.initDisplayMode ~double_buffer:true ();
428 Glut.initWindowSize V.w V.h
430 let winid = Glut.createWindow "APC" in
431 Glut.displayFunc display;
432 Glut.reshapeFunc reshape;
433 Glut.keyboardFunc keyboard;
434 GlDraw.color (1.0, 1.0, 0.0);
435 winid;
438 let inc () = List.iter (fun (_, _, inc) -> inc ()) !funcs
439 let update = Glut.postRedisplay
440 let func = Glut.idleFunc
441 let run = Glut.mainLoop
444 module Bar(T: sig val barw : int val bars : int end) = struct
445 let nbars = T.bars
446 let kload = ref 0.0
447 let iload = ref 0.0
448 let vw = ref 0
449 let vh = ref 0
450 let sw = float T.barw /. float !Args.w
451 let bw = ref 0
452 let m = 1
453 let fw = 3 * Glut.bitmapWidth font (Char.code 'W')
454 let ksepsl, isepsl =
455 let base = GlList.gen_lists ~len:2 in
456 GlList.nth base ~pos:0,
457 GlList.nth base ~pos:1
459 let getlr = function
460 | `k -> 0.01, 0.49
461 | `i -> 0.51, 0.99
463 let seps ki =
464 let xl, xr = getlr ki in
465 let y = 18 in
466 let h = !vh - 15 - y in
467 let () = GlDraw.viewport m y !bw h in
468 let () =
469 GlMat.push ();
470 GlMat.load_identity ();
471 GlMat.rotate ~y:1.0 ~angle:180.0 ();
472 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
473 GlMat.scale ~x:2.0 ~y:(2.0 /. float h) ()
475 let barm = 1 in
476 let mspace = barm * nbars in
477 let barh = (h + 66 - mspace / 2) / nbars |> float in
478 let barm = float barm in
479 let rec loop i yb =
480 if i = T.bars
481 then ()
482 else
483 let yt = yb +. barm in
484 let yn = yt +. barh in
485 GlDraw.vertex2 (xl, yb);
486 GlDraw.vertex2 (xl, yt);
487 GlDraw.vertex2 (xr, yt);
488 GlDraw.vertex2 (xr, yb);
489 succ i |> loop |< yn
491 GlDraw.color (0.0, 0.0, 0.0);
492 GlDraw.begins `quads;
493 loop 0 barh;
494 GlDraw.ends ();
495 GlMat.pop ();
498 let reshape w h =
499 vw := w;
500 vh := h;
501 bw :=
502 if !Args.scalebar
503 then
504 (float w *. sw |> truncate) - m
505 else
506 T.barw - m
509 GlList.begins ksepsl `compile;
510 seps `k;
511 GlList.ends ();
513 GlList.begins isepsl `compile;
514 seps `i;
515 GlList.ends ();
518 let drawseps = function
519 | `k -> GlList.call ksepsl
520 | `i -> GlList.call isepsl
523 let display () =
524 let kload = min !kload 1.0 |> max 0.0 in
525 let iload = min !iload 1.0 |> max 0.0 in
526 let () = GlDraw.viewport m 0 !bw 15 in
527 let () =
528 GlDraw.color (1.0, 1.0, 1.0);
529 let kload = 100.0 *. kload in
530 let iload = 100.0 *. iload in
531 let () =
532 GlMat.push ();
533 GlMat.load_identity ();
534 GlMat.scale ~x:(1.0/.float !bw) ~y:(1.0/.30.0) ()
536 let ix = !bw / 2 - fw |> float in
537 let kx = - (fw + !bw / 2) |> float in
538 let () = sprintf "%5.2f" iload |> draw_string ix 0.0 in
539 let () = sprintf "%5.2f" kload |> draw_string kx 0.0 in
540 let () = GlMat.pop () in ()
543 let y = 18 in
544 let h = !vh - 15 - y in
545 let () = GlDraw.viewport m y !bw h in
546 let () =
547 GlMat.push ();
548 GlMat.load_identity ();
549 GlMat.rotate ~y:1.0 ~angle:180.0 ();
550 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
551 GlMat.scale ~x:2.0 ~y:(2.0 /. float h) ()
553 let drawbar load ki =
554 let xl, xr = getlr ki in
555 let drawquad yb yt =
556 GlDraw.begins `quads;
557 GlDraw.vertex2 (xl, yb);
558 GlDraw.vertex2 (xl, yt);
559 GlDraw.vertex2 (xr, yt);
560 GlDraw.vertex2 (xr, yb);
561 GlDraw.ends ()
563 let yt = float h *. load in
564 let yb = 0.0 in
565 let () = drawquad yb yt in
566 let () = GlDraw.color (0.5, 0.5, 0.5) in
567 let yb = yt in
568 let yt = float h in
569 let () = drawquad yb yt in
570 drawseps ki
572 GlDraw.color (1.0, 1.0, 0.0);
573 drawbar iload `k;
574 GlDraw.color (1.0, 0.0, 0.0);
575 drawbar kload `i;
576 GlMat.pop ();
579 let update kload' iload' =
580 kload := kload' /. float NP.nprocs;
581 iload := iload' /. float NP.nprocs;
585 module Graph (V: View) = struct
586 let ox = if !Args.scalebar then 0 else !Args.barw
587 let sw = float V.w /. float (!Args.w - ox)
588 let sh = float V.h /. float !Args.h
589 let sx = float (V.x - ox) /. float V.w
590 let sy = float V.y /. float V.h
591 let vw = ref 0
592 let vh = ref 0
593 let vx = ref 0
594 let vy = ref 0
595 let scale = V.freq /. V.interval
596 let gscale = 1.0 /. float V.sgrid
597 let nsamples = ref 0
599 let fw, fh =
600 if !Args.labels
601 then 3 * Glut.bitmapWidth font (Char.code '%'), 20
602 else 0, 10
604 let gridlist =
605 let base = GlList.gen_lists ~len:1 in
606 GlList.nth base ~pos:0
608 let viewport typ =
609 let ox = if !Args.scalebar then 0 else !Args.barw in
610 let x, y, w, h =
611 match typ with
612 | `labels -> (!vx + ox, !vy + 5, fw, !vh - fh)
613 | `graph -> (!vx + fw + 5 + ox, !vy + 5, !vw - fw - 10, !vh - fh)
615 GlDraw.viewport x y w h;
618 let sgrid () =
619 for i = 0 to V.sgrid
621 let x = if i = 0 then 0.0009 else float i *. gscale in
622 GlDraw.vertex ~x ~y:0.0 ();
623 GlDraw.vertex ~x ~y:1.0 ();
624 done;
627 let grid () =
628 viewport `graph;
629 GlDraw.line_width 1.0;
630 GlDraw.color (0.0, 1.0, 0.0);
631 GlDraw.begins `lines;
632 if !Args.mgrid
633 then
634 begin
635 GlDraw.vertex2 (0.0009, 0.0);
636 GlDraw.vertex2 (0.0009, 1.0);
637 GlDraw.vertex2 (1.0000, 0.0);
638 GlDraw.vertex2 (1.0000, 1.0);
640 else
641 sgrid ()
643 let () =
644 let lim = 100 / V.pgrid in
645 for i = 0 to lim
647 let y = (i * V.pgrid |> float) /. 100.0 in
648 let y = if i = lim then y -. 0.0009 else y in
649 GlDraw.vertex ~x:0.0 ~y ();
650 GlDraw.vertex ~x:1.0 ~y ();
651 done;
653 let () = GlDraw.ends () in
654 if !Args.labels
655 then
656 begin
657 viewport `labels;
658 GlDraw.color (1.0, 1.0, 1.0);
659 let ohp = 100.0 in
660 for i = 0 to 100 / V.pgrid
662 let p = i * V.pgrid in
663 let y = float p /. ohp in
664 let s = Printf.sprintf "%3d%%" p in
665 draw_string 1.0 y s
666 done
670 let reshape w h =
671 let wxsw = float (w - ox) *. sw
672 and hxsh = float h *. sh in
673 vw := wxsw |> truncate;
674 vh := hxsh |> truncate;
675 vx := wxsw *. sx |> truncate;
676 vy := hxsh *. sy |> truncate;
677 GlList.begins gridlist `compile;
678 grid ();
679 GlList.ends ();
682 let swap =
683 Glut.swapBuffers |> oohz !Args.delay;
686 let inc () = incr nsamples
688 let mgrid () =
689 GlDraw.line_width 1.0;
690 GlDraw.color (0.0, 1.0, 0.0);
691 GlDraw.begins `lines;
692 let offset =
693 ((pred !nsamples |> float) *. scale /. gscale |> modf |> fst) *. gscale
695 for i = 0 to pred V.sgrid
697 let x = offset +. float i *. gscale in
698 GlDraw.vertex ~x ~y:0.0 ();
699 GlDraw.vertex ~x ~y:1.0 ();
700 done;
701 GlDraw.ends ();
704 let display () =
705 GlList.call gridlist;
706 viewport `graph;
707 if !Args.mgrid then mgrid ();
708 GlDraw.line_width 1.5;
710 let sample sampler =
711 GlDraw.color sampler.color;
712 let () =
713 if not !Args.poly
714 then GlDraw.begins `line_strip
715 else
716 begin
717 GlDraw.begins `polygon;
718 GlDraw.vertex2 (0.0, 0.0);
721 let yield = sampler.getyielder () in
722 let rec loop last i =
723 match yield () with
724 | Some y as opty ->
725 let x = float i *. scale in
726 GlDraw.vertex ~x ~y ();
727 loop opty (succ i)
728 | None ->
729 if !Args.poly
730 then
731 match last with
732 | None -> ()
733 | Some y ->
734 let x = float (pred i) *. scale in
735 GlDraw.vertex ~x ~y:0.0 ()
737 loop None 0;
738 GlDraw.ends ();
740 List.iter sample V.samplers;
743 let funcs = display, reshape, inc
746 let getplacements w h n barw =
747 let sr = float n |> sqrt |> ceil |> truncate in
748 let d = n / sr in
749 let r = if n mod sr = 0 then 0 else 1 in
750 let x, y =
751 if w - barw > h
752 then
753 sr + r, d
754 else
755 d, sr + r
757 let w' = w - barw in
758 let h' = h in
759 let vw = w' / x in
760 let vh = h' / y in
761 let rec loop accu i =
762 if i = n
763 then accu
764 else
765 let yc = i / x in
766 let xc = i mod x in
767 let xc = xc * vw + barw in
768 let yc = yc * vh in
769 (i, xc, yc) :: accu |> loop |< succ i
771 loop [] 0, vw, vh
773 let create fd w h =
774 let module S =
775 struct
776 let freq = !Args.freq
777 let nsamples = !Args.interval /. freq |> ceil |> truncate
780 let placements, vw, vh = getplacements w h NP.nprocs !Args.barw in
782 let iget () = NP.idletimeofday fd NP.nprocs in
783 let is = iget () in
785 let kget () =
786 let gks = NP.parse_stat () in
787 gks () |> Array.of_list
789 let ks = kget () in
791 let crgraph (kaccu, iaccu, gaccu) (i, x, y) =
792 let module Si = Sampler (S) in
793 let isampler =
794 { getyielder = Si.getyielder
795 ; color = (1.0, 1.0, 0.0)
796 ; update = Si.update
799 let (kcalc, ksampler) =
800 let module Sc = Sampler (S) in
801 let sampler =
802 { getyielder = Sc.getyielder
803 ; color = (1.0, 0.0, 0.0)
804 ; update = Sc.update
807 let calc =
808 if !Args.gzh
809 then
810 let d = ref 0.0 in
811 let f d' = d := d' in
812 let () = Gzh.gen f in
813 fun _ _ _ -> (0.0, !d)
814 else
815 if !Args.uptime
816 then
817 let (u1, i1) = NP.parse_uptime () in
818 let u1 = ref u1
819 and i1 = ref i1 in
820 fun _ _ _ ->
821 let (u2, i2) = NP.parse_uptime () in
822 let du = u2 -. !u1
823 and di = i2 -. !i1 in
824 u1 := u2;
825 i1 := i2;
826 (0.0, di /. du)
827 else
828 let i' = if i = NP.nprocs then 0 else succ i in
829 let n = NP.idle in
830 let g ks = Array.get ks i' |> snd |> Array.get |< n in
831 let i1 = g ks |> ref in
832 fun ks t1 t2 ->
833 let i2 = g ks in
834 let i1' = NP.jiffies_to_sec !i1
835 and i2' = NP.jiffies_to_sec i2 in
836 i1 := i2;
837 (i1', i2')
839 calc, sampler
841 let module V =
842 struct
843 let x = x
844 let y = y
845 let w = vw
846 let h = vh
847 let freq = S.freq
848 let interval = !Args.interval
849 let pgrid = !Args.pgrid
850 let sgrid = !Args.sgrid
851 let samplers =
852 if !Args.ksampler
853 then [isampler; ksampler]
854 else [isampler]
857 let module Graph = Graph (V) in
858 let icalc =
859 let i1 = Array.get is i |> ref in
860 fun is t1 t2 ->
861 let i2 = Array.get is i in
862 let i1' = !i1 in
863 i1 := i2;
864 (i1', i2)
866 let kaccu =
867 if !Args.ksampler
868 then (i, kcalc, ksampler) :: kaccu
869 else kaccu
871 kaccu, (i, icalc, isampler) :: iaccu, Graph.funcs :: gaccu
873 let kl, il, gl = List.fold_left crgraph ([], [], []) placements in
874 ((if kl == [] then (fun () -> [||]) else kget), kl), (iget, il), gl
876 let opendev path =
878 Unix.openfile path [Unix.O_RDONLY] 0
879 with
880 | Unix.Unix_error (Unix.ENODEV, s1, s2) ->
881 eprintf "Could not open ITC device %S:\n%s(%s): %s)\n"
882 path s1 s2 |< Unix.error_message Unix.ENODEV;
883 eprintf "(perhaps the module is not loaded?)@.";
884 exit 100
886 | Unix.Unix_error (Unix.ENOENT, s1, s2) ->
887 eprintf "Could not open ITC device %S:\n%s(%s): %s\n"
888 path s1 s2 |< Unix.error_message Unix.ENOENT;
889 exit 100
891 | exn ->
892 eprintf "Could not open ITC device %S:\n%s\n"
893 path |< Printexc.to_string exn;
894 exit 100
896 let seticon () =
897 let module X = struct external seticon : string -> unit = "ml_seticon" end in
898 let len = 32*4 in
899 let data = String.create |< 32*len + 2*4 in
900 let line r g b a =
901 let r = Char.chr r
902 and g = Char.chr g
903 and b = Char.chr b
904 and a = Char.chr a in
905 let s = String.create len in
906 let rec fill x =
907 if x = len
908 then s
909 else
910 begin
911 x + 0 |> String.set s |< b;
912 x + 1 |> String.set s |< g;
913 x + 2 |> String.set s |< r;
914 x + 3 |> String.set s |< a;
915 x + 4 |> fill
918 fill 0
920 let el = line 0x00 0x00 0x00 0xff
921 and kl = line 0xff 0x00 0x00 0xff
922 and il = line 0xff 0xff 0x00 0xff in
923 let fill l sy ey =
924 let src = l and dst = data and src_pos = 0 in
925 let rec loop n dst_pos =
926 if n > 0
927 then
928 begin
929 StringLabels.blit ~src ~src_pos ~dst ~dst_pos ~len;
930 pred n |> loop |< dst_pos + len
933 (ey - sy) |> loop |< (32 - ey) * len + 4*2
935 fun ~iload ~kload ->
936 let iy = iload *. 32.0 |> ceil |> truncate |> max 0 |> min 32
937 and ky = kload *. 32.0 |> ceil |> truncate |> max 0 |> min 32 in
938 let ey =
939 if ky < iy
940 then (fill kl 0 ky; fill il ky iy; iy)
941 else (fill kl 0 ky; ky)
943 fill el ey 32;
944 X.seticon data;
947 let main () =
948 let _ = Glut.init [|""|] in
949 let () = Args.init () in
950 let () = if !Args.gzh then Gzh.init !Args.verbose in
951 let () = Delay.init !Args.timer !Args.gzh in
952 let () = if !Args.niceval != 0 then NP.setnice !Args.niceval in
953 let w = !Args.w
954 and h = !Args.h in
955 let fd = opendev !Args.devpath in
956 let module FullV = View (struct let w = w let h = h end) in
957 let _winid = FullV.init () in
958 let (kget, kfuncs), (iget, ifuncs), gl = create fd w h in
959 let bar_update =
960 List.iter FullV.add gl;
961 if !Args.barw > 0
962 then
963 let module Bar =
964 Bar (struct let barw = !Args.barw let bars = !Args.bars end)
966 FullV.add (Bar.display, Bar.reshape, fun _ -> ());
967 Bar.update
968 else
969 fun _ _ -> ()
971 let seticon = if !Args.icon then seticon () else fun ~iload ~kload -> () in
972 let rec loop t1 () =
973 let t2 = Unix.gettimeofday () in
974 let dt = t2 -. t1 in
975 if dt >= !Args.freq
976 then
977 let is = iget () in
978 let ks = kget () in
979 let rec loop2 load s = function
980 | [] -> load
981 | (nr, calc, sampler) :: rest ->
982 let i1, i2 = calc s t1 t2 in
983 let thisload = 1.0 -. ((i2 -. i1) /. dt) in
984 let () =
985 if !Args.verbose
986 then
987 ("cpu load(" ^ string_of_int nr ^ "): "
988 ^ (thisload *. 100.0 |> string_of_float)
989 |> print_endline)
991 let load = load +. thisload in
992 sampler.update t1 t2 i1 i2;
993 loop2 load s rest
995 let iload = loop2 0.0 is ifuncs in
996 let kload = loop2 0.0 ks kfuncs in
997 if !Args.debug
998 then
999 begin
1000 iload |> string_of_float |> prerr_endline;
1001 kload |> string_of_float |> prerr_endline;
1004 seticon ~iload ~kload;
1005 bar_update kload iload;
1006 FullV.inc ();
1007 FullV.update ();
1008 FullV.func (Some (loop t2))
1009 else
1010 Delay.delay ()
1012 FullV.func (Some (Unix.gettimeofday () |> loop));
1013 FullV.run ()
1015 let _ =
1016 try main ()
1017 with
1018 | Unix.Unix_error (e, s1, s2) ->
1019 eprintf "%s(%s): %s@." s1 s2 |< Unix.error_message e
1021 | exn ->
1022 Printexc.to_string exn |> eprintf "Exception: %s@."