Code for unloadAll.
This commit is contained in:
lemmih
parent
ff2a96c13d
commit
fc58e81ed6
@ -20,9 +20,11 @@
|
||||
|
||||
module System.Plugins.Env (
|
||||
withModEnv,
|
||||
withDepEnv,
|
||||
withPkgEnvs,
|
||||
withMerged,
|
||||
modifyModEnv,
|
||||
modifyDepEnv,
|
||||
modifyPkgEnv,
|
||||
modifyMerged,
|
||||
addModule,
|
||||
@ -30,6 +32,9 @@ module System.Plugins.Env (
|
||||
addModules,
|
||||
isLoaded,
|
||||
loaded,
|
||||
addModuleDeps,
|
||||
getModuleDeps,
|
||||
rmModuleDeps,
|
||||
isMerged,
|
||||
lookupMerged,
|
||||
addMerge,
|
||||
@ -43,6 +48,7 @@ module System.Plugins.Env (
|
||||
|
||||
#include "../../../../config.h"
|
||||
|
||||
import System.Plugins.LoadTypes
|
||||
import System.Plugins.PackageAPI {- everything -}
|
||||
#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604
|
||||
import System.Plugins.ParsePkgConfCabal( parsePkgConf )
|
||||
@ -52,7 +58,7 @@ import System.Plugins.ParsePkgConfLite ( parsePkgConf )
|
||||
import System.Plugins.Consts ( ghcLibraryPath, sysPkgConf, sysPkgSuffix, dllSuf )
|
||||
|
||||
import Data.IORef ( writeIORef, readIORef, newIORef, IORef() )
|
||||
import Data.Maybe ( isJust )
|
||||
import Data.Maybe ( isJust, isNothing )
|
||||
import Data.List ( isPrefixOf, nub )
|
||||
|
||||
import System.IO.Unsafe ( unsafePerformIO )
|
||||
@ -118,7 +124,9 @@ lookupFM = flip M.lookup
|
||||
-- unlike in hram's loader.
|
||||
--
|
||||
|
||||
type ModEnv = FiniteMap String Bool
|
||||
type ModEnv = FiniteMap String (Module,Int)
|
||||
|
||||
type DepEnv = FiniteMap Module [Module]
|
||||
|
||||
-- represents a package.conf file
|
||||
type PkgEnv = FiniteMap PackageName PackageConfig
|
||||
@ -130,7 +138,8 @@ type MergeEnv = FiniteMap (FilePath,FilePath) FilePath
|
||||
type PkgEnvs = [PkgEnv]
|
||||
|
||||
type Env = (MVar (),
|
||||
IORef ModEnv,
|
||||
IORef ModEnv,
|
||||
IORef DepEnv,
|
||||
IORef PkgEnvs,
|
||||
IORef MergeEnv)
|
||||
|
||||
@ -142,10 +151,11 @@ type Env = (MVar (),
|
||||
env = unsafePerformIO $ do
|
||||
mvar <- newMVar ()
|
||||
ref1 <- newIORef emptyFM -- loaded objects
|
||||
ref2 <- newIORef emptyFM
|
||||
p <- grabDefaultPkgConf
|
||||
ref2 <- newIORef p -- package.conf info
|
||||
ref3 <- newIORef emptyFM -- merged files
|
||||
return (mvar, ref1, ref2, ref3)
|
||||
ref3 <- newIORef p -- package.conf info
|
||||
ref4 <- newIORef emptyFM -- merged files
|
||||
return (mvar, ref1, ref2, ref3, ref4)
|
||||
{-# NOINLINE env #-}
|
||||
|
||||
-- -----------------------------------------------------------
|
||||
@ -156,12 +166,14 @@ env = unsafePerformIO $ do
|
||||
-- with*Env function. Nice and threadsafe
|
||||
--
|
||||
withModEnv :: Env -> (ModEnv -> IO a) -> IO a
|
||||
withDepEnv :: Env -> (DepEnv -> IO a) -> IO a
|
||||
withPkgEnvs :: Env -> (PkgEnvs -> IO a) -> IO a
|
||||
withMerged :: Env -> (MergeEnv -> IO a) -> IO a
|
||||
|
||||
withModEnv (mvar,ref,_,_) f = withMVar mvar (\_ -> readIORef ref >>= f)
|
||||
withPkgEnvs (mvar,_,ref,_) f = withMVar mvar (\_ -> readIORef ref >>= f)
|
||||
withMerged (mvar,_,_,ref) f = withMVar mvar (\_ -> readIORef ref >>= f)
|
||||
withModEnv (mvar,ref,_,_,_) f = withMVar mvar (\_ -> readIORef ref >>= f)
|
||||
withDepEnv (mvar,_,ref,_,_) f = withMVar mvar (\_ -> readIORef ref >>= f)
|
||||
withPkgEnvs (mvar,_,_,ref,_) f = withMVar mvar (\_ -> readIORef ref >>= f)
|
||||
withMerged (mvar,_,_,_,ref) f = withMVar mvar (\_ -> readIORef ref >>= f)
|
||||
|
||||
-- -----------------------------------------------------------
|
||||
--
|
||||
@ -169,12 +181,14 @@ withMerged (mvar,_,_,ref) f = withMVar mvar (\_ -> readIORef ref >>= f)
|
||||
-- write a new PackageConfig
|
||||
--
|
||||
modifyModEnv :: Env -> (ModEnv -> IO ModEnv) -> IO ()
|
||||
modifyDepEnv :: Env -> (DepEnv -> IO DepEnv) -> IO ()
|
||||
modifyPkgEnv :: Env -> (PkgEnvs -> IO PkgEnvs) -> IO ()
|
||||
modifyMerged :: Env -> (MergeEnv -> IO MergeEnv)-> IO ()
|
||||
|
||||
modifyModEnv (mvar,ref,_,_) f = lockAndWrite mvar ref f
|
||||
modifyPkgEnv (mvar,_,ref,_) f = lockAndWrite mvar ref f
|
||||
modifyMerged (mvar,_,_,ref) f = lockAndWrite mvar ref f
|
||||
modifyModEnv (mvar,ref,_,_,_) f = lockAndWrite mvar ref f
|
||||
modifyDepEnv (mvar,_,ref,_,_) f = lockAndWrite mvar ref f
|
||||
modifyPkgEnv (mvar,_,_,ref,_) f = lockAndWrite mvar ref f
|
||||
modifyMerged (mvar,_,_,_,ref) f = lockAndWrite mvar ref f
|
||||
|
||||
-- private
|
||||
lockAndWrite mvar ref f = withMVar mvar (\_->readIORef ref>>=f>>=writeIORef ref)
|
||||
@ -183,23 +197,29 @@ lockAndWrite mvar ref f = withMVar mvar (\_->readIORef ref>>=f>>=writeIORef ref)
|
||||
--
|
||||
-- insert a loaded module name into the environment
|
||||
--
|
||||
addModule :: String -> IO ()
|
||||
addModule s = modifyModEnv env $ \fm -> return $ addToFM fm s True
|
||||
addModule :: String -> Module -> IO ()
|
||||
addModule s m = modifyModEnv env $ \fm -> let c = maybe 0 snd (lookupFM fm s)
|
||||
in return $ addToFM fm s (m,c+1)
|
||||
|
||||
--getModule :: String -> IO (Maybe Module)
|
||||
--getModule s = withModEnv env $ \fm -> return (lookupFM fm s)
|
||||
|
||||
--
|
||||
-- remove a module name from the environment
|
||||
-- remove a module name from the environment. Returns True if the module was actually removed.
|
||||
--
|
||||
rmModule :: String -> IO ()
|
||||
rmModule s = modifyModEnv env $ \fm -> return $ delFromFM fm s
|
||||
rmModule :: String -> IO Bool
|
||||
rmModule s = do modifyModEnv env $ \fm -> let c = maybe 1 snd (lookupFM fm s)
|
||||
fm' = delFromFM fm s
|
||||
in if c-1 <= 0
|
||||
then return fm'
|
||||
else return fm
|
||||
withModEnv env $ \fm -> return (isNothing (lookupFM fm s))
|
||||
|
||||
--
|
||||
-- insert a list of module names all in one go
|
||||
--
|
||||
addModules :: [String] -> IO ()
|
||||
addModules ns = modifyModEnv env $ \fm -> return $ unionL fm ns
|
||||
where
|
||||
unionL :: ModEnv -> [String] -> ModEnv
|
||||
unionL fm ss = foldr (\s fm' -> addToFM fm' s True) fm ss
|
||||
addModules :: [(String,Module)] -> IO ()
|
||||
addModules ns = mapM_ (uncurry addModule) ns
|
||||
|
||||
--
|
||||
-- is a module/package already loaded?
|
||||
@ -213,6 +233,30 @@ isLoaded s = withModEnv env $ \fm -> return $ isJust (lookupFM fm s)
|
||||
loaded :: String -> IO Bool
|
||||
loaded m = do t <- isLoaded m ; return (not t)
|
||||
|
||||
-- -----------------------------------------------------------
|
||||
--
|
||||
-- module dependency stuff
|
||||
--
|
||||
|
||||
--
|
||||
-- set the dependencies of a Module.
|
||||
--
|
||||
addModuleDeps :: Module -> [Module] -> IO ()
|
||||
addModuleDeps m deps = modifyDepEnv env $ \fm -> return $ addToFM fm m deps
|
||||
|
||||
--
|
||||
-- Get module dependencies. Nothing if none have been recored.
|
||||
--
|
||||
getModuleDeps :: Module -> IO (Maybe [Module])
|
||||
getModuleDeps m = withDepEnv env $ \fm -> return $ lookupFM fm m
|
||||
|
||||
|
||||
--
|
||||
-- Unrecord a module from the environment.
|
||||
--
|
||||
rmModuleDeps :: Module -> IO ()
|
||||
rmModuleDeps m = modifyDepEnv env $ \fm -> return $ delFromFM fm m
|
||||
|
||||
-- -----------------------------------------------------------
|
||||
-- Package management stuff
|
||||
--
|
||||
|
||||
@ -26,6 +26,7 @@ module System.Plugins.Load (
|
||||
, dynload
|
||||
, pdynload , pdynload_
|
||||
, unload
|
||||
, unloadAll
|
||||
, reload
|
||||
, Module(..)
|
||||
|
||||
@ -58,6 +59,7 @@ import AltData.Dynamic ( fromDynamic, Dynamic )
|
||||
import AltData.Typeable ( Typeable )
|
||||
|
||||
import Data.List ( isSuffixOf, nub, nubBy )
|
||||
import Data.Maybe ( fromMaybe )
|
||||
import Control.Monad ( when, filterM, liftM )
|
||||
import System.Directory ( doesFileExist, removeFile )
|
||||
import Foreign.C.String ( CString, withCString, peekCString )
|
||||
@ -75,19 +77,7 @@ import System.IO ( hClose )
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
type Symbol = String
|
||||
type Type = String
|
||||
type Errors = [String]
|
||||
type PackageConf = FilePath
|
||||
|
||||
data Module = Module { path :: !FilePath
|
||||
, mname :: !String
|
||||
, kind :: !ObjType
|
||||
, iface :: Iface -- cache the iface
|
||||
, key :: Key
|
||||
}
|
||||
|
||||
data ObjType = Vanilla | Shared deriving Eq
|
||||
import System.Plugins.LoadTypes
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
-- return status of all *load functions:
|
||||
@ -114,7 +104,7 @@ load obj incpaths pkgconfs sym = do
|
||||
|
||||
-- load extra package information
|
||||
mapM_ addPkgConf pkgconfs
|
||||
hif <- loadDepends obj incpaths
|
||||
(hif,moduleDeps) <- loadDepends obj incpaths
|
||||
|
||||
-- why is this the package name?
|
||||
#if DEBUG
|
||||
@ -128,7 +118,7 @@ load obj incpaths pkgconfs sym = do
|
||||
#if DEBUG
|
||||
putStrLn " ... done" >> hFlush stdout
|
||||
#endif
|
||||
|
||||
addModuleDeps m' moduleDeps
|
||||
v <- loadFunction m sym
|
||||
return $ case v of
|
||||
Nothing -> LoadFailure ["load: couldn't find symbol <<"++sym++">>"]
|
||||
@ -309,7 +299,13 @@ dynload2 obj incpath pkgconfs sym = do
|
||||
-- it. Cause we don't unload all the dependencies
|
||||
--
|
||||
unload :: Module -> IO ()
|
||||
unload = unloadObj
|
||||
unload m = rmModuleDeps m >> unloadObj m
|
||||
|
||||
unloadAll :: Module -> IO ()
|
||||
unloadAll m = do moduleDeps <- fmap (fromMaybe []) (getModuleDeps m)
|
||||
rmModuleDeps m
|
||||
mapM_ unloadAll moduleDeps
|
||||
unload m
|
||||
|
||||
--
|
||||
-- | this will be nice for panTHeon, needs thinking about the interface
|
||||
@ -409,7 +405,7 @@ loadFunction (Module { iface = i }) valsym
|
||||
-- Z-encoded modid from the .hi file. For archives/packages, we can
|
||||
-- probably get away with the package name
|
||||
--
|
||||
data Key = Object String | Package String
|
||||
|
||||
|
||||
loadObject :: FilePath -> Key -> IO Module
|
||||
loadObject p ky@(Object k) = loadObject' p ky k
|
||||
@ -424,7 +420,7 @@ loadObject' p ky k
|
||||
when (not alreadyLoaded) $ do
|
||||
r <- withCString p c_loadObj
|
||||
when (not r) (panic $ "Could not load module `"++p++"'")
|
||||
addModule k -- needs to Z-encode module name
|
||||
addModule k (emptyMod p) -- needs to Z-encode module name
|
||||
return (emptyMod p)
|
||||
|
||||
where emptyMod q = Module q (mkModid q) Vanilla emptyIface ky
|
||||
@ -466,12 +462,11 @@ resolveObjs = do
|
||||
unloadObj :: Module -> IO ()
|
||||
unloadObj (Module { path = p, kind = k, key = ky }) = case k of
|
||||
Vanilla -> withCString p $ \c_p -> do
|
||||
r <- c_unloadObj c_p
|
||||
when (not r) (panic "unloadObj: failed")
|
||||
rmModule $ case ky of Object s -> s ; Package pk -> pk
|
||||
|
||||
removed <- rmModule name
|
||||
when (removed) $ do r <- c_unloadObj c_p
|
||||
when (not r) (panic "unloadObj: failed")
|
||||
Shared -> return () -- can't unload .so?
|
||||
|
||||
where name = case ky of Object s -> s ; Package pk -> pk
|
||||
--
|
||||
-- | from ghci/ObjLinker.c
|
||||
--
|
||||
@ -559,7 +554,7 @@ loadPackageWith p pkgconfs = do
|
||||
-- the modenv fm. We need a canonical form for the keys -- is basename
|
||||
-- good enough?
|
||||
--
|
||||
loadDepends :: FilePath -> [FilePath] -> IO Iface
|
||||
loadDepends :: FilePath -> [FilePath] -> IO (Iface,[Module])
|
||||
loadDepends obj incpaths = do
|
||||
let hifile = replaceSuffix obj hiSuf
|
||||
exists <- doesFileExist hifile
|
||||
@ -568,11 +563,11 @@ loadDepends obj incpaths = do
|
||||
#if DEBUG
|
||||
putStrLn "No .hi file found." >> hFlush stdout
|
||||
#endif
|
||||
return emptyIface -- could be considered fatal
|
||||
return (emptyIface,[]) -- could be considered fatal
|
||||
|
||||
else do hiface <- readIface hifile
|
||||
let ds = mi_deps hiface
|
||||
|
||||
|
||||
-- remove ones that we've already loaded
|
||||
ds' <- filterM loaded (dep_mods ds)
|
||||
|
||||
@ -611,8 +606,8 @@ loadDepends obj incpaths = do
|
||||
putStr "Loading object"
|
||||
mapM_ (\(m,_) -> putStr (" "++(decode m)) >> hFlush stdout) mods''
|
||||
#endif
|
||||
mapM_ (\(hi,m) -> loadObject m (Object hi)) mods''
|
||||
return hiface
|
||||
moduleDeps <- mapM (\(hi,m) -> loadObject m (Object hi)) mods''
|
||||
return (hiface,moduleDeps)
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
-- C interface
|
||||
|
||||
31
src/plugins/System/Plugins/LoadTypes.hs
Normal file
31
src/plugins/System/Plugins/LoadTypes.hs
Normal file
@ -0,0 +1,31 @@
|
||||
module System.Plugins.LoadTypes
|
||||
( Key (..)
|
||||
, Symbol
|
||||
, Type
|
||||
, Errors
|
||||
, PackageConf
|
||||
, Module (..)
|
||||
, ObjType (..)
|
||||
) where
|
||||
|
||||
import Language.Hi.Parser
|
||||
|
||||
data Key = Object String | Package String
|
||||
type Symbol = String
|
||||
type Type = String
|
||||
type Errors = [String]
|
||||
type PackageConf = FilePath
|
||||
|
||||
data Module = Module { path :: !FilePath
|
||||
, mname :: !String
|
||||
, kind :: !ObjType
|
||||
, iface :: Iface -- cache the iface
|
||||
, key :: Key
|
||||
}
|
||||
instance Ord Module where
|
||||
compare m1 m2 = mname m1 `compare` mname m2
|
||||
|
||||
instance Eq Module where
|
||||
m1 == m2 = mname m1 == mname m2
|
||||
|
||||
data ObjType = Vanilla | Shared deriving Eq
|
||||
@ -29,6 +29,7 @@ maintainer: dons@cse.unsw.edu.au
|
||||
exposed: True
|
||||
exposed-modules:
|
||||
System.Plugins.Load,
|
||||
System.Plugins.LoadTypes,
|
||||
System.Plugins.Make,
|
||||
System.Plugins,
|
||||
System.MkTemp,
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user