X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=933503e4915742d14184463212503051a61a4b62;hp=9f91b4d6ba336a4f56c7715c3d7ca4cf085b3516;hb=b017f34bebf1588e5e579d7c653413e2a4c2d170;hpb=a21998556af1e827b9462d2cdc46005e90fb7fd2

diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 9f91b4d..933503e 100644
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -14,7 +14,7 @@ module HscMain
     , hscSimplify
     , hscNormalIface, hscWriteIface, hscGenHardCode
 #ifdef GHCI
-    , hscStmt, hscTcExpr, hscKcType
+    , hscStmt, hscTcExpr, hscImport, hscKcType
     , compileExpr
 #endif
     , HsCompiler(..)
@@ -24,6 +24,7 @@ module HscMain
     , hscCompileBatch       -- :: Compiler (HscStatus, ModIface, ModDetails)
     , hscCompileNothing     -- :: Compiler (HscStatus, ModIface, ModDetails)
     , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails)
+    , hscCheckRecompBackend
     , HscStatus' (..)
     , InteractiveStatus, HscStatus
 
@@ -50,7 +51,7 @@ import PrelNames	( iNTERACTIVE )
 import {- Kind parts of -} Type		( Kind )
 import CoreLint		( lintUnfolding )
 import DsMeta		( templateHaskellNames )
-import SrcLoc		( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan )
+import SrcLoc		( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan, unLoc )
 import VarSet
 import VarEnv		( emptyTidyEnv )
 #endif
@@ -108,7 +109,7 @@ import HscStats		( ppSourceStats )
 import HscTypes
 import MkExternalCore	( emitExternalCore )
 import FastString
-import LazyUniqFM		( emptyUFM )
+import UniqFM		( emptyUFM )
 import UniqSupply       ( initUs_ )
 import Bag		( unitBag )
 import Exception
@@ -185,7 +186,7 @@ hscParse mod_summary = do
 
    let loc  = mkSrcLoc (mkFastString src_filename) 1 1
 
-   case unP parseModule (mkPState buf loc dflags) of
+   case unP parseModule (mkPState dflags buf loc) of
      PFailed span err ->
          throwOneError (mkPlainErrMsg span err)
 
@@ -382,6 +383,22 @@ genericHscCompile compiler hscMessage
            -> do hscMessage mb_mod_index True mod_summary
                  hscRecompile compiler mod_summary mb_old_hash
 
+hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a
+hscCheckRecompBackend compiler tc_result 
+                   hsc_env mod_summary source_unchanged mb_old_iface _m_of_n =
+   withTempSession (\_ -> hsc_env) $ do
+     (recomp_reqd, mb_checked_iface)
+         <- {-# SCC "checkOldIface" #-}
+            liftIO $ checkOldIface hsc_env mod_summary
+                                   source_unchanged mb_old_iface
+
+     let mb_old_hash = fmap mi_iface_hash mb_checked_iface
+     case mb_checked_iface of
+       Just iface | not recomp_reqd
+           -> hscNoRecomp compiler iface{ mi_globals = Just (tcg_rdr_env tc_result) }
+       _otherwise
+           -> hscBackend compiler tc_result mod_summary mb_old_hash
+
 genericHscRecompile :: GhcMonad m =>
                        HsCompiler a
                     -> ModSummary -> Maybe Fingerprint
@@ -418,7 +435,12 @@ hscOneShotCompiler =
 
   , hscRecompile = genericHscRecompile hscOneShotCompiler
 
-  , hscBackend = genericHscBackend hscOneShotCompiler
+  , hscBackend = \ tc_result mod_summary mb_old_hash -> do
+       hsc_env <- getSession
+       case hscTarget (hsc_dflags hsc_env) of
+         HscNothing -> return (HscRecomp False ())
+         _otherw    -> genericHscBackend hscOneShotCompiler 
+                                         tc_result mod_summary mb_old_hash
 
   , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
        (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
@@ -519,13 +541,7 @@ hscNothingCompiler =
        details <- genModDetails iface
        return (HscNoRecomp, iface, details)
 
-  , hscRecompile = \mod_summary mb_old_hash ->
-      case ms_hsc_src mod_summary of
-        ExtCoreFile ->
-          panic "hscCompileNothing: cannot do external core"
-        _otherwise -> do
-          tc_result <- hscFileFrontEnd mod_summary
-          hscBackend hscNothingCompiler tc_result mod_summary mb_old_hash
+  , hscRecompile = genericHscRecompile hscNothingCompiler
 
   , hscBackend = \tc_result _mod_summary mb_old_iface -> do
        (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
@@ -915,6 +931,12 @@ hscStmt hsc_env stmt = do
 
 	return $ Just (ids, hval)
 
+hscImport :: GhcMonad m => HscEnv -> String -> m (ImportDecl RdrName)
+hscImport hsc_env str = do
+    (L _ (HsModule{hsmodImports=is})) <- hscParseThing parseModule (hsc_dflags hsc_env) str
+    case is of
+        [i] -> return (unLoc i)
+        _ -> throwOneError (mkPlainErrMsg noSrcSpan (ptext (sLit "parse error in import declaration")))
 
 hscTcExpr	-- Typecheck an expression (but don't run it)
   :: GhcMonad m =>
@@ -974,7 +996,7 @@ hscParseThing parser dflags str
 
       let loc  = mkSrcLoc (fsLit "<interactive>") 1 1
 
-      case unP parser (mkPState buf loc dflags) of
+      case unP parser (mkPState dflags buf loc) of
 
 	PFailed span err -> do
           let msg = mkPlainErrMsg span err