ml_apc.c

   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>
  10
  11 #include <math.h>
  12 #include <stdio.h>
  13 #include <stdarg.h>
  14
  15 #ifdef _MSC_VER
  16 #define vsnprintf _vsnprintf
  17 #endif
  18
  19 static void failwith_fmt (const char *fmt, ...) Noreturn;
  20 static void failwith_fmt (const char *fmt, ...)
  21 {
  22     va_list ap;
  23     char buf[1024];
  24
  25     va_start (ap, fmt);
  26     vsnprintf (buf, sizeof (buf), fmt, ap);
  27     va_end (ap);
  28
  29     failwith (buf);
  30 }
  31
  32 #if defined __linux__
  33 #include <alloca.h>
  34 #include <unistd.h>
  35 #include <sys/time.h>
  36 #include <sys/time.h>
  37 #include <sys/sysinfo.h>
  38 #include <signal.h>
  39 #include <string.h>
  40 #include <errno.h>
  41
  42 CAMLprim value ml_waitalrm (value unit_v)
  43 {
  44     CAMLparam1 (unit_v);
  45     sigset_t set;
  46     int signr;
  47
  48     sigemptyset (&set);
  49     sigaddset (&set, SIGALRM);
  50
  51     caml_enter_blocking_section ();
  52     {
  53         if (sigwait (&set, &signr)) {
  54             failwith_fmt ("sigwait: %s", strerror (errno));
  55         }
  56     }
  57     caml_leave_blocking_section ();
  58
  59     CAMLreturn (Val_unit);
  60 }
  61
  62 CAMLprim value ml_sysinfo (value unit_v)
  63 {
  64     CAMLparam1 (unit_v);
  65     CAMLlocal2 (res_v, loads_v);
  66     struct sysinfo si;
  67
  68     if (sysinfo (&si)) {
  69         failwith_fmt ("sysinfo: %s", strerror (errno));
  70     }
  71
  72     loads_v = caml_alloc_tuple (3);
  73     Store_field (loads_v, 0, caml_copy_int64 (si.loads[0]));
  74     Store_field (loads_v, 1, caml_copy_int64 (si.loads[1]));
  75     Store_field (loads_v, 2, caml_copy_int64 (si.loads[2]));
  76
  77     res_v = caml_alloc_tuple (9);
  78     Store_field (res_v, 0, caml_copy_int64 (si.uptime));
  79     Store_field (res_v, 1, loads_v);
  80     Store_field (res_v, 2, caml_copy_int64 (si.totalram));
  81     Store_field (res_v, 3, caml_copy_int64 (si.freeram));
  82     Store_field (res_v, 4, caml_copy_int64 (si.sharedram));
  83     Store_field (res_v, 5, caml_copy_int64 (si.bufferram));
  84     Store_field (res_v, 6, caml_copy_int64 (si.totalswap));
  85     Store_field (res_v, 7, caml_copy_int64 (si.freeswap));
  86     Store_field (res_v, 8, caml_copy_int64 (si.procs));
  87
  88     CAMLreturn (res_v);
  89 }
  90
  91 CAMLprim value ml_get_nprocs (value unit_v)
  92 {
  93     CAMLparam1 (unit_v);
  94     int nprocs;
  95
  96     nprocs = get_nprocs ();
  97     if (nprocs <= 0) {
  98         failwith_fmt ("get_nprocs: %s", strerror (errno));
  99     }
 100
 101     CAMLreturn (Val_int (nprocs));
 102 }
 103
 104 CAMLprim value ml_idletimeofday (value fd_v, value nprocs_v)
 105 {
 106     CAMLparam2 (fd_v, nprocs_v);
 107     CAMLlocal1 (res_v);
 108     struct timeval tv;
 109     int fd = Int_val (fd_v);
 110     int nprocs = Int_val (nprocs_v);
 111     size_t n = nprocs * sizeof (tv);
 112     ssize_t m;
 113     struct timeval *buf;
 114     int i;
 115
 116     buf = alloca (n);
 117     if (!buf) {
 118         failwith_fmt ("alloca: %s", strerror (errno));
 119     }
 120
 121     m = read (fd, buf, n);
 122     if (n - m) {
 123         failwith_fmt ("read [n=%zu, m=%zi]: %s", n, m, strerror (errno));
 124     }
 125
 126     res_v = caml_alloc (nprocs * Double_wosize, Double_array_tag);
 127     for (i = 0; i < nprocs; ++i) {
 128         double d;
 129
 130         d = buf[i].tv_sec + buf[i].tv_usec * 1e-6;
 131         Store_double_field (res_v, i, d);
 132     }
 133     CAMLreturn (res_v);
 134 }
 135
 136 CAMLprim value ml_get_hz (value unit_v)
 137 {
 138     CAMLparam1 (unit_v);
 139     CAMLreturn (Val_int (sysconf (_SC_CLK_TCK)));
 140 }
 141
 142 CAMLprim value ml_nice (value nice_v)
 143 {
 144     CAMLparam1 (nice_v);
 145     int niceval = Int_val (nice_v);
 146
 147     if (!nice (niceval)) {
 148         failwith_fmt ("nice %d: %s", niceval, strerror (errno));
 149     }
 150
 151     CAMLreturn (Val_unit);
 152 }
 153
 154 #include <X11/X.h>
 155 #include <X11/Xmd.h>
 156 #include <X11/Xlib.h>
 157 #include <X11/Xatom.h>
 158
 159 #include <GL/glx.h>
 160
 161 struct X11State {
 162     Display *dpy;
 163     Window id;
 164     Atom property;
 165     int error;
 166 };
 167
 168 CAMLprim value ml_seticon (value data_v)
 169 {
 170     CAMLparam1 (data_v);
 171     static struct X11State static_state;
 172     struct X11State *s = &static_state;
 173     void *ptr = String_val (data_v);
 174     CARD32 *p = ptr;
 175     unsigned char *data = ptr;
 176
 177     if (!s->error) {
 178         if (!s->dpy) {
 179             s->dpy = XOpenDisplay (NULL);
 180             if (!s->dpy) {
 181                 goto err0;
 182             }
 183             else {
 184                 /* "tiny bit" hackish */
 185                 s->id = glXGetCurrentDrawable ();
 186                 if (s->id == None) {
 187                     goto err1;
 188                 }
 189
 190                 s->property = XInternAtom (s->dpy, "_NET_WM_ICON", False);
 191                 if (s->property == None){
 192                     goto err1;
 193                 }
 194
 195 #ifdef DEBUG
 196                 printf ("id = %#x, property = %d\n",
 197                         (int) s->id, (int) s->property);
 198 #endif
 199             }
 200         }
 201     }
 202     else {
 203         CAMLreturn (Val_unit);
 204     }
 205
 206     p[0] = 32;
 207     p[1] = 32;
 208     XChangeProperty (s->dpy, s->id, s->property, XA_CARDINAL,
 209                      32, PropModeReplace, data, 32 * 32 + 2);
 210
 211     CAMLreturn (Val_unit);
 212
 213  err1:
 214     XCloseDisplay (s->dpy);
 215  err0:
 216     s->error = 1;
 217     CAMLreturn (Val_unit);
 218 }
 219
 220 CAMLprim value ml_delay (value secs_v)
 221 {
 222     CAMLparam1 (secs_v);
 223     failwith ("delay is not implemented on non-Windows");
 224     CAMLreturn (Val_unit);
 225 }
 226
 227 CAMLprim value ml_is_winnt (value unit_v)
 228 {
 229     CAMLparam1 (unit_v);
 230     CAMLreturn (Val_false);
 231 }
 232
 233 #elif defined _WIN32
 234
 235 #pragma warning (disable:4152 4127 4189)
 236 #define WIN32_LEAN_AND_MEAN
 237 #include <windows.h>
 238
 239 #define DDKFASTAPI __fastcall
 240 #define NTSTATUS long
 241 #define BOOLEAN int
 242
 243 /* Following (mildly modified) structure definitions, macros, enums,
 244    etc are taken from binutils w32api (http://sourceware.org/binutils/)
 245    Headers claim:
 246  */
 247 /*
 248  * ntpoapi.h
 249  * ntddk.h
 250  ...
 251  * This file is part of the w32api package.
 252  *
 253  * Contributors:
 254  *   Created by Casper S. Hornstrup <chorns@users.sourceforge.net>
 255  *
 256  * THIS SOFTWARE IS NOT COPYRIGHTED
 257  *
 258  * This source code is offered for use in the public domain. You may
 259  * use, modify or distribute it freely.
 260  *
 261  * This code is distributed in the hope that it will be useful but
 262  * WITHOUT ANY WARRANTY. ALL WARRANTIES, EXPRESS OR IMPLIED ARE HEREBY
 263  * DISCLAIMED. This includes but is not limited to warranties of
 264  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 265  *
 266  */
 267
 268 typedef struct _SYSTEM_BASIC_INFORMATION {
 269     ULONG  Unknown;
 270     ULONG  MaximumIncrement;
 271     ULONG  PhysicalPageSize;
 272     ULONG  NumberOfPhysicalPages;
 273     ULONG  LowestPhysicalPage;
 274     ULONG  HighestPhysicalPage;
 275     ULONG  AllocationGranularity;
 276     ULONG  LowestUserAddress;
 277     ULONG  HighestUserAddress;
 278     ULONG  ActiveProcessors;
 279     UCHAR  NumberProcessors;
 280 } SYSTEM_BASIC_INFORMATION, *PSYSTEM_BASIC_INFORMATION;
 281
 282 typedef struct _SYSTEM_PROCESSOR_TIMES {
 283     LARGE_INTEGER  IdleTime;
 284     LARGE_INTEGER  KernelTime;
 285     LARGE_INTEGER  UserTime;
 286     LARGE_INTEGER  DpcTime;
 287     LARGE_INTEGER  InterruptTime;
 288     ULONG  InterruptCount;
 289 } SYSTEM_PROCESSOR_TIMES, *PSYSTEM_PROCESSOR_TIMES;
 290
 291 typedef long (__stdcall *QuerySystemInformationProc)
 292     (SYSTEM_INFORMATION_CLASS, PVOID, ULONG, PULONG);
 293
 294 static struct {
 295     HMODULE hmod;
 296     QuerySystemInformationProc QuerySystemInformation;
 297     ULONG nprocs;
 298 } glob;
 299
 300 static void init (void)
 301 {
 302     if (!glob.hmod) {
 303         glob.hmod = LoadLibrary ("ntdll.dll");
 304         if (!glob.hmod) {
 305             failwith_fmt ("could not load ntdll.dll: %#lx", GetLastError ());
 306         }
 307
 308         *(void **) &glob.QuerySystemInformation =
 309             GetProcAddress (glob.hmod, "ZwQuerySystemInformation");
 310         if (!glob.QuerySystemInformation) {
 311             failwith_fmt (
 312                 "could not obtain ZwQuerySystemInformation entry point: %#lx\n",
 313                 GetLastError ());
 314         }
 315     }
 316 }
 317
 318 static void qsi (int c, PVOID buf, ULONG size)
 319 {
 320     ULONG retsize = 0;
 321     long status;
 322
 323     init ();
 324     status = glob.QuerySystemInformation (c, buf, size, &retsize);
 325     if (status < 0) {
 326         failwith_fmt ("could not query system information %d\n", c);
 327     }
 328     if (retsize != size) {
 329         fprintf (stderr, "class=%d status=%ld size=%d retsize=%d\n",
 330                  c, status, size, retsize);
 331     }
 332 #ifdef DEBUG
 333     printf ("class=%d status=%ld size=%d retsize=%d\n",
 334             c, status, size, retsize);
 335 #endif
 336 }
 337
 338 CAMLprim value ml_waitalrm (value unit_v)
 339 {
 340     CAMLparam1 (unit_v);
 341
 342     failwith ("waitalrm not supported on Windows");
 343     CAMLreturn (Val_unit);
 344 }
 345
 346 static void get_nprocs (void)
 347 {
 348     SYSTEM_BASIC_INFORMATION sbi;
 349
 350     qsi (0, &sbi, sizeof (sbi));
 351     glob.nprocs = sbi.NumberProcessors;
 352 }
 353
 354 CAMLprim value ml_sysinfo (value unit_v)
 355 {
 356     CAMLparam1 (unit_v);
 357     CAMLlocal2 (res_v, loads_v);
 358
 359     get_nprocs ();
 360
 361     loads_v = caml_alloc_tuple (3);
 362     Store_field (loads_v, 0, caml_copy_int64 (0));
 363     Store_field (loads_v, 1, caml_copy_int64 (0));
 364     Store_field (loads_v, 2, caml_copy_int64 (0));
 365
 366     res_v = caml_alloc_tuple (9);
 367     Store_field (res_v, 0, 0);
 368     Store_field (res_v, 1, loads_v);
 369     Store_field (res_v, 2, 0);
 370     Store_field (res_v, 3, 0);
 371     Store_field (res_v, 4, 0);
 372     Store_field (res_v, 5, 0);
 373     Store_field (res_v, 6, 0);
 374     Store_field (res_v, 7, 0);
 375     Store_field (res_v, 8, glob.nprocs);
 376
 377     CAMLreturn (res_v);
 378 }
 379
 380 CAMLprim value ml_get_nprocs (value unit_v)
 381 {
 382     CAMLparam1 (unit_v);
 383
 384     get_nprocs ();
 385     CAMLreturn (Val_int (glob.nprocs));
 386 }
 387
 388 CAMLprim value ml_idletimeofday (value fd_v, value nprocs_v)
 389 {
 390     CAMLparam2 (fd_v, nprocs_v);
 391     CAMLlocal1 (res_v);
 392     int nprocs = Int_val (nprocs_v);
 393     PSYSTEM_PROCESSOR_TIMES buf;
 394     size_t n = nprocs * sizeof (*buf);
 395     int i;
 396
 397     buf = _alloca (n);
 398     if (!buf) {
 399         failwith_fmt ("alloca: %s", strerror (errno));
 400     }
 401
 402     qsi (8, buf, n);
 403
 404     res_v = caml_alloc (nprocs * Double_wosize, Double_array_tag);
 405     for (i = 0; i < nprocs; ++i) {
 406         double d = buf[i].IdleTime.QuadPart * 1e-7;
 407
 408         Store_double_field (res_v, i, d);
 409     }
 410     CAMLreturn (res_v);
 411 }
 412
 413 CAMLprim value ml_get_hz (value unit_v)
 414 {
 415     CAMLparam1 (unit_v);
 416     CAMLreturn (Val_int (100));
 417 }
 418
 419 CAMLprim value ml_nice (value nice_v)
 420 {
 421     CAMLparam1 (nice_v);
 422     int niceval = Int_val (nice_v);
 423
 424     failwith_fmt ("nice: not implemented on Windows");
 425     CAMLreturn (Val_unit);
 426 }
 427
 428 CAMLprim value ml_seticon (value data_v)
 429 {
 430     CAMLparam1 (data_v);
 431     CAMLreturn (Val_unit);
 432 }
 433
 434 CAMLprim value ml_delay (value secs_v)
 435 {
 436     CAMLparam1 (secs_v);
 437     DWORD millis = (DWORD) (Double_val (secs_v) * 1e4);
 438
 439     caml_enter_blocking_section ();
 440     {
 441         Sleep (millis);
 442     }
 443     caml_leave_blocking_section ();
 444     CAMLreturn (Val_unit);
 445 }
 446
 447 CAMLprim value ml_is_winnt (value unit_v)
 448 {
 449     CAMLparam1 (unit_v);
 450     OSVERSIONINFO ovi;
 451
 452     ovi.dwOSVersionInfoSize = sizeof (ovi);
 453     if (!GetVersionEx (&ovi)) {
 454         failwith_fmt ("Could not get version information: %#lx",
 455                       GetLastError ());
 456     }
 457
 458     if (ovi.dwPlatformId != VER_PLATFORM_WIN32_NT) {
 459         caml_failwith ("Only NT family of Windows is supported by APC");
 460     }
 461
 462     CAMLreturn (Val_true);
 463 }
 464
 465 #else
 466 #error This operating system is not supported
 467 #endif