Finish support for DYNAMIC_GHC_PROGRAMS on Windows

Finish support for DYNAMIC_GHC_PROGRAMS on Windows.

#include <stdarg.h>
#include <stdio.h>
#include <Windows.h>
#include <Shlwapi.h>

#include "Rts.h"

LPTSTR path_dirs[] = {
    TEXT("libraries/haskeline/dist-install/build"),
    TEXT("compiler/stage2/build"),
    TEXT("ghc/stage2/build/tmp"),
    TEXT("libraries/transformers/dist-install/build"),
    TEXT("libraries/template-haskell/dist-install/build"),
    TEXT("libraries/hpc/dist-install/build"),
    TEXT("libraries/hoopl/dist-install/build"),
    TEXT("libraries/bin-package-db/dist-install/build"),
    TEXT("libraries/binary/dist-install/build"),
    TEXT("libraries/Cabal/Cabal/dist-install/build"),
    TEXT("libraries/process/dist-install/build"),
    TEXT("libraries/pretty/dist-install/build"),
    TEXT("libraries/directory/dist-install/build"),
    TEXT("libraries/time/dist-install/build"),
    TEXT("libraries/old-locale/dist-install/build"),
    TEXT("libraries/filepath/dist-install/build"),
    TEXT("libraries/Win32/dist-install/build"),
    TEXT("libraries/containers/dist-install/build"),
    TEXT("libraries/bytestring/dist-install/build"),
    TEXT("libraries/deepseq/dist-install/build"),
    TEXT("libraries/array/dist-install/build"),
    TEXT("libraries/base/dist-install/build"),
    TEXT("libraries/integer-gmp/dist-install/build"),
    TEXT("libraries/ghc-prim/dist-install/build"),
    TEXT("rts/dist/build"),
    NULL
};

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);
}

void setPath(void) {
    LPTSTR *dir;
    LPTSTR path;
    int n;
    int len = 0;
    LPTSTR exePath, s;
    HMODULE hExe;

    hExe = GetModuleHandle(NULL);
    if (hExe == NULL) {
        die("GetModuleHandle failed");
    }
    exePath = malloc(10000); // XXX
    GetModuleFileName(hExe, exePath, 10000); // XXX
    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(10000); // XXX
    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';

    if (! SetEnvironmentVariable(TEXT("PATH"), path)) {
        printf("SetEnvironmentVariable failed (%d)\n", GetLastError());
    }
}

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 failed: %d: %s\n", 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;

    StgClosure *main_p;
    RtsConfig *rts_config_p;
    hs_main_t hs_main_p;

    setPath();

    // hRtsDll = loadDll(TEXT("libHSrts_debug-ghc7.7.20130315.dll"));
    // hRtsDll = loadDll(TEXT("libHSrts_thr-ghc7.7.20130315.dll"));
    // hRtsDll = loadDll(TEXT("libHSrts-ghc7.7.20130315.dll"));
    hProgDll = loadDll(TEXT("ghc-stage2.exe.dll"));
    hRtsDll = GetNonNullModuleHandle(TEXT("libHSrts-ghc7.7.20130315.dll"));

    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);
}

Gives:

Segmentation fault/access violation in generated code

Trac metadata

Trac field	Value
Version	7.7
Type	Bug
TypeOfFailure	OtherFailure
Priority	high
Resolution	Unresolved
Component	Compiler
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system
Architecture