[project @ 2000-10-27 15:40:01 by simonpj]

[ghc-hetmet.git] / ghc / compiler / ghci / CmLink.lhs

diff --git a/ghc/compiler/ghci/CmLink.lhs b/ghc/compiler/ghci/CmLink.lhs
index 6445663..3ec42dd 100644 (file)
--- a/ghc/compiler/ghci/CmLink.lhs
+++ b/ghc/compiler/ghci/CmLink.lhs
@@ -4,26 +4,23 @@
 \section[CmLink]{Linker for GHCI}
 
 \begin{code}
-module CmLink ( Linkable(..), 
+module CmLink ( Linkable(..),  Unlinked(..),
                filterModuleLinkables, 
                modname_of_linkable, is_package_linkable,
                LinkResult(..),
                 link, 
-                PLS{-abstractly!-}, emptyPLS )
+                PersistentLinkerState{-abstractly!-}, emptyPLS )
 where
 
 import StgInterp       ( linkIModules, ClosureEnv, ItblEnv )
-import Linker
-
-import CmStaticInfo    ( PCI )
-import CmFind          ( Path, PkgName )
+import Linker          ( loadObj, resolveObjs )
+import CmStaticInfo    ( PackageConfigInfo )
+import Module          ( ModuleName, PackageName )
 import InterpSyn       ( UnlinkedIBind, HValue, binder )
 import Module          ( Module )
 import Outputable      ( SDoc )
-import FiniteMap       ( FiniteMap, emptyFM )
-import RdrName         ( RdrName )
-import Digraph         ( SCC(..) )
-import Addr            ( Addr )
+import FiniteMap       ( emptyFM )
+import Digraph         ( SCC(..), flattenSCC )
 import Outputable
 import Panic           ( panic )
 
@@ -31,29 +28,38 @@ import Panic                ( panic )
 \end{code}
 
 \begin{code}
-data PLS 
-   = MkPLS {
+data PersistentLinkerState 
+   = PersistentLinkerState {
+       -- Current global mapping from RdrNames to closure addresses
         closure_env :: ClosureEnv,
+
+       -- the current global mapping from RdrNames of DataCons to 
+       -- info table addresses.
+       -- When a new Unlinked is linked into the running image, or an existing
+       -- module in the image is replaced, the itbl_env must be updated
+       -- appropriately.
         itbl_env    :: ItblEnv
+
        -- notionally here, but really lives in the C part of the linker:
        --            object_symtab :: FiniteMap String Addr
      }
 
 data LinkResult 
-   = LinkOK   PLS
-   | LinkErrs PLS [SDoc]
+   = LinkOK   PersistentLinkerState
+   | LinkErrs PersistentLinkerState [SDoc]
 
 data Unlinked
-   = DotO Path
-   | DotA Path
-   | DotDLL Path
-   | Trees [UnlinkedIBind]     -- bunch of interpretable bindings
+   = DotO FilePath
+   | DotA FilePath
+   | DotDLL FilePath
+   | Trees [UnlinkedIBind] ItblEnv  -- bunch of interpretable bindings, +
+                                   -- a mapping from DataCons to their itbls
 
 instance Outputable Unlinked where
    ppr (DotO path)   = text "DotO" <+> text path
    ppr (DotA path)   = text "DotA" <+> text path
    ppr (DotDLL path) = text "DotDLL" <+> text path
-   ppr (Trees binds) = text "Trees" <+> ppr (map binder binds)
+   ppr (Trees binds _) = text "Trees" <+> ppr (map binder binds)
 
 
 isObject (DotO _) = True
@@ -61,24 +67,27 @@ isObject (DotA _) = True
 isObject (DotDLL _) = True
 isObject _ = False
 
-isInterpretable (Trees _) = True
+isInterpretable (Trees _ _) = True
 isInterpretable _ = False
 
 data Linkable
-   = LM {-should be:Module-} String{- == ModName-} [Unlinked]
-   | LP PkgName
+   = LM ModuleName [Unlinked]
+   | LP PackageName
 
 instance Outputable Linkable where
-   ppr (LM mod_nm unlinkeds) = text "LinkableM" <+> text mod_nm <+> ppr unlinkeds
-   ppr (LP package_nm)       = text "LinkableP" <+> text package_nm
+   ppr (LM mod_nm unlinkeds) = text "LinkableM" <+> ppr mod_nm <+> ppr unlinkeds
+   ppr (LP package_nm)       = text "LinkableP" <+> ptext package_nm
 
-emptyPLS :: IO PLS
-emptyPLS = return (MkPLS { closure_env = emptyFM, 
-                           itbl_env    = emptyFM })
+emptyPLS :: IO PersistentLinkerState
+emptyPLS = return (PersistentLinkerState { closure_env = emptyFM, 
+                                           itbl_env    = emptyFM })
 \end{code}
 
 \begin{code}
-link :: PCI -> [SCC Linkable] -> PLS -> IO LinkResult
+link :: PackageConfigInfo 
+     -> [SCC Linkable] 
+     -> PersistentLinkerState 
+     -> IO LinkResult
 
 #ifndef GHCI_NOTYET
 --link = panic "CmLink.link: not implemented"
@@ -89,13 +98,14 @@ link pci groups pls1
         return (LinkOK pls1)
 
 ppLinkableSCC :: SCC Linkable -> SDoc
-ppLinkableSCC (CyclicSCC xs) = ppr xs
-ppLinkableSCC (AcyclicSCC x) = ppr [x]
-
+ppLinkableSCC = ppr . flattenSCC
 
 #else
+
+
 link pci [] pls = return (LinkOK pls)
-link pci (group:groups) pls = do
+link pci (groupSCC:groups) pls = do
+   let group = flattenSCC groupSCC
    -- the group is either all objects or all interpretable, for now
    if all isObject group
        then do mapM loadObj [ file | DotO file <- group ]
@@ -106,19 +116,21 @@ link pci (group:groups) pls = do
                   linkIModules (closure_env pls)
                                (itbl_env pls)
                                [ trees | Trees trees <- group ]
-               link pci groups MkPLS{closure_env=new_closure_env,
-                                     itbl_env=new_itbl_env}
+               link pci groups (PersistentLinkerState{
+                                  closure_env=new_closure_env,
+                                  itbl_env=new_itbl_env})
     else
        return (LinkErrs pls (ptext SLIT("linker: group must contain all objects or all interpreted modules")))
 #endif
 
+
 modname_of_linkable (LM nm _) = nm
 modname_of_linkable (LP _)    = panic "modname_of_linkable: package"
 
 is_package_linkable (LP _)   = True
 is_package_linkable (LM _ _) = False
 
-filterModuleLinkables :: (String{- ==ModName-} -> Bool) 
+filterModuleLinkables :: (ModuleName -> Bool) 
                       -> [Linkable] 
                       -> [Linkable]
 filterModuleLinkables p [] = []