From ac3cccc135e59873cce1145c0455534d6289ed64 Mon Sep 17 00:00:00 2001 From: malc Date: Sun, 8 Jul 2007 17:36:42 +0400 Subject: [PATCH] v0.95 --- Changes | 3 + FILES | 1 + OMakefile | 31 ++++--- apc.ml | 162 +++++++++++++++++++++++------------ build.bat | 3 + ml_apc.c | 273 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- mod/Makefile | 3 + 7 files changed, 404 insertions(+), 72 deletions(-) create mode 100644 build.bat diff --git a/Changes b/Changes index 6606faa..6ef5213 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,6 @@ +5 + * NT support + 4 * Better working gzh mode (though still not satisfactory) diff --git a/FILES b/FILES index b5ddfa5..1369868 100644 --- a/FILES +++ b/FILES @@ -5,6 +5,7 @@ mod/OMakefile mod/itc-mod.c ml_apc.c build.sh +build.bat README Thanks FILES diff --git a/OMakefile b/OMakefile index afcd30e..e5ca1ea 100644 --- a/OMakefile +++ b/OMakefile @@ -1,9 +1,9 @@ -version = 0.94 +version = 0.95 ocaml-includes = -I +lablGL ocamlc-cflags += -g $(ocaml-includes) -thread -ocamlopt-cflags += $(ocaml-includes) -thread +ocamlopt-cflags += $(ocaml-includes) -thread -compact ocamlc-lflags += -g $(ocaml-includes) -thread ocamlopt-lflags += $(ocaml-includes) -thread @@ -12,7 +12,13 @@ ocaml-libs = unix lablgl lablglut threads ocamlc-libs = $(addsuffix .cma, $(ocaml-libs)) ocamlopt-libs = $(addsuffix .cmxa, $(ocaml-libs)) -section +if $(target-win32) + target-flags += -I. + %.obj: %.c :value: $(c-digest-deps) :value: $(c-emit-stdmake-rule $@) + $(ocamlc) -ccopt $(quote -c $(target-flags) $(c-cflags)) $< + + ml_apc.obj: +else target-flags += -Wno-long-long -I. .SCANNER: %.o.scan: %.c $(ocamlc) -ccopt $(quote $(c-cflags) \ @@ -24,18 +30,20 @@ section ml_apc.o: -apc.byte: apc.cmo ml_apc.o +$(exename apc.byte): apc.cmo ml_apc$(obj) $(ocamlc) -custom $(ocamlc-lflags) $(ocamlc-libs) $(target-flags) -o $@ \ - ml_apc.o apc.cmo + ml_apc$(obj) apc.cmo +# imt link -edit -subsystem\:windows $@ -apc.opt: apc.cmx apc.o ml_apc.o +$(exename apc.opt): apc.cmx apc$(obj) ml_apc$(obj) $(ocamlopt) $(ocamlopt-lflags) $(ocamlopt-libs) $(target-flags) -o $@ \ - apc.cmx ml_apc.o + apc.cmx ml_apc$(obj) +# imt link /edit /subsystem\:windows $@ .PHONY: byte opt dist -byte: apc.byte -opt: apc.opt +byte: $(exename apc.byte) +opt: $(exename apc.opt) all: byte @@ -47,5 +55,6 @@ apc-$(version).tgz: $(shell cat FILES) dist: apc-$(version).tgz -add-env2 (mod) -.SUBDIRS: mod +if $(not $(target-win32)) + add-env2 (mod) + .SUBDIRS: mod diff --git a/apc.ml b/apc.ml index ccc8d67..3d3eac1 100644 --- a/apc.ml +++ b/apc.ml @@ -28,6 +28,10 @@ module NP = struct external waitalrm : unit -> unit = "ml_waitalrm" 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" + + let winnt = is_winnt () let user = 0 let nice = 1 @@ -91,16 +95,35 @@ module NP = struct cpuname, Array.of_list vals let parse_stat () = - 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 + if winnt + then + fun () -> + let ia = idletimeofday Unix.stdin nprocs in + let rec convert accu total n = + if n = nprocs + then + let t = total *. hz |> truncate 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 t = i *. hz |> truncate in + let v = "cpu" ^ string_of_int n, Array.make 7 t 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 let getselfdir () = try @@ -111,7 +134,7 @@ end module Args = struct let banner = - [ "Amazing Piece of Code by insanely gifted programmer, Version 0.94" + [ "Amazing Piece of Code by insanely gifted programmer, Version 0.95" ; "Motivation by: gzh and afs" ; "usage: " ] |> String.concat "\n" @@ -175,7 +198,7 @@ module Args = struct "-" ^ opt, Arg.Set_string r, pad 9 " " ^ doc |> dS |< r let init () = - Arg.parse + let opts = [ sF "f" freq "sampling frequency in seconds" ; sF "D" delay "refresh delay in seconds" ; sF "i" interval "history interval in seconds" @@ -188,9 +211,11 @@ module Args = struct ; sI "n" niceval "value to renice self on init" ; sI "t" timer "timer frequency in herz" ; sS "d" devpath "path to itc device" - ; cB "k" ksampler "do not use `/proc/stat'" + ; cB "k" ksampler |< "do not use kernel sampler" + ^ (if NP.winnt then "" else " (`/proc/[stat|uptime]')") ; sB "g" gzh "gzh way (does not quite work yet)" - ; sB "u" uptime "use `/proc/uptime' instead of `/proc/stat` (UP only)" + ; sB "u" uptime + "use `uptime' instead of `stat' as kernel sampler (UP only)" ; sB "v" verbose "verbose" ; sB "S" sigway "sigwait delay method" ; sB "c" scalebar "constant bar width" @@ -199,11 +224,24 @@ module Args = struct ; cB "l" labels "do not draw labels" ; sB "m" mgrid "moving grid" ] - (fun s -> - "don't know what to do with " ^ s |> prerr_endline; - exit 100 - ) - banner + 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 + in + Arg.parse opts + (fun s -> + "don't know what to do with " ^ s |> prerr_endline; + exit 100 + ) + banner end module Gzh = struct @@ -290,26 +328,41 @@ let oohz oohz fn = module Delay = struct let sighandler signr = () + let winfreq = ref 0.0 + let init freq gzh = - let () = - Sys.Signal_handle sighandler |> Sys.set_signal Sys.sigalrm; - if !Args.sigway - then - let l = if gzh then [Sys.sigprof; Sys.sigvtalrm] else [] in - Unix.sigprocmask Unix.SIG_BLOCK |< Sys.sigalrm :: l |> ignore; + if NP.winnt + then + winfreq := 1.0 /. float freq + else + let () = + Sys.Signal_handle sighandler |> Sys.set_signal Sys.sigalrm; + if !Args.sigway + then + let l = if gzh then [Sys.sigprof; Sys.sigvtalrm] else [] in + Unix.sigprocmask Unix.SIG_BLOCK |< Sys.sigalrm :: l |> ignore; ; - in - let v = 1.0 /. float freq in - let t = { Unix.it_interval = v; it_value = v } in - let _ = Unix.setitimer Unix.ITIMER_REAL t in - () + in + let v = 1.0 /. float freq in + let t = { Unix.it_interval = v; it_value = v } in + let _ = Unix.setitimer Unix.ITIMER_REAL t in + () let delay () = - if !Args.sigway - then NP.waitalrm () + if NP.winnt + then + NP.delay !winfreq else - try let _ = Unix.select [] [] [] ~-.1.0 in () - with Unix.Unix_error (Unix.EINTR, _, _) -> () + begin + if !Args.sigway + then + NP.waitalrm () + else + begin + try let _ = Unix.select [] [] [] ~-.1.0 in () + with Unix.Unix_error (Unix.EINTR, _, _) -> () + end + end end type sampler = @@ -874,24 +927,28 @@ let create fd w h = ((if kl == [] then (fun () -> [||]) else kget), kl), (iget, il), gl let opendev path = - try - 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; - 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 - - | exn -> - eprintf "Could not open ITC device %S:\n%s\n" - path |< Printexc.to_string exn; - exit 100 + if NP.winnt + then + Unix.stdout + else + try + 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; + 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 + + | exn -> + eprintf "Could not open ITC device %S:\n%s\n" + path |< Printexc.to_string exn; + exit 100 let seticon () = let module X = struct external seticon : string -> unit = "ml_seticon" end in @@ -981,6 +1038,7 @@ let main () = | (nr, calc, sampler) :: rest -> let i1, i2 = calc s t1 t2 in let thisload = 1.0 -. ((i2 -. i1) /. dt) in + let thisload = max 0.0 thisload in let () = if !Args.verbose then diff --git a/build.bat b/build.bat new file mode 100644 index 0000000..8390ef0 --- /dev/null +++ b/build.bat @@ -0,0 +1,3 @@ +set libs=unix.cma lablgl.cma lablglut.cma threads.cma +set flags=-custom -thread -I +lablGL +ocamlc -o apc.exe %flags% %libs% apc.ml ml_apc.c diff --git a/ml_apc.c b/ml_apc.c index fb402e3..43c8722 100644 --- a/ml_apc.c +++ b/ml_apc.c @@ -8,16 +8,12 @@ #include #include -#include -#include -#include #include -#include -#include -#include -#include -#include -#include +#include + +#ifdef _MSC_VER +#define vsnprintf _vsnprintf +#endif static void failwith_fmt (const char *fmt, ...) Noreturn; static void failwith_fmt (const char *fmt, ...) @@ -32,6 +28,16 @@ static void failwith_fmt (const char *fmt, ...) failwith (buf); } +#if defined __linux__ +#include +#include +#include +#include +#include +#include +#include +#include + CAMLprim value ml_waitalrm (value unit_v) { CAMLparam1 (unit_v); @@ -205,3 +211,252 @@ CAMLprim value ml_seticon (value data_v) 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); +} + +#elif defined _WIN32 + +#pragma warning (disable:4152 4127 4189) +#define WIN32_LEAN_AND_MEAN +#include + +#define DDKFASTAPI __fastcall +#define NTSTATUS long +#define BOOLEAN int + +/* Following (mildly modified) structure definitions, macros, enums, + etc are taken from binutils w32api (http://sourceware.org/binutils/) + Headers claim: + */ +/* + * ntpoapi.h + * ntddk.h + ... + * This file is part of the w32api package. + * + * Contributors: + * Created by Casper S. Hornstrup + * + * THIS SOFTWARE IS NOT COPYRIGHTED + * + * This source code is offered for use in the public domain. You may + * use, modify or distribute it freely. + * + * This code is distributed in the hope that it will be useful but + * WITHOUT ANY WARRANTY. ALL WARRANTIES, EXPRESS OR IMPLIED ARE HEREBY + * DISCLAIMED. This includes but is not limited to warranties of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * + */ + +typedef struct _SYSTEM_BASIC_INFORMATION { + ULONG Unknown; + ULONG MaximumIncrement; + ULONG PhysicalPageSize; + ULONG NumberOfPhysicalPages; + ULONG LowestPhysicalPage; + ULONG HighestPhysicalPage; + ULONG AllocationGranularity; + ULONG LowestUserAddress; + ULONG HighestUserAddress; + ULONG ActiveProcessors; + UCHAR NumberProcessors; +} SYSTEM_BASIC_INFORMATION, *PSYSTEM_BASIC_INFORMATION; + +typedef struct _SYSTEM_PROCESSOR_TIMES { + LARGE_INTEGER IdleTime; + LARGE_INTEGER KernelTime; + LARGE_INTEGER UserTime; + LARGE_INTEGER DpcTime; + LARGE_INTEGER InterruptTime; + ULONG InterruptCount; +} SYSTEM_PROCESSOR_TIMES, *PSYSTEM_PROCESSOR_TIMES; + +typedef long (__stdcall *QuerySystemInformationProc) + (SYSTEM_INFORMATION_CLASS, PVOID, ULONG, PULONG); + +static struct { + HMODULE hmod; + QuerySystemInformationProc QuerySystemInformation; + ULONG nprocs; +} glob; + +static void init (void) +{ + if (!glob.hmod) { + glob.hmod = LoadLibrary ("ntdll.dll"); + if (!glob.hmod) { + failwith_fmt ("could not load ntdll.dll: %#lx", GetLastError ()); + } + + *(void **) &glob.QuerySystemInformation = + GetProcAddress (glob.hmod, "ZwQuerySystemInformation"); + if (!glob.QuerySystemInformation) { + failwith_fmt ( + "could not obtain ZwQuerySystemInformation entry point: %#lx\n", + GetLastError ()); + } + } +} + +static void qsi (int c, PVOID buf, ULONG size) +{ + ULONG retsize = 0; + long status; + + init (); + status = glob.QuerySystemInformation (c, buf, size, &retsize); + if (status < 0) { + failwith_fmt ("could not query system information %d\n", c); + } + if (retsize != size) { + fprintf (stderr, "class=%d status=%ld size=%d retsize=%d\n", + c, status, size, retsize); + } +#ifdef DEBUG + printf ("class=%d status=%ld size=%d retsize=%d\n", + c, status, size, retsize); +#endif +} + +CAMLprim value ml_waitalrm (value unit_v) +{ + CAMLparam1 (unit_v); + + failwith ("waitalrm not supported on Windows"); + CAMLreturn (Val_unit); +} + +static void get_nprocs (void) +{ + SYSTEM_BASIC_INFORMATION sbi; + + qsi (0, &sbi, sizeof (sbi)); + 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); + + get_nprocs (); + CAMLreturn (Val_int (glob.nprocs)); +} + +CAMLprim value ml_idletimeofday (value fd_v, value nprocs_v) +{ + CAMLparam2 (fd_v, nprocs_v); + CAMLlocal1 (res_v); + int nprocs = Int_val (nprocs_v); + PSYSTEM_PROCESSOR_TIMES buf; + size_t n = nprocs * sizeof (*buf); + int i; + + buf = _alloca (n); + if (!buf) { + failwith_fmt ("alloca: %s", strerror (errno)); + } + + 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; + + Store_double_field (res_v, i, d); + } + CAMLreturn (res_v); +} + +CAMLprim value ml_get_hz (value unit_v) +{ + CAMLparam1 (unit_v); + CAMLreturn (Val_int (100)); +} + +CAMLprim value ml_nice (value nice_v) +{ + CAMLparam1 (nice_v); + int niceval = Int_val (nice_v); + + failwith_fmt ("nice: not implemented on Windows"); + CAMLreturn (Val_unit); +} + +CAMLprim value ml_seticon (value data_v) +{ + CAMLparam1 (data_v); + CAMLreturn (Val_unit); +} + +CAMLprim value ml_delay (value secs_v) +{ + CAMLparam1 (secs_v); + DWORD millis = (DWORD) (Double_val (secs_v) * 1e4); + + caml_enter_blocking_section (); + { + Sleep (millis); + } + caml_leave_blocking_section (); + CAMLreturn (Val_unit); +} + +CAMLprim value ml_is_winnt (value unit_v) +{ + CAMLparam1 (unit_v); + OSVERSIONINFO ovi; + + ovi.dwOSVersionInfoSize = sizeof (ovi); + if (!GetVersionEx (&ovi)) { + failwith_fmt ("Could not get version information: %#lx", + GetLastError ()); + } + + if (ovi.dwPlatformId != VER_PLATFORM_WIN32_NT) { + caml_failwith ("Only NT family of Windows is supported by APC"); + } + + CAMLreturn (Val_true); +} + +#else +#error This operating system is not supported +#endif diff --git a/mod/Makefile b/mod/Makefile index 55ec7db..d8d74bb 100644 --- a/mod/Makefile +++ b/mod/Makefile @@ -23,6 +23,9 @@ itc-objs := itc-mod.o ifdef TOPDIR obj-m := itc.o +hack := $(shell $(CC) -print-search-dirs \ + | sed -n 's;^install: \(.*\);\1/include;p;q') +export CPATH := ${CPATH}:${hack} endif ifdef K24 -- 2.11.4.GIT