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"
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
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
133 let nprocs = get_nprocs
()
135 let rec parse_int_cont s pos
=
136 let jiffies_to_sec j
=
139 let slen = String.length s
in
147 if String.get s
pos = ' '
156 try String.index_from s
pos ' '
157 with Not_found
-> slen
159 let i = endpos - pos |> String.sub s
pos
166 `more
(i, fun () -> succ
endpos |> parse_int_cont 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
180 0.0 :: 0.0 :: 0.0 :: 0.0 :: vals
184 cpuname, Array.of_list
vals
191 let iukw = windows_processor_times
nprocs in
192 let rec create n ai ak au ad ar accu
=
195 ("cpu", [| au
; ad
; ak
; ai
; 0.0; ar
; 0.0 |]) :: List.rev accu
197 let hdr = "cpu" ^ string_of_int n
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
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 []
217 let ic = open_in
"/proc/stat" in
218 let rec loop i accu =
223 (input_line
ic |> parse_cpul) :: accu |> loop (pred
i)
225 let ret = loop nprocs [] in
232 let iukw = solaris_kstat
nprocs in
233 let rec create n
ai au ak aw
accu =
236 ("cpu", [| au; 0.0; ak; ai; aw
; 0.0; 0.0 |]) :: List.rev
accu
238 let hdr = "cpu" ^ string_of_int n
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
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 []
256 let iukn = macosx_host_processor_info
nprocs in
257 let rec create c
ai au ak an
accu =
260 ("cpu", [| au; an
; ak; ai; 0.0; 0.0; 0.0 |]) :: List.rev
accu
262 let hdr = "cpu" ^ string_of_int c
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
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 []
281 Filename.dirname
|< Unix.readlink
"/proc/self/exe"
290 [ "Amazing Piece of Code by insanely gifted programmer, Version 1.00b"
291 ; "Motivation by: gzh and afs"
293 ] |> String.concat
"\n"
296 let interval = ref 15.0
297 let devpath = NP.getselfdir () |> Filename.concat
|< "itc" |> ref
302 let verbose = ref false
304 let ksampler = ref true
305 let isampler = ref true
308 let sigway = ref (NP.os_type != NP.MacOSX
)
311 let scalebar = ref false
313 let debug = ref false
315 let uptime = ref false
317 let labels = ref true
318 let mgrid = ref false
319 let sepstat = ref true
322 let l = String.length s
in
327 let d = String.make
n ' '
in
328 StringLabels.blit ~src
:s ~dst
:d
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"
339 let dI = dA string_of_int
340 let dS = dA (fun s
-> "`" ^
String.escaped s ^
"'")
343 "-" ^ opt
, Arg.Set_float
r, pad 9 "<float> " ^ doc
|> dF |< r
347 "-" ^ opt
, Arg.Set_int
r, pad 9 "<int> " ^ doc
|> dI |< r
351 "-" ^ opt
, Arg.Set
r, pad 9 "" ^ doc
|> dB |< r
355 "-" ^ opt
, Arg.Set_string
r, pad 9 "<string> " ^ doc
|> dS |< r
361 "-" ^ opt
, Arg.Clear
r, pad 9 "" ^ doc
|> dB |< r
363 "-" ^ opt
, Arg.Set
r, pad 9 "" ^ doc
|> dcB |< r
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"
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"
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")
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"
399 let add_solaris opts
=
401 fB "I" icon "icon (hack)"
404 let add_windows opts
=
406 (fB "k" ksampler |< "kernel sampler (ZwQuerySystemInformation)")
407 :: (fB "M" isampler |< "idle sampler (PMC based)")
410 let add_macosx opts
=
412 fB "g" gzh "gzh way (does not quite work yet)"
415 match NP.os_type with
416 | NP.Linux
-> add_linux tail
417 | NP.Windows
-> add_windows tail
418 | NP.Solaris
-> add_solaris tail
419 | NP.MacOSX
-> add_macosx tail
423 let opts = add_opts commonopts in
427 ("Invocation error: Don't know what to do with " ^ s
));
431 let cp {contents
=v
} s
=
433 then (prerr_string s
; prerr_endline
" must be positive"; exit
1)
435 let cpf {contents
=v
} s
=
437 then (prerr_string s
; prerr_endline
" must be positive"; exit
1)
441 cp pgrid "Number of percent grid items";
442 cp sgrid "Number of history grid items";
443 cp bars "Number of CPU bars";
444 cp timer "Timer frequency";
445 cpf freq "Frequency";
447 cpf interval "Interval";
448 if not
(!isampler || !ksampler)
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) =
686 let keyboard ~key ~x ~y
=
687 if key
= 27 || key
= Char.code 'q'
693 funcs := dri
:: !funcs
697 GlClear.clear
[`color
];
698 List.iter
(fun (display, _, _) -> display ()) !funcs;
705 List.iter
(fun (_, reshape, _) -> reshape w h) !funcs;
706 GlClear.clear
[`color
];
707 GlMat.mode `modelview
;
708 GlMat.load_identity
();
709 GlMat.mode `projection
;
710 GlMat.load_identity
();
711 GlMat.rotate ~y
:1.0 ~angle
:180.0 ();
712 GlMat.translate ~x
:~
-.1.0 ~y
:~
-.1.0 ();
713 GlMat.scale ~x
:2.0 ~y
:2.0 ();
714 Glut.postRedisplay
();
719 Glut.initDisplayMode ~double_buffer
:true ();
720 Glut.initWindowSize
V.w V.h
722 let winid = Glut.createWindow
"APC" in
723 Glut.displayFunc
display;
724 Glut.reshapeFunc
reshape;
725 Glut.keyboardFunc
keyboard;
726 GlDraw.color
(1.0, 1.0, 0.0);
730 let inc () = List.iter
(fun (_, _, inc) -> inc ()) !funcs
731 let update = Glut.postRedisplay
732 let func = Glut.idleFunc
733 let run = Glut.mainLoop
736 module type BarInfo
=
742 val getl
: stats
-> ((float * float * float) * float) list
745 module Bar
(I
: BarInfo
) =
749 let wratio = float I.w /. float !Args.w
750 let load = ref zero_stat
751 let nrcpuscale = 1.0 /. float NP.nprocs
753 let strw = Glut.bitmapLength ~
font ~str
:"55.55"
755 let base = GlList.gen_lists ~len
:1 in
756 GlList.nth
base ~
pos:0
762 GlDraw.viewport
I.x
(I.y
+ 15) !w hh;
764 GlMat.load_identity
();
765 GlMat.translate ~x
:~
-.1.0 ~y
:~
-.1.0 ();
766 GlMat.scale ~y
:(2.0 /. (float hh)) ~x
:1.0 ();
769 let barh = float (hh - (!Args.bars - 1) * seph) /. float !Args.bars in
770 let barh = ceil
barh |> truncate
in
776 let yt = yb
+ seph in
777 let yn = yt + barh in
780 GlDraw.vertex2
(0.0, yb);
781 GlDraw.vertex2
(0.0, yt);
782 GlDraw.vertex2
(2.0, yt);
783 GlDraw.vertex2
(2.0, yb);
786 GlDraw.color
(0.0, 0.0, 0.0);
787 GlDraw.begins `quads
;
797 (float w'
*. wratio |> truncate
)
802 GlList.begins
sepsl `compile
;
808 let load = scale_stat !load nrcpuscale in
809 let load_all = min
(1.0 -. load.all
) 1.0 |> max
0.0 in
810 let () = GlMat.push
() in
812 GlDraw.viewport
I.x
(I.y
+ 2) !w !h;
813 GlDraw.color
(1.0, 1.0, 1.0);
814 let load_all = 100.0 *. load_all in
815 let str = sprintf
"%5.2f" load_all in
817 GlMat.load_identity
();
821 Glut.bitmapLength ~
font ~
str:str
825 let x = -. (float strw /. float !w) in
826 GlMat.translate ~y
:~
-.1.0 ~
x ();
828 let () = draw_string 0.0 0.0 str in
831 GlDraw.viewport
I.x (I.y
+ 15) !w (!h - 26);
832 GlMat.load_identity
();
833 GlMat.translate ~
x:~
-.1. ~y
:~
-.1.();
835 GlDraw.begins `quads
;
836 GlDraw.vertex2
(0.0, yb);
837 GlDraw.vertex2
(0.0, yt);
838 GlDraw.vertex2
(2.0, yt);
839 GlDraw.vertex2
(2.0, yb);
842 let fold yb (color
, load) =
845 let () = GlDraw.color color
in
846 let yt = yb +. 2.0*.load in
847 let () = drawquad yb yt in
852 let cl = I.getl
load in
853 let yb = List.fold_left
fold 0.0 cl in
854 let () = GlDraw.color
(0.5, 0.5, 0.5) in
855 let () = drawquad yb 2.0 in
856 let () = GlList.call
sepsl in
861 let update delta'
load'
=
862 let delta = 1.0 /. delta'
in
863 load := scale_stat load'
delta;
867 module Graph
(V
: View
) =
869 let ox = if !Args.scalebar then 0 else !Args.barw
870 let sw = float V.w /. float (!Args.w - ox)
871 let sh = float V.h /. float !Args.h
872 let sx = float (V.x - ox) /. float V.w
873 let sy = float V.y
/. float V.h
878 let scale = V.freq /. V.interval
879 let gscale = 1.0 /. float V.sgrid
885 3 * Glut.bitmapWidth
font (Char.code '
%'
), 20
891 let base = GlList.gen_lists ~len
:1 in
892 GlList.nth
base ~
pos:0
895 let ox = if !Args.scalebar then 0 else !Args.barw in
898 | `
labels -> (!vx + ox, !vy + 5, fw, !vh - fh)
899 | `graph
-> (!vx + fw + 5 + ox, !vy + 5, !vw - fw - 10, !vh - fh)
901 GlDraw.viewport x y
w h;
907 let x = if i = 0 then 0.0009 else float i *. gscale in
908 GlDraw.vertex ~
x ~y
:0.0 ();
909 GlDraw.vertex ~
x ~y
:1.0 ();
915 GlDraw.line_width
1.0;
916 GlDraw.color
(0.0, 1.0, 0.0);
917 GlDraw.begins `lines
;
921 GlDraw.vertex2
(0.0009, 0.0);
922 GlDraw.vertex2
(0.0009, 1.0);
923 GlDraw.vertex2
(1.0000, 0.0);
924 GlDraw.vertex2
(1.0000, 1.0);
930 let lim = 100 / V.pgrid in
933 let y = (i * V.pgrid |> float) /. 100.0 in
934 let y = if i = lim then y -. 0.0009 else y in
935 GlDraw.vertex ~
x:0.0 ~
y ();
936 GlDraw.vertex ~
x:1.0 ~
y ();
939 let () = GlDraw.ends
() in
944 GlDraw.color
(1.0, 1.0, 1.0);
946 for i = 0 to 100 / V.pgrid
948 let p = i * V.pgrid in
949 let y = float p /. ohp in
950 let s = Printf.sprintf
"%3d%%" p in
957 let wxsw = float (w - ox) *. sw
958 and hxsh
= float h *. sh in
959 vw := wxsw |> truncate
;
960 vh := hxsh
|> truncate
;
961 vx := wxsw *. sx |> truncate
;
962 vy := hxsh
*. sy |> truncate
;
963 GlList.begins
gridlist `compile
;
969 Glut.swapBuffers
|> oohz !Args.delay;
972 let inc () = incr
nsamples
975 GlDraw.line_width
1.0;
976 GlDraw.color
(0.0, 1.0, 0.0);
977 GlDraw.begins `lines
;
979 ((pred
!nsamples |> float) *. scale /. gscale |> modf
|> fst
) *. gscale
981 for i = 0 to pred
V.sgrid
983 let x = offset +. float i *. gscale in
984 GlDraw.vertex ~
x ~
y:0.0 ();
985 GlDraw.vertex ~
x ~
y:1.0 ();
991 GlList.call
gridlist;
993 if !Args.mgrid then mgrid ();
994 GlDraw.line_width
2.0;
996 GlDraw.color sampler
.color
;
999 then GlDraw.begins `line_strip
1002 GlDraw.begins `polygon
;
1003 GlDraw.vertex2
(0.0, 0.0);
1006 let yield = sampler
.getyielder () in
1007 let rec loop last
i =
1010 let x = scale *. float i in
1011 GlDraw.vertex ~
x ~
y ();
1020 let x = scale *. float (pred
i) in
1021 GlDraw.vertex ~
x ~
y:0.0 ()
1026 List.iter
sample V.samplers
;
1029 let funcs = display, reshape, inc
1032 let getplacements w h n barw =
1033 let sr = float n |> sqrt
|> ceil
|> truncate
in
1035 let r = if n mod sr = 0 then 0 else 1 in
1043 let w'
= w - barw in
1047 let rec loop accu i =
1054 let xc = xc * vw + barw in
1056 (i, xc, yc) :: accu |> loop |< succ
i
1064 let freq = !Args.freq
1065 let nsamples = !Args.interval /. freq |> ceil
|> truncate
1068 let placements, vw, vh = getplacements w h NP.nprocs !Args.barw in
1071 if !Args.isampler then NP.idletimeofday fd
NP.nprocs else [||]
1076 let gks = NP.parse_stat () in
1077 gks () |> Array.of_list
1081 let crgraph (kaccu
, iaccu
, gaccu
) (i, x, y) =
1082 let module Si
= Sampler
(S
) in
1084 { getyielder = Si.getyielder
1085 ; color
= (1.0, 1.0, 0.0)
1086 ; update = Si.update
1089 let module Sk
= Sampler
(S
) in
1091 { getyielder = Sk.getyielder
1092 ; color
= (1.0, 0.0, 0.0)
1093 ; update = Sk.update
1096 let module V
= struct
1102 let interval = !Args.interval
1103 let pgrid = !Args.pgrid
1104 let sgrid = !Args.sgrid
1108 isampler :: (if !Args.ksampler then [ksampler] else [])
1110 if !Args.ksampler then [ksampler] else []
1113 let module Graph
= Graph
(V
) in
1121 let f d'
= d := d'
in
1122 let () = Gzh.gen f in
1126 all
= d; iowait = d; user = 1.0 -. d; idle = d }
1130 let (u1
, i1
) = NP.parse_uptime () in
1134 let (u2
, i2
) = NP.parse_uptime () in
1136 and di
= i2
-. !i1
in
1141 all
= d; iowait = d; user = 1.0 -. d; idle = d }
1143 let i'
= if i = NP.nprocs then 0 else succ
i in
1144 let g ks n = Array.get
ks i'
|> snd
|> Array.get
|< n in
1146 let user = g ks NP.user
1147 and nice = g ks NP.nice
1148 and sys = g ks NP.sys
1149 and idle = g ks NP.idle
1150 and iowait = g ks NP.idle
1151 and intr = g ks NP.intr
1152 and softirq = g ks NP.softirq in
1157 "user=%f nice=%f sys=%f iowait=%f intr=%f softirq=%f@."
1176 let i1 = ref (gall ks) in
1179 let diff = add_stat i2 (neg_stat !i1) in
1183 (i, calc, ksampler) :: kaccu
1191 let i1 = Array.get
is i |> ref in
1193 let i2 = Array.get
is i in
1194 if classify_float
i2 = FP_infinite
1196 { zero_stat with all
= t2
-. t1 }
1200 { zero_stat with all
= i2 -. i1'
}
1202 (i, calc, isampler) :: iaccu
1206 kaccu, iaccu, Graph.funcs :: gaccu
1208 let kl, il
, gl
= List.fold_left
crgraph ([], [], []) placements in
1209 ((if kl == [] then (fun () -> [||]) else kget), kl), (iget, il
), gl
1215 (* gross hack but we are not particularly picky today *)
1219 if (Unix.stat path
).Unix.st_kind
!= Unix.S_CHR
1222 eprintf
"File %S is not an ITC device@." path
;
1226 Unix.openfile path
[Unix.O_RDONLY
] 0
1228 | Unix.Unix_error
((Unix.ENODEV
| Unix.ENXIO
) as err
, s1
, s2
) ->
1229 eprintf
"Could not open ITC device %S:\n%s(%s): %s@."
1230 path s1 s2
|< Unix.error_message err
;
1231 eprintf
"(perhaps the module is not loaded?)@.";
1234 | Unix.Unix_error
(Unix.EALREADY
, s1
, s2
) ->
1235 eprintf
"Could not open ITC device %S:\n%s(%s): %s@."
1236 path s1 s2
|< Unix.error_message
Unix.EALREADY
;
1237 eprintf
"(perhaps modules is already in use?)@.";
1240 | Unix.Unix_error
(error
, s1
, s2
) ->
1241 eprintf
"Could not open ITC device %S:\n%s(%s): %s@."
1242 path s1 s2
|< Unix.error_message error
;
1246 eprintf
"Could not open ITC device %S:\n%s@."
1247 path
|< Printexc.to_string exn
;
1254 external seticon : string -> unit = "ml_seticon"
1258 let data = String.create |< 32*len + 2*4 in
1263 and a = Char.chr
a in
1264 let s = String.create len in
1271 x + 0 |> String.set
s |< b;
1272 x + 1 |> String.set
s |< g;
1273 x + 2 |> String.set
s |< r;
1274 x + 3 |> String.set
s |< a;
1280 let el = line 0x00 0x00 0x00 0xff
1281 and kl = line 0xff 0x00 0x00 0xff
1282 and il
= line 0xff 0xff 0x00 0xff in
1284 let src = l and dst
= data and src_pos
= 0 in
1285 let rec loop n dst_pos
=
1289 StringLabels.blit ~
src ~src_pos ~dst ~dst_pos ~
len;
1290 pred
n |> loop |< dst_pos
+ len
1293 (ey
- sy) |> loop |< (32 - ey
) * len + 4*2
1295 fun ~iload ~kload
->
1296 let iy = iload
*. 32.0 |> ceil
|> truncate
|> max
0 |> min
32
1297 and ky
= kload
*. 32.0 |> ceil
|> truncate
|> max
0 |> min
32 in
1301 (fill kl 0 ky
; fill il ky
iy; iy)
1309 let create_bars h kactive iactive
=
1313 let sum = kload
.user +. kload
.nice +. kload
.sys
1314 +. kload
.intr +. kload
.softirq
1316 [ (1.0, 1.0, 0.0), kload
.user
1317 ; (0.0, 0.0, 1.0), kload
.nice
1318 ; (1.0, 0.0, 0.0), kload
.sys
1319 ; (1.0, 1.0, 1.0), kload
.intr
1320 ; (0.75, 0.5, 0.5), (1.0 -. kload
.iowait) -. sum
1321 ; (0.0, 1.0, 0.0), kload
.all
-. kload
.iowait -. kload
.softirq
1324 [ (1.0, 0.0, 0.0), 1.0 -. kload
.idle ]
1327 [ (1.0, 1.0, 0.0), 1.0 -. iload
.all
]
1329 let barw = !Args.barw in
1331 (fun () -> ()), (fun _ _ -> ()), (fun _ _ -> ())
1340 let w = (if iactive
then barw / 2 else barw) - 3
1345 Bar.display, Bar.reshape, Bar.update
1354 let x = (if kactive
then barw / 2 else 0) + 3
1356 let w = (if kactive
then barw / 2 else barw) - 3
1361 Bar.display, Bar.reshape, Bar.update
1370 let d () = kd (); id () in
1371 let r w h = kr
w h; ir
w h in
1372 let u d k i = ku
d k; iu
d i in
1375 kd, kr
, (fun d k _ -> ku
d k)
1381 id, ir
, (fun d _ i -> iu
d i)
1383 (fun () -> ()), (fun _ _ -> ()), (fun _ _ _ -> ())
1388 let _ = Glut.init [|""|] in
1389 let () = Args.init () in
1393 "detected " ^ string_of_int
NP.nprocs ^
" CPUs" |> print_endline
1395 let () = if !Args.gzh then Gzh.init !Args.verbose else () in
1396 let () = Delay.init !Args.timer !Args.gzh in
1397 let () = if !Args.niceval != 0 then NP.setnice
!Args.niceval else () in
1400 let fd = opendev !Args.devpath in
1401 let module FullV
= View
(struct let w = w let h = h end) in
1402 let _winid = FullV.init () in
1403 let (kget, kfuncs
), (iget, ifuncs
), gl
= create fd w h in
1405 List.iter
FullV.add gl
;
1408 let (display, reshape, update) =
1409 create_bars h !Args.ksampler !Args.isampler
1411 FullV.add (display, reshape, fun _ -> ());
1416 let seticon = if !Args.icon then seticon () else fun ~iload ~kload
-> () in
1417 let rec loop t1 () =
1418 let t2 = Unix.gettimeofday
() in
1419 let dt = t2 -. t1 in
1424 let rec loop2 load sample = function
1426 | (nr
, calc, sampler
) :: rest
->
1427 let cpuload = calc sample t1 t2 in
1429 let thisload = 1.0 -. (cpuload.all
/. dt) in
1430 let thisload = max
0.0 thisload in
1433 ("cpu load(" ^ string_of_int nr ^
"): "
1434 ^
(thisload *. 100.0 |> string_of_float
)
1437 let load = add_stat load cpuload in
1438 sampler
.update dt cpuload.all
;
1439 loop2 load sample rest
1441 let iload = loop2 zero_stat is ifuncs
in
1442 let kload = loop2 zero_stat ks kfuncs
in
1446 iload.all
|> string_of_float
|> prerr_endline
;
1447 kload.all
|> string_of_float
|> prerr_endline
;
1450 seticon ~
iload:iload.all ~
kload:kload.all
;
1451 bar_update dt kload iload;
1454 FullV.func (Some
(loop t2))
1458 FullV.func (Some
(Unix.gettimeofday
() |> loop));
1466 | Unix.Unix_error
(e
, s1
, s2
) ->
1467 Unix.error_message e
|> eprintf
"main failure: %s(%s): %s@." s1 s2
1470 Printexc.to_string exn
|> eprintf
"main failure: %s@."