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