Make the RTS linker API use wide-char pathnames on Windows (#5697)

I haven't been able to test whether this works or not due to #5754,
but at least it doesn't appear to break anything.

4 files changed, 107 insertions, 87 deletions

diff --git a/compiler/ghci/ObjLink.lhs b/compiler/ghci/ObjLink.lhs
index f467c7ada3..dedc9ceb2f 100644
--- a/compiler/ghci/ObjLink.lhs
+++ b/compiler/ghci/ObjLink.lhs
@@ -36,12 +36,7 @@ import Control.Monad    ( when )
 import Foreign.C
 import Foreign		( nullPtr )
 import GHC.Exts         ( Ptr(..) )
-#if __GLASGOW_HASKELL__ >= 703
-import GHC.IO.Encoding (getFileSystemEncoding)
-#else
-import GHC.IO.Encoding (TextEncoding, fileSystemEncoding)
-#endif
-import qualified GHC.Foreign as GHC
+import System.Posix.Internals ( CFilePath, withFilePath )
 import System.FilePath  ( dropExtension )
 
 
@@ -49,21 +44,10 @@ import System.FilePath  ( dropExtension )
 -- RTS Linker Interface
 -- ---------------------------------------------------------------------------
 
-#if __GLASGOW_HASKELL__ < 703
-getFileSystemEncoding :: IO TextEncoding
-getFileSystemEncoding = return fileSystemEncoding
-#endif
-
--- UNICODE FIXME: Unicode object/archive/DLL file names on Windows will only work in the right code page
-withFileCString :: FilePath -> (CString -> IO a) -> IO a
-withFileCString fp f = do
-    enc <- getFileSystemEncoding
-    GHC.withCString enc fp f
-
 insertSymbol :: String -> String -> Ptr a -> IO ()
 insertSymbol obj_name key symbol
     = let str = prefixUnderscore key
-      in withFileCString obj_name $ \c_obj_name ->
+      in withFilePath obj_name $ \c_obj_name ->
          withCAString str $ \c_str ->
           c_insertSymbol c_obj_name c_str symbol
 
@@ -99,7 +83,7 @@ loadDLL str0 = do
      str | isWindowsHost = dropExtension str0
          | otherwise     = str0
   --
-  maybe_errmsg <- withFileCString str $ \dll -> c_addDLL dll
+  maybe_errmsg <- withFilePath str $ \dll -> c_addDLL dll
   if maybe_errmsg == nullPtr
 	then return Nothing
 	else do str <- peekCString maybe_errmsg
@@ -107,19 +91,19 @@ loadDLL str0 = do
 
 loadArchive :: String -> IO ()
 loadArchive str = do
-   withFileCString str $ \c_str -> do
+   withFilePath str $ \c_str -> do
      r <- c_loadArchive c_str
      when (r == 0) (panic ("loadArchive " ++ show str ++ ": failed"))
 
 loadObj :: String -> IO ()
 loadObj str = do
-   withFileCString str $ \c_str -> do
+   withFilePath str $ \c_str -> do
      r <- c_loadObj c_str
      when (r == 0) (panic ("loadObj " ++ show str ++ ": failed"))
 
 unloadObj :: String -> IO ()
 unloadObj str =
-   withFileCString str $ \c_str -> do
+   withFilePath str $ \c_str -> do
      r <- c_unloadObj c_str
      when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed"))
 
@@ -132,12 +116,12 @@ resolveObjs = do
 -- Foreign declarations to RTS entry points which does the real work;
 -- ---------------------------------------------------------------------------
 
-foreign import ccall unsafe "addDLL"	   c_addDLL :: CString -> IO CString
+foreign import ccall unsafe "addDLL"       c_addDLL :: CFilePath -> IO CString
 foreign import ccall unsafe "initLinker"   initObjLinker :: IO ()
-foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CString -> CString -> Ptr a -> IO ()
+foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CFilePath -> CString -> Ptr a -> IO ()
 foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a)
-foreign import ccall unsafe "loadArchive"  c_loadArchive :: CString -> IO Int
-foreign import ccall unsafe "loadObj"      c_loadObj :: CString -> IO Int
-foreign import ccall unsafe "unloadObj"    c_unloadObj :: CString -> IO Int
+foreign import ccall unsafe "loadArchive"  c_loadArchive :: CFilePath -> IO Int
+foreign import ccall unsafe "loadObj"      c_loadObj :: CFilePath -> IO Int
+foreign import ccall unsafe "unloadObj"    c_unloadObj :: CFilePath -> IO Int
 foreign import ccall unsafe "resolveObjs"  c_resolveObjs :: IO Int
 \end{code}
diff --git a/includes/rts/Linker.h b/includes/rts/Linker.h
index f7c8ce9c4b..e900e858c1 100644
--- a/includes/rts/Linker.h
+++ b/includes/rts/Linker.h
@@ -14,31 +14,37 @@
 #ifndef RTS_LINKER_H
 #define RTS_LINKER_H
 
+#if defined(mingw32_HOST_OS)
+typedef wchar_t pathchar;
+#else
+typedef char    pathchar;
+#endif
+
 /* initialize the object linker */
 void initLinker( void );
 
 /* insert a stable symbol in the hash table */
-void insertStableSymbol(char* obj_name, char* key, StgPtr data);
+void insertStableSymbol(pathchar* obj_name, char* key, StgPtr data);
 
 /* insert a symbol in the hash table */
-void insertSymbol(char* obj_name, char* key, void* data);
+void insertSymbol(pathchar* obj_name, char* key, void* data);
 
 /* lookup a symbol in the hash table */
 void *lookupSymbol( char *lbl );
 
 /* delete an object from the pool */
-HsInt unloadObj( char *path );
+HsInt unloadObj( pathchar *path );
 
 /* add an obj (populate the global symbol table, but don't resolve yet) */
-HsInt loadObj( char *path );
+HsInt loadObj( pathchar *path );
 
 /* add an arch (populate the global symbol table, but don't resolve yet) */
-HsInt loadArchive( char *path );
+HsInt loadArchive( pathchar *path );
 
 /* resolve all the currently unlinked objects in memory */
 HsInt resolveObjs( void );
 
 /* load a dynamic library */
-const char *addDLL( char* dll_name );
+const char *addDLL( pathchar* dll_name );
 
 #endif /* RTS_LINKER_H */
diff --git a/rts/Linker.c b/rts/Linker.c
index 7e3c7b1167..7fc6d0a804 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -131,7 +131,7 @@ static /*Str*/HashTable *stablehash;
 ObjectCode *objects = NULL;     /* initially empty */
 
 static HsInt loadOc( ObjectCode* oc );
-static ObjectCode* mkOc( char *path, char *image, int imageSize,
+static ObjectCode* mkOc( pathchar *path, char *image, int imageSize,
                          char *archiveMemberName
 #ifndef USE_MMAP
 #ifdef darwin_HOST_OS
@@ -140,6 +140,40 @@ static ObjectCode* mkOc( char *path, char *image, int imageSize,
 #endif
                        );
 
+// Use wchar_t for pathnames on Windows (#5697)
+#if defined(mingw32_HOST_OS)
+#define pathcmp wcscmp
+#define pathlen wcslen
+#define pathopen _wfopen
+#define pathstat _wstat
+#define struct_stat struct _stat
+#define open wopen
+#define WSTR(s) L##s
+#define PATH_FMT "S"
+#else
+#define pathcmp strcmp
+#define pathlen strlen
+#define pathopen fopen
+#define pathstat stat
+#define struct_stat struct stat
+#define WSTR(s) s
+#define PATH_FMT "s"
+#endif
+
+static pathchar* pathdup(pathchar *path)
+{
+    pathchar *ret;
+#if defined(mingw32_HOST_OS)
+    ret = wcsdup(path);
+#else
+    /* sigh, strdup() isn't a POSIX function, so do it the long way */
+    ret = stgMallocBytes( strlen(path)+1, "loadObj" );
+    strcpy(ret, path);
+#endif
+    return ret;
+}
+
+
 #if defined(OBJFORMAT_ELF)
 static int ocVerifyImage_ELF    ( ObjectCode* oc );
 static int ocGetNames_ELF       ( ObjectCode* oc );
@@ -1097,12 +1131,11 @@ static RtsSymbolVal rtsSyms[] = {
 };
 
 
-
 /* -----------------------------------------------------------------------------
  * Insert symbols into hash tables, checking for duplicates.
  */
 
-static void ghciInsertStrHashTable ( char* obj_name,
+static void ghciInsertStrHashTable ( pathchar* obj_name,
                                      HashTable *table,
                                      char* key,
                                      void *data
@@ -1118,7 +1151,7 @@ static void ghciInsertStrHashTable ( char* obj_name,
       "GHCi runtime linker: fatal error: I found a duplicate definition for symbol\n"
       "   %s\n"
       "whilst processing object file\n"
-      "   %s\n"
+      "   %" PATH_FMT "\n"
       "This could be caused by:\n"
       "   * Loading two different object files which export the same symbol\n"
       "   * Specifying the same object file twice on the GHCi command line\n"
@@ -1175,7 +1208,7 @@ initLinker( void )
 
     /* populate the symbol table with stuff from the RTS */
     for (sym = rtsSyms; sym->lbl != NULL; sym++) {
-        ghciInsertStrHashTable("(GHCi built-in symbols)",
+        ghciInsertStrHashTable(WSTR("(GHCi built-in symbols)"),
                                symhash, sym->lbl, sym->addr);
         IF_DEBUG(linker, debugBelch("initLinker: inserting rts symbol %s, %p\n", sym->lbl, sym->addr));
     }
@@ -1217,8 +1250,8 @@ initLinker( void )
      * but are necessary for resolving symbols in GHCi, hence we load
      * them manually here.
      */
-    addDLL("msvcrt");
-    addDLL("kernel32");
+    addDLL(WSTR("msvcrt"));
+    addDLL(WSTR("kernel32"));
 #endif
 
     IF_DEBUG(linker, debugBelch("initLinker: done\n"));
@@ -1263,7 +1296,7 @@ exitLinker( void ) {
 
 typedef
    struct _OpenedDLL {
-      char*              name;
+      pathchar*          name;
       struct _OpenedDLL* next;
       HINSTANCE instance;
    }
@@ -1313,7 +1346,7 @@ internal_dlopen(const char *dll_name)
 #  endif
 
 const char *
-addDLL( char *dll_name )
+addDLL( pathchar *dll_name )
 {
 #  if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
    /* ------------------- ELF DLL loader ------------------- */
@@ -1385,7 +1418,7 @@ addDLL( char *dll_name )
 #  elif defined(OBJFORMAT_PEi386)
    /* ------------------- Win32 DLL loader ------------------- */
 
-   char*      buf;
+   pathchar*      buf;
    OpenedDLL* o_dll;
    HINSTANCE  instance;
 
@@ -1395,7 +1428,7 @@ addDLL( char *dll_name )
 
    /* See if we've already got it, and ignore if so. */
    for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
-      if (0 == strcmp(o_dll->name, dll_name))
+      if (0 == pathcmp(o_dll->name, dll_name))
          return NULL;
    }
 
@@ -1409,19 +1442,19 @@ addDLL( char *dll_name )
         point character (.) to indicate that the module name has no
         extension. */
 
-   buf = stgMallocBytes(strlen(dll_name) + 10, "addDLL");
-   sprintf(buf, "%s.DLL", dll_name);
-   instance = LoadLibrary(buf);
+   buf = stgMallocBytes((pathlen(dll_name) + 10) * sizeof(wchar_t), "addDLL");
+   swprintf(buf, L"%s.DLL", dll_name);
+   instance = LoadLibraryW(buf);
    if (instance == NULL) {
        if (GetLastError() != ERROR_MOD_NOT_FOUND) goto error;
        // KAA: allow loading of drivers (like winspool.drv)
-       sprintf(buf, "%s.DRV", dll_name);
-       instance = LoadLibrary(buf);
+       swprintf(buf, L"%s.DRV", dll_name);
+       instance = LoadLibraryW(buf);
        if (instance == NULL) {
            if (GetLastError() != ERROR_MOD_NOT_FOUND) goto error;
            // #1883: allow loading of unix-style libfoo.dll DLLs
-           sprintf(buf, "lib%s.DLL", dll_name);
-           instance = LoadLibrary(buf);
+           swprintf(buf, L"lib%s.DLL", dll_name);
+           instance = LoadLibraryW(buf);
            if (instance == NULL) {
                goto error;
            }
@@ -1431,8 +1464,7 @@ addDLL( char *dll_name )
 
    /* Add this DLL to the list of DLLs in which to search for symbols. */
    o_dll = stgMallocBytes( sizeof(OpenedDLL), "addDLL" );
-   o_dll->name     = stgMallocBytes(1+strlen(dll_name), "addDLL");
-   strcpy(o_dll->name, dll_name);
+   o_dll->name     = pathdup(dll_name);
    o_dll->instance = instance;
    o_dll->next     = opened_dlls;
    opened_dlls     = o_dll;
@@ -1441,7 +1473,7 @@ addDLL( char *dll_name )
 
 error:
    stgFree(buf);
-   sysErrorBelch(dll_name);
+   sysErrorBelch("%" PATH_FMT, dll_name);
 
    /* LoadLibrary failed; return a ptr to the error msg. */
    return "addDLL: could not load DLL";
@@ -1456,7 +1488,7 @@ error:
  */
 
 void
-insertStableSymbol(char* obj_name, char* key, StgPtr p)
+insertStableSymbol(pathchar* obj_name, char* key, StgPtr p)
 {
   ghciInsertStrHashTable(obj_name, stablehash, key, getStablePtr(p));
 }
@@ -1466,7 +1498,7 @@ insertStableSymbol(char* obj_name, char* key, StgPtr p)
  * insert a symbol in the hash table
  */
 void
-insertSymbol(char* obj_name, char* key, void* data)
+insertSymbol(pathchar* obj_name, char* key, void* data)
 {
   ghciInsertStrHashTable(obj_name, symhash, key, data);
 }
@@ -1646,7 +1678,7 @@ mmap_again:
 #endif // USE_MMAP
 
 static ObjectCode*
-mkOc( char *path, char *image, int imageSize,
+mkOc( pathchar *path, char *image, int imageSize,
       char *archiveMemberName
 #ifndef USE_MMAP
 #ifdef darwin_HOST_OS
@@ -1671,9 +1703,7 @@ mkOc( char *path, char *image, int imageSize,
 #  endif
 
    oc->image = image;
-   /* sigh, strdup() isn't a POSIX function, so do it the long way */
-   oc->fileName = stgMallocBytes( strlen(path)+1, "loadObj" );
-   strcpy(oc->fileName, path);
+   oc->fileName = pathdup(path);
 
    if (archiveMemberName) {
        oc->archiveMemberName = stgMallocBytes( strlen(archiveMemberName)+1, "loadObj" );
@@ -1703,7 +1733,7 @@ mkOc( char *path, char *image, int imageSize,
 }
 
 HsInt
-loadArchive( char *path )
+loadArchive( pathchar *path )
 {
     ObjectCode* oc;
     char *image;
@@ -1741,7 +1771,7 @@ loadArchive( char *path )
 #endif
 
     IF_DEBUG(linker, debugBelch("loadArchive: start\n"));
-    IF_DEBUG(linker, debugBelch("loadArchive: Loading archive `%s'\n", path));
+    IF_DEBUG(linker, debugBelch("loadArchive: Loading archive `%" PATH_FMT" '\n", path));
 
     gnuFileIndex = NULL;
     gnuFileIndexSize = 0;
@@ -1749,7 +1779,7 @@ loadArchive( char *path )
     fileNameSize = 32;
     fileName = stgMallocBytes(fileNameSize, "loadArchive(fileName)");
 
-    f = fopen(path, "rb");
+    f = pathopen(path, WSTR("rb"));
     if (!f)
         barf("loadObj: can't read `%s'", path);
 
@@ -1829,7 +1859,7 @@ loadArchive( char *path )
         n = fread ( fileName, 1, 16, f );
         if (n != 16) {
             if (feof(f)) {
-                IF_DEBUG(linker, debugBelch("loadArchive: EOF while reading from '%s'\n", path));
+                IF_DEBUG(linker, debugBelch("loadArchive: EOF while reading from '%" PATH_FMT "'\n", path));
                 break;
             }
             else {
@@ -2018,9 +2048,9 @@ loadArchive( char *path )
                 barf("loadArchive: error whilst reading `%s'", path);
             }
 
-            archiveMemberName = stgMallocBytes(strlen(path) + thisFileNameSize + 3,
+            archiveMemberName = stgMallocBytes(pathlen(path) + thisFileNameSize + 3,
                                                "loadArchive(file)");
-            sprintf(archiveMemberName, "%s(%.*s)",
+            sprintf(archiveMemberName, "%" PATH_FMT "(%.*s)",
                     path, (int)thisFileNameSize, fileName);
 
             oc = mkOc(path, image, memberSize, archiveMemberName
@@ -2102,12 +2132,12 @@ loadArchive( char *path )
  * Returns: 1 if ok, 0 on error.
  */
 HsInt
-loadObj( char *path )
+loadObj( pathchar *path )
 {
    ObjectCode* oc;
    char *image;
    int fileSize;
-   struct stat st;
+   struct_stat st;
    int r;
 #ifdef USE_MMAP
    int fd;
@@ -2117,7 +2147,7 @@ loadObj( char *path )
    int misalignment;
 #  endif
 #endif
-   IF_DEBUG(linker, debugBelch("loadObj %s\n", path));
+   IF_DEBUG(linker, debugBelch("loadObj %" PATH_FMT "\n", path));
 
    initLinker();
 
@@ -2129,7 +2159,7 @@ loadObj( char *path )
        ObjectCode *o;
        int is_dup = 0;
        for (o = objects; o; o = o->next) {
-          if (0 == strcmp(o->fileName, path)) {
+          if (0 == pathcmp(o->fileName, path)) {
              is_dup = 1;
              break; /* don't need to search further */
           }
@@ -2138,14 +2168,14 @@ loadObj( char *path )
           IF_DEBUG(linker, debugBelch(
             "GHCi runtime linker: warning: looks like you're trying to load the\n"
             "same object file twice:\n"
-            "   %s\n"
+            "   %" PATH_FMT "\n"
             "GHCi will ignore this, but be warned.\n"
             , path));
           return 1; /* success */
        }
    }
 
-   r = stat(path, &st);
+   r = pathstat(path, &st);
    if (r == -1) {
        IF_DEBUG(linker, debugBelch("File doesn't exist\n"));
        return 0;
@@ -2170,9 +2200,9 @@ loadObj( char *path )
 
 #else /* !USE_MMAP */
    /* load the image into memory */
-   f = fopen(path, "rb");
+   f = pathopen(path, WSTR("rb"));
    if (!f)
-       barf("loadObj: can't read `%s'", path);
+       barf("loadObj: can't read `%" PATH_FMT "'", path);
 
 #   if defined(mingw32_HOST_OS)
         // TODO: We would like to use allocateExec here, but allocateExec
@@ -2310,7 +2340,7 @@ resolveObjs( void )
  * delete an object from the pool
  */
 HsInt
-unloadObj( char *path )
+unloadObj( pathchar *path )
 {
     ObjectCode *oc, *prev;
     HsBool unloadedAnyObj = HS_BOOL_FALSE;
@@ -2322,7 +2352,7 @@ unloadObj( char *path )
 
     prev = NULL;
     for (oc = objects; oc; prev = oc, oc = oc->next) {
-        if (!strcmp(oc->fileName,path)) {
+        if (!pathcmp(oc->fileName,path)) {
 
             /* Remove all the mappings for the symbols within this
              * object..
@@ -2365,7 +2395,7 @@ unloadObj( char *path )
         return 1;
     }
     else {
-        errorBelch("unloadObj: can't find `%s' to unload", path);
+        errorBelch("unloadObj: can't find `%" PATH_FMT "' to unload", path);
         return 0;
     }
 }
@@ -2938,23 +2968,23 @@ ocVerifyImage_PEi386 ( ObjectCode* oc )
             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
 
    if (hdr->Machine != 0x14c) {
-      errorBelch("%s: Not x86 PEi386", oc->fileName);
+      errorBelch("%" PATH_FMT ": Not x86 PEi386", oc->fileName);
       return 0;
    }
    if (hdr->SizeOfOptionalHeader != 0) {
-      errorBelch("%s: PEi386 with nonempty optional header", oc->fileName);
+      errorBelch("%" PATH_FMT ": PEi386 with nonempty optional header", oc->fileName);
       return 0;
    }
    if ( /* (hdr->Characteristics & MYIMAGE_FILE_RELOCS_STRIPPED) || */
         (hdr->Characteristics & MYIMAGE_FILE_EXECUTABLE_IMAGE) ||
         (hdr->Characteristics & MYIMAGE_FILE_DLL) ||
         (hdr->Characteristics & MYIMAGE_FILE_SYSTEM) ) {
-      errorBelch("%s: Not a PEi386 object file", oc->fileName);
+      errorBelch("%" PATH_FMT ": Not a PEi386 object file", oc->fileName);
       return 0;
    }
    if ( (hdr->Characteristics & MYIMAGE_FILE_BYTES_REVERSED_HI)
         /* || !(hdr->Characteristics & MYIMAGE_FILE_32BIT_MACHINE) */ ) {
-      errorBelch("%s: Invalid PEi386 word size or endiannness: %d",
+      errorBelch("%" PATH_FMT ": Invalid PEi386 word size or endiannness: %d",
                  oc->fileName,
                  (int)(hdr->Characteristics));
       return 0;
@@ -3229,7 +3259,7 @@ ocGetNames_PEi386 ( ObjectCode* oc )
           && 0!= strcmp(".reloc", (char*)secname)
           && 0 != strcmp(".rdata$zzz", (char*)secname)
          ) {
-         errorBelch("Unknown PEi386 section name `%s' (while processing: %s)", secname, oc->fileName);
+         errorBelch("Unknown PEi386 section name `%s' (while processing: %" PATH_FMT")", secname, oc->fileName);
          stgFree(secname);
          return 0;
       }
@@ -3448,7 +3478,7 @@ ocResolve_PEi386 ( ObjectCode* oc )
             COFF_section* section_sym
                = findPEi386SectionCalled ( oc, sym->Name );
             if (!section_sym) {
-               errorBelch("%s: can't find section `%s'", oc->fileName, sym->Name);
+               errorBelch("%" PATH_FMT ": can't find section `%s'", oc->fileName, sym->Name);
                return 0;
             }
             S = ((UInt32)(oc->image))
@@ -3458,7 +3488,7 @@ ocResolve_PEi386 ( ObjectCode* oc )
             copyName ( sym->Name, strtab, symbol, 1000-1 );
             S = (UInt32) lookupSymbol( (char*)symbol );
             if ((void*)S != NULL) goto foundit;
-            errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
+            errorBelch("%" PATH_FMT ": unknown symbol `%s'", oc->fileName, symbol);
             return 0;
            foundit:;
          }
@@ -3496,7 +3526,7 @@ ocResolve_PEi386 ( ObjectCode* oc )
                *pP = S - ((UInt32)pP) - 4 + A;
                break;
             default:
-               debugBelch("%s: unhandled PEi386 relocation type %d",
+               debugBelch("%" PATH_FMT ": unhandled PEi386 relocation type %d",
                      oc->fileName, reltab_j->Type);
                return 0;
          }
@@ -3504,7 +3534,7 @@ ocResolve_PEi386 ( ObjectCode* oc )
       }
    }
 
-   IF_DEBUG(linker, debugBelch("completed %s", oc->fileName));
+   IF_DEBUG(linker, debugBelch("completed %" PATH_FMT, oc->fileName));
    return 1;
 }
 
diff --git a/rts/LinkerInternals.h b/rts/LinkerInternals.h
index d545c12ed9..dd4d7ed939 100644
--- a/rts/LinkerInternals.h
+++ b/rts/LinkerInternals.h
@@ -61,7 +61,7 @@ typedef struct {
  */
 typedef struct _ObjectCode {
     OStatus    status;
-    char*      fileName;
+    pathchar  *fileName;
     int        fileSize;
     char*      formatName;            /* eg "ELF32", "DLL", "COFF", etc. */