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

Implementation of hsig (module signatures), per #9252

Summary:
Module signatures, like hs-boot files, are Haskell modules which omit
value definitions and contain only signatures.  This patchset implements
one particular aspect of module signature, namely compiling them against
a concrete implementation.  It works like this: when we compile an hsig
file, we must be told (via the -sig-of flag) what module this signature
is implementing.  The signature is compiled into an interface file which
reexports precisely the entities mentioned in the signature file.  We also
verify that the interface is compatible with the implementation.

This feature is useful in a few situations:

    1. Like explicit import lists, signatures can be used to reduce
    sensitivity to upstream changes.  However, a signature can be defined
    once and then reused by many modules.

    2. Signatures can be used to quickly check if a new upstream version
    is compatible, by typechecking just the signatures and not the actual
    modules.

    3. A signature can be used to mediate separate modular development,
    where the signature is used as a placeholder for functionality which
    is loaded in later.  (This is only half useful at the moment, since
    typechecking against signatures without implementations is not implemented
    in this patchset.)

Unlike hs-boot files, hsig files impose no performance overhead.

This patchset punts on the type class instances (and type families) problem:
instances simply leak from the implementation to the signature.  You can
explicitly specify what instances you expect to have, and those will be checked,
but you may get more instances than you asked for.  Our eventual plan is
to allow hiding instances, but to consider all transitively reachable instances
when considering overlap and soundness.

ToDo: signature merging: when a module is provided by multiple signatures
for the same base implementation, we should not consider this ambiguous.

ToDo: at the moment, signatures do not constitute use-sites, so if you
write a signature for a deprecated function, you won't get a warning
when you compile the signature.

Future work: The ability to feed in shaping information so that we can take
advantage of more type equalities than might be immediately evident.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate and new tests

Reviewers: simonpj, simonmar, hvr, austin

Subscribers: simonmar, relrod, ezyang, carter, goldfire

Differential Revision: https://phabricator.haskell.org/D130

GHC Trac Issues: #9252
parent 5bb73d79
......@@ -48,6 +48,7 @@ module Name (
-- ** Manipulating and deconstructing 'Name's
nameUnique, setNameUnique,
nameOccName, nameModule, nameModule_maybe,
setNameLoc,
tidyNameOcc,
localiseName,
mkLocalisedOccName,
......@@ -317,6 +318,11 @@ mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan
setNameUnique :: Name -> Unique -> Name
setNameUnique name uniq = name {n_uniq = getKeyFastInt uniq}
-- This is used for hsigs: we want to use the name of the originally exported
-- entity, but edit the location to refer to the reexport site
setNameLoc :: Name -> SrcSpan -> Name
setNameLoc name loc = name {n_loc = loc}
tidyNameOcc :: Name -> OccName -> Name
-- We set the OccName of a Name when tidying
-- In doing so, we change System --> Internal, so that when we print
......
......@@ -108,7 +108,7 @@ deSugar hsc_env
_ -> True)
; (binds_cvr, ds_hpc_info, modBreaks)
<- if want_ticks && not (isHsBoot hsc_src)
<- if want_ticks && not (isHsBootOrSig hsc_src)
then addTicksToBinds dflags mod mod_loc export_set
(typeEnvTyCons type_env) binds
else return (binds, hpcInfo, emptyModBreaks)
......@@ -165,7 +165,7 @@ deSugar hsc_env
; let mod_guts = ModGuts {
mg_module = mod,
mg_boot = isHsBoot hsc_src,
mg_boot = hsc_src == HsBootFile,
mg_exports = exports,
mg_deps = deps,
mg_used_names = used_names,
......
......@@ -745,6 +745,7 @@ pprModIface iface
, nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface))
, nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))
, nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface))
, nest 2 (text "sig of:" <+> ppr (mi_sig_of iface))
, nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))
, nest 2 (ptext (sLit "where"))
, ptext (sLit "exports:")
......
......@@ -191,7 +191,8 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
used_th <- readIORef tc_splice_used
dep_files <- (readIORef dependent_files)
mkIface_ hsc_env maybe_old_fingerprint
this_mod (isHsBoot hsc_src) used_names used_th deps rdr_env
this_mod (hsc_src == HsBootFile) used_names
used_th deps rdr_env
fix_env warns hpc_info (imp_mods imports)
(imp_trust_own_pkg imports) dep_files safe_mode mod_details
......@@ -279,9 +280,11 @@ mkIface_ hsc_env maybe_old_fingerprint
iface_vect_info = flattenVectInfo vect_info
trust_info = setSafeMode safe_mode
annotations = map mkIfaceAnnotation anns
sig_of = getSigOf dflags (moduleName this_mod)
intermediate_iface = ModIface {
mi_module = this_mod,
mi_sig_of = sig_of,
mi_boot = is_boot,
mi_deps = deps,
mi_usages = usages,
......@@ -1259,6 +1262,9 @@ checkVersions hsc_env mod_summary iface
; recomp <- checkFlagHash hsc_env iface
; if recompileRequired recomp then return (recomp, Nothing) else do {
; if getSigOf (hsc_dflags hsc_env) (moduleName (mi_module iface))
/= mi_sig_of iface
then return (RecompBecause "sig-of changed", Nothing) else do {
; recomp <- checkDependencies hsc_env mod_summary iface
; if recompileRequired recomp then return (recomp, Just iface) else do {
......@@ -1278,7 +1284,7 @@ checkVersions hsc_env mod_summary iface
; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }
; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]
; return (recomp, Just iface)
}}}
}}}}
where
this_pkg = thisPackage (hsc_dflags hsc_env)
-- This is a bit of a hack really
......
......@@ -321,7 +321,7 @@ tcHiBootIface :: HscSource -> Module -> TcRn ModDetails
-- if it indeed exists in the transitive closure of imports
-- Return the ModDetails, empty if no hi-boot iface
tcHiBootIface hsc_src mod
| isHsBoot hsc_src -- Already compiling a hs-boot file
| HsBootFile <- hsc_src -- Already compiling a hs-boot file
= return emptyModDetails
| otherwise
= do { traceIf (text "loadHiBootInterface" <+> ppr mod)
......
......@@ -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,
......@@ -55,19 +57,54 @@ import System.FilePath
linker | other | - | a.out
-}
-- Note [HscSource types]
-- ~~~~~~~~~~~~~~~~~~~~~~
-- 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, which is used to break
-- recursive module imports (there will always be an
-- HsSrcFile associated with it), and
--
-- * 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
= HsSrcFile | HsBootFile | HsigFile
deriving( Eq, Ord, Show )
-- Ord needed for the finite maps we build in CompManager
hscSourceString :: HscSource -> String
hscSourceString HsSrcFile = ""
hscSourceString HsBootFile = "[boot]"
hscSourceString HsigFile = "[sig]"
isHsBoot :: HscSource -> Bool
isHsBoot HsBootFile = True
isHsBoot _ = False
-- See Note [isHsBootOrSig]
isHsBootOrSig :: HscSource -> Bool
isHsBootOrSig HsBootFile = True
isHsBootOrSig HsigFile = True
isHsBootOrSig _ = False
data Phase
= Unlit HscSource
......@@ -170,8 +207,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
......@@ -200,6 +239,7 @@ startPhase _ = StopLn -- all unknown file types
phaseInputExt :: Phase -> String
phaseInputExt (Unlit HsSrcFile) = "lhs"
phaseInputExt (Unlit HsBootFile) = "lhs-boot"
phaseInputExt (Unlit HsigFile) = "lhsig"
phaseInputExt (Cpp _) = "lpp" -- intermediate only
phaseInputExt (HsPp _) = "hscpp" -- intermediate only
phaseInputExt (Hsc _) = "hspp" -- intermediate only
......@@ -224,14 +264,16 @@ 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]
haskellish_src_suffixes = haskellish_user_src_suffixes ++
[ "hspp", "hscpp", "hcr", "cmm", "cmmcpp" ]
haskellish_suffixes = haskellish_src_suffixes ++ ["hc", "raw_s"]
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
......@@ -247,9 +289,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
......@@ -262,7 +305,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)
......@@ -270,6 +313,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)
......
......@@ -197,7 +197,7 @@ compileOne' m_tc_result mHscMessage
case hsc_lang of
HscInterpreted ->
case ms_hsc_src summary of
HsBootFile ->
t | isHsBootOrSig t ->
do (iface, _changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash
return (HomeModInfo{ hm_details = details,
hm_iface = iface,
......@@ -231,7 +231,7 @@ compileOne' m_tc_result mHscMessage
do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash
when (gopt Opt_WriteInterface dflags) $
hscWriteIface dflags iface changed summary
let linkable = if isHsBoot src_flavour
let linkable = if isHsBootOrSig src_flavour
then maybe_old_linkable
else Just (LM (ms_hs_date summary) this_mod [])
return (HomeModInfo{ hm_details = details,
......@@ -240,7 +240,7 @@ compileOne' m_tc_result mHscMessage
_ ->
case ms_hsc_src summary of
HsBootFile ->
t | isHsBootOrSig t ->
do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash
hscWriteIface dflags iface changed summary
touchObjectFile dflags object_filename
......@@ -341,7 +341,11 @@ link' dflags batch_attempt_linking hpt
LinkStaticLib -> True
_ -> platformBinariesAreStaticLibs (targetPlatform dflags)
home_mod_infos = eltsUFM hpt
-- Don't attempt to link hsigs; they don't actually produce objects.
-- This is in contrast to hs-boot files, which will /eventually/
-- get objects.
home_mod_infos =
filter ((==Nothing).mi_sig_of.hm_iface) (eltsUFM hpt)
-- the packages we depend on
pkg_deps = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos
......@@ -1511,8 +1515,8 @@ getLocation src_flavour mod_name = do
location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
-- Boot-ify it if necessary
let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
| otherwise = location1
let location2 | HsBootFile <- src_flavour = addBootSuffixLocn location1
| otherwise = location1
-- Take -ohi into account if present
......@@ -2199,6 +2203,7 @@ joinObjectFiles dflags o_files output_fn = do
-- | What phase to run after one of the backend code generators has run
hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase
hscPostBackendPhase _ HsBootFile _ = StopLn
hscPostBackendPhase _ HsigFile _ = StopLn
hscPostBackendPhase dflags _ hsc_lang =
case hsc_lang of
HscC -> HCc
......
......@@ -50,6 +50,7 @@ module DynFlags (
fFlags, fWarningFlags, fLangFlags, xFlags,
dynFlagDependencies,
tablesNextToCode, mkTablesNextToCode,
SigOf(..), getSigOf,
printOutputForUser, printInfoForUser,
......@@ -591,6 +592,17 @@ data ExtensionFlag
| Opt_PatternSynonyms
deriving (Eq, Enum, Show)
data SigOf = NotSigOf
| SigOf Module
| SigOfMap (Map ModuleName Module)
getSigOf :: DynFlags -> ModuleName -> Maybe Module
getSigOf dflags n =
case sigOf dflags of
NotSigOf -> Nothing
SigOf m -> Just m
SigOfMap m -> Map.lookup n m
-- | Contains not only a collection of 'GeneralFlag's but also a plethora of
-- information relating to the compilation of a single file or GHC session
data DynFlags = DynFlags {
......@@ -598,6 +610,8 @@ data DynFlags = DynFlags {
ghcLink :: GhcLink,
hscTarget :: HscTarget,
settings :: Settings,
-- See Note [Signature parameters in TcGblEnv and DynFlags]
sigOf :: SigOf, -- ^ Compiling an hs-boot against impl.
verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels]
optLevel :: Int, -- ^ Optimisation level
simplPhases :: Int, -- ^ Number of simplifier phases
......@@ -1334,6 +1348,7 @@ defaultDynFlags mySettings =
ghcMode = CompManager,
ghcLink = LinkBinary,
hscTarget = defaultHscTarget (sTargetPlatform mySettings),
sigOf = NotSigOf,
verbosity = 0,
optLevel = 0,
simplPhases = 2,
......@@ -1831,6 +1846,29 @@ setOutputFile f d = d{ outputFile = f}
setDynOutputFile f d = d{ dynOutputFile = f}
setOutputHi f d = d{ outputHi = f}
parseSigOf :: String -> SigOf
parseSigOf str = case filter ((=="").snd) (readP_to_S parse str) of
[(r, "")] -> r
_ -> throwGhcException $ CmdLineError ("Can't parse -sig-of: " ++ str)
where parse = parseOne +++ parseMany
parseOne = SigOf `fmap` parseModule
parseMany = SigOfMap . Map.fromList <$> sepBy parseEntry (R.char ',')
parseEntry = do
n <- tok $ parseModuleName
-- ToDo: deprecate this 'is' syntax?
tok $ ((string "is" >> return ()) +++ (R.char '=' >> return ()))
m <- tok $ parseModule
return (mkModuleName n, m)
parseModule = do
pk <- munch1 (\c -> isAlphaNum c || c `elem` "-_")
_ <- R.char ':'
m <- parseModuleName
return (mkModule (stringToPackageKey pk) (mkModuleName m))
tok m = skipSpaces >> m
setSigOf :: String -> DynFlags -> DynFlags
setSigOf s d = d { sigOf = parseSigOf s }
addPluginModuleName :: String -> DynFlags -> DynFlags
addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }
......@@ -2152,6 +2190,7 @@ dynamic_flags = [
, Flag "v" (OptIntSuffix setVerbosity)
, Flag "j" (OptIntSuffix (\n -> upd (\d -> d {parMakeCount = n})))
, Flag "sig-of" (sepArg setSigOf)
-- RTS options -------------------------------------------------------------
, Flag "H" (HasArg (\s -> upd (\d ->
......@@ -3366,6 +3405,9 @@ removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extra
clearPkgConf :: DynP ()
clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] }
parseModuleName :: ReadP String
parseModuleName = munch1 (\c -> isAlphaNum c || c `elem` ".")
parsePackageFlag :: (String -> PackageArg) -- type of argument
-> String -- string to parse
-> PackageFlag
......@@ -3380,11 +3422,10 @@ parsePackageFlag constr str = case filter ((=="").snd) (readP_to_S parse str) of
return (ExposePackage (constr pkg) (Just rns))
+++
return (ExposePackage (constr pkg) Nothing))
parseMod = munch1 (\c -> isAlphaNum c || c `elem` ".")
parseItem = do
orig <- tok $ parseMod
orig <- tok $ parseModuleName
(do _ <- tok $ string "as"
new <- tok $ parseMod
new <- tok $ parseModuleName
return (orig, new)
+++
return (orig, orig))
......
......@@ -247,6 +247,8 @@ findHomeModule hsc_env mod_name =
source_exts =
[ ("hs", mkHomeModLocationSearched dflags mod_name "hs")
, ("lhs", mkHomeModLocationSearched dflags mod_name "lhs")
, ("hsig", mkHomeModLocationSearched dflags mod_name "hsig")
, ("lhsig", mkHomeModLocationSearched dflags mod_name "lhsig")
]
hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf)
......
......@@ -673,10 +673,22 @@ buildCompGraph (scc:sccs) = case scc of
CyclicSCC mss -> return ([], Just mss)
-- A Module and whether it is a boot module.
type BuildModule = (Module, Bool)
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 = IsBoot | NotBoot
deriving (Ord, Eq, Show, Read)
-- | Tests if an 'HscSource' is a boot file, primarily for constructing
-- elements of 'BuildModule'.
hscSourceToIsBoot :: HscSource -> IsBoot
hscSourceToIsBoot HsBootFile = IsBoot
hscSourceToIsBoot _ = NotBoot
mkBuildModule :: ModSummary -> BuildModule
mkBuildModule ms = (ms_mod ms, isBootSummary ms)
mkBuildModule ms = (ms_mod ms, if isBootSummary ms then IsBoot else NotBoot)
-- | The entry point to the parallel upsweep.
--
......@@ -904,8 +916,8 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem
-- All the textual imports of this module.
let textual_deps = Set.fromList $ mapFst (mkModule (thisPackage lcl_dflags)) $
zip home_imps (repeat False) ++
zip home_src_imps (repeat True)
zip home_imps (repeat NotBoot) ++
zip home_src_imps (repeat IsBoot)
-- Dealing with module loops
-- ~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1420,13 +1432,14 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l
numbered_summaries = zip summaries [1..]
lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map
lookup_node hs_src mod = Map.lookup (mod, 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), ms_hsc_src s), node)
node_map = Map.fromList [ ((moduleName (ms_mod s),
hscSourceToIsBoot (ms_hsc_src s)), node)
| node@(s, _, _) <- nodes ]
-- We use integers as the keys for the SCC algorithm
......@@ -1459,14 +1472,17 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l
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
-- the IsBootInterface parameter True; else False
-- IsBoot; else NotBoot
type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs
-- 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 NodeMap a = Map.Map NodeKey a
msKey :: ModSummary -> NodeKey
msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot })
= (moduleName mod, hscSourceToIsBoot boot)
mkNodeMap :: [ModSummary] -> NodeMap ModSummary
mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]
......@@ -1535,9 +1551,19 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
rootSummariesOk <- reportImportErrors rootSummaries
let root_map = mkRootMap rootSummariesOk
checkDuplicates root_map
summs <- loop (concatMap msDeps rootSummariesOk) root_map
summs <- loop (concatMap calcDeps rootSummariesOk) root_map
return summs
where
-- When we're compiling a signature file, we have an implicit
-- dependency on what-ever the signature's implementation is.
-- (But not when we're type checking!)
calcDeps summ
| HsigFile <- ms_hsc_src summ
, Just m <- getSigOf (hsc_dflags hsc_env) (moduleName (ms_mod summ))
, modulePackageKey m == thisPackage (hsc_dflags hsc_env)
= (noLoc (moduleName m), NotBoot) : msDeps summ
| otherwise = msDeps summ
dflags = hsc_dflags hsc_env
roots = hsc_targets hsc_env
......@@ -1553,7 +1579,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
else return $ Left $ mkPlainErrMsg dflags noSrcSpan $
text "can't find file:" <+> text file
getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
= do maybe_summary <- summariseModule hsc_env old_summary_map False
= do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot
(L rootLoc modl) obj_allowed
maybe_buf excl_mods
case maybe_summary of
......@@ -1575,7 +1601,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,IsBootInterface)]
loop :: [(Located ModuleName,IsBoot)]
-- Work list: process these modules
-> NodeMap [Either ErrMsg ModSummary]
-- Visited set; the range is a list because
......@@ -1598,9 +1624,10 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
case mb_s of
Nothing -> loop ss done
Just (Left e) -> loop ss (Map.insert key [Left e] done)
Just (Right s)-> loop (msDeps s ++ ss) (Map.insert key [Right s] done)
Just (Right s)-> loop (calcDeps s ++ ss)
(Map.insert key [Right s] done)
where
key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
key = (unLoc wanted_mod, is_boot)
mkRootMap :: [ModSummary] -> NodeMap [Either ErrMsg ModSummary]
mkRootMap summaries = Map.insertListWith (flip (++))
......@@ -1615,10 +1642,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
msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
msDeps :: ModSummary -> [(Located ModuleName, IsBoot)]
msDeps s =
concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ]
++ [ (m,False) | m <- ms_home_imps s ]
concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ]
++ [ (m,NotBoot) | m <- ms_home_imps s ]
home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]
home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ]
......@@ -1678,7 +1705,7 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
obj_timestamp <-
if isObjectTarget (hscTarget (hsc_dflags hsc_env))
|| obj_allowed -- bug #1205
then liftIO $ getObjTimestamp location False
then liftIO $ getObjTimestamp location NotBoot
else return Nothing
return old_summary{ ms_obj_date = obj_timestamp }
else
......@@ -1696,6 +1723,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
......@@ -1716,7 +1745,7 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
then liftIO $ modificationTimeIfExists (ml_obj_file location)
else return Nothing
return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
return (ModSummary { ms_mod = mod, ms_hsc_src = hsc_src,
ms_location = location,
ms_hspp_file = hspp_fn,
ms_hspp_opts = dflags',
......@@ -1736,7 +1765,7 @@ findSummaryBySourceFile summaries file
summariseModule
:: HscEnv
-> NodeMap ModSummary -- Map of old summaries
-> IsBootInterface -- True <=> a {-# SOURCE #-} import
-> IsBoot -- IsBoot <=> a {-# SOURCE #-} import
-> Located ModuleName -- Imported module to be summarised
-> Bool -- object code allowed?
-> Maybe (StringBuffer, UTCTime)
......@@ -1748,7 +1777,7 @@ 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, hsc_src) old_summary_map
| Just old_summary <- Map.lookup (wanted_mod, 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
......@@ -1770,8 +1799,6 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
where
dflags = hsc_dflags hsc_env
hsc_src = if is_boot then HsBootFile else HsSrcFile
check_timestamp old_summary location src_fn src_timestamp
| ms_hs_date old_summary == src_timestamp &&
not (gopt Opt_ForceRecomp dflags) = do
......@@ -1809,8 +1836,8 @@ 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' | is_boot = addBootSuffixLocn location
| otherwise = location
let location' | IsBoot <- is_boot = addBootSuffixLocn location
| otherwise = location
src_fn = expectJust "summarise2" (ml_hs_file location')
-- Check that it exists
......@@ -1828,6 +1855,18 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)