From e05782ada091f43d0ed2f16e5730111d24938ad1 Mon Sep 17 00:00:00 2001 From: malc Date: Sun, 8 Jul 2007 17:40:23 +0400 Subject: [PATCH] v0.99 --- Changes | 11 + FILES | 7 +- OMakefile | 15 +- README.macosx | 4 + README.solaris | 3 + README.windows | 4 + Thanks | 2 + apc.ml | 869 ++++++++++++++++++++++++++++++++++++--------------------- build.linux | 11 + build.macosx | 9 + build.solaris | 9 + hog.c | 42 ++- ml_apc.c | 538 +++++++++++++++++++++++++---------- 13 files changed, 1028 insertions(+), 496 deletions(-) create mode 100644 README.macosx create mode 100644 README.solaris create mode 100644 README.windows create mode 100755 build.linux create mode 100755 build.macosx create mode 100755 build.solaris diff --git a/Changes b/Changes index 8d20fac..4bf1a0a 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,14 @@ +9 + * Do not show kernel-sampler CPU bar when not using kernel sampler + + * Reject invalid command line options + + * Properly flush stderr on error + + * Solaris support + + * Mac OS X support + 8 * Only allow one application to open and use the module at a time diff --git a/FILES b/FILES index fdb4222..062811f 100644 --- a/FILES +++ b/FILES @@ -4,9 +4,14 @@ OMakeroot mod/Makefile mod/itc-mod.c ml_apc.c -build.sh +build.linux +build.solaris +build.macosx build.bat README +README.solaris +README.macosx +README.windows Thanks FILES Changes diff --git a/OMakefile b/OMakefile index 02668c5..b06eacf 100644 --- a/OMakefile +++ b/OMakefile @@ -1,10 +1,14 @@ -version = 0.98b +version = 0.99 -.PHONY: all clean dist mod +.PHONY: all clean dist mod opt .DEFAULT: all +clibs = + if $(equal $(shell uname), SunOS) + value -cclib -lkstat + +Mocamlcc (ml_apc, -Wall -Werror -g -I/usr/X11R6/include) Mocamlc (apc, -warn-error A -g -thread -I +lablGL) -Mocamlcc (ml_apc, -Wall -Werror -g) Mocamlopt (apc, -warn-error A -thread -I +lablGL) objs = ml_apc.o @@ -15,14 +19,14 @@ section libs = $(addsuffix .cma, $(libs)) flags = -thread -custom -I +lablGL apc.byte: $(cmos) $(objs) - ocamlc.opt $(flags) -o $@ $(libs) $(caml-sort $(cmos)) $(objs) + ocamlc.opt $(flags) -o $@ $(libs) $(caml-sort $(cmos)) $(objs) $(clibs) section cmxs = apc.cmx libs = $(addsuffix .cmxa, $(libs)) flags = -thread -I +lablGL apc.opt: $(cmxs) $(objs) apc.o - ocamlopt.opt $(flags) -o $@ $(libs) $(caml-sort $(cmxs)) $(objs) + ocamlopt.opt $(flags) -o $@ $(libs) $(caml-sort $(cmxs)) $(objs) $(clibs) mkdir -p mod add-project-directories ($(dirof OMakefile)/mod) @@ -32,6 +36,7 @@ vmount (-l, $(dirof OMakefile)/mod, mod) make all: apc.byte +opt: apc.opt apc-$(version).tgz: $(shell cat FILES) rm -fr apc-$(version) diff --git a/README.macosx b/README.macosx new file mode 100644 index 0000000..6e09a10 --- /dev/null +++ b/README.macosx @@ -0,0 +1,4 @@ +Tested on Mac OS X Tiger (PPC) +SMP - not tested +Kernel accounting appears to be rather chaotic +No kernel mode driver hence no workaround diff --git a/README.solaris b/README.solaris new file mode 100644 index 0000000..21b1d93 --- /dev/null +++ b/README.solaris @@ -0,0 +1,3 @@ +Tested on Solaris 10 (X86_64 32bit mode) +SMP - tested (AMD X2 - i.e. 2 CPUs) +Kernel accounting _appears_ to be accurate diff --git a/README.windows b/README.windows new file mode 100644 index 0000000..dadd86c --- /dev/null +++ b/README.windows @@ -0,0 +1,4 @@ +Tested on Windows XP SP2 (X86) +SMP - tested (AMD X2 - i.e. 2 CPUs) +Kernel accounting _IS_ innaccurate +No kernel mode driver hence no workaround diff --git a/Thanks b/Thanks index 6158c18..bc2cad1 100644 --- a/Thanks +++ b/Thanks @@ -5,3 +5,5 @@ Jacques Garrigue, Isaac Trotts, Erick Tryzelaar and Christophe Raffali German Zhivotnikov, Alexey Sterjantov Con Kolivas, Pavel Machek + +Casper S. Hornstrup, Juergen Rinas diff --git a/apc.ml b/apc.ml index 11257da..2c01016 100644 --- a/apc.ml +++ b/apc.ml @@ -69,7 +69,8 @@ let add_stat a b = } ;; -module NP = struct +module NP = +struct type sysinfo = { uptime: int64 ; loads: int64 * int64 * int64 @@ -83,6 +84,13 @@ module NP = struct } ;; + type os = + | Linux + | Windows + | Solaris + | MacOSX + ;; + external get_nprocs : unit -> int = "ml_get_nprocs" external idletimeofday : Unix.file_descr -> int -> float array = "ml_idletimeofday" @@ -91,9 +99,19 @@ module NP = struct external get_hz : unit -> int = "ml_get_hz" external setnice : int -> unit = "ml_nice" external delay : float -> unit = "ml_delay" - external is_winnt : unit -> bool = "ml_is_winnt" + external os_type : unit -> os = "ml_os_type" + external solaris_kstat : int -> float array = "ml_solaris_kstat" + external macosx_host_processor_info : int -> float array = + "ml_macosx_host_processor_info" + external windows_processor_times : int -> float array = + "ml_windows_processor_times" - let winnt = is_winnt () + let os_type = os_type () + + let winnt = os_type = Windows + let solaris = os_type = Solaris + let linux = os_type = Linux + let macosx = os_type = MacOSX let user = 0 let nice = 1 @@ -105,10 +123,6 @@ module NP = struct let hz = get_hz () |> float - let jiffies_to_sec j = - float j /. hz - ;; - let parse_uptime () = let ic = open_in "/proc/uptime" in let vals = Scanf.fscanf ic "%f %f" (fun u i -> (u, i)) in @@ -119,15 +133,23 @@ module NP = struct let nprocs = get_nprocs () let rec parse_int_cont s pos = + let jiffies_to_sec j = + float j /. hz + in let slen = String.length s in let pos = let rec skipws pos = if pos = slen - then pos + then + pos else - if String.get s pos = ' ' - then succ pos |> skipws - else pos + begin + if String.get s pos = ' ' + then + succ pos |> skipws + else + pos + end in skipws pos in let endpos = @@ -163,34 +185,95 @@ module NP = struct ;; let parse_stat () = - if winnt - then - fun () -> - let ia = idletimeofday Unix.stdin nprocs in - let rec convert accu total n = - if n = nprocs - then - let t = total in - let a = "cpu", Array.make 7 t in - a :: List.rev accu - else - let i = Array.get ia n in - let total = total +. i in - let v = "cpu" ^ string_of_int n, Array.make 7 i in - convert |< v :: accu |< total |< succ n - in - convert [] 0.0 0 - else - fun () -> - let ic = open_in "/proc/stat" in - let rec loop i accu = - if i = -1 - then List.rev accu - else (input_line ic |> parse_cpul) :: accu |> loop (pred i) - in - let ret = loop nprocs [] in - close_in ic; - ret + match os_type with + | Windows -> + (fun () -> + let iukw = windows_processor_times nprocs in + let rec create n ai ak au ad ar accu = + if n = nprocs + then + ("cpu", [| au; ad; ak; ai; 0.0; ar; 0.0 |]) :: List.rev accu + else + let hdr = "cpu" ^ string_of_int n in + let o = n * 5 in + let i = Array.get iukw (o + 0) in + let k = Array.get iukw (o + 1) in + let u = Array.get iukw (o + 2) in + let d = Array.get iukw (o + 3) in + let r = Array.get iukw (o + 4) in + let ai = ai +. i in + let au = au +. u in + let ak = ak +. k in + let ad = ad +. d in + let ar = ar +. r in + let accu = (hdr, [| u; d; k; i; 0.0; r; 0.0 |]) :: accu in + create (succ n) ai ak au ad ar accu + in + create 0 0.0 0.0 0.0 0.0 0.0 [] + ) + + | Linux -> + (fun () -> + let ic = open_in "/proc/stat" in + let rec loop i accu = + if i = -1 + then + List.rev accu + else + (input_line ic |> parse_cpul) :: accu |> loop (pred i) + in + let ret = loop nprocs [] in + close_in ic; + ret + ) + + | Solaris -> + (fun () -> + let iukw = solaris_kstat nprocs in + let rec create n ai au ak aw accu = + if n = nprocs + then + ("cpu", [| au; 0.0; ak; ai; aw; 0.0; 0.0 |]) :: List.rev accu + else + let hdr = "cpu" ^ string_of_int n in + let o = n * 4 in + let i = Array.get iukw (o + 0) /. hz in + let u = Array.get iukw (o + 1) /. hz in + let k = Array.get iukw (o + 2) /. hz in + let w = Array.get iukw (o + 3) /. hz in + let ai = ai +. i in + let au = au +. u in + let ak = ak +. k in + let aw = aw +. w in + let accu = (hdr, [| u; 0.0; k; i; w; 0.0; 0.0 |]) :: accu in + create (succ n) ai au ak aw accu + in + create 0 0.0 0.0 0.0 0.0 [] + ) + + | MacOSX -> + (fun () -> + let iukn = macosx_host_processor_info nprocs in + let rec create c ai au ak an accu = + if c = nprocs + then + ("cpu", [| au; an; ak; ai; 0.0; 0.0; 0.0 |]) :: List.rev accu + else + let hdr = "cpu" ^ string_of_int c in + let o = c * 4 in + let i = Array.get iukn (o + 0) /. hz in + let u = Array.get iukn (o + 1) /. hz in + let k = Array.get iukn (o + 2) /. hz in + let n = Array.get iukn (o + 3) /. hz in + let ai = ai +. i in + let au = au +. u in + let ak = ak +. k in + let an = an +. n in + let accu = (hdr, [| u; n; k; i; 0.0; 0.0; 0.0 |]) :: accu in + create (succ c) ai au ak an accu + in + create 0 0.0 0.0 0.0 0.0 [] + ) ;; let getselfdir () = @@ -201,9 +284,10 @@ module NP = struct ;; end -module Args = struct +module Args = +struct let banner = - [ "Amazing Piece of Code by insanely gifted programmer, Version 0.98b" + [ "Amazing Piece of Code by insanely gifted programmer, Version 0.99" ; "Motivation by: gzh and afs" ; "usage: " ] |> String.concat "\n" @@ -218,9 +302,10 @@ module Args = struct let verbose = ref false let delay = ref 0.04 let ksampler = ref true + let isampler = ref true let barw = ref 100 let bars = ref 50 - let sigway = ref true + let sigway = ref (NP.os_type != NP.MacOSX) let niceval = ref 0 let gzh = ref false let scalebar = ref false @@ -231,7 +316,7 @@ module Args = struct let icon = ref false let labels = ref true let mgrid = ref false - let sepstat = ref false + let sepstat = ref true let pad n s = let l = String.length s in @@ -256,15 +341,19 @@ module Args = struct let sF opt r doc = "-" ^ opt, Arg.Set_float r, pad 9 " " ^ doc |> dF |< r + ;; let sI opt r doc = "-" ^ opt, Arg.Set_int r, pad 9 " " ^ doc |> dI |< r + ;; let sB opt r doc = "-" ^ opt, Arg.Set r, pad 9 "" ^ doc |> dB |< r + ;; let sS opt r doc = "-" ^ opt, Arg.Set_string r, pad 9 " " ^ doc |> dS |< r + ;; let fB opt r doc = if r.contents @@ -272,65 +361,107 @@ module Args = struct "-" ^ opt, Arg.Clear r, pad 9 "" ^ doc |> dB |< r else "-" ^ opt, Arg.Set r, pad 9 "" ^ doc |> dcB |< r + ;; - let init () = - let opts = - [ sF "f" freq "sampling frequency in seconds" - ; sF "D" delay "refresh delay in seconds" - ; sF "i" interval "history interval in seconds" - ; sI "p" pgrid "percent grid items" - ; sI "s" sgrid "history grid items" - ; sI "w" w "width" - ; sI "h" h "height" - ; sI "b" barw "bar width" - ; sI "B" bars "number of CPU bars" - ; sI "n" niceval "value to renice self on init" - ; sI "t" timer "timer frequency in herz" - ; sS "d" devpath "path to itc device" - ; fB "k" ksampler |< "kernel sampler" - ^ (if NP.winnt then "" else " (`/proc/[stat|uptime]')") - ; fB "g" gzh "gzh way (does not quite work yet)" - ; fB "u" uptime - "`uptime' instead of `stat' as kernel sampler (UP only)" - ; sB "v" verbose "verbose" - ; fB "S" sigway "sigwait delay method" - ; fB "C" sepstat "separate sys/nice/intr/iowait values (kernel sampler)" - ; fB "c" scalebar "constant bar width" - ; fB "P" poly "filled area instead of lines" - ; fB "I" icon "icon (hack)" - ; fB "l" labels "labels" - ; fB "m" mgrid "moving grid" - ] + let commonopts = + [ sF "f" freq "sampling frequency in seconds" + ; sF "D" delay "refresh delay in seconds" + ; sF "i" interval "history interval in seconds" + ; sI "p" pgrid "percent grid items" + ; sI "s" sgrid "history grid items" + ; sI "w" w "width" + ; sI "h" h "height" + ; sI "b" barw "bar width" + ; sI "B" bars "number of CPU bars" + ; sB "v" verbose "verbose" + ; fB "C" sepstat "separate sys/nice/intr/iowait values (kernel sampler)" + ; fB "c" scalebar "constant bar width" + ; fB "P" poly "filled area instead of lines" + ; fB "l" labels "labels" + ; fB "m" mgrid "moving grid" + ] + ;; + + let add_opts tail = + let add_linux opts = + sI "t" timer "timer frequency in herz" + :: fB "I" icon "icon (hack)" + :: sS "d" devpath "path to itc device" + :: (fB "k" ksampler |< "kernel sampler (`/proc/[stat|uptime]')") + :: (fB "M" isampler |< "idle sampler") + :: (fB "u" uptime + "`uptime' instead of `stat' as kernel sampler (UP only)") + :: sI "n" niceval "value to renice self on init" + :: fB "g" gzh "gzh way (does not quite work yet)" + :: fB "S" sigway "sigwait delay method" + :: opts in - let opts = - if NP.winnt - then - begin - let nixopts = ["-n"; "-u"; "-d"; "-I"; "-S"; "-g"] in - prerr_endline "Only kernel sampler is available on Windows"; - List.filter (fun (s, _, _) -> List.mem s nixopts |> not) opts - end - else - opts + let add_solaris opts = + isampler := false; + fB "I" icon "icon (hack)" + :: opts in + let add_windows opts = + isampler := false; + opts + in + let add_macosx opts = + isampler := false; + fB "g" gzh "gzh way (does not quite work yet)" + :: opts + in + match NP.os_type with + | NP.Linux -> add_linux tail + | NP.Windows -> add_windows tail + | NP.Solaris -> add_solaris tail + | NP.MacOSX -> add_macosx tail + ;; + + let init () = + let opts = add_opts commonopts in Arg.parse opts (fun s -> - "don't know what to do with " ^ s |> prerr_endline; - exit 100 + raise (Arg.Bad + ("Invocation error: Don't know what to do with " ^ s)); ) - banner; + banner + ; + let cp {contents=v} s = + if v <= 0 + then (prerr_string s; prerr_endline " must be positive"; exit 1) + in + let cpf {contents=v} s = + if v <= 0.0 + then (prerr_string s; prerr_endline " must be pisitive"; exit 1) + in + cp w "Width"; + cp h "Height"; + cp pgrid "Number of percent grid items"; + cp sgrid "Number of history grid items"; + cp bars "Number of CPU bars"; + cp timer "Timer frequency"; + cpf freq "Frequency"; + cpf delay "Delay"; + cpf interval "Interval"; + if not (!isampler || !ksampler) + then + barw := 0 + ; ;; end -module Gzh = struct +module Gzh = +struct let lim = ref 0 let stop = ref false let refdt = ref 0.0 let rec furious_cycle i = if not !stop && i > 0 - then pred i |> furious_cycle - else (i, Unix.gettimeofday ()) + then + pred i |> furious_cycle + else + (i, Unix.gettimeofday ()) ;; let init verbose = @@ -354,10 +485,11 @@ module Gzh = struct let n, t2 = furious_cycle max_int in let () = refdt := t2 -. t1 in let () = lim := tries * (max_int - n) in - let () = if verbose then - begin - printf "Completed %d iterations in %f seconds@." !lim !refdt - end in + let () = + if verbose + then + printf "Completed %d iterations in %f seconds@." !lim !refdt + in let _ = Unix.sigprocmask Unix.SIG_UNBLOCK oldup in let _ = Unix.setitimer Unix.ITIMER_REAL oldi in let _ = Unix.sigprocmask Unix.SIG_BLOCK oldbp in @@ -405,7 +537,8 @@ let oohz oohz fn = end ;; -module Delay = struct +module Delay = +struct let sighandler signr = () let winfreq = ref 0.0 @@ -419,7 +552,13 @@ module Delay = struct Sys.Signal_handle sighandler |> Sys.set_signal Sys.sigalrm; if !Args.sigway then - let l = if gzh then [Sys.sigprof; Sys.sigvtalrm] else [] in + let l = + if gzh + then + [Sys.sigprof; Sys.sigvtalrm] + else + [] + in Unix.sigprocmask Unix.SIG_BLOCK |< Sys.sigalrm :: l |> ignore; ; in @@ -450,10 +589,11 @@ end type sampler = { color : Gl.rgb; getyielder : unit -> unit -> float option; - update : float -> float -> float -> float -> unit; + update : float -> float -> unit; } +;; -module Sampler(T : sig val nsamples : int val freq : float end) = +module Sampler (T : sig val nsamples : int val freq : float end) = struct let nsamples = T.nsamples + 1 let samples = Array.create nsamples 0.0 @@ -465,9 +605,16 @@ struct let n = min nsamples n in let rec loop i j = if j = 0 - then () + then + () else - let i = if i = nsamples then 0 else i in + let i = + if i = nsamples + then + 0 + else + i + in Array.set samples i v; loop (succ i) (pred j) in @@ -481,13 +628,16 @@ struct let tail = let d = !head - !active in if d < 0 - then nsamples + d - else d + then + nsamples + d + else + d in let ry = ref (fun () -> assert false) in let rec yield i () = if i = !active - then None + then + None else begin ry := succ i |> yield; @@ -498,11 +648,10 @@ struct (fun () -> !ry ()); ;; - let update t1 t2 i1 i2 = - let d = t2 -. t1 in - let i = i2 -. i1 in - let isamples = d /. T.freq |> truncate in - let l = 1.0 -. (i /. d) in + let update dt di = + let isamples = dt /. T.freq |> truncate in + let l = 1.0 -. (di /. dt) in + let l = max 0.0 l in update l isamples; ;; end @@ -526,14 +675,16 @@ sig val samplers : sampler list end -module View(V: sig val w : int val h : int end) = struct +module View (V: sig val w : int val h : int end) = +struct let ww = ref 0 let wh = ref 0 let funcs = ref [] let keyboard ~key ~x ~y = if key = 27 || key = Char.code 'q' - then exit 0 + then + exit 0; ;; let add dri = @@ -543,7 +694,7 @@ module View(V: sig val w : int val h : int end) = struct let display () = GlClear.clear [`color]; List.iter (fun (display, _, _) -> display ()) !funcs; - Glut.swapBuffers () + Glut.swapBuffers (); ;; let reshape ~w ~h = @@ -558,7 +709,7 @@ module View(V: sig val w : int val h : int end) = struct GlMat.rotate ~y:1.0 ~angle:180.0 (); GlMat.translate ~x:~-.1.0 ~y:~-.1.0 (); GlMat.scale ~x:2.0 ~y:2.0 (); - Glut.postRedisplay () + Glut.postRedisplay (); ;; let init () = @@ -580,54 +731,54 @@ module View(V: sig val w : int val h : int end) = struct let run = Glut.mainLoop end -module Bar(T: sig val barw : int val bars : int end) = struct - let nbars = T.bars - let kload = ref zero_stat - let iload = ref zero_stat - let vw = ref 0 - let vh = ref 0 - let sw = float T.barw /. float !Args.w - let bw = ref 0 - let m = 1 - let nrcpuscale = 1.0 /. float NP.nprocs - let fw = 3 * Glut.bitmapWidth font (Char.code 'W') - let ksepsl, isepsl = - let base = GlList.gen_lists ~len:2 in - GlList.nth base ~pos:0, - GlList.nth base ~pos:1 - ;; +module type BarInfo = +sig + val x : int + val y : int + val w : int + val h : int + val getl : stats -> ((float * float * float) * float) list +end - let getlr = function - | `i -> 0.01, 0.49 - | `k -> 0.51, 0.99 +module Bar (I: BarInfo) = +struct + let w = ref I.w + let h = ref I.h + let wratio = float I.w /. float !Args.w + let load = ref zero_stat + let nrcpuscale = 1.0 /. float NP.nprocs + let fh = 12 + let strw = Glut.bitmapLength ~font ~str:"55.55" + let sepsl = + let base = GlList.gen_lists ~len:1 in + GlList.nth base ~pos:0 ;; - let seps ki = - let xl, xr = getlr ki in - let y = 18 in - let h = !vh - 15 - y in - let () = GlDraw.viewport m y !bw h in + let seps () = + let hh = !h - 26 in let () = + GlDraw.viewport I.x (I.y + 15) !w hh; GlMat.push (); GlMat.load_identity (); - GlMat.rotate ~y:1.0 ~angle:180.0 (); GlMat.translate ~x:~-.1.0 ~y:~-.1.0 (); - GlMat.scale ~x:2.0 ~y:(2.0 /. float h) () + GlMat.scale ~y:(2.0 /. (float hh)) ~x:1.0 (); in - let barm = 1 in - let mspace = barm * nbars in - let barh = (h + 66 - mspace / 2) / nbars |> float in - let barm = float barm in + let seph = 1 in + let barh = float (hh - (!Args.bars - 1) * seph) /. float !Args.bars in + let barh = ceil barh |> truncate in let rec loop i yb = - if i = T.bars - then () + if yb > hh + then + () else - let yt = yb +. barm in - let yn = yt +. barh in - GlDraw.vertex2 (xl, yb); - GlDraw.vertex2 (xl, yt); - GlDraw.vertex2 (xr, yt); - GlDraw.vertex2 (xr, yb); + let yt = yb + seph in + let yn = yt + barh in + let yb = float yb + and yt = float yt in + GlDraw.vertex2 (0.0, yb); + GlDraw.vertex2 (0.0, yt); + GlDraw.vertex2 (2.0, yt); + GlDraw.vertex2 (2.0, yb); succ i |> loop |< yn in GlDraw.color (0.0, 0.0, 0.0); @@ -637,119 +788,82 @@ module Bar(T: sig val barw : int val bars : int end) = struct GlMat.pop (); ;; - let reshape w h = - vw := w; - vh := h; - bw := + let reshape w' h' = + w := if !Args.scalebar then - (float w *. sw |> truncate) - m + (float w' *. wratio |> truncate) else - T.barw - m + !w ; - - GlList.begins ksepsl `compile; - seps `k; - GlList.ends (); - - GlList.begins isepsl `compile; - seps `i; + h := h'; + GlList.begins sepsl `compile; + seps (); GlList.ends (); ;; - let drawseps = function - | `k -> GlList.call ksepsl - | `i -> GlList.call isepsl - ;; - let display () = - let kload = scale_stat !kload nrcpuscale in - let iload = scale_stat !iload nrcpuscale in - let kload_all = min (1.0 -. kload.all) 1.0 |> max 0.0 in - let iload_all = min (1.0 -. iload.all) 1.0 |> max 0.0 in - let () = GlDraw.viewport m 0 !bw 15 in + let load = scale_stat !load nrcpuscale in + let load_all = min (1.0 -. load.all) 1.0 |> max 0.0 in + let () = GlMat.push () in let () = + GlDraw.viewport I.x (I.y + 2) !w !h; GlDraw.color (1.0, 1.0, 1.0); - let kload_all = 100.0 *. kload_all in - let iload_all = 100.0 *. iload_all in + let load_all = 100.0 *. load_all in + let str = sprintf "%5.2f" load_all in let () = - GlMat.push (); GlMat.load_identity (); - GlMat.scale ~x:(1.0/.float !bw) ~y:(1.0/.30.0) () + let strw = + if false + then + Glut.bitmapLength ~font ~str:str + else + strw + in + let x = -. (float strw /. float !w) in + GlMat.translate ~y:~-.1.0 ~x (); in - let ix = !bw / 2 - fw |> float in - let kx = - (fw + !bw / 2) |> float in - let () = sprintf "%5.2f" iload_all |> draw_string ix 0.0 in - let () = sprintf "%5.2f" kload_all |> draw_string kx 0.0 in - let () = GlMat.pop () in () + let () = draw_string 0.0 0.0 str in + () in - - let y = 18 in - let h = !vh - 15 - y in - let () = GlDraw.viewport m y !bw h in - let () = - GlMat.push (); + GlDraw.viewport I.x (I.y + 15) !w (!h - 26); GlMat.load_identity (); - GlMat.rotate ~y:1.0 ~angle:180.0 (); - GlMat.translate ~x:~-.1.0 ~y:~-.1.0 (); - GlMat.scale ~x:2.0 ~y:(2.0 /. float h) () - in - let aux ki cl = - let xl, xr = getlr ki in + GlMat.translate ~x:~-.1. ~y:~-.1.(); let drawquad yb yt = GlDraw.begins `quads; - GlDraw.vertex2 (xl, yb); - GlDraw.vertex2 (xl, yt); - GlDraw.vertex2 (xr, yt); - GlDraw.vertex2 (xr, yb); + GlDraw.vertex2 (0.0, yb); + GlDraw.vertex2 (0.0, yt); + GlDraw.vertex2 (2.0, yt); + GlDraw.vertex2 (2.0, yb); GlDraw.ends () in let fold yb (color, load) = if load > 0.0 then let () = GlDraw.color color in - let yt = yb +. float h *. load in + let yt = yb +. 2.0*.load in let () = drawquad yb yt in yt else yb in + let cl = I.getl load in let yb = List.fold_left fold 0.0 cl in let () = GlDraw.color (0.5, 0.5, 0.5) in - let yt = float h in - let () = drawquad yb yt in - let () = drawseps ki in - () - in - let () = - if !Args.sepstat - then - aux `k - [ (1.0, 1.0, 0.0), kload.user - ; (0.0, 0.0, 1.0), kload.nice - ; (1.0, 0.0, 0.0), kload.sys - ; (1.0, 1.0, 1.0), kload.intr - ; (0.75, 0.5, 0.5), - let sum = kload.user +. kload.nice +. kload.sys - +. kload.intr +. kload.softirq - in - (1.0 -. kload.iowait) -. sum - ] - else - aux `k [ (1.0, 0.0, 0.0), 1.0 -. kload.idle ] - in - let () = aux `i [ (1.0, 1.0, 0.0), 1.0 -. iload.all ] in - GlMat.pop (); + let () = drawquad yb 2.0 in + let () = GlList.call sepsl in + GlMat.pop (); + GlList.call sepsl; ;; - let update delta' kload' iload' = + let update delta' load' = let delta = 1.0 /. delta' in - kload := scale_stat kload' delta; - iload := scale_stat iload' delta; + load := scale_stat load' delta; ;; end -module Graph (V: View) = struct +module Graph (V: View) = +struct let ox = if !Args.scalebar then 0 else !Args.barw let sw = float V.w /. float (!Args.w - ox) let sh = float V.h /. float !Args.h @@ -765,8 +879,11 @@ module Graph (V: View) = struct let fw, fh = if !Args.labels - then 3 * Glut.bitmapWidth font (Char.code '%'), 20 - else 0, 10 + then + 3 * Glut.bitmapWidth font (Char.code '%'), 20 + else + 0, 10 + ;; let gridlist = let base = GlList.gen_lists ~len:1 in @@ -872,8 +989,7 @@ module Graph (V: View) = struct GlList.call gridlist; viewport `graph; if !Args.mgrid then mgrid (); - GlDraw.line_width 1.5; - + GlDraw.line_width 2.0; let sample sampler = GlDraw.color sampler.color; let () = @@ -889,16 +1005,17 @@ module Graph (V: View) = struct let rec loop last i = match yield () with | Some y as opty -> - let x = float i *. scale in + let x = scale *. float i in GlDraw.vertex ~x ~y (); loop opty (succ i) + | None -> if !Args.poly then match last with | None -> () | Some y -> - let x = float (pred i) *. scale in + let x = scale *. float (pred i) in GlDraw.vertex ~x ~y:0.0 () in loop None 0; @@ -927,7 +1044,8 @@ let getplacements w h n barw = let vh = h' / y in let rec loop accu i = if i = n - then accu + then + accu else let yc = i / x in let xc = i mod x in @@ -947,7 +1065,9 @@ let create fd w h = in let placements, vw, vh = getplacements w h NP.nprocs !Args.barw in - let iget () = NP.idletimeofday fd NP.nprocs in + let iget () = + if !Args.isampler then NP.idletimeofday fd NP.nprocs else [||] + in let is = iget () in let kget () = @@ -964,35 +1084,59 @@ let create fd w h = ; update = Si.update } in - let (kcalc, ksampler) = - let module Sc = Sampler (S) in - let sampler = - { getyielder = Sc.getyielder - ; color = (1.0, 0.0, 0.0) - ; update = Sc.update - } - in - let calc = - if !Args.gzh + let module Sk = Sampler (S) in + let ksampler = + { getyielder = Sk.getyielder + ; color = (1.0, 0.0, 0.0) + ; update = Sk.update + } + in + let module V = struct + let x = x + let y = y + let w = vw + let h = vh + let freq = S.freq + let interval = !Args.interval + let pgrid = !Args.pgrid + let sgrid = !Args.sgrid + let samplers = + if !Args.isampler then - let d = ref 0.0 in - let f d' = d := d' in - let () = Gzh.gen f in - fun _ _ _ -> - { zero_stat with all = !d } + isampler :: (if !Args.ksampler then [ksampler] else []) else - if !Args.uptime + if !Args.ksampler then [ksampler] else [] + end + in + let module Graph = Graph (V) in + let kaccu = + if !Args.ksampler + then + let calc = + if !Args.gzh then - let (u1, i1) = NP.parse_uptime () in - let u1 = ref u1 - and i1 = ref i1 in + let d = ref 0.0 in + let f d' = d := d' in + let () = Gzh.gen f in fun _ _ _ -> - let (u2, i2) = NP.parse_uptime () in - let du = u2 -. !u1 - and di = i2 -. !i1 in - u1 := u2; - i1 := i2; - { zero_stat with all = di /. du } + let d = !d in + { zero_stat with + all = d; iowait = d; user = 1.0 -. d; idle = d } + else + if !Args.uptime + then + let (u1, i1) = NP.parse_uptime () in + let u1 = ref u1 + and i1 = ref i1 in + fun _ _ _ -> + let (u2, i2) = NP.parse_uptime () in + let du = u2 -. !u1 + and di = i2 -. !i1 in + let d = di /. du in + u1 := u2; + i1 := i2; + { zero_stat with + all = d; iowait = d; user = 1.0 -. d; idle = d } else let i' = if i = NP.nprocs then 0 else succ i in let g ks n = Array.get ks i' |> snd |> Array.get |< n in @@ -1005,10 +1149,9 @@ let create fd w h = and intr = g ks NP.intr and softirq = g ks NP.softirq in let () = - if - !Args.debug + if !Args.debug then - Format.eprintf + eprintf "user=%f nice=%f sys=%f iowait=%f intr=%f softirq=%f@." user nice @@ -1029,92 +1172,86 @@ let create fd w h = } in let i1 = ref (gall ks) in - fun ks t1 t2 -> + fun ks _ _ -> let i2 = gall ks in let diff = add_stat i2 (neg_stat !i1) in i1 := i2; diff - in - calc, sampler - in - let module V = - struct - let x = x - let y = y - let w = vw - let h = vh - let freq = S.freq - let interval = !Args.interval - let pgrid = !Args.pgrid - let sgrid = !Args.sgrid - let samplers = - if !Args.ksampler - then [isampler; ksampler] - else [isampler] - end - in - let module Graph = Graph (V) in - let icalc = - let i1 = Array.get is i |> ref in - fun is t1 t2 -> - let i2 = Array.get is i in - if classify_float i2 = FP_infinite - then - { zero_stat with all = t2 -. t1 } - else - let i1' = !i1 in - i1 := i2; - { zero_stat with all = i2 -. i1' } + in + (i, calc, ksampler) :: kaccu + else + kaccu in - let kaccu = - if !Args.ksampler - then (i, kcalc, ksampler) :: kaccu - else kaccu + let iaccu = + if !Args.isampler + then + let calc = + let i1 = Array.get is i |> ref in + fun is t1 t2 -> + let i2 = Array.get is i in + if classify_float i2 = FP_infinite + then + { zero_stat with all = t2 -. t1 } + else + let i1' = !i1 in + i1 := i2; + { zero_stat with all = i2 -. i1' } + in + (i, calc, isampler) :: iaccu + else + iaccu in - kaccu, (i, icalc, isampler) :: iaccu, Graph.funcs :: gaccu + kaccu, iaccu, Graph.funcs :: gaccu in let kl, il, gl = List.fold_left crgraph ([], [], []) placements in ((if kl == [] then (fun () -> [||]) else kget), kl), (iget, il), gl ;; let opendev path = - if NP.winnt + if not NP.linux then + (* gross hack but we are not particularly picky today *) Unix.stdout else try + if (Unix.stat path).Unix.st_kind != Unix.S_CHR + then + begin + eprintf "File %S is not an ITC device@." path; + exit 100 + end + ; Unix.openfile path [Unix.O_RDONLY] 0 with - | Unix.Unix_error (Unix.ENODEV, s1, s2) -> - eprintf "Could not open ITC device %S:\n%s(%s): %s)\n" - path s1 s2 |< Unix.error_message Unix.ENODEV; + | Unix.Unix_error ((Unix.ENODEV | Unix.ENXIO) as err , s1, s2) -> + eprintf "Could not open ITC device %S:\n%s(%s): %s@." + path s1 s2 |< Unix.error_message err; eprintf "(perhaps the module is not loaded?)@."; exit 100 - | Unix.Unix_error (Unix.ENOENT, s1, s2) -> - eprintf "Could not open ITC device %S:\n%s(%s): %s\n" - path s1 s2 |< Unix.error_message Unix.ENOENT; - exit 100 - | Unix.Unix_error (Unix.EALREADY, s1, s2) -> - eprintf "Could not open ITC device %S:\n%s(%s): %s\n" + eprintf "Could not open ITC device %S:\n%s(%s): %s@." path s1 s2 |< Unix.error_message Unix.EALREADY; eprintf "(perhaps modules is already in use?)@."; exit 100 | Unix.Unix_error (error, s1, s2) -> - eprintf "Could not open ITC device %S:\n%s(%s): %s\n" + eprintf "Could not open ITC device %S:\n%s(%s): %s@." path s1 s2 |< Unix.error_message error; exit 100 | exn -> - eprintf "Could not open ITC device %S:\n%s\n" + eprintf "Could not open ITC device %S:\n%s@." path |< Printexc.to_string exn; exit 100 ;; let seticon () = - let module X = struct external seticon : string -> unit = "ml_seticon" end in + let module X = + struct + external seticon : string -> unit = "ml_seticon" + end + in let len = 32*4 in let data = String.create |< 32*len + 2*4 in let line r g b a = @@ -1125,7 +1262,8 @@ let seticon () = let s = String.create len in let rec fill x = if x = len - then s + then + s else begin x + 0 |> String.set s |< b; @@ -1157,13 +1295,93 @@ let seticon () = and ky = kload *. 32.0 |> ceil |> truncate |> max 0 |> min 32 in let ey = if ky < iy - then (fill kl 0 ky; fill il ky iy; iy) - else (fill kl 0 ky; ky) + then + (fill kl 0 ky; fill il ky iy; iy) + else + (fill kl 0 ky; ky) in fill el ey 32; X.seticon data; ;; +let create_bars h kactive iactive = + let getlk kload = + if !Args.sepstat + then + let sum = kload.user +. kload.nice +. kload.sys + +. kload.intr +. kload.softirq + in + [ (1.0, 1.0, 0.0), kload.user + ; (0.0, 0.0, 1.0), kload.nice + ; (1.0, 0.0, 0.0), kload.sys + ; (1.0, 1.0, 1.0), kload.intr + ; (0.75, 0.5, 0.5), (1.0 -. kload.iowait) -. sum + ; (0.0, 1.0, 0.0), kload.all -. kload.iowait -. kload.softirq + ] + else + [ (1.0, 0.0, 0.0), 1.0 -. kload.idle ] + in + let getli iload = + [ (1.0, 1.0, 0.0), 1.0 -. iload.all ] + in + let barw = !Args.barw in + let nfuncs = + (fun () -> ()), (fun _ _ -> ()), (fun _ _ -> ()) + in + let kd, kr, ku = + if kactive + then + let module Bar = + Bar (struct + let x = 3 + let y = 0 + let w = (if iactive then barw / 2 else barw) - 3 + let h = h + let getl = getlk + end) + in + Bar.display, Bar.reshape, Bar.update + else + nfuncs + in + let id, ir, iu = + if iactive + then + let module Bar = + Bar (struct + let x = (if kactive then barw / 2 else 0) + 3 + let y = 0 + let w = (if kactive then barw / 2 else barw) - 3 + let h = h + let getl = getli + end) + in + Bar.display, Bar.reshape, Bar.update + else + nfuncs + in + if kactive + then + begin + if iactive + then + let d () = kd (); id () in + let r w h = kr w h; ir w h in + let u d k i = ku d k; iu d i in + d, r, u + else + kd, kr, (fun d k _ -> ku d k) + end + else + begin + if iactive + then + id, ir, (fun d _ i -> iu d i) + else + (fun () -> ()), (fun _ _ -> ()), (fun _ _ _ -> ()) + end +;; + let main () = let _ = Glut.init [|""|] in let () = Args.init () in @@ -1172,9 +1390,9 @@ let main () = then "detected " ^ string_of_int NP.nprocs ^ " CPUs" |> print_endline in - let () = if !Args.gzh then Gzh.init !Args.verbose in + let () = if !Args.gzh then Gzh.init !Args.verbose else () in let () = Delay.init !Args.timer !Args.gzh in - let () = if !Args.niceval != 0 then NP.setnice !Args.niceval in + let () = if !Args.niceval != 0 then NP.setnice !Args.niceval else () in let w = !Args.w and h = !Args.h in let fd = opendev !Args.devpath in @@ -1185,11 +1403,11 @@ let main () = List.iter FullV.add gl; if !Args.barw > 0 then - let module Bar = - Bar (struct let barw = !Args.barw let bars = !Args.bars end) + let (display, reshape, update) = + create_bars h !Args.ksampler !Args.isampler in - FullV.add (Bar.display, Bar.reshape, fun _ -> ()); - Bar.update + FullV.add (display, reshape, fun _ -> ()); + update else fun _ _ _ -> () in @@ -1205,9 +1423,9 @@ let main () = | [] -> load | (nr, calc, sampler) :: rest -> let cpuload = calc sample t1 t2 in - let thisload = 1.0 -. (cpuload.all /. dt) in - let thisload = max 0.0 thisload in let () = + let thisload = 1.0 -. (cpuload.all /. dt) in + let thisload = max 0.0 thisload in if !Args.verbose then ("cpu load(" ^ string_of_int nr ^ "): " @@ -1215,7 +1433,7 @@ let main () = |> print_endline) in let load = add_stat load cpuload in - sampler.update t1 t2 0.0 cpuload.all; + sampler.update dt cpuload.all; loop2 load sample rest in let iload = loop2 zero_stat is ifuncs in @@ -1240,11 +1458,12 @@ let main () = ;; let _ = - try main () + try + main () with | Unix.Unix_error (e, s1, s2) -> - eprintf "%s(%s): %s@." s1 s2 |< Unix.error_message e + Unix.error_message e |> eprintf "main failure: %s(%s): %s@." s1 s2 | exn -> - Printexc.to_string exn |> eprintf "Exception: %s@." + Printexc.to_string exn |> eprintf "main failure: %s@." ;; diff --git a/build.linux b/build.linux new file mode 100755 index 0000000..3174bac --- /dev/null +++ b/build.linux @@ -0,0 +1,11 @@ +#!/bin/sh + +set -e + +libs="unix.cma lablgl.cma lablglut.cma threads.cma" +flags="-custom -thread -I +lablGL" +test -z "$comp" && comp=ocamlc +$comp -o apc $flags $libs apc.ml ml_apc.c +cc -o hog -Wall -Werror -pedantic -W hog.c + +(cd mod && make) diff --git a/build.macosx b/build.macosx new file mode 100755 index 0000000..0e28393 --- /dev/null +++ b/build.macosx @@ -0,0 +1,9 @@ +#!/bin/sh + +set -e + +libs="unix.cma lablgl.cma lablglut.cma threads.cma" +flags="-custom -thread -I +lablGL -ccopt -I/usr/X11R6/include" + +ocamlc -o apc $flags $libs ml_apc.c apc.ml +cc -o hog hog.c diff --git a/build.solaris b/build.solaris new file mode 100755 index 0000000..f867f4c --- /dev/null +++ b/build.solaris @@ -0,0 +1,9 @@ +#!/bin/sh + +set -e + +libs="unix.cma lablgl.cma lablglut.cma threads.cma -cclib -lkstat" +flags="-custom -thread -I +lablGL -ccopt -I/usr/X11R6/include -ccopt -D__sun__" + +ocamlc -o apc $flags $libs ml_apc.c apc.ml +cc -o hog hog.c diff --git a/hog.c b/hog.c index de2db1a..582acce 100644 --- a/hog.c +++ b/hog.c @@ -1,9 +1,10 @@ -/* gcc -o hog hog.c */ -#define _GNU_SOURCE -#include +/* cc -o hog hog.c */ +#define _POSIX_PTHREAD_SEMANTICS #include #include -#include +#include +#include +#include #include #include #include @@ -27,26 +28,45 @@ static unsigned long hog (unsigned long niters) return niters; } +static void err (int status, const char *fmt, ...) +{ + va_list ap; + int errno_code = errno; + + va_start (ap, fmt); + vfprintf (stderr, fmt, ap); + va_end (ap); + fprintf (stderr, ": %s\n", strerror (errno_code)); + exit (status); +} + int main (void) { unsigned int i; struct itimerval it; + struct sigaction act; sigset_t set; unsigned long v[HIST]; double tmp = 0.0; unsigned long n; + act.sa_handler = sighandler; + if (sigemptyset (&act.sa_mask)) { + err (EXIT_FAILURE, "sigemptyset failed"); + } + act.sa_flags = 0; + it.it_interval.tv_sec = 0; it.it_interval.tv_usec = 1; it.it_value.tv_sec = 0; it.it_value.tv_usec = 1; - if (signal (SIGALRM, &sighandler)) { - err (EXIT_FAILURE, "failed to set signal handler"); + if (sigaction (SIGALRM, &act, NULL)) { + err (EXIT_FAILURE, "sigaction failed"); } if (setitimer (ITIMER_REAL, &it, NULL)) { - err (EXIT_FAILURE, "failed to set interval timer"); + err (EXIT_FAILURE, "setitimer failed"); } hog (ULONG_MAX); @@ -62,11 +82,11 @@ int main (void) n = tmp - (tmp / 3); if (sigemptyset (&set)) { - err (EXIT_FAILURE, "failed to empty sigset"); + err (EXIT_FAILURE, "sigemptyset failed"); } if (sigaddset (&set, SIGALRM)) { - err (EXIT_FAILURE, "failed to add to sigset"); + err (EXIT_FAILURE, "sigaddset failed"); } for (;;) { @@ -74,9 +94,7 @@ int main (void) hog (n); if (sigwait (&set, &signr)) { - err (EXIT_FAILURE, "failed to wait for a signal"); + err (EXIT_FAILURE, "sigwait failed"); } } - - return 0; } diff --git a/ml_apc.c b/ml_apc.c index 3704663..b6ad10a 100644 --- a/ml_apc.c +++ b/ml_apc.c @@ -1,5 +1,3 @@ -#define _XOPEN_SOURCE 700 -#define _GNU_SOURCE #include #include #include @@ -12,6 +10,13 @@ #include #include +enum { + LINUX_TAG, + WINDOWS_TAG, + SOLARIS_TAG, + MACOSX_TAG +}; + #ifdef _MSC_VER #define vsnprintf _vsnprintf #endif @@ -30,6 +35,7 @@ static void failwith_fmt (const char *fmt, ...) } #if defined __linux__ +#define _GNU_SOURCE #include #include #include @@ -39,26 +45,6 @@ static void failwith_fmt (const char *fmt, ...) #include #include -CAMLprim value ml_waitalrm (value unit_v) -{ - CAMLparam1 (unit_v); - sigset_t set; - int signr; - - sigemptyset (&set); - sigaddset (&set, SIGALRM); - - caml_enter_blocking_section (); - { - if (sigwait (&set, &signr)) { - failwith_fmt ("sigwait: %s", strerror (errno)); - } - } - caml_leave_blocking_section (); - - CAMLreturn (Val_unit); -} - CAMLprim value ml_sysinfo (value unit_v) { CAMLparam1 (unit_v); @@ -133,101 +119,10 @@ CAMLprim value ml_idletimeofday (value fd_v, value nprocs_v) CAMLreturn (res_v); } -CAMLprim value ml_get_hz (value unit_v) +CAMLprim value ml_os_type (value unit_v) { CAMLparam1 (unit_v); - CAMLreturn (Val_int (sysconf (_SC_CLK_TCK))); -} - -CAMLprim value ml_nice (value nice_v) -{ - CAMLparam1 (nice_v); - int niceval = Int_val (nice_v); - - if (!nice (niceval)) { - failwith_fmt ("nice %d: %s", niceval, strerror (errno)); - } - - CAMLreturn (Val_unit); -} - -#include -#include -#include -#include - -#include - -struct X11State { - Display *dpy; - Window id; - Atom property; - int error; -}; - -CAMLprim value ml_seticon (value data_v) -{ - CAMLparam1 (data_v); - static struct X11State static_state; - struct X11State *s = &static_state; - void *ptr = String_val (data_v); - CARD32 *p = ptr; - unsigned char *data = ptr; - - if (!s->error) { - if (!s->dpy) { - s->dpy = XOpenDisplay (NULL); - if (!s->dpy) { - goto err0; - } - else { - /* "tiny bit" hackish */ - s->id = glXGetCurrentDrawable (); - if (s->id == None) { - goto err1; - } - - s->property = XInternAtom (s->dpy, "_NET_WM_ICON", False); - if (s->property == None){ - goto err1; - } - -#ifdef DEBUG - printf ("id = %#x, property = %d\n", - (int) s->id, (int) s->property); -#endif - } - } - } - else { - CAMLreturn (Val_unit); - } - - p[0] = 32; - p[1] = 32; - XChangeProperty (s->dpy, s->id, s->property, XA_CARDINAL, - 32, PropModeReplace, data, 32 * 32 + 2); - - CAMLreturn (Val_unit); - - err1: - XCloseDisplay (s->dpy); - err0: - s->error = 1; - CAMLreturn (Val_unit); -} - -CAMLprim value ml_delay (value secs_v) -{ - CAMLparam1 (secs_v); - failwith ("delay is not implemented on non-Windows"); - CAMLreturn (Val_unit); -} - -CAMLprim value ml_is_winnt (value unit_v) -{ - CAMLparam1 (unit_v); - CAMLreturn (Val_false); + CAMLreturn (Val_int (LINUX_TAG)); } #elif defined _WIN32 @@ -309,7 +204,7 @@ static void init (void) GetProcAddress (glob.hmod, "ZwQuerySystemInformation"); if (!glob.QuerySystemInformation) { failwith_fmt ( - "could not obtain ZwQuerySystemInformation entry point: %#lx\n", + "could not obtain ZwQuerySystemInformation entry point: %#lx", GetLastError ()); } } @@ -323,7 +218,8 @@ static void qsi (int c, PVOID buf, ULONG size) init (); status = glob.QuerySystemInformation (c, buf, size, &retsize); if (status < 0) { - failwith_fmt ("could not query system information %d\n", c); + failwith_fmt ("could not query system information %ld retsize %ld", + c, retsize); } if (retsize != size) { fprintf (stderr, "class=%d status=%ld size=%d retsize=%d\n", @@ -351,32 +247,6 @@ static void get_nprocs (void) glob.nprocs = sbi.NumberProcessors; } -CAMLprim value ml_sysinfo (value unit_v) -{ - CAMLparam1 (unit_v); - CAMLlocal2 (res_v, loads_v); - - get_nprocs (); - - loads_v = caml_alloc_tuple (3); - Store_field (loads_v, 0, caml_copy_int64 (0)); - Store_field (loads_v, 1, caml_copy_int64 (0)); - Store_field (loads_v, 2, caml_copy_int64 (0)); - - res_v = caml_alloc_tuple (9); - Store_field (res_v, 0, 0); - Store_field (res_v, 1, loads_v); - Store_field (res_v, 2, 0); - Store_field (res_v, 3, 0); - Store_field (res_v, 4, 0); - Store_field (res_v, 5, 0); - Store_field (res_v, 6, 0); - Store_field (res_v, 7, 0); - Store_field (res_v, 8, glob.nprocs); - - CAMLreturn (res_v); -} - CAMLprim value ml_get_nprocs (value unit_v) { CAMLparam1 (unit_v); @@ -385,14 +255,14 @@ CAMLprim value ml_get_nprocs (value unit_v) CAMLreturn (Val_int (glob.nprocs)); } -CAMLprim value ml_idletimeofday (value fd_v, value nprocs_v) +CAMLprim value ml_windows_processor_times (value nprocs_v) { - CAMLparam2 (fd_v, nprocs_v); + CAMLparam1 (nprocs_v); CAMLlocal1 (res_v); int nprocs = Int_val (nprocs_v); - PSYSTEM_PROCESSOR_TIMES buf; + PSYSTEM_PROCESSOR_TIMES buf, b; size_t n = nprocs * sizeof (*buf); - int i; + int i, j; buf = _alloca (n); if (!buf) { @@ -401,11 +271,19 @@ CAMLprim value ml_idletimeofday (value fd_v, value nprocs_v) qsi (8, buf, n); - res_v = caml_alloc (nprocs * Double_wosize, Double_array_tag); - for (i = 0; i < nprocs; ++i) { - double d = buf[i].IdleTime.QuadPart * 1e-7; + res_v = caml_alloc (nprocs * 5 * Double_wosize, Double_array_tag); + b = buf; + for (i = 0, j = 0; i < nprocs; ++i, ++b) { + double d = b->IdleTime.QuadPart * 1e-7; - Store_double_field (res_v, i, d); + Store_double_field (res_v, j, d); j += 1; + + d = b->KernelTime.QuadPart * 1e-7 - d; + Store_double_field (res_v, j, d); j += 1; + + Store_double_field (res_v, j, b->UserTime.QuadPart * 1e-7); j += 1; + Store_double_field (res_v, j, b->DpcTime.QuadPart * 1e-7); j += 1; + Store_double_field (res_v, j, b->InterruptTime.QuadPart * 1e-7); j += 1; } CAMLreturn (res_v); } @@ -444,7 +322,7 @@ CAMLprim value ml_delay (value secs_v) CAMLreturn (Val_unit); } -CAMLprim value ml_is_winnt (value unit_v) +CAMLprim value ml_os_type (value unit_v) { CAMLparam1 (unit_v); OSVERSIONINFO ovi; @@ -459,9 +337,363 @@ CAMLprim value ml_is_winnt (value unit_v) caml_failwith ("Only NT family of Windows is supported by APC"); } - CAMLreturn (Val_true); + CAMLreturn (Val_int (WINDOWS_TAG)); +} + +#elif defined __sun__ +#define _POSIX_PTHREAD_SEMANTICS +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +static long get_nprocs (void) +{ + long nprocs = sysconf (_SC_NPROCESSORS_CONF); + if (nprocs <= 0) { + failwith_fmt ("sysconf (_SC_NPROCESSORS_CONF) = %ld: %s", + nprocs, strerror (errno)); + } + return nprocs; +} + +CAMLprim value ml_get_nprocs (value unit_v) +{ + CAMLparam1 (unit_v); + CAMLreturn (Val_int (get_nprocs ())); +} + +CAMLprim value ml_solaris_kstat (value nprocs_v) +{ + /* Based on lib/cpustat.cc from sinfo package by Juergen Rinas */ + CAMLparam1 (nprocs_v); + CAMLlocal1 (res_v); + int i = 0, j = 0; + int nprocs = Int_val (nprocs_v); + struct kstat_ctl *kc; + kstat_t *ksp; + + kc = kstat_open (); + if (!kc) { + failwith_fmt ("kstat_open failed: %s", strerror (errno)); + } + + res_v = caml_alloc (nprocs * 4 * Double_wosize, Double_array_tag); + for (ksp = kc->kc_chain; ksp; ksp = ksp->ks_next) { + if (!strncmp (ksp->ks_name, "cpu_stat", 8)) { + cpu_stat_t cstat; + + i += 1; + if (i > nprocs) { + failwith_fmt ("number of processors changed?"); + } + + if (kstat_read (kc, ksp, 0) == -1) { + failwith_fmt ("kstat_read (update) failed: %s", strerror (errno)); + } + + if (kstat_read (kc, ksp, &cstat) == -1) { + failwith_fmt ("kstat_read (read) failed: %s", strerror (errno)); + } + + Store_double_field (res_v, j, cstat.cpu_sysinfo.cpu[0]); j += 1; + Store_double_field (res_v, j, cstat.cpu_sysinfo.cpu[1]); j += 1; + Store_double_field (res_v, j, cstat.cpu_sysinfo.cpu[2]); j += 1; + Store_double_field (res_v, j, cstat.cpu_sysinfo.cpu[3]); j += 1; + } + } + + kstat_close (kc); + CAMLreturn (res_v); +} + +CAMLprim value ml_os_type (value unit_v) +{ + CAMLparam1 (unit_v); + CAMLreturn (Val_int (SOLARIS_TAG)); +} +#elif defined __APPLE__ +#include +#include +#include +#include +#include + +CAMLprim value ml_seticon (value data_v) +{ + CAMLparam1 (data_v); + CAMLreturn (Val_unit); +} + +static long get_nprocs (void) +{ + int n, err; + size_t size; + int mib[] = { CTL_HW, HW_NCPU }; + + size = sizeof (int); + err = sysctl (mib, 2, &n, &size, NULL, 0); + if (err < 0) { + failwith_fmt ("sysctl (HW_NCPU) failed: %s", strerror (errno)); + } + return n; +} + +CAMLprim value ml_get_nprocs (value unit_v) +{ + CAMLparam1 (unit_v); + CAMLreturn (Val_int (get_nprocs ())); +} + +CAMLprim value ml_macosx_host_processor_info (value nprocs_v) +{ + CAMLparam1 (nprocs_v); + CAMLlocal1 (res_v); + int i, j = 0; + int nprocs = Int_val (nprocs_v); + unsigned int nprocs1; + kern_return_t kr; + processor_cpu_load_info_t cpu_load, c; + mach_msg_type_number_t cpu_msg_count; + + kr = host_processor_info (mach_host_self (), PROCESSOR_CPU_LOAD_INFO, + &nprocs1, + (processor_info_array_t *) &cpu_load, + &cpu_msg_count); + if (kr != KERN_SUCCESS) { + failwith_fmt ("host_processor_info failed: %s", + mach_error_string (kr)); + } + + if (nprocs1 != nprocs){ + failwith_fmt ("host_processor_info claims CPUs=%d expected %d", + nprocs1, nprocs); + } + + res_v = caml_alloc (nprocs * 4 * Double_wosize, Double_array_tag); + c = cpu_load; + for (i = 0; i < nprocs; ++i, ++c) { + Store_double_field (res_v, j, c->cpu_ticks[CPU_STATE_IDLE]); j += 1; + Store_double_field (res_v, j, c->cpu_ticks[CPU_STATE_USER]); j += 1; + Store_double_field (res_v, j, c->cpu_ticks[CPU_STATE_SYSTEM]); j += 1; + Store_double_field (res_v, j, c->cpu_ticks[CPU_STATE_NICE]); j += 1; + } + + kr = vm_deallocate (mach_task_self (), (vm_address_t) cpu_load, + cpu_msg_count * sizeof (*cpu_load)); + if (kr != KERN_SUCCESS) { + failwith_fmt ("vm_deallocate failed: %s", mach_error_string (kr)); + } + CAMLreturn (res_v); } +CAMLprim value ml_os_type (value unit_v) +{ + CAMLparam1 (unit_v); + CAMLreturn (Val_int (MACOSX_TAG)); +} #else #error This operating system is not supported #endif + +#if defined __linux__ || defined __sun__ +#include +#include +#include +#include + +#include + +struct X11State { + Display *dpy; + Window id; + Atom property; + int error; +}; + +CAMLprim value ml_seticon (value data_v) +{ + CAMLparam1 (data_v); + static struct X11State static_state; + struct X11State *s = &static_state; + void *ptr = String_val (data_v); + CARD32 *p = ptr; + unsigned char *data = ptr; + + if (!s->error) { + if (!s->dpy) { + s->dpy = XOpenDisplay (NULL); + if (!s->dpy) { + goto err0; + } + else { + /* "tiny bit" hackish */ + s->id = glXGetCurrentDrawable (); + if (s->id == None) { + goto err1; + } + + s->property = XInternAtom (s->dpy, "_NET_WM_ICON", False); + if (s->property == None){ + goto err1; + } + +#ifdef DEBUG + printf ("id = %#x, property = %d\n", + (int) s->id, (int) s->property); +#endif + } + } + } + else { + CAMLreturn (Val_unit); + } + + p[0] = 32; + p[1] = 32; + XChangeProperty (s->dpy, s->id, s->property, XA_CARDINAL, + 32, PropModeReplace, data, 32 * 32 + 2); + + CAMLreturn (Val_unit); + + err1: + XCloseDisplay (s->dpy); + err0: + s->error = 1; + CAMLreturn (Val_unit); +} +#endif + +#ifndef _WIN32 +CAMLprim value ml_waitalrm (value unit_v) +{ + CAMLparam1 (unit_v); + sigset_t set; + int signr, ret, errno_code; + + sigemptyset (&set); + sigaddset (&set, SIGALRM); + + caml_enter_blocking_section (); + { + ret = sigwait (&set, &signr); + errno_code = errno; + } + caml_leave_blocking_section (); + + if (ret) { + failwith_fmt ("sigwait: %s", strerror (errno_code)); + } + CAMLreturn (Val_unit); +} + +CAMLprim value ml_get_hz (value unit_v) +{ + CAMLparam1 (unit_v); + long clk_tck; + + clk_tck = sysconf (_SC_CLK_TCK); + if (clk_tck <= 0) { + failwith_fmt ("sysconf (SC_CLK_TCK): %s", strerror (errno)); + } + CAMLreturn (Val_int (clk_tck)); +} + +CAMLprim value ml_delay (value secs_v) +{ + CAMLparam1 (secs_v); + failwith ("delay is not implemented on non-Windows"); + CAMLreturn (Val_unit); +} + +CAMLprim value ml_nice (value nice_v) +{ + CAMLparam1 (nice_v); + int niceval = Int_val (nice_v); + +#ifdef __linux__ + errno = 0; +#endif + if (nice (niceval) < 0) { +#ifdef __linux__ + if (errno) +#endif + failwith_fmt ("nice %d: %s", niceval, strerror (errno)); + } + + CAMLreturn (Val_unit); +} +#endif + +#ifndef _WIN32 +CAMLprim value ml_windows_processor_times (value nprocs_v) +{ + CAMLparam1 (nprocs_v); + failwith ("ml_windows_processor_times is not implemented on non-Windows"); + CAMLreturn (Val_unit); +} +#endif + +#ifndef __sun__ +CAMLprim value ml_solaris_kstat (value nprocs_v) +{ + CAMLparam1 (nprocs_v); + failwith ("ml_solaris_kstat is not implemented on non-Solaris"); + CAMLreturn (Val_unit); +} +#endif + +#ifndef __APPLE__ +CAMLprim value ml_macosx_host_processor_info (value nprocs_v) +{ + CAMLparam1 (nprocs_v); + failwith ("ml_macosx_host_processor_info is not implemented on non-MacOSX"); + CAMLreturn (Val_unit); +} +#endif + +#ifndef __linux__ +CAMLprim value ml_sysinfo (value unit_v) +{ + CAMLparam1 (unit_v); + CAMLlocal2 (res_v, loads_v); + long nprocs; + +#ifdef _WIN32 + nprocs = glob.nprocs; +#else + nprocs = get_nprocs (); +#endif + + loads_v = caml_alloc_tuple (3); + Store_field (loads_v, 0, caml_copy_int64 (0)); + Store_field (loads_v, 1, caml_copy_int64 (0)); + Store_field (loads_v, 2, caml_copy_int64 (0)); + + res_v = caml_alloc_tuple (9); + Store_field (res_v, 0, 0); + Store_field (res_v, 1, loads_v); + Store_field (res_v, 2, 0); + Store_field (res_v, 3, 0); + Store_field (res_v, 4, 0); + Store_field (res_v, 5, 0); + Store_field (res_v, 6, 0); + Store_field (res_v, 7, 0); + Store_field (res_v, 8, nprocs); + + CAMLreturn (res_v); +} + +CAMLprim value ml_idletimeofday (value fd_v, value nprocs_v) +{ + CAMLparam2 (fd_v, nprocs_v); + failwith_fmt ("idletimeofday is not implemented on non-Linux"); + CAMLreturn (Val_unit); +} +#endif -- 2.11.4.GIT