ghc/compiler/compMan/CmLink.lhs

   1 %
   2 % (c) The University of Glasgow, 2001
   3 %
   4 \section[CmLink]{The compilation manager's linker}
   5
   6 \begin{code}
   7 module CmLink (
   8         LinkResult(..), link, unload,
   9
  10         filterModuleLinkables,
  11         findModuleLinkable_maybe,
  12
  13         PersistentLinkerState{-abstractly!-}, emptyPLS,
  14
  15 #ifdef GHCI
  16         delListFromClosureEnv,
  17         addListToClosureEnv,
  18         linkExpr
  19 #endif
  20   ) where
  21
  22
  23 #include "HsVersions.h"
  24
  25 #ifdef GHCI
  26 import ByteCodeLink     ( linkIModules, linkIExpr )
  27 import Interpreter
  28 import Name             ( Name )
  29 import FiniteMap
  30 import ErrUtils         ( showPass )
  31 import DATA_IOREF       ( readIORef, writeIORef )
  32 #endif
  33
  34 import DriverPipeline
  35 import CmTypes
  36 import HscTypes         ( GhciMode(..) )
  37 import Module           ( ModuleName )
  38 import Outputable
  39 import CmdLineOpts      ( DynFlags(..) )
  40 import Util
  41
  42 #ifdef GHCI
  43 import Control.Exception        ( block )
  44 #endif
  45
  46 import DATA_IOREF       ( IORef )
  47
  48 import List
  49 import Monad
  50 import IO
  51
  52 -- ---------------------------------------------------------------------------
  53 -- The Linker's state
  54
  55 -- The PersistentLinkerState maps Names to actual closures (for
  56 -- interpreted code only), for use during linking.
  57
  58 data PersistentLinkerState
  59    = PersistentLinkerState {
  60
  61 #ifdef GHCI
  62         -- Current global mapping from RdrNames to closure addresses
  63         closure_env :: ClosureEnv,
  64
  65         -- the current global mapping from RdrNames of DataCons to
  66         -- info table addresses.
  67         -- When a new Unlinked is linked into the running image, or an existing
  68         -- module in the image is replaced, the itbl_env must be updated
  69         -- appropriately.
  70         itbl_env    :: ItblEnv,
  71
  72         -- the currently loaded interpreted modules
  73         bcos_loaded :: [Linkable]
  74
  75 #else
  76         dummy :: ()     --  sigh, can't have an empty record
  77 #endif
  78
  79      }
  80
  81 emptyPLS :: IO PersistentLinkerState
  82 #ifdef GHCI
  83 emptyPLS = return (PersistentLinkerState { closure_env = emptyFM,
  84                                            itbl_env    = emptyFM,
  85                                            bcos_loaded = [] })
  86 #else
  87 emptyPLS = return (PersistentLinkerState {dummy=()})
  88 #endif
  89
  90 -- We also keep track of which object modules are currently loaded
  91 -- into the dynamic linker, so that we can unload them again later.
  92 --
  93 -- This state *must* match the actual state of the dyanmic linker at
  94 -- all times, which is why we keep it private here and don't
  95 -- put it in the PersistentLinkerState.
  96 --
  97 GLOBAL_VAR(v_ObjectsLoaded, [], [Linkable])
  98
  99
 100 -- ---------------------------------------------------------------------------
 101 -- Utils
 102
 103 findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable
 104 findModuleLinkable_maybe lis mod
 105    = case [LM time nm us | LM time nm us <- lis, nm == mod] of
 106         []   -> Nothing
 107         [li] -> Just li
 108         many -> pprPanic "findModuleLinkable" (ppr mod)
 109
 110 filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
 111 filterModuleLinkables p [] = []
 112 filterModuleLinkables p (li:lis)
 113    = case li of
 114         LM _ modnm _ -> if p modnm then retain else dump
 115      where
 116         dump   = filterModuleLinkables p lis
 117         retain = li : dump
 118
 119 #ifdef GHCI
 120 linkableInSet :: Linkable -> [Linkable] -> Bool
 121 linkableInSet l objs_loaded =
 122   case findModuleLinkable_maybe objs_loaded (linkableModName l) of
 123         Nothing -> False
 124         Just m  -> linkableTime l == linkableTime m
 125
 126 -- These two are used to add/remove entries from the closure env for
 127 -- new bindings made at the prompt.
 128 delListFromClosureEnv :: PersistentLinkerState -> [Name]
 129         -> IO PersistentLinkerState
 130 delListFromClosureEnv pls names
 131   = return pls{ closure_env = delListFromFM (closure_env pls) names }
 132
 133 addListToClosureEnv :: PersistentLinkerState -> [(Name,HValue)]
 134         -> IO PersistentLinkerState
 135 addListToClosureEnv pls new_bindings
 136   = return pls{ closure_env = addListToFM (closure_env pls) new_bindings }
 137 #endif
 138
 139 -- ---------------------------------------------------------------------------
 140 -- Unloading old objects ready for a new compilation sweep.
 141 --
 142 -- The compilation manager provides us with a list of linkables that it
 143 -- considers "stable", i.e. won't be recompiled this time around.  For
 144 -- each of the modules current linked in memory,
 145 --
 146 --      * if the linkable is stable (and it's the same one - the
 147 --        user may have recompiled the module on the side), we keep it,
 148 --
 149 --      * otherwise, we unload it.
 150 --
 151 --      * we also implicitly unload all temporary bindings at this point.
 152
 153 unload :: GhciMode
 154        -> DynFlags
 155        -> [Linkable]            -- stable linkables
 156        -> PersistentLinkerState
 157        -> IO PersistentLinkerState
 158
 159 unload Batch dflags linkables pls = return pls
 160
 161 #ifdef GHCI
 162 unload Interactive dflags linkables pls
 163   = block $ do -- block, so we're safe from Ctrl-C in here
 164         objs_loaded  <- readIORef v_ObjectsLoaded
 165         objs_loaded' <- filterM (maybeUnload objs_to_keep) objs_loaded
 166         writeIORef v_ObjectsLoaded objs_loaded'
 167
 168         bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
 169
 170         let objs_retained = map linkableModName objs_loaded'
 171             bcos_retained = map linkableModName bcos_loaded'
 172             itbl_env'     = filterNameMap bcos_retained (itbl_env pls)
 173             closure_env'  = filterNameMap bcos_retained (closure_env pls)
 174
 175         let verb = verbosity dflags
 176         when (verb >= 3) $ do
 177             hPutStrLn stderr (showSDoc
 178                 (text "CmLink.unload: retaining objs" <+> ppr objs_retained))
 179             hPutStrLn stderr (showSDoc
 180                 (text "CmLink.unload: retaining bcos" <+> ppr bcos_retained))
 181
 182         return pls{ itbl_env = itbl_env',
 183                     closure_env = closure_env',
 184                     bcos_loaded = bcos_loaded' }
 185   where
 186         (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
 187
 188         maybeUnload :: [Linkable] -> Linkable -> IO Bool
 189         maybeUnload keep_linkables l@(LM time mod objs)
 190            | linkableInSet l linkables
 191                 = return True
 192            | otherwise
 193                 = do mapM_ unloadObj [ f | DotO f <- objs ]
 194                      return False
 195 #else
 196 unload Interactive dflags linkables pls = panic "CmLink.unload: no interpreter"
 197 #endif
 198
 199 -----------------------------------------------------------------------------
 200 -- Linking
 201
 202 data LinkResult
 203    = LinkOK     PersistentLinkerState
 204    | LinkFailed PersistentLinkerState
 205
 206 link :: GhciMode                -- interactive or batch
 207      -> DynFlags                -- dynamic flags
 208      -> Bool                    -- attempt linking in batch mode?
 209      -> [Linkable]
 210      -> PersistentLinkerState
 211      -> IO LinkResult
 212
 213 -- For the moment, in the batch linker, we don't bother to tell doLink
 214 -- which packages to link -- it just tries all that are available.
 215 -- batch_attempt_linking should only be *looked at* in batch mode.  It
 216 -- should only be True if the upsweep was successful and someone
 217 -- exports main, i.e., we have good reason to believe that linking
 218 -- will succeed.
 219
 220 -- There will be (ToDo: are) two lists passed to link.  These
 221 -- correspond to
 222 --
 223 --      1. The list of all linkables in the current home package.  This is
 224 --         used by the batch linker to link the program, and by the interactive
 225 --         linker to decide which modules from the previous link it can
 226 --         throw away.
 227 --      2. The list of modules on which we just called "compile".  This list
 228 --         is used by the interactive linker to decide which modules need
 229 --         to be actually linked this time around (or unlinked and re-linked
 230 --         if the module was recompiled).
 231
 232 link mode dflags batch_attempt_linking linkables pls1
 233    = do let verb = verbosity dflags
 234         when (verb >= 3) $ do
 235              hPutStrLn stderr "CmLink.link: linkables are ..."
 236              hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
 237         res <- link' mode dflags batch_attempt_linking linkables pls1
 238         when (verb >= 3) $
 239              hPutStrLn stderr "CmLink.link: done"
 240         return res
 241
 242 link' Batch dflags batch_attempt_linking linkables pls1
 243    | batch_attempt_linking
 244    = do let o_files = concatMap getOfiles linkables
 245         when (verb >= 1) $
 246              hPutStrLn stderr "ghc: linking ..."
 247         -- don't showPass in Batch mode; doLink will do that for us.
 248         doLink o_files
 249         -- doLink only returns if it succeeds
 250         return (LinkOK pls1)
 251    | otherwise
 252    = do when (verb >= 3) $ do
 253             hPutStrLn stderr "CmLink.link(batch): upsweep (partially) failed OR"
 254             hPutStrLn stderr "   Main.main not exported; not linking."
 255         return (LinkOK pls1)
 256    where
 257       verb = verbosity dflags
 258       getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
 259
 260 #ifdef GHCI
 261 link' Interactive dflags batch_attempt_linking linkables pls
 262     = do showPass dflags "Linking"
 263          block $ do -- don't want to be interrupted by ^C in here
 264
 265             -- Always load objects first.  Objects aren't allowed to
 266             -- depend on BCOs.
 267             let (objs, bcos) = partition isObjectLinkable
 268                                   (concatMap partitionLinkable linkables)
 269
 270             objs_loaded  <- readIORef v_ObjectsLoaded
 271             objs_loaded' <- linkObjs objs objs_loaded
 272             writeIORef v_ObjectsLoaded objs_loaded'
 273
 274             -- resolve symbols within the object files
 275             ok <- resolveObjs
 276             -- if resolving failed, unload all our object modules and
 277             -- carry on.
 278             if (not ok)
 279                then do pls <- unload Interactive dflags [] pls
 280                        return (LinkFailed pls)
 281                else do
 282
 283             -- finally link the interpreted linkables
 284             linkBCOs bcos [] pls
 285 #endif
 286
 287 -----------------------------------------------------------------------------
 288 -- Linker for interactive mode
 289
 290 #ifdef GHCI
 291 linkObjs [] objs_loaded = return objs_loaded
 292 linkObjs (l@(LM _ m uls) : ls) objs_loaded
 293    | linkableInSet l objs_loaded  = linkObjs ls objs_loaded -- already loaded
 294    | otherwise = do mapM_ loadObj [ file | DotO file <- uls ]
 295                     linkObjs ls (l:objs_loaded)
 296
 297 linkBCOs [] ul_trees pls = linkFinish pls ul_trees
 298 linkBCOs (l@(LM _ m uls) : ls) ul_trees pls
 299    | linkableInSet l (bcos_loaded pls)
 300         = linkBCOs ls ul_trees pls
 301    | otherwise
 302         = linkBCOs ls (uls++ul_trees) pls{bcos_loaded = l : bcos_loaded pls}
 303
 304 -- link all the interpreted code in one go.
 305 linkFinish pls ul_bcos = do
 306
 307    let stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ]
 308
 309    (ibinds, new_itbl_env, new_closure_env) <-
 310         linkIModules (itbl_env pls) (closure_env pls) stuff
 311
 312    let new_pls = pls { closure_env = new_closure_env,
 313                        itbl_env    = new_itbl_env
 314                      }
 315    return (LinkOK new_pls)
 316 #endif
 317
 318 -- ---------------------------------------------------------------------------
 319 -- Link a single expression
 320
 321 #ifdef GHCI
 322 linkExpr :: PersistentLinkerState -> UnlinkedBCOExpr -> IO HValue
 323 linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } bcos
 324   = linkIExpr ie ce bcos
 325 #endif
 326 \end{code}