Adding pushing of hpc translation status through hi files.

[ghc-hetmet.git] / compiler / typecheck / TcRnDriver.lhs

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index c5a72fd..8468f87 100644 (file)
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -12,7 +12,6 @@ module TcRnDriver (
        tcRnLookupName,
        tcRnGetInfo,
        getModuleExports, 
-        tcRnRecoverDataCon,
 #endif
        tcRnModule, 
        tcTopSrcDecls,
@@ -198,7 +197,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax
 \begin{code}
 tcRnImports :: HscEnv -> Module -> [LImportDecl RdrName] -> TcM TcGblEnv
 tcRnImports hsc_env this_mod import_decls
-  = do { (rn_imports, rdr_env, imports) <- rnImports import_decls ;
+  = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ;
 
        ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
              ; dep_mods = imp_dep_mods imports
@@ -227,7 +226,8 @@ tcRnImports hsc_env this_mod import_decls
               tcg_rn_imports   = fmap (const rn_imports) (tcg_rn_imports gbl),
              tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
              tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) 
-                                                      home_fam_insts
+                                                      home_fam_insts,
+             tcg_hpc          = hpc_info
            }) $ do {
 
        ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports))
@@ -314,6 +314,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
                                mg_types     = final_type_env,
                                mg_insts     = tcg_insts tcg_env,
                                mg_fam_insts = tcg_fam_insts tcg_env,
+                               mg_inst_env  = tcg_inst_env tcg_env,
                                mg_fam_inst_env = tcg_fam_inst_env tcg_env,
                                mg_rules     = [],
                                mg_binds     = core_binds,
@@ -323,7 +324,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
                                mg_fix_env   = emptyFixityEnv,
                                mg_deprecs   = NoDeprecs,
                                mg_foreign   = NoStubs,
-                               mg_hpc_info  = noHpcInfo,
+                               mg_hpc_info  = emptyHpcInfo False,
                                 mg_modBreaks = emptyModBreaks,
                                 mg_vect_info = noVectInfo
                    } } ;
@@ -695,10 +696,10 @@ tcTopSrcDecls boot_details
        (tc_val_binds,   tcl_env) <- tcTopBinds val_binds ;
        setLclTypeEnv tcl_env   $ do {
 
-               -- Now GHC-generated derived bindings and generics
-               -- Do not generate warnings from compiler-generated code
-       (tc_deriv_binds, tcl_env) <- discardWarnings $ setOptM Opt_GlasgowExts $ 
-                                    tcTopBinds deriv_binds ;
+               -- Now GHC-generated derived bindings and generics.
+               -- Do not generate warnings from compiler-generated code.
+       (tc_deriv_binds, tcl_env) <- discardWarnings $
+                                 tcTopBinds deriv_binds ;
 
                -- Second pass over class and instance declarations, 
         traceTc (text "Tc6") ;
@@ -743,23 +744,16 @@ checkMain :: TcM TcGblEnv
 checkMain 
   = do { tcg_env   <- getGblEnv ;
         dflags    <- getDOpts ;
-        let { main_mod = mainModIs dflags ;
-              main_fn  = case mainFunIs dflags of {
-                               Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ;
-                               Nothing -> main_RDR_Unqual } } ;
-       
-        check_main dflags tcg_env main_mod main_fn
+        check_main dflags tcg_env
     }
 
-
-check_main dflags tcg_env main_mod main_fn
+check_main dflags tcg_env
  | mod /= main_mod
  = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
    return tcg_env
 
  | otherwise
- = addErrCtxt mainCtxt                 $
-   do  { mb_main <- lookupSrcOcc_maybe main_fn
+ = do  { mb_main <- lookupSrcOcc_maybe main_fn
                -- Check that 'main' is in scope
                -- It might be imported from another module!
        ; case mb_main of {
@@ -767,11 +761,13 @@ check_main dflags tcg_env main_mod main_fn
                           ; complain_no_main   
                           ; return tcg_env } ;
             Just main_name -> do
+
        { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn)
        ; let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
                        -- :Main.main :: IO () = runMainIO main 
 
-       ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
+       ; (main_expr, ty) <- addErrCtxt mainCtxt                        $
+                            setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
                             tcInferRho rhs
 
                -- See Note [Root-main Id]
@@ -790,17 +786,25 @@ check_main dflags tcg_env main_mod main_fn
                 }) 
     }}}
   where
-    mod = tcg_mod tcg_env
- 
+    mod         = tcg_mod tcg_env
+    main_mod     = mainModIs dflags
+    main_is_flag = mainFunIs dflags
+
+    main_fn  = case main_is_flag of
+                 Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
+                 Nothing -> main_RDR_Unqual
+
     complain_no_main | ghcLink dflags == LinkInMemory = return ()
                     | otherwise = failWithTc noMainMsg
        -- In interactive mode, don't worry about the absence of 'main'
        -- In other modes, fail altogether, so that we don't go on
        -- and complain a second time when processing the export list.
 
-    mainCtxt  = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
-    noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn) 
+    mainCtxt  = ptext SLIT("When checking the type of the") <+> pp_main_fn
+    noMainMsg = ptext SLIT("The") <+> pp_main_fn
                <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
+    pp_main_fn | isJust main_is_flag = ptext SLIT("main function") <+> quotes (ppr main_fn)
+              | otherwise           = ptext SLIT("function") <+> quotes (ppr main_fn)
 \end{code}
 
 Note [Root-main Id]
@@ -837,8 +841,8 @@ setInteractiveContext hsc_env icxt thing_inside
        tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
 
 
-    tcExtendIdEnv (ic_tmp_ids icxt) $
-        -- tcExtendIdEnv does lots: 
+    tcExtendGhciEnv (ic_tmp_ids icxt) $
+        -- tcExtendGhciEnv does lots: 
         --   - it extends the local type env (tcl_env) with the given Ids,
         --   - it extends the local rdr env (tcl_rdr) with the Names from 
         --     the given Ids
@@ -1201,13 +1205,6 @@ lookup_rdr_name rdr_name = do {
     return good_names
  }
 
-tcRnRecoverDataCon :: HscEnv -> Ptr () -> IO (Maybe DataCon) 
-tcRnRecoverDataCon hsc_env ptr
-  = initTcPrintErrors hsc_env iNTERACTIVE $ 
-    setInteractiveContext hsc_env (hsc_IC hsc_env) $ do
-        name <- dataConInfoPtrToName ptr
-        tcLookupDataCon name
-
 tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
 tcRnLookupName hsc_env name
   = initTcPrintErrors hsc_env iNTERACTIVE $