diff --git a/System/Plugins/DynamicLoader.hs b/System/Plugins/DynamicLoader.hs --- a/System/Plugins/DynamicLoader.hs +++ b/System/Plugins/DynamicLoader.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} +{-# LANGUAGE MagicHash, UnboxedTuples #-} ---------------------------------------------------------------------------- -- | -- Module : DynamicLoader @@ -17,6 +17,8 @@ dm_path, DynamicPackage, dp_path, + DynamicArchive, + da_path, addDLL, @@ -24,8 +26,10 @@ loadModuleFromPath, loadPackage, loadPackageFromPath, + loadArchiveFromPath, unloadModule, unloadPackage, + unloadArchive, loadFunction, loadQualifiedFunction, resolveFunctions) where @@ -39,6 +43,7 @@ import Foreign.C.String (CString, withCString, peekCString) import System.Directory (getCurrentDirectory, doesFileExist) import GHC.Prim +import System.Info (os) {- @@ -46,12 +51,18 @@ -} +foreign import ccall unsafe "initLinker" + c_initLinker :: IO () + foreign import ccall unsafe "loadObj" c_loadObj :: CString -> IO Int foreign import ccall unsafe "unloadObj" c_unloadObj :: CString -> IO Int +foreign import ccall unsafe "loadArchive" + c_loadArchive :: CString -> IO Int + foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Int @@ -68,6 +79,9 @@ data DynamicPackage = RTP { dp_path :: FilePath, dp_cbits :: Maybe DynamicPackage } + +newtype DynamicArchive = RTA { da_path :: FilePath } + {-| Dynamically load a shared library (DLL or .so). A shared library can't @@ -77,7 +91,9 @@ -} addDLL :: String -> IO () -addDLL str = withCString str +addDLL str + = do c_initLinker + withCString str (\s -> do err <- c_addDLL s unless (err == nullPtr) (do msg <- peekCString err @@ -106,8 +122,10 @@ -} loadModule :: String -> Maybe FilePath -> Maybe String -> IO DynamicModule loadModule name mpath msuff - = do base <- maybe getCurrentDirectory return mpath + = do c_initLinker + base <- maybe getCurrentDirectory return mpath + let qname = split '.' name suff = maybe "o" id msuff path = base ++ '/' : concat (intersperse "/" qname) ++ @@ -134,7 +152,8 @@ -} loadModuleFromPath :: FilePath -> Maybe FilePath -> IO DynamicModule loadModuleFromPath path mbase - = do base <- maybe getCurrentDirectory return mbase + = do c_initLinker + base <- maybe getCurrentDirectory return mbase qual <- dropIsEq base path @@ -183,7 +202,8 @@ loadPackage :: String -> Maybe FilePath -> Maybe String -> Maybe String -> IO DynamicPackage loadPackage name mpath mpre msuff - = do base <- case mpath of + = do c_initLinker + base <- case mpath of Just a -> return a _ -> getCurrentDirectory @@ -225,7 +245,8 @@ -} loadPackageFromPath :: FilePath -> IO DynamicPackage loadPackageFromPath path - = do ret <- withCString path c_loadObj + = do c_initLinker + ret <- withCString path c_loadObj unless (ret /= 0) (fail $ "Unable to load package: " ++ path) let cbits_path = cbitsName path @@ -247,13 +268,41 @@ {-| +Load an archive of GHC modules. Recent versions of GHC store packages +as archives. + +If it fails to load the archive it will throw an exception. You will +need to resolve functions before you use any functions loaded. + +-} +loadArchiveFromPath :: FilePath -> IO DynamicArchive +loadArchiveFromPath path + = do c_initLinker + ret <- withCString path c_loadArchive + unless (ret /= 0) (fail $ "Unable to load archive: " ++ path) + return (RTA path) + +{-| + +Unload an archive. Throws an exception if any unloading fails. + +-} +unloadArchive :: DynamicArchive -> IO () +unloadArchive (RTA { da_path = path }) + = do c_initLinker + ret <- withCString path c_unloadObj + unless (ret /= 0) (fail $ "Unable to unload archive: " ++ path) + +{-| + 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 + = do c_initLinker + ret <- withCString path c_unloadObj unless (ret /= 0) (fail $ "Unable to unload package: " ++ path) maybe (return ()) unloadPackage cbits @@ -265,7 +314,8 @@ -} unloadModule :: DynamicModule -> IO () unloadModule (RTM { dm_path = path }) - = do ret <- withCString path c_unloadObj + = do c_initLinker + ret <- withCString path c_unloadObj unless (ret /= 0) (fail $ "Unable to unload module: " ++ path) {-| @@ -279,7 +329,8 @@ -} loadFunction :: DynamicModule -> String -> IO a loadFunction dm functionName - = do Ptr addr <- lookupSymbol (dm_qname dm) functionName + = do c_initLinker + Ptr addr <- lookupSymbol (dm_qname dm) functionName case addrToAny# addr of (# hval #) -> return hval @@ -300,7 +351,8 @@ -} loadQualifiedFunction :: String -> IO a loadQualifiedFunction functionName - = do let qfunc = split '.' functionName + = do c_initLinker + let qfunc = split '.' functionName Ptr addr <- lookupSymbol (init qfunc) (last qfunc) case addrToAny# addr of (# hval #) -> return hval @@ -314,7 +366,8 @@ -} resolveFunctions :: IO () resolveFunctions - = do ret <- c_resolveObjs + = do c_initLinker + ret <- c_resolveObjs when (ret == 0) (fail "Unable to resolve functions!") {-| @@ -333,13 +386,8 @@ 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 + -- On OS X all functions have an extra _. + symbolName = (if os == "darwin" then "_" else "") ++ moduleName ++ "_" ++ realFunctionName ++ "_closure" encode :: String -> String encode str = concatMap encode_ch str diff --git a/dynamic-linker.pdf b/dynamic-linker.pdf new file mode 100644 Binary files /dev/null and b/dynamic-linker.pdf differ diff --git a/dynamic-loader.cabal b/dynamic-loader.cabal --- a/dynamic-loader.cabal +++ b/dynamic-loader.cabal @@ -1,13 +1,6 @@ --- 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 +Version: 0.0.1 Synopsis: lightweight loader of GHC-based modules or packages @@ -17,40 +10,35 @@ dependency checking. . No attempt at type-safe loading of symbols is made. + . + Release history: + . + [0.0] Initial version (testing Hackage build) + [0.0.1] Added support for archives. --- 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 +Copyright: Copyright (c) 2003-2004, Hampus Ram; + (c) 2012-2016, Gabor Greif Category: System Stability: experimental -Tested-with: GHC == 7.6.1 +Tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2 Build-type: Simple --- Extra files to be distributed with the package, such as examples or --- a README. --- Extra-source-files: +Data-files: dynamic-linker.pdf --- Constraint on the version of Cabal needed to build this package. Cabal-version: >= 1.6 Library @@ -60,7 +48,7 @@ Extensions: CPP, ForeignFunctionInterface, MagicHash, ScopedTypeVariables, UnboxedTuples KindSignatures, TypeFamilies, MultiParamTypeClasses, FlexibleInstances - -- ConstraintKinds + ConstraintKinds -- Packages needed in order to build this package. Build-depends: base >= 4.5 && < 5, directory, time, ghc-prim >= 0.2,