[project @ 2005-04-28 16:05:54 by simonpj]
[ghc-hetmet.git] / ghc / compiler / main / HscMain.lhs
index 83837ee..bd6bc43 100644 (file)
@@ -9,6 +9,7 @@ module HscMain (
        HscResult(..),
        hscMain, newHscEnv, hscCmmFile, 
        hscFileCheck,
+       hscParseIdentifier,
 #ifdef GHCI
        hscStmt, hscTcExpr, hscKcType,
        hscGetInfo, GetInfoResult,
@@ -19,13 +20,13 @@ module HscMain (
 #include "HsVersions.h"
 
 #ifdef GHCI
-import HsSyn           ( Stmt(..), LStmt, LHsExpr, LHsType )
+import HsSyn           ( Stmt(..), LHsExpr, LStmt, LHsType )
 import IfaceSyn                ( IfaceDecl, IfaceInst )
 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 ) 
@@ -33,36 +34,37 @@ import RdrName              ( rdrNameOcc )
 import OccName         ( occNameUserString )
 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 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         ( optTidyPgm, simpleTidyPgm )
 import CorePrep                ( corePrepPgm )
 import CoreToStg       ( coreToStg )
+import TyCon           ( isDataTyCon )
 import Name            ( Name, NamedThing(..) )
 import SimplStg                ( stg2stg )
 import CodeGen         ( codeGen )
@@ -82,9 +84,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 +137,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 +167,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 +185,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 +204,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 +259,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 +268,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 +289,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 +302,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 +327,62 @@ 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 { (_cg_guts, details) <- simpleTidyPgm 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
+
+       ; let { final_details = ModDetails { md_types   = mg_types ds_result,
+                                            md_exports = mg_exports ds_result,
+                                            md_insts   = mg_insts ds_result,
+                                            md_rules   = mg_rules ds_result } }
          -- And the answer is ...
        ; dumpIfaceStats hsc_env
 
        ; return (HscRecomp final_details
-                           final_iface
+                           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 +428,11 @@ 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
+       ; let omit_prags = dopt Opt_OmitInterfacePragmas dflags
+       ; (cg_guts, details) <- {-# SCC "CoreTidy" #-}
+                                if omit_prags 
+                                then simpleTidyPgm hsc_env simpl_result
+                                else optTidyPgm    hsc_env simpl_result
 
        -- Alive at this point:  
        --      tidy_result, pcs_final
@@ -413,30 +444,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 +481,24 @@ 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_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 +506,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) 
@@ -490,7 +525,7 @@ hscCodeGen dflags
 
             ------------------  Code generation ------------------
            abstractC <- {-# SCC "CodeGen" #-}
-                        codeGen dflags this_mod type_env foreign_stubs
+                        codeGen dflags this_mod data_tycons foreign_stubs
                                 dir_imps cost_centre_info stg_binds
 
            ------------------  Code output -----------------------
@@ -508,7 +543,7 @@ hscCmmFile dflags filename = do
   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"
@@ -648,14 +683,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,7 +724,6 @@ hscParseThing parser dflags str
       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
       return (Just thing)
       }}
-#endif
 \end{code}
 
 %************************************************************************
@@ -744,7 +781,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 +825,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}
+