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                 PersistentLinkerState{-abstractly!-}, emptyPLS )
  14 where
  15
  16
  17 import Interpreter
  18 import CmStaticInfo     ( PackageConfigInfo, GhciMode(..) )
  19 import Module           ( ModuleName, PackageName )
  20 import Outputable       ( SDoc )
  21 import FiniteMap
  22 import Digraph          ( SCC(..), flattenSCC )
  23 import Outputable
  24 import Panic            ( panic )
  25
  26 #include "HsVersions.h"
  27 \end{code}
  28
  29 \begin{code}
  30 data PersistentLinkerState
  31    = PersistentLinkerState {
  32
  33 #ifdef GHCI
  34         -- Current global mapping from RdrNames to closure addresses
  35         closure_env :: ClosureEnv,
  36
  37         -- the current global mapping from RdrNames of DataCons to
  38         -- info table addresses.
  39         -- When a new Unlinked is linked into the running image, or an existing
  40         -- module in the image is replaced, the itbl_env must be updated
  41         -- appropriately.
  42         itbl_env    :: ItblEnv
  43
  44         -- notionally here, but really lives in the C part of the linker:
  45         --            object_symtab :: FiniteMap String Addr
  46 #else
  47         dummy :: ()     --  sigh, can't have an empty record
  48 #endif
  49
  50      }
  51
  52 data LinkResult
  53    = LinkOK   PersistentLinkerState
  54    | LinkErrs PersistentLinkerState [SDoc]
  55
  56 data Unlinked
  57    = DotO FilePath
  58    | DotA FilePath
  59    | DotDLL FilePath
  60    | Trees [UnlinkedIBind] ItblEnv  -- bunch of interpretable bindings, +
  61                                     -- a mapping from DataCons to their itbls
  62
  63 instance Outputable Unlinked where
  64    ppr (DotO path)   = text "DotO" <+> text path
  65    ppr (DotA path)   = text "DotA" <+> text path
  66    ppr (DotDLL path) = text "DotDLL" <+> text path
  67    ppr (Trees binds _) = text "Trees" <+> ppr binds
  68
  69
  70 isObject (DotO _) = True
  71 isObject (DotA _) = True
  72 isObject (DotDLL _) = True
  73 isObject _ = False
  74
  75 nameOfObject (DotO fn)   = fn
  76 nameOfObject (DotA fn)   = fn
  77 nameOfObject (DotDLL fn) = fn
  78
  79 isInterpretable (Trees _ _) = True
  80 isInterpretable _ = False
  81
  82 data Linkable
  83    = LM ModuleName [Unlinked]
  84    | LP PackageName
  85
  86 instance Outputable Linkable where
  87    ppr (LM mod_nm unlinkeds) = text "LinkableM" <+> ppr mod_nm <+> ppr unlinkeds
  88    ppr (LP package_nm)       = text "LinkableP" <+> ptext package_nm
  89
  90 findModuleLinkable :: [Linkable] -> ModuleName -> Linkable
  91 findModuleLinkable lis mod
  92    = case [LM nm us | LM nm us <- lis, nm == mod] of
  93         [li] -> li
  94         other -> pprPanic "findModuleLinkable" (ppr mod)
  95
  96
  97 emptyPLS :: IO PersistentLinkerState
  98 #ifdef GHCI
  99 emptyPLS = return (PersistentLinkerState { closure_env = emptyFM,
 100                                            itbl_env    = emptyFM })
 101 #else
 102 emptyPLS = return (PersistentLinkerState {})
 103 #endif
 104 \end{code}
 105
 106 \begin{code}
 107 -- The first arg is supposed to be DriverPipeline.doLink.
 108 -- Passed in here to avoid a hard-to-avoid circular dependency
 109 -- between CmLink and DriverPipeline.  Same deal as with
 110 -- CmSummarise.summarise.
 111 link :: ([String] -> IO ())
 112      -> GhciMode                -- interactive or batch
 113      -> Bool                    -- attempt linking in batch mode?
 114      -> [Linkable]              -- only contains LMs, not LPs
 115      -> PersistentLinkerState
 116      -> IO LinkResult
 117
 118 #ifndef GHCI_NOTYET
 119 --link = panic "CmLink.link: not implemented"
 120
 121 -- For the moment, in the batch linker, we don't bother to
 122 -- tell doLink which packages to link -- it just tries all that
 123 -- are available.
 124 -- batch_attempt_linking should only be *looked at* in
 125 -- batch mode.  It should only be True if the upsweep was
 126 -- successful and someone exports main, i.e., we have good
 127 -- reason to believe that linking will succeed.
 128 link doLink Batch batch_attempt_linking linkables pls1
 129    | batch_attempt_linking
 130    = do putStrLn "LINK(batch): linkables are ..."
 131         putStrLn (showSDoc (vcat (map ppr linkables)))
 132         let o_files = concatMap getOfiles linkables
 133         doLink o_files
 134         -- doLink only returns if it succeeds
 135         putStrLn "LINK(batch): done"
 136         return (LinkOK pls1)
 137    | otherwise
 138    = do putStrLn "LINKER(batch): upsweep (partially?) failed OR main not exported;"
 139         putStrLn "               -- not doing linking"
 140         return (LinkOK pls1)
 141    where
 142       getOfiles (LP _)    = panic "link.getOfiles: shouldn't get package linkables"
 143       getOfiles (LM _ us) = map nameOfObject (filter isObject us)
 144
 145 link doLink Interactive batch_attempt_linking linkables pls1
 146    = do putStrLn "LINKER(interactive): not yet implemented"
 147         return (LinkOK pls1)
 148
 149 ppLinkableSCC :: SCC Linkable -> SDoc
 150 ppLinkableSCC = ppr . flattenSCC
 151
 152 #else
 153
 154
 155 link pci [] pls = return (LinkOK pls)
 156 link pci (groupSCC:groups) pls = do
 157    let group = flattenSCC groupSCC
 158    -- the group is either all objects or all interpretable, for now
 159    if all isObject group
 160         then do mapM loadObj [ file | DotO file <- group ]
 161                 resolveObjs
 162                 link pci groups pls
 163     else if all isInterpretable group
 164         then do (new_closure_env, new_itbl_env) <-
 165                    linkIModules (closure_env pls)
 166                                 (itbl_env pls)
 167                                 [ trees | Trees trees <- group ]
 168                 link pci groups (PersistentLinkerState{
 169                                    closure_env=new_closure_env,
 170                                    itbl_env=new_itbl_env})
 171     else
 172         return (LinkErrs pls (ptext SLIT("linker: group must contain all objects or all interpreted modules")))
 173 #endif
 174
 175
 176 modname_of_linkable (LM nm _) = nm
 177 modname_of_linkable (LP _)    = panic "modname_of_linkable: package"
 178
 179 is_package_linkable (LP _)   = True
 180 is_package_linkable (LM _ _) = False
 181
 182 filterModuleLinkables :: (ModuleName -> Bool)
 183                       -> [Linkable]
 184                       -> [Linkable]
 185 filterModuleLinkables p [] = []
 186 filterModuleLinkables p (li:lis)
 187    = case li of
 188         LP _       -> retain
 189         LM modnm _ -> if p modnm then retain else dump
 190      where
 191         dump   = filterModuleLinkables p lis
 192         retain = li : dump
 193 \end{code}