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