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