1 #define _XOPEN_SOURCE 700
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>
16 #define vsnprintf _vsnprintf
19 static void failwith_fmt (const char *fmt
, ...) Noreturn
;
20 static void failwith_fmt (const char *fmt
, ...)
26 vsnprintf (buf
, sizeof (buf
), fmt
, ap
);
37 #include <sys/sysinfo.h>
42 CAMLprim value
ml_waitalrm (value unit_v
)
49 sigaddset (&set
, SIGALRM
);
51 caml_enter_blocking_section ();
53 if (sigwait (&set
, &signr
)) {
54 failwith_fmt ("sigwait: %s", strerror (errno
));
57 caml_leave_blocking_section ();
59 CAMLreturn (Val_unit
);
62 CAMLprim value
ml_sysinfo (value unit_v
)
65 CAMLlocal2 (res_v
, loads_v
);
69 failwith_fmt ("sysinfo: %s", strerror (errno
));
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]));
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
));
91 CAMLprim value
ml_get_nprocs (value unit_v
)
96 nprocs
= get_nprocs ();
98 failwith_fmt ("get_nprocs: %s", strerror (errno
));
101 CAMLreturn (Val_int (nprocs
));
104 CAMLprim value
ml_idletimeofday (value fd_v
, value nprocs_v
)
106 CAMLparam2 (fd_v
, nprocs_v
);
109 int fd
= Int_val (fd_v
);
110 int nprocs
= Int_val (nprocs_v
);
111 size_t n
= nprocs
* sizeof (tv
);
118 failwith_fmt ("alloca: %s", strerror (errno
));
121 m
= read (fd
, buf
, n
);
123 failwith_fmt ("read [n=%zu, m=%zi]: %s", n
, m
, strerror (errno
));
126 res_v
= caml_alloc (nprocs
* Double_wosize
, Double_array_tag
);
127 for (i
= 0; i
< nprocs
; ++i
) {
130 d
= buf
[i
].tv_sec
+ buf
[i
].tv_usec
* 1e-6;
131 Store_double_field (res_v
, i
, d
);
136 CAMLprim value
ml_get_hz (value unit_v
)
139 CAMLreturn (Val_int (sysconf (_SC_CLK_TCK
)));
142 CAMLprim value
ml_nice (value nice_v
)
145 int niceval
= Int_val (nice_v
);
147 if (!nice (niceval
)) {
148 failwith_fmt ("nice %d: %s", niceval
, strerror (errno
));
151 CAMLreturn (Val_unit
);
156 #include <X11/Xlib.h>
157 #include <X11/Xatom.h>
168 CAMLprim value
ml_seticon (value data_v
)
171 static struct X11State static_state
;
172 struct X11State
*s
= &static_state
;
173 void *ptr
= String_val (data_v
);
175 unsigned char *data
= ptr
;
179 s
->dpy
= XOpenDisplay (NULL
);
184 /* "tiny bit" hackish */
185 s
->id
= glXGetCurrentDrawable ();
190 s
->property
= XInternAtom (s
->dpy
, "_NET_WM_ICON", False
);
191 if (s
->property
== None
){
196 printf ("id = %#x, property = %d\n",
197 (int) s
->id
, (int) s
->property
);
203 CAMLreturn (Val_unit
);
208 XChangeProperty (s
->dpy
, s
->id
, s
->property
, XA_CARDINAL
,
209 32, PropModeReplace
, data
, 32 * 32 + 2);
211 CAMLreturn (Val_unit
);
214 XCloseDisplay (s
->dpy
);
217 CAMLreturn (Val_unit
);
220 CAMLprim value
ml_delay (value secs_v
)
223 failwith ("delay is not implemented on non-Windows");
224 CAMLreturn (Val_unit
);
227 CAMLprim value
ml_is_winnt (value unit_v
)
230 CAMLreturn (Val_false
);
235 #pragma warning (disable:4152 4127 4189)
236 #define WIN32_LEAN_AND_MEAN
239 #define DDKFASTAPI __fastcall
240 #define NTSTATUS long
243 /* Following (mildly modified) structure definitions, macros, enums,
244 etc are taken from binutils w32api (http://sourceware.org/binutils/)
251 * This file is part of the w32api package.
254 * Created by Casper S. Hornstrup <chorns@users.sourceforge.net>
256 * THIS SOFTWARE IS NOT COPYRIGHTED
258 * This source code is offered for use in the public domain. You may
259 * use, modify or distribute it freely.
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.
268 typedef struct _SYSTEM_BASIC_INFORMATION
{
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
;
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
;
291 typedef long (__stdcall
*QuerySystemInformationProc
)
292 (SYSTEM_INFORMATION_CLASS
, PVOID
, ULONG
, PULONG
);
296 QuerySystemInformationProc QuerySystemInformation
;
300 static void init (void)
303 glob
.hmod
= LoadLibrary ("ntdll.dll");
305 failwith_fmt ("could not load ntdll.dll: %#lx", GetLastError ());
308 *(void **) &glob
.QuerySystemInformation
=
309 GetProcAddress (glob
.hmod
, "ZwQuerySystemInformation");
310 if (!glob
.QuerySystemInformation
) {
312 "could not obtain ZwQuerySystemInformation entry point: %#lx\n",
318 static void qsi (int c
, PVOID buf
, ULONG size
)
324 status
= glob
.QuerySystemInformation (c
, buf
, size
, &retsize
);
326 failwith_fmt ("could not query system information %d\n", c
);
328 if (retsize
!= size
) {
329 fprintf (stderr
, "class=%d status=%ld size=%d retsize=%d\n",
330 c
, status
, size
, retsize
);
333 printf ("class=%d status=%ld size=%d retsize=%d\n",
334 c
, status
, size
, retsize
);
338 CAMLprim value
ml_waitalrm (value unit_v
)
342 failwith ("waitalrm not supported on Windows");
343 CAMLreturn (Val_unit
);
346 static void get_nprocs (void)
348 SYSTEM_BASIC_INFORMATION sbi
;
350 qsi (0, &sbi
, sizeof (sbi
));
351 glob
.nprocs
= sbi
.NumberProcessors
;
354 CAMLprim value
ml_sysinfo (value unit_v
)
357 CAMLlocal2 (res_v
, loads_v
);
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));
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
);
380 CAMLprim value
ml_get_nprocs (value unit_v
)
385 CAMLreturn (Val_int (glob
.nprocs
));
388 CAMLprim value
ml_idletimeofday (value fd_v
, value nprocs_v
)
390 CAMLparam2 (fd_v
, nprocs_v
);
392 int nprocs
= Int_val (nprocs_v
);
393 PSYSTEM_PROCESSOR_TIMES buf
;
394 size_t n
= nprocs
* sizeof (*buf
);
399 failwith_fmt ("alloca: %s", strerror (errno
));
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;
408 Store_double_field (res_v
, i
, d
);
413 CAMLprim value
ml_get_hz (value unit_v
)
416 CAMLreturn (Val_int (100));
419 CAMLprim value
ml_nice (value nice_v
)
422 int niceval
= Int_val (nice_v
);
424 failwith_fmt ("nice: not implemented on Windows");
425 CAMLreturn (Val_unit
);
428 CAMLprim value
ml_seticon (value data_v
)
431 CAMLreturn (Val_unit
);
434 CAMLprim value
ml_delay (value secs_v
)
437 DWORD millis
= (DWORD
) (Double_val (secs_v
) * 1e4
);
439 caml_enter_blocking_section ();
443 caml_leave_blocking_section ();
444 CAMLreturn (Val_unit
);
447 CAMLprim value
ml_is_winnt (value unit_v
)
452 ovi
.dwOSVersionInfoSize
= sizeof (ovi
);
453 if (!GetVersionEx (&ovi
)) {
454 failwith_fmt ("Could not get version information: %#lx",
458 if (ovi
.dwPlatformId
!= VER_PLATFORM_WIN32_NT
) {
459 caml_failwith ("Only NT family of Windows is supported by APC");
462 CAMLreturn (Val_true
);
466 #error This operating system is not supported