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>
15 #define vsnprintf _vsnprintf
18 static void failwith_fmt (const char *fmt
, ...) Noreturn
;
19 static void failwith_fmt (const char *fmt
, ...)
25 vsnprintf (buf
, sizeof (buf
), fmt
, ap
);
36 #include <sys/sysinfo.h>
41 CAMLprim value
ml_waitalrm (value unit_v
)
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
)
64 CAMLlocal2 (res_v
, loads_v
);
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
));
90 CAMLprim value
ml_get_nprocs (value unit_v
)
95 nprocs
= get_nprocs ();
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
);
108 int fd
= Int_val (fd_v
);
109 int nprocs
= Int_val (nprocs_v
);
110 size_t n
= nprocs
* sizeof (tv
);
117 failwith_fmt ("alloca: %s", strerror (errno
));
120 m
= read (fd
, buf
, n
);
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
);
134 CAMLprim value
ml_get_hz (value unit_v
)
137 CAMLreturn (Val_int (sysconf (_SC_CLK_TCK
)));
140 CAMLprim value
ml_nice (value 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
);
154 #include <X11/Xlib.h>
155 #include <X11/Xatom.h>
166 CAMLprim value
ml_seticon (value data_v
)
169 static struct X11State static_state
;
170 struct X11State
*s
= &static_state
;
171 void *ptr
= String_val (data_v
);
173 unsigned char *data
= ptr
;
177 s
->dpy
= XOpenDisplay (NULL
);
182 /* "tiny bit" hackish */
183 s
->id
= glXGetCurrentDrawable ();
188 s
->property
= XInternAtom (s
->dpy
, "_NET_WM_ICON", False
);
189 if (s
->property
== None
){
194 printf ("id = %#x, property = %d\n",
195 (int) s
->id
, (int) s
->property
);
203 XChangeProperty (s
->dpy
, s
->id
, s
->property
, XA_CARDINAL
,
204 32, PropModeReplace
, data
, 32 * 32 + 2);
206 CAMLreturn (Val_unit
);
209 XCloseDisplay (s
->dpy
);
212 CAMLreturn (Val_unit
);
215 CAMLprim value
ml_delay (value secs_v
)
218 failwith ("delay is not implemented on non-Windows");
219 CAMLreturn (Val_unit
);
222 CAMLprim value
ml_is_winnt (value unit_v
)
225 CAMLreturn (Val_false
);
230 #pragma warning (disable:4152 4127 4189)
231 #define WIN32_LEAN_AND_MEAN
234 #define DDKFASTAPI __fastcall
235 #define NTSTATUS long
238 /* Following (mildly modified) structure definitions, macros, enums,
239 etc are taken from binutils w32api (http://sourceware.org/binutils/)
246 * This file is part of the w32api package.
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
{
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
);
291 QuerySystemInformationProc QuerySystemInformation
;
295 static void init (void)
298 glob
.hmod
= LoadLibrary ("ntdll.dll");
300 failwith_fmt ("could not load ntdll.dll: %#lx", GetLastError ());
303 *(void **) &glob
.QuerySystemInformation
=
304 GetProcAddress (glob
.hmod
, "ZwQuerySystemInformation");
305 if (!glob
.QuerySystemInformation
) {
307 "could not obtain ZwQuerySystemInformation entry point: %#lx\n",
313 static void qsi (int c
, PVOID buf
, ULONG size
)
319 status
= glob
.QuerySystemInformation (c
, buf
, size
, &retsize
);
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
);
328 printf ("class=%d status=%ld size=%d retsize=%d\n",
329 c
, status
, size
, retsize
);
333 CAMLprim value
ml_waitalrm (value 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
)
352 CAMLlocal2 (res_v
, loads_v
);
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
);
375 CAMLprim value
ml_get_nprocs (value unit_v
)
380 CAMLreturn (Val_int (glob
.nprocs
));
383 CAMLprim value
ml_idletimeofday (value fd_v
, value nprocs_v
)
385 CAMLparam2 (fd_v
, nprocs_v
);
387 int nprocs
= Int_val (nprocs_v
);
388 PSYSTEM_PROCESSOR_TIMES buf
;
389 size_t n
= nprocs
* sizeof (*buf
);
394 failwith_fmt ("alloca: %s", strerror (errno
));
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
);
408 CAMLprim value
ml_get_hz (value unit_v
)
411 CAMLreturn (Val_int (100));
414 CAMLprim value
ml_nice (value 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
)
426 CAMLreturn (Val_unit
);
429 CAMLprim value
ml_delay (value secs_v
)
432 DWORD millis
= (DWORD
) (Double_val (secs_v
) * 1e4
);
434 caml_enter_blocking_section ();
438 caml_leave_blocking_section ();
439 CAMLreturn (Val_unit
);
442 CAMLprim value
ml_is_winnt (value unit_v
)
447 ovi
.dwOSVersionInfoSize
= sizeof (ovi
);
448 if (!GetVersionEx (&ovi
)) {
449 failwith_fmt ("Could not get version information: %#lx",
453 if (ovi
.dwPlatformId
!= VER_PLATFORM_WIN32_NT
) {
454 caml_failwith ("Only NT family of Windows is supported by APC");
457 CAMLreturn (Val_true
);
461 #error This operating system is not supported