Generalise Package Support

[ghc-hetmet.git] / compiler / main / HscMain.lhs

diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index e170f8f..e5b7026 100644 (file)
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -41,13 +41,13 @@ import PrelNames    ( iNTERACTIVE )
 import Kind            ( Kind )
 import CoreLint                ( lintUnfolding )
 import DsMeta          ( templateHaskellNames )
-import SrcLoc          ( noSrcLoc )
+import SrcLoc          ( noSrcLoc, getLoc )
 import VarEnv          ( emptyTidyEnv )
 #endif
 
 import Var             ( Id )
 import Module          ( emptyModuleEnv, ModLocation(..) )
-import RdrName         ( GlobalRdrEnv, RdrName )
+import RdrName         ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv )
 import HsSyn           ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl )
 import SrcLoc          ( Located(..) )
 import StringBuffer    ( hGetStringBuffer, stringToStringBuffer )
@@ -68,12 +68,12 @@ import TidyPgm              ( tidyProgram, mkBootModDetails )
 import CorePrep                ( corePrepPgm )
 import CoreToStg       ( coreToStg )
 import TyCon           ( isDataTyCon )
-import Packages                ( mkHomeModules )
 import Name            ( Name, NamedThing(..) )
 import SimplStg                ( stg2stg )
 import CodeGen         ( codeGen )
 import CmmParse                ( parseCmmFile )
 import CodeOutput      ( codeOutput )
+import NameEnv          ( emptyNameEnv )
 
 import DynFlags
 import ErrUtils
@@ -86,7 +86,7 @@ import MkExternalCore ( emitExternalCore )
 import ParserCore
 import ParserCoreUtils
 import FastString
-import Maybes          ( expectJust )
+import UniqFM          ( emptyUFM )
 import Bag             ( unitBag )
 import Monad           ( unless )
 import IO
@@ -106,7 +106,8 @@ newHscEnv dflags
   = do         { eps_var <- newIORef initExternalPackageState
        ; us      <- mkSplitUniqSupply 'r'
        ; nc_var  <- newIORef (initNameCache us knownKeyNames)
-       ; fc_var  <- newIORef emptyModuleEnv
+       ; fc_var  <- newIORef emptyUFM
+       ; mlc_var  <- newIORef emptyModuleEnv
        ; return (HscEnv { hsc_dflags = dflags,
                           hsc_targets = [],
                           hsc_mod_graph = [],
@@ -114,7 +115,10 @@ newHscEnv dflags
                           hsc_HPT    = emptyHomePackageTable,
                           hsc_EPS    = eps_var,
                           hsc_NC     = nc_var,
-                          hsc_FC     = fc_var } ) }
+                          hsc_FC     = fc_var,
+                          hsc_MLC    = mlc_var,
+                           hsc_global_rdr_env = emptyGlobalRdrEnv,
+                           hsc_global_type_env = emptyNameEnv } ) }
                        
 
 knownKeyNames :: [Name]        -- Put here to avoid loops involving DsMeta,
@@ -214,6 +218,9 @@ data CompState
 get :: Comp CompState
 get = Comp $ \s -> return (s,s)
 
+modify :: (CompState -> CompState) -> Comp ()
+modify f = Comp $ \s -> return ((), f s)
+
 gets :: (CompState -> a) -> Comp a
 gets getter = do st <- get
                  return (getter st)
@@ -250,6 +257,10 @@ hscMkCompiler norecomp messenger frontend backend
              <- {-# SCC "checkOldIface" #-}
                 liftIO $ checkOldIface hsc_env mod_summary
                               source_unchanged mbOldIface
+        -- save the interface that comes back from checkOldIface.
+        -- In one-shot mode we don't have the old iface until this
+        -- point, when checkOldIface reads it from the disk.
+        modify (\s -> s{ compOldIface = mbCheckedIface })
          case mbCheckedIface of 
            Just iface | not recomp_reqd
                -> do messenger mbModIndex False
@@ -387,9 +398,9 @@ batchMsg mb_mod_index recomp
          liftIO $ do
          if recomp
             then showMsg "Compiling "
-            else showMsg "Skipping  "
-
-
+            else if verbosity (hsc_dflags hsc_env) >= 2
+                    then showMsg "Skipping  "
+                    else return ()
 
 --------------------------------------------------------------
 -- FrontEnds
@@ -516,7 +527,7 @@ hscNormalIface simpl_result
                <- {-# SCC "MkFinalIface" #-}
                   mkIface hsc_env maybe_old_iface simpl_result details
        -- Emit external core
-       emitExternalCore (hsc_dflags hsc_env) cg_guts -- Move this? --Lemmih 03/07/2006
+       emitExternalCore (hsc_dflags hsc_env) (mg_exports simpl_result) cg_guts -- Move this? --Lemmih 03/07/2006
        dumpIfaceStats hsc_env
 
            -------------------
@@ -569,7 +580,6 @@ hscCompile cgguts
                      cg_tycons   = tycons,
                      cg_dir_imps = dir_imps,
                      cg_foreign  = foreign_stubs,
-                     cg_home_mods = home_mods,
                      cg_dep_pkgs = dependencies } = cgguts
              dflags = hsc_dflags hsc_env
              location = ms_location mod_summary
@@ -585,10 +595,10 @@ hscCompile cgguts
          -----------------  Convert to STG ------------------
          (stg_binds, cost_centre_info)
              <- {-# SCC "CoreToStg" #-}
-                myCoreToStg dflags home_mods this_mod prepd_binds      
+                myCoreToStg dflags this_mod prepd_binds        
          ------------------  Code generation ------------------
          abstractC <- {-# SCC "CodeGen" #-}
-                      codeGen dflags home_mods this_mod data_tycons
+                      codeGen dflags this_mod data_tycons
                               foreign_stubs dir_imps cost_centre_info
                               stg_binds
          ------------------  Code output -----------------------
@@ -686,7 +696,7 @@ hscFileCheck hsc_env mod_summary = do {
 
 hscCmmFile :: DynFlags -> FilePath -> IO Bool
 hscCmmFile dflags filename = do
-  maybe_cmm <- parseCmmFile dflags (mkHomeModules []) filename
+  maybe_cmm <- parseCmmFile dflags filename
   case maybe_cmm of
     Nothing -> return False
     Just cmm -> do
@@ -729,13 +739,13 @@ myParseModule dflags src_filename maybe_src_buf
       }}
 
 
-myCoreToStg dflags home_mods this_mod prepd_binds
+myCoreToStg dflags this_mod prepd_binds
  = do 
       stg_binds <- {-# SCC "Core2Stg" #-}
-            coreToStg home_mods prepd_binds
+            coreToStg (thisPackage dflags) prepd_binds
 
       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
-            stg2stg dflags home_mods this_mod stg_binds
+            stg2stg dflags this_mod stg_binds
 
       return (stg_binds2, cost_centre_info)
 \end{code}
@@ -891,7 +901,8 @@ compileExpr :: HscEnv
 
 compileExpr hsc_env this_mod rdr_env type_env tc_expr
   = do { let { dflags  = hsc_dflags hsc_env ;
-               lint_on = dopt Opt_DoCoreLinting dflags }
+               lint_on = dopt Opt_DoCoreLinting dflags ;
+               !srcspan = getLoc tc_expr }
              
                -- Desugar it
        ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
@@ -921,7 +932,7 @@ compileExpr hsc_env this_mod rdr_env type_env tc_expr
        ; bcos <- coreExprToBCOs dflags prepd_expr
 
                -- link it
-       ; hval <- linkExpr hsc_env bcos
+       ; hval <- linkExpr hsc_env srcspan bcos
 
        ; return hval
      }