Remove LazyUniqFM; fixes trac #3880

[ghc-hetmet.git] / compiler / main / GHC.hs

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 0be0fc4..b713bc8 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -254,8 +254,8 @@ import NameSet
 import RdrName
 import qualified HsSyn -- hack as we want to reexport the whole module
 import HsSyn hiding ((<.>))
-import Type             hiding (typeKind)
-import TcType           hiding (typeKind)
+import Type
+import TcType          hiding( typeKind )
 import Id
 import Var
 import TysPrim         ( alphaTyVars )
@@ -284,8 +284,7 @@ import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
                       cleanTempDirs )
 import Annotations
 import Module
-import LazyUniqFM
-import qualified UniqFM as UFM
+import UniqFM
 import FiniteMap
 import Panic
 import Digraph
@@ -300,7 +299,6 @@ import Maybes               ( expectJust, mapCatMaybes )
 import FastString
 import Lexer
 
-import Control.Concurrent
 import System.Directory ( getModificationTime, doesFileExist,
                           getCurrentDirectory )
 import Data.Maybe
@@ -353,6 +351,7 @@ defaultErrorHandler dflags inner =
                case ge of
                     PhaseFailed _ code -> exitWith code
                     Interrupted -> exitWith (ExitFailure 1)
+                    Signal _ -> exitWith (ExitFailure 1)
                     _ -> do fatalErrorMsg dflags (text (show ge))
                             exitWith (ExitFailure 1)
            ) $
@@ -454,8 +453,6 @@ runGhcT mb_top_dir ghct = do
 initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
 initGhcMonad mb_top_dir = do
   -- catch ^C
-  main_thread <- liftIO $ myThreadId
-  liftIO $ modifyMVar_ interruptTargetThread (return . (main_thread :))
   liftIO $ installSignalHandlers
 
   liftIO $ StaticFlags.initStaticOpts
@@ -1115,25 +1112,35 @@ loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
 loadModule tcm = do
    let ms = modSummary tcm
    let mod = ms_mod_name ms
+   let loc = ms_location ms
    let (tcg, _details) = tm_internals tcm
    hpt_new <-
        withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
 
          let compilerBackend comp env ms' _ _mb_old_iface _ =
                withTempSession (\_ -> env) $
-                 hscBackend comp tcg ms'
-                            Nothing
+                 hscBackend comp tcg ms' Nothing
+
          hsc_env <- getSession
-         mod_info
-             <- compile' (compilerBackend hscNothingCompiler
-                         ,compilerBackend hscInteractiveCompiler
-                         ,compilerBackend hscBatchCompiler)
-                         hsc_env ms 1 1 Nothing Nothing
+         mod_info <- do
+             mb_linkable <- 
+                  case ms_obj_date ms of
+                     Just t | t > ms_hs_date ms  -> do
+                         l <- liftIO $ findObjectLinkable (ms_mod ms) 
+                                                  (ml_obj_file loc) t
+                         return (Just l)
+                     _otherwise -> return Nothing
+                                                
+             compile' (compilerBackend hscNothingCompiler
+                      ,compilerBackend hscInteractiveCompiler
+                      ,hscCheckRecompBackend hscBatchCompiler tcg)
+                      hsc_env ms 1 1 Nothing mb_linkable
          -- compile' shouldn't change the environment
          return $ addToUFM (hsc_HPT hsc_env) mod mod_info
    modifySession $ \e -> e{ hsc_HPT = hpt_new }
    return tcm
 
+
 -- | This is the way to get access to the Core bindings corresponding
 -- to a module. 'compileToCore' parses, typechecks, and
 -- desugars the module, then returns the resulting Core module (consisting of
@@ -2525,7 +2532,7 @@ packageDbModules :: GhcMonad m =>
                  -> m [Module]
 packageDbModules only_exposed = do
    dflags <- getSessionDynFlags
-   let pkgs = UFM.eltsUFM (pkgIdMap (pkgState dflags))
+   let pkgs = eltsUFM (pkgIdMap (pkgState dflags))
    return $
      [ mkModule pid modname | p <- pkgs
                             , not only_exposed || exposed p
@@ -2580,7 +2587,7 @@ getModuleSourceAndFlags mod = do
 getTokenStream :: GhcMonad m => Module -> m [Located Token]
 getTokenStream mod = do
   (sourceFile, source, flags) <- getModuleSourceAndFlags mod
-  let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
+  let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream source startLoc flags of
     POk _ ts  -> return ts
     PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
@@ -2591,7 +2598,7 @@ getTokenStream mod = do
 getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
 getRichTokenStream mod = do
   (sourceFile, source, flags) <- getModuleSourceAndFlags mod
-  let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
+  let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream source startLoc flags of
     POk _ ts -> return $ addSourceToTokens startLoc source ts
     PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
@@ -2622,7 +2629,7 @@ addSourceToTokens loc buf (t@(L span _) : ts)
 showRichTokenStream :: [(Located Token, String)] -> String
 showRichTokenStream ts = go startLoc ts ""
     where sourceFile = srcSpanFile (getLoc . fst . head $ ts)
-          startLoc = mkSrcLoc sourceFile 0 0
+          startLoc = mkSrcLoc sourceFile 1 1
           go _ [] = id
           go loc ((L span _, str):ts)
               | not (isGoodSrcSpan span) = go loc ts