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