[project @ 2000-11-21 14:31:58 by simonmar]

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

diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs
index f478dcc..c4cb9fc 100644 (file)
--- a/ghc/compiler/compMan/CmLink.lhs
+++ b/ghc/compiler/compMan/CmLink.lhs
@@ -12,7 +12,9 @@ module CmLink ( Linkable(..),  Unlinked(..),
                 link, 
                unload,
                 PersistentLinkerState{-abstractly!-}, emptyPLS,
+#ifdef GHCI
                linkExpr
+#endif
   ) where
 
 
@@ -23,13 +25,16 @@ import CmStaticInfo ( GhciMode(..) )
 import Outputable      ( SDoc )
 import Digraph         ( SCC(..), flattenSCC )
 import DriverUtil
-import Module          ( ModuleName, PackageName )
+import Module          ( ModuleName )
 import RdrName
 import FiniteMap
 import Outputable
+import ErrUtils                ( showPass )
+import CmdLineOpts     ( DynFlags(..) )
 import Panic           ( panic )
 
 import Exception
+import Monad
 import IO
 
 #include "HsVersions.h"
@@ -64,7 +69,7 @@ data LinkResult
 
 findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable
 findModuleLinkable_maybe lis mod 
-   = case [LM nm us | LM nm us <- lis, nm == mod] of
+   = case [LM time nm us | LM time nm us <- lis, nm == mod] of
         []   -> Nothing
         [li] -> Just li
         many -> pprPanic "findModuleLinkable" (ppr mod)
@@ -81,6 +86,7 @@ emptyPLS = return (PersistentLinkerState {})
 
 \begin{code}
 link :: GhciMode               -- interactive or batch
+     -> DynFlags               -- dynamic flags
      -> Bool                   -- attempt linking in batch mode?
      -> [Linkable]             -- only contains LMs, not LPs
      -> PersistentLinkerState 
@@ -105,40 +111,48 @@ link :: GhciMode          -- interactive or batch
 --        to be actually linked this time around (or unlinked and re-linked 
 --        if the module was recompiled).
 
-link mode batch_attempt_linking linkables pls1
-   = do hPutStrLn stderr "CmLink.link: linkables are ..."
-        hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
-       res <- link' mode batch_attempt_linking linkables pls1
-       hPutStrLn stderr "CmLink.link: done"
+link mode dflags batch_attempt_linking linkables pls1
+   = do let verb = verbosity dflags
+        when (verb >= 3) $ do
+            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) $ 
+            hPutStrLn stderr "CmLink.link: done"
        return res
 
-link' Batch batch_attempt_linking linkables pls1
+link' Batch dflags batch_attempt_linking linkables pls1
    | batch_attempt_linking
    = do let o_files = concatMap getOfiles linkables
+       -- don't showPass in Batch mode; doLink will do that for us.
         doLink o_files
        -- doLink only returns if it succeeds
         return (LinkOK pls1)
    | otherwise
-   = do hPutStrLn stderr "CmLink.link(batch): upsweep (partially?) failed OR main not exported;"
-        hPutStrLn stderr "               -- not doing linking"
+   = do let verb = verbosity dflags
+        when (verb >= 3) $ do
+           hPutStrLn stderr "CmLink.link(batch): upsweep (partially?) failed OR main not exported;"
+            hPutStrLn stderr "not linking."
         return (LinkOK pls1)
    where
       getOfiles (LP _)    = panic "CmLink.link(getOfiles): shouldn't get package linkables"
-      getOfiles (LM _ us) = map nameOfObject (filter isObject us)
+      getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
+
+link' Interactive dflags batch_attempt_linking linkables pls1
+    = do showPass dflags "Linking"
+        pls2 <- unload pls1
+        linkObjs linkables pls2
 
-link' Interactive batch_attempt_linking linkables pls1
-    = linkObjs linkables pls1
-        
 
 ppLinkableSCC :: SCC Linkable -> SDoc
 ppLinkableSCC = ppr . flattenSCC
 
 
-modname_of_linkable (LM nm _) = nm
-modname_of_linkable (LP _)    = panic "modname_of_linkable: package"
+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
+is_package_linkable (LP _)     = True
+is_package_linkable (LM _ _ _) = False
 
 filterModuleLinkables :: (ModuleName -> Bool) 
                       -> [Linkable] 
@@ -146,8 +160,8 @@ filterModuleLinkables :: (ModuleName -> Bool)
 filterModuleLinkables p [] = []
 filterModuleLinkables p (li:lis)
    = case li of
-        LP _       -> retain
-        LM modnm _ -> if p modnm then retain else dump
+        LP _         -> retain
+        LM _ modnm _ -> if p modnm then retain else dump
      where
         dump   = filterModuleLinkables p lis
         retain = li : dump
@@ -161,7 +175,7 @@ unload        = panic "CmLink.unload: no interpreter"
 lookupClosure = panic "CmLink.lookupClosure: no interpreter"
 #else
 linkObjs [] pls = linkFinish pls [] []
-linkObjs (l@(LM _ uls) : ls) pls
+linkObjs (l@(LM _ _ uls) : ls) pls
    | all isObject uls = do
        mapM_ loadObj [ file | DotO file <- uls ] 
        linkObjs ls pls
@@ -172,7 +186,7 @@ linkObjs _ pls =
 
  
 linkInterpretedCode [] mods ul_trees pls = linkFinish pls mods ul_trees
-linkInterpretedCode (LM m uls : ls) mods ul_trees pls
+linkInterpretedCode (LM _ m uls : ls) mods ul_trees pls
    | all isInterpretable uls = 
        linkInterpretedCode ls (m:mods) (uls++ul_trees) pls
         
@@ -200,7 +214,6 @@ linkFinish pls mods ul_trees = do
                                  closure_env = new_closure_env,
                                  itbl_env    = new_itbl_env
                        }
-   putStrLn (showSDoc (vcat (map ppr (keysFM new_closure_env))))
    return (LinkOK new_pls)
 
 -- purge the current "linked image"