diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/ghci/ObjLink.lhs | 20 | ||||
| -rw-r--r-- | compiler/main/SysTools.lhs | 19 |
2 files changed, 23 insertions, 16 deletions
diff --git a/compiler/ghci/ObjLink.lhs b/compiler/ghci/ObjLink.lhs index 310ddb5e9b..cd593f7b45 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 436cfa6c4c..497a938980 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 |