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
44 ; softirq
= -.a
.softirq
54 ; iowait
= a
.iowait
*. s
56 ; softirq
= a
.softirq
*. s
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
76 ; loads
: int64
* int64
* int64
94 external get_nprocs
: unit -> int = "ml_get_nprocs"
95 external idletimeofday
: Unix.file_descr
-> int -> float array
97 external sysinfo
: unit -> sysinfo
= "ml_sysinfo"
98 external waitalrm
: unit -> unit = "ml_waitalrm"
99 external get_hz
: unit -> int = "ml_get_hz"
100 external setnice
: int -> unit = "ml_nice"
101 external delay
: float -> unit = "ml_delay"
102 external os_type
: unit -> os
= "ml_os_type"
103 external solaris_kstat
: int -> float array
= "ml_solaris_kstat"
104 external macosx_host_processor_info
: int -> float array
=
105 "ml_macosx_host_processor_info"
106 external windows_processor_times
: int -> float array
=
107 "ml_windows_processor_times"
108 external fixwindow
: int -> unit = "ml_fixwindow"
109 external testpmc
: unit -> bool = "ml_testpmc"
111 let os_type = os_type ()
113 let winnt = os_type = Windows
114 let solaris = os_type = Solaris
115 let linux = os_type = Linux
116 let macosx = os_type = MacOSX
126 let hz = get_hz
() |> float
128 let parse_uptime () =
129 let ic = open_in
"/proc/uptime" in
130 let vals = Scanf.fscanf
ic "%f %f" (fun u i
-> (u
, i
)) in
135 let nprocs = get_nprocs
()
137 let rec parse_int_cont s pos
=
138 let jiffies_to_sec j
=
141 let slen = String.length s
in
149 if String.get s
pos = ' '
158 try String.index_from s
pos ' '
159 with Not_found
-> slen
161 let i = endpos - pos |> String.sub s
pos
168 `more
(i, fun () -> succ
endpos |> parse_int_cont s
)
172 let rec tolist accu
= function
173 | `last
i -> i :: accu
174 | `more
(i, f
) -> f
() |> tolist (i :: accu
)
176 let index = String.index s ' '
in
177 let cpuname = String.sub s
0 index in
178 let vals = parse_int_cont s
(succ
index) |> tolist [] in
179 let vals = List.rev
|<
180 if List.length
vals < 7
182 0.0 :: 0.0 :: 0.0 :: 0.0 :: vals
186 cpuname, Array.of_list
vals
193 let iukw = windows_processor_times
nprocs in
194 let rec create n ai ak au ad ar accu
=
197 ("cpu", [| au
; ad
; ak
; ai
; 0.0; ar
; 0.0 |]) :: List.rev accu
199 let hdr = "cpu" ^ string_of_int n
in
201 let i = Array.get
iukw (o + 0) in
202 let k = Array.get
iukw (o + 1) in
203 let u = Array.get
iukw (o + 2) in
204 let d = Array.get
iukw (o + 3) in
205 let r = Array.get
iukw (o + 4) in
211 let accu = (hdr, [| u; d; k; i; 0.0; r; 0.0 |]) :: accu in
212 create (succ n
) ai ak au ad ar accu
214 create 0 0.0 0.0 0.0 0.0 0.0 []
219 let ic = open_in
"/proc/stat" in
220 let rec loop i accu =
225 (input_line
ic |> parse_cpul) :: accu |> loop (pred
i)
227 let ret = loop nprocs [] in
234 let iukw = solaris_kstat
nprocs in
235 let rec create n
ai au ak aw
accu =
238 ("cpu", [| au; 0.0; ak; ai; aw
; 0.0; 0.0 |]) :: List.rev
accu
240 let hdr = "cpu" ^ string_of_int n
in
242 let i = Array.get
iukw (o + 0) /. hz in
243 let u = Array.get
iukw (o + 1) /. hz in
244 let k = Array.get
iukw (o + 2) /. hz in
245 let w = Array.get
iukw (o + 3) /. hz in
250 let accu = (hdr, [| u; 0.0; k; i; w; 0.0; 0.0 |]) :: accu in
251 create (succ n
) ai au ak aw accu
253 create 0 0.0 0.0 0.0 0.0 []
258 let iukn = macosx_host_processor_info
nprocs in
259 let rec create c
ai au ak an
accu =
262 ("cpu", [| au; an
; ak; ai; 0.0; 0.0; 0.0 |]) :: List.rev
accu
264 let hdr = "cpu" ^ string_of_int c
in
266 let i = Array.get
iukn (o + 0) /. hz in
267 let u = Array.get
iukn (o + 1) /. hz in
268 let k = Array.get
iukn (o + 2) /. hz in
269 let n = Array.get
iukn (o + 3) /. hz in
274 let accu = (hdr, [| u; n; k; i; 0.0; 0.0; 0.0 |]) :: accu in
275 create (succ c
) ai au ak an accu
277 create 0 0.0 0.0 0.0 0.0 []
285 [ "Amazing Piece of Code by insanely gifted programmer, Version 1.01"
286 ; "Motivation by: gzh and afs"
288 ] |> String.concat
"\n"
291 let interval = ref 15.0
292 let devpath = ref "/dev/itc"
297 let verbose = ref false
299 let ksampler = ref true
300 let isampler = ref true
303 let sigway = ref (NP.os_type != NP.MacOSX
)
306 let scalebar = ref false
308 let debug = ref false
310 let uptime = ref false
312 let labels = ref true
313 let mgrid = ref false
314 let sepstat = ref true
315 let grid_green = ref 0.75
318 let l = String.length s
in
323 let d = String.make
n ' '
in
324 StringLabels.blit ~src
:s ~dst
:d
330 let sooo b
= if b
then "on" else "off"
331 let dA tos s
{contents
=v
} = s ^
" (" ^ tos v ^
")"
332 let dF = dA |< sprintf
"%4.2f"
335 let dI = dA string_of_int
336 let dS = dA (fun s
-> "`" ^
String.escaped s ^
"'")
339 "-" ^ opt
, Arg.Set_float
r, pad 9 "<float> " ^ doc
|> dF |< r
343 "-" ^ opt
, Arg.Set_int
r, pad 9 "<int> " ^ doc
|> dI |< r
347 "-" ^ opt
, Arg.Set
r, pad 9 "" ^ doc
|> dB |< r
351 "-" ^ opt
, Arg.Set_string
r, pad 9 "<string> " ^ doc
|> dS |< r
357 "-" ^ opt
, Arg.Clear
r, pad 9 "" ^ doc
|> dB |< r
359 "-" ^ opt
, Arg.Set
r, pad 9 "" ^ doc
|> dcB |< r
363 [ sF "f" freq "sampling frequency in seconds"
364 ; sF "D" delay "refresh delay in seconds"
365 ; sF "i" interval "history interval in seconds"
366 ; sI "p" pgrid "percent grid items"
367 ; sI "s" sgrid "history grid items"
370 ; sI "b" barw "bar width"
371 ; sI "B" bars "number of CPU bars"
372 ; sB "v" verbose "verbose"
373 ; fB "C" sepstat "separate sys/nice/intr/iowait values (kernel sampler)"
374 ; fB "c" scalebar "constant bar width"
375 ; fB "P" poly "filled area instead of lines"
376 ; fB "l" labels "labels"
377 ; fB "m" mgrid "moving grid"
383 sI "t" timer "timer frequency in herz"
384 :: fB "I" icon "icon (hack)"
385 :: sS "d" devpath "path to itc device"
386 :: (fB "k" ksampler |< "kernel sampler (`/proc/[stat|uptime]')")
387 :: (fB "M" isampler |< "idle sampler")
389 "`uptime' instead of `stat' as kernel sampler (UP only)")
390 :: sI "n" niceval "value to renice self on init"
391 :: fB "g" gzh "gzh way (does not quite work yet)"
392 :: fB "S" sigway "sigwait delay method"
395 let add_solaris opts
=
397 fB "I" icon "icon (hack)"
400 let add_windows opts
=
402 (fB "k" ksampler |< "kernel sampler (ZwQuerySystemInformation)")
403 :: (fB "M" isampler |< "idle sampler (PMC based)")
406 let add_macosx opts
=
408 fB "g" gzh "gzh way (does not quite work yet)"
411 match NP.os_type with
412 | NP.Linux
-> add_linux tail
413 | NP.Windows
-> add_windows tail
414 | NP.Solaris
-> add_solaris tail
415 | NP.MacOSX
-> add_macosx tail
419 let opts = add_opts commonopts in
423 ("Invocation error: Don't know what to do with " ^ s
));
427 let cp {contents
=v
} s
=
429 then (prerr_string s
; prerr_endline
" must be positive"; exit
1)
431 let cpf {contents
=v
} s
=
433 then (prerr_string s
; prerr_endline
" must be positive"; exit
1)
437 cp pgrid "Number of percent grid items";
438 cp sgrid "Number of history grid items";
439 cp bars "Number of CPU bars";
440 cp timer "Timer frequency";
441 cpf freq "Frequency";
443 cpf interval "Interval";
444 if not
(!isampler || !ksampler)
448 if NP.winnt && !isampler
450 isampler := NP.testpmc
()
461 let rec furious_cycle i =
462 if not
!stop && i > 0
464 pred
i |> furious_cycle
466 (i, Unix.gettimeofday
())
471 let it = { Unix.it_interval
= t; it_value
= t } in
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
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
508 let _, t2
= furious_cycle !lim in
511 if !Args.debug && !l > 10
514 printf
"Completed %d iterations in %f seconds load %f@."
515 !lim dt |< !refdt /. dt;
522 Unix.gettimeofday
() |> loop
524 let _ = Thread.create thf () in
530 let prev = ref 0.0 in
533 let b = Unix.gettimeofday
() in
544 let sighandler signr
= ()
546 let winfreq = ref 0.0
551 winfreq := 1.0 /. float freq
554 Sys.Signal_handle
sighandler |> Sys.set_signal
Sys.sigalrm
;
560 [Sys.sigprof
; Sys.sigvtalrm
]
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
584 try let _ = Unix.select
[] [] [] ~
-.1.0 in ()
585 with Unix.Unix_error
(Unix.EINTR
, _, _) -> ()
593 getyielder
: unit -> unit -> float option;
594 update
: float -> float -> unit;
598 module Sampler
(T
: sig val nsamples
: int val freq : float end) =
600 let nsamples = T.nsamples + 1
601 let samples = Array.create nsamples 0.0
607 let n = min
nsamples n in
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
631 let d = !head - !active in
638 let ry = ref (fun () -> assert false) in
645 ry := succ
i |> yield;
646 Some
((i + tail) mod nsamples |> Array.get
samples)
654 let isamples = dt /. T.freq |> truncate
in
655 let l = 1.0 -. (di
/. dt) in
661 module type ViewSampler
=
663 val getyielder : unit -> unit -> float option
664 val update : float -> float -> float -> float -> unit
677 val samplers
: sampler list
680 module View
(V
: sig val w : int val h : int end) =
684 let oldwidth = ref !Args.w
685 let barmode = ref false
688 let keyboard ~key ~x ~y
=
689 if key
= 27 || key
= Char.code 'q'
693 if key
= Char.code '
b'
&& not
!barmode
696 let h = Glut.get
Glut.WINDOW_HEIGHT
in
697 oldwidth := Glut.get
Glut.WINDOW_WIDTH
;
698 Glut.reshapeWindow ~
w:(!Args.barw + 4) ~
h;
702 if key
= Char.code '
a'
&& !barmode
705 let h = Glut.get
Glut.WINDOW_HEIGHT
in
706 Glut.reshapeWindow ~
w:!oldwidth ~
h;
713 funcs := dri
:: !funcs
717 GlClear.clear
[`color
];
718 List.iter
(fun (display, _, _) -> display ()) !funcs;
725 List.iter
(fun (_, reshape, _) -> reshape w h) !funcs;
726 GlClear.clear
[`color
];
727 GlMat.mode `modelview
;
728 GlMat.load_identity
();
729 GlMat.mode `projection
;
730 GlMat.load_identity
();
731 GlMat.rotate ~y
:1.0 ~angle
:180.0 ();
732 GlMat.translate ~x
:~
-.1.0 ~y
:~
-.1.0 ();
733 GlMat.scale ~x
:2.0 ~y
:2.0 ();
734 Glut.postRedisplay
();
739 Glut.initDisplayMode ~double_buffer
:true ();
740 Glut.initWindowSize
V.w V.h
742 let winid = Glut.createWindow
"APC" in
743 Glut.displayFunc
display;
744 Glut.reshapeFunc
reshape;
745 Glut.keyboardFunc
keyboard;
746 GlDraw.color
(1.0, 1.0, 0.0);
750 let inc () = List.iter
(fun (_, _, inc) -> inc ()) !funcs
751 let update = Glut.postRedisplay
752 let func = Glut.idleFunc
753 let run = Glut.mainLoop
756 module type BarInfo
=
762 val getl
: stats
-> ((float * float * float) * float) list
765 module Bar
(I
: BarInfo
) =
768 let dontdraw = ref false
770 let xoffset = ref I.x
771 let xratio = float I.x
/. float !Args.w
772 let wratio = float I.w /. float !Args.w
773 let load = ref zero_stat
774 let nrcpuscale = 1.0 /. float NP.nprocs
776 let strw = Glut.bitmapLength ~
font ~str
:"55.55"
778 let base = GlList.gen_lists ~len
:1 in
779 GlList.nth
base ~
pos:0
785 GlDraw.viewport
!xoffset (I.y
+ 15) !w hh;
787 GlMat.load_identity
();
788 GlMat.translate ~x
:~
-.1.0 ~y
:~
-.1.0 ();
789 GlMat.scale ~y
:(2.0 /. (float hh)) ~x
:1.0 ();
792 let barh = float (hh - (!Args.bars - 1) * seph) /. float !Args.bars in
793 let barh = ceil
barh |> truncate
in
799 let yt = yb
+ seph in
800 let yn = yt + barh in
803 GlDraw.vertex2
(0.0, yb);
804 GlDraw.vertex2
(0.0, yt);
805 GlDraw.vertex2
(2.0, yt);
806 GlDraw.vertex2
(2.0, yb);
809 GlDraw.color
(0.0, 0.0, 0.0);
810 GlDraw.begins `quads
;
820 w := float w'
*. wratio |> truncate
;
821 xoffset := float w'
*. xratio |> truncate
;
830 GlList.begins
sepsl `compile
;
834 !h < 20 || !w < 20 || !xoffset < 0
839 let load = scale_stat !load nrcpuscale in
840 let load_all = min
(1.0 -. load.all
) 1.0 |> max
0.0 in
841 let () = GlMat.push
() in
843 GlDraw.viewport
!xoffset (I.y
+ 2) !w !h;
844 GlDraw.color
(1.0, 1.0, 1.0);
845 let load_all = 100.0 *. load_all in
846 let str = sprintf
"%5.2f" load_all in
848 GlMat.load_identity
();
852 Glut.bitmapLength ~
font ~
str:str
856 let x = -. (float strw /. float !w) in
857 GlMat.translate ~y
:~
-.1.0 ~
x ();
859 let () = draw_string 0.0 0.0 str in
862 GlDraw.viewport
!xoffset (I.y
+ 15) !w (!h - 26);
863 GlMat.load_identity
();
864 GlMat.translate ~
x:~
-.1. ~y
:~
-.1.();
866 GlDraw.begins `quads
;
867 GlDraw.vertex2
(0.0, yb);
868 GlDraw.vertex2
(0.0, yt);
869 GlDraw.vertex2
(2.0, yt);
870 GlDraw.vertex2
(2.0, yb);
873 let fold yb (color
, load) =
876 let () = GlDraw.color color
in
877 let yt = yb +. 2.0*.load in
878 let () = drawquad yb yt in
883 let cl = I.getl
load in
884 let yb = List.fold_left
fold 0.0 cl in
885 let () = GlDraw.color
(0.5, 0.5, 0.5) in
886 let () = drawquad yb 2.0 in
887 let () = GlList.call
sepsl in
901 let update delta'
load'
=
902 let delta = 1.0 /. delta'
in
903 load := scale_stat load'
delta;
907 module Graph
(V
: View
) =
909 let ox = if !Args.scalebar then 0 else !Args.barw
910 let sw = float V.w /. float (!Args.w - ox)
911 let sh = float V.h /. float !Args.h
912 let sx = float (V.x - ox) /. float V.w
913 let sy = float V.y
/. float V.h
918 let scale = V.freq /. V.interval
919 let gscale = 1.0 /. float V.sgrid
921 let dontdraw = ref false
926 3 * Glut.bitmapWidth
font (Char.code '
%'
), 20
932 let base = GlList.gen_lists ~len
:1 in
933 GlList.nth
base ~
pos:0
936 let getviewport typ
=
937 let ox = if !Args.scalebar then 0 else !Args.barw in
939 | `
labels -> (!vx + ox, !vy + 5, fw, !vh - fh)
940 | `graph
-> (!vx + fw + 5 + ox, !vy + 5, !vw - fw - 10, !vh - fh)
944 let x, y
, w, h = getviewport typ
in
945 GlDraw.viewport x y
w h;
951 let x = if i = 0 then 0.0009 else float i *. gscale in
952 GlDraw.vertex ~
x ~y
:0.0 ();
953 GlDraw.vertex ~
x ~y
:1.0 ();
959 GlDraw.line_width
1.0;
960 GlDraw.color
(0.0, !Args.grid_green, 0.0);
961 GlDraw.begins `lines
;
965 GlDraw.vertex2
(0.0009, 0.0);
966 GlDraw.vertex2
(0.0009, 1.0);
967 GlDraw.vertex2
(1.0000, 0.0);
968 GlDraw.vertex2
(1.0000, 1.0);
974 let lim = 100 / V.pgrid in
977 let y = (i * V.pgrid |> float) /. 100.0 in
978 let y = if i = lim then y -. 0.0009 else y in
979 GlDraw.vertex ~
x:0.0 ~
y ();
980 GlDraw.vertex ~
x:1.0 ~
y ();
983 let () = GlDraw.ends
() in
988 GlDraw.color
(1.0, 1.0, 1.0);
990 for i = 0 to 100 / V.pgrid
992 let p = i * V.pgrid in
993 let y = float p /. ohp in
994 let s = sprintf
"%3d%%" p in
1001 let wxsw = float (w - ox) *. sw
1002 and hxsh
= float h *. sh in
1003 vw := wxsw |> truncate
;
1004 vh := hxsh
|> truncate
;
1005 vx := wxsw *. sx |> truncate
;
1006 vy := hxsh
*. sy |> truncate
;
1009 let x0, y0
, w0
, h0
= getviewport `
labels in
1010 let x1, y1
, w1
, h1
= getviewport `graph
in
1011 (!Args.labels && (w0
< 20 || h0
< 20 || x0 < 0 || y0
< 0))
1012 || (w1
< 20 || h1
< 20 || x1 < 0 || y1
< 0)
1018 GlList.begins
gridlist `compile
;
1025 Glut.swapBuffers
|> oohz !Args.delay;
1028 let inc () = incr
nsamples
1031 GlDraw.line_width
1.0;
1032 GlDraw.color
(0.0, !Args.grid_green, 0.0);
1033 GlDraw.begins `lines
;
1035 ((pred
!nsamples |> float) *. scale /. gscale |> modf
|> fst
) *. gscale
1037 for i = 0 to pred
V.sgrid
1039 let x = offset +. float i *. gscale in
1040 GlDraw.vertex ~
x ~
y:0.0 ();
1041 GlDraw.vertex ~
x ~
y:1.0 ();
1046 let display_aux () =
1047 GlList.call
gridlist;
1049 if !Args.mgrid then mgrid ();
1050 GlDraw.line_width
2.0;
1051 let sample sampler
=
1052 GlDraw.color sampler
.color
;
1055 then GlDraw.begins `line_strip
1058 GlDraw.begins `polygon
;
1059 GlDraw.vertex2
(0.0, 0.0);
1062 let yield = sampler
.getyielder () in
1063 let rec loop last
i =
1066 let x = scale *. float i in
1067 GlDraw.vertex ~
x ~
y ();
1076 let x = scale *. float (pred
i) in
1077 GlDraw.vertex ~
x ~
y:0.0 ()
1082 List.iter
sample V.samplers
;
1094 let funcs = display, reshape, inc
1097 let getplacements w h n barw =
1098 let sr = float n |> sqrt
|> ceil
|> truncate
in
1100 let r = if n mod sr = 0 then 0 else 1 in
1108 let w'
= w - barw in
1112 let rec loop accu i =
1119 let xc = xc * vw + barw in
1121 (i, xc, yc) :: accu |> loop |< succ
i
1129 let freq = !Args.freq
1130 let nsamples = !Args.interval /. freq |> ceil
|> truncate
1133 let placements, vw, vh = getplacements w h NP.nprocs !Args.barw in
1136 if !Args.isampler then NP.idletimeofday fd
NP.nprocs else [||]
1141 let gks = NP.parse_stat () in
1142 gks () |> Array.of_list
1146 let crgraph (kaccu
, iaccu
, gaccu
) (i, x, y) =
1147 let module Si
= Sampler
(S
) in
1149 { getyielder = Si.getyielder
1150 ; color
= (1.0, 1.0, 0.0)
1151 ; update = Si.update
1154 let module Sk
= Sampler
(S
) in
1156 { getyielder = Sk.getyielder
1157 ; color
= (1.0, 0.0, 0.0)
1158 ; update = Sk.update
1161 let module V
= struct
1167 let interval = !Args.interval
1168 let pgrid = !Args.pgrid
1169 let sgrid = !Args.sgrid
1173 isampler :: (if !Args.ksampler then [ksampler] else [])
1175 if !Args.ksampler then [ksampler] else []
1178 let module Graph
= Graph
(V
) in
1186 let f d'
= d := d'
in
1187 let () = Gzh.gen f in
1191 all
= d; iowait = d; user = 1.0 -. d; idle = d }
1195 let (u1
, i1
) = NP.parse_uptime () in
1199 let (u2
, i2
) = NP.parse_uptime () in
1201 and di
= i2
-. !i1
in
1206 all
= d; iowait = d; user = 1.0 -. d; idle = d }
1208 let i'
= if i = NP.nprocs then 0 else succ
i in
1209 let g ks n = Array.get
ks i'
|> snd
|> Array.get
|< n in
1211 let user = g ks NP.user
1212 and nice = g ks NP.nice
1213 and sys = g ks NP.sys
1214 and idle = g ks NP.idle
1215 and iowait = g ks NP.idle
1216 and intr = g ks NP.intr
1217 and softirq = g ks NP.softirq in
1222 "user=%f nice=%f sys=%f iowait=%f intr=%f softirq=%f@."
1241 let i1 = ref (gall ks) in
1244 let diff = add_stat i2 (neg_stat !i1) in
1248 (i, calc, ksampler) :: kaccu
1256 let i1 = Array.get
is i |> ref in
1258 let i2 = Array.get
is i in
1259 if classify_float
i2 = FP_infinite
1261 { zero_stat with all
= t2
-. t1 }
1265 { zero_stat with all
= i2 -. i1'
}
1267 (i, calc, isampler) :: iaccu
1271 kaccu, iaccu, Graph.funcs :: gaccu
1273 let kl, il
, gl
= List.fold_left
crgraph ([], [], []) placements in
1274 ((if kl == [] then (fun () -> [||]) else kget), kl), (iget, il
), gl
1280 (* gross hack but we are not particularly picky today *)
1284 if (Unix.stat path
).Unix.st_kind
!= Unix.S_CHR
1287 eprintf
"File %S is not an ITC device@." path
;
1291 Unix.openfile path
[Unix.O_RDONLY
] 0
1293 | Unix.Unix_error
((Unix.ENODEV
| Unix.ENXIO
) as err
, s1
, s2
) ->
1294 eprintf
"Could not open ITC device %S:\n%s(%s): %s@."
1295 path s1 s2
|< Unix.error_message err
;
1296 eprintf
"(perhaps the module is not loaded?)@.";
1299 | Unix.Unix_error
(Unix.EALREADY
, s1
, s2
) ->
1300 eprintf
"Could not open ITC device %S:\n%s(%s): %s@."
1301 path s1 s2
|< Unix.error_message
Unix.EALREADY
;
1302 eprintf
"(perhaps modules is already in use?)@.";
1305 | Unix.Unix_error
(error
, s1
, s2
) ->
1306 eprintf
"Could not open ITC device %S:\n%s(%s): %s@."
1307 path s1 s2
|< Unix.error_message error
;
1311 eprintf
"Could not open ITC device %S:\n%s@."
1312 path
|< Printexc.to_string exn
;
1319 external seticon : string -> unit = "ml_seticon"
1323 let data = String.create |< 32*len + 2*4 in
1328 and a = Char.chr
a in
1329 let s = String.create len in
1336 x + 0 |> String.set
s |< b;
1337 x + 1 |> String.set
s |< g;
1338 x + 2 |> String.set
s |< r;
1339 x + 3 |> String.set
s |< a;
1345 let el = line 0x00 0x00 0x00 0xff
1346 and kl = line 0xff 0x00 0x00 0xff
1347 and il
= line 0xff 0xff 0x00 0xff in
1349 let src = l and dst
= data and src_pos
= 0 in
1350 let rec loop n dst_pos
=
1354 StringLabels.blit ~
src ~src_pos ~dst ~dst_pos ~
len;
1355 pred
n |> loop |< dst_pos
+ len
1358 (ey
- sy) |> loop |< (32 - ey
) * len + 4*2
1360 fun ~iload ~kload
->
1361 let iy = iload
*. 32.0 |> ceil
|> truncate
|> max
0 |> min
32
1362 and ky
= kload
*. 32.0 |> ceil
|> truncate
|> max
0 |> min
32 in
1366 (fill kl 0 ky
; fill il ky
iy; iy)
1374 let create_bars h kactive iactive
=
1378 let sum = kload
.user +. kload
.nice +. kload
.sys
1379 +. kload
.intr +. kload
.softirq
1381 [ (1.0, 1.0, 0.0), kload
.user
1382 ; (0.0, 0.0, 1.0), kload
.nice
1383 ; (1.0, 0.0, 0.0), kload
.sys
1384 ; (1.0, 1.0, 1.0), kload
.intr
1385 ; (0.75, 0.5, 0.5), (1.0 -. kload
.iowait) -. sum
1386 ; (0.0, 1.0, 0.0), kload
.all
-. kload
.iowait -. kload
.softirq
1389 [ (1.0, 0.0, 0.0), 1.0 -. kload
.idle ]
1392 [ (1.0, 1.0, 0.0), 1.0 -. iload
.all
]
1394 let barw = !Args.barw in
1396 (fun () -> ()), (fun _ _ -> ()), (fun _ _ -> ())
1405 let w = (if iactive
then barw / 2 else barw) - 3
1410 Bar.display, Bar.reshape, Bar.update
1419 let x = (if kactive
then barw / 2 else 0) + 3
1421 let w = (if kactive
then barw / 2 else barw) - 3
1426 Bar.display, Bar.reshape, Bar.update
1435 let d () = kd (); id () in
1436 let r w h = kr
w h; ir
w h in
1437 let u d k i = ku
d k; iu
d i in
1440 kd, kr
, (fun d k _ -> ku
d k)
1446 id, ir
, (fun d _ i -> iu
d i)
1448 (fun () -> ()), (fun _ _ -> ()), (fun _ _ _ -> ())
1453 let _ = Glut.init [|""|] in
1454 let () = Args.init () in
1458 "detected " ^ string_of_int
NP.nprocs ^
" CPUs" |> print_endline
1460 let () = if !Args.gzh then Gzh.init !Args.verbose else () in
1461 let () = Delay.init !Args.timer !Args.gzh in
1462 let () = if !Args.niceval != 0 then NP.setnice
!Args.niceval else () in
1465 let fd = opendev !Args.devpath in
1466 let module FullV
= View
(struct let w = w let h = h end) in
1467 let winid = FullV.init () in
1468 let () = NP.fixwindow
winid in
1469 let (kget, kfuncs
), (iget, ifuncs
), gl
= create fd w h in
1471 List.iter
FullV.add gl
;
1474 let (display, reshape, update) =
1475 create_bars h !Args.ksampler !Args.isampler
1477 FullV.add (display, reshape, fun _ -> ());
1482 let seticon = if !Args.icon then seticon () else fun ~iload ~kload
-> () in
1483 let rec loop t1 () =
1484 let t2 = Unix.gettimeofday
() in
1485 let dt = t2 -. t1 in
1490 let rec loop2 load sample = function
1492 | (nr
, calc, sampler
) :: rest
->
1493 let cpuload = calc sample t1 t2 in
1495 let thisload = 1.0 -. (cpuload.all
/. dt) in
1496 let thisload = max
0.0 thisload in
1499 ("cpu load(" ^ string_of_int nr ^
"): "
1500 ^
(thisload *. 100.0 |> string_of_float
)
1503 let load = add_stat load cpuload in
1504 sampler
.update dt cpuload.all
;
1505 loop2 load sample rest
1507 let iload = loop2 zero_stat is ifuncs
in
1508 let kload = loop2 zero_stat ks kfuncs
in
1512 iload.all
|> string_of_float
|> prerr_endline
;
1513 kload.all
|> string_of_float
|> prerr_endline
;
1516 seticon ~
iload:iload.all ~
kload:kload.all
;
1517 bar_update dt kload iload;
1520 FullV.func (Some
(loop t2))
1524 FullV.func (Some
(Unix.gettimeofday
() |> loop));
1532 | Unix.Unix_error
(e
, s1
, s2
) ->
1533 Unix.error_message e
|> eprintf
"main failure: %s(%s): %s@." s1 s2
1536 Printexc.to_string exn
|> eprintf
"main failure: %s@."