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