Commit ac1a3793 authored by Edward Z. Yang's avatar Edward Z. Yang

Revert "Unify hsig and hs-boot; add preliminary "hs-boot" merging."

Summary:
This reverts commit 06d46b1e.

This also has a Haddock submodule update.

Test Plan: validate

Reviewers: simonpj, austin, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1475
parent 9193629a
......@@ -296,7 +296,7 @@ deSugar hsc_env
hpcInfo = emptyHpcInfo other_hpc_info
; (binds_cvr, ds_hpc_info, modBreaks)
<- if not (isHsBoot hsc_src)
<- if not (isHsBootOrSig hsc_src)
then addTicksToBinds dflags mod mod_loc export_set
(typeEnvTyCons type_env) binds
else return (binds, hpcInfo, emptyModBreaks)
......
......@@ -897,7 +897,7 @@ pprModIface iface
]
where
pp_hsc_src HsBootFile = ptext (sLit "[boot]")
pp_hsc_src HsBootMerge = ptext (sLit "[merge]")
pp_hsc_src HsigFile = ptext (sLit "[hsig]")
pp_hsc_src HsSrcFile = Outputable.empty
{-
......
......@@ -13,7 +13,6 @@ module MkIface (
-- including computing version information
mkIfaceTc,
mkIfaceDirect,
writeIfaceFile, -- Write the interface file
......@@ -154,35 +153,6 @@ mkIface hsc_env maybe_old_fingerprint mod_details
warns hpc_info self_trust
safe_mode usages mod_details
-- | Make an interface from a manually constructed 'ModIface'. We use
-- this when we are merging 'ModIface's. We assume that the 'ModIface'
-- has accurate entries but not accurate fingerprint information (so,
-- like @intermediate_iface@ in 'mkIface_'.)
mkIfaceDirect :: HscEnv
-> Maybe Fingerprint
-> ModIface
-> IO (ModIface, Bool)
mkIfaceDirect hsc_env maybe_old_fingerprint iface0 = do
-- Sort some things to make sure we're deterministic
let intermediate_iface = iface0 {
mi_exports = mkIfaceExports (mi_exports iface0),
mi_insts = sortBy cmp_inst (mi_insts iface0),
mi_fam_insts = sortBy cmp_fam_inst (mi_fam_insts iface0),
mi_rules = sortBy cmp_rule (mi_rules iface0)
}
dflags = hsc_dflags hsc_env
(final_iface, no_change_at_all)
<- {-# SCC "versioninfo" #-}
addFingerprints hsc_env maybe_old_fingerprint
intermediate_iface
(map snd (mi_decls iface0))
-- Debug printing
dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
(pprModIface final_iface)
return (final_iface, no_change_at_all)
-- | make an interface from the results of typechecking only. Useful
-- for non-optimising compilation, or where we aren't generating any
-- object code at all ('HscNothing').
......@@ -320,6 +290,11 @@ mkIface_ hsc_env maybe_old_fingerprint
return (final_iface, no_change_at_all)
where
cmp_rule = comparing ifRuleName
-- Compare these lexicographically by OccName, *not* by unique,
-- because the latter is not stable across compilations:
cmp_inst = comparing (nameOccName . ifDFun)
cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)
dflags = hsc_dflags hsc_env
......@@ -337,6 +312,8 @@ mkIface_ hsc_env maybe_old_fingerprint
deliberatelyOmitted :: String -> a
deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
ifFamInstTcName = ifFamInstFam
flattenVectInfo (VectInfo { vectInfoVar = vVar
, vectInfoTyCon = vTyCon
, vectInfoParallelVars = vParallelVars
......@@ -350,16 +327,6 @@ mkIface_ hsc_env maybe_old_fingerprint
, ifaceVectInfoParallelTyCons = nameSetElems vParallelTyCons
}
cmp_rule :: IfaceRule -> IfaceRule -> Ordering
cmp_rule = comparing ifRuleName
-- Compare these lexicographically by OccName, *not* by unique,
-- because the latter is not stable across compilations:
cmp_inst :: IfaceClsInst -> IfaceClsInst -> Ordering
cmp_inst = comparing (nameOccName . ifDFun)
cmp_fam_inst :: IfaceFamInst -> IfaceFamInst -> Ordering
cmp_fam_inst = comparing (nameOccName . ifFamInstFam)
-----------------------------
writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()
writeIfaceFile dflags hi_file_path new_iface
......
......@@ -197,9 +197,9 @@ processDeps dflags _ _ _ _ (CyclicSCC nodes)
throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))
processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
| Just src_file <- msHsFilePath node
= do { let extra_suffixes = depSuffixes dflags
include_pkg_deps = depIncludePkgDeps dflags
src_file = msHsFilePath node
obj_file = msObjFilePath node
obj_files = insertSuffixes obj_file extra_suffixes
......@@ -233,10 +233,6 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
; do_imps False (ms_imps node)
}
| otherwise
= ASSERT( ms_hsc_src node == HsBootMerge )
panic "HsBootMerge not supported in DriverMkDepend yet"
findDependency :: HscEnv
-> SrcSpan
......
......@@ -10,7 +10,7 @@
-----------------------------------------------------------------------------
module DriverPhases (
HscSource(..), isHsBoot, hscSourceString,
HscSource(..), isHsBootOrSig, hscSourceString,
Phase(..),
happensBefore, eqPhase, anyHsc, isStopLn,
startPhase,
......@@ -22,10 +22,12 @@ module DriverPhases (
isCishSuffix,
isDynLibSuffix,
isHaskellUserSrcSuffix,
isHaskellSigSuffix,
isSourceSuffix,
isHaskellishFilename,
isHaskellSrcFilename,
isHaskellSigFilename,
isObjectFilename,
isCishFilename,
isDynLibFilename,
......@@ -58,51 +60,63 @@ import Binary
-- Note [HscSource types]
-- ~~~~~~~~~~~~~~~~~~~~~~
-- There are two types of source file for user-written Haskell code:
-- There are three types of source file for Haskell code:
--
-- * HsSrcFile is an ordinary hs file which contains code,
--
-- * HsBootFile is an hs-boot file. Within a unit, it can
-- be used to break recursive module imports, in which case there's an
-- HsSrcFile associated with it. However, externally, it can
-- also be used to specify the *requirements* of a package,
-- in which case there is an HsBootMerge associated with it.
-- * HsBootFile is an hs-boot file, which is used to break
-- recursive module imports (there will always be an
-- HsSrcFile associated with it), and
--
-- An HsBootMerge is a "fake" source file, which is constructed
-- by collecting up non-recursive HsBootFiles into a single interface.
-- HsBootMerges get an hi and o file, and are treated as "non-boot"
-- sources.
-- * HsigFile is an hsig file, which contains only type
-- signatures and is used to specify signatures for
-- modules.
--
-- Syntactically, hs-boot files and hsig files are quite similar: they
-- only include type signatures and must be associated with an
-- actual HsSrcFile. isHsBootOrSig allows us to abstract over code
-- which is indifferent to which. However, there are some important
-- differences, mostly owing to the fact that hsigs are proper
-- modules (you `import Sig` directly) whereas HsBootFiles are
-- temporary placeholders (you `import {-# SOURCE #-} Mod).
-- When we finish compiling the true implementation of an hs-boot,
-- we replace the HomeModInfo with the real HsSrcFile. An HsigFile, on the
-- other hand, is never replaced (in particular, we *cannot* use the
-- HomeModInfo of the original HsSrcFile backing the signature, since it
-- will export too many symbols.)
--
-- Additionally, while HsSrcFile is the only Haskell file
-- which has *code*, we do generate .o files for HsigFile, because
-- this is how the recompilation checker figures out if a file
-- needs to be recompiled. These are fake object files which
-- should NOT be linked against.
data HscSource
= HsSrcFile | HsBootFile | HsBootMerge
= HsSrcFile | HsBootFile | HsigFile
deriving( Eq, Ord, Show )
-- Ord needed for the finite maps we build in CompManager
instance Outputable HscSource where
ppr HsSrcFile = text "HsSrcFile"
ppr HsBootFile = text "HsBootFile"
ppr HsBootMerge = text "HsBootMerge"
instance Binary HscSource where
put_ bh HsSrcFile = putByte bh 0
put_ bh HsBootFile = putByte bh 1
put_ bh HsBootMerge = putByte bh 2
put_ bh HsigFile = putByte bh 2
get bh = do
h <- getByte bh
case h of
0 -> return HsSrcFile
1 -> return HsBootFile
_ -> return HsBootMerge
_ -> return HsigFile
hscSourceString :: HscSource -> String
hscSourceString HsSrcFile = ""
hscSourceString HsBootFile = "[boot]"
hscSourceString HsBootMerge = "[merge]"
hscSourceString HsigFile = "[sig]"
isHsBoot :: HscSource -> Bool
isHsBoot HsBootFile = True
isHsBoot HsSrcFile = False
isHsBoot HsBootMerge = False
-- See Note [isHsBootOrSig]
isHsBootOrSig :: HscSource -> Bool
isHsBootOrSig HsBootFile = True
isHsBootOrSig HsigFile = True
isHsBootOrSig _ = False
data Phase
= Unlit HscSource
......@@ -218,8 +232,10 @@ nextPhase dflags p
startPhase :: String -> Phase
startPhase "lhs" = Unlit HsSrcFile
startPhase "lhs-boot" = Unlit HsBootFile
startPhase "lhsig" = Unlit HsigFile
startPhase "hs" = Cpp HsSrcFile
startPhase "hs-boot" = Cpp HsBootFile
startPhase "hsig" = Cpp HsigFile
startPhase "hscpp" = HsPp HsSrcFile
startPhase "hspp" = Hsc HsSrcFile
startPhase "hc" = HCc
......@@ -248,9 +264,7 @@ startPhase _ = StopLn -- all unknown file types
phaseInputExt :: Phase -> String
phaseInputExt (Unlit HsSrcFile) = "lhs"
phaseInputExt (Unlit HsBootFile) = "lhs-boot"
phaseInputExt (Unlit HsBootMerge) = panic "phaseInputExt: Unlit HsBootMerge"
-- You can't Unlit an HsBootMerge, because there's no source
-- file to Unlit!
phaseInputExt (Unlit HsigFile) = "lhsig"
phaseInputExt (Cpp _) = "lpp" -- intermediate only
phaseInputExt (HsPp _) = "hscpp" -- intermediate only
phaseInputExt (Hsc _) = "hspp" -- intermediate only
......@@ -275,7 +289,7 @@ phaseInputExt MergeStub = "o"
phaseInputExt StopLn = "o"
haskellish_src_suffixes, haskellish_suffixes, cish_suffixes,
haskellish_user_src_suffixes
haskellish_user_src_suffixes, haskellish_sig_suffixes
:: [String]
-- When a file with an extension in the haskellish_src_suffixes group is
-- loaded in --make mode, its imports will be loaded too.
......@@ -286,7 +300,9 @@ haskellish_suffixes = haskellish_src_suffixes ++
cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ]
-- Will not be deleted as temp files:
haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ]
haskellish_user_src_suffixes =
haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ]
haskellish_sig_suffixes = [ "hsig", "lhsig" ]
objish_suffixes :: Platform -> [String]
-- Use the appropriate suffix for the system on which
......@@ -302,9 +318,10 @@ dynlib_suffixes platform = case platformOS platform of
_ -> ["so"]
isHaskellishSuffix, isHaskellSrcSuffix, isCishSuffix,
isHaskellUserSrcSuffix
isHaskellUserSrcSuffix, isHaskellSigSuffix
:: String -> Bool
isHaskellishSuffix s = s `elem` haskellish_suffixes
isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes
isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes
isCishSuffix s = s `elem` cish_suffixes
isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes
......@@ -317,7 +334,7 @@ isSourceSuffix :: String -> Bool
isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff
isHaskellishFilename, isHaskellSrcFilename, isCishFilename,
isHaskellUserSrcFilename, isSourceFilename
isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename
:: FilePath -> Bool
-- takeExtension return .foo, so we drop 1 to get rid of the .
isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f)
......@@ -325,6 +342,7 @@ isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f)
isCishFilename f = isCishSuffix (drop 1 $ takeExtension f)
isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f)
isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f)
isHaskellSigFilename f = isHaskellSigSuffix (drop 1 $ takeExtension f)
isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool
isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f)
......
......@@ -13,7 +13,7 @@
module DriverPipeline (
-- Run a series of compilation steps in a pipeline, for a
-- collection of source files.
oneShot, compileFile, mergeRequirement,
oneShot, compileFile,
-- Interfaces for the batch-mode driver
linkBinary,
......@@ -23,9 +23,6 @@ module DriverPipeline (
compileOne, compileOne',
link,
-- Misc utility
makeMergeRequirementSummary,
-- Exports for hooks to override runPhase and link
PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),
phaseOutputFilename, getPipeState, getPipeEnv,
......@@ -73,7 +70,6 @@ import System.IO
import Control.Monad
import Data.List ( isSuffixOf )
import Data.Maybe
import Data.Time
import Data.Version
-- ---------------------------------------------------------------------------
......@@ -133,6 +129,22 @@ compileOne' m_tc_result mHscMessage
hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
source_modified0
= do
let dflags0 = ms_hspp_opts summary
this_mod = ms_mod summary
src_flavour = ms_hsc_src summary
location = ms_location summary
input_fnpp = ms_hspp_file summary
mod_graph = hsc_mod_graph hsc_env0
needsTH = any (xopt Opt_TemplateHaskell . ms_hspp_opts) mod_graph
needsQQ = any (xopt Opt_QuasiQuotes . ms_hspp_opts) mod_graph
needsLinker = needsTH || needsQQ
isDynWay = any (== WayDyn) (ways dflags0)
isProfWay = any (== WayProf) (ways dflags0)
-- #8180 - when using TemplateHaskell, switch on -dynamic-too so
-- the linker can correctly load the object files.
let dflags1 = if needsLinker && dynamicGhc && not isDynWay && not isProfWay
then gopt_set dflags0 Opt_BuildDynamicToo
else dflags0
debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)
......@@ -146,7 +158,7 @@ compileOne' m_tc_result mHscMessage
ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )
return hmi0 { hm_linkable = maybe_old_linkable }
(HscNotGeneratingCode, HscNothing) ->
let mb_linkable = if isHsBoot src_flavour
let mb_linkable = if isHsBootOrSig src_flavour
then Nothing
-- TODO: Questionable.
else Just (LM (ms_hs_date summary) this_mod [])
......@@ -158,10 +170,10 @@ compileOne' m_tc_result mHscMessage
(HscUpdateBoot, _) -> do
touchObjectFile dflags object_filename
return hmi0
(HscUpdateBootMerge, HscInterpreted) ->
(HscUpdateSig, HscInterpreted) ->
let linkable = LM (ms_hs_date summary) this_mod []
in return hmi0 { hm_linkable = Just linkable }
(HscUpdateBootMerge, _) -> do
(HscUpdateSig, _) -> do
output_fn <- getOutputFilename next_phase
Temporary basename dflags next_phase (Just location)
......@@ -171,7 +183,7 @@ compileOne' m_tc_result mHscMessage
_ <- runPipeline StopLn hsc_env
(output_fn,
Just (HscOut src_flavour
mod_name HscUpdateBootMerge))
mod_name HscUpdateSig))
(Just basename)
Persistent
(Just location)
......@@ -218,7 +230,6 @@ compileOne' m_tc_result mHscMessage
where dflags0 = ms_hspp_opts summary
location = ms_location summary
input_fn = expectJust "compile:hs" (ml_hs_file location)
input_fnpp = ms_hspp_file summary
mod_graph = hsc_mod_graph hsc_env0
needsTH = any (xopt Opt_TemplateHaskell . ms_hspp_opts) mod_graph
needsQQ = any (xopt Opt_QuasiQuotes . ms_hspp_opts) mod_graph
......@@ -228,7 +239,6 @@ compileOne' m_tc_result mHscMessage
src_flavour = ms_hsc_src summary
this_mod = ms_mod summary
mod_name = ms_mod_name summary
next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
object_filename = ml_obj_file location
......@@ -489,50 +499,6 @@ oneShot hsc_env stop_phase srcs = do
o_files <- mapM (compileFile hsc_env stop_phase) srcs
doLink (hsc_dflags hsc_env) stop_phase o_files
-- | Constructs a 'ModSummary' for a "signature merge" node.
-- This is a simplified construction function which only checks
-- for a local hs-boot file.
makeMergeRequirementSummary :: HscEnv -> Bool -> ModuleName -> IO ModSummary
makeMergeRequirementSummary hsc_env obj_allowed mod_name = do
let dflags = hsc_dflags hsc_env
location <- liftIO $ mkHomeModLocation2 dflags mod_name
(moduleNameSlashes mod_name) (hiSuf dflags)
obj_timestamp <-
if isObjectTarget (hscTarget dflags) || obj_allowed -- bug #1205
then liftIO $ modificationTimeIfExists (ml_obj_file location)
else return Nothing
r <- findHomeModule hsc_env mod_name
let has_local_boot = case r of
Found _ _ -> True
_ -> False
src_timestamp <- case obj_timestamp of
Just date -> return date
Nothing -> getCurrentTime -- something fake
return ModSummary {
ms_mod = mkModule (thisPackage dflags) mod_name,
ms_hsc_src = HsBootMerge,
ms_location = location,
ms_hs_date = src_timestamp,
ms_obj_date = obj_timestamp,
ms_iface_date = Nothing,
-- TODO: fill this in with all the imports eventually
ms_srcimps = [],
ms_textual_imps = [],
ms_merge_imps = (has_local_boot, []),
ms_hspp_file = "FAKE",
ms_hspp_opts = dflags,
ms_hspp_buf = Nothing
}
-- | Top-level entry point for @ghc -merge-requirement ModName@.
mergeRequirement :: HscEnv -> ModuleName -> IO ()
mergeRequirement hsc_env mod_name = do
mod_summary <- makeMergeRequirementSummary hsc_env True mod_name
-- Based off of GhcMake handling
_ <- liftIO $ compileOne' Nothing Nothing hsc_env mod_summary 1 1 Nothing
Nothing SourceUnmodified
return ()
compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
compileFile hsc_env stop_phase (src, mb_phase) = do
exists <- doesFileExist src
......@@ -1014,8 +980,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
ms_obj_date = Nothing,
ms_iface_date = Nothing,
ms_textual_imps = imps,
ms_srcimps = src_imps,
ms_merge_imps = (False, []) }
ms_srcimps = src_imps }
-- run the compiler!
let msg hsc_env _ what _ = oneShotMsg hsc_env what
......@@ -1048,7 +1013,7 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do
-- stamp file for the benefit of Make
liftIO $ touchObjectFile dflags o_file
return (RealPhase StopLn, o_file)
HscUpdateBootMerge ->
HscUpdateSig ->
do -- We need to create a REAL but empty .o file
-- because we are going to attempt to put it in a library
PipeState{hsc_env=hsc_env'} <- getPipeState
......@@ -2211,7 +2176,7 @@ writeInterfaceOnlyMode dflags =
-- | What phase to run after one of the backend code generators has run
hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase
hscPostBackendPhase _ HsBootFile _ = StopLn
hscPostBackendPhase _ HsBootMerge _ = StopLn
hscPostBackendPhase _ HsigFile _ = StopLn
hscPostBackendPhase dflags _ hsc_lang =
case hsc_lang of
HscC -> HCc
......
......@@ -228,11 +228,8 @@ findHomeModule hsc_env mod_name =
source_exts =
[ ("hs", mkHomeModLocationSearched dflags mod_name "hs")
, ("lhs", mkHomeModLocationSearched dflags mod_name "lhs")
-- TODO: This is a giant hack! If we find an hs-boot file,
-- pretend that there's an hs file here too, even if there isn't.
-- GhcMake will know what to do next.
, ("hs-boot", mkHomeModLocationSearched dflags mod_name "hs")
, ("lhs-boot", mkHomeModLocationSearched dflags mod_name "lhs")
, ("hsig", mkHomeModLocationSearched dflags mod_name "hsig")
, ("lhsig", mkHomeModLocationSearched dflags mod_name "lhsig")
]
hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf)
......@@ -253,6 +250,7 @@ findHomeModule hsc_env mod_name =
then return (Found (error "GHC.Prim ModLocation") mod)
else searchPathExts home_path mod exts
-- | Search for a module in external packages only.
findPackageModule :: HscEnv -> Module -> IO FindResult
findPackageModule hsc_env mod = do
......
......@@ -988,7 +988,7 @@ compileCore simplify fn = do
_ <- load LoadAllTargets
-- Then find dependencies
modGraph <- depanal [] True
case find ((== Just fn) . msHsFilePath) modGraph of
case find ((== fn) . msHsFilePath) modGraph of
Just modSummary -> do
-- Now we have the module name;
-- parse, typecheck and desugar the module
......
......@@ -1424,7 +1424,7 @@ reachableBackwards mod summaries
= [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
where -- the rest just sets up the graph:
(graph, lookup_node) = moduleGraphNodes False summaries
root = expectJust "reachableBackwards" (lookup_node IsBoot mod)
root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
-- ---------------------------------------------------------------------------
--
......@@ -1463,8 +1463,7 @@ topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
-- the specified module. We do this by building a graph with
-- the full set of nodes, and determining the reachable set from
-- the specified node.
let root | Just node <- lookup_node NotBoot root_mod
, graph `hasVertexG` node = node
let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
| otherwise = throwGhcException (ProgramError "module does not exist")
in graphFromEdgedVertices (seq root (reachableG graph root))
......@@ -1477,48 +1476,36 @@ summaryNodeSummary :: SummaryNode -> ModSummary
summaryNodeSummary (s, _, _) = s
moduleGraphNodes :: Bool -> [ModSummary]
-> (Graph SummaryNode, IsBoot -> ModuleName -> Maybe SummaryNode)
-> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)
where
numbered_summaries = zip summaries [1..]
lookup_node :: IsBoot -> ModuleName -> Maybe SummaryNode
lookup_node is_boot mod = Map.lookup (mod, is_boot) node_map
lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
lookup_node hs_src mod = Map.lookup (mod, hscSourceToIsBoot hs_src) node_map
lookup_key :: IsBoot -> ModuleName -> Maybe Int
lookup_key is_boot mod = fmap summaryNodeKey (lookup_node is_boot mod)
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@(s, _, _) <- nodes ]
hasImplSet :: Set.Set ModuleName
hasImplSet = Set.fromList [ ms_mod_name s
| s <- summaries, ms_hsc_src s == HsSrcFile ]
hasImpl :: ModuleName -> Bool
hasImpl modname = modname `Set.member` hasImplSet
-- We use integers as the keys for the SCC algorithm
nodes :: [SummaryNode]
nodes = [ (s, key, out_keys)
| (s, key) <- numbered_summaries
-- Drop the hi-boot ones if told to do so
, not (isBootSummary s && hasImpl (ms_mod_name s)
&& drop_hs_boot_nodes)
, let out_keys
= out_edge_keys IsBoot (map unLoc (ms_home_srcimps s)) ++
out_edge_keys NotBoot (map unLoc (ms_home_imps s)) ++
(if fst (ms_merge_imps s)
then out_edge_keys IsBoot [moduleName (ms_mod s)]
else []) ++
(-- see [boot-edges] below
if drop_hs_boot_nodes || ms_hsc_src s /= HsSrcFile
then []
else case lookup_key IsBoot (ms_mod_name s) of
Nothing -> []
Just k -> [k]) ]
, not (isBootSummary s && 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
if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
then []
else case lookup_key HsBootFile (ms_mod_name s) of
Nothing -> []
Just k -> [k]) ]
-- [boot-edges] if this is a .hs and there is an equivalent
-- .hs-boot, add a link from the former to the latter. This
......@@ -1528,13 +1515,12 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l
-- the .hs, and so the HomePackageTable will always have the
-- most up to date information.
out_edge_keys :: IsBoot -> [ModuleName] -> [Int]
out_edge_keys hi_boot ms = mapMaybe (lookup_out_edge_key hi_boot) ms
-- Drop hs-boot nodes by using HsSrcFile as the key
hs_boot_key | drop_hs_boot_nodes = HsSrcFile
| otherwise = HsBootFile
lookup_out_edge_key :: IsBoot -> ModuleName -> Maybe Int
lookup_out_edge_key hi_boot m
| hasImpl m, drop_hs_boot_nodes = lookup_key NotBoot m
| otherwise = lookup_key hi_boot m
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
......@@ -1623,7 +1609,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
-- dependency on what-ever the signature's implementation is.
-- (But not when we're type checking!)
calcDeps summ
| HsBootFile <- ms_hsc_src summ
| HsigFile <- ms_hsc_src summ
, Just m <- getSigOf (hsc_dflags hsc_env) (moduleName (ms_mod summ))
, moduleUnitId m == thisPackage (hsc_dflags hsc_env)
= (noLoc (moduleName m), NotBoot) : msDeps summ
......@@ -1707,16 +1693,10 @@ 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
--
-- NB: for signatures, (m,NotBoot) is "special"; the Haskell file
-- may not exist; we just synthesize it ourselves.
msDeps :: ModSummary -> [(Located ModuleName, IsBoot)]
msDeps s =
concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ]
++ [ (m,NotBoot) | m <- ms_home_imps s ]
++ if fst (ms_merge_imps s)
then [ (noLoc (moduleName (ms_mod s)), IsBoot) ]
else []
home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps,
......@@ -1798,6 +1778,8 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
new_summary src_timestamp = do
let dflags = hsc_dflags hsc_env
let hsc_src = if isHaskellSigFilename file then HsigFile else HsSrcFile
(dflags', hspp_fn, buf)
<- preprocessFile hsc_env file mb_phase maybe_buf
......@@ -1820,16 +1802,12 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
hi_timestamp <- maybeGetIfaceDate dflags location
return (ModSummary { ms_mod = mod,
ms_hsc_src = if "boot" `isSuffixOf` file
then HsBootFile
else HsSrcFile,
return (ModSummary { ms_mod = mod, ms_hsc_src = hsc_src,
ms_location = location,
ms_hspp_file = hspp_fn,
ms_hspp_opts = dflags',
ms_hspp_buf = Just buf,
ms_srcimps = srcimps, ms_textual_imps = the_imps,
ms_merge_imps = (False, []),
ms_hs_date = src_timestamp,
ms_iface_date = hi_timestamp,
ms_obj_date = obj_timestamp })
......@@ -1875,17 +1853,6 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
Left e | isDoesNotExistError e -> find_it
| otherwise -> ioError e
| NotBoot <- is_boot
, Just _ <- getSigOf dflags wanted_mod
= do mod_summary0 <- makeMergeRequirementSummary hsc_env
obj_allowed
wanted_mod
hi_timestamp <- maybeGetIfaceDate dflags (ms_location mod_summary0)
let mod_summary = mod_summary0 {
ms_iface_date = hi_timestamp
}
return (Just (Right mod_summary))
| otherwise = find_it
where
dflags = hsc_dflags hsc_env
......@@ -1948,10 +1915,17 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
(dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
(srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
let hsc_src =
case is_boot of
IsBoot -> HsBootFile
NotBoot -> HsSrcFile
-- NB: Despite the fact that is_boot is a top-level parameter, we
-- don't actually know coming into this function what the HscSource
-- of the module in question is. This is because we may be processing
-- this module because another module in the graph imported it: in this
-- 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