2 #include <caml/alloc.h>
3 #include <caml/memory.h>
4 #include <caml/custom.h>
5 #include <caml/signals.h>
6 #include <caml/mlvalues.h>
7 #include <caml/bigarray.h>
21 #define vsnprintf _vsnprintf
24 static void failwith_fmt (const char *fmt
, ...) Noreturn
;
25 static void failwith_fmt (const char *fmt
, ...)
31 vsnprintf (buf
, sizeof (buf
), fmt
, ap
);
43 #include <sys/sysinfo.h>
48 CAMLprim value
ml_sysinfo (value unit_v
)
51 CAMLlocal2 (res_v
, loads_v
);
55 failwith_fmt ("sysinfo: %s", strerror (errno
));
58 loads_v
= caml_alloc_tuple (3);
59 Store_field (loads_v
, 0, caml_copy_int64 (si
.loads
[0]));
60 Store_field (loads_v
, 1, caml_copy_int64 (si
.loads
[1]));
61 Store_field (loads_v
, 2, caml_copy_int64 (si
.loads
[2]));
63 res_v
= caml_alloc_tuple (9);
64 Store_field (res_v
, 0, caml_copy_int64 (si
.uptime
));
65 Store_field (res_v
, 1, loads_v
);
66 Store_field (res_v
, 2, caml_copy_int64 (si
.totalram
));
67 Store_field (res_v
, 3, caml_copy_int64 (si
.freeram
));
68 Store_field (res_v
, 4, caml_copy_int64 (si
.sharedram
));
69 Store_field (res_v
, 5, caml_copy_int64 (si
.bufferram
));
70 Store_field (res_v
, 6, caml_copy_int64 (si
.totalswap
));
71 Store_field (res_v
, 7, caml_copy_int64 (si
.freeswap
));
72 Store_field (res_v
, 8, caml_copy_int64 (si
.procs
));
77 CAMLprim value
ml_get_nprocs (value unit_v
)
82 nprocs
= get_nprocs ();
84 failwith_fmt ("get_nprocs: %s", strerror (errno
));
87 CAMLreturn (Val_int (nprocs
));
90 CAMLprim value
ml_idletimeofday (value fd_v
, value nprocs_v
)
92 CAMLparam2 (fd_v
, nprocs_v
);
95 int fd
= Int_val (fd_v
);
96 int nprocs
= Int_val (nprocs_v
);
97 size_t n
= nprocs
* sizeof (tv
);
104 failwith_fmt ("alloca: %s", strerror (errno
));
107 m
= read (fd
, buf
, n
);
109 failwith_fmt ("read [n=%zu, m=%zi]: %s", n
, m
, strerror (errno
));
112 res_v
= caml_alloc (nprocs
* Double_wosize
, Double_array_tag
);
113 for (i
= 0; i
< nprocs
; ++i
) {
116 d
= buf
[i
].tv_sec
+ buf
[i
].tv_usec
* 1e-6;
117 Store_double_field (res_v
, i
, d
);
122 CAMLprim value
ml_os_type (value unit_v
)
125 CAMLreturn (Val_int (LINUX_TAG
));
130 #pragma warning (disable:4152 4127 4189)
131 #define WIN32_LEAN_AND_MEAN
134 #define DDKFASTAPI __fastcall
135 #define NTSTATUS long
138 /* Following (mildly modified) structure definitions, macros, enums,
139 etc are taken from binutils w32api (http://sourceware.org/binutils/)
146 * This file is part of the w32api package.
149 * Created by Casper S. Hornstrup <chorns@users.sourceforge.net>
151 * THIS SOFTWARE IS NOT COPYRIGHTED
153 * This source code is offered for use in the public domain. You may
154 * use, modify or distribute it freely.
156 * This code is distributed in the hope that it will be useful but
157 * WITHOUT ANY WARRANTY. ALL WARRANTIES, EXPRESS OR IMPLIED ARE HEREBY
158 * DISCLAIMED. This includes but is not limited to warranties of
159 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
163 typedef struct _SYSTEM_BASIC_INFORMATION
{
165 ULONG MaximumIncrement
;
166 ULONG PhysicalPageSize
;
167 ULONG NumberOfPhysicalPages
;
168 ULONG LowestPhysicalPage
;
169 ULONG HighestPhysicalPage
;
170 ULONG AllocationGranularity
;
171 ULONG LowestUserAddress
;
172 ULONG HighestUserAddress
;
173 ULONG ActiveProcessors
;
174 UCHAR NumberProcessors
;
175 } SYSTEM_BASIC_INFORMATION
, *PSYSTEM_BASIC_INFORMATION
;
177 typedef struct _SYSTEM_PROCESSOR_TIMES
{
178 LARGE_INTEGER IdleTime
;
179 LARGE_INTEGER KernelTime
;
180 LARGE_INTEGER UserTime
;
181 LARGE_INTEGER DpcTime
;
182 LARGE_INTEGER InterruptTime
;
183 ULONG InterruptCount
;
184 } SYSTEM_PROCESSOR_TIMES
, *PSYSTEM_PROCESSOR_TIMES
;
186 typedef long (__stdcall
*QuerySystemInformationProc
)
187 (SYSTEM_INFORMATION_CLASS
, PVOID
, ULONG
, PULONG
);
191 QuerySystemInformationProc QuerySystemInformation
;
195 static void init (void)
198 glob
.hmod
= LoadLibrary ("ntdll.dll");
200 failwith_fmt ("could not load ntdll.dll: %#lx", GetLastError ());
203 *(void **) &glob
.QuerySystemInformation
=
204 GetProcAddress (glob
.hmod
, "ZwQuerySystemInformation");
205 if (!glob
.QuerySystemInformation
) {
207 "could not obtain ZwQuerySystemInformation entry point: %#lx",
213 static void qsi (int c
, PVOID buf
, ULONG size
)
219 status
= glob
.QuerySystemInformation (c
, buf
, size
, &retsize
);
221 failwith_fmt ("could not query system information %ld retsize %ld",
224 if (retsize
!= size
) {
225 fprintf (stderr
, "class=%d status=%ld size=%d retsize=%d\n",
226 c
, status
, size
, retsize
);
229 printf ("class=%d status=%ld size=%d retsize=%d\n",
230 c
, status
, size
, retsize
);
234 CAMLprim value
ml_waitalrm (value unit_v
)
238 failwith ("waitalrm not supported on Windows");
239 CAMLreturn (Val_unit
);
242 static void get_nprocs (void)
244 SYSTEM_BASIC_INFORMATION sbi
;
246 qsi (0, &sbi
, sizeof (sbi
));
247 glob
.nprocs
= sbi
.NumberProcessors
;
250 CAMLprim value
ml_get_nprocs (value unit_v
)
255 CAMLreturn (Val_int (glob
.nprocs
));
258 CAMLprim value
ml_windows_processor_times (value nprocs_v
)
260 CAMLparam1 (nprocs_v
);
262 int nprocs
= Int_val (nprocs_v
);
263 PSYSTEM_PROCESSOR_TIMES buf
, b
;
264 size_t n
= nprocs
* sizeof (*buf
);
269 failwith_fmt ("alloca: %s", strerror (errno
));
274 res_v
= caml_alloc (nprocs
* 5 * Double_wosize
, Double_array_tag
);
276 for (i
= 0, j
= 0; i
< nprocs
; ++i
, ++b
) {
277 double d
= b
->IdleTime
.QuadPart
* 1e-7;
279 Store_double_field (res_v
, j
, d
); j
+= 1;
281 d
= b
->KernelTime
.QuadPart
* 1e-7 - d
;
282 Store_double_field (res_v
, j
, d
); j
+= 1;
284 Store_double_field (res_v
, j
, b
->UserTime
.QuadPart
* 1e-7); j
+= 1;
285 Store_double_field (res_v
, j
, b
->DpcTime
.QuadPart
* 1e-7); j
+= 1;
286 Store_double_field (res_v
, j
, b
->InterruptTime
.QuadPart
* 1e-7); j
+= 1;
291 CAMLprim value
ml_get_hz (value unit_v
)
294 CAMLreturn (Val_int (100));
297 CAMLprim value
ml_nice (value nice_v
)
300 int niceval
= Int_val (nice_v
);
302 failwith_fmt ("nice: not implemented on Windows");
303 CAMLreturn (Val_unit
);
306 CAMLprim value
ml_seticon (value data_v
)
309 CAMLreturn (Val_unit
);
312 CAMLprim value
ml_delay (value secs_v
)
315 DWORD millis
= (DWORD
) (Double_val (secs_v
) * 1e4
);
317 caml_enter_blocking_section ();
321 caml_leave_blocking_section ();
322 CAMLreturn (Val_unit
);
325 CAMLprim value
ml_os_type (value unit_v
)
330 ovi
.dwOSVersionInfoSize
= sizeof (ovi
);
331 if (!GetVersionEx (&ovi
)) {
332 failwith_fmt ("Could not get version information: %#lx",
336 if (ovi
.dwPlatformId
!= VER_PLATFORM_WIN32_NT
) {
337 caml_failwith ("Only NT family of Windows is supported by APC");
340 CAMLreturn (Val_int (WINDOWS_TAG
));
343 #elif defined __sun__
344 #define _POSIX_PTHREAD_SEMANTICS
347 #include <sys/time.h>
348 #include <sys/time.h>
349 #include <sys/sysinfo.h>
351 #include <sys/stat.h>
356 static long get_nprocs (void)
358 long nprocs
= sysconf (_SC_NPROCESSORS_CONF
);
360 failwith_fmt ("sysconf (_SC_NPROCESSORS_CONF) = %ld: %s",
361 nprocs
, strerror (errno
));
366 CAMLprim value
ml_get_nprocs (value unit_v
)
369 CAMLreturn (Val_int (get_nprocs ()));
372 CAMLprim value
ml_solaris_kstat (value nprocs_v
)
374 /* Based on lib/cpustat.cc from sinfo package by Juergen Rinas */
375 CAMLparam1 (nprocs_v
);
378 int nprocs
= Int_val (nprocs_v
);
379 struct kstat_ctl
*kc
;
384 failwith_fmt ("kstat_open failed: %s", strerror (errno
));
387 res_v
= caml_alloc (nprocs
* 4 * Double_wosize
, Double_array_tag
);
388 for (ksp
= kc
->kc_chain
; ksp
; ksp
= ksp
->ks_next
) {
389 if (!strncmp (ksp
->ks_name
, "cpu_stat", 8)) {
394 failwith_fmt ("number of processors changed?");
397 if (kstat_read (kc
, ksp
, 0) == -1) {
398 failwith_fmt ("kstat_read (update) failed: %s", strerror (errno
));
401 if (kstat_read (kc
, ksp
, &cstat
) == -1) {
402 failwith_fmt ("kstat_read (read) failed: %s", strerror (errno
));
405 Store_double_field (res_v
, j
, cstat
.cpu_sysinfo
.cpu
[0]); j
+= 1;
406 Store_double_field (res_v
, j
, cstat
.cpu_sysinfo
.cpu
[1]); j
+= 1;
407 Store_double_field (res_v
, j
, cstat
.cpu_sysinfo
.cpu
[2]); j
+= 1;
408 Store_double_field (res_v
, j
, cstat
.cpu_sysinfo
.cpu
[3]); j
+= 1;
416 CAMLprim value
ml_os_type (value unit_v
)
419 CAMLreturn (Val_int (SOLARIS_TAG
));
421 #elif defined __APPLE__
422 #include <mach/mach.h>
423 #include <sys/sysctl.h>
428 CAMLprim value
ml_seticon (value data_v
)
431 CAMLreturn (Val_unit
);
434 static long get_nprocs (void)
438 int mib
[] = { CTL_HW
, HW_NCPU
};
441 err
= sysctl (mib
, 2, &n
, &size
, NULL
, 0);
443 failwith_fmt ("sysctl (HW_NCPU) failed: %s", strerror (errno
));
448 CAMLprim value
ml_get_nprocs (value unit_v
)
451 CAMLreturn (Val_int (get_nprocs ()));
454 CAMLprim value
ml_macosx_host_processor_info (value nprocs_v
)
456 CAMLparam1 (nprocs_v
);
459 int nprocs
= Int_val (nprocs_v
);
460 unsigned int nprocs1
;
462 processor_cpu_load_info_t cpu_load
, c
;
463 mach_msg_type_number_t cpu_msg_count
;
465 kr
= host_processor_info (mach_host_self (), PROCESSOR_CPU_LOAD_INFO
,
467 (processor_info_array_t
*) &cpu_load
,
469 if (kr
!= KERN_SUCCESS
) {
470 failwith_fmt ("host_processor_info failed: %s",
471 mach_error_string (kr
));
474 if (nprocs1
!= nprocs
){
475 failwith_fmt ("host_processor_info claims CPUs=%d expected %d",
479 res_v
= caml_alloc (nprocs
* 4 * Double_wosize
, Double_array_tag
);
481 for (i
= 0; i
< nprocs
; ++i
, ++c
) {
482 Store_double_field (res_v
, j
, c
->cpu_ticks
[CPU_STATE_IDLE
]); j
+= 1;
483 Store_double_field (res_v
, j
, c
->cpu_ticks
[CPU_STATE_USER
]); j
+= 1;
484 Store_double_field (res_v
, j
, c
->cpu_ticks
[CPU_STATE_SYSTEM
]); j
+= 1;
485 Store_double_field (res_v
, j
, c
->cpu_ticks
[CPU_STATE_NICE
]); j
+= 1;
488 kr
= vm_deallocate (mach_task_self (), (vm_address_t
) cpu_load
,
489 cpu_msg_count
* sizeof (*cpu_load
));
490 if (kr
!= KERN_SUCCESS
) {
491 failwith_fmt ("vm_deallocate failed: %s", mach_error_string (kr
));
496 CAMLprim value
ml_os_type (value unit_v
)
499 CAMLreturn (Val_int (MACOSX_TAG
));
502 #error This operating system is not supported
505 #if defined __linux__ || defined __sun__
508 #include <X11/Xlib.h>
509 #include <X11/Xatom.h>
520 CAMLprim value
ml_seticon (value data_v
)
523 static struct X11State static_state
;
524 struct X11State
*s
= &static_state
;
525 void *ptr
= String_val (data_v
);
527 unsigned char *data
= ptr
;
531 s
->dpy
= XOpenDisplay (NULL
);
536 /* "tiny bit" hackish */
537 s
->id
= glXGetCurrentDrawable ();
542 s
->property
= XInternAtom (s
->dpy
, "_NET_WM_ICON", False
);
543 if (s
->property
== None
){
548 printf ("id = %#x, property = %d\n",
549 (int) s
->id
, (int) s
->property
);
555 CAMLreturn (Val_unit
);
560 XChangeProperty (s
->dpy
, s
->id
, s
->property
, XA_CARDINAL
,
561 32, PropModeReplace
, data
, 32 * 32 + 2);
563 CAMLreturn (Val_unit
);
566 XCloseDisplay (s
->dpy
);
569 CAMLreturn (Val_unit
);
574 CAMLprim value
ml_waitalrm (value unit_v
)
578 int signr
, ret
, errno_code
;
581 sigaddset (&set
, SIGALRM
);
583 caml_enter_blocking_section ();
585 ret
= sigwait (&set
, &signr
);
588 caml_leave_blocking_section ();
591 failwith_fmt ("sigwait: %s", strerror (errno_code
));
593 CAMLreturn (Val_unit
);
596 CAMLprim value
ml_get_hz (value unit_v
)
601 clk_tck
= sysconf (_SC_CLK_TCK
);
603 failwith_fmt ("sysconf (SC_CLK_TCK): %s", strerror (errno
));
605 CAMLreturn (Val_int (clk_tck
));
608 CAMLprim value
ml_delay (value secs_v
)
611 failwith ("delay is not implemented on non-Windows");
612 CAMLreturn (Val_unit
);
615 CAMLprim value
ml_nice (value nice_v
)
618 int niceval
= Int_val (nice_v
);
623 if (nice (niceval
) < 0) {
627 failwith_fmt ("nice %d: %s", niceval
, strerror (errno
));
630 CAMLreturn (Val_unit
);
635 CAMLprim value
ml_windows_processor_times (value nprocs_v
)
637 CAMLparam1 (nprocs_v
);
638 failwith ("ml_windows_processor_times is not implemented on non-Windows");
639 CAMLreturn (Val_unit
);
644 CAMLprim value
ml_solaris_kstat (value nprocs_v
)
646 CAMLparam1 (nprocs_v
);
647 failwith ("ml_solaris_kstat is not implemented on non-Solaris");
648 CAMLreturn (Val_unit
);
653 CAMLprim value
ml_macosx_host_processor_info (value nprocs_v
)
655 CAMLparam1 (nprocs_v
);
656 failwith ("ml_macosx_host_processor_info is not implemented on non-MacOSX");
657 CAMLreturn (Val_unit
);
662 CAMLprim value
ml_sysinfo (value unit_v
)
665 CAMLlocal2 (res_v
, loads_v
);
669 nprocs
= glob
.nprocs
;
671 nprocs
= get_nprocs ();
674 loads_v
= caml_alloc_tuple (3);
675 Store_field (loads_v
, 0, caml_copy_int64 (0));
676 Store_field (loads_v
, 1, caml_copy_int64 (0));
677 Store_field (loads_v
, 2, caml_copy_int64 (0));
679 res_v
= caml_alloc_tuple (9);
680 Store_field (res_v
, 0, 0);
681 Store_field (res_v
, 1, loads_v
);
682 Store_field (res_v
, 2, 0);
683 Store_field (res_v
, 3, 0);
684 Store_field (res_v
, 4, 0);
685 Store_field (res_v
, 5, 0);
686 Store_field (res_v
, 6, 0);
687 Store_field (res_v
, 7, 0);
688 Store_field (res_v
, 8, nprocs
);
693 CAMLprim value
ml_idletimeofday (value fd_v
, value nprocs_v
)
695 CAMLparam2 (fd_v
, nprocs_v
);
696 failwith_fmt ("idletimeofday is not implemented on non-Linux");
697 CAMLreturn (Val_unit
);