X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscMain.lhs;h=10c946beb1f3d3a78842f83a70ae566d79276f4d;hb=1f19d1989866ec3c42083e5a4612248842f07814;hp=83837ee73e6fb74acbab3d7b9df942da26339686;hpb=d551dbfef0b710f5ede21ee0c54ee7e80dd53b64;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 83837ee..10c946b 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -9,9 +9,9 @@ module HscMain (
 	HscResult(..),
 	hscMain, newHscEnv, hscCmmFile, 
 	hscFileCheck,
+	hscParseIdentifier,
 #ifdef GHCI
 	hscStmt, hscTcExpr, hscKcType,
-	hscGetInfo, GetInfoResult,
 	compileExpr,
 #endif
 	) where
@@ -19,50 +19,48 @@ module HscMain (
 #include "HsVersions.h"
 
 #ifdef GHCI
-import HsSyn		( Stmt(..), LStmt, LHsExpr, LHsType )
-import IfaceSyn		( IfaceDecl, IfaceInst )
+import HsSyn		( Stmt(..), LHsExpr, LStmt, LHsType )
 import Module		( Module )
 import CodeOutput	( outputForeignStubs )
 import ByteCodeGen	( byteCodeGen, coreExprToBCOs )
 import Linker		( HValue, linkExpr )
-import TidyPgm		( tidyCoreExpr )
+import CoreTidy		( tidyExpr )
 import CorePrep		( corePrepExpr )
 import Flattening	( flattenExpr )
-import TcRnDriver	( tcRnStmt, tcRnExpr, tcRnGetInfo, GetInfoResult, tcRnType ) 
-import RdrName		( rdrNameOcc )
-import OccName		( occNameUserString )
+import TcRnDriver	( tcRnStmt, tcRnExpr, tcRnType ) 
 import Type		( Type )
 import PrelNames	( iNTERACTIVE )
-import StringBuffer	( stringToStringBuffer )
 import Kind		( Kind )
 import CoreLint		( lintUnfolding )
 import DsMeta		( templateHaskellNames )
-import BasicTypes	( Fixity )
-import SrcLoc		( SrcLoc, noSrcLoc )
+import SrcLoc		( noSrcLoc )
+import VarEnv		( emptyTidyEnv )
 #endif
 
 import Var		( Id )
 import Module		( emptyModuleEnv )
 import RdrName		( GlobalRdrEnv, RdrName )
-import HsSyn		( HsModule, LHsBinds )
+import HsSyn		( HsModule, LHsBinds, HsGroup )
 import SrcLoc		( Located(..) )
-import StringBuffer	( hGetStringBuffer )
+import StringBuffer	( hGetStringBuffer, stringToStringBuffer )
 import Parser
 import Lexer		( P(..), ParseResult(..), mkPState )
 import SrcLoc		( mkSrcLoc )
 import TcRnDriver	( tcRnModule, tcRnExtCore )
-import TcRnTypes	( TcGblEnv(..) )
 import TcIface		( typecheckIface )
+import TcRnMonad	( initIfaceCheck, TcGblEnv(..) )
 import IfaceEnv		( initNameCache )
 import LoadIface	( ifaceStats, initExternalPackageState )
 import PrelInfo		( wiredInThings, basicKnownKeyNames )
-import MkIface		( checkOldIface, mkIface )
+import MkIface		( checkOldIface, mkIface, writeIfaceFile )
 import Desugar
 import Flattening       ( flatten )
 import SimplCore
-import TidyPgm		( tidyCorePgm )
+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 )
@@ -70,7 +68,6 @@ import CmmParse		( parseCmmFile )
 import CodeOutput	( codeOutput )
 
 import DynFlags
-import DriverPhases     ( HscSource(..) )
 import ErrUtils
 import UniqSupply	( mkSplitUniqSupply )
 
@@ -82,9 +79,7 @@ import ParserCore
 import ParserCoreUtils
 import FastString
 import Maybes		( expectJust )
-import StringBuffer	( StringBuffer )
 import Bag		( unitBag, emptyBag )
-
 import Monad		( when )
 import Maybe		( isJust )
 import IO
@@ -137,7 +132,10 @@ data HscResult
    = HscFail
 
    -- In IDE mode: we just do the static/dynamic checks
-   | HscChecked (Located (HsModule RdrName)) (Maybe (LHsBinds Id, GlobalRdrEnv))
+   | HscChecked 
+	(Located (HsModule RdrName))			-- parsed
+	(Maybe (HsGroup Name))				-- renamed
+	(Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails)) -- typechecked
 
    -- Concluded that it wasn't necessary
    | HscNoRecomp ModDetails  	         -- new details (HomeSymbolTable additions)
@@ -164,10 +162,12 @@ hscMain
   -> Bool		-- True <=> source unchanged
   -> Bool		-- True <=> have an object file (for msgs only)
   -> Maybe ModIface	-- Old interface, if available
+  -> Maybe (Int, Int)   -- Just (i,n) <=> module i of n (for msgs)
   -> IO HscResult
 
 hscMain hsc_env msg_act mod_summary
 	source_unchanged have_object maybe_old_iface
+        mb_mod_index
  = do {
       (recomp_reqd, maybe_checked_iface) <- 
 		{-# SCC "checkOldIface" #-}
@@ -180,13 +180,14 @@ hscMain hsc_env msg_act mod_summary
 
       ; what_next hsc_env msg_act mod_summary have_object 
 		  maybe_checked_iface
+                  mb_mod_index
       }
 
 
 ------------------------------
--- hscNoRecomp definitely expects to have the old interface available
 hscNoRecomp hsc_env msg_act mod_summary 
 	    have_object (Just old_iface)
+            mb_mod_index
  | isOneShot (ghcMode (hsc_dflags hsc_env))
  = do {
       compilationProgressMsg (hsc_dflags hsc_env) $
@@ -198,30 +199,39 @@ hscNoRecomp hsc_env msg_act mod_summary
       }
  | otherwise
  = do	{ compilationProgressMsg (hsc_dflags hsc_env) $
-		("Skipping  " ++ showModMsg have_object mod_summary)
+		(showModuleIndex mb_mod_index ++ 
+                 "Skipping  " ++ showModMsg have_object mod_summary)
 
 	; new_details <- {-# SCC "tcRnIface" #-}
-		     typecheckIface hsc_env old_iface ;
+		         initIfaceCheck hsc_env $
+			 typecheckIface old_iface ;
 	; dumpIfaceStats hsc_env
 
 	; return (HscNoRecomp new_details old_iface)
     }
 
+hscNoRecomp hsc_env msg_act mod_summary 
+	    have_object Nothing
+	    mb_mod_index
+  = panic "hscNoRecomp"	-- hscNoRecomp definitely expects to 
+			-- have the old interface available
+
 ------------------------------
 hscRecomp hsc_env msg_act mod_summary
-	  have_object maybe_checked_iface
+	  have_object maybe_old_iface
+          mb_mod_index
  = case ms_hsc_src mod_summary of
      HsSrcFile -> do 
-	front_res <- hscFileFrontEnd hsc_env msg_act mod_summary
-	hscBackEnd hsc_env mod_summary maybe_checked_iface front_res
+	front_res <- hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index
+	hscBackEnd hsc_env mod_summary maybe_old_iface front_res
 
      HsBootFile -> do
-	front_res <- hscFileFrontEnd hsc_env msg_act mod_summary
-	hscBootBackEnd hsc_env mod_summary maybe_checked_iface front_res
+	front_res <- hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index
+	hscBootBackEnd hsc_env mod_summary maybe_old_iface front_res
 
      ExtCoreFile -> do
 	front_res <- hscCoreFrontEnd hsc_env msg_act mod_summary
-	hscBackEnd hsc_env mod_summary maybe_checked_iface front_res
+	hscBackEnd hsc_env mod_summary maybe_old_iface front_res
 
 hscCoreFrontEnd hsc_env msg_act mod_summary = do {
  	    -------------------
@@ -244,7 +254,7 @@ hscCoreFrontEnd hsc_env msg_act mod_summary = do {
 	}}
 	 
 
-hscFileFrontEnd hsc_env msg_act mod_summary = do {
+hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index = do {
  	    -------------------
  	    -- DISPLAY PROGRESS MESSAGE
  	    -------------------
@@ -253,7 +263,8 @@ hscFileFrontEnd hsc_env msg_act mod_summary = do {
 	; let toInterp  = hscTarget dflags == HscInterpreted
       	; when (not one_shot) $
 		 compilationProgressMsg dflags $
-		 ("Compiling " ++ showModMsg (not toInterp) mod_summary)
+		 (showModuleIndex mb_mod_index ++
+                  "Compiling " ++ showModMsg (not toInterp) mod_summary)
 			
  	    -------------------
  	    -- PARSE
@@ -273,7 +284,7 @@ hscFileFrontEnd hsc_env msg_act mod_summary = do {
  	    -------------------
 	  (tc_msgs, maybe_tc_result) 
 		<- {-# SCC "Typecheck-Rename" #-}
-		   tcRnModule hsc_env (ms_hsc_src mod_summary) rdr_module
+		   tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
 
 	; msg_act tc_msgs
 	; case maybe_tc_result of {
@@ -286,9 +297,7 @@ hscFileFrontEnd hsc_env msg_act mod_summary = do {
 	; (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-}
 		 	     deSugar hsc_env tc_result
 	; msg_act (warns, emptyBag)
-	; case maybe_ds_result of
-	    Nothing        -> return Nothing
-	    Just ds_result -> return (Just ds_result)
+	; return maybe_ds_result
 	}}}}}
 
 ------------------------------
@@ -313,45 +322,57 @@ hscFileCheck hsc_env msg_act mod_summary = do {
  	    -------------------
 	  (tc_msgs, maybe_tc_result) 
 		<- _scc_ "Typecheck-Rename" 
-		   tcRnModule hsc_env (ms_hsc_src mod_summary) rdr_module
+		   tcRnModule hsc_env (ms_hsc_src mod_summary) 
+			True{-save renamed syntax-}
+			rdr_module
 
 	; msg_act tc_msgs
 	; case maybe_tc_result of {
-      	     Nothing -> return (HscChecked rdr_module Nothing);
-      	     Just tc_result -> return (HscChecked rdr_module 
-					(Just (tcg_binds tc_result,
-					       tcg_rdr_env tc_result)))
-	}}}}    
+      	     Nothing -> return (HscChecked rdr_module Nothing Nothing);
+      	     Just tc_result -> do
+		let md = ModDetails { 
+				md_types   = tcg_type_env tc_result,
+				md_exports = tcg_exports  tc_result,
+				md_insts   = tcg_insts    tc_result,
+				md_rules   = [panic "no rules"] }
+				   -- Rules are CoreRules, not the
+				   -- RuleDecls we get out of the typechecker
+		return (HscChecked rdr_module 
+				   (tcg_rn_decls tc_result)
+				   (Just (tcg_binds tc_result,
+					  tcg_rdr_env tc_result,
+					  md)))
+	}}}}
 
 ------------------------------
 hscBootBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO HscResult
 -- For hs-boot files, there's no code generation to do
 
-hscBootBackEnd hsc_env mod_summary maybe_checked_iface Nothing 
+hscBootBackEnd hsc_env mod_summary maybe_old_iface Nothing 
   = return HscFail
-hscBootBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result)
-  = do	{ final_iface <- {-# SCC "MkFinalIface" #-}
-			 mkIface hsc_env (ms_location mod_summary)
-                         	 maybe_checked_iface ds_result
-
-	; let { final_details = ModDetails { md_types = mg_types ds_result,
-					     md_insts = mg_insts ds_result,
-					     md_rules = mg_rules ds_result } }
+hscBootBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result)
+  = do	{ details <- mkBootModDetails hsc_env ds_result
+
+	; (new_iface, no_change) 
+		<- {-# SCC "MkFinalIface" #-}
+		   mkIface hsc_env maybe_old_iface ds_result details
+
+	; writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change
+
       	  -- And the answer is ...
 	; dumpIfaceStats hsc_env
 
-	; return (HscRecomp final_details
-			    final_iface
+	; return (HscRecomp details new_iface
                             False False Nothing)
  	}
 
 ------------------------------
 hscBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO HscResult
 
-hscBackEnd hsc_env mod_summary maybe_checked_iface Nothing 
+hscBackEnd hsc_env mod_summary maybe_old_iface Nothing 
   = return HscFail
 
-hscBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result) 
+hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result) 
   = do 	{ 	-- OMITTED: 
 		-- ; seqList imported_modules (return ())
 
@@ -397,11 +418,8 @@ hscBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result)
  	    -------------------
  	    -- TIDY
  	    -------------------
-	; tidy_result <- {-# SCC "CoreTidy" #-}
-		         tidyCorePgm hsc_env simpl_result
-
-	-- Emit external core
-	; emitExternalCore dflags tidy_result
+	; (cg_guts, details) <- {-# SCC "CoreTidy" #-}
+			         tidyProgram hsc_env simpl_result
 
 	-- Alive at this point:  
 	--	tidy_result, pcs_final
@@ -413,30 +431,30 @@ hscBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result)
 	    -- This has to happen *after* code gen so that the back-end
 	    -- info has been set.  Not yet clear if it matters waiting
 	    -- until after code output
-	; new_iface <- {-# SCC "MkFinalIface" #-}
-			mkIface hsc_env (ms_location mod_summary)
-                         	maybe_checked_iface tidy_result
+	; (new_iface, no_change)
+		<- {-# SCC "MkFinalIface" #-}
+		   mkIface hsc_env maybe_old_iface simpl_result details
+
+	; writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change
 
 	    -- Space leak reduction: throw away the new interface if
 	    -- we're in one-shot mode; we won't be needing it any
 	    -- more.
-	; final_iface <-
-	     if one_shot then return (error "no final iface")
+	; final_iface <- if one_shot then return (error "no final iface")
 			 else return new_iface
 
 	    -- Build the final ModDetails (except in one-shot mode, where
 	    -- we won't need this information after compilation).
-	; final_details <- 
-	     if one_shot then return (error "no final details")
-		 	 else return $! ModDetails { 
-					   md_types = mg_types tidy_result,
-					   md_insts = mg_insts tidy_result,
-					   md_rules = mg_rules tidy_result }
+	; final_details <- if one_shot then return (error "no final details")
+		 	   else return $! details
+
+	-- Emit external core
+	; emitExternalCore dflags cg_guts
 
  	    -------------------
  	    -- CONVERT TO STG and COMPLETE CODE GENERATION
 	; (stub_h_exists, stub_c_exists, maybe_bcos)
-		<- hscCodeGen dflags tidy_result
+		<- hscCodeGen dflags cg_guts
 
       	  -- And the answer is ...
 	; dumpIfaceStats hsc_env
@@ -450,20 +468,25 @@ hscBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result)
 
 
 hscCodeGen dflags 
-    ModGuts{  -- This is the last use of the ModGuts in a compilation.
+    CgGuts{  -- This is the last use of the ModGuts in a compilation.
 	      -- From now on, we just use the bits we need.
-        mg_module   = this_mod,
-	mg_binds    = core_binds,
-	mg_types    = type_env,
-	mg_dir_imps = dir_imps,
-	mg_foreign  = foreign_stubs,
-	mg_deps     = dependencies     }  = do {
+        cg_module   = this_mod,
+	cg_binds    = core_binds,
+	cg_tycons   = tycons,
+	cg_dir_imps = dir_imps,
+	cg_foreign  = foreign_stubs,
+	cg_home_mods = home_mods,
+	cg_dep_pkgs = dependencies     }  = do {
+
+  let { data_tycons = filter isDataTyCon tycons } ;
+	-- cg_tycons includes newtypes, for the benefit of External Core,
+	-- but we don't generate any code for newtypes
 
  	    -------------------
  	    -- PREPARE FOR CODE GENERATION
 	    -- Do saturation and convert to A-normal form
   prepd_binds <- {-# SCC "CorePrep" #-}
-		 corePrepPgm dflags core_binds type_env;
+		 corePrepPgm dflags core_binds data_tycons ;
 
   case hscTarget dflags of
       HscNothing -> return (False, False, Nothing)
@@ -471,7 +494,7 @@ hscCodeGen dflags
       HscInterpreted ->
 #ifdef GHCI
 	do  -----------------  Generate byte code ------------------
-	    comp_bc <- byteCodeGen dflags prepd_binds type_env
+	    comp_bc <- byteCodeGen dflags prepd_binds data_tycons
 	
 	    ------------------ Create f-x-dynamic C-side stuff ---
 	    (istub_h_exists, istub_c_exists) 
@@ -486,12 +509,13 @@ hscCodeGen dflags
 	do
 	    -----------------  Convert to STG ------------------
 	    (stg_binds, cost_centre_info) <- {-# SCC "CoreToStg" #-}
-	    		 myCoreToStg dflags this_mod prepd_binds	
+	    		 myCoreToStg dflags home_mods this_mod prepd_binds	
 
             ------------------  Code generation ------------------
 	    abstractC <- {-# SCC "CodeGen" #-}
-		         codeGen dflags this_mod type_env foreign_stubs
-				 dir_imps cost_centre_info stg_binds
+		         codeGen dflags home_mods this_mod data_tycons
+				 foreign_stubs dir_imps cost_centre_info
+				 stg_binds
 
 	    ------------------  Code output -----------------------
 	    (stub_h_exists, stub_c_exists)
@@ -504,11 +528,11 @@ hscCodeGen dflags
 
 hscCmmFile :: DynFlags -> FilePath -> IO Bool
 hscCmmFile dflags filename = do
-  maybe_cmm <- parseCmmFile dflags filename
+  maybe_cmm <- parseCmmFile dflags (mkHomeModules []) filename
   case maybe_cmm of
     Nothing -> return False
     Just cmm -> do
-	codeOutput dflags no_mod NoStubs noDependencies [cmm]
+	codeOutput dflags no_mod NoStubs [] [cmm]
 	return True
   where
 	no_mod = panic "hscCmmFile: no_mod"
@@ -544,13 +568,13 @@ myParseModule dflags src_filename maybe_src_buf
       }}
 
 
-myCoreToStg dflags this_mod prepd_binds
+myCoreToStg dflags home_mods this_mod prepd_binds
  = do 
       stg_binds <- {-# SCC "Core2Stg" #-}
-	     coreToStg dflags prepd_binds
+	     coreToStg home_mods prepd_binds
 
       (stg_binds2, cost_centre_info) <- {-# SCC "Core2Stg" #-}
-	     stg2stg dflags this_mod stg_binds
+	     stg2stg dflags home_mods this_mod stg_binds
 
       return (stg_binds2, cost_centre_info)
 \end{code}
@@ -648,14 +672,17 @@ hscKcType hsc_env str
 	     Just other -> do { errorMsg ("not an type: `" ++ str ++ "'") ;
 			        return Nothing } ;
       	     Nothing    -> return Nothing } }
+#endif
 \end{code}
 
 \begin{code}
+#ifdef GHCI
 hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
 hscParseStmt = hscParseThing parseStmt
 
 hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
 hscParseType = hscParseThing parseType
+#endif
 
 hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName))
 hscParseIdentifier = hscParseThing parseIdentifier
@@ -686,35 +713,6 @@ hscParseThing parser dflags str
       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
       return (Just thing)
       }}
-#endif
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Getting information about an identifer}
-%*									*
-%************************************************************************
-
-\begin{code}
-#ifdef GHCI
-hscGetInfo -- like hscStmt, but deals with a single identifier
-  :: HscEnv
-  -> String			-- The identifier
-  -> IO [GetInfoResult]
-
-hscGetInfo hsc_env str
-   = do maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
-	case maybe_rdr_name of {
-	  Nothing -> return [];
-	  Just (L _ rdr_name) -> do
-
-	maybe_tc_result <- tcRnGetInfo hsc_env (hsc_IC hsc_env) rdr_name
-
-	case maybe_tc_result of
-	     Nothing     -> return []
-	     Just things -> return things
- 	}
-#endif
 \end{code}
 
 %************************************************************************
@@ -744,7 +742,7 @@ compileExpr hsc_env this_mod rdr_env type_env tc_expr
 	; simpl_expr <- simplifyExpr dflags flat_expr
 
 		-- Tidy it (temporary, until coreSat does cloning)
-	; tidy_expr <- tidyCoreExpr simpl_expr
+	; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
 
 		-- Prepare for codegen
 	; prepd_expr <- corePrepExpr dflags tidy_expr
@@ -788,3 +786,19 @@ dumpIfaceStats hsc_env
     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
     dump_if_trace = dopt Opt_D_dump_if_trace dflags
 \end{code}
+
+%************************************************************************
+%*									*
+	Progress Messages: Module i of n
+%*									*
+%************************************************************************
+
+\begin{code}
+showModuleIndex Nothing = ""
+showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
+    where
+        n_str = show n
+        i_str = show i
+        padded = replicate (length n_str - length i_str) ' ' ++ i_str
+\end{code}
+