Hi all,
I'm working on how to dynamic loading library into *running* program.
I can dynamic loading/update module into *running* program if have *new*
package installed.
Example, when program *startup* and loading package foo-0.0.1 with function :
api :: String -> String
api =
reverse
then, i change `api` and install by foo-0.0.2:
api :: String -> String
api =
show . length
and dynamic-linking foo-0.0.2 works fine, i change api's value in
*runtime*.
And problem is, my solution just work when you install *new* package in
Cabal/GHC database (foo-0.0.1 => foo-0.0.2),
if i just change `api` value and don't install *new* package, my code can't
work.
I use Linker.linkPackages and Linker.getHValue to get symbol value, but
looks Linker.getHValue can't get *update* value once current package has
linked in memory.
So how to make Linker.getHValue can get *update* value and don't need
install *new* package in Cabal/GHC database?
How to *reload* module with current version package?
Or any GHC-API missing?
Below is my source code, you just need look function `load`.
Thanks! :)
-- Andy
------------------------------> source code start <------------------------------
module System.Dynload (
PackageVersion (..),
dynload
) where
import Control.Monad (forM_)
import Data.IORef
import GHC.Paths (libdir)
import MonadUtils (liftIO)
import Data.List
import Data.Ord
import Distribution.Package
import qualified DynFlags
import qualified Exception
import qualified GHC
import qualified HscTypes
import qualified IOEnv
import qualified Linker
import qualified LoadIface
import qualified Maybes
import qualified Module
import qualified Name
import qualified OccName
import qualified Outputable
import qualified PackageConfig as PC
import qualified Packages
import qualified SrcLoc
import qualified TcRnTypes
import qualified UniqSupply
import qualified Unique
data PackageVersion = Newest
| Version String
deriving (Ord, Show, Eq)
dynload :: (String, PackageVersion, String, [(String, Linker.HValue -> IO ())]) -> IO ()
dynload (packageName, packageVersion, moduleName, loadList) =
GHC.defaultErrorHandler DynFlags.defaultDynFlags $
GHC.runGhc (Just libdir) $ do
-- Update Flags of session.
sessionFlags <- GHC.getSessionDynFlags
GHC.setSessionDynFlags sessionFlags -- this is ncessary, otherwise get GHC error
-- Initialise package information.
(flags, _) <- liftIO $ Packages.initPackages sessionFlags
-- Search packages that export modules.
let packages = map fst
$ filter snd
$ Packages.lookupModuleInAllPackages flags (Module.mkModuleName moduleName)
exportError pName mName =
"# Package " ++ pName ++ " not exist or not export module " ++ mName
result =
case packages of
[] -> Left $ "# No package export module : " ++ moduleName
_ ->
let matchPackages = filter (\x -> packageConfigName x == packageName) packages
in case matchPackages of
[] -> Left $ exportError packageName moduleName
_ ->
case packageVersion of
Version pv ->
let pName = packageName ++ "-" ++ pv
versions = map packageConfigVersion matchPackages
in if pv `elem` versions
then Right pName
else Left $ exportError pName moduleName
Newest ->
case findNewestPackage matchPackages of
Nothing ->
Left "# dynload : Impossible reach here"
Just packageConfig ->
Right $ packageConfigIdString packageConfig
case result of
Left err ->
liftIO $ putStrLn err
Right packageNameStr -> do
liftIO $ putStrLn $ "* Use package : " ++ packageNameStr
-- Initialise the dynamic linker.
liftIO $ Linker.initDynLinker flags
hscEnv <- GHC.getSession
forM_ loadList $ \ (symbolName, loadFun) -> do
-- Because symbol perhaps re-export from external module.
-- So we need parse symbol to find define location.
parseResult <- liftIO $ parseSymbol (packageNameStr, moduleName, symbolName) hscEnv flags
case parseResult of
Just args -> load args flags loadFun
Nothing -> return ()
-- | Internal load function for pdynload.
load :: (GHC.GhcMonad m)
=> (String, String, String)
-> GHC.DynFlags
-> (Linker.HValue -> IO ())
-> m ()
load (packageName, moduleName, symbolName) flags loadFun =
Exception.ghandle
(\(GHC.CmdLineError _) ->
-- Catch package error.
liftIO $ putStrLn $ "# Unknown package " ++ packageName)
(do
-- Debug code.
-- liftIO $ Linker.showLinkerState
-- Link exactly the specified packages, and their dependents
-- (unless of course they are already linked).
-- The dependents are linked automatically,
-- and it doesn't matter what order you specify the input packages.
let packageId = Module.stringToPackageId packageName
liftIO $ Linker.linkPackages flags [packageId]
Exception.ghandle
(\(GHC.ProgramError err) -> liftIO $ putStrLn $ "# " ++ err)
(do
liftIO $ putStrLn $ "* Linking " ++ packageName ++ ":" ++ moduleName ++ "." ++ symbolName ++ " ..."
-- Get current session.
session <- GHC.getSession
-- Create a name which definitely originates in the given module.
let name = Name.mkExternalName
(Unique.mkBuiltinUnique 0)
(Module.mkModule packageId
(Module.mkModuleName moduleName))
(OccName.mkVarOcc symbolName)
SrcLoc.noSrcSpan
-- Get the HValue associated with the given name.
-- May cause loading the module that contains the name.
result <- liftIO $ Linker.getHValue session name
liftIO $ loadFun result))
-- | Parse symbol whether defined in current module.
-- If symbol is re-export other module, parse recursively,
-- until found the define location of symbol.
parseSymbol :: (String, String, String)
-> HscTypes.HscEnv
-> GHC.DynFlags
-> IO (Maybe (String, String, String))
parseSymbol (packageName, moduleName, symbolName) hscEnv flags = do
putStrLn $ "* Parse " ++ packageName ++ ":" ++ moduleName ++ "." ++ symbolName ++ " ..."
-- Build unique supply to build environment.
uniqueSupply <- UniqSupply.mkSplitUniqSupply 'a'
uniqueSupplyIORef <- newIORef uniqueSupply
-- Initialise.
let packageId = Module.stringToPackageId packageName
module' = Module.mkModule packageId $ Module.mkModuleName moduleName
environment = TcRnTypes.Env {
TcRnTypes.env_top = hscEnv,
TcRnTypes.env_us = uniqueSupplyIORef,
TcRnTypes.env_gbl = (),
TcRnTypes.env_lcl = ()}
-- Find and read interface file.
iface <- IOEnv.runIOEnv environment
$ LoadIface.findAndReadIface Outputable.empty module' False
case iface of
-- Return Nothing if can't found interface file.
Maybes.Failed _ -> do
putStrLn $ "# Can't found interface file of " ++ packageName ++ ":" ++ moduleName ++ "." ++ symbolName
return Nothing
-- Parse symbol.
Maybes.Succeeded (moduleInterface, hiFile) -> do
putStrLn $ "* Scan interface file " ++ hiFile ++ " ..."
-- Export list of current module
let ifaceExport = HscTypes.mi_exports moduleInterface
-- [(ModuleName, [type])]
exports = map (\ (mod, items) ->
(Module.moduleNameString $ Module.moduleName mod
,concatMap (\item ->
case item of
HscTypes.Avail name -> [OccName.occNameString name]
HscTypes.AvailTC _ list ->
map OccName.occNameString list
) items)
) ifaceExport
-- Partition current module and external module.
(currentExports, otherExports) = partition (\ (mName, _) -> mName == moduleName) exports
case findSymbolInExportList currentExports symbolName of
-- Return current module if found symbol in export list of current module.
Just _ -> do
putStrLn $ "* '" ++ symbolName ++ "' defined in " ++ packageName ++ ":" ++ moduleName
return $ Just (packageName, moduleName, symbolName)
Nothing ->
-- Parse recursively if symbol is re-export from external module.
case findSymbolInExportList otherExports symbolName of
Just mn -> do
putStrLn $ "* '" ++ symbolName ++ "' is re-export from module " ++ mn
-- Lookup new package of external module.
newPackageName <- do
putStrLn $ "* Lookup package of module " ++ mn
lookupPackageName flags mn
case newPackageName of
-- Parse symbol in new package.
Just npn -> parseSymbol (npn, mn, symbolName) hscEnv flags
-- Return Nothing if package not found.
Nothing -> return Nothing
-- Return Nothing if can't found symbol in interface file.
-- If reach this, interface file is incorrect.
Nothing -> do
putStrLn $ "# Can't found symbol " ++ symbolName ++ " in " ++ hiFile
return Nothing
-- | Lookup package name from ghc database.
lookupPackageName :: DynFlags.DynFlags -> String -> IO (Maybe String)
lookupPackageName flags moduleName
-- Return Nothing when no package found.
| packageNum == 0
= do
putStrLn $ "# Can't found module " ++ show moduleName
return Nothing
| packageNum == 1
= do
let (packageConfig, isExpose) = head packages
pName = packageConfigIdString packageConfig
if isExpose
-- Return package name when package expose module.
then return $ Just pName
-- Return Nothing if module hide in package.
else do
putStrLn $ "# Module " ++ show moduleName ++ " hide in package " ++ pName
return Nothing
-- Return Nothing if no package expose module.
| null exposePackages
= do
putStrLn $ "# Can't found module " ++ show moduleName
return Nothing
-- Return first match package when found module in multiple packages.
| otherwise
=
case findNewestPackage exposePackages of
Nothing -> do
putStrLn "# lookupPackageName: Impossible reach here"
return Nothing
Just packageConfig -> do
let pName = packageConfigIdString packageConfig
putStrLn $ "# Module " ++ moduleName ++ " expose in multiple packages."
putStrLn $ "* Use package : " ++ pName
return $ Just pName
where packages -- search package that *contain* module.
= Packages.lookupModuleInAllPackages flags (Module.mkModuleName moduleName)
packageNum -- length of package list
= length packages
exposePackages -- filter package that *export* module
= map fst $ filter snd packages
-- | Find symbol in export list of module.
-- Return module name when found symbol in export list.
-- Otherwise return Nothing.
findSymbolInExportList :: Eq b => [(a, [b])] -> b -> Maybe a
findSymbolInExportList [] _ = Nothing
findSymbolInExportList ((moduleName, symList) :xs) sym
| sym `elem` symList
= Just moduleName
| otherwise
= findSymbolInExportList xs sym
-- | Get PackageConfig id string.
packageConfigIdString :: PC.PackageConfig -> String
packageConfigIdString = Module.packageIdString . PC.packageConfigId
-- | The package name of PC.
packageConfigName :: PC.PackageConfig -> String
packageConfigName packageConfig = packageName
where (PackageName packageName) =
PC.pkgName $ PC.sourcePackageId packageConfig
-- | The package version of PC.
packageConfigVersion :: PC.PackageConfig -> String
packageConfigVersion =
showVersion . PC.versionBranch . PC.pkgVersion . PC.sourcePackageId
-- | Find newest package.
findNewestPackage :: [PC.PackageConfig] -> Maybe PC.PackageConfig
findNewestPackage [] = Nothing
findNewestPackage [a] = Just a
findNewestPackage xs = Just $ maximumBy (comparing (PC.pkgVersion . PC.sourcePackageId)) xs
-- | Convert version [x,y,z] to "x.y.z".
showVersion :: [Int] -> String
showVersion [] = ""
showVersion [x] = show x
showVersion (x:xs) =
(show x ++ ".") ++ showVersion xs
------------------------------> source code end <------------------------------
