Try to integrate @abarbu patches.
This commit is contained in:
parent
f569b82460
commit
ff6d053a4c
@ -59,6 +59,7 @@ library
|
||||
filepath,
|
||||
random,
|
||||
process,
|
||||
split,
|
||||
ghc >= 6.10,
|
||||
ghc-prim
|
||||
|
||||
|
@ -40,13 +40,15 @@ module System.Plugins.Env (
|
||||
lookupMerged,
|
||||
addMerge,
|
||||
addPkgConf,
|
||||
defaultPkgConf,
|
||||
union,
|
||||
addStaticPkg,
|
||||
isStaticPkg,
|
||||
rmStaticPkg,
|
||||
grabDefaultPkgConf,
|
||||
readPackageConf,
|
||||
lookupPkg
|
||||
lookupPkg,
|
||||
pkgManglingPrefix
|
||||
|
||||
) where
|
||||
|
||||
@ -59,7 +61,7 @@ import Control.Monad ( liftM )
|
||||
|
||||
import Data.IORef ( writeIORef, readIORef, newIORef, IORef() )
|
||||
import Data.Maybe ( isJust, isNothing, fromMaybe )
|
||||
import Data.List ( (\\), nub, )
|
||||
import Data.List ( (\\), nub )
|
||||
|
||||
import System.IO.Unsafe ( unsafePerformIO )
|
||||
import System.Directory ( doesFileExist )
|
||||
@ -83,6 +85,7 @@ import Distribution.Package hiding (
|
||||
Module,
|
||||
#endif
|
||||
depends, packageName, PackageName(..)
|
||||
, installedUnitId
|
||||
#if MIN_VERSION_ghc(7,10,0)
|
||||
, installedPackageId
|
||||
#endif
|
||||
@ -96,6 +99,9 @@ import Distribution.Simple.PackageIndex
|
||||
import Distribution.Simple.Program
|
||||
import Distribution.Verbosity
|
||||
|
||||
import System.Environment
|
||||
import Data.List.Split
|
||||
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
--
|
||||
@ -305,6 +311,15 @@ addPkgConf f = do
|
||||
ps <- readPackageConf f
|
||||
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
|
||||
-- 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)
|
||||
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
|
||||
= DLL String -- -lLib
|
||||
| DLLPath FilePath -- -Lpath
|
||||
@ -459,9 +485,9 @@ lookupPkg' p = withPkgEnvs env $ \fms -> go fms p
|
||||
ldOptsPaths = [ path | Just (DLLPath path) <- ldInput ]
|
||||
dlls = map mkSOName (extras ++ ldOptsLibs)
|
||||
#if defined(CYGWIN) || defined(__MINGW32__)
|
||||
libdirs = fix_topdir (libraryDirs pkg) ++ ldOptsPaths
|
||||
libdirs = fix_topdir (libraryDirs pkg) ++ ldOptsPaths ++ fix_topdir (libraryDynDirs pkg)
|
||||
#else
|
||||
libdirs = libraryDirs pkg ++ ldOptsPaths
|
||||
libdirs = libraryDirs pkg ++ ldOptsPaths ++ libraryDynDirs pkg
|
||||
#endif
|
||||
-- If we're loading dynamic libs we need the cbits to appear before the
|
||||
-- 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
|
||||
-- and add any other dynamic libraries found.
|
||||
dl <- findHSdlib dirs lib
|
||||
let rdl = case dl of
|
||||
Just file -> Right $ Dynamic file
|
||||
Nothing -> Left lib
|
||||
rdl <- case dl of
|
||||
Just file -> return $ Right $ Dynamic file
|
||||
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
|
||||
rsl <- findHSslib dirs lib
|
||||
return $ case rsl of
|
||||
|
@ -474,10 +474,17 @@ loadFunction__ :: Maybe String
|
||||
-> String
|
||||
-> IO (Maybe a)
|
||||
loadFunction__ pkg m valsym
|
||||
= do let symbol = prefixUnderscore++(maybe "" (\p -> zEncodeString p++"_") pkg)
|
||||
++zEncodeString m++"_"++(zEncodeString valsym)++"_closure"
|
||||
= do let encode = zEncodeString
|
||||
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
|
||||
putStrLn $ "Looking for <<"++symbol++">>"
|
||||
initLinker
|
||||
#endif
|
||||
ptr@(Ptr addr) <- withCString symbol c_lookupSymbol
|
||||
if (ptr == nullPtr)
|
||||
@ -596,10 +603,15 @@ unloadObj (Module { path = p, kind = k, key = ky }) = case k of
|
||||
-- Load a .so type object file.
|
||||
--
|
||||
loadShared :: FilePath -> IO Module
|
||||
loadShared str = do
|
||||
loadShared str' = do
|
||||
#if DEBUG
|
||||
putStrLn $ " shared: " ++ str
|
||||
putStrLn $ " shared: " ++ str'
|
||||
#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
|
||||
if maybe_errmsg == nullPtr
|
||||
then return (Module str (mkModid str) Shared undefined (Package (mkModid str)))
|
||||
@ -618,6 +630,7 @@ loadShared str = do
|
||||
--
|
||||
loadPackage :: String -> IO ()
|
||||
loadPackage p = do
|
||||
initLinker
|
||||
#if DEBUG
|
||||
putStr (' ':p) >> hFlush stdout
|
||||
#endif
|
||||
|
Loading…
x
Reference in New Issue
Block a user