Commit 3c44a46b authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactor self-boot info

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.
parent cd48797a
......@@ -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
{-
************************************************************************
* *
......
......@@ -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'
......
......@@ -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) $$
......
This diff is collapsed.
......@@ -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) }
......
......@@ -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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment