From b35a6ce0e34255d200ddcf341ffc645fd237ea32 Mon Sep 17 00:00:00 2001
From: Ian Lynagh <igloo@earth.li>
Date: Sun, 12 May 2013 01:44:02 +0100
Subject: [PATCH] More work towards dynamic programs on Windows
Dynamic GHC is now working in-place, but pathologically slow due
to the DLL split.
(GHC assumes that all intra-package calls are in the same DLL, but that
isn't true when we split the GHC package into 2 DLLs. That means that
GHC's startup time is around 22 seconds, as it is doing run-time
linking).
Also, ghci isn't actually working yet:
$ inplace/bin/ghc-stage2 --interactive
GHCi, version 7.7.20130512: http://www.haskell.org/ghc/ :? for help
Loading package ghc-prim ... <command line>: can't load .so/.DLL for:
HSghc-prim-0.3.1.0.dll (addDLL: could not load DLL)
ghc-stage2.exe: HSghc-prim-0.3.1.0: The specified module could not be
found.
---
driver/utils/dynwrapper.c | 197 ++++++++++++++++++++++++++++++++++++++
ghc.mk | 9 ++
rules/build-prog.mk | 21 +++-
utils/ghc-cabal/Main.hs | 1 +
4 files changed, 227 insertions(+), 1 deletion(-)
create mode 100644 driver/utils/dynwrapper.c
diff --git a/driver/utils/dynwrapper.c b/driver/utils/dynwrapper.c
new file mode 100644
index 000000000000..eead8bd0a0b6
--- /dev/null
+++ b/driver/utils/dynwrapper.c
@@ -0,0 +1,197 @@
+
+/*
+Need to concatenate this file with something that defines:
+LPTSTR path_dirs[];
+LPTSTR progDll;
+LPTSTR rtsDll;
+*/
+
+#include <stdarg.h>
+#include <stdio.h>
+#include <Windows.h>
+#include <Shlwapi.h>
+
+#include "Rts.h"
+
+void die(char *fmt, ...) {
+ va_list argp;
+
+ fprintf(stderr, "error: ");
+ va_start(argp, fmt);
+ vfprintf(stderr, fmt, argp);
+ va_end(argp);
+ fprintf(stderr, "\n");
+
+ exit(1);
+}
+
+LPTSTR getModuleFileName(void) {
+ HMODULE hExe;
+ LPTSTR exePath;
+ DWORD exePathSize;
+ DWORD res;
+
+ hExe = GetModuleHandle(NULL);
+ if (hExe == NULL) {
+ die("GetModuleHandle failed");
+ }
+
+ // 300 chars ought to be enough, but there are various cases where
+ // it might not be (e.g. unicode paths, or \\server\foo\... paths.
+ // So we start off with 300 and grow if necessary.
+ exePathSize = 300;
+ exePath = malloc(exePathSize);
+ if (exePath == NULL) {
+ die("Mallocing %d for GetModuleFileName failed", exePathSize);
+ }
+
+ while ((res = GetModuleFileName(hExe, exePath, exePathSize)) &&
+ (GetLastError() == ERROR_INSUFFICIENT_BUFFER)) {
+ exePathSize *= 2;
+ exePath = realloc(exePath, exePathSize);
+ if (exePath == NULL) {
+ die("Reallocing %d for GetModuleFileName failed", exePathSize);
+ }
+ }
+
+ if (!res) {
+ die("GetModuleFileName failed");
+ }
+ return exePath;
+}
+
+void setPath(void) {
+ LPTSTR *dir;
+ LPTSTR path;
+ int n;
+ int len = 0;
+ LPTSTR exePath, s;
+
+ exePath = getModuleFileName();
+ for(s = exePath; *s != '\0'; s++) {
+ if (*s == '\\') {
+ *s = '/';
+ }
+ }
+ s = StrRChr(exePath, NULL, '/');
+ if (s == NULL) {
+ die("No directory separator in executable path: %s", exePath);
+ }
+ s[0] = '\0';
+ n = s - exePath;
+
+ for (dir = path_dirs; *dir != NULL; dir++) {
+ len += n + 7/* /../../ */ + lstrlen(*dir) + 1/* semicolon */;
+ }
+ len++; // NUL
+
+ path = malloc(len);
+ if (path == NULL) {
+ die("Mallocing %d for PATH failed", len);
+ }
+ s = path;
+ for (dir = path_dirs; *dir != NULL; dir++) {
+ StrCpy(s, exePath);
+ s += n;
+ StrCpy(s, "/../../");
+ s += 7;
+ StrCpy(s, *dir);
+ s += lstrlen(*dir);
+ s[0] = ';';
+ s++;
+ }
+ s[0] = '\0';
+ free(exePath);
+
+ if (! SetEnvironmentVariable(TEXT("PATH"), path)) {
+ printf("SetEnvironmentVariable failed (%d)\n", GetLastError());
+ }
+ free(path);
+}
+
+HINSTANCE loadDll(LPTSTR dll) {
+ HINSTANCE h;
+ DWORD dw;
+ LPVOID lpMsgBuf;
+
+ h = LoadLibrary(dll);
+
+ if (h == NULL) {
+ dw = GetLastError();
+ FormatMessage(
+ FORMAT_MESSAGE_ALLOCATE_BUFFER |
+ FORMAT_MESSAGE_FROM_SYSTEM |
+ FORMAT_MESSAGE_IGNORE_INSERTS,
+ NULL,
+ dw,
+ MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
+ (LPTSTR) &lpMsgBuf,
+ 0, NULL );
+ die("loadDll %s failed: %d: %s\n", dll, dw, lpMsgBuf);
+ }
+
+ return h;
+}
+
+void *GetNonNullProcAddress(HINSTANCE h, char *sym) {
+ void *p;
+
+ p = GetProcAddress(h, sym);
+ if (p == NULL) {
+ die("Failed to find address for %s", sym);
+ }
+ return p;
+}
+
+HINSTANCE GetNonNullModuleHandle(LPTSTR dll) {
+ HINSTANCE h;
+
+ h = GetModuleHandle(dll);
+ if (h == NULL) {
+ die("Failed to get module handle for %s", dll);
+ }
+ return h;
+}
+
+typedef int (*hs_main_t)(int , char **, StgClosure *, RtsConfig);
+
+int main(int argc, char *argv[]) {
+ void *p;
+ HINSTANCE hRtsDll, hProgDll;
+ LPTSTR oldPath;
+
+ StgClosure *main_p;
+ RtsConfig *rts_config_p;
+ hs_main_t hs_main_p;
+
+ // MSDN says: An environment variable has a maximum size limit of
+ // 32,767 characters, including the null-terminating character.
+ oldPath = malloc(32767);
+ if (oldPath == NULL) {
+ die("Mallocing 32767 for oldPath failed");
+ }
+
+ if (!GetEnvironmentVariable(TEXT("PATH"), oldPath, 32767)) {
+ if (GetLastError() == ERROR_ENVVAR_NOT_FOUND) {
+ oldPath[0] = '\0';
+ }
+ else {
+ die("Looking up PATH env var failed");
+ }
+ }
+ setPath();
+ hProgDll = loadDll(progDll);
+ if (! SetEnvironmentVariable(TEXT("PATH"), oldPath)) {
+ printf("SetEnvironmentVariable failed (%d)\n", GetLastError());
+ }
+ free(oldPath);
+
+ hRtsDll = GetNonNullModuleHandle(rtsDll);
+
+ hs_main_p = GetNonNullProcAddress(hRtsDll, "hs_main");
+ rts_config_p = GetNonNullProcAddress(hRtsDll, "defaultRtsConfig");
+ main_p = GetNonNullProcAddress(hProgDll, "ZCMain_main_closure");
+
+ return hs_main_p(argc, argv, main_p, *rts_config_p);
+}
+
diff --git a/ghc.mk b/ghc.mk
index 4bd2de3474ac..d519c2044f22 100644
--- a/ghc.mk
+++ b/ghc.mk
@@ -204,6 +204,15 @@ GHCI_WAY = v
HADDOCK_WAY = v
endif
+WINDOWS_DYN_PROG_RTS := rts
+ifeq "$(GhcThreaded)" "YES"
+WINDOWS_DYN_PROG_RTS := $(WINDOWS_DYN_PROG_RTS)_thr
+endif
+ifeq "$(GhcDebugged)" "YES"
+WINDOWS_DYN_PROG_RTS := $(WINDOWS_DYN_PROG_RTS)_debug
+endif
+WINDOWS_DYN_PROG_RTS := $(WINDOWS_DYN_PROG_RTS)_dyn_LIB_NAME
+
# -----------------------------------------------------------------------------
# Compilation Flags
diff --git a/rules/build-prog.mk b/rules/build-prog.mk
index 464ed73567c6..9d1e5890be07 100644
--- a/rules/build-prog.mk
+++ b/rules/build-prog.mk
@@ -204,8 +204,27 @@ $1/$2/build/tmp/$$($1_$2_PROG) $1/$2/build/tmp/$$($1_$2_PROG).dll : \
$$(error Bad build stage)))),\
$$$$($$(dep)_dist-$(if $(filter 0,$3),boot,install)_PROGRAM_DEP_LIB)))
+$1_$2_PROG_NEEDS_C_WRAPPER = NO
ifeq "$$(Windows_Host) $$($1_$2_PROGRAM_WAY)" "YES dyn"
-$1/$2/build/tmp/$$($1_$2_PROG) : $1/$2/build/tmp/$$($1_$2_PROG).c $1/$2/build/tmp/$$($1_$2_PROG).dll | $$$$(dir $$$$@)/.
+ifneq "$$($1_$2_HS_SRCS)" ""
+$1_$2_PROG_NEEDS_C_WRAPPER = YES
+endif
+endif
+
+ifeq "$$($1_$2_PROG_NEEDS_C_WRAPPER)" "YES"
+
+$1/$2/build/tmp/$$($1_$2_PROG)-inplace-wrapper.c: driver/utils/dynwrapper.c | $$$$(dir $$$$@)/.
+ $$(call removeFiles,$$@)
+ echo '#include <Windows.h>' >> $$@
+ echo 'LPTSTR path_dirs[] = {' >> $$@
+ $$(foreach d,$$($1_$2_DEP_LIB_REL_DIRS),$$(call make-command,echo ' TEXT("$$d")$$(comma)' >> $$@))
+ echo ' TEXT("$1/$2/build/tmp/"),' >> $$@
+ echo ' NULL};' >> $$@
+ echo 'LPTSTR progDll = TEXT("../../$1/$2/build/tmp/$$($1_$2_PROG).dll");' >> $$@
+ echo 'LPTSTR rtsDll = TEXT("$$($$(WINDOWS_DYN_PROG_RTS))");' >> $$@
+ cat driver/utils/dynwrapper.c >> $$@
+
+$1/$2/build/tmp/$$($1_$2_PROG) : $1/$2/build/tmp/$$($1_$2_PROG)-inplace-wrapper.c $1/$2/build/tmp/$$($1_$2_PROG).dll | $$$$(dir $$$$@)/.
$$(call cmd,$1_$2_HC) -no-hs-main -optc-g -optc-O0 $$< -o $$@
$1/$2/build/tmp/$$($1_$2_PROG).dll : $$($1_$2_$$($1_$2_PROGRAM_WAY)_HS_OBJS) $$($1_$2_$$($1_$2_PROGRAM_WAY)_C_OBJS) $$($1_$2_$$($1_$2_PROGRAM_WAY)_S_OBJS) $$($1_$2_OTHER_OBJS) | $$$$(dir $$$$@)/.
diff --git a/utils/ghc-cabal/Main.hs b/utils/ghc-cabal/Main.hs
index 991b2b80b688..e330d5354aa7 100644
--- a/utils/ghc-cabal/Main.hs
+++ b/utils/ghc-cabal/Main.hs
@@ -437,6 +437,7 @@ generate config_args distdir directory
variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions),
variablePrefix ++ "_DEP_LIB_DIRS_SINGLE_QUOTED = " ++ unwords wrappedLibraryDirs,
variablePrefix ++ "_DEP_LIB_DIRS_SEARCHPATH = " ++ mkSearchPath libraryDirs,
+ variablePrefix ++ "_DEP_LIB_REL_DIRS = " ++ unwords libraryRelDirs,
variablePrefix ++ "_DEP_LIB_REL_DIRS_SEARCHPATH = " ++ mkSearchPath libraryRelDirs,
variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
variablePrefix ++ "_DEP_LD_OPTS = " ++ unwords (forDeps Installed.ldOptions),
--
GitLab