v0.95
[apc.git] / ml_apc.c
blob43c8722a22e35a7bc34be51ad3f2da45de923659
1 #define _XOPEN_SOURCE 700
2 #define _GNU_SOURCE
3 #include <caml/fail.h>
4 #include <caml/alloc.h>
5 #include <caml/memory.h>
6 #include <caml/custom.h>
7 #include <caml/signals.h>
8 #include <caml/mlvalues.h>
9 #include <caml/bigarray.h>
11 #include <stdio.h>
12 #include <stdarg.h>
14 #ifdef _MSC_VER
15 #define vsnprintf _vsnprintf
16 #endif
18 static void failwith_fmt (const char *fmt, ...) Noreturn;
19 static void failwith_fmt (const char *fmt, ...)
21 va_list ap;
22 char buf[1024];
24 va_start (ap, fmt);
25 vsnprintf (buf, sizeof (buf), fmt, ap);
26 va_end (ap);
28 failwith (buf);
31 #if defined __linux__
32 #include <alloca.h>
33 #include <unistd.h>
34 #include <sys/time.h>
35 #include <sys/time.h>
36 #include <sys/sysinfo.h>
37 #include <signal.h>
38 #include <string.h>
39 #include <errno.h>
41 CAMLprim value ml_waitalrm (value unit_v)
43 CAMLparam1 (unit_v);
44 sigset_t set;
45 int signr;
47 sigemptyset (&set);
48 sigaddset (&set, SIGALRM);
50 caml_enter_blocking_section ();
52 if (sigwait (&set, &signr)) {
53 failwith_fmt ("sigwait: %s", strerror (errno));
56 caml_leave_blocking_section ();
58 CAMLreturn (Val_unit);
61 CAMLprim value ml_sysinfo (value unit_v)
63 CAMLparam1 (unit_v);
64 CAMLlocal2 (res_v, loads_v);
65 struct sysinfo si;
67 if (sysinfo (&si)) {
68 failwith_fmt ("sysinfo: %s", strerror (errno));
71 loads_v = caml_alloc_tuple (3);
72 Store_field (loads_v, 0, caml_copy_int64 (si.loads[0]));
73 Store_field (loads_v, 1, caml_copy_int64 (si.loads[1]));
74 Store_field (loads_v, 2, caml_copy_int64 (si.loads[2]));
76 res_v = caml_alloc_tuple (9);
77 Store_field (res_v, 0, caml_copy_int64 (si.uptime));
78 Store_field (res_v, 1, loads_v);
79 Store_field (res_v, 2, caml_copy_int64 (si.totalram));
80 Store_field (res_v, 3, caml_copy_int64 (si.freeram));
81 Store_field (res_v, 4, caml_copy_int64 (si.sharedram));
82 Store_field (res_v, 5, caml_copy_int64 (si.bufferram));
83 Store_field (res_v, 6, caml_copy_int64 (si.totalswap));
84 Store_field (res_v, 7, caml_copy_int64 (si.freeswap));
85 Store_field (res_v, 8, caml_copy_int64 (si.procs));
87 CAMLreturn (res_v);
90 CAMLprim value ml_get_nprocs (value unit_v)
92 CAMLparam1 (unit_v);
93 int nprocs;
95 nprocs = get_nprocs ();
96 if (nprocs <= 0) {
97 failwith_fmt ("get_nprocs: %s", strerror (errno));
100 CAMLreturn (Val_int (nprocs));
103 CAMLprim value ml_idletimeofday (value fd_v, value nprocs_v)
105 CAMLparam2 (fd_v, nprocs_v);
106 CAMLlocal1 (res_v);
107 struct timeval tv;
108 int fd = Int_val (fd_v);
109 int nprocs = Int_val (nprocs_v);
110 size_t n = nprocs * sizeof (tv);
111 ssize_t m;
112 struct timeval *buf;
113 int i;
115 buf = alloca (n);
116 if (!buf) {
117 failwith_fmt ("alloca: %s", strerror (errno));
120 m = read (fd, buf, n);
121 if (n - m) {
122 failwith_fmt ("read [n=%zu, m=%zi]: %s", n, m, strerror (errno));
125 res_v = caml_alloc (nprocs * Double_wosize, Double_array_tag);
126 for (i = 0; i < nprocs; ++i) {
127 double d = buf[i].tv_sec + buf[i].tv_usec * 1e-6;
129 Store_double_field (res_v, i, d);
131 CAMLreturn (res_v);
134 CAMLprim value ml_get_hz (value unit_v)
136 CAMLparam1 (unit_v);
137 CAMLreturn (Val_int (sysconf (_SC_CLK_TCK)));
140 CAMLprim value ml_nice (value nice_v)
142 CAMLparam1 (nice_v);
143 int niceval = Int_val (nice_v);
145 if (!nice (niceval)) {
146 failwith_fmt ("nice %d: %s", niceval, strerror (errno));
149 CAMLreturn (Val_unit);
152 #include <X11/X.h>
153 #include <X11/Xmd.h>
154 #include <X11/Xlib.h>
155 #include <X11/Xatom.h>
157 #include <GL/glx.h>
159 struct X11State {
160 Display *dpy;
161 Window id;
162 Atom property;
163 int error;
166 CAMLprim value ml_seticon (value data_v)
168 CAMLparam1 (data_v);
169 static struct X11State static_state;
170 struct X11State *s = &static_state;
171 void *ptr = String_val (data_v);
172 CARD32 *p = ptr;
173 unsigned char *data = ptr;
175 if (!s->error) {
176 if (!s->dpy) {
177 s->dpy = XOpenDisplay (NULL);
178 if (!s->dpy) {
179 goto err0;
181 else {
182 /* "tiny bit" hackish */
183 s->id = glXGetCurrentDrawable ();
184 if (s->id == None) {
185 goto err1;
188 s->property = XInternAtom (s->dpy, "_NET_WM_ICON", False);
189 if (s->property == None){
190 goto err1;
193 #ifdef DEBUG
194 printf ("id = %#x, property = %d\n",
195 (int) s->id, (int) s->property);
196 #endif
201 p[0] = 32;
202 p[1] = 32;
203 XChangeProperty (s->dpy, s->id, s->property, XA_CARDINAL,
204 32, PropModeReplace, data, 32 * 32 + 2);
206 CAMLreturn (Val_unit);
208 err1:
209 XCloseDisplay (s->dpy);
210 err0:
211 s->error = 1;
212 CAMLreturn (Val_unit);
215 CAMLprim value ml_delay (value secs_v)
217 CAMLparam1 (secs_v);
218 failwith ("delay is not implemented on non-Windows");
219 CAMLreturn (Val_unit);
222 CAMLprim value ml_is_winnt (value unit_v)
224 CAMLparam1 (unit_v);
225 CAMLreturn (Val_false);
228 #elif defined _WIN32
230 #pragma warning (disable:4152 4127 4189)
231 #define WIN32_LEAN_AND_MEAN
232 #include <windows.h>
234 #define DDKFASTAPI __fastcall
235 #define NTSTATUS long
236 #define BOOLEAN int
238 /* Following (mildly modified) structure definitions, macros, enums,
239 etc are taken from binutils w32api (http://sourceware.org/binutils/)
240 Headers claim:
243 * ntpoapi.h
244 * ntddk.h
246 * This file is part of the w32api package.
248 * Contributors:
249 * Created by Casper S. Hornstrup <chorns@users.sourceforge.net>
251 * THIS SOFTWARE IS NOT COPYRIGHTED
253 * This source code is offered for use in the public domain. You may
254 * use, modify or distribute it freely.
256 * This code is distributed in the hope that it will be useful but
257 * WITHOUT ANY WARRANTY. ALL WARRANTIES, EXPRESS OR IMPLIED ARE HEREBY
258 * DISCLAIMED. This includes but is not limited to warranties of
259 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
263 typedef struct _SYSTEM_BASIC_INFORMATION {
264 ULONG Unknown;
265 ULONG MaximumIncrement;
266 ULONG PhysicalPageSize;
267 ULONG NumberOfPhysicalPages;
268 ULONG LowestPhysicalPage;
269 ULONG HighestPhysicalPage;
270 ULONG AllocationGranularity;
271 ULONG LowestUserAddress;
272 ULONG HighestUserAddress;
273 ULONG ActiveProcessors;
274 UCHAR NumberProcessors;
275 } SYSTEM_BASIC_INFORMATION, *PSYSTEM_BASIC_INFORMATION;
277 typedef struct _SYSTEM_PROCESSOR_TIMES {
278 LARGE_INTEGER IdleTime;
279 LARGE_INTEGER KernelTime;
280 LARGE_INTEGER UserTime;
281 LARGE_INTEGER DpcTime;
282 LARGE_INTEGER InterruptTime;
283 ULONG InterruptCount;
284 } SYSTEM_PROCESSOR_TIMES, *PSYSTEM_PROCESSOR_TIMES;
286 typedef long (__stdcall *QuerySystemInformationProc)
287 (SYSTEM_INFORMATION_CLASS, PVOID, ULONG, PULONG);
289 static struct {
290 HMODULE hmod;
291 QuerySystemInformationProc QuerySystemInformation;
292 ULONG nprocs;
293 } glob;
295 static void init (void)
297 if (!glob.hmod) {
298 glob.hmod = LoadLibrary ("ntdll.dll");
299 if (!glob.hmod) {
300 failwith_fmt ("could not load ntdll.dll: %#lx", GetLastError ());
303 *(void **) &glob.QuerySystemInformation =
304 GetProcAddress (glob.hmod, "ZwQuerySystemInformation");
305 if (!glob.QuerySystemInformation) {
306 failwith_fmt (
307 "could not obtain ZwQuerySystemInformation entry point: %#lx\n",
308 GetLastError ());
313 static void qsi (int c, PVOID buf, ULONG size)
315 ULONG retsize = 0;
316 long status;
318 init ();
319 status = glob.QuerySystemInformation (c, buf, size, &retsize);
320 if (status < 0) {
321 failwith_fmt ("could not query system information %d\n", c);
323 if (retsize != size) {
324 fprintf (stderr, "class=%d status=%ld size=%d retsize=%d\n",
325 c, status, size, retsize);
327 #ifdef DEBUG
328 printf ("class=%d status=%ld size=%d retsize=%d\n",
329 c, status, size, retsize);
330 #endif
333 CAMLprim value ml_waitalrm (value unit_v)
335 CAMLparam1 (unit_v);
337 failwith ("waitalrm not supported on Windows");
338 CAMLreturn (Val_unit);
341 static void get_nprocs (void)
343 SYSTEM_BASIC_INFORMATION sbi;
345 qsi (0, &sbi, sizeof (sbi));
346 glob.nprocs = sbi.NumberProcessors;
349 CAMLprim value ml_sysinfo (value unit_v)
351 CAMLparam1 (unit_v);
352 CAMLlocal2 (res_v, loads_v);
354 get_nprocs ();
356 loads_v = caml_alloc_tuple (3);
357 Store_field (loads_v, 0, caml_copy_int64 (0));
358 Store_field (loads_v, 1, caml_copy_int64 (0));
359 Store_field (loads_v, 2, caml_copy_int64 (0));
361 res_v = caml_alloc_tuple (9);
362 Store_field (res_v, 0, 0);
363 Store_field (res_v, 1, loads_v);
364 Store_field (res_v, 2, 0);
365 Store_field (res_v, 3, 0);
366 Store_field (res_v, 4, 0);
367 Store_field (res_v, 5, 0);
368 Store_field (res_v, 6, 0);
369 Store_field (res_v, 7, 0);
370 Store_field (res_v, 8, glob.nprocs);
372 CAMLreturn (res_v);
375 CAMLprim value ml_get_nprocs (value unit_v)
377 CAMLparam1 (unit_v);
379 get_nprocs ();
380 CAMLreturn (Val_int (glob.nprocs));
383 CAMLprim value ml_idletimeofday (value fd_v, value nprocs_v)
385 CAMLparam2 (fd_v, nprocs_v);
386 CAMLlocal1 (res_v);
387 int nprocs = Int_val (nprocs_v);
388 PSYSTEM_PROCESSOR_TIMES buf;
389 size_t n = nprocs * sizeof (*buf);
390 int i;
392 buf = _alloca (n);
393 if (!buf) {
394 failwith_fmt ("alloca: %s", strerror (errno));
397 qsi (8, buf, n);
399 res_v = caml_alloc (nprocs * Double_wosize, Double_array_tag);
400 for (i = 0; i < nprocs; ++i) {
401 double d = buf[i].IdleTime.QuadPart * 1e-7;
403 Store_double_field (res_v, i, d);
405 CAMLreturn (res_v);
408 CAMLprim value ml_get_hz (value unit_v)
410 CAMLparam1 (unit_v);
411 CAMLreturn (Val_int (100));
414 CAMLprim value ml_nice (value nice_v)
416 CAMLparam1 (nice_v);
417 int niceval = Int_val (nice_v);
419 failwith_fmt ("nice: not implemented on Windows");
420 CAMLreturn (Val_unit);
423 CAMLprim value ml_seticon (value data_v)
425 CAMLparam1 (data_v);
426 CAMLreturn (Val_unit);
429 CAMLprim value ml_delay (value secs_v)
431 CAMLparam1 (secs_v);
432 DWORD millis = (DWORD) (Double_val (secs_v) * 1e4);
434 caml_enter_blocking_section ();
436 Sleep (millis);
438 caml_leave_blocking_section ();
439 CAMLreturn (Val_unit);
442 CAMLprim value ml_is_winnt (value unit_v)
444 CAMLparam1 (unit_v);
445 OSVERSIONINFO ovi;
447 ovi.dwOSVersionInfoSize = sizeof (ovi);
448 if (!GetVersionEx (&ovi)) {
449 failwith_fmt ("Could not get version information: %#lx",
450 GetLastError ());
453 if (ovi.dwPlatformId != VER_PLATFORM_WIN32_NT) {
454 caml_failwith ("Only NT family of Windows is supported by APC");
457 CAMLreturn (Val_true);
460 #else
461 #error This operating system is not supported
462 #endif