[project @ 2001-10-23 22:25:46 by sof]
[ghc-hetmet.git] / ghc / compiler / compMan / CompManager.lhs
index 001a44d..1642b26 100644 (file)
@@ -4,22 +4,26 @@
 \section[CompManager]{The Compilation Manager}
 
 \begin{code}
+{-# OPTIONS -fvia-C #-}
 module CompManager ( 
     cmInit,      -- :: GhciMode -> IO CmState
 
     cmLoadModule, -- :: CmState -> FilePath -> IO (CmState, [String])
 
-    cmUnload,    -- :: CmState -> IO CmState
+    cmUnload,    -- :: CmState -> DynFlags -> IO CmState
 
     cmSetContext, -- :: CmState -> String -> IO CmState
 
     cmGetContext, -- :: CmState -> IO String
 
 #ifdef GHCI
-    cmRunStmt,   --  :: CmState -> DynFlags -> String -> IO (CmState, [Name])
+    cmInfoThing,  -- :: CmState -> DynFlags -> String -> IO (Maybe TyThing)
 
-    cmTypeOfExpr, --  :: CmState -> DynFlags -> String
-                 --  -> IO (CmState, Maybe String)
+    CmRunResult(..),
+    cmRunStmt,   -- :: CmState -> DynFlags -> String -> IO (CmState, CmRunResult)
+
+    cmTypeOfExpr, -- :: CmState -> DynFlags -> String
+                 -- -> IO (CmState, Maybe String)
 
     cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String)
 
@@ -34,17 +38,22 @@ where
 
 import CmLink
 import CmTypes
-import CmStaticInfo    ( GhciMode(..) )
 import DriverPipeline
 import DriverFlags     ( getDynFlags )
+import DriverState     ( v_Output_file )
 import DriverPhases
 import DriverUtil
 import Finder
+#ifdef GHCI
+import HscMain         ( initPersistentCompilerState, hscThing )
+#else
 import HscMain         ( initPersistentCompilerState )
+#endif
 import HscTypes
 import RnEnv           ( unQualInScope )
 import Id              ( idType, idName )
-import Name            ( Name, NamedThing(..), nameRdrName )
+import Name            ( Name, NamedThing(..), nameRdrName, nameModule,
+                         isHomePackageName )
 import NameEnv
 import RdrName         ( lookupRdrEnv, emptyRdrEnv )
 import Module
@@ -53,13 +62,15 @@ import Type         ( tidyType )
 import VarEnv          ( emptyTidyEnv )
 import UniqFM
 import Unique          ( Uniquable )
-import Digraph         ( SCC(..), stronglyConnComp, flattenSCC )
+import Digraph         ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
 import ErrUtils                ( showPass )
+import SysTools                ( cleanTempFilesExcept )
 import Util
-import TmpFiles
 import Outputable
+import BasicTypes      ( Fixity, defaultFixity )
 import Panic
 import CmdLineOpts     ( DynFlags(..) )
+
 import IOExts
 
 #ifdef GHCI
@@ -69,7 +80,9 @@ import PrelGHC                ( unsafeCoerce# )
 #endif
 
 -- lang
-import Exception       ( throwDyn )
+import Foreign
+import CForeign
+import Exception       ( Exception, try, throwDyn )
 
 -- std
 import Directory        ( getModificationTime, doesFileExist )
@@ -142,7 +155,7 @@ cmInit mode = do
 cmSetContext :: CmState -> String -> IO CmState
 cmSetContext cmstate str
    = do let mn = mkModuleName str
-           modules_loaded = [ (name_of_summary s, ms_mod s)  | s <- mg cmstate ]
+           modules_loaded = [ (name_of_summary s, ms_mod s) | s <- mg cmstate ]
 
         m <- case lookup mn modules_loaded of
                Just m  -> return m
@@ -168,13 +181,46 @@ moduleNameToModule mn
        Just (m,_) -> return m
 
 -----------------------------------------------------------------------------
+-- cmInfoThing: convert a String to a TyThing
+
+-- A string may refer to more than one TyThing (eg. a constructor,
+-- and type constructor), so we return a list of all the possible TyThings.
+
+#ifdef GHCI
+cmInfoThing :: CmState -> DynFlags -> String 
+       -> IO (CmState, PrintUnqualified, [(TyThing,Fixity)])
+cmInfoThing cmstate dflags id
+   = do (new_pcs, things) <- hscThing dflags hst hit pcs icontext id
+       let pairs = map (\x -> (x, getFixity new_pcs (getName x))) things
+       return (cmstate{ pcs=new_pcs }, unqual, pairs)
+   where 
+     CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
+     unqual = getUnqual pcs hit icontext
+
+     getFixity :: PersistentCompilerState -> Name -> Fixity
+     getFixity pcs name
+       | Just iface  <- lookupModuleEnv iface_table (nameModule name),
+         Just fixity <- lookupNameEnv (mi_fixities iface) name
+         = fixity
+       | otherwise
+         = defaultFixity
+       where iface_table | isHomePackageName name = hit
+                         | otherwise              = pcs_PIT pcs
+#endif
+
+-----------------------------------------------------------------------------
 -- cmRunStmt:  Run a statement/expr.
 
 #ifdef GHCI
-cmRunStmt :: CmState -> DynFlags -> String
-       -> IO (CmState,                 -- new state
-              [Name])                  -- names bound by this evaluation
-cmRunStmt cmstate dflags expr
+data CmRunResult
+  = CmRunOk [Name]             -- names bound by this evaluation
+  | CmRunFailed 
+  | CmRunDeadlocked            -- statement deadlocked
+  | CmRunException Exception   -- statement raised an exception
+
+cmRunStmt :: CmState -> DynFlags -> String -> IO (CmState, CmRunResult)                
+cmRunStmt cmstate@CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext }
+          dflags expr
    = do 
        let InteractiveContext { 
                ic_rn_env = rn_env, 
@@ -185,7 +231,7 @@ cmRunStmt cmstate dflags expr
            <- hscStmt dflags hst hit pcs icontext expr False{-stmt-}
 
         case maybe_stuff of
-          Nothing -> return (cmstate{ pcs=new_pcs }, [])
+          Nothing -> return (cmstate{ pcs=new_pcs }, CmRunFailed)
           Just (ids, _, bcos) -> do
 
                -- update the interactive context
@@ -212,17 +258,56 @@ cmRunStmt cmstate dflags expr
 
                -- run it!
                let thing_to_run = unsafeCoerce# hval :: IO [HValue]
-               hvals <- thing_to_run
-
-               -- Get the newly bound things, and bind them.  Don't forget
-               -- to delete any shadowed bindings from the closure_env, lest
-               -- we end up with a space leak.
-               pls <- delListFromClosureEnv pls shadowed
-               new_pls <- addListToClosureEnv pls (zip names hvals)
-
-               return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names)
-   where
-       CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
+               either_hvals <- sandboxIO thing_to_run
+               case either_hvals of
+                  Left err
+                       | err == dEADLOCKED
+                       -> return ( cmstate{ pcs=new_pcs, ic=new_ic }, 
+                                   CmRunDeadlocked )
+                       | otherwise
+                       -> do hPutStrLn stderr ("unknown failure, code " ++ show err)
+                             return ( cmstate{ pcs=new_pcs, ic=new_ic }, CmRunFailed )
+
+                  Right maybe_hvals ->
+                    case maybe_hvals of
+                       Left e -> 
+                           return ( cmstate{ pcs=new_pcs, ic=new_ic }, 
+                                    CmRunException e )
+                       Right hvals -> do
+                            -- Get the newly bound things, and bind them.  
+                            -- Don't forget to delete any shadowed bindings from the
+                            -- closure_env, lest we end up with a space leak.
+                            pls <- delListFromClosureEnv pls shadowed
+                            new_pls <- addListToClosureEnv pls (zip names hvals)
+            
+                            return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, 
+                                    CmRunOk names)
+
+-- We run the statement in a "sandbox", which amounts to calling into
+-- the RTS to request a new main thread.  The main benefit is that we
+-- get to detect a deadlock this way, but also there's no danger that
+-- exceptions raised by the expression can affect the interpreter.
+
+sandboxIO :: IO a -> IO (Either Int (Either Exception a))
+sandboxIO thing = do
+  st_thing <- newStablePtr (Exception.try thing)
+  alloca $ \ p_st_result -> do
+    stat <- rts_evalStableIO st_thing p_st_result
+    freeStablePtr st_thing
+    if stat == 1
+       then do st_result <- peek p_st_result
+               result <- deRefStablePtr st_result
+               freeStablePtr st_result
+               return (Right result)
+       else do
+               return (Left (fromIntegral stat))
+
+-- ToDo: slurp this in from ghc/includes/RtsAPI.h somehow
+dEADLOCKED = 4 :: Int
+
+foreign import "rts_evalStableIO"  {- safe -}
+  rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
+  -- more informative than the C type!
 #endif
 
 -----------------------------------------------------------------------------
@@ -238,19 +323,23 @@ cmTypeOfExpr cmstate dflags expr
 
        case maybe_stuff of
           Nothing -> return (new_cmstate, Nothing)
-          Just (_, ty, _) ->
-            let pit = pcs_PIT pcs
-                modname = moduleName (ic_module ic)
-                tidy_ty = tidyType emptyTidyEnv ty
-                str = case lookupIfaceByModName hit pit modname of
-                         Nothing    -> showSDoc (ppr tidy_ty)
-                         Just iface -> showSDocForUser unqual (ppr tidy_ty)
-                            where unqual = unQualInScope (mi_globals iface)
-            in return (new_cmstate, Just str)
+          Just (_, ty, _) -> return (new_cmstate, Just str)
+            where 
+               str = showSDocForUser unqual (ppr tidy_ty)
+               unqual  = getUnqual pcs hit ic
+               tidy_ty = tidyType emptyTidyEnv ty
    where
        CmState{ hst=hst, hit=hit, pcs=pcs, ic=ic } = cmstate
 #endif
 
+getUnqual pcs hit ic
+   = case lookupIfaceByModName hit pit modname of
+       Nothing    -> alwaysQualify
+       Just iface -> unQualInScope (mi_globals iface)
+ where
+    pit = pcs_PIT pcs
+    modname = moduleName (ic_module ic)
+
 -----------------------------------------------------------------------------
 -- cmTypeOfName: returns a string representing the type of a name.
 
@@ -259,15 +348,11 @@ cmTypeOfName :: CmState -> Name -> IO (Maybe String)
 cmTypeOfName CmState{ hit=hit, pcs=pcs, ic=ic } name
  = case lookupNameEnv (ic_type_env ic) name of
        Nothing -> return Nothing
-       Just (AnId id) -> 
-          let pit = pcs_PIT pcs
-              modname = moduleName (ic_module ic)
-              ty = tidyType emptyTidyEnv (idType id)
-              str = case lookupIfaceByModName hit pit modname of
-                       Nothing    -> showSDoc (ppr ty)
-                       Just iface -> showSDocForUser unqual (ppr ty)
-                          where unqual = unQualInScope (mi_globals iface)
-          in return (Just str)
+       Just (AnId id) -> return (Just str)
+          where
+            unqual = getUnqual pcs hit ic
+            ty = tidyType emptyTidyEnv (idType id)
+            str = showSDocForUser unqual (ppr ty)
 
        _ -> panic "cmTypeOfName"
 #endif
@@ -326,15 +411,17 @@ cmInfo cmstate str
 -- Unload the compilation manager's state: everything it knows about the
 -- current collection of modules in the Home package.
 
-cmUnload :: CmState -> IO CmState
-cmUnload state 
+cmUnload :: CmState -> DynFlags -> IO CmState
+cmUnload state@CmState{ gmode=mode, pls=pls, pcs=pcs } dflags
  = do -- Throw away the old home dir cache
       emptyHomeDirCache
-      -- Throw away the HIT and the HST
-      return state{ hst=new_hst, hit=new_hit, ui=emptyUI }
-   where
-     CmState{ hst=hst, hit=hit } = state
-     (new_hst, new_hit) = retainInTopLevelEnvs [] (hst,hit)
+
+      -- Unload everything the linker knows about
+      new_pls <- CmLink.unload mode dflags [] pls 
+
+      -- Start with a fresh CmState, but keep the PersistentCompilerState
+      new_state <- cmInit mode
+      return new_state{ pcs=pcs, pls=new_pls }
 
 -----------------------------------------------------------------------------
 -- The real business of the compilation manager: given a system state and
@@ -342,12 +429,12 @@ cmUnload state
 -- the system state at the same time.
 
 cmLoadModule :: CmState 
-             -> FilePath
+             -> [FilePath]
              -> IO (CmState,           -- new state
                    Bool,               -- was successful
                    [String])           -- list of modules loaded
 
-cmLoadModule cmstate1 rootname
+cmLoadModule cmstate1 rootnames
    = do -- version 1's are the original, before downsweep
         let pls1      = pls    cmstate1
         let pcs1      = pcs    cmstate1
@@ -367,9 +454,11 @@ cmLoadModule cmstate1 rootname
 
        showPass dflags "Chasing dependencies"
         when (verb >= 1 && ghci_mode == Batch) $
-           hPutStrLn stderr (progName ++ ": chasing modules from: " ++ rootname)
+           hPutStrLn stderr (showSDoc (hcat [
+            text progName, text ": chasing modules from: ",
+            hcat (punctuate comma (map text rootnames))]))
 
-        (mg2unsorted, a_root_is_Main) <- downsweep [rootname] mg1
+        (mg2unsorted, a_root_is_Main) <- downsweep rootnames mg1
         let mg2unsorted_names = map name_of_summary mg2unsorted
 
         -- reachable_from follows source as well as normal imports
@@ -388,6 +477,9 @@ cmLoadModule cmstate1 rootname
        -- See getValidLinkables below for details.
        valid_linkables <- getValidLinkables ui1 mg2unsorted_names 
                                mg2_with_srcimps
+       -- when (verb >= 2) $
+        --    putStrLn (showSDoc (text "Valid linkables:" 
+        --                      <+> ppr valid_linkables))
 
         -- Figure out a stable set of modules which can be retained
         -- the top level envs, to avoid upsweeping them.  Goes to a
@@ -415,7 +507,7 @@ cmLoadModule cmstate1 rootname
 
        -- 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
@@ -439,9 +531,13 @@ cmLoadModule cmstate1 rootname
 
         let threaded2 = CmThreaded pcs1 hst1 hit1
 
+       -- clean up between compilations
+       let cleanup = cleanTempFilesExcept verb 
+                         (ppFilesFromSummaries (flattenSCCs upsweep_these))
+
         (upsweep_complete_success, threaded3, modsUpswept, newLis)
            <- upsweep_mods ghci_mode dflags valid_linkables reachable_from 
-                           threaded2 upsweep_these
+                           threaded2 cleanup upsweep_these
 
         let ui3 = add_to_ui valid_linkables newLis
         let (CmThreaded pcs3 hst3 hit3) = threaded3
@@ -471,6 +567,13 @@ cmLoadModule cmstate1 rootname
              -- clean up after ourselves
              cleanTempFilesExcept verb (ppFilesFromSummaries modsDone)
 
+             -- issue a warning for the confusing case where the user said '-o foo'
+             -- but we're not going to do any linking.
+             ofile <- readIORef v_Output_file
+             when (ghci_mode == Batch && isJust ofile && not a_root_is_Main
+                    && verb > 0) $
+                hPutStrLn stderr "Warning: output was redirected with -o, but no output will be generated\nbecause there is no Main module."
+
              -- link everything together
               linkresult <- link ghci_mode dflags a_root_is_Main ui3 pls2
 
@@ -489,13 +592,14 @@ cmLoadModule cmstate1 rootname
               let mods_to_zap_names 
                      = findPartiallyCompletedCycles modsDone_names 
                          mg2_with_srcimps
-              let (hst4, hit4, ui4)
-                     = removeFromTopLevelEnvs mods_to_zap_names (hst3,hit3,ui3)
-
               let mods_to_keep
                      = filter ((`notElem` mods_to_zap_names).name_of_summary) 
                          modsDone
 
+              let (hst4, hit4, ui4)
+                     = retainInTopLevelEnvs (map name_of_summary mods_to_keep) 
+                                            (hst3,hit3,ui3)
+
              -- clean up after ourselves
              cleanTempFilesExcept verb (ppFilesFromSummaries mods_to_keep)
 
@@ -507,33 +611,43 @@ cmLoadModule cmstate1 rootname
 
 
 -- Finish up after a cmLoad.
---
+
+-- If the link failed, unload everything and return.
+cmLoadFinish ok (LinkFailed pls) hst hit ui mods ghci_mode pcs = do
+  dflags <- getDynFlags
+  new_pls <- CmLink.unload ghci_mode dflags [] pls 
+  new_state <- cmInit ghci_mode
+  return (new_state{ pcs=pcs, pls=new_pls }, False, [])
+
 -- Empty the interactive context and set the module context to the topmost
 -- newly loaded module, or the Prelude if none were loaded.
-cmLoadFinish ok linkresult hst hit ui mods ghci_mode pcs
-  = do case linkresult of {
-          LinkErrs _ _ -> panic "cmLoadModule: link failed (2)";
-          LinkOK pls   -> do
-
-       def_mod <- readIORef defaultCurrentModule
+cmLoadFinish ok (LinkOK pls) hst hit ui mods ghci_mode pcs
+  = do def_mod <- readIORef defaultCurrentModule
        let current_mod = case mods of 
                                []    -> def_mod
                                (x:_) -> ms_mod x
 
                   new_ic = emptyInteractiveContext current_mod
 
-           new_cmstate = CmState{ hst=hst, hit=hit, 
-                                  ui=ui, mg=mods,
-                                  gmode=ghci_mode, pcs=pcs, 
-                                 pls=pls,
+           new_cmstate = CmState{ hst=hst, hit=hit, ui=ui, mg=mods,
+                                  gmode=ghci_mode, pcs=pcs, pls=pls,
                                  ic = new_ic }
            mods_loaded = map (moduleNameUserString.name_of_summary) mods
 
        return (new_cmstate, ok, mods_loaded)
-    }
 
+-- used to fish out the preprocess output files for the purposes
+-- of cleaning up.
 ppFilesFromSummaries summaries
-  = [ fn | Just fn <- map (ml_hspp_file . ms_location) summaries ]
+  = [ fn | Just fn <- map toPpFile summaries ]
+  where
+   toPpFile sum
+     | hspp /= ml_hs_file loc = hspp
+     | otherwise              = Nothing
+    where
+      loc  = ms_location sum
+      hspp = ml_hspp_file loc
+
 
 -----------------------------------------------------------------------------
 -- getValidLinkables
@@ -569,7 +683,10 @@ getValidLinkablesSCC old_linkables all_home_mods new_linkables scc0
          scc             = flattenSCC scc0
           scc_names       = map name_of_summary scc
          home_module m   = m `elem` all_home_mods && m `notElem` scc_names
-          scc_allhomeimps = nub (filter home_module (concatMap ms_allimps scc))
+          scc_allhomeimps = nub (filter home_module (concatMap ms_imps scc))
+               -- NOTE: ms_imps, not ms_allimps above.  We don't want to
+               -- force a module's SOURCE imports to be already compiled for
+               -- its object linkable to be valid.
 
          has_object m = case findModuleLinkable_maybe new_linkables m of
                            Nothing -> False
@@ -610,8 +727,7 @@ getValidLinkable old_linkables objects_allowed new_linkables summary
                    Just l | not (isObjectLinkable l) || stillThere l 
                                -> old_linkable
                                -- ToDo: emit a warning if not (stillThere l)
-                          | otherwise
-                               -> Nothing
+                    other -> Nothing
 
           -- make sure that if we had an old disk linkable around, that it's
           -- still there on the disk (in case we need to re-link it).
@@ -631,12 +747,17 @@ getValidLinkable old_linkables objects_allowed new_linkables summary
            src_date = ms_hs_date summary
 
           valid_linkable
-             =  filter (\l -> linkableTime l > src_date) linkable
+             =  filter (\l -> linkableTime l >= src_date) linkable
+               -- why '>=' rather than '>' above?  If the filesystem stores
+               -- times to the nearset second, we may occasionally find that
+               -- the object & source have the same modification time, 
+               -- especially if the source was automatically generated
+               -- and compiled.  Using >= is slightly unsafe, but it matches
+               -- make's behaviour.
 
        return (valid_linkable ++ new_linkables)
 
 
-
 maybe_getFileLinkable :: ModuleName -> FilePath -> IO (Maybe Linkable)
 maybe_getFileLinkable mod_name obj_fn
    = do obj_exist <- doesFileExist obj_fn
@@ -755,6 +876,7 @@ upsweep_mods :: GhciMode
              -> UnlinkedImage         -- valid linkables
              -> (ModuleName -> [ModuleName])  -- to construct downward closures
              -> CmThreaded            -- PCS & HST & HIT
+            -> IO ()                 -- how to clean up unwanted tmp files
              -> [SCC ModSummary]      -- mods to do (the worklist)
                                       -- ...... RETURNING ......
              -> IO (Bool{-complete success?-},
@@ -762,17 +884,17 @@ upsweep_mods :: GhciMode
                     [ModSummary],     -- mods which succeeded
                     [Linkable])       -- new linkables
 
-upsweep_mods ghci_mode dflags oldUI reachable_from threaded 
+upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup
      []
    = return (True, threaded, [], [])
 
-upsweep_mods ghci_mode dflags oldUI reachable_from threaded 
+upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup
      ((CyclicSCC ms):_)
    = do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++
                           unwords (map (moduleNameUserString.name_of_summary) ms))
         return (False, threaded, [], [])
 
-upsweep_mods ghci_mode dflags oldUI reachable_from threaded 
+upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup
      ((AcyclicSCC mod):mods)
    = do --case threaded of
         --   CmThreaded pcsz hstz hitz
@@ -781,12 +903,16 @@ upsweep_mods ghci_mode dflags oldUI reachable_from threaded
         (threaded1, maybe_linkable) 
            <- upsweep_mod ghci_mode dflags oldUI threaded mod 
                           (reachable_from (name_of_summary mod))
+
+       -- remove unwanted tmp files between compilations
+       cleanup
+
         case maybe_linkable of
            Just linkable 
               -> -- No errors; do the rest
                  do (restOK, threaded2, modOKs, linkables) 
                        <- upsweep_mods ghci_mode dflags oldUI reachable_from 
-                                       threaded1 mods
+                                       threaded1 cleanup mods
                     return (restOK, threaded2, mod:modOKs, linkable:linkables)
            Nothing -- we got a compilation error; give up now
               -> return (False, threaded1, [], [])
@@ -820,10 +946,10 @@ upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me
           -- in interactive mode, all home modules below us *must* have an
           -- interface in the HIT.  We never demand-load home interfaces in
           -- interactive mode.
-            (hst1_strictDC, hit1_strictDC)
+            (hst1_strictDC, hit1_strictDC, [])
                = ASSERT(ghci_mode == Batch || 
                        all (`elemUFM` hit1) reachable_only)
-                retainInTopLevelEnvs reachable_only (hst1,hit1)
+                retainInTopLevelEnvs reachable_only (hst1,hit1,[])
 
             old_linkable 
                = unJust "upsweep_mod:old_linkable" maybe_old_linkable
@@ -855,22 +981,14 @@ upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me
              -> do let threaded2 = CmThreaded pcs2 hst1 hit1
                     return (threaded2, Nothing)
 
--- Remove unwanted modules from the top level envs (HST, HIT, UI).
-removeFromTopLevelEnvs :: [ModuleName]
-                       -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
-                       -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
-removeFromTopLevelEnvs zap_these (hst, hit, ui)
-   = (delListFromUFM hst zap_these,
-      delListFromUFM hit zap_these,
-      filterModuleLinkables (`notElem` zap_these) ui
-     )
-
+-- Filter modules in the top level envs (HST, HIT, UI).
 retainInTopLevelEnvs :: [ModuleName]
-                        -> (HomeSymbolTable, HomeIfaceTable)
-                        -> (HomeSymbolTable, HomeIfaceTable)
-retainInTopLevelEnvs keep_these (hst, hit)
+                        -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
+                        -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
+retainInTopLevelEnvs keep_these (hst, hit, ui)
    = (retainInUFM hst keep_these,
-      retainInUFM hit keep_these
+      retainInUFM hit keep_these,
+      filterModuleLinkables (`elem` keep_these) ui
      )
      where
         retainInUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
@@ -890,10 +1008,9 @@ downwards_closure_of_module summaries root
 
          res = simple_transitive_closure (map toEdge summaries) [root]
      in
-         --trace (showSDoc (text "DC of mod" <+> ppr root
-         --                 <+> text "=" <+> ppr res)) (
+--         trace (showSDoc (text "DC of mod" <+> ppr root
+--                          <+> text "=" <+> ppr res)) $
          res
-         --)
 
 -- Calculate transitive closures from a set of roots given an adjacency list
 simple_transitive_closure :: Eq a => [(a,[a])] -> [a] -> [a]
@@ -952,7 +1069,7 @@ downsweep rootNm old_summaries
      where
        getRootSummary :: FilePath -> IO ModSummary
        getRootSummary file
-          | haskellish_file file
+          | haskellish_src_file file
           = do exists <- doesFileExist file
                if exists then summariseFile file else do
                throwDyn (CmdLineError ("can't find file `" ++ file ++ "'"))    
@@ -1016,14 +1133,13 @@ downsweep rootNm old_summaries
 summariseFile :: FilePath -> IO ModSummary
 summariseFile file
    = do hspp_fn <- preprocess file
-        modsrc <- readFile hspp_fn
+        (srcimps,imps,mod_name) <- getImportsFromFile hspp_fn
 
-        let (srcimps,imps,mod_name) = getImports modsrc
-           (path, basename, ext) = splitFilename3 file
+        let (path, basename, ext) = splitFilename3 file
 
-       Just (mod, location)
+       (mod, location)
           <- mkHomeModuleLocn mod_name (path ++ '/':basename) file
-          
+
         src_timestamp
            <- case ml_hs_file location of 
                  Nothing     -> noHsFileErr mod_name
@@ -1037,13 +1153,15 @@ summariseFile file
 summarise :: Module -> ModuleLocation -> Maybe ModSummary
         -> IO (Maybe ModSummary)
 summarise mod location old_summary
-   | isHomeModule mod
+   | not (isHomeModule mod) = return Nothing
+   | otherwise
    = do let hs_fn = unJust "summarise" (ml_hs_file location)
 
-        src_timestamp
-           <- case ml_hs_file location of 
-                 Nothing     -> noHsFileErr mod
-                 Just src_fn -> getModificationTime src_fn
+        case ml_hs_file location of {
+           Nothing -> noHsFileErr mod;
+           Just src_fn -> do
+
+        src_timestamp <- getModificationTime src_fn
 
        -- return the cached summary if the source didn't change
        case old_summary of {
@@ -1051,23 +1169,22 @@ summarise mod location old_summary
           _ -> do
 
         hspp_fn <- preprocess hs_fn
-        modsrc <- readFile hspp_fn
-        let (srcimps,imps,mod_name) = getImports modsrc
+        (srcimps,imps,mod_name) <- getImportsFromFile hspp_fn
 
        when (mod_name /= moduleName mod) $
                throwDyn (ProgramError 
-                  (showSDoc (text modsrc
+                  (showSDoc (text hs_fn
                              <>  text ": file name does not match module name"
                              <+> quotes (ppr (moduleName mod)))))
 
         return (Just (ModSummary mod location{ml_hspp_file=Just hspp_fn} 
                                  srcimps imps src_timestamp))
         }
+      }
 
-   | otherwise = return Nothing
 
 noHsFileErr mod
-  = panic (showSDoc (text "no source file for module" <+> quotes (ppr mod)))
+  = throwDyn (CmdLineError (showSDoc (text "no source file for module" <+> quotes (ppr mod))))
 
 packageModErr mod
   = throwDyn (CmdLineError (showSDoc (text "module" <+>