plugins 1.5.7 → 1.6.0
raw patch · 8 files changed
+98/−79 lines, 8 filesdep +split
Dependencies added: split
Files
- plugins.cabal +9/−7
- src/System/Plugins/Consts.hs +1/−1
- src/System/Plugins/Env.hs +43/−10
- src/System/Plugins/Load.hs +27/−13
- src/System/Plugins/Make.hs +7/−7
- src/System/Plugins/Parser.hs +1/−1
- src/System/Plugins/Process.hs +8/−35
- src/System/Plugins/Utils.hs +2/−5
plugins.cabal view
@@ -1,5 +1,5 @@ name: plugins-version: 1.5.7+version: 1.6.0 homepage: https://github.com/stepcut/plugins synopsis: Dynamic linking for Haskell and C objects description: Dynamic linking and runtime evaluation of Haskell,@@ -20,12 +20,13 @@ maintainer: Jeremy Shaw <jeremy@seereason.com> cabal-version: >= 1.6 build-type: Configure-Tested-with: GHC == 7.4.*- , GHC == 7.6.*- , GHC == 7.8.*- , GHC == 7.10.*- , GHC == 8.0.*- , GHC == 8.2.*+Tested-with: GHC == 7.4.2+ , GHC == 7.6.3+ , GHC == 7.8.4+ , GHC == 7.10.3+ , GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.6.4 extra-source-files: config.guess, config.h.in, config.mk.in, config.sub, configure, configure.ac, install.sh, Makefile, testsuite/makewith/io/TestIO.conf.in,@@ -59,6 +60,7 @@ filepath, random, process,+ split, ghc >= 6.10, ghc-prim
src/System/Plugins/Consts.hs view
@@ -20,7 +20,7 @@ module System.Plugins.Consts where -#include "../../../config.h"+#include "config.h" #if __GLASGOW_HASKELL__ >= 604
src/System/Plugins/Env.hs view
@@ -40,17 +40,19 @@ 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 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 @@ 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.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 @@ 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 @@ (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 @@ 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 @@ -- 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
src/System/Plugins/Load.hs view
@@ -61,7 +61,7 @@ ) where -#include "../../../config.h"+#include "config.h" import System.Plugins.Make ( build ) import System.Plugins.Env@@ -104,7 +104,7 @@ #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 @@ -- 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@@ -259,11 +260,11 @@ #if DEBUG putStr "Checking types ... " >> hFlush stdout #endif- errors <- unify object incpaths [] ty sym+ (errors, success) <- unify object incpaths [] ty sym #if DEBUG putStrLn "done" #endif- if null errors+ if success then load object incpaths pkgconfs sym else return $ LoadFailure errors @@ -283,11 +284,11 @@ #if DEBUG putStr "Checking types ... " >> hFlush stdout #endif- errors <- unify object incpaths args ty sym+ (errors, success) <- unify object incpaths args ty sym #if DEBUG putStrLn "done" #endif- if null errors+ if success then load object incpaths pkgconfs sym else return $ LoadFailure errors @@ -316,9 +317,9 @@ hWrite hdl src - e <- build tmpf tmpf1 (i:is++args++["-fno-code","-c","-ohi "++tmpf1])+ (e,success) <- build tmpf tmpf1 (i:is++args++["-fno-code","-c","-ohi "++tmpf1]) mapM_ removeFile [tmpf,tmpf1]- return e+ return (e, success) where -- fix up hierarchical names@@ -473,10 +474,17 @@ -> 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 @@ -- 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 @@ -- loadPackage :: String -> IO () loadPackage p = do+ initLinker #if DEBUG putStr (' ':p) >> hFlush stdout #endif
src/System/Plugins/Make.hs view
@@ -269,11 +269,11 @@ #if DEBUG putStr "Compiling object ... " >> hFlush stdout #endif- err <- build src obj args+ (err, success) <- build src obj args #if DEBUG putStrLn "done" #endif- return $ if null err+ return $ if success then MakeSuccess ReComp obj else MakeFailure err }@@ -287,7 +287,7 @@ build :: FilePath -- ^ path to .hs source -> FilePath -- ^ path to object file -> [String] -- ^ any extra cmd line flags- -> IO [String]+ -> IO ([String], Bool) build src obj extra_opts = do @@ -306,12 +306,12 @@ putStr $ show $ ghc : flags #endif - (_out,err) <- exec ghc flags -- this is a fork()+ (_out,err,success) <- exec ghc flags -- this is a fork() obj_exists <- doesFileExist obj -- sanity- return $ if not obj_exists && null err -- no errors, but no object?- then ["Compiled, but didn't create object file `"++obj++"'!"]- else err+ return $ if not obj_exists && success+ then (["Compiled, but didn't create object file `"++obj++"'!"], success)+ else (err, success) -- --------------------------------------------------------------------- -- | Merge to source files into a temporary file. If we've tried to
src/System/Plugins/Parser.hs view
@@ -25,7 +25,7 @@ replaceModName ) where -#include "../../../config.h"+#include "config.h" import Data.List import Data.Char
src/System/Plugins/Process.hs view
@@ -7,25 +7,19 @@ module System.Plugins.Process (exec, popen) where import System.Exit-#if __GLASGOW_HASKELL__ >= 604 import System.IO import System.Process import Control.Concurrent (forkIO)-#else-import qualified Posix as P-#endif import qualified Control.Exception as E -- -- slight wrapper over popen for calls that don't care about stdin to the program ---exec :: String -> [String] -> IO ([String],[String])+exec :: String -> [String] -> IO ([String],[String],Bool) exec f as = do- (a,b,_) <- popen f as (Just [])- return (lines a, lines b)--#if __GLASGOW_HASKELL__ >= 604+ (a,b,c,_) <- popen f as (Just [])+ return (lines a, lines b,c) type ProcessID = ProcessHandle @@ -37,9 +31,9 @@ -- Posix.popen doesn't have this problem, so maybe we can reproduce its -- pipe handling somehow. ---popen :: FilePath -> [String] -> Maybe String -> IO (String,String,ProcessID)+popen :: FilePath -> [String] -> Maybe String -> IO (String,String,Bool,ProcessID) popen file args minput =- E.handle (\e -> return ([],show (e::E.IOException), error (show e))) $ do+ E.handle (\e -> return ([],show (e::E.IOException), False, error (show e))) $ do (inp,out,err,pid) <- runInteractiveProcess file args Nothing Nothing @@ -64,27 +58,6 @@ case exitCode of ExitFailure code | null errput -> let errMsg = file ++ ": failed with error code " ++ show code- in return ([],errMsg,error errMsg)- _ -> return (output,errput,pid)--#else------- catch so that we can deal with forkProcess failing gracefully. and--- getProcessStatus is needed so as not to get a bunch of zombies,--- leading to forkProcess failing.------ Large amounts of input will cause problems with blocking as we wait--- on the process to finish. Make sure no lambdabot processes will--- generate 1000s of lines of output.----popen :: FilePath -> [String] -> Maybe String -> IO (String,String,P.ProcessID)-popen f s m =- E.handle (\e -> return ([], show (e::IOException), error $ show e )) $ do- x@(_,_,pid) <- P.popen f s m- b <- P.getProcessStatus True False pid -- wait- return $ case b of- Nothing -> ([], "process has disappeared", pid)- _ -> x--#endif+ in return ([],errMsg,False,error errMsg)+ | otherwise -> return ([],errput,False,error errput)+ _ -> return (output,errput,True,pid)
src/System/Plugins/Utils.hs view
@@ -58,7 +58,7 @@ ) where -#include "../../../config.h"+#include "config.h" import System.Plugins.Env ( isLoaded ) import System.Plugins.Consts ( objSuf, hiSuf, tmpDir )@@ -289,7 +289,7 @@ infixr 6 </> infixr 6 <.> -(</>), (<.>), (<+>), (<>) :: FilePath -> FilePath -> FilePath+(</>), (<.>), (<+>) :: FilePath -> FilePath -> FilePath [] </> b = b a </> b = a ++ "/" ++ b @@ -298,9 +298,6 @@ [] <+> b = b a <+> b = a ++ " " ++ b--[] <> b = b-a <> b = a ++ b -- -- | dirname : return the directory portion of a file path