Try to integrate @abarbu patches.
This commit is contained in:
parent
2443774403
commit
57aa1e606a
@ -59,6 +59,7 @@ library
|
|||||||
filepath,
|
filepath,
|
||||||
random,
|
random,
|
||||||
process,
|
process,
|
||||||
|
split,
|
||||||
ghc >= 6.10,
|
ghc >= 6.10,
|
||||||
ghc-prim
|
ghc-prim
|
||||||
|
|
||||||
|
@ -40,13 +40,15 @@ module System.Plugins.Env (
|
|||||||
lookupMerged,
|
lookupMerged,
|
||||||
addMerge,
|
addMerge,
|
||||||
addPkgConf,
|
addPkgConf,
|
||||||
|
defaultPkgConf,
|
||||||
union,
|
union,
|
||||||
addStaticPkg,
|
addStaticPkg,
|
||||||
isStaticPkg,
|
isStaticPkg,
|
||||||
rmStaticPkg,
|
rmStaticPkg,
|
||||||
grabDefaultPkgConf,
|
grabDefaultPkgConf,
|
||||||
readPackageConf,
|
readPackageConf,
|
||||||
lookupPkg
|
lookupPkg,
|
||||||
|
pkgManglingPrefix
|
||||||
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
@ -59,7 +61,7 @@ import Control.Monad ( liftM )
|
|||||||
|
|
||||||
import Data.IORef ( writeIORef, readIORef, newIORef, IORef() )
|
import Data.IORef ( writeIORef, readIORef, newIORef, IORef() )
|
||||||
import Data.Maybe ( isJust, isNothing, fromMaybe )
|
import Data.Maybe ( isJust, isNothing, fromMaybe )
|
||||||
import Data.List ( (\\), nub, )
|
import Data.List ( (\\), nub )
|
||||||
|
|
||||||
import System.IO.Unsafe ( unsafePerformIO )
|
import System.IO.Unsafe ( unsafePerformIO )
|
||||||
import System.Directory ( doesFileExist )
|
import System.Directory ( doesFileExist )
|
||||||
@ -83,6 +85,7 @@ import Distribution.Package hiding (
|
|||||||
Module,
|
Module,
|
||||||
#endif
|
#endif
|
||||||
depends, packageName, PackageName(..)
|
depends, packageName, PackageName(..)
|
||||||
|
, installedUnitId
|
||||||
#if MIN_VERSION_ghc(7,10,0)
|
#if MIN_VERSION_ghc(7,10,0)
|
||||||
, installedPackageId
|
, installedPackageId
|
||||||
#endif
|
#endif
|
||||||
@ -96,6 +99,9 @@ import Distribution.Simple.PackageIndex
|
|||||||
import Distribution.Simple.Program
|
import Distribution.Simple.Program
|
||||||
import Distribution.Verbosity
|
import Distribution.Verbosity
|
||||||
|
|
||||||
|
import System.Environment
|
||||||
|
import Data.List.Split
|
||||||
|
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import qualified Data.Set as S
|
import qualified Data.Set as S
|
||||||
--
|
--
|
||||||
@ -305,6 +311,15 @@ addPkgConf f = do
|
|||||||
ps <- readPackageConf f
|
ps <- readPackageConf f
|
||||||
modifyPkgEnv env $ \ls -> return $ union ls ps
|
modifyPkgEnv env $ \ls -> return $ union ls ps
|
||||||
|
|
||||||
|
-- | This function is required when running with stack.
|
||||||
|
defaultPkgConf :: IO ()
|
||||||
|
defaultPkgConf = do
|
||||||
|
paths <- lookupEnv "GHC_PACKAGE_PATH"
|
||||||
|
unsetEnv "GHC_PACKAGE_PATH"
|
||||||
|
case paths of
|
||||||
|
Nothing -> return ()
|
||||||
|
Just s -> mapM_ addPkgConf $ splitOn ":" s
|
||||||
|
|
||||||
--
|
--
|
||||||
-- | add a new FM for the package.conf to the list of existing ones; if a package occurs multiple
|
-- | add a new FM for the package.conf to the list of existing ones; if a package occurs multiple
|
||||||
-- times, pick the one with the higher version number as the default (e.g., important for base in
|
-- times, pick the one with the higher version number as the default (e.g., important for base in
|
||||||
@ -407,6 +422,17 @@ lookupPkg pn = go [] pn
|
|||||||
(f', g') <- liftM unzip $ mapM (go (nub $ seen ++ ps)) (ps \\ seen)
|
(f', g') <- liftM unzip $ mapM (go (nub $ seen ++ ps)) (ps \\ seen)
|
||||||
return $ (nub $ (concat f') ++ f, if static then [] else nub $ (concat g') ++ g)
|
return $ (nub $ (concat f') ++ f, if static then [] else nub $ (concat g') ++ g)
|
||||||
|
|
||||||
|
-- This is the prefix of mangled symbols that come from this package.
|
||||||
|
pkgManglingPrefix :: PackageName -> IO (Maybe String)
|
||||||
|
-- base seems to be mangled differently!
|
||||||
|
pkgManglingPrefix "base" = return $ Just "base"
|
||||||
|
pkgManglingPrefix p = withPkgEnvs env $ \fms -> return (go fms p)
|
||||||
|
where
|
||||||
|
go [] _ = Nothing
|
||||||
|
go (fm:fms) q = case lookupFM fm q of
|
||||||
|
Nothing -> go fms q -- look in other pkgs
|
||||||
|
Just pkg -> Just $ drop 2 $ getHSLibraryName $ installedUnitId pkg
|
||||||
|
|
||||||
data LibrarySpec
|
data LibrarySpec
|
||||||
= DLL String -- -lLib
|
= DLL String -- -lLib
|
||||||
| DLLPath FilePath -- -Lpath
|
| DLLPath FilePath -- -Lpath
|
||||||
@ -459,9 +485,9 @@ lookupPkg' p = withPkgEnvs env $ \fms -> go fms p
|
|||||||
ldOptsPaths = [ path | Just (DLLPath path) <- ldInput ]
|
ldOptsPaths = [ path | Just (DLLPath path) <- ldInput ]
|
||||||
dlls = map mkSOName (extras ++ ldOptsLibs)
|
dlls = map mkSOName (extras ++ ldOptsLibs)
|
||||||
#if defined(CYGWIN) || defined(__MINGW32__)
|
#if defined(CYGWIN) || defined(__MINGW32__)
|
||||||
libdirs = fix_topdir (libraryDirs pkg) ++ ldOptsPaths
|
libdirs = fix_topdir (libraryDirs pkg) ++ ldOptsPaths ++ fix_topdir (libraryDynDirs pkg)
|
||||||
#else
|
#else
|
||||||
libdirs = libraryDirs pkg ++ ldOptsPaths
|
libdirs = libraryDirs pkg ++ ldOptsPaths ++ libraryDynDirs pkg
|
||||||
#endif
|
#endif
|
||||||
-- If we're loading dynamic libs we need the cbits to appear before the
|
-- If we're loading dynamic libs we need the cbits to appear before the
|
||||||
-- real packages.
|
-- real packages.
|
||||||
@ -531,9 +557,15 @@ lookupPkg' p = withPkgEnvs env $ \fms -> go fms p
|
|||||||
-- Solution: look for dynamic libraries only if using -dynamic; otherwise, use static
|
-- Solution: look for dynamic libraries only if using -dynamic; otherwise, use static
|
||||||
-- and add any other dynamic libraries found.
|
-- and add any other dynamic libraries found.
|
||||||
dl <- findHSdlib dirs lib
|
dl <- findHSdlib dirs lib
|
||||||
let rdl = case dl of
|
rdl <- case dl of
|
||||||
Just file -> Right $ Dynamic file
|
Just file -> return $ Right $ Dynamic file
|
||||||
Nothing -> Left lib
|
Nothing -> do
|
||||||
|
-- TODO Generate this suffix automatically. It's absurd we have to use the preprocessor.
|
||||||
|
dynamicSuffix <- findHSdlib dirs (lib ++ "-ghc" ++ (reverse $ takeWhile (/= '-') $ reverse GHC_LIB_PATH))
|
||||||
|
case dynamicSuffix of
|
||||||
|
Just file -> return $ Right $ Dynamic file
|
||||||
|
Nothing -> return $ Left lib
|
||||||
|
|
||||||
if dynonly then return rdl else do
|
if dynonly then return rdl else do
|
||||||
rsl <- findHSslib dirs lib
|
rsl <- findHSslib dirs lib
|
||||||
return $ case rsl of
|
return $ case rsl of
|
||||||
|
@ -474,10 +474,17 @@ loadFunction__ :: Maybe String
|
|||||||
-> String
|
-> String
|
||||||
-> IO (Maybe a)
|
-> IO (Maybe a)
|
||||||
loadFunction__ pkg m valsym
|
loadFunction__ pkg m valsym
|
||||||
= do let symbol = prefixUnderscore++(maybe "" (\p -> zEncodeString p++"_") pkg)
|
= do let encode = zEncodeString
|
||||||
++zEncodeString m++"_"++(zEncodeString valsym)++"_closure"
|
p <- case pkg of
|
||||||
|
Just p -> do
|
||||||
|
prefix <- pkgManglingPrefix p
|
||||||
|
return $ encode (maybe p id prefix)++"_"
|
||||||
|
Nothing -> return ""
|
||||||
|
let symbol = prefixUnderscore++p++encode m++"_"++(encode valsym)++"_closure"
|
||||||
|
|
||||||
#if DEBUG
|
#if DEBUG
|
||||||
putStrLn $ "Looking for <<"++symbol++">>"
|
putStrLn $ "Looking for <<"++symbol++">>"
|
||||||
|
initLinker
|
||||||
#endif
|
#endif
|
||||||
ptr@(Ptr addr) <- withCString symbol c_lookupSymbol
|
ptr@(Ptr addr) <- withCString symbol c_lookupSymbol
|
||||||
if (ptr == nullPtr)
|
if (ptr == nullPtr)
|
||||||
@ -596,10 +603,15 @@ unloadObj (Module { path = p, kind = k, key = ky }) = case k of
|
|||||||
-- Load a .so type object file.
|
-- Load a .so type object file.
|
||||||
--
|
--
|
||||||
loadShared :: FilePath -> IO Module
|
loadShared :: FilePath -> IO Module
|
||||||
loadShared str = do
|
loadShared str' = do
|
||||||
#if DEBUG
|
#if DEBUG
|
||||||
putStrLn $ " shared: " ++ str
|
putStrLn $ " shared: " ++ str'
|
||||||
#endif
|
#endif
|
||||||
|
let str = case str' of
|
||||||
|
-- TODO My GHC segfaults because libm.so is a linker script
|
||||||
|
"libm.so" -> "/lib/x86_64-linux-gnu/libm.so.6"
|
||||||
|
"libpthread.so" -> "/lib/x86_64-linux-gnu/libpthread.so.0"
|
||||||
|
x -> x
|
||||||
maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
|
maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
|
||||||
if maybe_errmsg == nullPtr
|
if maybe_errmsg == nullPtr
|
||||||
then return (Module str (mkModid str) Shared undefined (Package (mkModid str)))
|
then return (Module str (mkModid str) Shared undefined (Package (mkModid str)))
|
||||||
@ -618,6 +630,7 @@ loadShared str = do
|
|||||||
--
|
--
|
||||||
loadPackage :: String -> IO ()
|
loadPackage :: String -> IO ()
|
||||||
loadPackage p = do
|
loadPackage p = do
|
||||||
|
initLinker
|
||||||
#if DEBUG
|
#if DEBUG
|
||||||
putStr (' ':p) >> hFlush stdout
|
putStr (' ':p) >> hFlush stdout
|
||||||
#endif
|
#endif
|
||||||
|
Loading…
x
Reference in New Issue
Block a user