Refactor self-boot info
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 20 Jul 2015 14:38:12 +0000 (15:38 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 21 Jul 2015 13:21:37 +0000 (14:21 +0100)
This patch is a simple refactoring that prepares for a later one,
related to Trac #10083.

* Add a field tcg_self_boot :: SelfBootInfo to TcGblEnv,
  where SelfBootInfo is a new data type, describing the
  hi-boot file, if any, for the module being compiled.

* Make tcHiBootIface return SelfBootInfo, a new data type

* Make other functions get SelfBootInfo from the monad.

* Remove tcg_mod_name from TcGblEnv; it was barely used and
  simpler to pass around explicitly.

compiler/iface/TcIface.hs
compiler/rename/RnSource.hs
compiler/rename/RnSplice.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcTyDecls.hs

index 4f80fc9..9480aec 100644 (file)
@@ -165,13 +165,13 @@ typecheckIface iface
 ************************************************************************
 -}
 
-tcHiBootIface :: HscSource -> Module -> TcRn ModDetails
+tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo
 -- Load the hi-boot iface for the module being compiled,
 -- if it indeed exists in the transitive closure of imports
--- Return the ModDetails, empty if no hi-boot iface
+-- Return the ModDetails; Nothing if no hi-boot iface
 tcHiBootIface hsc_src mod
   | HsBootFile <- hsc_src            -- Already compiling a hs-boot file
-  = return emptyModDetails
+  = return NoSelfBoot
   | otherwise
   = do  { traceIf (text "loadHiBootInterface" <+> ppr mod)
 
@@ -188,10 +188,10 @@ tcHiBootIface hsc_src mod
                 -- And that's fine, because if M's ModInfo is in the HPT, then
                 -- it's been compiled once, and we don't need to check the boot iface
           then do { hpt <- getHpt
-                  ; case lookupUFM hpt (moduleName mod) of
+                 ; case lookupUFM hpt (moduleName mod) of
                       Just info | mi_boot (hm_iface info)
-                                -> return (hm_details info)
-                      _ -> return emptyModDetails }
+                                -> return (mkSelfBootInfo (hm_details info))
+                      _ -> return NoSelfBoot }
           else do
 
         -- OK, so we're in one-shot mode.
@@ -203,8 +203,9 @@ tcHiBootIface hsc_src mod
                                 True    -- Hi-boot file
 
         ; case read_result of {
-                Succeeded (iface, _path) -> typecheckIface iface ;
-                Failed err               ->
+            Succeeded (iface, _path) -> do { tc_iface <- typecheckIface iface
+                                           ; return (mkSelfBootInfo tc_iface) } ;
+            Failed err               ->
 
         -- There was no hi-boot file. But if there is circularity in
         -- the module graph, there really should have been one.
@@ -215,7 +216,7 @@ tcHiBootIface hsc_src mod
         -- disappeared.
     do  { eps <- getEps
         ; case lookupUFM (eps_is_boot eps) (moduleName mod) of
-            Nothing -> return emptyModDetails -- The typical case
+            Nothing -> return NoSelfBoot -- The typical case
 
             Just (_, False) -> failWithTc moduleLoop
                 -- Someone below us imported us!
@@ -234,6 +235,15 @@ tcHiBootIface hsc_src mod
     elaborate err = hang (ptext (sLit "Could not find hi-boot interface for") <+>
                           quotes (ppr mod) <> colon) 4 err
 
+
+mkSelfBootInfo :: ModDetails -> SelfBootInfo
+mkSelfBootInfo mds
+  = SelfBoot { sb_mds = mds
+             , sb_tcs = mkNameSet (map tyConName (typeEnvTyCons iface_env))
+             , sb_ids = mkNameSet (map idName (typeEnvIds iface_env)) }
+  where
+    iface_env = md_types mds
+
 {-
 ************************************************************************
 *                                                                      *
index f5ffcd7..9ad8b1e 100644 (file)
@@ -43,7 +43,6 @@ import DynFlags
 import HscTypes         ( HscEnv, hsc_dflags )
 import ListSetOps       ( findDupsEq, removeDups )
 import Digraph          ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
-import Util             ( mapSnd )
 
 import Control.Monad
 import Data.List( partition, sortBy )
@@ -71,21 +70,21 @@ Checks the @(..)@ etc constraints in the export list.
 
 -- Brings the binders of the group into scope in the appropriate places;
 -- does NOT assume that anything is in scope already
-rnSrcDecls :: Maybe FreeVars -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
+rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
 -- Rename a top-level HsGroup; used for normal source files *and* hs-boot files
-rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_decls,
-                                       hs_splcds  = splice_decls,
-                                       hs_tyclds  = tycl_decls,
-                                       hs_instds  = inst_decls,
-                                       hs_derivds = deriv_decls,
-                                       hs_fixds   = fix_decls,
-                                       hs_warnds  = warn_decls,
-                                       hs_annds   = ann_decls,
-                                       hs_fords   = foreign_decls,
-                                       hs_defds   = default_decls,
-                                       hs_ruleds  = rule_decls,
-                                       hs_vects   = vect_decls,
-                                       hs_docs    = docs })
+rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
+                            hs_splcds  = splice_decls,
+                            hs_tyclds  = tycl_decls,
+                            hs_instds  = inst_decls,
+                            hs_derivds = deriv_decls,
+                            hs_fixds   = fix_decls,
+                            hs_warnds  = warn_decls,
+                            hs_annds   = ann_decls,
+                            hs_fords   = foreign_decls,
+                            hs_defds   = default_decls,
+                            hs_ruleds  = rule_decls,
+                            hs_vects   = vect_decls,
+                            hs_docs    = docs })
  = do {
    -- (A) Process the fixity declarations, creating a mapping from
    --     FastStrings to FixItems.
@@ -147,7 +146,7 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_decls,
    -- means we'll only report a declaration as unused if it isn't
    -- mentioned at all.  Ah well.
    traceRn (text "Start rnTyClDecls") ;
-   (rn_tycl_decls, src_fvs1) <- rnTyClDecls extra_deps tycl_decls ;
+   (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
 
    -- (F) Rename Value declarations right-hand sides
    traceRn (text "Start rnmono") ;
@@ -930,7 +929,7 @@ doing dependency analysis when compiling A.hs
 To handle this problem, we add a dependency
   - from every local declaration
   - to everything that comes from this module's .hs-boot file.
-In this case, we'll add and edges
+In this case, we'll ad and edges
   - from A2 to A1 (but that edge is there already)
   - from A1 to A1 (which is new)
 
@@ -949,26 +948,35 @@ See also Note [Grouping of type and class declarations] in TcTyClsDecls.
 -}
 
 
-rnTyClDecls :: Maybe FreeVars -> [TyClGroup RdrName]
+rnTyClDecls :: [TyClGroup RdrName]
             -> RnM ([TyClGroup Name], FreeVars)
 -- Rename the declarations and do depedency analysis on them
-rnTyClDecls extra_deps tycl_ds
-  = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat tycl_ds)
+rnTyClDecls tycl_ds
+  = do { ds_w_fvs       <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat tycl_ds)
        ; let decl_names = mkNameSet (map (tcdName . unLoc . fst) ds_w_fvs)
        ; role_annot_env <- rnRoleAnnots decl_names (concatMap group_roles tycl_ds)
-       ; this_mod  <- getModule
-       ; let add_boot_deps :: FreeVars -> FreeVars
+       ; tcg_env        <- getGblEnv
+       ; let this_mod  = tcg_mod tcg_env
+             boot_info = tcg_self_boot tcg_env
+
+             add_boot_deps :: [(LTyClDecl Name, FreeVars)] -> [(LTyClDecl Name, FreeVars)]
              -- See Note [Extra dependencies from .hs-boot files]
-             add_boot_deps fvs
-               | Just extra <- extra_deps
-               , has_local_imports fvs = fvs `plusFV` extra
-               | otherwise             = fvs
+             add_boot_deps ds_w_fvs
+               = case boot_info of
+                     SelfBoot { sb_tcs = tcs } | not (isEmptyNameSet tcs)
+                        -> map (add_one tcs) ds_w_fvs
+                     _  -> ds_w_fvs
+
+             add_one :: NameSet -> (LTyClDecl Name, FreeVars) -> (LTyClDecl Name, FreeVars)
+             add_one tcs pr@(decl,fvs)
+                | has_local_imports fvs = (decl, fvs `plusFV` tcs)
+                | otherwise             = pr
 
              has_local_imports fvs
                  = foldNameSet ((||) . nameIsHomePackageImport this_mod)
                                False fvs
 
-             ds_w_fvs' = mapSnd add_boot_deps ds_w_fvs
+             ds_w_fvs' = add_boot_deps ds_w_fvs
 
              sccs :: [SCC (LTyClDecl Name)]
              sccs = depAnalTyClDecls ds_w_fvs'
index d023f11..073ddaa 100644 (file)
@@ -131,7 +131,7 @@ rn_bracket _ (DecBrL decls)
                           -- The emptyDUs is so that we just collect uses for this
                           -- group alone in the call to rnSrcDecls below
        ; (tcg_env, group') <- setGblEnv new_gbl_env $
-                              rnSrcDecls Nothing group
+                              rnSrcDecls group
 
               -- Discard the tcg_env; it contains only extra info about fixity
         ; traceRn (text "rn_bracket dec" <+> (ppr (tcg_dus tcg_env) $$
index 633f1f1..c46a217 100644 (file)
@@ -252,7 +252,7 @@ checkHsigIface' gr
 
     -- In general, for hsig files we can't assume that the implementing
     -- file actually implemented the instances (they may be reexported
-    -- from elsewhere.  Where should we look for the instances?  We do
+    -- from elsewhere).  Where should we look for the instances?  We do
     -- the same as we would otherwise: consult the EPS.  This isn't
     -- perfect (we might conclude the module exports an instance
     -- when it doesn't, see #9422), but we will never refuse to compile
@@ -280,10 +280,22 @@ tcRnModuleTcRnM hsc_env hsc_src
                 })
                 (this_mod, prel_imp_loc)
  = setSrcSpan loc $
-   do { let { dflags = hsc_dflags hsc_env } ;
+   do { let { dflags = hsc_dflags hsc_env
+            ; explicit_mod_hdr = isJust maybe_mod } ;
 
         tcg_env <- tcRnSignature dflags hsc_src ;
-        setGblEnv tcg_env { tcg_mod_name=maybe_mod } $ do {
+        setGblEnv tcg_env $ do {
+
+                -- Load the hi-boot interface for this module, if any
+                -- We do this now so that the boot_names can be passed
+                -- to tcTyAndClassDecls, because the boot_names are
+                -- automatically considered to be loop breakers
+                --
+                -- Do this *after* tcRnImports, so that we know whether
+                -- a module that we import imports us; and hence whether to
+                -- look for a hi-boot file
+        boot_info <- tcHiBootIface hsc_src this_mod ;
+        setGblEnv (tcg_env { tcg_self_boot = boot_info }) $ do {
 
         -- Deal with imports; first add implicit prelude
         implicit_prelude <- xoptM Opt_ImplicitPrelude;
@@ -306,28 +318,18 @@ tcRnModuleTcRnM hsc_env hsc_src
 
         setGblEnv tcg_env1 $ do {
 
-                -- Load the hi-boot interface for this module, if any
-                -- We do this now so that the boot_names can be passed
-                -- to tcTyAndClassDecls, because the boot_names are
-                -- automatically considered to be loop breakers
-                --
-                -- Do this *after* tcRnImports, so that we know whether
-                -- a module that we import imports us; and hence whether to
-                -- look for a hi-boot file
-        boot_iface <- tcHiBootIface hsc_src this_mod ;
-
                 -- Rename and type check the declarations
         traceRn (text "rn1a") ;
         tcg_env <- if isHsBootOrSig hsc_src then
                         tcRnHsBootDecls hsc_src local_decls
                    else
                         {-# SCC "tcRnSrcDecls" #-}
-                        tcRnSrcDecls boot_iface export_ies local_decls ;
+                        tcRnSrcDecls explicit_mod_hdr export_ies local_decls ;
         setGblEnv tcg_env               $ do {
 
                 -- Process the export list
         traceRn (text "rn4a: before exports");
-        tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ;
+        tcg_env <- rnExports explicit_mod_hdr export_ies tcg_env ;
         traceRn (text "rn4b: after exports") ;
 
                 -- Check that main is exported (must be after rnExports)
@@ -335,7 +337,7 @@ tcRnModuleTcRnM hsc_env hsc_src
 
         -- Compare the hi-boot iface (if any) with the real thing
         -- Must be done after processing the exports
-        tcg_env <- checkHiBootIface tcg_env boot_iface ;
+        tcg_env <- checkHiBootIface tcg_env boot_info ;
 
         -- Compare the hsig tcg_env with the real thing
         checkHsigIface hsc_env tcg_env ;
@@ -371,7 +373,7 @@ tcRnModuleTcRnM hsc_env hsc_src
                 -- Dump output and return
         tcDump tcg_env ;
         return tcg_env
-    }}}}
+    }}}}}
 
 implicitPreludeWarn :: SDoc
 implicitPreludeWarn
@@ -455,20 +457,31 @@ tcRnImports hsc_env import_decls
 ************************************************************************
 -}
 
-tcRnSrcDecls :: ModDetails
+tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
              -> Maybe (Located [LIE RdrName])   -- Exports
              -> [LHsDecl RdrName]               -- Declarations
              -> TcM TcGblEnv
         -- Returns the variables free in the decls
         -- Reason: solely to report unused imports and bindings
-tcRnSrcDecls boot_iface exports decls
+tcRnSrcDecls explicit_mod_hdr exports decls
  = do {         -- Do all the declarations
-        ((tcg_env, tcl_env), lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ;
-      ; traceTc "Tc8" empty ;
-      ; setEnvs (tcg_env, tcl_env) $
-   do {
+        ((tcg_env, tcl_env), lie) <- captureConstraints $
+              do { (tcg_env, tcl_env) <- tc_rn_src_decls decls ;
+                 ; tcg_env <- setEnvs (tcg_env, tcl_env) $
+                              checkMain explicit_mod_hdr
+                 ; return (tcg_env, tcl_env) }
+      ; setEnvs (tcg_env, tcl_env) $ do {
+
+#ifdef GHCI
+        -- Run all module finalizers
+        let th_modfinalizers_var = tcg_th_modfinalizers tcg_env
+      ; modfinalizers <- readTcRef th_modfinalizers_var
+      ; writeTcRef th_modfinalizers_var []
+      ; mapM_ runQuasi modfinalizers
+#endif /* GHCI */
+
         -- wanted constraints from static forms
-        stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
+      ; stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef
 
              --         Finish simplifying class constraints
              --
@@ -484,18 +497,18 @@ tcRnSrcDecls boot_iface exports decls
              --  * the global env exposes the instances to simplifyTop
              --  * the local env exposes the local Ids to simplifyTop,
              --    so that we get better error messages (monomorphism restriction)
-        new_ev_binds <- {-# SCC "simplifyTop" #-}
-                        simplifyTop (andWC stWC lie) ;
-        traceTc "Tc9" empty ;
+      ; new_ev_binds <- {-# SCC "simplifyTop" #-}
+                        simplifyTop (andWC stWC lie)
+      ; traceTc "Tc9" empty
 
-        failIfErrsM ;   -- Don't zonk if there have been errors
+      ; failIfErrsM     -- Don't zonk if there have been errors
                         -- It's a waste of time; and we may get debug warnings
                         -- about strangely-typed TyCons!
 
         -- Zonk the final code.  This must be done last.
         -- Even simplifyTop may do some unification.
         -- This pass also warns about missing type signatures
-        let { TcGblEnv { tcg_type_env  = type_env,
+      ; let { TcGblEnv { tcg_type_env  = type_env,
                          tcg_binds     = binds,
                          tcg_sigs      = sig_ns,
                          tcg_ev_binds  = cur_ev_binds,
@@ -505,12 +518,12 @@ tcRnSrcDecls boot_iface exports decls
                          tcg_fords     = fords } = tcg_env
             ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
 
-        (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
+      ; (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
             <- {-# SCC "zonkTopDecls" #-}
                zonkTopDecls all_ev_binds binds exports sig_ns rules vects
                             imp_specs fords ;
 
-        let { final_type_env = extendTypeEnvWithIds type_env bind_ids
+      ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids
             ; tcg_env' = tcg_env { tcg_binds    = binds',
                                    tcg_ev_binds = ev_binds',
                                    tcg_imp_specs = imp_specs',
@@ -518,28 +531,21 @@ tcRnSrcDecls boot_iface exports decls
                                    tcg_vects    = vects',
                                    tcg_fords    = fords' } } ;
 
-        setGlobalTypeEnv tcg_env' final_type_env
+      ; setGlobalTypeEnv tcg_env' final_type_env
 
    } }
 
-tc_rn_src_decls :: ModDetails
-                -> [LHsDecl RdrName]
+tc_rn_src_decls :: [LHsDecl RdrName]
                 -> TcM (TcGblEnv, TcLclEnv)
 -- Loops around dealing with each top level inter-splice group
 -- in turn, until it's dealt with the entire module
-tc_rn_src_decls boot_details ds
+tc_rn_src_decls ds
  = {-# SCC "tc_rn_src_decls" #-}
    do { (first_group, group_tail) <- findSplice ds
                 -- If ds is [] we get ([], Nothing)
 
-        -- The extra_deps are needed while renaming type and class declarations
-        -- See Note [Extra dependencies from .hs-boot files] in RnSource
-      ; let { tycons = typeEnvTyCons (md_types boot_details)
-            ; extra_deps | null tycons = Nothing
-                         | otherwise   = Just (mkFVs (map tyConName tycons)) }
-
         -- Deal with decls up to, but not including, the first splice
-      ; (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group
+      ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group
                 -- rnTopSrcDecls fails if there are any errors
 
 #ifdef GHCI
@@ -562,7 +568,7 @@ tc_rn_src_decls boot_details ds
 
                     -- Rename TH-generated top-level declarations
                     ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env $
-                      rnTopSrcDecls extra_deps th_group
+                      rnTopSrcDecls th_group
 
                     -- Dump generated top-level declarations
                     ; let msg = "top-level declarations added with addTopDecls"
@@ -577,21 +583,12 @@ tc_rn_src_decls boot_details ds
 
       -- Type check all declarations
       ; (tcg_env, tcl_env) <- setGblEnv tcg_env $
-                              tcTopSrcDecls boot_details rn_decls
+                              tcTopSrcDecls rn_decls
 
         -- If there is no splice, we're nearly done
       ; setEnvs (tcg_env, tcl_env) $
         case group_tail of
-          { Nothing -> do { tcg_env <- checkMain       -- Check for `main'
-#ifdef GHCI
-                            -- Run all module finalizers
-                          ; th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
-                          ; modfinalizers <- readTcRef th_modfinalizers_var
-                          ; writeTcRef th_modfinalizers_var []
-                          ; mapM_ runQuasi modfinalizers
-#endif /* GHCI */
-                          ; return (tcg_env, tcl_env)
-                          }
+          { Nothing -> return (tcg_env, tcl_env)
 
 #ifndef GHCI
             -- There shouldn't be a splice
@@ -606,7 +603,7 @@ tc_rn_src_decls boot_details ds
 
                  -- Glue them on the front of the remaining decls and loop
                ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
-                 tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
+                 tc_rn_src_decls (spliced_decls ++ rest_ds)
                }
           }
 #endif /* GHCI */
@@ -635,7 +632,7 @@ tcRnHsBootDecls hsc_src decls
                    hs_ruleds = rule_decls,
                    hs_vects  = vect_decls,
                    hs_annds  = _,
-                   hs_valds  = val_binds }) <- rnTopSrcDecls Nothing first_group
+                   hs_valds  = val_binds }) <- rnTopSrcDecls first_group
         -- The empty list is for extra dependencies coming from .hs-boot files
         -- See Note [Extra dependencies from .hs-boot files] in RnSource
         ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
@@ -653,7 +650,7 @@ tcRnHsBootDecls hsc_src decls
                 -- Typecheck type/class/isntance decls
         ; traceTc "Tc2 (boot)" empty
         ; (tcg_env, inst_infos, _deriv_binds)
-             <- tcTyClsInstDecls emptyModDetails tycl_decls inst_decls deriv_decls
+             <- tcTyClsInstDecls tycl_decls inst_decls deriv_decls
         ; setGblEnv tcg_env     $ do {
 
                 -- Typecheck value declarations
@@ -696,22 +693,24 @@ Once we've typechecked the body of the module, we want to compare what
 we've found (gathered in a TypeEnv) with the hi-boot details (if any).
 -}
 
-checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv
+checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv
 -- Compare the hi-boot file for this module (if there is one)
 -- with the type environment we've just come up with
 -- In the common case where there is no hi-boot file, the list
 -- of boot_names is empty.
 
-checkHiBootIface
-        tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds
-                          , tcg_insts = local_insts
-                          , tcg_type_env = local_type_env
-                          , tcg_exports = local_exports })
-        boot_details
-  | HsBootFile <- hs_src     -- Current module is already a hs-boot file!
+checkHiBootIface tcg_env boot_info
+  | NoSelfBoot <- boot_info  -- Common case
   = return tcg_env
 
-  | otherwise
+  | HsBootFile <- tcg_src tcg_env   -- Current module is already a hs-boot file!
+  = return tcg_env
+
+  | SelfBoot { sb_mds = boot_details } <- boot_info
+  , TcGblEnv { tcg_binds    = binds
+             , tcg_insts    = local_insts
+             , tcg_type_env = local_type_env
+             , tcg_exports  = local_exports } <- tcg_env
   = do  { dfun_prs <- checkHiBootIface' local_insts local_type_env
                                         local_exports boot_details
         ; let boot_dfuns = map fst dfun_prs
@@ -726,6 +725,8 @@ checkHiBootIface
              -- mentioning one of the dfuns from the boot module, then it
              -- can "see" that boot dfun.   See Trac #4003
 
+  | otherwise = panic "checkHiBootIface: unreachable code"
+
 checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]
                   -> ModDetails -> TcM [(Id, Id)]
 -- Variant which doesn't require a full TcGblEnv; you could get the
@@ -1087,12 +1088,12 @@ instMisMatch is_boot inst
 ************************************************************************
 -}
 
-rnTopSrcDecls :: Maybe FreeVars -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
+rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
 -- Fails if there are any errors
-rnTopSrcDecls extra_deps group
+rnTopSrcDecls group
  = do { -- Rename the source decls
         traceTc "rn12" empty ;
-        (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls extra_deps group ;
+        (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
         traceTc "rn13" empty ;
 
         -- save the renamed syntax, if we want it
@@ -1108,17 +1109,16 @@ rnTopSrcDecls extra_deps group
         return (tcg_env', rn_decls)
    }
 
-tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
-tcTopSrcDecls boot_details
-        (HsGroup { hs_tyclds = tycl_decls,
-                   hs_instds = inst_decls,
-                   hs_derivds = deriv_decls,
-                   hs_fords  = foreign_decls,
-                   hs_defds  = default_decls,
-                   hs_annds  = annotation_decls,
-                   hs_ruleds = rule_decls,
-                   hs_vects  = vect_decls,
-                   hs_valds  = val_binds })
+tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
+tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
+                         hs_instds = inst_decls,
+                         hs_derivds = deriv_decls,
+                         hs_fords  = foreign_decls,
+                         hs_defds  = default_decls,
+                         hs_annds  = annotation_decls,
+                         hs_ruleds = rule_decls,
+                         hs_vects  = vect_decls,
+                         hs_valds  = val_binds })
  = do {         -- Type-check the type and class decls, and all imported decls
                 -- The latter come in via tycl_decls
         traceTc "Tc2 (src)" empty ;
@@ -1127,7 +1127,7 @@ tcTopSrcDecls boot_details
                 -- and import the supporting declarations
         traceTc "Tc3" empty ;
         (tcg_env, inst_infos, deriv_binds)
-            <- tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls ;
+            <- tcTyClsInstDecls tycl_decls inst_decls deriv_decls ;
         setGblEnv tcg_env       $ do {
 
 
@@ -1213,8 +1213,7 @@ tcTopSrcDecls boot_details
       | otherwise      = greUsedRdrName gre : rdrs
 
 ---------------------------
-tcTyClsInstDecls :: ModDetails
-                 -> [TyClGroup Name]
+tcTyClsInstDecls :: [TyClGroup Name]
                  -> [LInstDecl Name]
                  -> [LDerivDecl Name]
                  -> TcM (TcGblEnv,            -- The full inst env
@@ -1222,11 +1221,11 @@ tcTyClsInstDecls :: ModDetails
                                               -- contains all dfuns for this module
                           HsValBinds Name)    -- Supporting bindings for derived instances
 
-tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls
+tcTyClsInstDecls tycl_decls inst_decls deriv_decls
  = tcExtendKindEnv2 [ (con, APromotionErr FamDataConPE)
                     | lid <- inst_decls, con <- get_cons lid ] $
       -- Note [AFamDataCon: not promoting data family constructors]
-   do { tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
+   do { tcg_env <- tcTyAndClassDecls tycl_decls ;
       ; setGblEnv tcg_env $
         tcInstDecls1 (tyClGroupConcat tycl_decls) inst_decls deriv_decls }
   where
@@ -1268,16 +1267,16 @@ type checking 'S' we'll produce a decent error message.
 ************************************************************************
 -}
 
-checkMain :: TcM TcGblEnv
+checkMain :: Bool  -- False => no 'module M(..) where' header at all
+          -> TcM TcGblEnv
 -- If we are in module Main, check that 'main' is defined.
-checkMain
-  = do { tcg_env   <- getGblEnv ;
-         dflags    <- getDynFlags ;
-         check_main dflags tcg_env
-    }
+checkMain explicit_mod_hdr
+ = do   { dflags  <- getDynFlags
+        ; tcg_env <- getGblEnv
+        ; check_main dflags tcg_env explicit_mod_hdr }
 
-check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv
-check_main dflags tcg_env
+check_main :: DynFlags -> TcGblEnv -> Bool -> TcM TcGblEnv
+check_main dflags tcg_env explicit_mod_hdr
  | mod /= main_mod
  = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>
    return tcg_env
@@ -1323,13 +1322,12 @@ check_main dflags tcg_env
                  })
     }}}
   where
-    mod          = tcg_mod tcg_env
-    main_mod     = mainModIs dflags
-    main_fn      = getMainFun dflags
-    interactive  = ghcLink dflags == LinkInMemory
-    implicit_mod = isNothing (tcg_mod_name tcg_env)
+    mod         = tcg_mod tcg_env
+    main_mod    = mainModIs dflags
+    main_fn     = getMainFun dflags
+    interactive = ghcLink dflags == LinkInMemory
 
-    complain_no_main = checkTc (interactive && implicit_mod) noMainMsg
+    complain_no_main = checkTc (interactive && not explicit_mod_hdr) noMainMsg
         -- In interactive mode, without an explicit module header, don't
         -- worry about the absence of 'main'.
         -- In other modes, fail altogether, so that we don't go on
@@ -1907,8 +1905,8 @@ tcRnDeclsi :: HscEnv
 tcRnDeclsi hsc_env local_decls =
   runTcInteractive hsc_env $ do
 
-    ((tcg_env, tclcl_env), lie) <-
-        captureConstraints $ tc_rn_src_decls emptyModDetails local_decls
+    ((tcg_env, tclcl_env), lie) <- captureConstraints $
+                                   tc_rn_src_decls local_decls
     setEnvs (tcg_env, tclcl_env) $ do
 
     -- wanted constraints from static forms
index 0e44c4c..c1392f4 100644 (file)
@@ -120,7 +120,6 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_mod            = mod,
                 tcg_src            = hsc_src,
                 tcg_sig_of         = getSigOf dflags (moduleName mod),
-                tcg_mod_name       = Nothing,
                 tcg_impl_rdr_env   = Nothing,
                 tcg_rdr_env        = emptyGlobalRdrEnv,
                 tcg_fix_env        = emptyNameEnv,
@@ -162,6 +161,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_doc_hdr        = Nothing,
                 tcg_hpc            = False,
                 tcg_main           = Nothing,
+                tcg_self_boot      = NoSelfBoot,
                 tcg_safeInfer      = infer_var,
                 tcg_dependent_files = dependent_files_var,
                 tcg_tc_plugins     = [],
@@ -611,6 +611,9 @@ getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC h
 tcIsHsBootOrSig :: TcRn Bool
 tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
 
+tcSelfBootInfo :: TcRn SelfBootInfo
+tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) }
+
 getGlobalRdrEnv :: TcRn GlobalRdrEnv
 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
 
index 4d36243..5547bbc 100644 (file)
@@ -36,6 +36,7 @@ module TcRnTypes(
         -- Typechecker types
         TcTypeEnv, TcIdBinderStack, TcIdBinder(..),
         TcTyThing(..), PromotionErr(..),
+        SelfBootInfo(..),
         pprTcTyThingCategory, pprPECategory,
 
         -- Desugaring types
@@ -337,8 +338,6 @@ data TcGblEnv
           -- ^ What kind of module (regular Haskell, hs-boot, hsig)
         tcg_sig_of  :: Maybe Module,
           -- ^ Are we being compiled as a signature of an implementation?
-        tcg_mod_name :: Maybe (Located ModuleName),
-          -- ^ @Nothing@: \"module X where\" is omitted
         tcg_impl_rdr_env :: Maybe GlobalRdrEnv,
           -- ^ Environment used only during -sig-of for resolving top level
           -- bindings.  See Note [Signature parameters in TcGblEnv and DynFlags]
@@ -477,6 +476,9 @@ data TcGblEnv
         tcg_hpc       :: AnyHpcUsage,        -- ^ @True@ if any part of the
                                              --  prog uses hpc instrumentation.
 
+        tcg_self_boot :: SelfBootInfo,       -- ^ Whether this module has a
+                                             -- corresponding hi-boot file
+
         tcg_main      :: Maybe Name,         -- ^ The Name of the main
                                              -- function, if this module is
                                              -- the main module.
@@ -560,6 +562,15 @@ data RecFieldEnv
         -- module.  For imported modules, we get the same info from the
         -- TypeEnv
 
+data SelfBootInfo
+  = NoSelfBoot    -- No corresponding hi-boot file
+  | SelfBoot
+       { sb_mds :: ModDetails   -- There was a hi-boot file,
+       , sb_tcs :: NameSet      -- defining these TyCons,
+       , sb_ids :: NameSet }    -- and these Ids
+  -- We need this info to compute a safe approximation to
+  -- recursive loops, to avoid infinite inlinings
+
 {-
 Note [Tracking unused binding and imports]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 57ed460..9c14055 100644 (file)
@@ -107,12 +107,11 @@ Thus, we take two passes over the resulting tycons, first checking for general
 validity and then checking for valid role annotations.
 -}
 
-tcTyAndClassDecls :: ModDetails
-                  -> [TyClGroup Name]   -- Mutually-recursive groups in dependency order
+tcTyAndClassDecls :: [TyClGroup Name]   -- Mutually-recursive groups in dependency order
                   -> TcM TcGblEnv       -- Input env extended by types and classes
                                         -- and their implicit Ids,DataCons
 -- Fails if there are any errors
-tcTyAndClassDecls boot_details tyclds_s
+tcTyAndClassDecls tyclds_s
   = checkNoErrs $       -- The code recovers internally, but if anything gave rise to
                         -- an error we'd better stop now, to avoid a cascade
     fold_env tyclds_s   -- Type check each group in dependency order folding the global env
@@ -120,13 +119,13 @@ tcTyAndClassDecls boot_details tyclds_s
     fold_env :: [TyClGroup Name] -> TcM TcGblEnv
     fold_env [] = getGblEnv
     fold_env (tyclds:tyclds_s)
-      = do { tcg_env <- tcTyClGroup boot_details tyclds
+      = do { tcg_env <- tcTyClGroup tyclds
            ; setGblEnv tcg_env $ fold_env tyclds_s }
              -- remaining groups are typecheck in the extended global env
 
-tcTyClGroup :: ModDetails -> TyClGroup Name -> TcM TcGblEnv
+tcTyClGroup :: TyClGroup Name -> TcM TcGblEnv
 -- Typecheck one strongly-connected component of type and class decls
-tcTyClGroup boot_details tyclds
+tcTyClGroup tyclds
   = do {    -- Step 1: kind-check this group and returns the final
             -- (possibly-polymorphic) kind of each TyCon and Class
             -- See Note [Kind checking for type and class decls]
@@ -138,8 +137,9 @@ tcTyClGroup boot_details tyclds
        ; let role_annots = extractRoleAnnots tyclds
              decls = group_tyclds tyclds
        ; tyclss <- fixM $ \ rec_tyclss -> do
-           { is_boot <- tcIsHsBootOrSig
-           ; let rec_flags = calcRecFlags boot_details is_boot
+           { is_boot   <- tcIsHsBootOrSig
+           ; self_boot <- tcSelfBootInfo
+           ; let rec_flags = calcRecFlags self_boot is_boot
                                           role_annots rec_tyclss
 
                  -- Populate environment with knot-tied ATyCon for TyCons
index 6787c9c..827f217 100644 (file)
@@ -24,7 +24,7 @@ import HsSyn
 import Class
 import Type
 import Kind
-import HscTypes
+import TcRnTypes( SelfBootInfo(..) )
 import TyCon
 import DataCon
 import Var
@@ -34,7 +34,6 @@ import VarEnv
 import VarSet
 import NameSet
 import Coercion ( ltRole )
-import Avail
 import Digraph
 import BasicTypes
 import SrcLoc
@@ -359,7 +358,7 @@ data RecTyInfo = RTI { rti_promotable :: Bool
                      , rti_roles      :: Name -> [Role]
                      , rti_is_rec     :: Name -> RecFlag }
 
-calcRecFlags :: ModDetails -> Bool  -- hs-boot file?
+calcRecFlags :: SelfBootInfo -> Bool  -- hs-boot file?
              -> RoleAnnots -> [TyThing] -> RecTyInfo
 -- The 'boot_names' are the things declared in M.hi-boot, if M is the current module.
 -- Any type constructors in boot_names are automatically considered loop breakers
@@ -381,7 +380,9 @@ calcRecFlags boot_details is_boot mrole_env tyclss
     is_rec n | n `elemNameSet` rec_names = Recursive
              | otherwise                 = NonRecursive
 
-    boot_name_set = availsToNameSet (md_exports boot_details)
+    boot_name_set = case boot_details of
+                      NoSelfBoot                -> emptyNameSet
+                      SelfBoot { sb_tcs = tcs } -> tcs
     rec_names = boot_name_set     `unionNameSet`
                 nt_loop_breakers  `unionNameSet`
                 prod_loop_breakers