summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorEdward Z. Yang <ezyang@cs.stanford.edu>2015-07-24 15:13:49 -0700
committerEdward Z. Yang <ezyang@cs.stanford.edu>2015-09-21 11:53:56 -0700
commit06d46b1e4507e09eb2a7a04998a92610c8dc6277 (patch)
tree7dc84733d3b6a8313c272c2c8fed4cc0b5d30e90 /compiler
parent09d214dcd8e831c128c684facb7c8da1d63c58bc (diff)
downloadhaskell-06d46b1e4507e09eb2a7a04998a92610c8dc6277.tar.gz
Unify hsig and hs-boot; add preliminary "hs-boot" merging.
This patch drops the file level distinction between hs-boot and hsig; we figure out which one we are compiling based on whether or not there is a corresponding hs file lying around. To make the "import A" syntax continue to work for bare hs-boot files, we also introduce hs-boot merging, which takes an A.hi-boot and converts it to an A.hi when there is no A.hs file in scope. This will be generalized in Backpack to merge multiple A.hi files together; which means we can jettison the "load multiple interface files" functionality. This works automatically for --make, but for one-shot compilation we need a new mode: ghc --merge-requirements A will generate an A.hi/A.o from a local A.hi-boot file; Backpack will extend this mechanism further. Has Haddock submodule update to deal with change in msHsFilePath behavior. - This commit drops support for the hsig extension. Can we support it? It's annoying because the finder code is written with the assumption that where there's an hs-boot file, there's always an hs file too. To support hsig, you'd have to probe two locations. Easier to just not support it. - #10333 affects us, modifying an hs-boot still doesn't trigger recomp. - See compiler/main/Finder.hs: this diff is very skeevy, but it seems to work. - This code cunningly doesn't drop hs-boot files from the "drop hs-boot files" module graph, if they don't have a corresponding hs file. I have no idea if this actually is useful. Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu> Test Plan: validate Reviewers: simonpj, austin, bgamari, spinda Subscribers: thomie Differential Revision: https://phabricator.haskell.org/D1098
Diffstat (limited to 'compiler')
-rw-r--r--compiler/deSugar/Desugar.hs2
-rw-r--r--compiler/iface/LoadIface.hs2
-rw-r--r--compiler/iface/MkIface.hs47
-rw-r--r--compiler/main/DriverMkDepend.hs6
-rw-r--r--compiler/main/DriverPhases.hs80
-rw-r--r--compiler/main/DriverPipeline.hs248
-rw-r--r--compiler/main/Finder.hs8
-rw-r--r--compiler/main/GHC.hs2
-rw-r--r--compiler/main/GhcMake.hs103
-rw-r--r--compiler/main/HscMain.hs95
-rw-r--r--compiler/main/HscTypes.hs40
-rw-r--r--compiler/typecheck/TcBinds.hs4
-rw-r--r--compiler/typecheck/TcInstDcls.hs4
-rw-r--r--compiler/typecheck/TcRnDriver.hs43
-rw-r--r--compiler/typecheck/TcRnMonad.hs2
15 files changed, 447 insertions, 239 deletions
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index 94ee7faab3..1508922423 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -106,7 +106,7 @@ deSugar hsc_env
hpcInfo = emptyHpcInfo other_hpc_info
; (binds_cvr, ds_hpc_info, modBreaks)
- <- if not (isHsBootOrSig hsc_src)
+ <- if not (isHsBoot hsc_src)
then addTicksToBinds dflags mod mod_loc export_set
(typeEnvTyCons type_env) binds
else return (binds, hpcInfo, emptyModBreaks)
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index 6ffa990d57..ddbd80347f 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -896,7 +896,7 @@ pprModIface iface
]
where
pp_hsc_src HsBootFile = ptext (sLit "[boot]")
- pp_hsc_src HsigFile = ptext (sLit "[hsig]")
+ pp_hsc_src HsBootMerge = ptext (sLit "[merge]")
pp_hsc_src HsSrcFile = Outputable.empty
{-
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 757bebac93..99544c4e4f 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -15,6 +15,7 @@ module MkIface (
-- including computing version information
mkIfaceTc,
+ mkIfaceDirect,
writeIfaceFile, -- Write the interface file
@@ -160,6 +161,35 @@ mkIface hsc_env maybe_old_fingerprint mod_details
warns hpc_info dir_imp_mods self_trust dependent_files
safe_mode 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').
@@ -357,11 +387,6 @@ mkIface_ hsc_env maybe_old_fingerprint
return (errs_and_warns, Just (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
@@ -379,8 +404,6 @@ 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
@@ -394,6 +417,16 @@ 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
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index 4d2aadca90..aae4d0e7c2 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -199,9 +199,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
@@ -236,6 +236,10 @@ 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
diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs
index ff6f8b8ab1..f079212112 100644
--- a/compiler/main/DriverPhases.hs
+++ b/compiler/main/DriverPhases.hs
@@ -10,7 +10,7 @@
-----------------------------------------------------------------------------
module DriverPhases (
- HscSource(..), isHsBootOrSig, hscSourceString,
+ HscSource(..), isHsBoot, hscSourceString,
Phase(..),
happensBefore, eqPhase, anyHsc, isStopLn,
startPhase,
@@ -22,12 +22,10 @@ module DriverPhases (
isCishSuffix,
isDynLibSuffix,
isHaskellUserSrcSuffix,
- isHaskellSigSuffix,
isSourceSuffix,
isHaskellishFilename,
isHaskellSrcFilename,
- isHaskellSigFilename,
isObjectFilename,
isCishFilename,
isDynLibFilename,
@@ -60,63 +58,51 @@ import Binary
-- Note [HscSource types]
-- ~~~~~~~~~~~~~~~~~~~~~~
--- There are three types of source file for Haskell code:
+-- There are two types of source file for user-written 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
+-- * 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.
--
--- * 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.
+-- 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.
data HscSource
- = HsSrcFile | HsBootFile | HsigFile
+ = HsSrcFile | HsBootFile | HsBootMerge
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 HsigFile = putByte bh 2
+ put_ bh HsBootMerge = putByte bh 2
get bh = do
h <- getByte bh
case h of
0 -> return HsSrcFile
1 -> return HsBootFile
- _ -> return HsigFile
+ _ -> return HsBootMerge
hscSourceString :: HscSource -> String
hscSourceString HsSrcFile = ""
hscSourceString HsBootFile = "[boot]"
-hscSourceString HsigFile = "[sig]"
+hscSourceString HsBootMerge = "[merge]"
--- See Note [isHsBootOrSig]
-isHsBootOrSig :: HscSource -> Bool
-isHsBootOrSig HsBootFile = True
-isHsBootOrSig HsigFile = True
-isHsBootOrSig _ = False
+isHsBoot :: HscSource -> Bool
+isHsBoot HsBootFile = True
+isHsBoot HsSrcFile = False
+isHsBoot HsBootMerge = False
data Phase
= Unlit HscSource
@@ -232,10 +218,8 @@ 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
@@ -264,7 +248,9 @@ startPhase _ = StopLn -- all unknown file types
phaseInputExt :: Phase -> String
phaseInputExt (Unlit HsSrcFile) = "lhs"
phaseInputExt (Unlit HsBootFile) = "lhs-boot"
-phaseInputExt (Unlit HsigFile) = "lhsig"
+phaseInputExt (Unlit HsBootMerge) = panic "phaseInputExt: Unlit HsBootMerge"
+ -- You can't Unlit an HsBootMerge, because there's no source
+ -- file to Unlit!
phaseInputExt (Cpp _) = "lpp" -- intermediate only
phaseInputExt (HsPp _) = "hscpp" -- intermediate only
phaseInputExt (Hsc _) = "hspp" -- intermediate only
@@ -289,7 +275,7 @@ phaseInputExt MergeStub = "o"
phaseInputExt StopLn = "o"
haskellish_src_suffixes, haskellish_suffixes, cish_suffixes,
- haskellish_user_src_suffixes, haskellish_sig_suffixes
+ haskellish_user_src_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.
@@ -300,9 +286,7 @@ 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 =
- haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ]
-haskellish_sig_suffixes = [ "hsig", "lhsig" ]
+haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ]
objish_suffixes :: Platform -> [String]
-- Use the appropriate suffix for the system on which
@@ -318,10 +302,9 @@ dynlib_suffixes platform = case platformOS platform of
_ -> ["so"]
isHaskellishSuffix, isHaskellSrcSuffix, isCishSuffix,
- isHaskellUserSrcSuffix, isHaskellSigSuffix
+ isHaskellUserSrcSuffix
:: 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
@@ -334,7 +317,7 @@ isSourceSuffix :: String -> Bool
isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff
isHaskellishFilename, isHaskellSrcFilename, isCishFilename,
- isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename
+ isHaskellUserSrcFilename, isSourceFilename
:: FilePath -> Bool
-- takeExtension return .foo, so we drop 1 to get rid of the .
isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f)
@@ -342,7 +325,6 @@ 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)
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index f8b7c30300..a45507e635 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -13,7 +13,7 @@
module DriverPipeline (
-- Run a series of compilation steps in a pipeline, for a
-- collection of source files.
- oneShot, compileFile,
+ oneShot, compileFile, mergeRequirement,
-- Interfaces for the batch-mode driver
linkBinary,
@@ -23,6 +23,9 @@ module DriverPipeline (
compileOne, compileOne',
link,
+ -- Misc utility
+ makeMergeRequirementSummary,
+
-- Exports for hooks to override runPhase and link
PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),
phaseOutputFilename, getPipeState, getPipeEnv,
@@ -61,6 +64,7 @@ import MonadUtils
import Platform
import TcRnTypes
import Hooks
+import MkIface
import Exception
import Data.IORef ( readIORef )
@@ -71,6 +75,7 @@ import Control.Monad
import Data.List ( isSuffixOf )
import Data.Maybe
import Data.Char
+import Data.Time
-- ---------------------------------------------------------------------------
-- Pre-process
@@ -128,56 +133,75 @@ compileOne' :: Maybe TcGblEnv
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_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
- 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)
+ | HsBootMerge <- ms_hsc_src summary
+ = do -- Do a boot merge instead! For now, something very simple
+ output_fn <- getOutputFilename next_phase
+ Temporary basename dflags next_phase (Just location)
+ e <- genericHscMergeRequirement mHscMessage
+ hsc_env summary mb_old_iface (mod_index, nmods)
- let basename = dropExtension input_fn
+ case e of
+ -- TODO: dedup
+ Left iface ->
+ do details <- genModDetails hsc_env iface
+ return (HomeModInfo{ hm_details = details,
+ hm_iface = iface,
+ hm_linkable = maybe_old_linkable })
+ Right (iface0, mb_old_hash) ->
+ case hsc_lang of
+ HscInterpreted ->
+ do (iface, _no_change) <- mkIfaceDirect hsc_env mb_old_hash iface0
+ details <- genModDetails hsc_env iface
+ -- Merges don't need to link in any bytecode, unlike
+ -- HsSrcFiles.
+ let linkable = LM (ms_hs_date summary) this_mod []
+ return (HomeModInfo{ hm_details = details,
+ hm_iface = iface,
+ hm_linkable = Just linkable })
+
+ HscNothing ->
+ do (iface, no_change) <- mkIfaceDirect hsc_env mb_old_hash iface0
+ details <- genModDetails hsc_env iface
+ when (gopt Opt_WriteInterface dflags) $
+ hscWriteIface dflags iface no_change summary
+ let linkable = LM (ms_hs_date summary) this_mod []
+ return (HomeModInfo{ hm_details = details,
+ hm_iface = iface,
+ hm_linkable = Just linkable })
+ _ ->
+ do (iface, no_change) <- mkIfaceDirect hsc_env mb_old_hash iface0
+ hscWriteIface dflags iface no_change summary
+
+ -- #10660: Use the pipeline instead of calling
+ -- compileEmptyStub directly, so -dynamic-too gets
+ -- handled properly
+ let mod_name = ms_mod_name summary
+ _ <- runPipeline StopLn hsc_env
+ (output_fn,
+ Just (HscOut src_flavour
+ mod_name HscUpdateBootMerge))
+ (Just basename)
+ Persistent
+ (Just location)
+ Nothing
+
+ details <- genModDetails hsc_env iface
+
+ o_time <- getModificationUTCTime object_filename
+ let linkable =
+ LM o_time this_mod [DotO object_filename]
+ return (HomeModInfo{ hm_details = details,
+ hm_iface = iface,
+ hm_linkable = Just linkable })
- -- We add the directory in which the .hs files resides) to the import path.
- -- This is needed when we try to compile the .hc file later, if it
- -- imports a _stub.h file that we created here.
- let current_dir = takeDirectory basename
- old_paths = includePaths dflags1
- dflags = dflags1 { includePaths = current_dir : old_paths }
- hsc_env = hsc_env0 {hsc_dflags = dflags}
+ | otherwise
+ = do
- -- Figure out what lang we're generating
- let hsc_lang = hscTarget dflags
- -- ... and what the next phase should be
- let next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
- -- ... and what file to generate the output into
+ debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)
+ -- What file to generate the output into?
output_fn <- getOutputFilename next_phase
Temporary basename dflags next_phase (Just location)
- -- -fforce-recomp should also work with --make
- let force_recomp = gopt Opt_ForceRecomp dflags
- source_modified
- | force_recomp = SourceModified
- | otherwise = source_modified0
- object_filename = ml_obj_file location
-
- let always_do_basic_recompilation_check = case hsc_lang of
- HscInterpreted -> True
- _ -> False
-
e <- genericHscCompileGetFrontendResult
always_do_basic_recompilation_check
m_tc_result mHscMessage
@@ -196,7 +220,7 @@ compileOne' m_tc_result mHscMessage
case hsc_lang of
HscInterpreted ->
case ms_hsc_src summary of
- t | isHsBootOrSig t ->
+ HsBootFile ->
do (iface, _changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash
return (HomeModInfo{ hm_details = details,
hm_iface = iface,
@@ -230,7 +254,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 isHsBootOrSig src_flavour
+ let linkable = if isHsBoot src_flavour
then maybe_old_linkable
else Just (LM (ms_hs_date summary) this_mod [])
return (HomeModInfo{ hm_details = details,
@@ -239,39 +263,17 @@ compileOne' m_tc_result mHscMessage
_ ->
case ms_hsc_src summary of
+ HsBootMerge -> panic "This driver can't handle it"
HsBootFile ->
do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash
hscWriteIface dflags iface changed summary
- touchObjectFile dflags object_filename
- return (HomeModInfo{ hm_details = details,
- hm_iface = iface,
- hm_linkable = maybe_old_linkable })
- HsigFile ->
- do (iface, changed, details) <-
- hscSimpleIface hsc_env tc_result mb_old_hash
- hscWriteIface dflags iface changed summary
-
- -- #10660: Use the pipeline instead of calling
- -- compileEmptyStub directly, so -dynamic-too gets
- -- handled properly
- let mod_name = ms_mod_name summary
- _ <- runPipeline StopLn hsc_env
- (output_fn,
- Just (HscOut src_flavour mod_name HscUpdateSig))
- (Just basename)
- Persistent
- (Just location)
- Nothing
-
- -- Same as Hs
- o_time <- getModificationUTCTime object_filename
- let linkable =
- LM o_time this_mod [DotO object_filename]
+ touchObjectFile dflags object_filename
- return (HomeModInfo{ hm_details = details,
- hm_iface = iface,
- hm_linkable = Just linkable })
+ return (HomeModInfo{
+ hm_details = details,
+ hm_iface = iface,
+ hm_linkable = maybe_old_linkable })
HsSrcFile ->
do guts0 <- hscDesugar hsc_env summary tc_result
@@ -295,6 +297,51 @@ compileOne' m_tc_result mHscMessage
return (HomeModInfo{ hm_details = details,
hm_iface = iface,
hm_linkable = Just linkable })
+ where dflags0 = ms_hspp_opts summary
+ this_mod = ms_mod summary
+ src_flavour = ms_hsc_src 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
+ 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.
+
+ dflags1 = if needsLinker && dynamicGhc && not isDynWay && not isProfWay
+ then gopt_set dflags0 Opt_BuildDynamicToo
+ else dflags0
+
+ basename = dropExtension input_fn
+
+ -- We add the directory in which the .hs files resides) to the import
+ -- path. This is needed when we try to compile the .hc file later, if it
+ -- imports a _stub.h file that we created here.
+ current_dir = takeDirectory basename
+ old_paths = includePaths dflags1
+ dflags = dflags1 { includePaths = current_dir : old_paths }
+ hsc_env = hsc_env0 {hsc_dflags = dflags}
+
+ -- Figure out what lang we're generating
+ hsc_lang = hscTarget dflags
+ -- ... and what the next phase should be
+ next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
+
+ -- -fforce-recomp should also work with --make
+ force_recomp = gopt Opt_ForceRecomp dflags
+ source_modified
+ | force_recomp = SourceModified
+ | otherwise = source_modified0
+ object_filename = ml_obj_file location
+
+ always_do_basic_recompilation_check = case hsc_lang of
+ HscInterpreted -> True
+ _ -> False
-----------------------------------------------------------------------------
-- stub .h and .c files (for foreign export support)
@@ -511,6 +558,50 @@ 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
@@ -992,7 +1083,8 @@ 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_srcimps = src_imps,
+ ms_merge_imps = (False, []) }
-- run the compiler!
result <- liftIO $ hscCompileOneShot hsc_env'
@@ -1024,7 +1116,7 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do
-- stamp file for the benefit of Make
liftIO $ touchObjectFile dflags o_file
return (RealPhase next_phase, o_file)
- HscUpdateSig ->
+ HscUpdateBootMerge ->
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
@@ -2159,7 +2251,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 _ HsigFile _ = StopLn
+hscPostBackendPhase _ HsBootMerge _ = StopLn
hscPostBackendPhase dflags _ hsc_lang =
case hsc_lang of
HscC -> HCc
diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs
index 00ba0388dd..208475fefb 100644
--- a/compiler/main/Finder.hs
+++ b/compiler/main/Finder.hs
@@ -228,8 +228,11 @@ 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")
+ -- 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")
]
hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf)
@@ -250,7 +253,6 @@ 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
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 591d569c41..883cd2c9d7 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -989,7 +989,7 @@ compileCore simplify fn = do
_ <- load LoadAllTargets
-- Then find dependencies
modGraph <- depanal [] True
- case find ((== fn) . msHsFilePath) modGraph of
+ case find ((== Just fn) . msHsFilePath) modGraph of
Just modSummary -> do
-- Now we have the module name;
-- parse, typecheck and desugar the module
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 715b4503ef..cc112da197 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1423,7 +1423,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 HsBootFile mod)
+ root = expectJust "reachableBackwards" (lookup_node IsBoot mod)
-- ---------------------------------------------------------------------------
--
@@ -1462,7 +1462,8 @@ 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 HsSrcFile root_mod, graph `hasVertexG` node = node
+ let root | Just node <- lookup_node NotBoot root_mod
+ , graph `hasVertexG` node = node
| otherwise = throwGhcException (ProgramError "module does not exist")
in graphFromEdgedVertices (seq root (reachableG graph root))
@@ -1475,36 +1476,48 @@ summaryNodeSummary :: SummaryNode -> ModSummary
summaryNodeSummary (s, _, _) = s
moduleGraphNodes :: Bool -> [ModSummary]
- -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
+ -> (Graph SummaryNode, IsBoot -> ModuleName -> Maybe SummaryNode)
moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)
where
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 :: IsBoot -> ModuleName -> Maybe SummaryNode
+ lookup_node is_boot mod = Map.lookup (mod, is_boot) node_map
- lookup_key :: HscSource -> ModuleName -> Maybe Int
- lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
+ lookup_key :: IsBoot -> ModuleName -> Maybe Int
+ lookup_key is_boot mod = fmap summaryNodeKey (lookup_node is_boot 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 && 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]) ]
+ , 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]) ]
-- [boot-edges] if this is a .hs and there is an equivalent
-- .hs-boot, add a link from the former to the latter. This
@@ -1514,12 +1527,13 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l
-- the .hs, and so the HomePackageTable will always have the
-- most up to date information.
- -- Drop hs-boot nodes by using HsSrcFile as the key
- hs_boot_key | drop_hs_boot_nodes = HsSrcFile
- | otherwise = HsBootFile
+ out_edge_keys :: IsBoot -> [ModuleName] -> [Int]
+ out_edge_keys hi_boot ms = mapMaybe (lookup_out_edge_key hi_boot) ms
- out_edge_keys :: HscSource -> [ModuleName] -> [Int]
- out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms
+ 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
-- If we want keep_hi_boot_nodes, then we do lookup_key with
-- IsBoot; else NotBoot
@@ -1608,7 +1622,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
- | HsigFile <- ms_hsc_src summ
+ | HsBootFile <- 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
@@ -1692,10 +1706,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
+--
+-- 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 :: [Located (ImportDecl RdrName)] -> [Located ModuleName]
home_imps imps = [ ideclName i | L _ i <- imps,
@@ -1777,8 +1797,6 @@ 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
@@ -1801,12 +1819,16 @@ 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 = hsc_src,
+ return (ModSummary { ms_mod = mod,
+ ms_hsc_src = if "boot" `isSuffixOf` file
+ then HsBootFile
+ else HsSrcFile,
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 })
@@ -1852,6 +1874,17 @@ 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
@@ -1914,17 +1947,10 @@ 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
- -- 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
+ let hsc_src =
+ case is_boot of
+ IsBoot -> HsBootFile
+ NotBoot -> HsSrcFile
when (mod_name /= wanted_mod) $
throwOneError $ mkPlainErrMsg dflags' mod_loc $
@@ -1949,6 +1975,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
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 })))
@@ -2054,4 +2081,6 @@ cyclicModuleErr mss
ppr_ms :: ModSummary -> SDoc
ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>
- (parens (text (msHsFilePath ms)))
+ case msHsFilePath ms of
+ Just path -> parens (text path)
+ Nothing -> empty
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index c7cabe6f9a..00cff287e0 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -41,6 +41,7 @@ module HscMain
, hscCompileCore
, genericHscCompileGetFrontendResult
+ , genericHscMergeRequirement
, genModDetails
, hscSimpleIface
@@ -94,12 +95,12 @@ import CoreTidy ( tidyExpr )
import Type ( Type, Kind )
import CoreLint ( lintInteractiveExpr )
import VarEnv ( emptyTidyEnv )
-import Panic
import ConLike
import GHC.Exts
#endif
+import Panic
import Module
import Packages
import RdrName
@@ -113,7 +114,8 @@ import TcRnDriver
import TcIface ( typecheckIface )
import TcRnMonad
import IfaceEnv ( initNameCache )
-import LoadIface ( ifaceStats, initExternalPackageState )
+import LoadIface ( ifaceStats, initExternalPackageState
+ , findAndReadIface )
import PrelInfo
import MkIface
import Desugar
@@ -140,6 +142,7 @@ import InstEnv
import FamInstEnv
import Fingerprint ( Fingerprint )
import Hooks
+import Maybes
import DynFlags
import ErrUtils
@@ -158,7 +161,6 @@ import Util
import Data.List
import Control.Monad
-import Data.Maybe
import Data.IORef
import System.FilePath as FilePath
import System.Directory
@@ -511,6 +513,45 @@ This is the only thing that isn't caught by the type-system.
type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO ()
+-- | Analogous to 'genericHscCompileGetFrontendResult', this function
+-- calls 'hscMergeFrontEnd' if recompilation is necessary. It does
+-- not write out the resulting 'ModIface' (see 'compileOne').
+-- TODO: maybe fold this 'genericHscCompileGetFrontendResult' into
+-- some higher-order function
+genericHscMergeRequirement ::
+ Maybe Messager
+ -> HscEnv
+ -> ModSummary
+ -> Maybe ModIface -- Old interface, if available
+ -> (Int,Int) -- (i,n) = module i of n (for msgs)
+ -> IO (Either ModIface (ModIface, Maybe Fingerprint))
+genericHscMergeRequirement mHscMessage
+ hsc_env mod_summary mb_old_iface mod_index = do
+ let msg what = case mHscMessage of
+ Just hscMessage ->
+ hscMessage hsc_env mod_index what mod_summary
+ Nothing -> return ()
+
+ skip iface = do
+ msg UpToDate
+ return (Left iface)
+
+ -- TODO: hook this
+ compile mb_old_hash reason = do
+ msg reason
+ r <- hscMergeFrontEnd hsc_env mod_summary
+ return $ Right (r, mb_old_hash)
+
+ (recomp_reqd, mb_checked_iface)
+ <- {-# SCC "checkOldIface" #-}
+ checkOldIface hsc_env mod_summary
+ SourceUnmodified mb_old_iface
+ case mb_checked_iface of
+ Just iface | not (recompileRequired recomp_reqd) -> skip iface
+ _ -> compile (fmap mi_iface_hash mb_checked_iface) recomp_reqd
+
+-- | This function runs 'genericHscFrontend' if recompilation is necessary.
+-- It does not write out the results of typechecking (see 'compileOne').
genericHscCompileGetFrontendResult ::
Bool -- always do basic recompilation check?
-> Maybe TcGblEnv
@@ -635,18 +676,16 @@ hscCompileOneShot' hsc_env mod_summary src_changed
return HscNotGeneratingCode
_ ->
case ms_hsc_src mod_summary of
- t | isHsBootOrSig t ->
+ HsBootFile ->
do (iface, changed, _) <- hscSimpleIface' tc_result mb_old_hash
liftIO $ hscWriteIface dflags iface changed mod_summary
- return (case t of
- HsBootFile -> HscUpdateBoot
- HsigFile -> HscUpdateSig
- HsSrcFile -> panic "hscCompileOneShot Src")
- _ ->
+ return HscUpdateBoot
+ HsSrcFile ->
do guts <- hscSimplify' guts0
(iface, changed, _details, cgguts) <- hscNormalIface' guts mb_old_hash
liftIO $ hscWriteIface dflags iface changed mod_summary
return $ HscRecomp cgguts mod_summary
+ HsBootMerge -> panic "hscCompileOneShot HsBootMerge"
-- XXX This is always False, because in one-shot mode the
-- concept of stability does not exist. The driver never
@@ -727,8 +766,46 @@ batchMsg hsc_env mod_index recomp mod_summary =
-- FrontEnds
--------------------------------------------------------------
+-- | Given an 'HsBootMerge' 'ModSummary', merges all @hs-boot@ files
+-- under this module name into a composite, publically visible 'ModIface'.
+hscMergeFrontEnd :: HscEnv -> ModSummary -> IO ModIface
+hscMergeFrontEnd hsc_env mod_summary = do
+ MASSERT( ms_hsc_src mod_summary == HsBootMerge )
+ let dflags = hsc_dflags hsc_env
+ -- TODO: actually merge in signatures from external packages.
+ -- Grovel in HPT if necessary
+ -- TODO: replace with 'computeInterface'
+ let hpt = hsc_HPT hsc_env
+ -- TODO multiple mods
+ let name = moduleName (ms_mod mod_summary)
+ mod = mkModule (thisPackage dflags) name
+ is_boot = True
+ iface0 <- case lookupHptByModule hpt mod of
+ Just hm -> return (hm_iface hm)
+ Nothing -> do
+ mb_iface0 <- initIfaceCheck hsc_env
+ $ findAndReadIface (text "merge-requirements")
+ mod is_boot
+ case mb_iface0 of
+ Succeeded (i, _) -> return i
+ Failed err -> liftIO $ throwGhcExceptionIO
+ (ProgramError (showSDoc dflags err))
+ let iface = iface0 {
+ mi_hsc_src = HsBootMerge,
+ -- TODO: mkDependencies doublecheck
+ mi_deps = (mi_deps iface0) {
+ dep_mods = (name, is_boot)
+ : dep_mods (mi_deps iface0)
+ }
+ }
+ return iface
+
+-- | Given a 'ModSummary', parses and typechecks it, returning the
+-- 'TcGblEnv' resulting from type-checking.
hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
hscFileFrontEnd mod_summary = do
+ MASSERT( ms_hsc_src mod_summary == HsBootFile ||
+ ms_hsc_src mod_summary == HsSrcFile )
hpm <- hscParse' mod_summary
hsc_env <- getHscEnv
tcg_env <- tcRnModule' hsc_env mod_summary False hpm
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 6b94998490..00ceb41ed9 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -29,7 +29,7 @@ module HscTypes (
-- * Information about the module being compiled
-- (re-exported from DriverPhases)
- HscSource(..), isHsBootOrSig, hscSourceString,
+ HscSource(..), isHsBoot, hscSourceString,
-- * State relating to modules in this package
@@ -162,7 +162,7 @@ import PatSyn
import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule )
import Packages hiding ( Version(..) )
import DynFlags
-import DriverPhases ( Phase, HscSource(..), isHsBootOrSig, hscSourceString )
+import DriverPhases ( Phase, HscSource(..), isHsBoot, hscSourceString )
import BasicTypes
import IfaceSyn
import CoreSyn ( CoreRule, CoreVect )
@@ -202,7 +202,7 @@ data HscStatus
= HscNotGeneratingCode
| HscUpToDate
| HscUpdateBoot
- | HscUpdateSig
+ | HscUpdateBootMerge
| HscRecomp CgGuts ModSummary
-- -----------------------------------------------------------------------------
@@ -2410,6 +2410,8 @@ data ModSummary
-- ^ Source imports of the module
ms_textual_imps :: [Located (ImportDecl RdrName)],
-- ^ Non-source imports of the module from the module *text*
+ ms_merge_imps :: (Bool, [Module]),
+ -- ^ Non-textual imports computed for HsBootMerge
ms_hspp_file :: FilePath,
-- ^ Filename of preprocessed source file
ms_hspp_opts :: DynFlags,
@@ -2453,8 +2455,10 @@ ms_imps ms =
-- The ModLocation is stable over successive up-sweeps in GHCi, wheres
-- the ms_hs_date and imports can, of course, change
-msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath
-msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms))
+msHsFilePath :: ModSummary -> Maybe FilePath
+msHsFilePath ms = ml_hs_file (ms_location ms)
+
+msHiFilePath, msObjFilePath :: ModSummary -> FilePath
msHiFilePath ms = ml_hi_file (ms_location ms)
msObjFilePath ms = ml_obj_file (ms_location ms)
@@ -2469,7 +2473,10 @@ instance Outputable ModSummary where
text "ms_mod =" <+> ppr (ms_mod ms)
<> text (hscSourceString (ms_hsc_src ms)) <> comma,
text "ms_textual_imps =" <+> ppr (ms_textual_imps ms),
- text "ms_srcimps =" <+> ppr (ms_srcimps ms)]),
+ text "ms_srcimps =" <+> ppr (ms_srcimps ms),
+ if not (null (ms_merge_imps ms))
+ then text "ms_merge_imps =" <+> ppr (ms_merge_imps ms)
+ else empty]),
char '}'
]
@@ -2477,29 +2484,20 @@ showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String
showModMsg dflags target recomp mod_summary
= showSDoc dflags $
hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '),
- char '(', text (normalise $ msHsFilePath mod_summary) <> comma,
+ char '(',
+ case msHsFilePath mod_summary of
+ Just path -> text (normalise path) <> comma
+ Nothing -> text "nothing" <> comma,
case target of
HscInterpreted | recomp
-> text "interpreted"
HscNothing -> text "nothing"
- _ | HsigFile == ms_hsc_src mod_summary -> text "nothing"
- | otherwise -> text (normalise $ msObjFilePath mod_summary),
+ _ -> text (normalise $ msObjFilePath mod_summary),
char ')']
where
mod = moduleName (ms_mod mod_summary)
mod_str = showPpr dflags mod
- ++ hscSourceString' dflags mod (ms_hsc_src mod_summary)
-
--- | Variant of hscSourceString which prints more information for signatures.
--- This can't live in DriverPhases because this would cause a module loop.
-hscSourceString' :: DynFlags -> ModuleName -> HscSource -> String
-hscSourceString' _ _ HsSrcFile = ""
-hscSourceString' _ _ HsBootFile = "[boot]"
-hscSourceString' dflags mod HsigFile =
- "[" ++ (maybe "abstract sig"
- (("sig of "++).showPpr dflags)
- (getSigOf dflags mod)) ++ "]"
- -- NB: -sig-of could be missing if we're just typechecking
+ ++ hscSourceString (ms_hsc_src mod_summary)
{-
************************************************************************
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 897828d5ec..48abcc805c 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -21,7 +21,7 @@ import {-# SOURCE #-} TcExpr ( tcMonoExpr )
import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl, tcPatSynBuilderBind )
import DynFlags
import HsSyn
-import HscTypes( isHsBootOrSig )
+import HscTypes( isHsBoot )
import TcRnMonad
import TcEnv
import TcUnify
@@ -184,7 +184,7 @@ tcRecSelBinds (ValBindsOut binds sigs)
= tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
do { (rec_sel_binds, tcg_env) <- discardWarnings (tcValBinds TopLevel binds sigs getGblEnv)
; let tcg_env'
- | isHsBootOrSig (tcg_src tcg_env) = tcg_env
+ | isHsBoot (tcg_src tcg_env) = tcg_env
| otherwise = tcg_env { tcg_binds = foldr (unionBags . snd)
(tcg_binds tcg_env)
rec_sel_binds }
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index d31b7bf310..d5dee95b00 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -50,7 +50,7 @@ import BasicTypes
import DynFlags
import ErrUtils
import FastString
-import HscTypes ( isHsBootOrSig )
+import HscTypes ( isHsBoot )
import Id
import MkId
import Name
@@ -442,7 +442,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
typeable_err i =
setSrcSpan (getSrcSpan (iSpec i)) $
do env <- getGblEnv
- if isHsBootOrSig (tcg_src env)
+ if isHsBoot (tcg_src env)
then
do warn <- woptM Opt_WarnDerivingTypeable
when warn $ addWarnTc $ vcat
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index fc90f316fe..2c2e5d71a9 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -161,8 +161,12 @@ tcRnSignature dflags hsc_src
= do { tcg_env <- getGblEnv ;
case tcg_sig_of tcg_env of {
Just sof
- | hsc_src /= HsigFile -> do
- { addErr (ptext (sLit "Illegal -sig-of specified for non hsig"))
+ | hsc_src /= HsBootFile -> do
+ { modname <- fmap moduleName getModule
+ ; addErr (text "Found -sig-of entry for" <+> ppr modname
+ <+> text "which is not hs-boot." $$
+ text "Try removing" <+> ppr modname <+>
+ text "from -sig-of")
; return tcg_env
}
| otherwise -> do
@@ -176,15 +180,7 @@ tcRnSignature dflags hsc_src
, tcg_imports = tcg_imports tcg_env `plusImportAvails` avails
})
} ;
- Nothing
- | HsigFile <- hsc_src
- , HscNothing <- hscTarget dflags -> do
- { return tcg_env
- }
- | HsigFile <- hsc_src -> do
- { addErr (ptext (sLit "Missing -sig-of for hsig"))
- ; failM }
- | otherwise -> return tcg_env
+ Nothing -> return tcg_env
}
}
@@ -320,7 +316,7 @@ tcRnModuleTcRnM hsc_env hsc_src
-- Rename and type check the declarations
traceRn (text "rn1a") ;
- tcg_env <- if isHsBootOrSig hsc_src then
+ tcg_env <- if isHsBoot hsc_src then
tcRnHsBootDecls hsc_src local_decls
else
{-# SCC "tcRnSrcDecls" #-}
@@ -667,9 +663,9 @@ tcRnHsBootDecls hsc_src decls
-- are written into the interface file.
; let { type_env0 = tcg_type_env gbl_env
; type_env1 = extendTypeEnvWithIds type_env0 val_ids
- -- Don't add the dictionaries for hsig, we don't actually want
- -- to /define/ the instance
- ; type_env2 | HsigFile <- hsc_src = type_env1
+ -- Don't add the dictionaries for non-recursive case, we don't
+ -- actually want to /define/ the instance, just an export list
+ ; type_env2 | Just _ <- tcg_impl_rdr_env gbl_env = type_env1
| otherwise = extendTypeEnvWithIds type_env1 dfun_ids
; dfun_ids = map iDFunId inst_infos
}
@@ -679,14 +675,9 @@ tcRnHsBootDecls hsc_src decls
; traceTc "boot" (ppr lie); return gbl_env }
badBootDecl :: HscSource -> String -> Located decl -> TcM ()
-badBootDecl hsc_src what (L loc _)
+badBootDecl _hsc_src what (L loc _)
= addErrAt loc (char 'A' <+> text what
- <+> ptext (sLit "declaration is not (currently) allowed in a")
- <+> (case hsc_src of
- HsBootFile -> ptext (sLit "hs-boot")
- HsigFile -> ptext (sLit "hsig")
- _ -> panic "badBootDecl: should be an hsig or hs-boot file")
- <+> ptext (sLit "file"))
+ <+> text "declaration is not (currently) allowed in a hs-boot file")
{-
Once we've typechecked the body of the module, we want to compare what
@@ -1061,7 +1052,7 @@ emptyRnEnv2 = mkRnEnv2 emptyInScopeSet
missingBootThing :: Bool -> Name -> String -> SDoc
missingBootThing is_boot name what
= quotes (ppr name) <+> ptext (sLit "is exported by the")
- <+> (if is_boot then ptext (sLit "hs-boot") else ptext (sLit "hsig"))
+ <+> (if is_boot then ptext (sLit "hs-boot") else ptext (sLit "signature"))
<+> ptext (sLit "file, but not")
<+> text what <+> ptext (sLit "the module")
@@ -1071,11 +1062,11 @@ bootMisMatch is_boot extra_info real_thing boot_thing
ptext (sLit "has conflicting definitions in the module"),
ptext (sLit "and its") <+>
(if is_boot then ptext (sLit "hs-boot file")
- else ptext (sLit "hsig file")),
+ else ptext (sLit "signature file")),
ptext (sLit "Main module:") <+> PprTyThing.pprTyThing real_thing,
(if is_boot
then ptext (sLit "Boot file: ")
- else ptext (sLit "Hsig file: "))
+ else ptext (sLit "Signature file: "))
<+> PprTyThing.pprTyThing boot_thing,
extra_info]
@@ -1083,7 +1074,7 @@ instMisMatch :: Bool -> ClsInst -> SDoc
instMisMatch is_boot inst
= hang (ppr inst)
2 (ptext (sLit "is defined in the") <+>
- (if is_boot then ptext (sLit "hs-boot") else ptext (sLit "hsig"))
+ (if is_boot then ptext (sLit "hs-boot") else ptext (sLit "signature"))
<+> ptext (sLit "file, but not in the module itself"))
{-
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 2492c5544e..2dbabfc8fd 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -609,7 +609,7 @@ getInteractivePrintName :: TcRn Name
getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }
tcIsHsBootOrSig :: TcRn Bool
-tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
+tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
tcSelfBootInfo :: TcRn SelfBootInfo
tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) }