From 1a410093862a85b51aa59605af80868eaecd25c4 Mon Sep 17 00:00:00 2001 From: Max Bolingbroke Date: Sat, 14 May 2011 22:34:41 +0100 Subject: [PATCH] Unicode fixes, taking into account PEP383 support --- compiler/ghci/ObjLink.lhs | 20 +++++++++------ compiler/main/SysTools.lhs | 19 ++++++++------- includes/Rts.h | 6 +++++ rts/Linker.c | 2 ++ rts/RtsFlags.c | 58 ++++++++++++++++++++++++++++++++++++++++++++ utils/ghc-pkg/Main.hs | 21 ++++++++-------- utils/runghc/runghc.hs | 20 ++++++++------- 7 files changed, 111 insertions(+), 35 deletions(-) diff --git a/compiler/ghci/ObjLink.lhs b/compiler/ghci/ObjLink.lhs index 310ddb5..cd593f7 100644 --- a/compiler/ghci/ObjLink.lhs +++ b/compiler/ghci/ObjLink.lhs @@ -28,6 +28,8 @@ import Control.Monad ( when ) import Foreign.C import Foreign ( nullPtr ) import GHC.Exts ( Ptr(..) ) +import GHC.IO.Encoding ( fileSystemEncoding ) +import qualified GHC.Foreign as GHC @@ -35,17 +37,21 @@ import GHC.Exts ( Ptr(..) ) -- RTS Linker Interface -- --------------------------------------------------------------------------- +-- 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 = GHC.withCString fileSystemEncoding + insertSymbol :: String -> String -> Ptr a -> IO () insertSymbol obj_name key symbol = let str = prefixUnderscore key - in withCString obj_name $ \c_obj_name -> - withCString str $ \c_str -> + in withFileCString obj_name $ \c_obj_name -> + withCAString str $ \c_str -> c_insertSymbol c_obj_name c_str symbol lookupSymbol :: String -> IO (Maybe (Ptr a)) lookupSymbol str_in = do let str = prefixUnderscore str_in - withCString str $ \c_str -> do + withCAString str $ \c_str -> do addr <- c_lookupSymbol c_str if addr == nullPtr then return Nothing @@ -60,7 +66,7 @@ loadDLL :: String -> IO (Maybe String) -- Nothing => success -- Just err_msg => failure loadDLL str = do - maybe_errmsg <- withCString str $ \dll -> c_addDLL dll + maybe_errmsg <- withFileCString str $ \dll -> c_addDLL dll if maybe_errmsg == nullPtr then return Nothing else do str <- peekCString maybe_errmsg @@ -68,19 +74,19 @@ loadDLL str = do loadArchive :: String -> IO () loadArchive str = do - withCString str $ \c_str -> do + withFileCString str $ \c_str -> do r <- c_loadArchive c_str when (r == 0) (panic ("loadArchive " ++ show str ++ ": failed")) loadObj :: String -> IO () loadObj str = do - withCString str $ \c_str -> do + withFileCString str $ \c_str -> do r <- c_loadObj c_str when (r == 0) (panic ("loadObj " ++ show str ++ ": failed")) unloadObj :: String -> IO () unloadObj str = - withCString str $ \c_str -> do + withFileCString str $ \c_str -> do r <- c_unloadObj c_str when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed")) diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 436cfa6..497a938 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -822,14 +822,15 @@ getBaseDir :: IO (Maybe String) #if defined(mingw32_HOST_OS) -- Assuming we are running ghc, accessed by path $(stuff)/bin/ghc.exe, -- return the path $(stuff)/lib. -getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32. - buf <- mallocArray len - ret <- getModuleFileName nullPtr buf len - if ret == 0 then free buf >> return Nothing - else do s <- peekCString buf - free buf - return (Just (rootDir s)) +getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. where + try_size size = allocaArray (fromIntegral size) $ \buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> return Nothing + _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf + | otherwise -> try_size (size * 2) + rootDir s = case splitFileName $ normalise s of (d, ghc_exe) | lower ghc_exe `elem` ["ghc.exe", @@ -844,8 +845,8 @@ getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32. where fail = panic ("can't decompose ghc.exe path: " ++ show s) lower = map toLower -foreign import stdcall unsafe "GetModuleFileNameA" - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 +foreign import stdcall unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 #else getBaseDir = return Nothing #endif diff --git a/includes/Rts.h b/includes/Rts.h index 51351fa..3a6c6f2 100644 --- a/includes/Rts.h +++ b/includes/Rts.h @@ -219,6 +219,12 @@ DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell * DLL_IMPORT_RTS extern int prog_argc; DLL_IMPORT_RTS extern char *prog_name; +#ifdef mingw32_HOST_OS +// We need these two from Haskell too +void getWin32ProgArgv(int *argc, wchar_t **argv[]); +void setWin32ProgArgv(int argc, wchar_t *argv[]); +#endif + void stackOverflow(void); void stg_exit(int n) GNU_ATTRIBUTE(__noreturn__); diff --git a/rts/Linker.c b/rts/Linker.c index 2c084ba..28ba9a0 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -387,6 +387,8 @@ typedef struct _RtsSymbolVal { SymI_HasProto(stg_asyncReadzh) \ SymI_HasProto(stg_asyncWritezh) \ SymI_HasProto(stg_asyncDoProczh) \ + SymI_HasProto(getWin32ProgArgv) \ + SymI_HasProto(setWin32ProgArgv) \ SymI_HasProto(memset) \ SymI_HasProto(inet_ntoa) \ SymI_HasProto(inet_addr) \ diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index 408e1c7..1408070 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -34,6 +34,14 @@ char **full_prog_argv = NULL; char *prog_name = NULL; /* 'basename' of prog_argv[0] */ int rts_argc = 0; /* ditto */ char *rts_argv[MAX_RTS_ARGS]; +#if defined(mingw32_HOST_OS) +// On Windows, we want to use GetCommandLineW rather than argc/argv, +// but we need to mutate the command line arguments for withProgName and +// friends. The System.Environment module achieves that using this bit of +// shared state: +int win32_prog_argc = 0; +wchar_t **win32_prog_argv = NULL; +#endif /* * constants, used later @@ -1536,3 +1544,53 @@ freeFullProgArgv (void) full_prog_argc = 0; full_prog_argv = NULL; } + +#if defined(mingw32_HOST_OS) +void freeWin32ProgArgv (void); + +void +freeWin32ProgArgv (void) +{ + int i; + + if (win32_prog_argv != NULL) { + for (i = 0; i < win32_prog_argc; i++) { + stgFree(win32_prog_argv[i]); + } + stgFree(win32_prog_argv); + } + + win32_prog_argc = 0; + win32_prog_argv = NULL; +} + +void +getWin32ProgArgv(int *argc, wchar_t **argv[]) +{ + *argc = win32_prog_argc; + *argv = win32_prog_argv; +} + +void +setWin32ProgArgv(int argc, wchar_t *argv[]) +{ + int i; + + freeWin32ProgArgv(); + + win32_prog_argc = argc; + if (argv == NULL) { + win32_prog_argv = NULL; + return; + } + + win32_prog_argv = stgCallocBytes(argc + 1, sizeof (wchar_t *), + "setWin32ProgArgv 1"); + for (i = 0; i < argc; i++) { + win32_prog_argv[i] = stgMallocBytes((wcslen(argv[i]) + 1) * sizeof(wchar_t), + "setWin32ProgArgv 2"); + wcscpy(win32_prog_argv[i], argv[i]); + } + win32_prog_argv[argc] = NULL; +} +#endif diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 1cec56a..74f761b 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -1487,16 +1487,17 @@ getExecDir cmd = removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath getExecPath :: IO (Maybe String) -getExecPath = - allocaArray len $ \buf -> do - ret <- getModuleFileName nullPtr buf len - if ret == 0 then return Nothing - else liftM Just $ peekCString buf - where len = 2048 -- Plenty, PATH_MAX is 512 under Win32. - -foreign import stdcall unsafe "GetModuleFileNameA" - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 - +getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. + where + try_size size = allocaArray (fromIntegral size) $ \buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> return Nothing + _ | ret < size -> fmap Just $ peekCWString buf + | otherwise -> try_size (size * 2) + +foreign import stdcall unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 #else getLibDir :: IO (Maybe String) getLibDir = return Nothing diff --git a/utils/runghc/runghc.hs b/utils/runghc/runghc.hs index ab49513..4424c96 100644 --- a/utils/runghc/runghc.hs +++ b/utils/runghc/runghc.hs @@ -149,15 +149,17 @@ dieProg msg = do getExecPath :: IO (Maybe String) #if defined(mingw32_HOST_OS) -getExecPath = - allocaArray len $ \buf -> do - ret <- getModuleFileName nullPtr buf len - if ret == 0 then return Nothing - else liftM Just $ peekCString buf - where len = 2048 -- Plenty, PATH_MAX is 512 under Win32. - -foreign import stdcall unsafe "GetModuleFileNameA" - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 +getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. + where + try_size size = allocaArray (fromIntegral size) $ \buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> return Nothing + _ | ret < size -> fmap Just $ peekCWString buf + | otherwise -> try_size (size * 2) + +foreign import stdcall unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 #else getExecPath = return Nothing #endif -- 1.7.10.4