[Haskell-cafe] How to reload module that package has linked in memory?

[Andy Stewart]

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   <------------------------------