[Git][ghc/ghc][master] Clean up boot vs non-boot disambiguating types
Marge Bot
gitlab at gitlab.haskell.org
Thu Jun 4 08:34:59 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
32a4ae90 by John Ericson at 2020-06-04T04:34:42-04:00
Clean up boot vs non-boot disambiguating types
We often have (ModuleName, Bool) or (Module, Bool) pairs for "extended"
module names (without or with a unit id) disambiguating boot and normal
modules. We think this is important enough across the compiler that it
deserves a new nominal product type. We do this with synnoyms and a
functor named with a `Gen` prefix, matching other newly created
definitions.
It was also requested that we keep custom `IsBoot` / `NotBoot` sum type.
So we have it too. This means changing many the many bools to use that
instead.
Updates `haddock` submodule.
- - - - -
30 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Driver/Types.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Header.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Linker.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit/Module.hs
- compiler/GHC/Unit/Module/Location.hs
- compiler/GHC/Unit/Types.hs
- ghc/Main.hs
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- testsuite/tests/parser/should_run/CountParserDeps.hs
- utils/haddock
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -936,7 +936,7 @@ getModSummary mod = do
mg <- liftM hsc_mod_graph getSession
let mods_by_name = [ ms | ms <- mgModSummaries mg
, ms_mod_name ms == mod
- , not (isBootSummary ms) ]
+ , isBootSummary ms == NotBoot ]
case mods_by_name of
[] -> do dflags <- getDynFlags
liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -772,7 +772,7 @@ hsModuleToModSummary pn hsc_src modname
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
-- Also copied from 'getImports'
- let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
+ let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
-- GHC.Prim doesn't exist physically, so don't go looking for it.
ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -21,14 +21,14 @@ module GHC.Driver.Make (
ms_home_srcimps, ms_home_imps,
- IsBoot(..),
summariseModule,
hscSourceToIsBoot,
findExtraSigImports,
implicitRequirements,
noModError, cyclicModuleErr,
- moduleGraphNodes, SummaryNode
+ moduleGraphNodes, SummaryNode,
+ IsBootInterface(..)
) where
#include "HsVersions.h"
@@ -378,7 +378,7 @@ load' how_much mHscMessage mod_graph = do
-- (see msDeps)
let all_home_mods =
mkUniqSet [ ms_mod_name s
- | s <- mgModSummaries mod_graph, not (isBootSummary s)]
+ | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot]
-- TODO: Figure out what the correct form of this assert is. It's violated
-- when you have HsBootMerge nodes in the graph: then you'll have hs-boot
-- files without corresponding hs files.
@@ -930,23 +930,26 @@ buildCompGraph (scc:sccs) = case scc of
return ((ms,mvar,log_queue):rest, cycle)
CyclicSCC mss -> return ([], Just mss)
--- A Module and whether it is a boot module.
-type BuildModule = (Module, IsBoot)
-
--- | 'Bool' indicating if a module is a boot module or not. We need to treat
--- boot modules specially when building compilation graphs, since they break
--- cycles. Regular source files and signature files are treated equivalently.
-data IsBoot = NotBoot | IsBoot
- deriving (Ord, Eq, Show, Read)
-
--- | Tests if an 'HscSource' is a boot file, primarily for constructing
--- elements of 'BuildModule'.
-hscSourceToIsBoot :: HscSource -> IsBoot
+-- | A Module and whether it is a boot module.
+--
+-- We need to treat boot modules specially when building compilation graphs,
+-- since they break cycles. Regular source files and signature files are treated
+-- equivalently.
+type BuildModule = ModuleWithIsBoot
+
+-- | Tests if an 'HscSource' is a boot file, primarily for constructing elements
+-- of 'BuildModule'. We conflate signatures and modules because they are bound
+-- in the same namespace; only boot interfaces can be disambiguated with
+-- `import {-# SOURCE #-}`.
+hscSourceToIsBoot :: HscSource -> IsBootInterface
hscSourceToIsBoot HsBootFile = IsBoot
hscSourceToIsBoot _ = NotBoot
mkBuildModule :: ModSummary -> BuildModule
-mkBuildModule ms = (ms_mod ms, if isBootSummary ms then IsBoot else NotBoot)
+mkBuildModule ms = GWIB
+ { gwib_mod = ms_mod ms
+ , gwib_isBoot = isBootSummary ms
+ }
-- | The entry point to the parallel upsweep.
--
@@ -1014,12 +1017,12 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
-- NB: For convenience, the last module of each loop (aka the module that
-- finishes the loop) is prepended to the beginning of the loop.
let graph = map fstOf3 (reverse comp_graph)
- boot_modules = mkModuleSet [ms_mod ms | ms <- graph, isBootSummary ms]
+ boot_modules = mkModuleSet [ms_mod ms | ms <- graph, isBootSummary ms == IsBoot]
comp_graph_loops = go graph boot_modules
where
- remove ms bm
- | isBootSummary ms = delModuleSet bm (ms_mod ms)
- | otherwise = bm
+ remove ms bm = case isBootSummary ms of
+ IsBoot -> delModuleSet bm (ms_mod ms)
+ NotBoot -> bm
go [] _ = []
go mg@(ms:mss) boot_modules
| Just loop <- getModLoop ms mg (`elemModuleSet` boot_modules)
@@ -1193,9 +1196,13 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup
let home_src_imps = map unLoc $ ms_home_srcimps mod
-- All the textual imports of this module.
- let textual_deps = Set.fromList $ mapFst (mkModule (thisPackage lcl_dflags)) $
- zip home_imps (repeat NotBoot) ++
- zip home_src_imps (repeat IsBoot)
+ let textual_deps = Set.fromList $
+ zipWith f home_imps (repeat NotBoot) ++
+ zipWith f home_src_imps (repeat IsBoot)
+ where f mn isBoot = GWIB
+ { gwib_mod = mkModule (thisPackage lcl_dflags) mn
+ , gwib_isBoot = isBoot
+ }
-- Dealing with module loops
-- ~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1301,8 +1308,8 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup
-- SCCs include the loop closer, so we have to filter
-- it out.
Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $
- filter (/= moduleName (fst this_build_mod)) $
- map (moduleName . fst) loop
+ filter (/= moduleName (gwib_mod this_build_mod)) $
+ map (moduleName . gwib_mod) loop
-- Compile the module.
mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods
@@ -1315,7 +1322,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup
let this_mod = ms_mod_name mod
-- Prune the old HPT unless this is an hs-boot module.
- unless (isBootSummary mod) $
+ unless (isBootSummary mod == IsBoot) $
atomicModifyIORef' old_hpt_var $ \old_hpt ->
(delFromHpt old_hpt this_mod, ())
@@ -1331,7 +1338,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup
hsc_env'' <- case finish_loop of
Nothing -> return hsc_env'
Just loop -> typecheckLoop lcl_dflags hsc_env' $
- map (moduleName . fst) loop
+ map (moduleName . gwib_mod) loop
return (hsc_env'', localize_hsc_env hsc_env'')
-- Clean up any intermediate files.
@@ -1491,8 +1498,9 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
-- main Haskell source file. Deleting it
-- would force the real module to be recompiled
-- every time.
- old_hpt1 | isBootSummary mod = old_hpt
- | otherwise = delFromHpt old_hpt this_mod
+ old_hpt1 = case isBootSummary mod of
+ IsBoot -> old_hpt
+ NotBoot -> delFromHpt old_hpt this_mod
done' = extendMG done mod
@@ -1596,10 +1604,10 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind
mb_old_iface
= case old_hmi of
- Nothing -> Nothing
- Just hm_info | isBootSummary summary -> Just iface
- | not (mi_boot iface) -> Just iface
- | otherwise -> Nothing
+ Nothing -> Nothing
+ Just hm_info | isBootSummary summary == IsBoot -> Just iface
+ | mi_boot iface == NotBoot -> Just iface
+ | otherwise -> Nothing
where
iface = hm_iface hm_info
@@ -1823,7 +1831,7 @@ reTypecheckLoop hsc_env ms graph
| Just loop <- getModLoop ms mss appearsAsBoot
-- SOME hs-boot files should still
-- get used, just not the loop-closer.
- , let non_boot = filter (\l -> not (isBootSummary l &&
+ , let non_boot = filter (\l -> not (isBootSummary l == IsBoot &&
ms_mod l == ms_mod ms)) loop
= typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot)
| otherwise
@@ -1874,7 +1882,7 @@ getModLoop
-> (Module -> Bool) -- check if a module appears as a boot module in 'graph'
-> Maybe [ModSummary]
getModLoop ms graph appearsAsBoot
- | not (isBootSummary ms)
+ | isBootSummary ms == NotBoot
, appearsAsBoot this_mod
, let mss = reachableBackwards (ms_mod_name ms) graph
= Just mss
@@ -1974,14 +1982,23 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
numbered_summaries = zip summaries [1..]
lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
- lookup_node hs_src mod = Map.lookup (mod, hscSourceToIsBoot hs_src) node_map
+ lookup_node hs_src mod = Map.lookup
+ GWIB
+ { gwib_mod = mod
+ , gwib_isBoot = hscSourceToIsBoot hs_src
+ }
+ node_map
lookup_key :: HscSource -> ModuleName -> Maybe Int
lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
node_map :: NodeMap SummaryNode
- node_map = Map.fromList [ ((moduleName (ms_mod s),
- hscSourceToIsBoot (ms_hsc_src s)), node)
+ node_map = Map.fromList [ ( GWIB
+ { gwib_mod = moduleName $ ms_mod s
+ , gwib_isBoot = hscSourceToIsBoot $ ms_hsc_src s
+ }
+ , node
+ )
| node <- nodes
, let s = summaryNodeSummary node ]
@@ -1990,7 +2007,7 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
nodes = [ DigraphNode s key out_keys
| (s, key) <- numbered_summaries
-- Drop the hi-boot ones if told to do so
- , not (isBootSummary s && drop_hs_boot_nodes)
+ , not (isBootSummary s == IsBoot && drop_hs_boot_nodes)
, let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++
(-- see [boot-edges] below
@@ -2015,17 +2032,20 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
out_edge_keys :: HscSource -> [ModuleName] -> [Int]
out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms
-- If we want keep_hi_boot_nodes, then we do lookup_key with
- -- IsBoot; else NotBoot
+ -- IsBoot; else False
-- The nodes of the graph are keyed by (mod, is boot?) pairs
-- NB: hsig files show up as *normal* nodes (not boot!), since they don't
-- participate in cycles (for now)
-type NodeKey = (ModuleName, IsBoot)
+type NodeKey = ModuleNameWithIsBoot
type NodeMap a = Map.Map NodeKey a
msKey :: ModSummary -> NodeKey
msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot })
- = (moduleName mod, hscSourceToIsBoot boot)
+ = GWIB
+ { gwib_mod = moduleName mod
+ , gwib_isBoot = hscSourceToIsBoot boot
+ }
mkNodeMap :: [ModSummary] -> NodeMap ModSummary
mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]
@@ -2143,7 +2163,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
dup_roots :: [[ModSummary]] -- Each at least of length 2
dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map
- loop :: [(Located ModuleName,IsBoot)]
+ loop :: [GenWithIsBoot (Located ModuleName)]
-- Work list: process these modules
-> NodeMap [Either ErrorMessages ModSummary]
-- Visited set; the range is a list because
@@ -2152,7 +2172,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
-> IO (NodeMap [Either ErrorMessages ModSummary])
-- The result is the completed NodeMap
loop [] done = return done
- loop ((wanted_mod, is_boot) : ss) done
+ loop (s : ss) done
| Just summs <- Map.lookup key done
= if isSingleton summs then
loop ss done
@@ -2170,7 +2190,12 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
loop (calcDeps s) (Map.insert key [Right s] done)
loop ss new_map
where
- key = (unLoc wanted_mod, is_boot)
+ GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = s
+ wanted_mod = L loc mod
+ key = GWIB
+ { gwib_mod = unLoc wanted_mod
+ , gwib_isBoot = is_boot
+ }
-- | Update the every ModSummary that is depended on
-- by a module that needs template haskell. We enable codegen to
@@ -2206,7 +2231,7 @@ enableCodeGenForUnboxedTuplesOrSums =
condition ms =
unboxed_tuples_or_sums (ms_hspp_opts ms) &&
not (gopt Opt_ByteCode (ms_hspp_opts ms)) &&
- not (isBootSummary ms)
+ (isBootSummary ms == NotBoot)
unboxed_tuples_or_sums d =
xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d
should_modify (ModSummary { ms_hspp_opts = dflags }) =
@@ -2281,10 +2306,11 @@ enableCodeGenWhen condition should_modify staticLife dynLife target nodemap =
-- If a module imports a boot module, msDeps helpfully adds a
-- dependency to that non-boot module in it's result. This
-- means we don't have to think about boot modules here.
- | (L _ mn, NotBoot) <- msDeps ms
- , dep_ms <-
- toList (Map.lookup (mn, NotBoot) nodemap) >>= toList >>=
- toList
+ | dep <- msDeps ms
+ , NotBoot == gwib_isBoot dep
+ , dep_ms_0 <- toList $ Map.lookup (unLoc <$> dep) nodemap
+ , dep_ms_1 <- toList $ dep_ms_0
+ , dep_ms <- toList $ dep_ms_1
]
new_marked_mods = Set.insert ms_mod marked_mods
in foldl' go new_marked_mods deps
@@ -2302,10 +2328,16 @@ mkRootMap summaries = Map.insertListWith (flip (++))
-- modules always contains B.hs if it contains B.hs-boot.
-- Remember, this pass isn't doing the topological sort. It's
-- just gathering the list of all relevant ModSummaries
-msDeps :: ModSummary -> [(Located ModuleName, IsBoot)]
-msDeps s =
- concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ]
- ++ [ (m,NotBoot) | m <- ms_home_imps s ]
+msDeps :: ModSummary -> [GenWithIsBoot (Located ModuleName)]
+msDeps s = [ d
+ | m <- ms_home_srcimps s
+ , d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot }
+ , GWIB { gwib_mod = m, gwib_isBoot = NotBoot }
+ ]
+ ]
+ ++ [ GWIB { gwib_mod = m, gwib_isBoot = NotBoot }
+ | m <- ms_home_imps s
+ ]
-----------------------------------------------------------------------------
-- Summarising modules
@@ -2392,7 +2424,7 @@ findSummaryBySourceFile summaries file
(x:_) -> Just x
checkSummaryTimestamp
- :: HscEnv -> DynFlags -> Bool -> IsBoot
+ :: HscEnv -> DynFlags -> Bool -> IsBootInterface
-> (UTCTime -> IO (Either e ModSummary))
-> ModSummary -> ModLocation -> UTCTime
-> IO (Either e ModSummary)
@@ -2433,7 +2465,7 @@ checkSummaryTimestamp
summariseModule
:: HscEnv
-> NodeMap ModSummary -- Map of old summaries
- -> IsBoot -- IsBoot <=> a {-# SOURCE #-} import
+ -> IsBootInterface -- True <=> a {-# SOURCE #-} import
-> Located ModuleName -- Imported module to be summarised
-> Bool -- object code allowed?
-> Maybe (StringBuffer, UTCTime)
@@ -2445,7 +2477,9 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
| wanted_mod `elem` excl_mods
= return Nothing
- | Just old_summary <- Map.lookup (wanted_mod, is_boot) old_summary_map
+ | Just old_summary <- Map.lookup
+ (GWIB { gwib_mod = wanted_mod, gwib_isBoot = is_boot })
+ old_summary_map
= do -- Find its new timestamp; all the
-- ModSummaries in the old map have valid ml_hs_files
let location = ms_location old_summary
@@ -2491,8 +2525,9 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
just_found location mod = do
-- Adjust location to point to the hs-boot source file,
-- hi file, object file, when is_boot says so
- let location' | IsBoot <- is_boot = addBootSuffixLocn location
- | otherwise = location
+ let location' = case is_boot of
+ IsBoot -> addBootSuffixLocn location
+ NotBoot -> location
src_fn = expectJust "summarise2" (ml_hs_file location')
-- Check that it exists
@@ -2514,10 +2549,10 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
-- case, we know if it's a boot or not because of the {-# SOURCE #-}
-- annotation, but we don't know if it's a signature or a regular
-- module until we actually look it up on the filesystem.
- let hsc_src = case is_boot of
- IsBoot -> HsBootFile
- _ | isHaskellSigFilename src_fn -> HsigFile
- | otherwise -> HsSrcFile
+ let hsc_src
+ | is_boot == IsBoot = HsBootFile
+ | isHaskellSigFilename src_fn = HsigFile
+ | otherwise = HsSrcFile
when (pi_mod_name /= wanted_mod) $
throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $
@@ -2560,7 +2595,7 @@ data MakeNewModSummary
= MakeNewModSummary
{ nms_src_fn :: FilePath
, nms_src_timestamp :: UTCTime
- , nms_is_boot :: IsBoot
+ , nms_is_boot :: IsBootInterface
, nms_hsc_src :: HscSource
, nms_location :: ModLocation
, nms_mod :: Module
@@ -2604,10 +2639,11 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do
, ms_obj_date = obj_timestamp
}
-getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime)
+getObjTimestamp :: ModLocation -> IsBootInterface -> IO (Maybe UTCTime)
getObjTimestamp location is_boot
- = if is_boot == IsBoot then return Nothing
- else modificationTimeIfExists (ml_obj_file location)
+ = case is_boot of
+ IsBoot -> return Nothing
+ NotBoot -> modificationTimeIfExists (ml_obj_file location)
data PreprocessedImports
= PreprocessedImports
@@ -2722,8 +2758,11 @@ cyclicModuleErr mss
graph = [ DigraphNode ms (msKey ms) (get_deps ms) | ms <- mss]
get_deps :: ModSummary -> [NodeKey]
- get_deps ms = ([ (unLoc m, IsBoot) | m <- ms_home_srcimps ms ] ++
- [ (unLoc m, NotBoot) | m <- ms_home_imps ms ])
+ get_deps ms =
+ [ GWIB { gwib_mod = unLoc m, gwib_isBoot = IsBoot }
+ | m <- ms_home_srcimps ms ] ++
+ [ GWIB { gwib_mod = unLoc m, gwib_isBoot = NotBoot }
+ | m <- ms_home_imps ms ]
show_path [] = panic "show_path"
show_path [m] = text "module" <+> ppr_ms m
=====================================
compiler/GHC/Driver/MakeFile.hs
=====================================
@@ -247,8 +247,8 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
| (mb_pkg, L loc mod) <- idecls,
mod `notElem` excl_mods ]
- ; do_imps True (ms_srcimps node)
- ; do_imps False (ms_imps node)
+ ; do_imps IsBoot (ms_srcimps node)
+ ; do_imps NotBoot (ms_imps node)
}
=====================================
compiler/GHC/Driver/Types.hs
=====================================
@@ -114,7 +114,7 @@ module GHC.Driver.Types (
MonadThings(..),
-- * Information on imports and exports
- WhetherHasOrphans, IsBootInterface, Usage(..),
+ WhetherHasOrphans, IsBootInterface(..), Usage(..),
Dependencies(..), noDependencies,
updNameCache,
IfaceExport,
@@ -745,12 +745,12 @@ hptInstances hsc_env want_this_module
in (concat insts, concat famInsts)
-- | Get rules from modules "below" this one (in the dependency sense)
-hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule]
+hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]
hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False
-- | Get annotations from modules "below" this one (in the dependency sense)
-hptAnns :: HscEnv -> Maybe [(ModuleName, IsBootInterface)] -> [Annotation]
+hptAnns :: HscEnv -> Maybe [ModuleNameWithIsBoot] -> [Annotation]
hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps
hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env
@@ -759,7 +759,7 @@ hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env))
-- | Get things from modules "below" this one (in the dependency sense)
-- C.f Inst.hptInstances
-hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [(ModuleName, IsBootInterface)] -> [a]
+hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]
hptSomeThingsBelowUs extract include_hi_boot hsc_env deps
| isOneShot (ghcMode (hsc_dflags hsc_env)) = []
@@ -768,8 +768,8 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps
in
[ thing
| -- Find each non-hi-boot module below me
- (mod, is_boot_mod) <- deps
- , include_hi_boot || not is_boot_mod
+ GWIB { gwib_mod = mod, gwib_isBoot = is_boot } <- deps
+ , include_hi_boot || (is_boot == NotBoot)
-- unsavoury: when compiling the base package with --make, we
-- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't
@@ -1114,8 +1114,10 @@ data ModIface_ (phase :: ModIfacePhase)
-- | Old-style accessor for whether or not the ModIface came from an hs-boot
-- file.
-mi_boot :: ModIface -> Bool
-mi_boot iface = mi_hsc_src iface == HsBootFile
+mi_boot :: ModIface -> IsBootInterface
+mi_boot iface = if mi_hsc_src iface == HsBootFile
+ then IsBoot
+ else NotBoot
-- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be
-- found, 'defaultFixity' is returned instead.
@@ -1141,7 +1143,7 @@ mi_free_holes iface =
-> renameFreeHoles (mkUniqDSet cands) (instUnitInsts (moduleUnit indef))
_ -> emptyUniqDSet
where
- cands = map fst (dep_mods (mi_deps iface))
+ cands = map gwib_mod $ dep_mods $ mi_deps iface
-- | Given a set of free holes, and a unit identifier, rename
-- the free holes according to the instantiation of the unit
@@ -2494,9 +2496,6 @@ type WhetherHasOrphans = Bool
-- | Does this module define family instances?
type WhetherHasFamInst = Bool
--- | Did this module originate from a *-boot file?
-type IsBootInterface = Bool
-
-- | Dependency information about ALL modules and packages below this one
-- in the import hierarchy.
--
@@ -2504,7 +2503,7 @@ type IsBootInterface = Bool
--
-- Invariant: none of the lists contain duplicates.
data Dependencies
- = Deps { dep_mods :: [(ModuleName, IsBootInterface)]
+ = Deps { dep_mods :: [ModuleNameWithIsBoot]
-- ^ All home-package modules transitively below this one
-- I.e. modules that this one imports, or that are in the
-- dep_mods of those directly-imported modules
@@ -2694,7 +2693,7 @@ type PackageCompleteMatchMap = CompleteMatchMap
-- their interface files
data ExternalPackageState
= EPS {
- eps_is_boot :: !(ModuleNameEnv (ModuleName, IsBootInterface)),
+ eps_is_boot :: !(ModuleNameEnv ModuleNameWithIsBoot),
-- ^ In OneShot mode (only), home-package modules
-- accumulate in the external package state, and are
-- sucked in lazily. For these home-pkg modules
@@ -2872,19 +2871,19 @@ isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ms =
(xopt LangExt.TemplateHaskell (ms_hspp_opts ms)
|| xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) &&
- not (isBootSummary ms)
+ (isBootSummary ms == NotBoot)
-- | Add a ModSummary to ModuleGraph. Assumes that the new ModSummary is
-- not an element of the ModuleGraph.
extendMG :: ModuleGraph -> ModSummary -> ModuleGraph
extendMG ModuleGraph{..} ms = ModuleGraph
{ mg_mss = ms:mg_mss
- , mg_non_boot = if isBootSummary ms
- then mg_non_boot
- else extendModuleEnv mg_non_boot (ms_mod ms) ms
- , mg_boot = if isBootSummary ms
- then extendModuleSet mg_boot (ms_mod ms)
- else mg_boot
+ , mg_non_boot = case isBootSummary ms of
+ IsBoot -> mg_non_boot
+ NotBoot -> extendModuleEnv mg_non_boot (ms_mod ms) ms
+ , mg_boot = case isBootSummary ms of
+ NotBoot -> mg_boot
+ IsBoot -> extendModuleSet mg_boot (ms_mod ms)
, mg_needs_th_or_qq = mg_needs_th_or_qq || isTemplateHaskellOrQQNonBoot ms
}
@@ -2985,8 +2984,8 @@ msDynObjFilePath :: ModSummary -> DynFlags -> FilePath
msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms)
-- | Did this 'ModSummary' originate from a hs-boot file?
-isBootSummary :: ModSummary -> Bool
-isBootSummary ms = ms_hsc_src ms == HsBootFile
+isBootSummary :: ModSummary -> IsBootInterface
+isBootSummary ms = if ms_hsc_src ms == HsBootFile then IsBoot else NotBoot
instance Outputable ModSummary where
ppr ms
=====================================
compiler/GHC/Hs/ImpExp.hs
=====================================
@@ -18,7 +18,7 @@ module GHC.Hs.ImpExp where
import GHC.Prelude
-import GHC.Unit.Module ( ModuleName )
+import GHC.Unit.Module ( ModuleName, IsBootInterface(..) )
import GHC.Hs.Doc ( HsDocString )
import GHC.Types.Name.Occurrence ( HasOccName(..), isTcOcc, isSymOcc )
import GHC.Types.Basic ( SourceText(..), StringLiteral(..), pprWithSourceText )
@@ -83,7 +83,7 @@ data ImportDecl pass
-- Note [Pragma source text] in GHC.Types.Basic
ideclName :: Located ModuleName, -- ^ Module name.
ideclPkgQual :: Maybe StringLiteral, -- ^ Package qualifier.
- ideclSource :: Bool, -- ^ True <=> {-\# SOURCE \#-} import
+ ideclSource :: IsBootInterface, -- ^ IsBoot <=> {-\# SOURCE \#-} import
ideclSafe :: Bool, -- ^ True => safe import
ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified.
ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude)
@@ -118,7 +118,7 @@ simpleImportDecl mn = ImportDecl {
ideclSourceSrc = NoSourceText,
ideclName = noLoc mn,
ideclPkgQual = Nothing,
- ideclSource = False,
+ ideclSource = NotBoot,
ideclSafe = False,
ideclImplicit = False,
ideclQualified = NotQualified,
@@ -156,10 +156,10 @@ instance OutputableBndrId p
pp_as Nothing = empty
pp_as (Just a) = text "as" <+> ppr a
- ppr_imp True = case mSrcText of
+ ppr_imp IsBoot = case mSrcText of
NoSourceText -> text "{-# SOURCE #-}"
SourceText src -> text src <+> text "#-}"
- ppr_imp False = empty
+ ppr_imp NotBoot = empty
pp_spec Nothing = empty
pp_spec (Just (False, (L _ ies))) = ppr_ies ies
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -285,7 +285,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs",
if_rec_types = Just (mod, return type_env) }
if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
- False -- not boot!
+ NotBoot
real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
completeMatchMap = mkCompleteMatchMap complete_matches
gbl_env = DsGblEnv { ds_mod = mod
=====================================
compiler/GHC/HsToCore/Usage.hs
=====================================
@@ -215,9 +215,10 @@ mkPluginUsage hsc_env pluginModule
where
dflags = hsc_dflags hsc_env
platform = targetPlatform dflags
- pNm = moduleName (mi_module pluginModule)
- pPkg = moduleUnit (mi_module pluginModule)
- deps = map fst (dep_mods (mi_deps pluginModule))
+ pNm = moduleName $ mi_module pluginModule
+ pPkg = moduleUnit $ mi_module pluginModule
+ deps = map gwib_mod $
+ dep_mods $ mi_deps pluginModule
-- Lookup object file for a plugin dependency,
-- from the same package as the plugin.
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -366,7 +366,7 @@ loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBy
------------------
-- | Loads a user interface and throws an exception if it fails. The first parameter indicates
-- whether we should import the boot variant of the module
-loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface
+loadUserInterface :: IsBootInterface -> SDoc -> Module -> IfM lcl ModIface
loadUserInterface is_boot doc mod_name
= loadInterfaceWithException doc mod_name (ImportByUser is_boot)
@@ -485,7 +485,7 @@ loadInterface doc_str mod from
}
}
- ; let bad_boot = mi_boot iface && fmap fst (if_rec_types gbl_env) == Just mod
+ ; let bad_boot = mi_boot iface == IsBoot && fmap fst (if_rec_types gbl_env) == Just mod
-- Warn warn against an EPS-updating import
-- of one's own boot file! (one-shot only)
-- See Note [Loading your own hi-boot file]
@@ -690,7 +690,7 @@ moduleFreeHolesPrecise doc_str mod
Just ifhs -> Just (renameFreeHoles ifhs insts)
_otherwise -> Nothing
readAndCache imod insts = do
- mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod mod False
+ mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod mod NotBoot
case mb_iface of
Succeeded (iface, _) -> do
let ifhs = mi_free_holes iface
@@ -706,23 +706,25 @@ wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom
wantHiBootFile dflags eps mod from
= case from of
ImportByUser usr_boot
- | usr_boot && not this_package
+ | usr_boot == IsBoot && not this_package
-> Failed (badSourceImport mod)
| otherwise -> Succeeded usr_boot
ImportByPlugin
- -> Succeeded False
+ -> Succeeded NotBoot
ImportBySystem
| not this_package -- If the module to be imported is not from this package
- -> Succeeded False -- don't look it up in eps_is_boot, because that is keyed
+ -> Succeeded NotBoot -- don't look it up in eps_is_boot, because that is keyed
-- on the ModuleName of *home-package* modules only.
-- We never import boot modules from other packages!
| otherwise
-> case lookupUFM (eps_is_boot eps) (moduleName mod) of
- Just (_, is_boot) -> Succeeded is_boot
- Nothing -> Succeeded False
+ Just (GWIB { gwib_isBoot = is_boot }) ->
+ Succeeded is_boot
+ Nothing ->
+ Succeeded NotBoot
-- The boot-ness of the requested interface,
-- based on the dependencies in directly-imported modules
where
@@ -899,7 +901,7 @@ findAndReadIface :: SDoc
-- sometimes it's ok to fail... see notes with loadInterface
findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file
= do traceIf (sep [hsep [text "Reading",
- if hi_boot_file
+ if hi_boot_file == IsBoot
then text "[boot]"
else Outputable.empty,
text "interface for",
@@ -1219,11 +1221,11 @@ pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
text "family instance modules:" <+> fsep (map ppr finsts)
]
where
- ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot
+ ppr_mod (GWIB { gwib_mod = mod_name, gwib_isBoot = boot }) = ppr mod_name <+> ppr_boot boot
ppr_pkg (pkg,trust_req) = ppr pkg <>
(if trust_req then text "*" else Outputable.empty)
- ppr_boot True = text "[boot]"
- ppr_boot False = Outputable.empty
+ ppr_boot IsBoot = text "[boot]"
+ ppr_boot NotBoot = Outputable.empty
pprFixities :: [(OccName, Fixity)] -> SDoc
pprFixities [] = Outputable.empty
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -252,7 +252,7 @@ checkVersions hsc_env mod_summary iface
where
this_pkg = thisPackage (hsc_dflags hsc_env)
-- This is a bit of a hack really
- mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
+ mod_deps :: ModuleNameEnv ModuleNameWithIsBoot
mod_deps = mkModDeps (dep_mods (mi_deps iface))
-- | Check if any plugins are requesting recompilation
@@ -455,7 +455,7 @@ checkDependencies hsc_env summary iface
case find_res of
Found _ mod
| pkg == this_pkg
- -> if moduleName mod `notElem` map fst prev_dep_mods ++ prev_dep_plgn
+ -> if moduleName mod `notElem` map gwib_mod prev_dep_mods ++ prev_dep_plgn
then do traceHiDiffs $
text "imported module " <> quotes (ppr mod) <>
text " not among previous dependencies"
@@ -474,7 +474,9 @@ checkDependencies hsc_env summary iface
where pkg = moduleUnit mod
_otherwise -> return (RecompBecause reason)
- old_deps = Set.fromList $ map fst $ filter (not . snd) prev_dep_mods
+ projectNonBootNames = map gwib_mod . filter ((== NotBoot) . gwib_isBoot)
+ old_deps = Set.fromList
+ $ projectNonBootNames prev_dep_mods
isOldHomeDeps = flip Set.member old_deps
checkForNewHomeDependency (L _ mname) = do
let
@@ -489,7 +491,7 @@ checkDependencies hsc_env summary iface
then return (UpToDate, [])
else do
mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do
- let mnames = mname:(map fst $ filter (not . snd) $
+ let mnames = mname:(map gwib_mod $ filter ((== NotBoot) . gwib_isBoot) $
dep_mods $ mi_deps imported_iface)
case find (not . isOldHomeDeps) mnames of
Nothing -> return (UpToDate, mnames)
@@ -1073,7 +1075,7 @@ getOrphanHashes hsc_env mods = do
sortDependencies :: Dependencies -> Dependencies
sortDependencies d
- = Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
+ = Deps { dep_mods = sortBy (compare `on` (moduleNameFS . gwib_mod)) (dep_mods d),
dep_pkgs = sortBy (compare `on` fst) (dep_pkgs d),
dep_orphs = sortBy stableModuleCmp (dep_orphs d),
dep_finsts = sortBy stableModuleCmp (dep_finsts d),
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -354,7 +354,7 @@ mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl
typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails])
typecheckIfacesForMerging mod ifaces tc_env_var =
-- cannot be boot (False)
- initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do
+ initIfaceLcl mod (text "typecheckIfacesForMerging") NotBoot $ do
ignore_prags <- goptM Opt_IgnoreInterfacePragmas
-- Build the initial environment
-- NB: Don't include dfuns here, because we don't want to
@@ -506,7 +506,7 @@ tcHiBootIface hsc_src mod
-- it's been compiled once, and we don't need to check the boot iface
then do { hpt <- getHpt
; case lookupHpt hpt (moduleName mod) of
- Just info | mi_boot (hm_iface info)
+ Just info | mi_boot (hm_iface info) == IsBoot
-> mkSelfBootInfo (hm_iface info) (hm_details info)
_ -> return NoSelfBoot }
else do
@@ -517,7 +517,7 @@ tcHiBootIface hsc_src mod
-- that an hi-boot is necessary due to a circular import.
{ read_result <- findAndReadIface
need (fst (getModuleInstantiation mod)) mod
- True -- Hi-boot file
+ IsBoot -- Hi-boot file
; case read_result of {
Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface
@@ -533,14 +533,15 @@ tcHiBootIface hsc_src mod
-- disappeared.
do { eps <- getEps
; case lookupUFM (eps_is_boot eps) (moduleName mod) of
- Nothing -> return NoSelfBoot -- The typical case
-
- Just (_, False) -> failWithTc moduleLoop
- -- Someone below us imported us!
- -- This is a loop with no hi-boot in the way
-
- Just (_mod, True) -> failWithTc (elaborate err)
- -- The hi-boot file has mysteriously disappeared.
+ -- The typical case
+ Nothing -> return NoSelfBoot
+ -- error cases
+ Just (GWIB { gwib_isBoot = is_boot }) -> case is_boot of
+ IsBoot -> failWithTc (elaborate err)
+ -- The hi-boot file has mysteriously disappeared.
+ NotBoot -> failWithTc moduleLoop
+ -- Someone below us imported us!
+ -- This is a loop with no hi-boot in the way
}}}}
where
need = text "Need the hi-boot interface for" <+> ppr mod
@@ -1480,8 +1481,9 @@ tcIdInfo ignore_prags toplvl name ty info = do
lcl_env <- getLclEnv
-- Set the CgInfo to something sensible but uninformative before
-- we start; default assumption is that it has CAFs
- let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding
- | otherwise = vanillaIdInfo
+ let init_info = if if_boot lcl_env == IsBoot
+ then vanillaIdInfo `setUnfoldingInfo` BootUnfolding
+ else vanillaIdInfo
let needed = needed_prags info
foldlM tcPrag init_info needed
=====================================
compiler/GHC/Parser.y
=====================================
@@ -51,7 +51,7 @@ import qualified Prelude
import GHC.Hs
import GHC.Driver.Phases ( HscSource(..) )
-import GHC.Driver.Types ( IsBootInterface, WarningTxt(..) )
+import GHC.Driver.Types ( IsBootInterface(..), WarningTxt(..) )
import GHC.Driver.Session
import GHC.Driver.Backpack.Syntax
import GHC.Unit.Info
@@ -722,8 +722,8 @@ unitdecl :: { LHsUnitDecl PackageName }
-- XXX not accurate
{ sL1 $2 $ DeclD
(case snd $3 of
- False -> HsSrcFile
- True -> HsBootFile)
+ NotBoot -> HsSrcFile
+ IsBoot -> HsBootFile)
$4
(Just $ sL1 $2 (HsModule (Just $4) $6 (fst $ snd $8) (snd $ snd $8) $5 $1)) }
| maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body
@@ -735,8 +735,8 @@ unitdecl :: { LHsUnitDecl PackageName }
-- will prevent us from parsing both forms.
| maybedocheader 'module' maybe_src modid
{ sL1 $2 $ DeclD (case snd $3 of
- False -> HsSrcFile
- True -> HsBootFile) $4 Nothing }
+ NotBoot -> HsSrcFile
+ IsBoot -> HsBootFile) $4 Nothing }
| maybedocheader 'signature' modid
{ sL1 $2 $ DeclD HsigFile $3 Nothing }
| 'dependency' unitid mayberns
@@ -985,8 +985,8 @@ importdecl :: { LImportDecl GhcPs }
maybe_src :: { (([AddAnn],SourceText),IsBootInterface) }
: '{-# SOURCE' '#-}' { (([mo $1,mc $2],getSOURCE_PRAGs $1)
- , True) }
- | {- empty -} { (([],NoSourceText),False) }
+ , IsBoot) }
+ | {- empty -} { (([],NoSourceText),NotBoot) }
maybe_safe :: { ([AddAnn],Bool) }
: 'safe' { ([mj AnnSafe $1],True) }
=====================================
compiler/GHC/Parser/Header.hs
=====================================
@@ -91,7 +91,7 @@ getImports dflags buf filename source_filename = do
main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename)
1 1)
mod = mb_mod `orElse` L main_loc mAIN_NAME
- (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
+ (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
-- GHC.Prim doesn't exist physically, so don't go looking for it.
ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc
@@ -135,7 +135,7 @@ mkPrelImports this_mod loc implicit_prelude import_decls
ideclSourceSrc = NoSourceText,
ideclName = L loc pRELUDE_NAME,
ideclPkgQual = Nothing,
- ideclSource = False,
+ ideclSource = NotBoot,
ideclSafe = False, -- Not a safe import
ideclQualified = NotQualified,
ideclImplicit = True, -- Implicit!
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -1347,7 +1347,7 @@ lookupQualifiedNameGHCi rdr_name
, is_ghci
, gopt Opt_ImplicitImportQualified dflags -- Enables this GHCi behaviour
, not (safeDirectImpsReq dflags) -- See Note [Safe Haskell and GHCi]
- = do { res <- loadSrcInterface_maybe doc mod False Nothing
+ = do { res <- loadSrcInterface_maybe doc mod NotBoot Nothing
; case res of
Succeeded iface
-> return [ name
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -176,7 +176,7 @@ rnImports imports = do
-- module to import from its implementor
let this_mod = tcg_mod tcg_env
let (source, ordinary) = partition is_source_import imports
- is_source_import d = ideclSource (unLoc d)
+ is_source_import d = ideclSource (unLoc d) == IsBoot
stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary
stuff2 <- mapAndReportM (rnImportDecl this_mod) source
-- Safe Haskell: See Note [Tracking Trust Transitively]
@@ -323,7 +323,7 @@ rnImportDecl this_mod
-- Compiler sanity check: if the import didn't say
-- {-# SOURCE #-} we should not get a hi-boot file
- WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) do
+ WARN( (want_boot == NotBoot) && (mi_boot iface == IsBoot), ppr imp_mod_name ) do
-- Issue a user warning for a redundant {- SOURCE -} import
-- NB that we arrange to read all the ordinary imports before
@@ -334,7 +334,7 @@ rnImportDecl this_mod
-- the non-boot module depends on the compilation order, which
-- is not deterministic. The hs-boot test can show this up.
dflags <- getDynFlags
- warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags))
+ warnIf ((want_boot == IsBoot) && (mi_boot iface == NotBoot) && isOneShot (ghcMode dflags))
(warnRedundantSourceImport imp_mod_name)
when (mod_safe && not (safeImportsOn dflags)) $
addErr (text "safe import can't be used as Safe Haskell isn't on!"
@@ -460,7 +460,10 @@ calculateAvails dflags iface mod_safe' want_boot imported_by =
-- know if any of them depended on CM.hi-boot, in
-- which case we should do the hi-boot consistency
-- check. See GHC.Iface.Load.loadHiBootInterface
- ((moduleName imp_mod,want_boot):dep_mods deps,dep_pkgs deps,ptrust)
+ ( GWIB { gwib_mod = moduleName imp_mod, gwib_isBoot = want_boot } : dep_mods deps
+ , dep_pkgs deps
+ , ptrust
+ )
| otherwise =
-- Imported module is from another package
@@ -1698,20 +1701,23 @@ qualImportItemErr rdr
= hang (text "Illegal qualified name in import item:")
2 (ppr rdr)
+pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc
+pprImpDeclSpec iface decl_spec =
+ quotes (ppr (is_mod decl_spec)) <+> case mi_boot iface of
+ IsBoot -> text "(hi-boot interface)"
+ NotBoot -> Outputable.empty
+
badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc
badImportItemErrStd iface decl_spec ie
- = sep [text "Module", quotes (ppr (is_mod decl_spec)), source_import,
+ = sep [text "Module", pprImpDeclSpec iface decl_spec,
text "does not export", quotes (ppr ie)]
- where
- source_import | mi_boot iface = text "(hi-boot interface)"
- | otherwise = Outputable.empty
badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE GhcPs
-> SDoc
badImportItemErrDataCon dataType_occ iface decl_spec ie
= vcat [ text "In module"
- <+> quotes (ppr (is_mod decl_spec))
- <+> source_import <> colon
+ <+> pprImpDeclSpec iface decl_spec
+ <> colon
, nest 2 $ quotes datacon
<+> text "is a data constructor of"
<+> quotes dataType
@@ -1728,8 +1734,6 @@ badImportItemErrDataCon dataType_occ iface decl_spec ie
datacon_occ = rdrNameOcc $ ieName ie
datacon = parenSymOcc datacon_occ (ppr datacon_occ)
dataType = parenSymOcc dataType_occ (ppr dataType_occ)
- source_import | mi_boot iface = text "(hi-boot interface)"
- | otherwise = Outputable.empty
parens_sp d = parens (space <> d <> space) -- T( f,g )
badImportItemErr :: ModIface -> ImpDeclSpec -> IE GhcPs -> [AvailInfo] -> SDoc
=====================================
compiler/GHC/Runtime/Linker.hs
=====================================
@@ -68,6 +68,7 @@ import Control.Monad
import qualified Data.Set as Set
import Data.Char (isSpace)
+import Data.Function ((&))
import Data.IORef
import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition)
import Data.Maybe
@@ -670,21 +671,23 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
follow_deps (mod:mods) acc_mods acc_pkgs
= do
mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $
- loadInterface msg mod (ImportByUser False)
+ loadInterface msg mod (ImportByUser NotBoot)
iface <- case mb_iface of
Maybes.Failed err -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))
Maybes.Succeeded iface -> return iface
- when (mi_boot iface) $ link_boot_mod_error mod
+ when (mi_boot iface == IsBoot) $ link_boot_mod_error mod
let
pkg = moduleUnit mod
deps = mi_deps iface
pkg_deps = dep_pkgs deps
- (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
- where is_boot (m,True) = Left m
- is_boot (m,False) = Right m
+ (boot_deps, mod_deps) = flip partitionWith (dep_mods deps) $
+ \ (GWIB { gwib_mod = m, gwib_isBoot = is_boot }) ->
+ m & case is_boot of
+ IsBoot -> Left
+ NotBoot -> Right
boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps
acc_mods' = addListToUniqDSet acc_mods (moduleName mod : mod_deps)
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -321,7 +321,7 @@ tcRnImports hsc_env import_decls
= do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;
; this_mod <- getModule
- ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
+ ; let { dep_mods :: ModuleNameEnv ModuleNameWithIsBoot
; dep_mods = imp_dep_mods imports
-- We want instance declarations from all home-package
@@ -1973,7 +1973,7 @@ runTcInteractive hsc_env thing_inside
; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface
: dep_orphs (mi_deps iface))
(loadSrcInterface (text "runTcInteractive") m
- False mb_pkg)
+ NotBoot mb_pkg)
; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
case i of -- force above: see #15111
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -262,7 +262,7 @@ data IfLclEnv
-- Whether or not the IfaceDecl came from a boot
-- file or not; we'll use this to choose between
-- NoUnfolding and BootUnfolding
- if_boot :: Bool,
+ if_boot :: IsBootInterface,
-- The field is used only for error reporting
-- if (say) there's a Lint error in it
@@ -1340,7 +1340,7 @@ data ImportAvails
-- different packages. (currently not the case, but might be in the
-- future).
- imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface),
+ imp_dep_mods :: ModuleNameEnv ModuleNameWithIsBoot,
-- ^ Home-package modules needed by the module being compiled
--
-- It doesn't matter whether any of these dependencies
@@ -1381,15 +1381,15 @@ data ImportAvails
-- including us for imported modules)
}
-mkModDeps :: [(ModuleName, IsBootInterface)]
- -> ModuleNameEnv (ModuleName, IsBootInterface)
+mkModDeps :: [ModuleNameWithIsBoot]
+ -> ModuleNameEnv ModuleNameWithIsBoot
mkModDeps deps = foldl' add emptyUFM deps
- where
- add env elt@(m,_) = addToUFM env m elt
+ where
+ add env elt = addToUFM env (gwib_mod elt) elt
modDepsElts
- :: ModuleNameEnv (ModuleName, IsBootInterface)
- -> [(ModuleName, IsBootInterface)]
+ :: ModuleNameEnv ModuleNameWithIsBoot
+ -> [ModuleNameWithIsBoot]
modDepsElts = sort . nonDetEltsUFM
-- It's OK to use nonDetEltsUFM here because sorting by module names
-- restores determinism
@@ -1426,9 +1426,10 @@ plusImportAvails
imp_orphs = orphs1 `unionLists` orphs2,
imp_finsts = finsts1 `unionLists` finsts2 }
where
- plus_mod_dep r1@(m1, boot1) r2@(m2, boot2)
- | ASSERT2( m1 == m2, (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) )
- boot1 = r2
+ plus_mod_dep r1@(GWIB { gwib_mod = m1, gwib_isBoot = boot1 })
+ r2@(GWIB {gwib_mod = m2, gwib_isBoot = boot2})
+ | ASSERT2( m1 == m2, (ppr m1 <+> ppr m2) $$ (ppr (boot1 == IsBoot) <+> ppr (boot2 == IsBoot)))
+ boot1 == IsBoot = r2
| otherwise = r1
-- If either side can "see" a non-hi-boot interface, use that
-- Reusing existing tuples saves 10% of allocations on test
@@ -1451,8 +1452,8 @@ data WhereFrom
-- See Note [Care with plugin imports] in GHC.Iface.Load
instance Outputable WhereFrom where
- ppr (ImportByUser is_boot) | is_boot = text "{- SOURCE -}"
- | otherwise = empty
+ ppr (ImportByUser IsBoot) = text "{- SOURCE -}"
+ ppr (ImportByUser NotBoot) = empty
ppr ImportBySystem = text "{- SYSTEM -}"
ppr ImportByPlugin = text "{- PLUGIN -}"
=====================================
compiler/GHC/Tc/Utils/Backpack.hs
=====================================
@@ -549,7 +549,7 @@ mergeSignatures
im = fst (getModuleInstantiation m)
in fmap fst
. withException
- $ findAndReadIface (text "mergeSignatures") im m False
+ $ findAndReadIface (text "mergeSignatures") im m NotBoot
-- STEP 3: Get the unrenamed exports of all these interfaces,
-- thin it according to the export list, and do shaping on them.
@@ -842,7 +842,7 @@ mergeSignatures
-- supposed to include itself in its dep_orphs/dep_finsts. See #13214
iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } }
avails = plusImportAvails (tcg_imports tcg_env) $
- calculateAvails dflags iface' False False ImportedBySystem
+ calculateAvails dflags iface' False NotBoot ImportedBySystem
return tcg_env {
tcg_inst_env = inst_env,
tcg_insts = insts,
@@ -929,7 +929,7 @@ checkImplements impl_mod req_mod@(Module uid mod_name) =
dflags <- getDynFlags
let avails = calculateAvails dflags
- impl_iface False{- safe -} False{- boot -} ImportedBySystem
+ impl_iface False{- safe -} NotBoot ImportedBySystem
fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
| (occ, f) <- mi_fixities impl_iface
, rdr_elt <- lookupGlobalRdrEnv impl_gr occ ]
@@ -953,7 +953,7 @@ checkImplements impl_mod req_mod@(Module uid mod_name) =
-- instantiation is correct.
let sig_mod = mkModule (VirtUnit uid) mod_name
isig_mod = fst (getModuleInstantiation sig_mod)
- mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod False
+ mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod NotBoot
isig_iface <- case mb_isig_iface of
Succeeded (iface, _) -> return iface
Failed err -> failWithTc $
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -1830,7 +1830,7 @@ setLocalRdrEnv rdr_env thing_inside
************************************************************************
-}
-mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv
+mkIfLclEnv :: Module -> SDoc -> IsBootInterface -> IfLclEnv
mkIfLclEnv mod loc boot
= IfLclEnv { if_mod = mod,
if_loc = loc,
@@ -1887,14 +1887,14 @@ initIfaceCheck doc hsc_env do_this
}
initTcRnIf 'i' hsc_env gbl_env () do_this
-initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a
+initIfaceLcl :: Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a
initIfaceLcl mod loc_doc hi_boot_file thing_inside
= setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside
-- | Initialize interface typechecking, but with a 'NameShape'
-- to apply when typechecking top-level 'OccName's (see
-- 'lookupIfaceTop')
-initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a
+initIfaceLclWithSubst :: Module -> SDoc -> IsBootInterface -> NameShape -> IfL a -> IfM lcl a
initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside
= setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside
=====================================
compiler/GHC/Unit/Module.hs
=====================================
@@ -9,13 +9,13 @@ These are Uniquable, hence we can build Maps with Modules as
the keys.
-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ExplicitNamespaces #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeSynonymInstances #-}
module GHC.Unit.Module
( module GHC.Unit.Types
@@ -29,7 +29,6 @@ module GHC.Unit.Module
-- * ModuleEnv
, module GHC.Unit.Module.Env
-
-- * Generalization
, getModuleInstantiation
, getUnitInstantiations
@@ -148,4 +147,3 @@ isHoleModule _ = False
-- | Create a hole Module
mkHoleModule :: ModuleName -> GenModule (GenUnit u)
mkHoleModule = Module HoleUnit
-
=====================================
compiler/GHC/Unit/Module/Location.hs
=====================================
@@ -9,6 +9,7 @@ module GHC.Unit.Module.Location
where
import GHC.Prelude
+import GHC.Unit.Types
import GHC.Utils.Outputable
-- | Module Location
@@ -54,10 +55,10 @@ addBootSuffix :: FilePath -> FilePath
addBootSuffix path = path ++ "-boot"
-- | Add the @-boot@ suffix if the @Bool@ argument is @True@
-addBootSuffix_maybe :: Bool -> FilePath -> FilePath
-addBootSuffix_maybe is_boot path
- | is_boot = addBootSuffix path
- | otherwise = path
+addBootSuffix_maybe :: IsBootInterface -> FilePath -> FilePath
+addBootSuffix_maybe is_boot path = case is_boot of
+ IsBoot -> addBootSuffix path
+ NotBoot -> path
-- | Add the @-boot@ suffix to all file paths associated with the module
addBootSuffixLocn :: ModLocation -> ModLocation
=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -1,7 +1,8 @@
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE NamedFieldPuns #-}
-- | Unit & Module types
--
@@ -63,6 +64,12 @@ module GHC.Unit.Types
, interactiveUnitId
, isInteractiveModule
, wiredInUnitIds
+
+ -- * Boot modules
+ , IsBootInterface (..)
+ , GenWithIsBoot (..)
+ , ModuleNameWithIsBoot
+ , ModuleWithIsBoot
)
where
@@ -634,3 +641,64 @@ wiredInUnitIds =
, thUnitId
, thisGhcUnitId
]
+
+---------------------------------------------------------------------
+-- Boot Modules
+---------------------------------------------------------------------
+
+-- Note [Boot Module Naming]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Why is this section here? After all, these modules are supposed to be about
+-- ways of referring to modules, not modules themselves. Well, the "bootness" of
+-- a module is in a way part of its name, because 'import {-# SOURCE #-} Foo'
+-- references the boot module in particular while 'import Foo' references the
+-- regular module. Backpack signatures live in the normal module namespace (no
+-- special import), so they don't matter here. When dealing with the modules
+-- themselves, however, one should use not 'IsBoot' or conflate signatures and
+-- modules in opposition to boot interfaces. Instead, one should use
+-- 'DriverPhases.HscSource'. See Note [HscSource types].
+
+-- | Indicates whether a module name is referring to a boot interface (hs-boot
+-- file) or regular module (hs file). We need to treat boot modules specially
+-- when building compilation graphs, since they break cycles. Regular source
+-- files and signature files are treated equivalently.
+data IsBootInterface = NotBoot | IsBoot
+ deriving (Eq, Ord, Show, Data)
+
+instance Binary IsBootInterface where
+ put_ bh ib = put_ bh $
+ case ib of
+ NotBoot -> False
+ IsBoot -> True
+ get bh = do
+ b <- get bh
+ return $ case b of
+ False -> NotBoot
+ True -> IsBoot
+
+-- | This data type just pairs a value 'mod' with an IsBootInterface flag. In
+-- practice, 'mod' is usually a @Module@ or @ModuleName@'.
+data GenWithIsBoot mod = GWIB
+ { gwib_mod :: mod
+ , gwib_isBoot :: IsBootInterface
+ } deriving ( Eq, Ord, Show
+ , Functor, Foldable, Traversable
+ )
+
+type ModuleNameWithIsBoot = GenWithIsBoot ModuleName
+
+type ModuleWithIsBoot = GenWithIsBoot Module
+
+instance Binary a => Binary (GenWithIsBoot a) where
+ put_ bh (GWIB { gwib_mod, gwib_isBoot }) = do
+ put_ bh gwib_mod
+ put_ bh gwib_isBoot
+ get bh = do
+ gwib_mod <- get bh
+ gwib_isBoot <- get bh
+ pure $ GWIB { gwib_mod, gwib_isBoot }
+
+instance Outputable a => Outputable (GenWithIsBoot a) where
+ ppr (GWIB { gwib_mod, gwib_isBoot }) = hsep $ ppr gwib_mod : case gwib_isBoot of
+ IsBoot -> []
+ NotBoot -> [text "{-# SOURCE #-}"]
=====================================
ghc/Main.hs
=====================================
@@ -918,7 +918,7 @@ abiHash strs = do
mods <- mapM find_it strs
- let get_iface modl = loadUserInterface False (text "abiHash") modl
+ let get_iface modl = loadUserInterface NotBoot (text "abiHash") modl
ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods
bh <- openBinMem (3*1024) -- just less than a block
=====================================
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
=====================================
@@ -14,7 +14,7 @@
({ DumpParsedAst.hs:5:8-16 }
{ModuleName: Data.Kind})
(Nothing)
- (False)
+ (NotBoot)
(False)
(NotQualified)
(False)
=====================================
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
=====================================
@@ -648,7 +648,7 @@
({ DumpRenamedAst.hs:4:8-21 }
{ModuleName: Prelude})
(Nothing)
- (False)
+ (NotBoot)
(False)
(NotQualified)
(True)
@@ -661,7 +661,7 @@
({ DumpRenamedAst.hs:5:8-16 }
{ModuleName: Data.Kind})
(Nothing)
- (False)
+ (NotBoot)
(False)
(NotQualified)
(False)
@@ -674,7 +674,7 @@
({ DumpRenamedAst.hs:7:8-16 }
{ModuleName: Data.Kind})
(Nothing)
- (False)
+ (NotBoot)
(False)
(NotQualified)
(False)
=====================================
testsuite/tests/parser/should_compile/KindSigs.stderr
=====================================
@@ -14,7 +14,7 @@
({ KindSigs.hs:8:8-16 }
{ModuleName: Data.Kind})
(Nothing)
- (False)
+ (NotBoot)
(False)
(NotQualified)
(False)
@@ -608,5 +608,3 @@
[])))]
(Nothing)
(Nothing)))
-
-
=====================================
testsuite/tests/parser/should_compile/T14189.stderr
=====================================
@@ -108,7 +108,7 @@
({ T14189.hs:1:8-13 }
{ModuleName: Prelude})
(Nothing)
- (False)
+ (NotBoot)
(False)
(NotQualified)
(True)
=====================================
testsuite/tests/parser/should_run/CountParserDeps.hs
=====================================
@@ -59,4 +59,4 @@ parserDeps libdir =
mkModule = Module (stringToUnit "ghc")
modDeps :: ModIface -> [ModuleName]
- modDeps mi = map fst $ dep_mods (mi_deps mi)
+ modDeps mi = map gwib_mod $ dep_mods (mi_deps mi)
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 8134a3be2c01ab5f1b88fed86c4ad7cc2f417f0a
+Subproject commit 60c85324ae083e2ac3d6180c0f20db5cdb31168b
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/32a4ae90b50cc56f2955f489ad0cf8c7ff5e131a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/32a4ae90b50cc56f2955f489ad0cf8c7ff5e131a
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200604/af4014b7/attachment-0001.html>
More information about the ghc-commits
mailing list