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
;
201 static double gettime (void)
206 GetSystemTimeAsFileTime (&ft
);
207 tmp
= ft
.dwHighDateTime
;
209 tmp
|= ft
.dwLowDateTime
;
213 static void init (void)
216 glob
.hmod
= LoadLibrary ("ntdll.dll");
218 failwith_fmt ("could not load ntdll.dll: %#lx", GetLastError ());
221 *(void **) &glob
.QuerySystemInformation
=
222 GetProcAddress (glob
.hmod
, "ZwQuerySystemInformation");
223 if (!glob
.QuerySystemInformation
) {
225 "could not obtain ZwQuerySystemInformation entry point: %#lx",
228 glob
.prevtime
= gettime ();
232 static void qsi (int c
, PVOID buf
, ULONG size
)
238 status
= glob
.QuerySystemInformation (c
, buf
, size
, &retsize
);
240 failwith_fmt ("could not query system information %ld retsize %ld",
243 if (retsize
!= size
) {
244 fprintf (stderr
, "class=%d status=%ld size=%d retsize=%d\n",
245 c
, status
, size
, retsize
);
248 printf ("class=%d status=%ld size=%d retsize=%d\n",
249 c
, status
, size
, retsize
);
253 CAMLprim value
ml_waitalrm (value unit_v
)
257 failwith ("waitalrm not supported on Windows");
258 CAMLreturn (Val_unit
);
261 static void pmc (int nproc
, double *clocksp
, double *unhaltedp
)
263 unsigned int h1
, l1
, h2
, l2
, p
;
267 prevmask
= SetThreadAffinityMask (GetCurrentThread (), 1 << nproc
);
269 failwith_fmt ("SetThreadAffinityMask failed: %ld\n", GetLastError ());
273 #error Not yet written
300 /* printf ("[%d] = %f %f %x\n", p >> 24, *clocksp, *unhaltedp, prevmask); */
303 static void get_nprocs (void)
305 SYSTEM_BASIC_INFORMATION sbi
;
307 qsi (0, &sbi
, sizeof (sbi
));
308 glob
.nprocs
= sbi
.NumberProcessors
;
309 if (glob
.nprocs
> 64) {
310 failwith_fmt ("Hmm... the future is now, but i'm not ready %d",
315 CAMLprim value
ml_get_nprocs (value unit_v
)
320 CAMLreturn (Val_int (glob
.nprocs
));
323 CAMLprim value
ml_windows_processor_times (value nprocs_v
)
325 CAMLparam1 (nprocs_v
);
327 int nprocs
= Int_val (nprocs_v
);
328 PSYSTEM_PROCESSOR_TIMES buf
, b
;
329 size_t n
= nprocs
* sizeof (*buf
);
334 failwith_fmt ("alloca: %s", strerror (errno
));
339 res_v
= caml_alloc (nprocs
* 5 * Double_wosize
, Double_array_tag
);
341 for (i
= 0, j
= 0; i
< nprocs
; ++i
, ++b
) {
342 double d
= b
->IdleTime
.QuadPart
* 1e-7;
344 Store_double_field (res_v
, j
, d
); j
+= 1;
346 d
= b
->KernelTime
.QuadPart
* 1e-7 - d
;
347 Store_double_field (res_v
, j
, d
); j
+= 1;
349 Store_double_field (res_v
, j
, b
->UserTime
.QuadPart
* 1e-7); j
+= 1;
350 Store_double_field (res_v
, j
, b
->DpcTime
.QuadPart
* 1e-7); j
+= 1;
351 Store_double_field (res_v
, j
, b
->InterruptTime
.QuadPart
* 1e-7); j
+= 1;
356 CAMLprim value
ml_get_hz (value unit_v
)
359 CAMLreturn (Val_int (100));
362 CAMLprim value
ml_nice (value nice_v
)
365 int niceval
= Int_val (nice_v
);
367 failwith_fmt ("nice: not implemented on Windows");
368 CAMLreturn (Val_unit
);
371 CAMLprim value
ml_seticon (value data_v
)
374 CAMLreturn (Val_unit
);
377 CAMLprim value
ml_delay (value secs_v
)
380 DWORD millis
= (DWORD
) (Double_val (secs_v
) * 1e4
);
382 caml_enter_blocking_section ();
386 caml_leave_blocking_section ();
387 CAMLreturn (Val_unit
);
390 CAMLprim value
ml_os_type (value unit_v
)
395 ovi
.dwOSVersionInfoSize
= sizeof (ovi
);
396 if (!GetVersionEx (&ovi
)) {
397 failwith_fmt ("Could not get version information: %#lx",
401 if (ovi
.dwPlatformId
!= VER_PLATFORM_WIN32_NT
) {
402 caml_failwith ("Only NT family of Windows is supported by APC");
405 CAMLreturn (Val_int (WINDOWS_TAG
));
408 CAMLprim value
ml_idletimeofday (value fd_v
, value nprocs_v
)
410 CAMLparam2 (fd_v
, nprocs_v
);
416 delta
= now
- glob
.prevtime
;
419 res_v
= caml_alloc (glob
.nprocs
* Double_wosize
, Double_array_tag
);
420 for (i
= 0; i
< glob
.nprocs
; ++i
) {
422 double clocks
, unhalted
;
425 pmc (i
, &clocks
, &unhalted
);
426 dc
= clocks
- glob
.prev
[i
].clocks
;
427 du
= unhalted
- glob
.prev
[i
].unhalted
;
428 d
= delta
* (1.0 - du
/ dc
);
429 glob
.prev
[i
].clocks
= clocks
;
430 glob
.prev
[i
].unhalted
= unhalted
;
431 glob
.prev
[i
].total
+= d
;
432 Store_double_field (res_v
, i
, glob
.prev
[i
].total
);
436 #elif defined __sun__
437 #define _POSIX_PTHREAD_SEMANTICS
440 #include <sys/time.h>
441 #include <sys/time.h>
442 #include <sys/sysinfo.h>
444 #include <sys/stat.h>
449 static long get_nprocs (void)
451 long nprocs
= sysconf (_SC_NPROCESSORS_CONF
);
453 failwith_fmt ("sysconf (_SC_NPROCESSORS_CONF) = %ld: %s",
454 nprocs
, strerror (errno
));
459 CAMLprim value
ml_get_nprocs (value unit_v
)
462 CAMLreturn (Val_int (get_nprocs ()));
465 CAMLprim value
ml_solaris_kstat (value nprocs_v
)
467 /* Based on lib/cpustat.cc from sinfo package by Juergen Rinas */
468 CAMLparam1 (nprocs_v
);
471 int nprocs
= Int_val (nprocs_v
);
472 struct kstat_ctl
*kc
;
477 failwith_fmt ("kstat_open failed: %s", strerror (errno
));
480 res_v
= caml_alloc (nprocs
* 4 * Double_wosize
, Double_array_tag
);
481 for (ksp
= kc
->kc_chain
; ksp
; ksp
= ksp
->ks_next
) {
482 if (!strncmp (ksp
->ks_name
, "cpu_stat", 8)) {
487 failwith_fmt ("number of processors changed?");
490 if (kstat_read (kc
, ksp
, 0) == -1) {
491 failwith_fmt ("kstat_read (update) failed: %s", strerror (errno
));
494 if (kstat_read (kc
, ksp
, &cstat
) == -1) {
495 failwith_fmt ("kstat_read (read) failed: %s", strerror (errno
));
498 Store_double_field (res_v
, j
, cstat
.cpu_sysinfo
.cpu
[0]); j
+= 1;
499 Store_double_field (res_v
, j
, cstat
.cpu_sysinfo
.cpu
[1]); j
+= 1;
500 Store_double_field (res_v
, j
, cstat
.cpu_sysinfo
.cpu
[2]); j
+= 1;
501 Store_double_field (res_v
, j
, cstat
.cpu_sysinfo
.cpu
[3]); j
+= 1;
509 CAMLprim value
ml_os_type (value unit_v
)
512 CAMLreturn (Val_int (SOLARIS_TAG
));
514 #elif defined __APPLE__
515 #include <mach/mach.h>
516 #include <sys/sysctl.h>
521 CAMLprim value
ml_seticon (value data_v
)
524 CAMLreturn (Val_unit
);
527 static long get_nprocs (void)
531 int mib
[] = { CTL_HW
, HW_NCPU
};
534 err
= sysctl (mib
, 2, &n
, &size
, NULL
, 0);
536 failwith_fmt ("sysctl (HW_NCPU) failed: %s", strerror (errno
));
541 CAMLprim value
ml_get_nprocs (value unit_v
)
544 CAMLreturn (Val_int (get_nprocs ()));
547 CAMLprim value
ml_macosx_host_processor_info (value nprocs_v
)
549 CAMLparam1 (nprocs_v
);
552 int nprocs
= Int_val (nprocs_v
);
553 unsigned int nprocs1
;
555 processor_cpu_load_info_t cpu_load
, c
;
556 mach_msg_type_number_t cpu_msg_count
;
558 kr
= host_processor_info (mach_host_self (), PROCESSOR_CPU_LOAD_INFO
,
560 (processor_info_array_t
*) &cpu_load
,
562 if (kr
!= KERN_SUCCESS
) {
563 failwith_fmt ("host_processor_info failed: %s",
564 mach_error_string (kr
));
567 if (nprocs1
!= nprocs
){
568 failwith_fmt ("host_processor_info claims CPUs=%d expected %d",
572 res_v
= caml_alloc (nprocs
* 4 * Double_wosize
, Double_array_tag
);
574 for (i
= 0; i
< nprocs
; ++i
, ++c
) {
575 Store_double_field (res_v
, j
, c
->cpu_ticks
[CPU_STATE_IDLE
]); j
+= 1;
576 Store_double_field (res_v
, j
, c
->cpu_ticks
[CPU_STATE_USER
]); j
+= 1;
577 Store_double_field (res_v
, j
, c
->cpu_ticks
[CPU_STATE_SYSTEM
]); j
+= 1;
578 Store_double_field (res_v
, j
, c
->cpu_ticks
[CPU_STATE_NICE
]); j
+= 1;
581 kr
= vm_deallocate (mach_task_self (), (vm_address_t
) cpu_load
,
582 cpu_msg_count
* sizeof (*cpu_load
));
583 if (kr
!= KERN_SUCCESS
) {
584 failwith_fmt ("vm_deallocate failed: %s", mach_error_string (kr
));
589 CAMLprim value
ml_os_type (value unit_v
)
592 CAMLreturn (Val_int (MACOSX_TAG
));
595 #error This operating system is not supported
598 #if defined __linux__ || defined __sun__
601 #include <X11/Xlib.h>
602 #include <X11/Xatom.h>
613 CAMLprim value
ml_seticon (value data_v
)
616 static struct X11State static_state
;
617 struct X11State
*s
= &static_state
;
618 void *ptr
= String_val (data_v
);
620 unsigned char *data
= ptr
;
624 s
->dpy
= XOpenDisplay (NULL
);
629 /* "tiny bit" hackish */
630 s
->id
= glXGetCurrentDrawable ();
635 s
->property
= XInternAtom (s
->dpy
, "_NET_WM_ICON", False
);
636 if (s
->property
== None
){
641 printf ("id = %#x, property = %d\n",
642 (int) s
->id
, (int) s
->property
);
648 CAMLreturn (Val_unit
);
653 XChangeProperty (s
->dpy
, s
->id
, s
->property
, XA_CARDINAL
,
654 32, PropModeReplace
, data
, 32 * 32 + 2);
656 CAMLreturn (Val_unit
);
659 XCloseDisplay (s
->dpy
);
662 CAMLreturn (Val_unit
);
667 CAMLprim value
ml_waitalrm (value unit_v
)
671 int signr
, ret
, errno_code
;
674 sigaddset (&set
, SIGALRM
);
676 caml_enter_blocking_section ();
678 ret
= sigwait (&set
, &signr
);
681 caml_leave_blocking_section ();
684 failwith_fmt ("sigwait: %s", strerror (errno_code
));
686 CAMLreturn (Val_unit
);
689 CAMLprim value
ml_get_hz (value unit_v
)
694 clk_tck
= sysconf (_SC_CLK_TCK
);
696 failwith_fmt ("sysconf (SC_CLK_TCK): %s", strerror (errno
));
698 CAMLreturn (Val_int (clk_tck
));
701 CAMLprim value
ml_delay (value secs_v
)
704 failwith ("delay is not implemented on non-Windows");
705 CAMLreturn (Val_unit
);
708 CAMLprim value
ml_nice (value nice_v
)
711 int niceval
= Int_val (nice_v
);
716 if (nice (niceval
) < 0) {
720 failwith_fmt ("nice %d: %s", niceval
, strerror (errno
));
723 CAMLreturn (Val_unit
);
728 CAMLprim value
ml_windows_processor_times (value nprocs_v
)
730 CAMLparam1 (nprocs_v
);
731 failwith ("ml_windows_processor_times is not implemented on non-Windows");
732 CAMLreturn (Val_unit
);
737 CAMLprim value
ml_solaris_kstat (value nprocs_v
)
739 CAMLparam1 (nprocs_v
);
740 failwith ("ml_solaris_kstat is not implemented on non-Solaris");
741 CAMLreturn (Val_unit
);
746 CAMLprim value
ml_macosx_host_processor_info (value nprocs_v
)
748 CAMLparam1 (nprocs_v
);
749 failwith ("ml_macosx_host_processor_info is not implemented on non-MacOSX");
750 CAMLreturn (Val_unit
);
755 CAMLprim value
ml_sysinfo (value unit_v
)
758 CAMLlocal2 (res_v
, loads_v
);
762 nprocs
= glob
.nprocs
;
764 nprocs
= get_nprocs ();
767 loads_v
= caml_alloc_tuple (3);
768 Store_field (loads_v
, 0, caml_copy_int64 (0));
769 Store_field (loads_v
, 1, caml_copy_int64 (0));
770 Store_field (loads_v
, 2, caml_copy_int64 (0));
772 res_v
= caml_alloc_tuple (9);
773 Store_field (res_v
, 0, 0);
774 Store_field (res_v
, 1, loads_v
);
775 Store_field (res_v
, 2, 0);
776 Store_field (res_v
, 3, 0);
777 Store_field (res_v
, 4, 0);
778 Store_field (res_v
, 5, 0);
779 Store_field (res_v
, 6, 0);
780 Store_field (res_v
, 7, 0);
781 Store_field (res_v
, 8, nprocs
);
787 CAMLprim value
ml_idletimeofday (value fd_v
, value nprocs_v
)
789 CAMLparam2 (fd_v
, nprocs_v
);
790 failwith_fmt ("idletimeofday is not implemented on non-Linux/Win32");
791 CAMLreturn (Val_unit
);
796 CAMLprim value
ml_fixwindow (value window_v
)
798 CAMLparam1 (window_v
);
799 CAMLreturn (Val_unit
);
802 CAMLprim value
ml_testpmc (value unit_v
)
821 "Requested PMC based sampling is not available",
823 MB_OK
| MB_ICONWARNING
);
826 int response
= MessageBox (
828 "Requested PMC based sampling might cause the application to crash.\n"
829 "Continue trying to use PMC?",
831 MB_YESNO
| MB_ICONWARNING
);
832 pmcok
= response
== IDYES
;
837 CAMLreturn (Val_bool (pmcok
));