[project @ 2001-08-01 12:07:50 by simonmar]

Signification cleanup & rewrite of CmLink.

Fixes at least one bug: the PersistentLinkerState could sometimes get
out of step with the RTS's idea of which modules were loaded, leading
to an unloadObj failure when we try to unload the same module twice.
This could happen if a ^C exception is received in the middle of a
:load.

Fixed by keeping the part of the linker's state that must match up
with the RTS's internal state entirely private to CmLink, stored in a
global variable.  The operations in CmLink which manipulate this state
are now wrapped by Exception.block, and so are safe from ^C
exceptions.

diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs
index 4b592f5..7c69ebe 100644 (file)
--- a/ghc/compiler/compMan/CmLink.lhs
+++ b/ghc/compiler/compMan/CmLink.lhs
@@ -1,20 +1,21 @@
 %
 %

-% (c) The University of Glasgow, 2000
+% (c) The University of Glasgow, 2001

 %
 %

-\section[CmLink]{Linker for GHCI}
+\section[CmLink]{The compilation manager's linker}

 
 \begin{code}
 
 \begin{code}

-module CmLink ( Linkable(..),  Unlinked(..),
-               filterModuleLinkables, 
-               findModuleLinkable_maybe,
-               LinkResult(..),
-                link, 
-               unload,
-                PersistentLinkerState{-abstractly!-}, emptyPLS,
+module CmLink (
+       LinkResult(..), link, unload,
+
+       filterModuleLinkables,
+       findModuleLinkable_maybe,
+
+        PersistentLinkerState{-abstractly!-}, emptyPLS,
+

 #ifdef GHCI
 #ifdef GHCI

-               delListFromClosureEnv,
-               addListToClosureEnv,
-               linkExpr
+       delListFromClosureEnv,
+       addListToClosureEnv,
+       linkExpr

 #endif
   ) where
 
 #endif
   ) where
 

@@ -28,85 +29,110 @@ import DriverPipeline
 import CmTypes
 import HscTypes                ( GhciMode(..) )
 import Outputable      ( SDoc )
 import CmTypes
 import HscTypes                ( GhciMode(..) )
 import Outputable      ( SDoc )

-import Digraph         ( SCC(..), flattenSCC )

 import Name            ( Name )
 import Module          ( ModuleName )
 import FiniteMap
 import Outputable
 import ErrUtils                ( showPass )
 import CmdLineOpts     ( DynFlags(..) )
 import Name            ( Name )
 import Module          ( ModuleName )
 import FiniteMap
 import Outputable
 import ErrUtils                ( showPass )
 import CmdLineOpts     ( DynFlags(..) )

-import Panic           ( panic )
+import Util

 
 

+import Exception       ( block )
+import IOExts

 import List
 import Monad
 import IO
 
 #include "HsVersions.h"
 import List
 import Monad
 import IO
 
 #include "HsVersions.h"

-\end{code}

 
 

-\begin{code}
-data PersistentLinkerState 
-   = PersistentLinkerState {
+-- ---------------------------------------------------------------------------
+-- The Linker's state
+
+-- The PersistentLinkerState maps Names to actual closures (for
+-- interpreted code only), for use during linking.

 
 

+data PersistentLinkerState
+   = PersistentLinkerState {

 
 #ifdef GHCI
        -- Current global mapping from RdrNames to closure addresses
         closure_env :: ClosureEnv,
 
 
 #ifdef GHCI
        -- Current global mapping from RdrNames to closure addresses
         closure_env :: ClosureEnv,
 

-       -- the current global mapping from RdrNames of DataCons to 
+       -- 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,
 
        -- 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,
 

-       -- list of objects we've loaded (we'll need to unload them again
-       -- before re-loading the same module), together with the ClockTime
-       -- of the linkable they were loaded from.
-       objects_loaded :: [Linkable]
+       -- the currently loaded interpreted modules
+       bcos_loaded :: [Linkable]

 
 

-       -- notionally here, but really lives in the C part of the linker:
-       --            object_symtab :: FiniteMap String Addr

 #else
        dummy :: ()     --  sigh, can't have an empty record
 #endif
 
      }
 
 #else
        dummy :: ()     --  sigh, can't have an empty record
 #endif
 
      }
 

-data LinkResult 
-   = LinkOK   PersistentLinkerState
-   | LinkErrs PersistentLinkerState [SDoc]
+emptyPLS :: IO PersistentLinkerState
+#ifdef GHCI
+emptyPLS = return (PersistentLinkerState { closure_env = emptyFM,
+                                           itbl_env    = emptyFM,
+                                          bcos_loaded = [] })
+#else
+emptyPLS = return (PersistentLinkerState {})
+#endif
+
+-- We also keep track of which object modules are currently loaded
+-- into the dynamic linker, so that we can unload them again later.
+--
+-- This state *must* match the actual state of the dyanmic linker at
+-- all times, which is why we keep it private here and don't
+-- put it in the PersistentLinkerState.
+--
+GLOBAL_VAR(v_ObjectsLoaded, [], [Linkable])
+
+
+-- ---------------------------------------------------------------------------
+-- Utils

 
 findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable
 
 findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable

-findModuleLinkable_maybe lis mod 
+findModuleLinkable_maybe lis mod

    = case [LM time nm us | LM time nm us <- lis, nm == mod] of
         []   -> Nothing
         [li] -> Just li
         many -> pprPanic "findModuleLinkable" (ppr mod)
 
    = case [LM time nm us | LM time nm us <- lis, nm == mod] of
         []   -> Nothing
         [li] -> Just li
         many -> pprPanic "findModuleLinkable" (ppr mod)
 

+filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
+filterModuleLinkables p [] = []
+filterModuleLinkables p (li:lis)
+   = case li of
+        LM _ modnm _ -> if p modnm then retain else dump
+     where
+        dump   = filterModuleLinkables p lis
+        retain = li : dump

 
 

-emptyPLS :: IO PersistentLinkerState
-#ifdef GHCI
-emptyPLS = return (PersistentLinkerState { closure_env = emptyFM, 
-                                           itbl_env    = emptyFM,
-                                          objects_loaded = [] })
-#else
-emptyPLS = return (PersistentLinkerState {})
-#endif
+linkableInSet :: Linkable -> [Linkable] -> Bool
+linkableInSet l objs_loaded =
+  case findModuleLinkable_maybe objs_loaded (linkableModName l) of
+       Nothing -> False
+       Just m  -> linkableTime l == linkableTime m

 
 

+-- These two are used to add/remove entries from the closure env for
+-- new bindings made at the prompt.

 #ifdef GHCI
 delListFromClosureEnv :: PersistentLinkerState -> [Name]
        -> IO PersistentLinkerState
 delListFromClosureEnv pls names
   = return pls{ closure_env = delListFromFM (closure_env pls) names }
 
 #ifdef GHCI
 delListFromClosureEnv :: PersistentLinkerState -> [Name]
        -> IO PersistentLinkerState
 delListFromClosureEnv pls names
   = return pls{ closure_env = delListFromFM (closure_env pls) names }
 

-addListToClosureEnv :: PersistentLinkerState -> [(Name,HValue)] 
+addListToClosureEnv :: PersistentLinkerState -> [(Name,HValue)]

        -> IO PersistentLinkerState
 addListToClosureEnv pls new_bindings
   = return pls{ closure_env = addListToFM (closure_env pls) new_bindings }
 #endif
 
        -> IO PersistentLinkerState
 addListToClosureEnv pls new_bindings
   = return pls{ closure_env = addListToFM (closure_env pls) new_bindings }
 #endif
 

------------------------------------------------------------------------------
+-- ---------------------------------------------------------------------------

 -- Unloading old objects ready for a new compilation sweep.
 --
 -- The compilation manager provides us with a list of linkables that it
 -- Unloading old objects ready for a new compilation sweep.
 --
 -- The compilation manager provides us with a list of linkables that it

@@ -124,45 +150,60 @@ unload :: GhciMode
        -> DynFlags
        -> [Linkable]           -- stable linkables
        -> PersistentLinkerState
        -> DynFlags
        -> [Linkable]           -- stable linkables
        -> PersistentLinkerState

-       -> IO PersistentLinkerState 
+       -> IO PersistentLinkerState

 
 unload Batch dflags linkables pls = return pls
 
 #ifdef GHCI
 unload Interactive dflags linkables pls
 
 unload Batch dflags linkables pls = return pls
 
 #ifdef GHCI
 unload Interactive dflags linkables pls

-  = do new_loaded <- filterM maybeUnload (objects_loaded pls)
-       let mods_retained = map linkableModName new_loaded
-          itbl_env'     = filterNameMap mods_retained (itbl_env pls)
-           closure_env'  = filterNameMap mods_retained (closure_env pls)
-
-       let verb = verbosity dflags
-       when (verb >= 3) $ do
-           hPutStrLn stderr (showSDoc 
-               (text "CmLink.unload: retaining" <+> ppr mods_retained))
-
-       return pls{ objects_loaded = new_loaded,
-                  itbl_env = itbl_env',
-                  closure_env = closure_env' }
+  = block $ do -- block, so we're safe from Ctrl-C in here
+       objs_loaded  <- readIORef v_ObjectsLoaded
+       objs_loaded' <- filterM (maybeUnload objs_to_keep) objs_loaded
+       writeIORef v_ObjectsLoaded objs_loaded'
+
+        bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
+
+               let objs_retained = map linkableModName objs_loaded'
+           bcos_retained = map linkableModName bcos_loaded'
+           itbl_env'     = filterNameMap bcos_retained (itbl_env pls)
+            closure_env'  = filterNameMap bcos_retained (closure_env pls)
+
+               let verb = verbosity dflags
+               when (verb >= 3) $ do
+           hPutStrLn stderr (showSDoc
+               (text "CmLink.unload: retaining objs" <+> ppr objs_retained))
+           hPutStrLn stderr (showSDoc
+               (text "CmLink.unload: retaining bcos" <+> ppr bcos_retained))
+
+               return pls{ itbl_env = itbl_env',
+                   closure_env = closure_env',
+                   bcos_loaded = bcos_loaded' }

   where
   where

-       maybeUnload :: Linkable -> IO Bool
-       maybeUnload (LM time mod objs) = do
-         case findModuleLinkable_maybe linkables mod of
-               Nothing -> do unloadObjs; return False
-               Just l | linkableTime l /= time -> do unloadObjs; return False
-                      | otherwise              -> return True
-         where
-            unloadObjs = mapM unloadObj [ f | DotO f <- objs ]
+       (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
+
+       maybeUnload :: [Linkable] -> Linkable -> IO Bool
+       maybeUnload keep_linkables l@(LM time mod objs)
+          | linkableInSet l linkables
+               = return True
+          | otherwise
+               = do mapM unloadObj [ f | DotO f <- objs ]
+                    return False

 #else
 unload Interactive dflags linkables pls = panic "CmLink.unload: no interpreter"
 #endif
 #else
 unload Interactive dflags linkables pls = panic "CmLink.unload: no interpreter"
 #endif

+

 -----------------------------------------------------------------------------
 -- Linking
 
 -----------------------------------------------------------------------------
 -- Linking
 

+data LinkResult
+   = LinkOK   PersistentLinkerState
+   | LinkErrs PersistentLinkerState [SDoc]
+

 link :: GhciMode               -- interactive or batch
      -> DynFlags               -- dynamic flags
      -> Bool                   -- attempt linking in batch mode?
      -> [Linkable]
 link :: GhciMode               -- interactive or batch
      -> DynFlags               -- dynamic flags
      -> Bool                   -- attempt linking in batch mode?
      -> [Linkable]

-     -> PersistentLinkerState 
+     -> PersistentLinkerState

      -> IO LinkResult
 
 -- For the moment, in the batch linker, we don't bother to tell doLink
      -> IO LinkResult
 
 -- For the moment, in the batch linker, we don't bother to tell doLink

@@ -177,11 +218,11 @@ link :: GhciMode          -- interactive or batch
 --
 --     1. The list of all linkables in the current home package.  This is
 --        used by the batch linker to link the program, and by the interactive
 --
 --     1. The list of all linkables in the current home package.  This is
 --        used by the batch linker to link the program, and by the interactive

---        linker to decide which modules from the previous link it can 
+--        linker to decide which modules from the previous link it can

 --        throw away.
 --     2. The list of modules on which we just called "compile".  This list
 --        is used by the interactive linker to decide which modules need
 --        throw away.
 --     2. The list of modules on which we just called "compile".  This list
 --        is used by the interactive linker to decide which modules need

---        to be actually linked this time around (or unlinked and re-linked 
+--        to be actually linked this time around (or unlinked and re-linked

 --        if the module was recompiled).
 
 link mode dflags batch_attempt_linking linkables pls1
 --        if the module was recompiled).
 
 link mode dflags batch_attempt_linking linkables pls1

@@ -190,7 +231,7 @@ link mode dflags batch_attempt_linking linkables pls1
             hPutStrLn stderr "CmLink.link: linkables are ..."
              hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
        res <- link' mode dflags batch_attempt_linking linkables pls1
             hPutStrLn stderr "CmLink.link: linkables are ..."
              hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
        res <- link' mode dflags batch_attempt_linking linkables pls1

-        when (verb >= 3) $ 
+        when (verb >= 3) $

             hPutStrLn stderr "CmLink.link: done"
        return res
 
             hPutStrLn stderr "CmLink.link: done"
        return res
 

@@ -212,59 +253,45 @@ link' Batch dflags batch_attempt_linking linkables pls1
       verb = verbosity dflags
       getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
 
       verb = verbosity dflags
       getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
 

+#ifdef GHCI

 link' Interactive dflags batch_attempt_linking linkables pls
     = do showPass dflags "Linking"
 link' Interactive dflags batch_attempt_linking linkables pls
     = do showPass dflags "Linking"

-        let (objs, bcos) = partition (isObject.head.linkableUnlinked) linkables
-        linkObjs (objs ++ bcos) pls
-          -- get the objects first
+        block $ do -- don't want to be interrupted by ^C in here

 
 

-filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
-filterModuleLinkables p [] = []
-filterModuleLinkables p (li:lis)
-   = case li of
-        LM _ modnm _ -> if p modnm then retain else dump
-     where
-        dump   = filterModuleLinkables p lis
-        retain = li : dump
+           -- Always load objects first.  Objects aren't allowed to
+           -- depend on BCOs.
+           let (objs, bcos) = partition isObjectLinkable linkables

 
 

------------------------------------------------------------------------------
--- Linker for interactive mode
+           objs_loaded  <- readIORef v_ObjectsLoaded
+           objs_loaded' <- linkObjs objs objs_loaded
+           writeIORef v_ObjectsLoaded objs_loaded'

 
 

-#ifndef GHCI
-linkObjs      = panic "CmLink.linkObjs: no interpreter"
-#else
-linkObjs [] pls = linkFinish pls []
-linkObjs (l@(LM _ m uls) : ls) pls
-   | all isObject uls = do
-       if isLoaded l pls then linkObjs ls pls else do
-       let objs = [ file | DotO file <- uls ] 
-       mapM_ loadObj objs
-       linkObjs ls pls{objects_loaded = l : objects_loaded pls}
-   | all isInterpretable uls  = linkInterpretedCode (l:ls) [] pls
-   | otherwise                = invalidLinkable
-
-isLoaded :: Linkable -> PersistentLinkerState -> Bool
-isLoaded l pls = 
-  case findModuleLinkable_maybe (objects_loaded pls) (linkableModName l) of
-       Nothing -> False
-       Just m  -> linkableTime l == linkableTime m
- 
-linkInterpretedCode [] ul_trees pls = linkFinish pls ul_trees
-linkInterpretedCode (l@(LM _ m uls) : ls) ul_trees pls
-   | all isInterpretable uls = 
-       if isLoaded l pls then linkInterpretedCode ls ul_trees pls else
-       linkInterpretedCode ls (uls++ul_trees) 
-               pls{objects_loaded = l : objects_loaded pls}
-   | any isObject uls
-        = panic "linkInterpretedCode: trying to link object code to interpreted code"
-   | otherwise = invalidLinkable
+           -- resolve symbols within the object files
+           resolveObjs
+
+           -- finally link the interpreted linkables
+           linkBCOs bcos [] pls
+#endif

 
 

-invalidLinkable = panic "CmLink: linkable doesn't contain entirely objects or interpreted code"
+-----------------------------------------------------------------------------
+-- Linker for interactive mode

 
 

+#ifdef GHCI
+linkObjs [] objs_loaded = return objs_loaded
+linkObjs (l@(LM _ m uls) : ls) objs_loaded
+   | linkableInSet l objs_loaded  = linkObjs ls objs_loaded -- already loaded
+   | otherwise = do mapM_ loadObj [ file | DotO file <- uls ]
+                   linkObjs ls (l:objs_loaded)
+
+linkBCOs [] ul_trees pls = linkFinish pls ul_trees
+linkBCOs (l@(LM _ m uls) : ls) ul_trees pls
+   | linkableInSet l (bcos_loaded pls)
+       = linkBCOs ls ul_trees pls
+   | otherwise
+       = linkBCOs ls (uls++ul_trees) pls{bcos_loaded = l : bcos_loaded pls}

 
 -- link all the interpreted code in one go.
 linkFinish pls ul_bcos = do
 
 -- link all the interpreted code in one go.
 linkFinish pls ul_bcos = do

-   resolveObjs

 
    let stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ]
 
 
    let stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ]
 

@@ -275,7 +302,12 @@ linkFinish pls ul_bcos = do
                       itbl_env    = new_itbl_env
                     }
    return (LinkOK new_pls)
                       itbl_env    = new_itbl_env
                     }
    return (LinkOK new_pls)

+#endif

 
 

+-- ---------------------------------------------------------------------------
+-- Link a single expression
+
+#ifdef GHCI

 linkExpr :: PersistentLinkerState -> UnlinkedBCOExpr -> IO HValue
 linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } bcos
   = linkIExpr ie ce bcos
 linkExpr :: PersistentLinkerState -> UnlinkedBCOExpr -> IO HValue
 linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } bcos
   = linkIExpr ie ce bcos

diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs
index 107fe7d..4623970 100644 (file)
--- a/ghc/compiler/compMan/CompManager.lhs
+++ b/ghc/compiler/compMan/CompManager.lhs
@@ -432,7 +432,7 @@ cmLoadModule cmstate1 rootnames
 
        -- unload any modules which aren't going to be re-linked this
        -- time around.
 
        -- unload any modules which aren't going to be re-linked this
        -- time around.

-       pls2 <- unload ghci_mode dflags stable_linkables pls1
+       pls2 <- CmLink.unload ghci_mode dflags stable_linkables pls1

 
         -- We could at this point detect cycles which aren't broken by
         -- a source-import, and complain immediately, but it seems better
 
         -- We could at this point detect cycles which aren't broken by
         -- a source-import, and complain immediately, but it seems better