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