From fc58e81ed63ffc8ae274f3c1a6aa41d7e0eb356e Mon Sep 17 00:00:00 2001 From: lemmih Date: Thu, 19 May 2005 03:22:54 +0000 Subject: [PATCH] Code for unloadAll. --- src/plugins/System/Plugins/Env.hs | 88 ++++++++++++++++++------- src/plugins/System/Plugins/Load.hs | 51 +++++++------- src/plugins/System/Plugins/LoadTypes.hs | 31 +++++++++ src/plugins/plugins.conf.in.cpp | 1 + 4 files changed, 121 insertions(+), 50 deletions(-) create mode 100644 src/plugins/System/Plugins/LoadTypes.hs diff --git a/src/plugins/System/Plugins/Env.hs b/src/plugins/System/Plugins/Env.hs index 0fc75da..7d8362f 100644 --- a/src/plugins/System/Plugins/Env.hs +++ b/src/plugins/System/Plugins/Env.hs @@ -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 -- diff --git a/src/plugins/System/Plugins/Load.hs b/src/plugins/System/Plugins/Load.hs index 9f9361c..8479a67 100644 --- a/src/plugins/System/Plugins/Load.hs +++ b/src/plugins/System/Plugins/Load.hs @@ -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 diff --git a/src/plugins/System/Plugins/LoadTypes.hs b/src/plugins/System/Plugins/LoadTypes.hs new file mode 100644 index 0000000..a59ee42 --- /dev/null +++ b/src/plugins/System/Plugins/LoadTypes.hs @@ -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 \ No newline at end of file diff --git a/src/plugins/plugins.conf.in.cpp b/src/plugins/plugins.conf.in.cpp index fc251f1..67114f2 100644 --- a/src/plugins/plugins.conf.in.cpp +++ b/src/plugins/plugins.conf.in.cpp @@ -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,