diff --git a/plugins.cabal b/plugins.cabal --- a/plugins.cabal +++ b/plugins.cabal @@ -1,5 +1,5 @@ name: plugins -version: 1.5.7 +version: 1.6.2.1 homepage: https://github.com/stepcut/plugins synopsis: Dynamic linking for Haskell and C objects description: Dynamic linking and runtime evaluation of Haskell, @@ -18,20 +18,24 @@ License-file: LICENSE author: Don Stewart 2004..2010 maintainer: Jeremy Shaw -cabal-version: >= 1.6 +cabal-version: >= 1.10 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.5 + , GHC == 8.8.3 + , GHC == 8.10.1 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, testsuite/makewith/unsafeio/Unsafe.conf.in library + default-language: Haskell2010 exposed-modules: System.Eval, System.Eval.Haskell, @@ -46,7 +50,7 @@ System.Plugins.Process, System.Plugins.Utils - extensions: CPP, + default-extensions: CPP, ForeignFunctionInterface ghc-options: -Wall -funbox-strict-fields -fno-warn-missing-signatures hs-source-dirs: src @@ -59,6 +63,7 @@ filepath, random, process, + split, ghc >= 6.10, ghc-prim diff --git a/src/System/Eval/Haskell.hs b/src/System/Eval/Haskell.hs --- a/src/System/Eval/Haskell.hs +++ b/src/System/Eval/Haskell.hs @@ -254,7 +254,7 @@ x = ident () -- what is this big variable name? --- its a random value, so that it won't clash if the accidently mistype +-- its a random value, so that it won't clash if the accidentally mistype -- an unbound 'x' or 'v' in their code.. it won't reveal the internal -- structure of the wrapper, which is annoying in irc use by lambdabot @@ -267,7 +267,7 @@ -- -- --- return NULL pointer if an error occured. +-- return NULL pointer if an error occurred. -- foreign export ccall hs_eval_b :: CString -> IO (Ptr CInt) diff --git a/src/System/Plugins/Consts.hs b/src/System/Plugins/Consts.hs --- 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 diff --git a/src/System/Plugins/Env.hs b/src/System/Plugins/Env.hs --- a/src/System/Plugins/Env.hs +++ b/src/System/Plugins/Env.hs @@ -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,20 @@ Way(WayDyn), dynamicGhc, ways, #endif defaultDynFlags, initDynFlags) -import SysTools (initSysTools) +import SysTools ( initSysTools +#if MIN_VERSION_ghc(8,10,1) + , lazyInitLlvmConfig +#else + , initLlvmConfig +#endif + ) 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,8 +105,16 @@ 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 + +#if !MIN_VERSION_ghc(8,10,1) +lazyInitLlvmConfig = initLlvmConfig +#endif + -- -- and map Data.Map terms to FiniteMap terms -- @@ -173,7 +190,7 @@ -- -- our environment, contains a set of loaded objects, and a map of known --- packages and their informations. Initially all we know is the default +-- packages and their information. Initially all we know is the default -- package.conf information. -- env = unsafePerformIO $ do @@ -305,6 +322,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 @@ -316,14 +342,14 @@ in foldr addOnePkg fm ps' : ls where -- we add each package with and without it's version number and with the full installedPackageId - addOnePkg p fm' = addToPkgEnvs (addToPkgEnvs (addToPkgEnvs fm' (display $ sourcePackageId p) p) (display $ installedPackageId p) p) + addOnePkg p fm' = addToPkgEnvs (addToPkgEnvs (addToPkgEnvs fm' (display $ sourcePackageId p) p) (display $ packageId p) p) (packageName p) p -- if no version number specified, pick the higher version addToPkgEnvs = addWithFM higherVersion higherVersion pkgconf1 pkgconf2 - | installedPackageId pkgconf1 >= installedPackageId pkgconf2 = pkgconf1 + | packageId pkgconf1 >= packageId pkgconf2 = pkgconf1 | otherwise = pkgconf2 -- @@ -335,7 +361,7 @@ grabDefaultPkgConf :: IO PkgEnvs grabDefaultPkgConf = do - pc <- configureAllKnownPrograms silent defaultProgramConfiguration + pc <- configureAllKnownPrograms silent defaultProgramDb #if MIN_VERSION_Cabal(1,24,0) (compiler, _platform, _programConfiguration) <- configure silent Nothing Nothing pc @@ -351,7 +377,7 @@ -- readPackageConf :: FilePath -> IO [PackageConfig] readPackageConf f = do - pc <- configureAllKnownPrograms silent defaultProgramConfiguration + pc <- configureAllKnownPrograms silent defaultProgramDb #if MIN_VERSION_Cabal(1,24,0) (compiler, _platform, _programConfiguration) <- configure silent Nothing Nothing pc @@ -407,6 +433,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 +496,20 @@ 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. +#if MIN_VERSION_ghc(8,8,1) + settings <- initSysTools (libdir) + llvmConfig <- lazyInitLlvmConfig (libdir) +#else settings <- initSysTools (Just libdir) - dflags <- initDynFlags $ defaultDynFlags settings + llvmConfig <- lazyInitLlvmConfig (Just libdir) +#endif + dflags <- initDynFlags $ defaultDynFlags settings llvmConfig libs <- mapM (findHSlib #if MIN_VERSION_ghc(7,8,0) (WayDyn `elem` ways dflags || dynamicGhc) @@ -530,9 +573,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 diff --git a/src/System/Plugins/Load.hs b/src/System/Plugins/Load.hs --- a/src/System/Plugins/Load.hs +++ b/src/System/Plugins/Load.hs @@ -61,7 +61,7 @@ ) where -#include "../../../config.h" +#include "config.h" import System.Plugins.Make ( build ) import System.Plugins.Env @@ -104,8 +104,14 @@ #else import DynFlags (defaultDynFlags, initDynFlags) import GHC.Paths (libdir) -import SysTools (initSysTools) +import SysTools ( initSysTools +#if MIN_VERSION_ghc(8,10,1) + , lazyInitLlvmConfig +#else + , initLlvmConfig #endif + ) +#endif import GHC.Ptr ( Ptr(..), nullPtr ) #if !MIN_VERSION_ghc(7,4,1) import GHC.Exts ( addrToHValue# ) @@ -120,14 +126,24 @@ #endif import System.IO ( hClose ) +#if !MIN_VERSION_ghc(8,10,1) +lazyInitLlvmConfig = initLlvmConfig +#endif + ifaceModuleName = moduleNameString . moduleName . mi_module readBinIface' :: FilePath -> IO ModIface readBinIface' hi_path = do -- kludgy as hell #if MIN_VERSION_ghc(7,2,0) +#if MIN_VERSION_ghc(8,8,1) + mySettings <- initSysTools (libdir) -- how should we really set the top dir? + llvmConfig <- lazyInitLlvmConfig (libdir) +#else mySettings <- initSysTools (Just libdir) -- how should we really set the top dir? - dflags <- initDynFlags (defaultDynFlags mySettings) + llvmConfig <- lazyInitLlvmConfig (Just libdir) +#endif + dflags <- initDynFlags (defaultDynFlags mySettings llvmConfig) e <- newHscEnv dflags #else e <- newHscEnv defaultCallbacks undefined @@ -244,7 +260,7 @@ -- -- Use GHC at runtime so we get staged type inference, providing full -- power dynamics, *on module interfaces only*. This is quite suitable --- for plugins, of coures :) +-- for plugins, of course :) -- -- TODO where does the .hc file go in the call to build() ? -- @@ -259,11 +275,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 +299,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 +332,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 +489,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 +618,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 +645,7 @@ -- loadPackage :: String -> IO () loadPackage p = do + initLinker #if DEBUG putStr (' ':p) >> hFlush stdout #endif diff --git a/src/System/Plugins/Make.hs b/src/System/Plugins/Make.hs --- a/src/System/Plugins/Make.hs +++ b/src/System/Plugins/Make.hs @@ -113,7 +113,7 @@ -- -- | Merging may be avoided if the source files are older than an -- existing merged result. The @MergeCode@ type indicates whether --- merging was performed, or whether it was unneccessary. +-- merging was performed, or whether it was unnecessary. -- type MergeCode = MakeCode @@ -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 diff --git a/src/System/Plugins/Parser.hs b/src/System/Plugins/Parser.hs --- a/src/System/Plugins/Parser.hs +++ b/src/System/Plugins/Parser.hs @@ -25,7 +25,7 @@ replaceModName ) where -#include "../../../config.h" +#include "config.h" import Data.List import Data.Char diff --git a/src/System/Plugins/Process.hs b/src/System/Plugins/Process.hs --- a/src/System/Plugins/Process.hs +++ b/src/System/Plugins/Process.hs @@ -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) diff --git a/src/System/Plugins/Utils.hs b/src/System/Plugins/Utils.hs --- a/src/System/Plugins/Utils.hs +++ b/src/System/Plugins/Utils.hs @@ -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 @@ -299,9 +299,6 @@ [] <+> b = b a <+> b = a ++ " " ++ b -[] <> b = b -a <> b = a ++ b - -- -- | dirname : return the directory portion of a file path -- if null, return "." @@ -429,7 +426,7 @@ -- -- This code checks if "-o foo" or "-odir foodir" are supplied as args -- to make(), and if so returns a modified file path, otherwise it --- uses the source file to determing the path to where the object and +-- uses the source file to determine the path to where the object and -- .hi file will be put. -- outFilePath :: FilePath -> [Arg] -> (FilePath,FilePath) @@ -473,7 +470,7 @@ -- fileExist still seems to throw exceptions on some platforms: ia64 in -- particular. -- --- invarient : we already assume the first file, 'a', exists +-- invariant : we already assume the first file, 'a', exists -- newer :: FilePath -> FilePath -> IO Bool newer a b = do