[MLton-commit] r6838
Wesley Terpstra
wesley at mlton.org
Sat Sep 6 14:51:00 PDT 2008
Time profiling now works on MinGW.
Unfortunately, the granularity of the windows clock is 16ms. This affects gettimeofday and setitimer. The normal sampling rate of 100Hz for profiling is thus clipped at about 62Hz.
----------------------------------------------------------------------
U mlton/trunk/mlton/main/main.fun
U mlton/trunk/runtime/platform/mingw.c
U mlton/trunk/runtime/platform/mingw.h
U mlton/trunk/runtime/platform/windows.c
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun 2008-09-06 15:00:13 UTC (rev 6837)
+++ mlton/trunk/mlton/main/main.fun 2008-09-06 21:50:54 UTC (rev 6838)
@@ -1009,6 +1009,7 @@
| FreeBSD => ()
| HPUX => ()
| Linux => ()
+ | MinGW => ()
| NetBSD => ()
| OpenBSD => ()
| Solaris => ()
Modified: mlton/trunk/runtime/platform/mingw.c
===================================================================
--- mlton/trunk/runtime/platform/mingw.c 2008-09-06 15:00:13 UTC (rev 6837)
+++ mlton/trunk/runtime/platform/mingw.c 2008-09-06 21:50:54 UTC (rev 6838)
@@ -111,6 +111,7 @@
static HANDLE RealTimer = NULL;
static HANDLE VirtTimer = NULL;
static HANDLE ProfTimer = NULL;
+static HANDLE PrioTimer = NULL;
static void (*SIGALRM_handler)(int sig) = SIG_DFL;
static void (*SIGVTAM_handler)(int sig) = SIG_DFL;
static void (*SIGPROF_handler)(int sig) = SIG_DFL;
@@ -161,6 +162,12 @@
ResumeThread(MainThread);
}
+static void CALLBACK fixPriority(__attribute__ ((unused)) PVOID myArg,
+ __attribute__ ((unused)) BOOLEAN timeout) {
+ SetThreadPriority(GetCurrentThread(), THREAD_PRIORITY_ABOVE_NORMAL);
+ DeleteTimerQueueTimer(TimerQueue, PrioTimer, NULL);
+}
+
static int MLTimer(HANDLE *timer,
const struct itimerval *value,
WAITORTIMERCALLBACK callback) {
@@ -168,8 +175,27 @@
/* Initialize the TimerQueue */
if (MainThread == 0) {
+ /* This call improves the resolution of the scheduler from
+ * 16ms to about 2ms in my testing. Sadly, it requires winmm.
+ */
+ //timeBeginPeriod(1);
+
TimerQueue = CreateTimerQueue();
if (TimerQueue == NULL) { errno = ENOMEM; return -1; }
+
+ /* We need to get the TimerQueue to have higher priority.
+ * From my testing, if it has the same priority as the main
+ * thread and the main thread is busy, your best resolution
+ * is a terribly slow 188ms. By boosting the priority of the
+ * timer thread to ABOVE_NORMAL, I've gotten down to 2ms.
+ */
+ CreateTimerQueueTimer(&PrioTimer, TimerQueue, fixPriority,
+ 0, 1, 0, WT_EXECUTEINTIMERTHREAD);
+
+ /* We need a handle to the main thread usable by the timer
+ * thread. GetCurrentThread() is a self-reference so we need
+ * to copy it to a new handle for it to work in other threads.
+ */
DuplicateHandle(GetCurrentProcess(), /* source process */
GetCurrentThread(), /* source handle */
GetCurrentProcess(), /* target process */
@@ -177,6 +203,7 @@
0, /* access (ignored) */
FALSE, /* not inheritable */
DUPLICATE_SAME_ACCESS);
+
if (MainThread == 0) die("Cannot get handle to initial thread");
}
@@ -223,9 +250,10 @@
}
}
-/*
+
static void catcher(__attribute__ ((unused)) int sig) {
CONTEXT context;
+ context.ContextFlags = CONTEXT_CONTROL;
GetThreadContext(MainThread, &context);
#if defined(__i386__)
@@ -249,7 +277,6 @@
sa->sa_flags = 0;
sa->sa_handler = (_sig_func_ptr)&catcher;
}
-*/
/* ------------------------------------------------- */
/* MLton.Rlimit */
Modified: mlton/trunk/runtime/platform/mingw.h
===================================================================
--- mlton/trunk/runtime/platform/mingw.h 2008-09-06 15:00:13 UTC (rev 6837)
+++ mlton/trunk/runtime/platform/mingw.h 2008-09-06 21:50:54 UTC (rev 6838)
@@ -40,7 +40,7 @@
#define HAS_SIGALTSTACK FALSE
#define HAS_SIGNBIT TRUE
#define HAS_SPAWN TRUE
-#define HAS_TIME_PROFILING FALSE
+#define HAS_TIME_PROFILING TRUE
#define MLton_Platform_OS_host "mingw"
@@ -832,9 +832,11 @@
#define SIGPROF 30 /* profiling time alarm */
#endif
-#ifndef _NSIG
-#define _NSIG 32
+/* We have extended the number of signals ... */
+#ifdef NSIG
+#undef NSIG
#endif
+#define NSIG 32
typedef __p_sig_fn_t MLton__sig_func_ptr;
typedef int MLton_sigset_t;
Modified: mlton/trunk/runtime/platform/windows.c
===================================================================
--- mlton/trunk/runtime/platform/windows.c 2008-09-06 15:00:13 UTC (rev 6837)
+++ mlton/trunk/runtime/platform/windows.c 2008-09-06 21:50:54 UTC (rev 6838)
@@ -348,3 +348,56 @@
}
return 0;
}
+
+static intptr_t text_start = 0;
+static intptr_t text_end = 0;
+
+/* GNU binutils generate this symbol */
+extern char base_address asm("__image_base__");
+
+static void findTextSegment (void) {
+ PIMAGE_DOS_HEADER dosHeader;
+ PIMAGE_NT_HEADERS ntHeader;
+ PIMAGE_SECTION_HEADER sectionHeader;
+ DWORD entryPoint, start = 0, end = 0;
+ UINT sections, i;
+ char *base = &base_address;
+
+ dosHeader = (PIMAGE_DOS_HEADER)base;
+ if (dosHeader->e_magic != IMAGE_DOS_SIGNATURE)
+ die("bad dos header magic");
+
+ ntHeader = (PIMAGE_NT_HEADERS)(base + dosHeader->e_lfanew);
+ if (ntHeader->Signature != IMAGE_NT_SIGNATURE)
+ die("bad NT header magic");
+
+ entryPoint = ntHeader->OptionalHeader.AddressOfEntryPoint;
+ sections = ntHeader->FileHeader.NumberOfSections;
+ sectionHeader = IMAGE_FIRST_SECTION(ntHeader);
+
+ for (i = 0; i < sections; ++i) {
+ start = sectionHeader->VirtualAddress;
+ end = start + sectionHeader->Misc.VirtualSize;
+ if (start <= entryPoint && entryPoint < end)
+ break;
+ ++sectionHeader;
+ }
+
+ if (i == sections)
+ die("entry point has no containing section");
+
+ /* Factor in the loaded memory position */
+ text_start = (intptr_t)base + start;
+ text_end = (intptr_t)base + end;
+}
+
+code_pointer GC_getTextStart (void) {
+ if (!text_start) findTextSegment();
+ return (code_pointer)text_start;
+}
+
+code_pointer GC_getTextEnd (void) {
+ if (!text_end) findTextSegment();
+ return (code_pointer)text_end;
+}
+
More information about the MLton-commit
mailing list