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