[GHC] #7772: Finish support for DYNAMIC_GHC_PROGRAMS on Windows

[GHC]

#7772: Finish support for DYNAMIC_GHC_PROGRAMS on Windows
---------------------------------+------------------------------------------
    Reporter:  igloo             |       Owner:  igloo           
        Type:  bug               |      Status:  new             
    Priority:  high              |   Milestone:  7.8.1           
   Component:  Compiler          |     Version:  7.7             
    Keywords:                    |          Os:  Unknown/Multiple
Architecture:  Unknown/Multiple  |     Failure:  None/Unknown    
  Difficulty:  Unknown           |    Testcase:                  
   Blockedby:                    |    Blocking:                  
     Related:                    |  
---------------------------------+------------------------------------------
 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
 }}}

-- 
Ticket URL: <http://hackage.haskell.org/trac/ghc/ticket/7772>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler