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