packages feed

dynamic-loader (empty) → 0.0

raw patch · 8 files changed

+1284/−0 lines, 8 filesdep +basedep +directorydep +ghc-primsetup-changed

Dependencies added: base, directory, ghc-prim, hashable, hashtables, time, transformers

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/Plugins/Criteria/LoadCriterion.hs view
@@ -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"+
+ System/Plugins/Criteria/UnsafeCriterion.hs view
@@ -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
+ System/Plugins/DynamicLoader.hs view
@@ -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"
+ System/Plugins/NameLoader.hs view
@@ -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
+ System/Plugins/PathLoader.hs view
@@ -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
+ dynamic-loader.cabal view
@@ -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 <ggreif+dynamic@gmail.com>++-- 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