diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2003-2004, Hampus Ram +Copyright (c) 2012, Gabor Greif + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Hampus Ram nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/Plugins/Criteria/LoadCriterion.hs b/System/Plugins/Criteria/LoadCriterion.hs new file mode 100644 --- /dev/null +++ b/System/Plugins/Criteria/LoadCriterion.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE KindSignatures, ConstraintKinds, + TypeFamilies, MultiParamTypeClasses #-} + +module System.Plugins.Criteria.LoadCriterion (LoadCriterion(..), Criterion(..)) where + +-- The 'Constraint' kind is defined in 'GHC.Exts' + +import GHC.Exts +import System.Plugins.DynamicLoader +import Data.Dynamic +import Control.Monad.IO.Class + +class LoadCriterion (c :: Constraint) t where + data Criterion c t + type Effective c t :: * + addDynamicLibrary :: Criterion c t -> String -> IO () + addDynamicLibrary _ = addDLL + resolveSymbols :: Criterion c t -> IO () + resolveSymbols _ = resolveFunctions + loadQualified :: c => Criterion c t -> String -> Effective c t + + +-- Safe criteria follow + +-- | When the symbol's type is Typeable we load from the suffixed symbol and +-- | try to resolve it. +instance LoadCriterion (Typeable t) t where + data Criterion (Typeable t) t = DynamicCriterion + type Effective (Typeable t) t = IO (Maybe t) + loadQualified DynamicCriterion name = loadQualifiedDynFunction (adornSymbol name) + where adornSymbol n = n ++ "Dyn" + + +loadQualifiedDynFunction :: Typeable t => String -> IO (Maybe t) +loadQualifiedDynFunction name = fmap fromDynamic dyn + where dyn :: IO Dynamic + dyn = loadQualifiedFunction name + + +-- | When the symbol's type is Typeable and we are in a monad that can +-- | reliably fail, we load from the suffixed symbol and try to resolve it, +-- | failing when the type does not correspond with the expectation. +instance LoadCriterion (Typeable t, MonadIO m) t where + data Criterion (Typeable t, MonadIO m) t = DynamicFailableCriterion + type Effective (Typeable t, MonadIO m) t = m t + loadQualified DynamicFailableCriterion name = do sym <- liftIO $ loadQualifiedDynFunction (adornSymbol name) + case sym of + Nothing -> liftIO $ fail ("symbol " ++ name ++ " does not have the expected type") + Just it -> return it + where adornSymbol n = n ++ "Dyn" + diff --git a/System/Plugins/Criteria/UnsafeCriterion.hs b/System/Plugins/Criteria/UnsafeCriterion.hs new file mode 100644 --- /dev/null +++ b/System/Plugins/Criteria/UnsafeCriterion.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE KindSignatures, ConstraintKinds, TypeFamilies, + MultiParamTypeClasses, FlexibleInstances #-} + +module System.Plugins.Criteria.UnsafeCriterion (Criterion(..)) where + +import System.Plugins.Criteria.LoadCriterion +import System.Plugins.DynamicLoader + +instance LoadCriterion () t where + data Criterion () t = UnsafeCriterion + type Effective () t = IO t + loadQualified UnsafeCriterion = loadQualifiedFunction diff --git a/System/Plugins/DynamicLoader.hs b/System/Plugins/DynamicLoader.hs new file mode 100644 --- /dev/null +++ b/System/Plugins/DynamicLoader.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} +---------------------------------------------------------------------------- +-- | +-- Module : DynamicLoader +-- Copyright : (c) Hampus Ram 2003-2004, Gabor Greif 2012 +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : ggreif+dynamic@gmail.com +-- Stability : experimental +-- Portability : non-portable (ghc >= 7.6 only) +-- +-- A module that implements dynamic loading. You can load +-- and use GHC object files and packages dynamically at runtime. +-- +---------------------------------------------------------------------------- +module System.Plugins.DynamicLoader (DynamicModule, + dm_path, + DynamicPackage, + dp_path, + + addDLL, + + loadModule, + loadModuleFromPath, + loadPackage, + loadPackageFromPath, + unloadModule, + unloadPackage, + loadFunction, + loadQualifiedFunction, + resolveFunctions) where + +import Data.Char (ord) +import Data.List +import Control.Monad + +import GHC.Exts +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.C.String (CString, withCString, peekCString) +import System.Directory (getCurrentDirectory, doesFileExist) +import GHC.Prim + +{- + +Foreign imports, hooks into the GHC RTS. + +-} + +foreign import ccall unsafe "loadObj" + c_loadObj :: CString -> IO Int + +foreign import ccall unsafe "unloadObj" + c_unloadObj :: CString -> IO Int + +foreign import ccall unsafe "resolveObjs" + c_resolveObjs :: IO Int + +foreign import ccall unsafe "lookupSymbol" + c_lookupSymbol :: CString -> IO (Ptr a) + +foreign import ccall unsafe "addDLL" + c_addDLL :: CString -> IO CString + +-- split up qualified name so one could easily transform it +-- into A.B.C or A/B/C depending on context +data DynamicModule = RTM { dm_qname :: [String], + dm_path :: FilePath } + +data DynamicPackage = RTP { dp_path :: FilePath, + dp_cbits :: Maybe DynamicPackage } +{-| + +Dynamically load a shared library (DLL or .so). A shared library can't +be unloaded using this interface, if you need it use +System.Posix.DynamicLinker instead. + +-} + +addDLL :: String -> IO () +addDLL str = withCString str + (\s -> do err <- c_addDLL s + unless (err == nullPtr) + (do msg <- peekCString err + fail $ "Unable to load library: " ++ str ++ "\n " ++ msg)) + +{-| + +Load a module given its name (for instance @Data.FiniteMap@), maybe a +path to the base directory and maybe a file extension. If no such path +is given the current working directory is used and if no file suffix +is given \"o\" is used. + +If we have our module hierarchy in @\/usr\/lib\/modules@ and we want to +load the module @Foo.Bar@ located in @\/usr\/lib\/modules\/Foo\/Bar.o@ we +could issue the command: + +@loadModule \"Foo.Bar\" (Just \"\/usr\/lib\/modules\") Nothing@ + +If our current directory was @\/tmp@ and we wanted to load the module +@Foo@ located in the file @\/tmp\/Foo.obj@ we would write: + +@loadModule \"Foo\" Nothing (Just \"obj\")@ + +If it cannot load the object it will throw an exception. + +-} +loadModule :: String -> Maybe FilePath -> Maybe String -> IO DynamicModule +loadModule name mpath msuff + = do base <- maybe getCurrentDirectory return mpath + + let qname = split '.' name + suff = maybe "o" id msuff + path = base ++ '/' : concat (intersperse "/" qname) ++ + '.' : suff + ret <- withCString path c_loadObj + if ret /= 0 + then return (RTM qname path) + else fail $ "Unable to load module: " ++ path + +{-| + +Load a module given its full path and maybe a base directory to use in +figuring out the module's hierarchical name. If no base directory is +given, it is set to the current directory. + +For instance if one wants to load module @Foo.Bar@ located in +@\/usr\/modules\/Foo\/Bar.o@ one would issue the command: + +@loadModuleFromPath \"\/usr\/modules\/Foo\/Bar.o\" (Just +\"\/usr\/modules\")@ + +If it cannot load the object it will throw an exception. + +-} +loadModuleFromPath :: FilePath -> Maybe FilePath -> IO DynamicModule +loadModuleFromPath path mbase + = do base <- maybe getCurrentDirectory return mbase + + qual <- dropIsEq base path + + -- not very smart but simple... + let name = reverse $ drop 1 $ dropWhile (/='.') $ + reverse $ if head qual == '/' then drop 1 qual else qual + + qname = split '/' name + + ret <- withCString path c_loadObj + if ret /= 0 + then return (RTM qname path) + else fail $ "Unable to load module: " ++ path + + where dropIsEq [] ys = return ys + dropIsEq (x:xs) (y:ys) + | x == y = dropIsEq xs ys + | otherwise = fail $ "Unable to get qualified name from: " + ++ path + dropIsEq _ _ = fail $ "Unable to get qualified name from: " ++ path + +split :: Char -> String -> [String] +split _ "" = [] +split c s = let (l,s') = break (c==) s + in l : case s' of [] -> [] + (_:s'') -> split c s'' + +{-| + +Load a GHC package such as \"base\" or \"text\". Takes the package name, +maybe a path to the packages, maybe a package prefix and maybe a +package suffix. + +Path defaults to the current directory, package prefix to \"HS\" and +package suffix to \"o\". + +This function also loads accompanying cbits-packages. I.e. if you load +the package @base@ located in @\/usr\/modules@ using @HS@ and @o@ as +prefix and suffix, @loadPackage@ will also look for the file +@\/usr\/modules\/HSbase_cbits.o@ and load it if present. + +If it fails to load a package it will throw an exception. You will +need to resolve functions before you use any functions loaded. + +-} +loadPackage :: String -> Maybe FilePath -> Maybe String -> Maybe String -> + IO DynamicPackage +loadPackage name mpath mpre msuff + = do base <- case mpath of + Just a -> return a + _ -> getCurrentDirectory + + let path = packageName name base mpre msuff + + ret <- withCString path c_loadObj + unless (ret /= 0) (fail $ "Unable to load package: " ++ name) + + let cbits_path = packageName (name ++ "_cbits") base mpre msuff + + -- this will generate an extra unnecessary call checking for + -- FOO_cbits_cbits, but it looks nicer! + cbitsExist <- doesFileExist cbits_path + if cbitsExist + then do rtp <- loadPackage (name ++ "_cbits") mpath mpre msuff + return (RTP path (Just rtp)) + else return (RTP path Nothing) + + where packageName :: String -> FilePath -> Maybe String -> + Maybe String -> FilePath + packageName name path mpre msuff + = let prefix = maybe "HS" id mpre + suffix = maybe "o" id msuff + in path ++ '/' : prefix ++ name ++ '.' : suffix + +{-| + +Load a GHC package such as \"base\" or \"text\". Takes the full path to +the package. + +This function also loads accompanying cbits-packages. I.e. if you load +the package @\/usr\/modules\/HSbase.o@ it will deduce that @o@ is the +suffix and @loadPackageFromPath@ will then also look for the file +@\/usr\/modules\/HSbase_cbits.o@ and load it if present. + +If it fails to load a package it will throw an exception. You will +need to resolve functions before you use any functions loaded. + +-} +loadPackageFromPath :: FilePath -> IO DynamicPackage +loadPackageFromPath path + = do ret <- withCString path c_loadObj + unless (ret /= 0) (fail $ "Unable to load package: " ++ path) + + let cbits_path = cbitsName path + + -- this will generate an extra unnecessary call checking for + -- FOO_cbits_cbits, but it looks nicer! + cbitsExist <- doesFileExist cbits_path + if cbitsExist + then do rtp <- loadPackageFromPath cbits_path + return (RTP path (Just rtp)) + else return (RTP path Nothing) + + where cbitsName :: FilePath -> String + cbitsName name + = let suffix = reverse $! takeWhile (/='.') rname + rname = reverse name + in reverse (drop (length suffix + 1) rname) ++ + "_cbits." ++ suffix -- wrong but simple... + +{-| + +Unload a package (such as @base@) and its cbits-package (if +any). Throws an exception if any unloading fails. + +-} +unloadPackage :: DynamicPackage -> IO () +unloadPackage (RTP { dp_path = path, dp_cbits = cbits }) + = do ret <- withCString path c_unloadObj + unless (ret /= 0) (fail $ "Unable to unload package: " ++ path) + maybe (return ()) unloadPackage cbits + +{-| + +Unload a previously loaded module. If it cannot unload it an exception +will be thrown. + +-} +unloadModule :: DynamicModule -> IO () +unloadModule (RTM { dm_path = path }) + = do ret <- withCString path c_unloadObj + unless (ret /= 0) (fail $ "Unable to unload module: " ++ path) + +{-| + +Load a function from a given module. If the function can't be found an +exception will be thrown. You should have called @resolveFunctions@ before +you call this. + +Beware that this function isn't type-safe in any way! + +-} +loadFunction :: DynamicModule -> String -> IO a +loadFunction dm functionName + = do Ptr addr <- lookupSymbol (dm_qname dm) functionName + case addrToAny# addr of + (# hval #) -> return hval + +{-| + +Load a function from package (or module) given the fully qualified +name (e.g. @Data.FiniteMap.emptyFM@). If the function can't be found an +exception will be thrown. You should have called @resolveFunctions@ +before you call this. + +You must take care that you load the function qualified with the name +of the module it's defined in! You can for instance not load +@Data.Bool.not@ because it is only reexported in that module (from +GHC.Base). + +Beware that this function isn't type-safe in any way! + +-} +loadQualifiedFunction :: String -> IO a +loadQualifiedFunction functionName + = do let qfunc = split '.' functionName + Ptr addr <- lookupSymbol (init qfunc) (last qfunc) + case addrToAny# addr of + (# hval #) -> return hval + +{-| + +Resolve all loaded functions. Should be called before any functions +are loaded. If it is unable to resolve all functions it will throw an +exception. + +-} +resolveFunctions :: IO () +resolveFunctions + = do ret <- c_resolveObjs + when (ret == 0) (fail "Unable to resolve functions!") + +{-| + +Find a symbol in a module's symbol-table. Throw an exception if it +isn't found. + +-} +lookupSymbol :: [String] -> String -> IO (Ptr a) +lookupSymbol qname functionName + = do ptr <- withCString symbolName c_lookupSymbol + if ptr /= nullPtr + then return ptr + else fail $ "Could not load symbol: " ++ symbolName + where + moduleName = encode $ concat (intersperse "." qname) + realFunctionName = encode functionName + + -- On OS X all functions have an extra _, at least that + -- is what people say. Not tested! +#ifdef __MACOSX__ + symbolName = "_" ++ moduleName ++ "_" ++ realFunctionName ++ "_closure" +#else + symbolName = moduleName ++ "_" ++ realFunctionName ++ "_closure" +#endif + + encode :: String -> String + encode str = concatMap encode_ch str + + unencodedChar :: Char -> Bool -- True for chars that don't need encoding + unencodedChar 'Z' = False + unencodedChar 'z' = False + unencodedChar c = c >= 'a' && c <= 'z' + || c >= 'A' && c <= 'Z' + || c >= '0' && c <= '9' + + encode_ch c | unencodedChar c = [c] -- Common case first + encode_ch 'Z' = "ZZ" + encode_ch 'z' = "zz" + encode_ch '&' = "za" + encode_ch '|' = "zb" + encode_ch '^' = "zc" + encode_ch '$' = "zd" + encode_ch '=' = "ze" + encode_ch '>' = "zg" + encode_ch '#' = "zh" + encode_ch '.' = "zi" + encode_ch '<' = "zl" + encode_ch '-' = "zm" + encode_ch '!' = "zn" + encode_ch '+' = "zp" + encode_ch '\'' = "zq" + encode_ch '\\' = "zr" + encode_ch '/' = "zs" + encode_ch '*' = "zt" + encode_ch '_' = "zu" + encode_ch '%' = "zv" + encode_ch c = 'z' : shows (ord c) "U" diff --git a/System/Plugins/NameLoader.hs b/System/Plugins/NameLoader.hs new file mode 100644 --- /dev/null +++ b/System/Plugins/NameLoader.hs @@ -0,0 +1,369 @@ +---------------------------------------------------------------------------- +-- | +-- Module : NameLoader +-- Copyright : (c) Hampus Ram 2004, Gabor Greif 2012 +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : ggreif+dynamic@gmail.com +-- Stability : experimental +-- Portability : non-portable (ghc >= 7.6 only) +-- +-- A module that implements dynamic loading. +-- Has smart handling of dependencies and +-- is thread safe. +-- +---------------------------------------------------------------------------- +{-# LANGUAGE ScopedTypeVariables, ConstraintKinds #-} + +module System.Plugins.NameLoader (Module, LoadedModule, + ModuleType(..), + setEnvironment, + addDependency, + delDependency, + delAllDeps, + withDependencies, + loadModule, + unloadModule, + unloadModuleQuiet, + loadFunction, + moduleLoadedAt, + loadedModules, + sm_path, + DL.addDLL) where + +import Data.Char (isUpper) + +import Control.Concurrent.MVar +import Data.List +import qualified Data.HashTable.IO as HT +import Data.Hashable +import Data.IORef +import System.IO.Unsafe +import System.Directory +import Data.Time +import Control.Exception (catch, SomeException) +import System.Plugins.Criteria.LoadCriterion +import System.Plugins.Criteria.UnsafeCriterion + +import qualified System.Plugins.DynamicLoader as DL + +type Loadable c t t' = (LoadCriterion c t, Effective c t ~ IO t') + +type Module = String + +newtype LoadedModule = LM Module + +data ModuleType = MT_Module + | MT_Package + deriving (Eq, Ord, Show) + +type ModuleWT = (String, ModuleType) + +type NameDynamics = Either DL.DynamicModule DL.DynamicPackage + +type NameDep = [Module] + +-- SM reference_count type time module +data NameModule = SM { sm_refc :: !Int, + sm_time :: UTCTime, + sm_deps :: NameDep, + sm_module :: NameDynamics } + +-- module_path modudle_suff +-- pkg_path pkg_prefix pkg_suffix +-- dependency_map modules +type NameEnvData = (Maybe FilePath, Maybe String, + Maybe FilePath, Maybe String, Maybe String, + HT.BasicHashTable String [Module], + HT.BasicHashTable String NameModule) + +{- + + New NameEnv that uses both an IORef and a MVar + to make it possible to have non blocking functions + that inspect the state. + + Could perhaps change it to only use IORef (with atomicModifyIORef) + but let's play safe and have an MVar too. + +-} +type NameEnv = (MVar (), IORef NameEnvData) + +withNameEnv :: Loadable c t t' => Criterion c t -> NameEnv -> (NameEnvData -> Effective c t) -> Effective c t +withNameEnv _ (mvar, ioref) f + = withMVar mvar (\_ -> readIORef ioref >>= f) + +withNameEnvNB :: NameEnv -> (NameEnvData -> IO b) -> IO b +withNameEnvNB (_, ioref) f = readIORef ioref >>= f + +modifyNameEnv_ :: NameEnv -> (NameEnvData -> IO NameEnvData) -> IO () +modifyNameEnv_ (mvar, ioref) f + = withMVar mvar (\_ -> readIORef ioref >>= f >>= writeIORef ioref) + +{-# NOINLINE env #-} +env :: NameEnv +env = unsafePerformIO (do modh <- HT.new + deph <- HT.new + mvar <- newMVar () + ioref <- newIORef (Nothing, Nothing, Nothing, + Nothing, Nothing, deph, modh) + return (mvar, ioref)) + +{-| + +Set the environment in wich all module loading will reside. If this +function isn't called the defaults will be used. + +The parameters are: Path to modules, module suffix, path to packages, +package prefix and package suffix. The paths will default to current +directory and the rest (in order) to /o/, /HS/ and /o/. + +-} +setEnvironment :: Maybe FilePath -> Maybe String -> + Maybe FilePath -> Maybe String -> Maybe String -> IO () +setEnvironment mpath msuff ppath ppre psuff + = modifyNameEnv_ env (\(_, _, _, _, _, deph, modh) -> + return (mpath, msuff, ppath, ppre, psuff, + deph, modh)) + + +{-| + +Add a module dependency. Any dependencies must be added /before/ any +calls to loadModule or symbols will not be resolved with a crash as +result. + +-} +addDependency :: Module -> Module -> IO () +addDependency from to = withNameEnv UnsafeCriterion env (addDependency' from to) + +addDependency' :: Module -> Module -> NameEnvData -> IO () +addDependency' from to (_, _, _, _, _, deph, _) + = insertHT_C union deph from [to] + +{-| + +Delete a module dependency. + +-} +delDependency :: Module -> Module -> IO () +delDependency from to = withNameEnv UnsafeCriterion env (delDependency' from to) + +delDependency' :: Module -> Module -> NameEnvData -> IO () +delDependency' from to (_, _, _, _, _, deph, _) + = modifyHT (\\[to]) deph from + +{-| + +Delete all dependencies for a module. + +-} + +delAllDeps :: Module -> IO () +delAllDeps from = withNameEnv UnsafeCriterion env (delAllDeps' from) + +delAllDeps' :: Module -> NameEnvData -> IO () +delAllDeps' from (_, _, _, _, _, deph, _) + = deleteHT deph from + +{-| + +Do something with the current dependencies of a module. You can't use +(blocking) functions from this module in the function given to +withDependencies. If you do so, a deadlock will occur. + +-} +withDependencies :: Loadable c t t' => Criterion c t -> Module -> (Maybe [Module] -> Effective c t) -> Effective c t +withDependencies crit from f + = withNameEnv crit env (\(_,_,_,_,_,deph,_) -> lookupHT deph from >>= f) + +{-| + +Load a module (or package) and modules it depends on. It is possible +to load a module many times without any error occuring. However to +unload a module one needs to call @unloadModule@ the same number of +times. + +Before loading any modules you should add wich dependencies it has +with addDependency (and which dependencies the modules upon which it +depends have). + +If the module already has been loaded nothing will be done except +updating the reference count. I.e. if dependencies have been updated +they will be ignored until the module has been completely unloaded and +loaded again. + +It treats names begining with uppercase letters (such as @Foo.Bar@) as +modules and other names (such as @base@) as packages. + +If any error occurs an exception is thrown. + +-} +loadModule :: Module -> IO LoadedModule +loadModule m + = do withNameEnv UnsafeCriterion env (\env -> do loadModuleWithDep m env + DL.resolveFunctions + return (LM m)) + +loadModuleWithDep :: Module -> NameEnvData -> IO () +loadModuleWithDep name + env@(_, _, _, _, _, _, modh) + = do msm <- HT.lookup modh name + (sm, depmods) <- midLoadModule msm name env + + insertHT modh name sm + + mapM_ (\modwt -> loadModuleWithDep modwt env) depmods + +midLoadModule :: Maybe NameModule -> Module -> NameEnvData -> + IO (NameModule, NameDep) +midLoadModule (Just sm) _ _ = return $ (sm { sm_refc = sm_refc sm + 1 }, + sm_deps sm) +midLoadModule Nothing name env@(_, _, _, _, _, deph, _) + = do (sd, time) <- lowLoadModule (nameToMWT name) env + depmods <- lookupDefHT deph [] name + return (SM 1 time depmods sd, depmods) + +lowLoadModule :: ModuleWT -> NameEnvData -> IO (NameDynamics, UTCTime) +lowLoadModule (name, MT_Package) (_, _, ppath, ppre, psuff, _, _) + = do lp <- DL.loadPackage name ppath ppre psuff + time <- getModificationTime (DL.dp_path lp) + return (Right lp, time) +lowLoadModule (name, MT_Module) (mpath, msuff, _, _, _, _, _) + = do lm <- DL.loadModule name mpath msuff + time <- getModificationTime (DL.dm_path lm) + return (Left lm, time) + +{-| + +Unload a module and all modules it depends on. This unloading only +occurs if the module isn't needed by any other libraries or hasn't +been loaded more than once. An exception is thrown in case of error. + +-} +unloadModule :: LoadedModule -> IO () +unloadModule (LM name) + = withNameEnv UnsafeCriterion env (unloadModuleWithDep name) + +{-| + +Same as @unloadModule@ just doesn't trow any exceptions on error. + +-} +unloadModuleQuiet :: LoadedModule -> IO () +unloadModuleQuiet (LM name) + = withNameEnv UnsafeCriterion env (\env -> catch (unloadModuleWithDep name env) + (\(_ :: SomeException) -> return ())) + +unloadModuleWithDep :: Module -> NameEnvData -> IO () +unloadModuleWithDep name env@(_, _, _, _, _, _, modh) + = do msm <- lookupHT modh name + sm <- maybe (fail $ "Module " ++ name ++ " not loaded") + return msm + + if sm_refc sm > 1 + then do insertHT modh name (sm { sm_refc = sm_refc sm - 1 }) + else do lowUnloadModule (sm_module sm) + deleteHT modh name + + mapM_ (\m -> unloadModuleWithDep m env) (sm_deps sm) + +lowUnloadModule :: NameDynamics -> IO () +lowUnloadModule (Left lm) = DL.unloadModule lm +lowUnloadModule (Right lp) = DL.unloadPackage lp + +{-| + +Load a function from a module. It cannot load functions from packages +and will throw an exception if one tries to do so. Also throws if an +error occurs. + +It seems (but I'm unsure) like any functions loaded will continue to +be valid even after the module it resides in is unloaded. It will also +still be valid if a new version of that module is loaded (it will thus +still call the old function). + +-} +loadFunction :: Loadable c t t' => Criterion c t -> LoadedModule -> String -> Effective c t +loadFunction crit (LM m) name + = withNameEnv crit env (loadFunction' (nameToMWT m) name) + where loadFunction' (_, MT_Package) _ _ = fail "Cannot load functions from packages" + loadFunction' (mname, _) fname (_, _, _, _, _, _, modh) + = do msm <- HT.lookup modh mname + sm <- maybe (fail $ "Module " ++ mname ++ " isn't loaded") + return msm + let Left dm = sm_module sm + DL.loadFunction dm fname + + +{-| + +Give the modification time for a loded module. Will throw an exception +if the module isn't loaded. + +-} +moduleLoadedAt :: LoadedModule -> IO UTCTime +moduleLoadedAt (LM m) + = withNameEnvNB env (moduleLoadedAt' m) + +moduleLoadedAt' :: Module -> NameEnvData -> IO UTCTime +moduleLoadedAt' name (_, _, _, _, _, _, modh) + = do msm <- HT.lookup modh name + sm <- maybe (fail $ "Module " ++ name ++ " not loaded") + return msm + return (sm_time sm) + +loadedModules :: IO [String] +loadedModules = withNameEnvNB env loadedModules' + +loadedModules' :: NameEnvData -> IO [String] +loadedModules' (_, _, _, _, _, _, modh) + = HT.toList modh >>= (\lst -> return (map fst lst)) + +-- Some helper functions + +sm_path :: NameModule -> FilePath +sm_path sm = case sm_module sm of + Left dm -> DL.dm_path dm + Right dp -> DL.dp_path dp + +nameToMWT :: String -> ModuleWT +nameToMWT (c:cs) + | isUpper c = (c:cs, MT_Module) + | otherwise = (c:cs, MT_Package) +nameToMWT _ = error "empty module names not allowed" + +-- functions to handle HashTables in a better way + +-- it seems like it doesn't replace the old value on insert +insertHT :: (Eq key, Hashable key) => HT.BasicHashTable key val -> key -> val -> IO () +insertHT ht key val + = do HT.delete ht key + HT.insert ht key val + +insertHT_C :: (Eq key, Hashable key) => (val -> val -> val) -> HT.BasicHashTable key val -> key -> val -> IO () +insertHT_C func ht key val + = do mval <- HT.lookup ht key + case mval of + Just val' -> insertHT ht key (func val val') + Nothing -> insertHT ht key val + +modifyHT :: (Eq key, Hashable key) => (val -> val) -> HT.BasicHashTable key val -> key -> IO () +modifyHT func ht key + = do mval <- HT.lookup ht key + case mval of + Just val -> insertHT ht key (func val) + Nothing -> return () + +lookupHT :: (Eq key, Hashable key) => HT.BasicHashTable key val -> key -> IO (Maybe val) +lookupHT ht key = HT.lookup ht key + +deleteHT :: (Eq key, Hashable key) => HT.BasicHashTable key val -> key -> IO () +deleteHT ht key = HT.delete ht key + +lookupDefHT :: (Eq key, Hashable key) => HT.BasicHashTable key b -> b -> key -> IO b +lookupDefHT ht val key + = do mval <- HT.lookup ht key + case mval of + Just val -> return val + Nothing -> return val diff --git a/System/Plugins/PathLoader.hs b/System/Plugins/PathLoader.hs new file mode 100644 --- /dev/null +++ b/System/Plugins/PathLoader.hs @@ -0,0 +1,365 @@ +---------------------------------------------------------------------------- +-- | +-- Module : PathLoader +-- Copyright : (c) Hampus Ram 2004, Gabor Greif 2012 +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : ggreif+dynamic@gmail.com +-- Stability : experimental +-- Portability : non-portable (ghc >= 7.6 only) +-- +-- A module that implements dynamic loading. +-- Has smart handling of dependencies and +-- is thread safe. +-- +---------------------------------------------------------------------------- +{-# LANGUAGE ScopedTypeVariables, ConstraintKinds #-} + +module System.Plugins.PathLoader (LoadedModule, + ModuleType (..), + setBasePath, + addDependency, + setDependencies, + delDependency, + delAllDeps, + withDependencies, + loadModule, + unloadModule, + unloadModuleQuiet, + loadFunction, + loadQualifiedFunction, + moduleLoadedAt, + loadedModules, + DL.addDLL) where + +import Control.Concurrent.MVar +import Data.List +import qualified Data.HashTable.IO as HT +import Data.Hashable +import Data.IORef +import System.IO.Unsafe +import System.Directory +import Data.Time +import Control.Exception (catch, SomeException) +import System.Plugins.Criteria.LoadCriterion +import System.Plugins.Criteria.UnsafeCriterion + +import qualified System.Plugins.DynamicLoader as DL + +type Loadable c t t' = (LoadCriterion c t, Effective c t ~ IO t') + +data LoadedModule = LM FilePath ModuleType + +data ModuleType = MT_Module + | MT_Package + deriving (Eq, Ord, Show) + +type ModuleWT = (ModuleType, FilePath) + +type PathDynamics = Either DL.DynamicModule DL.DynamicPackage + +type PathDep = [ModuleWT] + +-- PM reference_count type time module +data PathModule = PM { pm_refc :: !Int, + pm_time :: UTCTime, + pm_deps :: PathDep, + pm_module :: PathDynamics } + + +-- base_path dependency_map modules +type PathEnvData = (Maybe FilePath, + HT.BasicHashTable String [ModuleWT], + HT.BasicHashTable String PathModule) + + +{- + + New PathEnv that uses both an IORef and a MVar + to make it possible to have non blocking functions + that inspect the state. + +-} +type PathEnv = (MVar (), IORef PathEnvData) + +withPathEnv :: Loadable c t t' => Criterion c t -> PathEnv -> (PathEnvData -> Effective c t) -> Effective c t +withPathEnv _ (mvar, ioref) f + = withMVar mvar (\_ -> readIORef ioref >>= f) + +withPathEnvNB :: PathEnv -> (PathEnvData -> IO b) -> IO b +withPathEnvNB (_, ioref) f = readIORef ioref >>= f + +modifyPathEnv_ :: PathEnv -> (PathEnvData -> IO PathEnvData) -> IO () +modifyPathEnv_ (mvar, ioref) f + = withMVar mvar (\_ -> readIORef ioref >>= f >>= writeIORef ioref) + +{-# NOINLINE env #-} +env :: PathEnv +env = unsafePerformIO (do modh <- HT.new + deph <- HT.new + mvar <- newMVar () + ioref <- newIORef (Nothing, deph, modh) + return (mvar, ioref)) + +{-| + +Set the base path used in figuring out module names. If not set the default +(i.e. currentDirectory) will be used. + +-} +setBasePath :: Maybe FilePath -> IO () +setBasePath mpath + = modifyPathEnv_ env (\(_, deph, modh) -> return (mpath, deph, modh)) + + +{-| + +Add a module dependency. Any dependencies must be added /before/ any +calls to loadModule\/loadPackage or symbols will not be resolved with a +crash as result. + +-} +addDependency :: FilePath -> (ModuleType, FilePath) -> IO () +addDependency from to = withPathEnv UnsafeCriterion env (addDependency' from to) + +addDependency' :: FilePath -> (ModuleType, FilePath) -> PathEnvData -> IO () +addDependency' from to (_, deph, _) + = insertHT_C union deph from [to] + +{-| + +Set all dependencies. All previous dependencies are removed. + +-} + +setDependencies :: FilePath -> [(ModuleType, FilePath)] -> IO () +setDependencies from to = withPathEnv UnsafeCriterion env (setDependencies' from to) + +setDependencies' :: FilePath -> [(ModuleType, FilePath)] -> + PathEnvData -> IO () +setDependencies' from to (_, deph, _) + = insertHT deph from to + +{-| + +Delete a module dependency. + +-} +delDependency :: FilePath -> (ModuleType, FilePath) -> IO () +delDependency from to = withPathEnv UnsafeCriterion env (delDependency' from to) + +delDependency' :: FilePath -> (ModuleType, FilePath) -> PathEnvData -> IO () +delDependency' from to (_, deph, _) + = modifyHT (\\[to]) deph from + +{-| + +Delete all dependencies for a module. Same behaviour as +@setDependencies path []@. + +-} + +delAllDeps :: FilePath -> IO () +delAllDeps from = withPathEnv UnsafeCriterion env (delAllDeps' from) + +delAllDeps' :: FilePath -> PathEnvData -> IO () +delAllDeps' from (_, deph, _) + = deleteHT deph from + +{-| + +Do something with the current dependencies of a module. You can't use +(blocking) functions from this module in the function given to +withDependencies. If you do so, a deadlock will occur. + +-} +withDependencies :: Loadable c t t' => Criterion c t -> FilePath + -> (Maybe [(ModuleType, FilePath)] -> Effective c t) -> Effective c t +withDependencies crit from f + = withPathEnv crit env (\(_,deph,_) -> lookupHT deph from >>= f) + +{-| + +Load a module (or package) and modules (or packages) it depends on. It +is possible to load a module many times without any error +occuring. However to unload a module one needs to call @unloadModule@ +the same number of times. + +Before loading any modules you should add wich dependencies it has +with addDependency (and which dependencies the modules upon which it +depends have). + +If the module already has been loaded nothing will be done except +updating the reference count. I.e. if dependencies have been updated +they will be ignored until the module has been completely unloaded and +loaded again. + +If any error occurs an exception is thrown. + +-} +loadModule :: FilePath -> ModuleType -> IO LoadedModule +loadModule m mt + = do withPathEnv UnsafeCriterion env (\env -> do loadModuleWithDep (mt, m) env + DL.resolveFunctions + return (LM m mt)) + +loadModuleWithDep :: (ModuleType, FilePath) -> PathEnvData -> IO () +loadModuleWithDep nwt@(_, name) env@(_, _, modh) + = do mpm <- lookupHT modh name + (pm, depmods) <- midLoadModule mpm nwt env + + insertHT modh name pm + + mapM_ (\modwt -> loadModuleWithDep modwt env) depmods + +midLoadModule :: Maybe PathModule -> (ModuleType, FilePath) -> + PathEnvData -> IO (PathModule, PathDep) +midLoadModule (Just pm) _ _ = return $ (pm { pm_refc = pm_refc pm + 1 }, + pm_deps pm) +midLoadModule Nothing nwt@(_, name) env@(_, deph, _) + = do (sd, time) <- lowLoadModule nwt env + depmods <- lookupDefHT deph [] name + return (PM 1 time depmods sd, depmods) + +lowLoadModule :: ModuleWT -> PathEnvData -> IO (PathDynamics, UTCTime) +lowLoadModule (MT_Package, name) (_, _, _) + = do lp <- DL.loadPackageFromPath name + time <- getModificationTime (DL.dp_path lp) + return (Right lp, time) +lowLoadModule (MT_Module, name) (mpath, _, _) + = do lm <- DL.loadModuleFromPath name mpath + time <- getModificationTime (DL.dm_path lm) + return (Left lm, time) + +{-| + +Unload a module and all modules it depends on. This unloading only +occurs if the module isn't needed by any other libraries or hasn't +been loaded more than once. An exception is thrown in case of error. + +-} +unloadModule :: LoadedModule -> IO () +unloadModule (LM name _) + = withPathEnv UnsafeCriterion env (unloadModuleWithDep name) + +{-| + +Same as @unloadModule@ just doesn't trow any exceptions on error. + +-} +unloadModuleQuiet :: LoadedModule -> IO () +unloadModuleQuiet (LM name _) + = withPathEnv UnsafeCriterion env (\env -> catch (unloadModuleWithDep name env) + (\(_ :: SomeException) -> return ())) + +unloadModuleWithDep :: FilePath -> PathEnvData -> IO () +unloadModuleWithDep name env@(_, _, modh) + = do mpm <- lookupHT modh name + pm <- maybe (fail $ "Module " ++ name ++ " not loaded") + return mpm + + if pm_refc pm > 1 + then do insertHT modh name (pm { pm_refc = pm_refc pm - 1 }) + else do lowUnloadModule (pm_module pm) + deleteHT modh name + + mapM_ (\(_, m) -> unloadModuleWithDep m env) (pm_deps pm) + +lowUnloadModule :: PathDynamics -> IO () +lowUnloadModule (Left lm) = DL.unloadModule lm +lowUnloadModule (Right lp) = DL.unloadPackage lp + +{-| + +Load a function from a module. It cannot load functions from packages +and will throw an exception if one tries to do so. Also throws if an +error occurs. + +It seems (but I'm unsure) like any functions loaded will continue to +be valid even after the module it resides in is unloaded. It will also +still be valid if a new version of that module is loaded (it will thus +still call the old function). + +-} +loadFunction :: Loadable c t t' => Criterion c t -> LoadedModule -> String -> Effective c t +loadFunction crit (LM m MT_Module) name + = withPathEnv crit env (loadFunction' m name) + where loadFunction' mname fname (_, _, modh) + = do mpm <- HT.lookup modh mname + pm <- maybe (fail $ "Module " ++ mname ++ " isn't loaded") + return mpm + let Left dm = pm_module pm + DL.loadFunction dm fname + +loadFunction _ _ _ = fail "You cannot load functions from a package." + +{-| + +Load a qualified function from a module or package. It will throw an +exception if an error occurs. Same restriction as for +DynamicLinker.loadQualifiedFunction applies here too. + +-} +loadQualifiedFunction :: Loadable c t t' => Criterion c t -> String -> Effective c t +loadQualifiedFunction crit name + = withPathEnv crit env (loadQualifiedFunction' name) + where loadQualifiedFunction' qname _ = DL.loadQualifiedFunction qname + + +{-| + +Give the modification time for a loded module. Will throw an exception +if the module isn't loaded. + +-} +moduleLoadedAt :: LoadedModule -> IO UTCTime +moduleLoadedAt (LM m _) + = withPathEnvNB env (moduleLoadedAt' m) + +moduleLoadedAt' :: FilePath -> PathEnvData -> IO UTCTime +moduleLoadedAt' name (_, _, modh) + = do mpm <- HT.lookup modh name + pm <- maybe (fail $ "Module " ++ name ++ " not loaded") + return mpm + return (pm_time pm) + +loadedModules :: IO [String] +loadedModules = withPathEnvNB env loadedModules' + +loadedModules' :: PathEnvData -> IO [String] +loadedModules' (_, _, modh) = HT.toList modh >>= (\lst -> return (map fst lst)) + +-- functions to handle HashTables in a better way + +-- it seems like it doesn't replace the old value on insert +insertHT :: (Eq key, Hashable key) => HT.BasicHashTable key val -> key -> val -> IO () +insertHT ht key val + = do HT.delete ht key + HT.insert ht key val + +insertHT_C :: (Eq key, Hashable key) => (val -> val -> val) -> HT.BasicHashTable key val -> key -> val -> IO () +insertHT_C func ht key val + = do mval <- HT.lookup ht key + case mval of + Just val' -> insertHT ht key (func val val') + Nothing -> insertHT ht key val + +modifyHT :: (Eq key, Hashable key) => (val -> val) -> HT.BasicHashTable key val -> key -> IO () +modifyHT func ht key + = do mval <- HT.lookup ht key + case mval of + Just val -> insertHT ht key (func val) + Nothing -> return () + +lookupHT :: (Eq key, Hashable key) => HT.BasicHashTable key val -> key -> IO (Maybe val) +lookupHT ht key = HT.lookup ht key + +deleteHT :: (Eq key, Hashable key) => HT.BasicHashTable key val -> key -> IO () +deleteHT ht key = HT.delete ht key + +lookupDefHT :: (Eq key, Hashable key) => HT.BasicHashTable key b -> b -> key -> IO b +lookupDefHT ht val key + = do mval <- HT.lookup ht key + case mval of + Just val -> return val + Nothing -> return val diff --git a/dynamic-loader.cabal b/dynamic-loader.cabal new file mode 100644 --- /dev/null +++ b/dynamic-loader.cabal @@ -0,0 +1,79 @@ +-- dynamic-loader.cabal auto-generated by cabal init. For additional +-- options, see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: dynamic-loader + +-- The package version. See the Haskell package versioning policy +-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for +-- standards guiding when and how versions should be incremented. +Version: 0.0 + +Synopsis: lightweight loader of GHC-based modules or packages + +Description: This package allows the linking against GHC-compiled + object files and shared libraries. Specialized modules + are provided for navigating directory structure and + dependency checking. + . + No attempt at type-safe loading of symbols is made. + +-- URL for the project homepage or repository. +Homepage: https://github.com/ggreif/dynamic-loader +Bug-reports: https://github.com/ggreif/dynamic-loader/issues + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Hampus Ram + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: Gabor Greif + +-- A copyright notice. +Copyright: Copyright (c) 2003-2004, Hampus Ram + Copyright (c) 2012-2013, Gabor Greif + +Category: System + +Stability: experimental +Tested-with: GHC == 7.6.1 + +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +-- Extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >= 1.6 + +Library + -- Modules exported by the library. + Exposed-modules: System.Plugins.DynamicLoader, System.Plugins.PathLoader, System.Plugins.NameLoader + System.Plugins.Criteria.LoadCriterion, System.Plugins.Criteria.UnsafeCriterion + + Extensions: CPP, ForeignFunctionInterface, MagicHash, ScopedTypeVariables, UnboxedTuples + KindSignatures, TypeFamilies, MultiParamTypeClasses, FlexibleInstances + -- ConstraintKinds + + -- Packages needed in order to build this package. + Build-depends: base >= 4.5 && < 5, directory, time, ghc-prim >= 0.2, + hashable, hashtables, transformers + + -- Modules not exported by this package. + -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: + + Ghc-Options: -Wall + +Source-repository head + type: git + location: git://github.com/ggreif/dynamic-loader.git