ghc/compiler/compMan/CmLink.lhs

   1 %
   2 % (c) The University of Glasgow, 2000
   3 %
   4 \section[CmLink]{Linker for GHCI}
   5
   6 \begin{code}
   7 module CmLink ( Linkable(..),  Unlinked(..),
   8                 filterModuleLinkables,
   9                 findModuleLinkable_maybe,
  10                 LinkResult(..),
  11                 updateClosureEnv,
  12                 link,
  13                 unload,
  14                 PersistentLinkerState{-abstractly!-}, emptyPLS,
  15 #ifdef GHCI
  16                 linkExpr
  17 #endif
  18   ) where
  19
  20
  21 import Interpreter
  22 import DriverPipeline
  23 import CmTypes
  24 import CmStaticInfo     ( GhciMode(..) )
  25 import Outputable       ( SDoc )
  26 import Digraph          ( SCC(..), flattenSCC )
  27 import Name             ( Name )
  28 import Module           ( ModuleName )
  29 import FiniteMap
  30 import Outputable
  31 import ErrUtils         ( showPass )
  32 import CmdLineOpts      ( DynFlags(..) )
  33 import Panic            ( panic, GhcException(..) )
  34
  35 import Exception
  36 import List
  37 import Monad
  38 import IO
  39
  40 #include "HsVersions.h"
  41 \end{code}
  42
  43 \begin{code}
  44 data PersistentLinkerState
  45    = PersistentLinkerState {
  46
  47
  48 #ifdef GHCI
  49         -- Current global mapping from RdrNames to closure addresses
  50         closure_env :: ClosureEnv,
  51
  52         -- the current global mapping from RdrNames of DataCons to
  53         -- info table addresses.
  54         -- When a new Unlinked is linked into the running image, or an existing
  55         -- module in the image is replaced, the itbl_env must be updated
  56         -- appropriately.
  57         itbl_env    :: ItblEnv,
  58
  59         -- list of objects we've loaded (we'll need to unload them again
  60         -- before re-loading the same module), together with the ClockTime
  61         -- of the linkable they were loaded from.
  62         objects_loaded :: [Linkable]
  63
  64         -- notionally here, but really lives in the C part of the linker:
  65         --            object_symtab :: FiniteMap String Addr
  66 #else
  67         dummy :: ()     --  sigh, can't have an empty record
  68 #endif
  69
  70      }
  71
  72 data LinkResult
  73    = LinkOK   PersistentLinkerState
  74    | LinkErrs PersistentLinkerState [SDoc]
  75
  76 findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable
  77 findModuleLinkable_maybe lis mod
  78    = case [LM time nm us | LM time nm us <- lis, nm == mod] of
  79         []   -> Nothing
  80         [li] -> Just li
  81         many -> pprPanic "findModuleLinkable" (ppr mod)
  82
  83
  84 emptyPLS :: IO PersistentLinkerState
  85 #ifdef GHCI
  86 emptyPLS = return (PersistentLinkerState { closure_env = emptyFM,
  87                                            itbl_env    = emptyFM,
  88                                            objects_loaded = [] })
  89 #else
  90 emptyPLS = return (PersistentLinkerState {})
  91 #endif
  92
  93 updateClosureEnv :: PersistentLinkerState -> [(Name,HValue)]
  94         -> IO PersistentLinkerState
  95 updateClosureEnv pls new_bindings
  96   = return pls{ closure_env = addListToFM (closure_env pls) new_bindings }
  97
  98 -----------------------------------------------------------------------------
  99 -- Unloading old objects ready for a new compilation sweep.
 100 --
 101 -- The compilation manager provides us with a list of linkables that it
 102 -- considers "stable", i.e. won't be recompiled this time around.  For
 103 -- each of the modules current linked in memory,
 104 --
 105 --      * if the linkable is stable (and it's the same one - the
 106 --        user may have recompiled the module on the side), we keep it,
 107 --
 108 --      * otherwise, we unload it.
 109 --
 110
 111 unload :: GhciMode
 112        -> DynFlags
 113        -> [Linkable]            -- stable linkables
 114        -> PersistentLinkerState
 115        -> IO PersistentLinkerState
 116
 117 unload Batch dflags linkables pls = return pls
 118
 119 #ifdef GHCI
 120 unload Interactive dflags linkables pls
 121   = do new_loaded <- filterM maybeUnload (objects_loaded pls)
 122        let mods_retained = map linkableModName new_loaded
 123            itbl_env'     = filterNameMap mods_retained (itbl_env pls)
 124            closure_env'  = filterNameMap mods_retained (closure_env pls)
 125
 126        let verb = verbosity dflags
 127        when (verb >= 3) $ do
 128             hPutStrLn stderr (showSDoc
 129                 (text "CmLink.unload: retaining" <+> ppr mods_retained))
 130
 131        return pls{ objects_loaded = new_loaded,
 132                    itbl_env = itbl_env',
 133                    closure_env = closure_env' }
 134   where
 135         maybeUnload :: Linkable -> IO Bool
 136         maybeUnload (LM time mod objs) = do
 137           case findModuleLinkable_maybe linkables mod of
 138                 Nothing -> do unloadObjs; return False
 139                 Just l | linkableTime l /= time -> do unloadObjs; return False
 140                        | otherwise              -> return True
 141           where
 142              unloadObjs = mapM unloadObj [ f | DotO f <- objs ]
 143 #else
 144 unload Interactive dflags linkables pls = panic "CmLink.unload: no interpreter"
 145 #endif
 146 -----------------------------------------------------------------------------
 147 -- Linking
 148
 149 link :: GhciMode                -- interactive or batch
 150      -> DynFlags                -- dynamic flags
 151      -> Bool                    -- attempt linking in batch mode?
 152      -> [Linkable]
 153      -> PersistentLinkerState
 154      -> IO LinkResult
 155
 156 -- For the moment, in the batch linker, we don't bother to tell doLink
 157 -- which packages to link -- it just tries all that are available.
 158 -- batch_attempt_linking should only be *looked at* in batch mode.  It
 159 -- should only be True if the upsweep was successful and someone
 160 -- exports main, i.e., we have good reason to believe that linking
 161 -- will succeed.
 162
 163 -- There will be (ToDo: are) two lists passed to link.  These
 164 -- correspond to
 165 --
 166 --      1. The list of all linkables in the current home package.  This is
 167 --         used by the batch linker to link the program, and by the interactive
 168 --         linker to decide which modules from the previous link it can
 169 --         throw away.
 170 --      2. The list of modules on which we just called "compile".  This list
 171 --         is used by the interactive linker to decide which modules need
 172 --         to be actually linked this time around (or unlinked and re-linked
 173 --         if the module was recompiled).
 174
 175 link mode dflags batch_attempt_linking linkables pls1
 176    = do let verb = verbosity dflags
 177         when (verb >= 3) $ do
 178              hPutStrLn stderr "CmLink.link: linkables are ..."
 179              hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
 180         res <- link' mode dflags batch_attempt_linking linkables pls1
 181         when (verb >= 3) $
 182              hPutStrLn stderr "CmLink.link: done"
 183         return res
 184
 185 link' Batch dflags batch_attempt_linking linkables pls1
 186    | batch_attempt_linking
 187    = do let o_files = concatMap getOfiles linkables
 188         when (verb >= 1) $
 189              hPutStrLn stderr "ghc: linking ..."
 190         -- don't showPass in Batch mode; doLink will do that for us.
 191         doLink o_files
 192         -- doLink only returns if it succeeds
 193         return (LinkOK pls1)
 194    | otherwise
 195    = do when (verb >= 3) $ do
 196             hPutStrLn stderr "CmLink.link(batch): upsweep (partially) failed OR"
 197             hPutStrLn stderr "   Main.main not exported; not linking."
 198         return (LinkOK pls1)
 199    where
 200       verb = verbosity dflags
 201       getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
 202
 203 link' Interactive dflags batch_attempt_linking linkables pls
 204     = do showPass dflags "Linking"
 205          let (objs, bcos) = partition (isObject.head.linkableUnlinked) linkables
 206          linkObjs (objs ++ bcos) pls
 207            -- get the objects first
 208
 209 ppLinkableSCC :: SCC Linkable -> SDoc
 210 ppLinkableSCC = ppr . flattenSCC
 211
 212 filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
 213 filterModuleLinkables p [] = []
 214 filterModuleLinkables p (li:lis)
 215    = case li of
 216         LM _ modnm _ -> if p modnm then retain else dump
 217      where
 218         dump   = filterModuleLinkables p lis
 219         retain = li : dump
 220
 221 -----------------------------------------------------------------------------
 222 -- Linker for interactive mode
 223
 224 #ifndef GHCI
 225 linkObjs      = panic "CmLink.linkObjs: no interpreter"
 226 lookupClosure = panic "CmLink.lookupClosure: no interpreter"
 227 #else
 228 linkObjs [] pls = linkFinish pls []
 229 linkObjs (l@(LM _ m uls) : ls) pls
 230    | all isObject uls = do
 231         if isLoaded l pls then linkObjs ls pls else do
 232         let objs = [ file | DotO file <- uls ]
 233         mapM_ loadObj objs
 234         linkObjs ls pls{objects_loaded = l : objects_loaded pls}
 235    | all isInterpretable uls  = linkInterpretedCode (l:ls) [] pls
 236    | otherwise                = invalidLinkable
 237
 238 isLoaded :: Linkable -> PersistentLinkerState -> Bool
 239 isLoaded l pls =
 240   case findModuleLinkable_maybe (objects_loaded pls) (linkableModName l) of
 241         Nothing -> False
 242         Just m  -> linkableTime l == linkableTime m
 243
 244 linkInterpretedCode [] ul_trees pls = linkFinish pls ul_trees
 245 linkInterpretedCode (l@(LM _ m uls) : ls) ul_trees pls
 246    | all isInterpretable uls =
 247         if isLoaded l pls then linkInterpretedCode ls ul_trees pls else
 248         linkInterpretedCode ls (uls++ul_trees)
 249                 pls{objects_loaded = l : objects_loaded pls}
 250    | any isObject uls
 251         = throwDyn (OtherError
 252              "can't link object code that depends on interpreted code")
 253    | otherwise = invalidLinkable
 254
 255 invalidLinkable = panic "CmLink: linkable doesn't contain entirely objects or interpreted code"
 256
 257
 258 -- link all the interpreted code in one go.
 259 linkFinish pls ul_bcos = do
 260    resolveObjs
 261
 262    let stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ]
 263
 264    (ibinds, new_itbl_env, new_closure_env) <-
 265         linkIModules (itbl_env pls) (closure_env pls) stuff
 266
 267    let new_pls = pls { closure_env = new_closure_env,
 268                        itbl_env    = new_itbl_env
 269                      }
 270    return (LinkOK new_pls)
 271
 272 linkExpr :: PersistentLinkerState -> UnlinkedBCOExpr -> IO HValue
 273 linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } bcos
 274   = linkIExpr ie ce bcos
 275 #endif
 276 \end{code}