Try to integrate @abarbu patches.

This commit is contained in:
Galen Huntington 2019-03-15 21:43:48 -07:00
parent 2443774403
commit 57aa1e606a
3 changed files with 57 additions and 11 deletions

View File

@ -59,6 +59,7 @@ library
filepath,
random,
process,
split,
ghc >= 6.10,
ghc-prim

View File

@ -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

View File

@ -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