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 import Linker
  17
  18 import CmStaticInfo     ( PackageConfigInfo )
  19 import Module           ( ModuleName, PackageName )
  20 import InterpSyn        ( UnlinkedIBind, HValue, binder )
  21 import Module           ( Module )
  22 import Outputable       ( SDoc )
  23 import FiniteMap        ( FiniteMap, emptyFM )
  24 import RdrName          ( RdrName )
  25 import Digraph          ( SCC(..) )
  26 import Addr             ( Addr )
  27 import Outputable
  28 import Panic            ( panic )
  29
  30 #include "HsVersions.h"
  31 \end{code}
  32
  33 \begin{code}
  34 data PersistentLinkerState
  35    = PersistentLinkerState {
  36         closure_env :: ClosureEnv,
  37         itbl_env    :: ItblEnv
  38         -- notionally here, but really lives in the C part of the linker:
  39         --            object_symtab :: FiniteMap String Addr
  40      }
  41
  42 data LinkResult
  43    = LinkOK   PersistentLinkerState
  44    | LinkErrs PersistentLinkerState [SDoc]
  45
  46 data Unlinked
  47    = DotO FilePath
  48    | DotA FilePath
  49    | DotDLL FilePath
  50    | Trees [UnlinkedIBind]      -- bunch of interpretable bindings
  51
  52 instance Outputable Unlinked where
  53    ppr (DotO path)   = text "DotO" <+> text path
  54    ppr (DotA path)   = text "DotA" <+> text path
  55    ppr (DotDLL path) = text "DotDLL" <+> text path
  56    ppr (Trees binds) = text "Trees" <+> ppr (map binder binds)
  57
  58
  59 isObject (DotO _) = True
  60 isObject (DotA _) = True
  61 isObject (DotDLL _) = True
  62 isObject _ = False
  63
  64 isInterpretable (Trees _) = True
  65 isInterpretable _ = False
  66
  67 data Linkable
  68    = LM ModuleName [Unlinked]
  69    | LP PackageName
  70
  71 instance Outputable Linkable where
  72    ppr (LM mod_nm unlinkeds) = text "LinkableM" <+> ppr mod_nm <+> ppr unlinkeds
  73    ppr (LP package_nm)       = text "LinkableP" <+> ptext package_nm
  74
  75 emptyPLS :: IO PersistentLinkerState
  76 emptyPLS = return (PersistentLinkerState { closure_env = emptyFM,
  77                                            itbl_env    = emptyFM })
  78 \end{code}
  79
  80 \begin{code}
  81 link :: PackageConfigInfo
  82      -> [SCC Linkable]
  83      -> PersistentLinkerState
  84      -> IO LinkResult
  85
  86 #ifndef GHCI_NOTYET
  87 --link = panic "CmLink.link: not implemented"
  88 link pci groups pls1
  89    = do putStrLn "Hello from the Linker!"
  90         putStrLn (showSDoc (vcat (map ppLinkableSCC groups)))
  91         putStrLn "Bye-bye from the Linker!"
  92         return (LinkOK pls1)
  93
  94 ppLinkableSCC :: SCC Linkable -> SDoc
  95 ppLinkableSCC (CyclicSCC xs) = ppr xs
  96 ppLinkableSCC (AcyclicSCC x) = ppr [x]
  97
  98
  99 #else
 100 link pci [] pls = return (LinkOK pls)
 101 link pci (group:groups) pls = do
 102    -- the group is either all objects or all interpretable, for now
 103    if all isObject group
 104         then do mapM loadObj [ file | DotO file <- group ]
 105                 resolveObjs
 106                 link pci groups pls
 107     else if all isInterpretable group
 108         then do (new_closure_env, new_itbl_env) <-
 109                    linkIModules (closure_env pls)
 110                                 (itbl_env pls)
 111                                 [ trees | Trees trees <- group ]
 112                 link pci groups (PersistentLinkerState{
 113                                    closure_env=new_closure_env,
 114                                    itbl_env=new_itbl_env})
 115     else
 116         return (LinkErrs pls (ptext SLIT("linker: group must contain all objects or all interpreted modules")))
 117 #endif
 118
 119 modname_of_linkable (LM nm _) = nm
 120 modname_of_linkable (LP _)    = panic "modname_of_linkable: package"
 121
 122 is_package_linkable (LP _)   = True
 123 is_package_linkable (LM _ _) = False
 124
 125 filterModuleLinkables :: (ModuleName -> Bool)
 126                       -> [Linkable]
 127                       -> [Linkable]
 128 filterModuleLinkables p [] = []
 129 filterModuleLinkables p (li:lis)
 130    = case li of
 131         LP _       -> retain
 132         LM modnm _ -> if p modnm then retain else dump
 133      where
 134         dump   = filterModuleLinkables p lis
 135         retain = li : dump
 136 \end{code}