ghc/compiler/ghci/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 StgInterp        ( linkIModules, ClosureEnv, ItblEnv )
  16
  17 import CmStaticInfo     ( PackageConfigInfo )
  18 import Module           ( ModuleName, PackageName )
  19 import InterpSyn        ( UnlinkedIBind, HValue, binder )
  20 import Module           ( Module )
  21 import Outputable       ( SDoc )
  22 import FiniteMap        ( emptyFM )
  23 import Digraph          ( SCC(..) )
  24 import Outputable
  25 import Panic            ( panic )
  26
  27 #include "HsVersions.h"
  28 \end{code}
  29
  30 \begin{code}
  31 data PersistentLinkerState
  32    = PersistentLinkerState {
  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      }
  46
  47 data LinkResult
  48    = LinkOK   PersistentLinkerState
  49    | LinkErrs PersistentLinkerState [SDoc]
  50
  51 data Unlinked
  52    = DotO FilePath
  53    | DotA FilePath
  54    | DotDLL FilePath
  55    | Trees [UnlinkedIBind] ItblEnv  -- bunch of interpretable bindings, +
  56                                     -- a mapping from DataCons to their itbls
  57
  58 instance Outputable Unlinked where
  59    ppr (DotO path)   = text "DotO" <+> text path
  60    ppr (DotA path)   = text "DotA" <+> text path
  61    ppr (DotDLL path) = text "DotDLL" <+> text path
  62    ppr (Trees binds _) = text "Trees" <+> ppr (map binder binds)
  63
  64
  65 isObject (DotO _) = True
  66 isObject (DotA _) = True
  67 isObject (DotDLL _) = True
  68 isObject _ = False
  69
  70 isInterpretable (Trees _ _) = True
  71 isInterpretable _ = False
  72
  73 data Linkable
  74    = LM ModuleName [Unlinked]
  75    | LP PackageName
  76
  77 instance Outputable Linkable where
  78    ppr (LM mod_nm unlinkeds) = text "LinkableM" <+> ppr mod_nm <+> ppr unlinkeds
  79    ppr (LP package_nm)       = text "LinkableP" <+> ptext package_nm
  80
  81 emptyPLS :: IO PersistentLinkerState
  82 emptyPLS = return (PersistentLinkerState { closure_env = emptyFM,
  83                                            itbl_env    = emptyFM })
  84 \end{code}
  85
  86 \begin{code}
  87 link :: PackageConfigInfo
  88      -> [SCC Linkable]
  89      -> PersistentLinkerState
  90      -> IO LinkResult
  91
  92 link pci [] pls = return (LinkOK pls)
  93 link pci (group:groups) pls = do
  94    -- the group is either all objects or all interpretable, for now
  95    if all isObject group
  96         then do mapM loadObj [ file | DotO file <- group ]
  97                 resolveObjs
  98                 link pci groups pls
  99     else if all isInterpretable group
 100         then do (new_closure_env, new_itbl_env) <-
 101                    linkIModules (closure_env pls)
 102                                 (itbl_env pls)
 103                                 [ trees | Trees trees <- group ]
 104                 link pci groups (PersistentLinkerState{
 105                                    closure_env=new_closure_env,
 106                                    itbl_env=new_itbl_env})
 107     else
 108         return (LinkErrs pls (ptext SLIT("linker: group must contain all objects or all interpreted modules")))
 109
 110 modname_of_linkable (LM nm _) = nm
 111 modname_of_linkable (LP _)    = panic "modname_of_linkable: package"
 112
 113 is_package_linkable (LP _)   = True
 114 is_package_linkable (LM _ _) = False
 115
 116 filterModuleLinkables :: (ModuleName -> Bool)
 117                       -> [Linkable]
 118                       -> [Linkable]
 119 filterModuleLinkables p [] = []
 120 filterModuleLinkables p (li:lis)
 121    = case li of
 122         LP _       -> retain
 123         LM modnm _ -> if p modnm then retain else dump
 124      where
 125         dump   = filterModuleLinkables p lis
 126         retain = li : dump
 127 \end{code}