wrath/shaniqua-plugins
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Fixes for GHC 8.x, archive loading, -dynamic, and file generation

Browse Source
This commit is contained in:
Mark Laws
2018-01-20 10:16:48 +09:00
parent 22dabddd73
commit 9eb6ab384e
16 changed files with 458 additions and 216 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/System/Eval/Haskell.hs
View File

@ -239,7 +239,7 @@ dynwrap expr nm mods =
x = ident ()
ident () = unsafePerformIO $
sequence (take 3 (repeat $ getStdRandom (randomR (97,122)) >>= return . chr))
sequence (Prelude.take 3 (repeat $ getStdRandom (randomR (97,122)) >>= return . chr))
-- ---------------------------------------------------------------------
-- unsafe wrapper

4
src/System/Plugins/Consts.hs
View File

@ -43,8 +43,8 @@ sysPkgConf = "package.conf"
-- | This code is from runtime_loader:
-- The extension used by system modules.
sysPkgSuffix = ".o"
objSuf = sysPkgSuffix
sysPkgSuffix = ".a"
objSuf = ".o"
hiSuf = ".hi"
hsSuf = ".hs"
#if defined(CYGWIN) || defined(__MINGW32__)

67
src/System/Plugins/Env.hs
View File

@ -43,6 +43,7 @@ module System.Plugins.Env (
union,
addStaticPkg,
isStaticPkg,
rmStaticPkg,
grabDefaultPkgConf,
readPackageConf,
lookupPkg
@ -69,7 +70,19 @@ import System.IO.Error ( catch, ioError, isDoesNotExistError )
import Control.Concurrent.MVar ( MVar(), newMVar, withMVar )
import Distribution.Package hiding (depends, packageName, PackageName(..)
import GHC.Paths (libdir)
import DynFlags (
#if MIN_VERSION_ghc(7,8,0)
Way(WayDyn), dynamicGhc, ways,
#endif
defaultDynFlags, initDynFlags)
import SysTools (initSysTools)
import Distribution.Package hiding (
#if MIN_VERSION_ghc(7,6,0)
Module,
#endif
depends, packageName, PackageName(..)
#if MIN_VERSION_ghc(7,10,0)
, installedPackageId
#endif
@ -358,6 +371,12 @@ addStaticPkg pkg = modifyStaticPkgEnv env $ \set -> return $ S.insert pkg set
isStaticPkg :: PackageName -> IO Bool
isStaticPkg pkg = withStaticPkgEnv env $ \set -> return $ S.member pkg set
rmStaticPkg :: String -> IO Bool
rmStaticPkg pkg = do
(willRemove, s) <- withStaticPkgEnv env $ \s -> return (S.member pkg s, s)
if not willRemove then return False
else do modifyStaticPkgEnv env $ \s' -> return $ S.delete pkg s'
return True
--
-- Package path, given a package name, look it up in the environment and
-- return the path to all the libraries needed to load this package.
@ -382,7 +401,9 @@ lookupPkg pn = go [] pn
go :: [PackageName] -> PackageName -> IO ([FilePath],[FilePath])
go seen p = do
(ps, (f, g)) <- lookupPkg' p
static <- isStaticPkg p
static <- if not (null f) && null g
then addStaticPkg p >> return True
else isStaticPkg p
(f', g') <- liftM unzip $ mapM (go (nub $ seen ++ ps)) (ps \\ seen)
return $ (nub $ (concat f') ++ f, if static then [] else nub $ (concat g') ++ g)
@ -444,7 +465,16 @@ lookupPkg' p = withPkgEnvs env $ \fms -> go fms p
#endif
-- If we're loading dynamic libs we need the cbits to appear before the
-- real packages.
libs <- mapM (findHSlib libdirs) (cbits ++ hslibs)
settings <- initSysTools (Just libdir)
dflags <- initDynFlags $ defaultDynFlags settings
libs <- mapM (findHSlib
#if MIN_VERSION_ghc(7,8,0)
(WayDyn `elem` ways dflags || dynamicGhc)
#else
False
#endif
libdirs)
(cbits ++ hslibs)
#if defined(CYGWIN) || defined(__MINGW32__)
windowsos <- catch (getEnv "OS")
(\e -> if isDoesNotExistError e then return "Windows_98" else ioError e)
@ -490,23 +520,24 @@ lookupPkg' p = withPkgEnvs env $ \fms -> go fms p
if b then return $ Just l -- found it!
else findHSlib' dirs lib
findHSslib dirs lib = findHSlib' dirs $ lib ++ sysPkgSuffix
findHSslib dirs lib = findHSlib' dirs $ "lib" ++ lib ++ sysPkgSuffix
findHSdlib dirs lib = findHSlib' dirs $ mkDynPkgName lib
-- Problem: sysPkgSuffix is ".o", but extra libraries could be
-- ".so"
-- Solution: first look for static library, if we don't find it
-- look for a dynamic version.
findHSlib :: [FilePath] -> String -> IO (Either String HSLib)
findHSlib dirs lib = do
static <- findHSslib dirs lib
case static of
Just file -> return $ Right $ Static file
Nothing -> do
dynamic <- findHSdlib dirs lib
case dynamic of
Just file -> return $ Right $ Dynamic file
Nothing -> return $ Left lib
findHSlib :: Bool -> [FilePath] -> String -> IO (Either String HSLib)
findHSlib dynonly dirs lib = do
-- Problem: sysPkgSuffix is ".a", but system packages could be dynamic, and
-- extra dynamic libraries could be needed even when using normal (static) linkage.
-- 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
if dynonly then return rdl else do
rsl <- findHSslib dirs lib
return $ case rsl of
Just file -> Right $ Static file
Nothing -> rdl
findDLL :: [FilePath] -> String -> IO (Either String FilePath)
findDLL [] lib = return (Left lib)

46
src/System/Plugins/Load.hs
View File

@ -70,12 +70,17 @@ import System.Plugins.Consts ( sysPkgSuffix, hiSuf, prefixUnderscore )
import System.Plugins.LoadTypes
-- import Language.Hi.Parser
import Encoding (zEncodeString)
import BinIface
import HscTypes
import Module (moduleName, moduleNameString)
#if MIN_VERSION_ghc(8,0,0)
#if MIN_VERSION_Cabal(2,0,0)
import Module (installedUnitIdString)
#else
import Module (unitIdString)
#endif
#elif MIN_VERSION_ghc(7,10,0)
import Module (packageKeyString)
#else
@ -91,6 +96,7 @@ import Data.Typeable ( Typeable )
import Data.List ( isSuffixOf, nub, nubBy )
import Control.Monad ( when, filterM, liftM )
import System.Directory ( doesFileExist, removeFile )
import Foreign.C ( CInt(..) )
import Foreign.C.String ( CString, withCString, peekCString )
#if !MIN_VERSION_ghc(7,2,0)
@ -173,7 +179,7 @@ load :: FilePath -- ^ object file
-> IO (LoadStatus a)
load obj incpaths pkgconfs sym = do
initLinker
initLinker_ $ fromIntegral 0
-- load extra package information
mapM_ addPkgConf pkgconfs
@ -443,7 +449,8 @@ reload m@(Module{path = p, iface = hi}) sym = do
-- | Call the initLinker function first, before calling any of the other
-- functions in this module - otherwise you\'ll get unresolved symbols.
-- initLinker :: IO ()
initLinker :: IO ()
initLinker = initLinker_ $ fromIntegral 0
-- our initLinker transparently calls the one in GHC
--
@ -466,8 +473,8 @@ loadFunction__ :: Maybe String
-> String
-> IO (Maybe a)
loadFunction__ pkg m valsym
= do let symbol = prefixUnderscore++(maybe "" (\p -> encode p++"_") pkg)
++encode m++"_"++(encode valsym)++"_closure"
= do let symbol = prefixUnderscore++(maybe "" (\p -> zEncodeString p++"_") pkg)
++zEncodeString m++"_"++(zEncodeString valsym)++"_closure"
#if DEBUG
putStrLn $ "Looking for <<"++symbol++">>"
#endif
@ -525,17 +532,21 @@ loadObject p ky@(Package k) = loadObject' p ky k
loadObject' :: FilePath -> Key -> String -> IO Module
loadObject' p ky k
| ("HSrts"++sysPkgSuffix) `isSuffixOf` p = return (emptyMod p)
| otherwise
= do alreadyLoaded <- isLoaded k
when (not alreadyLoaded) $ do
r <- withCString p c_loadObj
when (not r) (panic $ "Could not load module `"++p++"'")
addModule k (emptyMod p) -- needs to Z-encode module name
return (emptyMod p)
let ld = if sysPkgSuffix `isSuffixOf` p
then c_loadArchive
else c_loadObj
r <- withCString p ld
when (not r) (panic $ "Could not load module or package `"++p++"'")
let hifile = replaceSuffix p hiSuf
exists <- doesFileExist hifile
hiface <- if exists then readBinIface' hifile else return undefined
let m = emptyMod p hiface
addModule k m
return m
where emptyMod q = Module q (mkModid q) Vanilla undefined ky
where emptyMod q hiface = Module q (mkModid q) Vanilla hiface ky
-- |
-- load a single object. no dependencies. You should know what you're
@ -711,7 +722,11 @@ loadDepends obj incpaths = do
-- and find some packages to load, as well.
let ps = dep_pkgs ds
#if MIN_VERSION_ghc(8,0,0)
#if MIN_VERSION_Cabal(2,0,0)
ps' <- filterM loaded . map installedUnitIdString . nub $ map fst ps
#else
ps' <- filterM loaded . map unitIdString . nub $ map fst ps
#endif
#elif MIN_VERSION_ghc(7,10,0)
ps' <- filterM loaded . map packageKeyString . nub $ map fst ps
#elif MIN_VERSION_ghc(7,2,0)
@ -758,11 +773,14 @@ foreign import ccall unsafe "loadObj"
foreign import ccall unsafe "unloadObj"
c_unloadObj :: CString -> IO Bool
foreign import ccall unsafe "loadArchive"
c_loadArchive :: CString -> IO Bool
foreign import ccall unsafe "resolveObjs"
c_resolveObjs :: IO Bool
foreign import ccall unsafe "addDLL"
c_addDLL :: CString -> IO CString
foreign import ccall unsafe "initLinker"
initLinker :: IO ()
foreign import ccall unsafe "initLinker_"
initLinker_ :: CInt -> IO ()

159
src/System/Plugins/Utils.hs
View File

@ -57,20 +57,33 @@ module System.Plugins.Utils (
) where
#include "../../../config.h"
import System.Plugins.Env ( isLoaded )
import System.Plugins.Consts ( objSuf, hiSuf, tmpDir )
-- import qualified System.MkTemp ( mkstemps )
import Foreign.C (CInt(..), CString, withCString)
import Foreign.C.Error (Errno, eEXIST, getErrno, errnoToIOError)
import System.Posix.Internals
import System.Posix.Types (CMode)
import Control.Exception (IOException, catch)
import Data.Bits
import Data.Char
import Data.List
import Prelude hiding (catch)
import Prelude hiding (catch)
import System.IO
import System.IO hiding (openBinaryTempFile, openTempFile)
import System.Random (randomRIO)
import GHC.IO.Encoding (getLocaleEncoding)
import GHC.IO.Handle.FD
import qualified GHC.IO.FD as FD
import System.Environment ( getEnv )
import System.Directory ( doesFileExist, getModificationTime, removeFile )
import System.FilePath (pathSeparator)
-- ---------------------------------------------------------------------
-- some misc types we use
@ -90,31 +103,129 @@ hWrite hdl src = hPutStr hdl src >> hClose hdl >> return ()
-- ---------------------------------------------------------------------
-- | mkstemps.
-- | openTempFile.
--
-- We use the Haskell version now... it is faster than calling into
-- mkstemps(3).
-- System.IO.openTempFile uses undesirable characters in its filenames, which
-- breaks e.g. merge and other functions that try to compile Haskell source.
-- Sadly, this means we must provide our own secure temporary file facility.
--
-- mkstemps :: String -> Int -> IO (String,Handle)
-- mkstemps path slen = do
-- m_v <- System.MkTemp.mkstemps path slen
-- case m_v of Nothing -> error "mkstemps : couldn't create temp file"
-- Just v' -> return v'
openTempFile :: FilePath -- ^ Directory in which to create the file
-> String -- ^ File name prefix. If the prefix is \"fooie\",
-- the full name will be \"fooie\" followed by six
-- random alphanumeric characters followed by, if
-- given, the suffix. Should not contain any path
-- separator characters.
-> String -- ^ File name suffix. Should not contain any path
-- separator characters.
-> IO (FilePath, Handle)
openTempFile tmp_dir pfx sfx
= openTempFile' "openTempFile" tmp_dir pfx sfx False 0o600
{-
-- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.
openBinaryTempFile :: FilePath -> String -> String -> IO (FilePath, Handle)
openBinaryTempFile tmp_dir pfx sfx
= openTempFile' "openBinaryTempFile" tmp_dir pfx sfx True 0o600
mkstemps path slen = do
withCString path $ \ ptr -> do
let c_slen = fromIntegral $ slen+1
fd <- throwErrnoIfMinus1 "mkstemps" $ c_mkstemps ptr c_slen
name <- peekCString ptr
hdl <- fdToHandle fd
return (name, hdl)
-- | Like 'openTempFile', but uses the default file permissions
openTempFileWithDefaultPermissions :: FilePath -> String -> String
-> IO (FilePath, Handle)
openTempFileWithDefaultPermissions tmp_dir pfx sfx
= openTempFile' "openTempFileWithDefaultPermissions" tmp_dir pfx sfx False 0o666
foreign import ccall unsafe "mkstemps" c_mkstemps :: CString -> CInt -> IO Fd
-- | Like 'openBinaryTempFile', but uses the default file permissions
openBinaryTempFileWithDefaultPermissions :: FilePath -> String -> String
-> IO (FilePath, Handle)
openBinaryTempFileWithDefaultPermissions tmp_dir pfx sfx
= openTempFile' "openBinaryTempFileWithDefaultPermissions" tmp_dir pfx sfx True 0o666
-}
badfnmsg :: String
badfnmsg = "openTempFile': Template string must not contain path separator characters: "
openTempFile' :: String -> FilePath -> String -> String -> Bool -> CMode
-> IO (FilePath, Handle)
openTempFile' loc tmp_dir pfx sfx binary mode
| pathSeparator `elem` pfx
= fail $ badfnmsg++pfx
| pathSeparator `elem` sfx
= fail $ badfnmsg++sfx
| otherwise = findTempName
where
findTempName = do
filename <- mkTempFileName tmp_dir pfx sfx
r <- openNewFile filename binary mode
case r of
FileExists -> findTempName
OpenNewError errno -> ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
NewFileCreated fd -> do
(fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-}
False{-is_socket-}
True{-is_nonblock-}
enc <- getLocaleEncoding
h <- mkHandleFromFD fD fd_type filename ReadWriteMode False{-set non-block-} (Just enc)
return (filename, h)
mkTempFileName :: FilePath -> String -> String -> IO String
mkTempFileName dir pfx sfx = do
let rs = filter isAlphaNum ['0'..'z']
maxInd = length rs - 1
rchoose = do
i <- randomRIO (0, maxInd)
return (rs !! i)
rnd <- sequence $ replicate 6 rchoose
return $ dir </> pfx ++ rnd ++ sfx
data OpenNewFileResult
= NewFileCreated CInt
| FileExists
| OpenNewError Errno
openNewFile :: FilePath -> Bool -> CMode -> IO OpenNewFileResult
openNewFile filepath binary mode = do
let oflags1 = rw_flags .|. o_EXCL
binary_flags
| binary = o_BINARY
| otherwise = 0
oflags = oflags1 .|. binary_flags
fd <- withFilePath filepath $ \ f ->
c_open f oflags mode
if fd < 0
then do
errno <- getErrno
case errno of
_ | errno == eEXIST -> return FileExists
#ifdef mingw32_HOST_OS
-- If c_open throws EACCES on windows, it could mean that filepath is a
-- directory. In this case, we want to return FileExists so that the
-- enclosing openTempFile can try again instead of failing outright.
-- See bug #4968.
_ | errno == eACCES -> do
withCString filepath $ \path -> do
-- There is a race here: the directory might have been moved or
-- deleted between the c_open call and the next line, but there
-- doesn't seem to be any direct way to detect that the c_open call
-- failed because of an existing directory.
exists <- c_fileExists path
return $ if exists
then FileExists
else OpenNewError errno
#endif
_ -> return (OpenNewError errno)
else return (NewFileCreated fd)
#ifdef mingw32_HOST_OS
foreign import ccall "file_exists" c_fileExists :: CString -> IO Bool
#endif
-- XXX Copied from GHC.Handle
std_flags, output_flags, rw_flags :: CInt
std_flags = o_NONBLOCK .|. o_NOCTTY
output_flags = std_flags .|. o_CREAT
rw_flags = output_flags .|. o_RDWR
-- ---------------------------------------------------------------------
-- | create a new temp file, returning name and handle.
@ -126,10 +237,8 @@ mkTemp = do tmpd <- catch (getEnv "TMPDIR") (\ (_ :: IOException) -> return tmp
mkTempIn :: String -> IO (String, Handle)
mkTempIn tmpd = do
-- XXX (tmpf,hdl) <- mkstemps (tmpd++"/MXXXXXXXXX.hs") 3
(tmpf, hdl) <- openTempFile tmpd "MXXXXX.hs"
let modname = mkModid $ dropSuffix tmpf
(tmpf, hdl) <- openTempFile tmpd "Hsplugins" ".hs"
let modname = mkModid tmpf
if and $ map (\c -> isAlphaNum c && c /= '_') modname
then return (tmpf,hdl)
else panic $ "Illegal characters in temp file: `"++tmpf++"'"