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