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                 link,
  12                 unload,
  13                 PersistentLinkerState{-abstractly!-}, emptyPLS,
  14 #ifdef GHCI
  15                 updateClosureEnv,
  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 #ifdef GHCI
  94 updateClosureEnv :: PersistentLinkerState -> [(Name,HValue)]
  95         -> IO PersistentLinkerState
  96 updateClosureEnv pls new_bindings
  97   = return pls{ closure_env = addListToFM (closure_env pls) new_bindings }
  98 #endif
  99
 100 -----------------------------------------------------------------------------
 101 -- Unloading old objects ready for a new compilation sweep.
 102 --
 103 -- The compilation manager provides us with a list of linkables that it
 104 -- considers "stable", i.e. won't be recompiled this time around.  For
 105 -- each of the modules current linked in memory,
 106 --
 107 --      * if the linkable is stable (and it's the same one - the
 108 --        user may have recompiled the module on the side), we keep it,
 109 --
 110 --      * otherwise, we unload it.
 111 --
 112
 113 unload :: GhciMode
 114        -> DynFlags
 115        -> [Linkable]            -- stable linkables
 116        -> PersistentLinkerState
 117        -> IO PersistentLinkerState
 118
 119 unload Batch dflags linkables pls = return pls
 120
 121 #ifdef GHCI
 122 unload Interactive dflags linkables pls
 123   = do new_loaded <- filterM maybeUnload (objects_loaded pls)
 124        let mods_retained = map linkableModName new_loaded
 125            itbl_env'     = filterNameMap mods_retained (itbl_env pls)
 126            closure_env'  = filterNameMap mods_retained (closure_env pls)
 127
 128        let verb = verbosity dflags
 129        when (verb >= 3) $ do
 130             hPutStrLn stderr (showSDoc
 131                 (text "CmLink.unload: retaining" <+> ppr mods_retained))
 132
 133        return pls{ objects_loaded = new_loaded,
 134                    itbl_env = itbl_env',
 135                    closure_env = closure_env' }
 136   where
 137         maybeUnload :: Linkable -> IO Bool
 138         maybeUnload (LM time mod objs) = do
 139           case findModuleLinkable_maybe linkables mod of
 140                 Nothing -> do unloadObjs; return False
 141                 Just l | linkableTime l /= time -> do unloadObjs; return False
 142                        | otherwise              -> return True
 143           where
 144              unloadObjs = mapM unloadObj [ f | DotO f <- objs ]
 145 #else
 146 unload Interactive dflags linkables pls = panic "CmLink.unload: no interpreter"
 147 #endif
 148 -----------------------------------------------------------------------------
 149 -- Linking
 150
 151 link :: GhciMode                -- interactive or batch
 152      -> DynFlags                -- dynamic flags
 153      -> Bool                    -- attempt linking in batch mode?
 154      -> [Linkable]
 155      -> PersistentLinkerState
 156      -> IO LinkResult
 157
 158 -- For the moment, in the batch linker, we don't bother to tell doLink
 159 -- which packages to link -- it just tries all that are available.
 160 -- batch_attempt_linking should only be *looked at* in batch mode.  It
 161 -- should only be True if the upsweep was successful and someone
 162 -- exports main, i.e., we have good reason to believe that linking
 163 -- will succeed.
 164
 165 -- There will be (ToDo: are) two lists passed to link.  These
 166 -- correspond to
 167 --
 168 --      1. The list of all linkables in the current home package.  This is
 169 --         used by the batch linker to link the program, and by the interactive
 170 --         linker to decide which modules from the previous link it can
 171 --         throw away.
 172 --      2. The list of modules on which we just called "compile".  This list
 173 --         is used by the interactive linker to decide which modules need
 174 --         to be actually linked this time around (or unlinked and re-linked
 175 --         if the module was recompiled).
 176
 177 link mode dflags batch_attempt_linking linkables pls1
 178    = do let verb = verbosity dflags
 179         when (verb >= 3) $ do
 180              hPutStrLn stderr "CmLink.link: linkables are ..."
 181              hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
 182         res <- link' mode dflags batch_attempt_linking linkables pls1
 183         when (verb >= 3) $
 184              hPutStrLn stderr "CmLink.link: done"
 185         return res
 186
 187 link' Batch dflags batch_attempt_linking linkables pls1
 188    | batch_attempt_linking
 189    = do let o_files = concatMap getOfiles linkables
 190         when (verb >= 1) $
 191              hPutStrLn stderr "ghc: linking ..."
 192         -- don't showPass in Batch mode; doLink will do that for us.
 193         doLink o_files
 194         -- doLink only returns if it succeeds
 195         return (LinkOK pls1)
 196    | otherwise
 197    = do when (verb >= 3) $ do
 198             hPutStrLn stderr "CmLink.link(batch): upsweep (partially) failed OR"
 199             hPutStrLn stderr "   Main.main not exported; not linking."
 200         return (LinkOK pls1)
 201    where
 202       verb = verbosity dflags
 203       getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
 204
 205 link' Interactive dflags batch_attempt_linking linkables pls
 206     = do showPass dflags "Linking"
 207          let (objs, bcos) = partition (isObject.head.linkableUnlinked) linkables
 208          linkObjs (objs ++ bcos) pls
 209            -- get the objects first
 210
 211 ppLinkableSCC :: SCC Linkable -> SDoc
 212 ppLinkableSCC = ppr . flattenSCC
 213
 214 filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
 215 filterModuleLinkables p [] = []
 216 filterModuleLinkables p (li:lis)
 217    = case li of
 218         LM _ modnm _ -> if p modnm then retain else dump
 219      where
 220         dump   = filterModuleLinkables p lis
 221         retain = li : dump
 222
 223 -----------------------------------------------------------------------------
 224 -- Linker for interactive mode
 225
 226 #ifndef GHCI
 227 linkObjs      = panic "CmLink.linkObjs: no interpreter"
 228 lookupClosure = panic "CmLink.lookupClosure: no interpreter"
 229 #else
 230 linkObjs [] pls = linkFinish pls []
 231 linkObjs (l@(LM _ m uls) : ls) pls
 232    | all isObject uls = do
 233         if isLoaded l pls then linkObjs ls pls else do
 234         let objs = [ file | DotO file <- uls ]
 235         mapM_ loadObj objs
 236         linkObjs ls pls{objects_loaded = l : objects_loaded pls}
 237    | all isInterpretable uls  = linkInterpretedCode (l:ls) [] pls
 238    | otherwise                = invalidLinkable
 239
 240 isLoaded :: Linkable -> PersistentLinkerState -> Bool
 241 isLoaded l pls =
 242   case findModuleLinkable_maybe (objects_loaded pls) (linkableModName l) of
 243         Nothing -> False
 244         Just m  -> linkableTime l == linkableTime m
 245
 246 linkInterpretedCode [] ul_trees pls = linkFinish pls ul_trees
 247 linkInterpretedCode (l@(LM _ m uls) : ls) ul_trees pls
 248    | all isInterpretable uls =
 249         if isLoaded l pls then linkInterpretedCode ls ul_trees pls else
 250         linkInterpretedCode ls (uls++ul_trees)
 251                 pls{objects_loaded = l : objects_loaded pls}
 252    | any isObject uls
 253         = throwDyn (OtherError
 254              "can't link object code that depends on interpreted code")
 255    | otherwise = invalidLinkable
 256
 257 invalidLinkable = panic "CmLink: linkable doesn't contain entirely objects or interpreted code"
 258
 259
 260 -- link all the interpreted code in one go.
 261 linkFinish pls ul_bcos = do
 262    resolveObjs
 263
 264    let stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ]
 265
 266    (ibinds, new_itbl_env, new_closure_env) <-
 267         linkIModules (itbl_env pls) (closure_env pls) stuff
 268
 269    let new_pls = pls { closure_env = new_closure_env,
 270                        itbl_env    = new_itbl_env
 271                      }
 272    return (LinkOK new_pls)
 273
 274 linkExpr :: PersistentLinkerState -> UnlinkedBCOExpr -> IO HValue
 275 linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } bcos
 276   = linkIExpr ie ce bcos
 277 #endif
 278 \end{code}