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