Merge pull request #9 from galenhuntington/master

Try to get this package working again.
2019-03-18 11:39:05 -05:00 · 2019-03-18 11:39:05 -05:00 · 5866046ca0
commit 5866046ca0
parent f6e23dd402 57aa1e606a
6 changed files with 69 additions and 24 deletions
--- a/plugins.cabal
+++ b/plugins.cabal
@ -59,6 +59,7 @@ library
                          filepath,
                          random,
                          process,
+                          split,
                          ghc >= 6.10,
                          ghc-prim

--- a/src/System/Plugins/Consts.hs
+++ b/src/System/Plugins/Consts.hs
@ -20,7 +20,7 @@

 module System.Plugins.Consts where

-#include "../../../config.h"
+#include "config.h"


 #if __GLASGOW_HASKELL__ >= 604
--- a/src/System/Plugins/Env.hs
+++ b/src/System/Plugins/Env.hs
@ -40,17 +40,19 @@ module System.Plugins.Env (
        lookupMerged,
        addMerge,
        addPkgConf,
+        defaultPkgConf,
        union,
        addStaticPkg,
        isStaticPkg,
        rmStaticPkg,
        grabDefaultPkgConf,
        readPackageConf,
-        lookupPkg
+        lookupPkg,
+        pkgManglingPrefix

   ) where

-#include "../../../config.h"
+#include "config.h"

 import System.Plugins.LoadTypes (Module)
 import System.Plugins.Consts           ( sysPkgSuffix )
@ -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 )
@ -76,13 +78,14 @@ import DynFlags (
  Way(WayDyn), dynamicGhc, ways,
 #endif
  defaultDynFlags, initDynFlags)
-import SysTools (initSysTools)
+import SysTools (initSysTools, initLlvmConfig)

 import Distribution.Package hiding (
 #if MIN_VERSION_ghc(7,6,0)
                                     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,14 +485,15 @@ 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.
                settings <- initSysTools (Just libdir)
-                dflags <- initDynFlags $ defaultDynFlags settings
+                llvmConfig <- initLlvmConfig (Just libdir)
+                dflags <- initDynFlags $ defaultDynFlags settings llvmConfig
                libs <- mapM (findHSlib
 #if MIN_VERSION_ghc(7,8,0)
                              (WayDyn `elem` ways dflags || dynamicGhc)
@ -530,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
--- a/src/System/Plugins/Load.hs
+++ b/src/System/Plugins/Load.hs
@ -61,7 +61,7 @@ module System.Plugins.Load (

  ) where

-#include "../../../config.h"
+#include "config.h"

 import System.Plugins.Make             ( build )
 import System.Plugins.Env
@ -104,7 +104,7 @@ import GHC                      ( defaultCallbacks )
 #else
 import DynFlags                 (defaultDynFlags, initDynFlags)
 import GHC.Paths                (libdir)
-import SysTools                 (initSysTools)
+import SysTools                 (initSysTools, initLlvmConfig)
 #endif
 import GHC.Ptr                  ( Ptr(..), nullPtr )
 #if !MIN_VERSION_ghc(7,4,1)
@ -127,7 +127,8 @@ readBinIface' hi_path = do
    -- kludgy as hell
 #if MIN_VERSION_ghc(7,2,0)
    mySettings <- initSysTools (Just libdir) -- how should we really set the top dir?
-    dflags <- initDynFlags (defaultDynFlags mySettings)
+    llvmConfig <- initLlvmConfig (Just libdir)
+    dflags <- initDynFlags (defaultDynFlags mySettings llvmConfig)
    e <- newHscEnv dflags
 #else
    e <- newHscEnv defaultCallbacks undefined
@ -473,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)
@ -595,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)))
@ -617,6 +630,7 @@ loadShared str = do
 --
 loadPackage :: String -> IO ()
 loadPackage p = do
+        initLinker
 #if DEBUG
        putStr (' ':p) >> hFlush stdout
 #endif
--- a/src/System/Plugins/Parser.hs
+++ b/src/System/Plugins/Parser.hs
@ -25,7 +25,7 @@ module System.Plugins.Parser (
        replaceModName
  ) where

-#include "../../../config.h"
+#include "config.h"

 import Data.List
 import Data.Char
--- a/src/System/Plugins/Utils.hs
+++ b/src/System/Plugins/Utils.hs
@ -58,7 +58,7 @@ module System.Plugins.Utils (
  ) where


-#include "../../../config.h"
+#include "config.h"

 import System.Plugins.Env              ( isLoaded )
 import System.Plugins.Consts           ( objSuf, hiSuf, tmpDir )
@ -289,7 +289,7 @@ findFile (ext:exts) file
 infixr 6 </>
 infixr 6 <.>

-(</>), (<.>), (<+>), (<>) :: FilePath -> FilePath -> FilePath
+(</>), (<.>), (<+>) :: FilePath -> FilePath -> FilePath
 [] </> b = b
 a  </> b = a ++ "/" ++ b

@ -299,9 +299,6 @@ a  <.> b = a ++ "." ++ b
 [] <+> b = b
 a  <+> b = a ++ " " ++ b

-[] <> b = b
-a  <> b = a ++ b
-
 --
 -- | dirname : return the directory portion of a file path
 -- if null, return "."