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 <alloca.h>
  12 #include <unistd.h>
  13 #include <stdarg.h>
  14 #include <stdio.h>
  15 #include <sys/time.h>
  16 #include <sys/time.h>
  17 #include <sys/sysinfo.h>
  18 #include <signal.h>
  19 #include <string.h>
  20 #include <errno.h>
  21
  22 static void failwith_fmt (const char *fmt, ...) Noreturn;
  23 static void failwith_fmt (const char *fmt, ...)
  24 {
  25     va_list ap;
  26     char buf[1024];
  27
  28     va_start (ap, fmt);
  29     vsnprintf (buf, sizeof (buf), fmt, ap);
  30     va_end (ap);
  31
  32     failwith (buf);
  33 }
  34
  35 CAMLprim value ml_waitalrm (value unit_v)
  36 {
  37     CAMLparam1 (unit_v);
  38     sigset_t set;
  39     int signr;
  40
  41     sigemptyset (&set);
  42     sigaddset (&set, SIGALRM);
  43
  44     caml_enter_blocking_section ();
  45     {
  46         if (sigwait (&set, &signr)) {
  47             failwith_fmt ("sigwait: %s", strerror (errno));
  48         }
  49     }
  50     caml_leave_blocking_section ();
  51
  52     CAMLreturn (Val_unit);
  53 }
  54
  55 CAMLprim value ml_sysinfo (value unit_v)
  56 {
  57     CAMLparam1 (unit_v);
  58     CAMLlocal2 (res_v, loads_v);
  59     struct sysinfo si;
  60
  61     if (sysinfo (&si)) {
  62         failwith_fmt ("sysinfo: %s", strerror (errno));
  63     }
  64
  65     loads_v = caml_alloc_tuple (3);
  66     Store_field (loads_v, 0, caml_copy_int64 (si.loads[0]));
  67     Store_field (loads_v, 1, caml_copy_int64 (si.loads[1]));
  68     Store_field (loads_v, 2, caml_copy_int64 (si.loads[2]));
  69
  70     res_v = caml_alloc_tuple (9);
  71     Store_field (res_v, 0, caml_copy_int64 (si.uptime));
  72     Store_field (res_v, 1, loads_v);
  73     Store_field (res_v, 2, caml_copy_int64 (si.totalram));
  74     Store_field (res_v, 3, caml_copy_int64 (si.freeram));
  75     Store_field (res_v, 4, caml_copy_int64 (si.sharedram));
  76     Store_field (res_v, 5, caml_copy_int64 (si.bufferram));
  77     Store_field (res_v, 6, caml_copy_int64 (si.totalswap));
  78     Store_field (res_v, 7, caml_copy_int64 (si.freeswap));
  79     Store_field (res_v, 8, caml_copy_int64 (si.procs));
  80
  81     CAMLreturn (res_v);
  82 }
  83
  84 CAMLprim value ml_get_nprocs (value unit_v)
  85 {
  86     CAMLparam1 (unit_v);
  87     int nprocs;
  88
  89     nprocs = get_nprocs ();
  90     if (nprocs <= 0) {
  91         failwith_fmt ("get_nprocs: %s", strerror (errno));
  92     }
  93
  94     CAMLreturn (Val_int (nprocs));
  95 }
  96
  97 CAMLprim value ml_idletimeofday (value fd_v, value nprocs_v)
  98 {
  99     CAMLparam2 (fd_v, nprocs_v);
 100     CAMLlocal1 (res_v);
 101     struct timeval tv;
 102     int fd = Int_val (fd_v);
 103     int nprocs = Int_val (nprocs_v);
 104     size_t n = nprocs * sizeof (tv);
 105     ssize_t m;
 106     struct timeval *buf;
 107     int i;
 108
 109     buf = alloca (n);
 110     if (!buf) {
 111         failwith_fmt ("alloca: %s", strerror (errno));
 112     }
 113
 114     m = read (fd, buf, n);
 115     if (n - m) {
 116         failwith_fmt ("read [n=%zu, m=%zi]: %s", n, m, strerror (errno));
 117     }
 118
 119     res_v = caml_alloc (nprocs * Double_wosize, Double_array_tag);
 120     for (i = 0; i < nprocs; ++i) {
 121         double d = buf[i].tv_sec + buf[i].tv_usec * 1e-6;
 122
 123         Store_double_field (res_v, i, d);
 124     }
 125     CAMLreturn (res_v);
 126 }
 127
 128 CAMLprim value ml_get_hz (value unit_v)
 129 {
 130     CAMLparam1 (unit_v);
 131     CAMLreturn (Val_int (sysconf (_SC_CLK_TCK)));
 132 }
 133
 134 CAMLprim value ml_nice (value nice_v)
 135 {
 136     CAMLparam1 (nice_v);
 137     int niceval = Int_val (nice_v);
 138
 139     if (!nice (niceval)) {
 140         failwith_fmt ("nice %d: %s", niceval, strerror (errno));
 141     }
 142
 143     CAMLreturn (Val_unit);
 144 }
 145
 146 #include <X11/X.h>
 147 #include <X11/Xmd.h>
 148 #include <X11/Xlib.h>
 149 #include <X11/Xatom.h>
 150
 151 #include <GL/glx.h>
 152
 153 struct X11State {
 154     Display *dpy;
 155     Window id;
 156     Atom property;
 157     int error;
 158 };
 159
 160 CAMLprim value ml_seticon (value data_v)
 161 {
 162     CAMLparam1 (data_v);
 163     static struct X11State static_state;
 164     struct X11State *s = &static_state;
 165     void *ptr = String_val (data_v);
 166     CARD32 *p = ptr;
 167     unsigned char *data = ptr;
 168
 169     if (!s->error) {
 170         if (!s->dpy) {
 171             s->dpy = XOpenDisplay (NULL);
 172             if (!s->dpy) {
 173                 goto err0;
 174             }
 175             else {
 176                 /* "tiny bit" hackish */
 177                 s->id = glXGetCurrentDrawable ();
 178                 if (s->id == None) {
 179                     goto err1;
 180                 }
 181
 182                 s->property = XInternAtom (s->dpy, "_NET_WM_ICON", False);
 183                 if (s->property == None){
 184                     goto err1;
 185                 }
 186
 187 #ifdef DEBUG
 188                 printf ("id = %#x, property = %d\n",
 189                         (int) s->id, (int) s->property);
 190 #endif
 191             }
 192         }
 193     }
 194
 195     p[0] = 32;
 196     p[1] = 32;
 197     XChangeProperty (s->dpy, s->id, s->property, XA_CARDINAL,
 198                      32, PropModeReplace, data, 32 * 32 + 2);
 199
 200     CAMLreturn (Val_unit);
 201
 202  err1:
 203     XCloseDisplay (s->dpy);
 204  err0:
 205     s->error = 1;
 206     CAMLreturn (Val_unit);
 207 }