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 <stdio.h>
  12 #include <stdarg.h>
  13
  14 #ifdef _MSC_VER
  15 #define vsnprintf _vsnprintf
  16 #endif
  17
  18 static void failwith_fmt (const char *fmt, ...) Noreturn;
  19 static void failwith_fmt (const char *fmt, ...)
  20 {
  21     va_list ap;
  22     char buf[1024];
  23
  24     va_start (ap, fmt);
  25     vsnprintf (buf, sizeof (buf), fmt, ap);
  26     va_end (ap);
  27
  28     failwith (buf);
  29 }
  30
  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>
  40
  41 CAMLprim value ml_waitalrm (value unit_v)
  42 {
  43     CAMLparam1 (unit_v);
  44     sigset_t set;
  45     int signr;
  46
  47     sigemptyset (&set);
  48     sigaddset (&set, SIGALRM);
  49
  50     caml_enter_blocking_section ();
  51     {
  52         if (sigwait (&set, &signr)) {
  53             failwith_fmt ("sigwait: %s", strerror (errno));
  54         }
  55     }
  56     caml_leave_blocking_section ();
  57
  58     CAMLreturn (Val_unit);
  59 }
  60
  61 CAMLprim value ml_sysinfo (value unit_v)
  62 {
  63     CAMLparam1 (unit_v);
  64     CAMLlocal2 (res_v, loads_v);
  65     struct sysinfo si;
  66
  67     if (sysinfo (&si)) {
  68         failwith_fmt ("sysinfo: %s", strerror (errno));
  69     }
  70
  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]));
  75
  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));
  86
  87     CAMLreturn (res_v);
  88 }
  89
  90 CAMLprim value ml_get_nprocs (value unit_v)
  91 {
  92     CAMLparam1 (unit_v);
  93     int nprocs;
  94
  95     nprocs = get_nprocs ();
  96     if (nprocs <= 0) {
  97         failwith_fmt ("get_nprocs: %s", strerror (errno));
  98     }
  99
 100     CAMLreturn (Val_int (nprocs));
 101 }
 102
 103 CAMLprim value ml_idletimeofday (value fd_v, value nprocs_v)
 104 {
 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;
 114
 115     buf = alloca (n);
 116     if (!buf) {
 117         failwith_fmt ("alloca: %s", strerror (errno));
 118     }
 119
 120     m = read (fd, buf, n);
 121     if (n - m) {
 122         failwith_fmt ("read [n=%zu, m=%zi]: %s", n, m, strerror (errno));
 123     }
 124
 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;
 128
 129         Store_double_field (res_v, i, d);
 130     }
 131     CAMLreturn (res_v);
 132 }
 133
 134 CAMLprim value ml_get_hz (value unit_v)
 135 {
 136     CAMLparam1 (unit_v);
 137     CAMLreturn (Val_int (sysconf (_SC_CLK_TCK)));
 138 }
 139
 140 CAMLprim value ml_nice (value nice_v)
 141 {
 142     CAMLparam1 (nice_v);
 143     int niceval = Int_val (nice_v);
 144
 145     if (!nice (niceval)) {
 146         failwith_fmt ("nice %d: %s", niceval, strerror (errno));
 147     }
 148
 149     CAMLreturn (Val_unit);
 150 }
 151
 152 #include <X11/X.h>
 153 #include <X11/Xmd.h>
 154 #include <X11/Xlib.h>
 155 #include <X11/Xatom.h>
 156
 157 #include <GL/glx.h>
 158
 159 struct X11State {
 160     Display *dpy;
 161     Window id;
 162     Atom property;
 163     int error;
 164 };
 165
 166 CAMLprim value ml_seticon (value data_v)
 167 {
 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;
 174
 175     if (!s->error) {
 176         if (!s->dpy) {
 177             s->dpy = XOpenDisplay (NULL);
 178             if (!s->dpy) {
 179                 goto err0;
 180             }
 181             else {
 182                 /* "tiny bit" hackish */
 183                 s->id = glXGetCurrentDrawable ();
 184                 if (s->id == None) {
 185                     goto err1;
 186                 }
 187
 188                 s->property = XInternAtom (s->dpy, "_NET_WM_ICON", False);
 189                 if (s->property == None){
 190                     goto err1;
 191                 }
 192
 193 #ifdef DEBUG
 194                 printf ("id = %#x, property = %d\n",
 195                         (int) s->id, (int) s->property);
 196 #endif
 197             }
 198         }
 199     }
 200
 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);
 205
 206     CAMLreturn (Val_unit);
 207
 208  err1:
 209     XCloseDisplay (s->dpy);
 210  err0:
 211     s->error = 1;
 212     CAMLreturn (Val_unit);
 213 }
 214
 215 CAMLprim value ml_delay (value secs_v)
 216 {
 217     CAMLparam1 (secs_v);
 218     failwith ("delay is not implemented on non-Windows");
 219     CAMLreturn (Val_unit);
 220 }
 221
 222 CAMLprim value ml_is_winnt (value unit_v)
 223 {
 224     CAMLparam1 (unit_v);
 225     CAMLreturn (Val_false);
 226 }
 227
 228 #elif defined _WIN32
 229
 230 #pragma warning (disable:4152 4127 4189)
 231 #define WIN32_LEAN_AND_MEAN
 232 #include <windows.h>
 233
 234 #define DDKFASTAPI __fastcall
 235 #define NTSTATUS long
 236 #define BOOLEAN int
 237
 238 /* Following (mildly modified) structure definitions, macros, enums,
 239    etc are taken from binutils w32api (http://sourceware.org/binutils/)
 240    Headers claim:
 241  */
 242 /*
 243  * ntpoapi.h
 244  * ntddk.h
 245  ...
 246  * This file is part of the w32api package.
 247  *
 248  * Contributors:
 249  *   Created by Casper S. Hornstrup <chorns@users.sourceforge.net>
 250  *
 251  * THIS SOFTWARE IS NOT COPYRIGHTED
 252  *
 253  * This source code is offered for use in the public domain. You may
 254  * use, modify or distribute it freely.
 255  *
 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.
 260  *
 261  */
 262
 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;
 276
 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;
 285
 286 typedef long (__stdcall *QuerySystemInformationProc)
 287     (SYSTEM_INFORMATION_CLASS, PVOID, ULONG, PULONG);
 288
 289 static struct {
 290     HMODULE hmod;
 291     QuerySystemInformationProc QuerySystemInformation;
 292     ULONG nprocs;
 293 } glob;
 294
 295 static void init (void)
 296 {
 297     if (!glob.hmod) {
 298         glob.hmod = LoadLibrary ("ntdll.dll");
 299         if (!glob.hmod) {
 300             failwith_fmt ("could not load ntdll.dll: %#lx", GetLastError ());
 301         }
 302
 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 ());
 309         }
 310     }
 311 }
 312
 313 static void qsi (int c, PVOID buf, ULONG size)
 314 {
 315     ULONG retsize = 0;
 316     long status;
 317
 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);
 322     }
 323     if (retsize != size) {
 324         fprintf (stderr, "class=%d status=%ld size=%d retsize=%d\n",
 325                  c, status, size, retsize);
 326     }
 327 #ifdef DEBUG
 328     printf ("class=%d status=%ld size=%d retsize=%d\n",
 329             c, status, size, retsize);
 330 #endif
 331 }
 332
 333 CAMLprim value ml_waitalrm (value unit_v)
 334 {
 335     CAMLparam1 (unit_v);
 336
 337     failwith ("waitalrm not supported on Windows");
 338     CAMLreturn (Val_unit);
 339 }
 340
 341 static void get_nprocs (void)
 342 {
 343     SYSTEM_BASIC_INFORMATION sbi;
 344
 345     qsi (0, &sbi, sizeof (sbi));
 346     glob.nprocs = sbi.NumberProcessors;
 347 }
 348
 349 CAMLprim value ml_sysinfo (value unit_v)
 350 {
 351     CAMLparam1 (unit_v);
 352     CAMLlocal2 (res_v, loads_v);
 353
 354     get_nprocs ();
 355
 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));
 360
 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);
 371
 372     CAMLreturn (res_v);
 373 }
 374
 375 CAMLprim value ml_get_nprocs (value unit_v)
 376 {
 377     CAMLparam1 (unit_v);
 378
 379     get_nprocs ();
 380     CAMLreturn (Val_int (glob.nprocs));
 381 }
 382
 383 CAMLprim value ml_idletimeofday (value fd_v, value nprocs_v)
 384 {
 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;
 391
 392     buf = _alloca (n);
 393     if (!buf) {
 394         failwith_fmt ("alloca: %s", strerror (errno));
 395     }
 396
 397     qsi (8, buf, n);
 398
 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;
 402
 403         Store_double_field (res_v, i, d);
 404     }
 405     CAMLreturn (res_v);
 406 }
 407
 408 CAMLprim value ml_get_hz (value unit_v)
 409 {
 410     CAMLparam1 (unit_v);
 411     CAMLreturn (Val_int (100));
 412 }
 413
 414 CAMLprim value ml_nice (value nice_v)
 415 {
 416     CAMLparam1 (nice_v);
 417     int niceval = Int_val (nice_v);
 418
 419     failwith_fmt ("nice: not implemented on Windows");
 420     CAMLreturn (Val_unit);
 421 }
 422
 423 CAMLprim value ml_seticon (value data_v)
 424 {
 425     CAMLparam1 (data_v);
 426     CAMLreturn (Val_unit);
 427 }
 428
 429 CAMLprim value ml_delay (value secs_v)
 430 {
 431     CAMLparam1 (secs_v);
 432     DWORD millis = (DWORD) (Double_val (secs_v) * 1e4);
 433
 434     caml_enter_blocking_section ();
 435     {
 436         Sleep (millis);
 437     }
 438     caml_leave_blocking_section ();
 439     CAMLreturn (Val_unit);
 440 }
 441
 442 CAMLprim value ml_is_winnt (value unit_v)
 443 {
 444     CAMLparam1 (unit_v);
 445     OSVERSIONINFO ovi;
 446
 447     ovi.dwOSVersionInfoSize = sizeof (ovi);
 448     if (!GetVersionEx (&ovi)) {
 449         failwith_fmt ("Could not get version information: %#lx",
 450                       GetLastError ());
 451     }
 452
 453     if (ovi.dwPlatformId != VER_PLATFORM_WIN32_NT) {
 454         caml_failwith ("Only NT family of Windows is supported by APC");
 455     }
 456
 457     CAMLreturn (Val_true);
 458 }
 459
 460 #else
 461 #error This operating system is not supported
 462 #endif