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                 modname_of_linkable, is_package_linkable,
  11                 LinkResult(..),
  12                 link,
  13                 unload,
  14                 PersistentLinkerState{-abstractly!-}, emptyPLS,
  15 #ifdef GHCI
  16                 linkExpr
  17 #endif
  18   ) where
  19
  20
  21 import Interpreter
  22 import DriverPipeline
  23 import CmTypes
  24 import CmStaticInfo     ( GhciMode(..) )
  25 import Outputable       ( SDoc )
  26 import Digraph          ( SCC(..), flattenSCC )
  27 import Module           ( ModuleName )
  28 import FiniteMap
  29 import Outputable
  30 import ErrUtils         ( showPass )
  31 import CmdLineOpts      ( DynFlags(..) )
  32 import Panic            ( panic, GhcException(..) )
  33
  34 import Exception
  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).
  59         objects_loaded :: [FilePath]
  60
  61         -- notionally here, but really lives in the C part of the linker:
  62         --            object_symtab :: FiniteMap String Addr
  63 #else
  64         dummy :: ()     --  sigh, can't have an empty record
  65 #endif
  66
  67      }
  68
  69 data LinkResult
  70    = LinkOK   PersistentLinkerState
  71    | LinkErrs PersistentLinkerState [SDoc]
  72
  73 findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable
  74 findModuleLinkable_maybe lis mod
  75    = case [LM time nm us | LM time nm us <- lis, nm == mod] of
  76         []   -> Nothing
  77         [li] -> Just li
  78         many -> pprPanic "findModuleLinkable" (ppr mod)
  79
  80
  81 emptyPLS :: IO PersistentLinkerState
  82 #ifdef GHCI
  83 emptyPLS = return (PersistentLinkerState { closure_env = emptyFM,
  84                                            itbl_env    = emptyFM,
  85                                            objects_loaded = [] })
  86 #else
  87 emptyPLS = return (PersistentLinkerState {})
  88 #endif
  89 \end{code}
  90
  91 \begin{code}
  92 link :: GhciMode                -- interactive or batch
  93      -> DynFlags                -- dynamic flags
  94      -> Bool                    -- attempt linking in batch mode?
  95      -> [Linkable]              -- only contains LMs, not LPs
  96      -> PersistentLinkerState
  97      -> IO LinkResult
  98
  99 -- For the moment, in the batch linker, we don't bother to tell doLink
 100 -- which packages to link -- it just tries all that are available.
 101 -- batch_attempt_linking should only be *looked at* in batch mode.  It
 102 -- should only be True if the upsweep was successful and someone
 103 -- exports main, i.e., we have good reason to believe that linking
 104 -- will succeed.
 105
 106 -- There will be (ToDo: are) two lists passed to link.  These
 107 -- correspond to
 108 --
 109 --      1. The list of all linkables in the current home package.  This is
 110 --         used by the batch linker to link the program, and by the interactive
 111 --         linker to decide which modules from the previous link it can
 112 --         throw away.
 113 --      2. The list of modules on which we just called "compile".  This list
 114 --         is used by the interactive linker to decide which modules need
 115 --         to be actually linked this time around (or unlinked and re-linked
 116 --         if the module was recompiled).
 117
 118 link mode dflags batch_attempt_linking linkables pls1
 119    = do let verb = verbosity dflags
 120         when (verb >= 3) $ do
 121              hPutStrLn stderr "CmLink.link: linkables are ..."
 122              hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
 123         res <- link' mode dflags batch_attempt_linking linkables pls1
 124         when (verb >= 3) $
 125              hPutStrLn stderr "CmLink.link: done"
 126         return res
 127
 128 link' Batch dflags batch_attempt_linking linkables pls1
 129    | batch_attempt_linking
 130    = do let o_files = concatMap getOfiles linkables
 131         when (verb >= 1) $
 132              hPutStrLn stderr "ghc: linking ..."
 133         -- don't showPass in Batch mode; doLink will do that for us.
 134         doLink o_files
 135         -- doLink only returns if it succeeds
 136         return (LinkOK pls1)
 137    | otherwise
 138    = do when (verb >= 3) $ do
 139             hPutStrLn stderr "CmLink.link(batch): upsweep (partially) failed OR"
 140             hPutStrLn stderr "   Main.main not exported; not linking."
 141         return (LinkOK pls1)
 142    where
 143       verb = verbosity dflags
 144       getOfiles (LP _)    = panic "CmLink.link(getOfiles): found package linkable"
 145       getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
 146
 147 link' Interactive dflags batch_attempt_linking linkables pls1
 148     = do showPass dflags "Linking"
 149          pls2 <- unload pls1
 150          linkObjs linkables [] pls2
 151                 -- reverse the linkables, to get the leaves of the tree first.
 152
 153 ppLinkableSCC :: SCC Linkable -> SDoc
 154 ppLinkableSCC = ppr . flattenSCC
 155
 156
 157 modname_of_linkable (LM _ nm _) = nm
 158 modname_of_linkable (LP _)      = panic "modname_of_linkable: package"
 159
 160 is_package_linkable (LP _)     = True
 161 is_package_linkable (LM _ _ _) = False
 162
 163 filterModuleLinkables :: (ModuleName -> Bool)
 164                       -> [Linkable]
 165                       -> [Linkable]
 166 filterModuleLinkables p [] = []
 167 filterModuleLinkables p (li:lis)
 168    = case li of
 169         LP _         -> retain
 170         LM _ modnm _ -> if p modnm then retain else dump
 171      where
 172         dump   = filterModuleLinkables p lis
 173         retain = li : dump
 174
 175 -----------------------------------------------------------------------------
 176 -- Linker for interactive mode
 177
 178 #ifndef GHCI
 179 linkObjs      = panic "CmLink.linkObjs: no interpreter"
 180 unload        = panic "CmLink.unload: no interpreter"
 181 lookupClosure = panic "CmLink.lookupClosure: no interpreter"
 182 #else
 183 linkObjs [] mods pls = linkFinish pls [] []
 184 linkObjs (l@(LM _ m uls) : ls) mods pls
 185    | all isObject uls = do
 186         let objs = [ file | DotO file <- uls ]
 187         mapM_ loadObj objs
 188         linkObjs ls (m:mods) pls{objects_loaded = objs++objects_loaded pls}
 189    | all isInterpretable uls  = linkInterpretedCode (l:ls) mods [] pls
 190    | otherwise                = invalidLinkable
 191 linkObjs _ _ _ =
 192    panic "CmLink.linkObjs: found package linkable"
 193
 194
 195 linkInterpretedCode [] mods ul_trees pls = linkFinish pls mods ul_trees
 196 linkInterpretedCode (LM _ m uls : ls) mods ul_trees pls
 197    | all isInterpretable uls =
 198         linkInterpretedCode ls (m:mods) (uls++ul_trees) pls
 199    | any isObject uls
 200         = throwDyn (OtherError
 201              "can't link object code that depends on interpreted code")
 202    | otherwise = invalidLinkable
 203 linkInterpretedCode _ _ _ pls =
 204    panic "CmLink.linkInterpretedCode: found package linkable"
 205
 206 invalidLinkable = panic "CmLink: linkable doesn't contain entirely objects or interpreted code"
 207
 208
 209 -- link all the interpreted code in one go.  We first remove from the
 210 -- various environments any previous versions of these modules.
 211 linkFinish pls mods ul_bcos = do
 212    resolveObjs
 213    let itbl_env'    = filterNameMap mods (itbl_env pls)
 214        closure_env' = filterNameMap mods (closure_env pls)
 215        stuff        = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ]
 216
 217    (ibinds, new_itbl_env, new_closure_env) <-
 218         linkIModules itbl_env' closure_env' stuff
 219
 220    let new_pls = pls { closure_env = new_closure_env,
 221                        itbl_env    = new_itbl_env
 222                      }
 223    return (LinkOK new_pls)
 224
 225 -- purge the current "linked image"
 226 unload :: PersistentLinkerState -> IO PersistentLinkerState
 227 unload pls = do
 228    mapM unloadObj (objects_loaded pls)
 229    return pls{ closure_env = emptyFM,
 230                itbl_env = emptyFM,
 231                objects_loaded = [] }
 232
 233 linkExpr :: PersistentLinkerState -> UnlinkedBCOExpr -> IO HValue
 234 linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } bcos
 235   = linkIExpr ie ce bcos
 236 #endif
 237 \end{code}