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 import Interpreter
  16 import CmStaticInfo     ( PackageConfigInfo )
  17 import Module           ( ModuleName, PackageName )
  18 import InterpSyn        ( UnlinkedIBind, HValue, binder )
  19 import Module           ( Module )
  20 import Outputable       ( SDoc )
  21 import FiniteMap        ( emptyFM )
  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         -- 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      }
  45
  46 data LinkResult
  47    = LinkOK   PersistentLinkerState
  48    | LinkErrs PersistentLinkerState [SDoc]
  49
  50 data Unlinked
  51    = DotO FilePath
  52    | DotA FilePath
  53    | DotDLL FilePath
  54    | Trees [UnlinkedIBind] ItblEnv  -- bunch of interpretable bindings, +
  55                                     -- a mapping from DataCons to their itbls
  56
  57 instance Outputable Unlinked where
  58    ppr (DotO path)   = text "DotO" <+> text path
  59    ppr (DotA path)   = text "DotA" <+> text path
  60    ppr (DotDLL path) = text "DotDLL" <+> text path
  61    ppr (Trees binds _) = text "Trees" <+> ppr (map binder binds)
  62
  63
  64 isObject (DotO _) = True
  65 isObject (DotA _) = True
  66 isObject (DotDLL _) = True
  67 isObject _ = False
  68
  69 isInterpretable (Trees _ _) = True
  70 isInterpretable _ = False
  71
  72 data Linkable
  73    = LM ModuleName [Unlinked]
  74    | LP PackageName
  75
  76 instance Outputable Linkable where
  77    ppr (LM mod_nm unlinkeds) = text "LinkableM" <+> ppr mod_nm <+> ppr unlinkeds
  78    ppr (LP package_nm)       = text "LinkableP" <+> ptext package_nm
  79
  80 emptyPLS :: IO PersistentLinkerState
  81 emptyPLS = return (PersistentLinkerState { closure_env = emptyFM,
  82                                            itbl_env    = emptyFM })
  83 \end{code}
  84
  85 \begin{code}
  86 link :: PackageConfigInfo
  87      -> [SCC Linkable]
  88      -> PersistentLinkerState
  89      -> IO LinkResult
  90
  91 #ifndef GHCI_NOTYET
  92 --link = panic "CmLink.link: not implemented"
  93 link pci groups pls1
  94    = do putStrLn "Hello from the Linker!"
  95         putStrLn (showSDoc (vcat (map ppLinkableSCC groups)))
  96         putStrLn "Bye-bye from the Linker!"
  97         return (LinkOK pls1)
  98
  99 ppLinkableSCC :: SCC Linkable -> SDoc
 100 ppLinkableSCC = ppr . flattenSCC
 101
 102 #else
 103
 104
 105 link pci [] pls = return (LinkOK pls)
 106 link pci (groupSCC:groups) pls = do
 107    let group = flattenSCC groupSCC
 108    -- the group is either all objects or all interpretable, for now
 109    if all isObject group
 110         then do mapM loadObj [ file | DotO file <- group ]
 111                 resolveObjs
 112                 link pci groups pls
 113     else if all isInterpretable group
 114         then do (new_closure_env, new_itbl_env) <-
 115                    linkIModules (closure_env pls)
 116                                 (itbl_env pls)
 117                                 [ trees | Trees trees <- group ]
 118                 link pci groups (PersistentLinkerState{
 119                                    closure_env=new_closure_env,
 120                                    itbl_env=new_itbl_env})
 121     else
 122         return (LinkErrs pls (ptext SLIT("linker: group must contain all objects or all interpreted modules")))
 123 #endif
 124
 125
 126 modname_of_linkable (LM nm _) = nm
 127 modname_of_linkable (LP _)    = panic "modname_of_linkable: package"
 128
 129 is_package_linkable (LP _)   = True
 130 is_package_linkable (LM _ _) = False
 131
 132 filterModuleLinkables :: (ModuleName -> Bool)
 133                       -> [Linkable]
 134                       -> [Linkable]
 135 filterModuleLinkables p [] = []
 136 filterModuleLinkables p (li:lis)
 137    = case li of
 138         LP _       -> retain
 139         LM modnm _ -> if p modnm then retain else dump
 140      where
 141         dump   = filterModuleLinkables p lis
 142         retain = li : dump
 143 \end{code}