diff options
author | Edward Z. Yang <ezyang@cs.stanford.edu> | 2015-07-24 15:13:49 -0700 |
---|---|---|
committer | Edward Z. Yang <ezyang@cs.stanford.edu> | 2015-09-21 11:53:56 -0700 |
commit | 06d46b1e4507e09eb2a7a04998a92610c8dc6277 (patch) | |
tree | 7dc84733d3b6a8313c272c2c8fed4cc0b5d30e90 /compiler | |
parent | 09d214dcd8e831c128c684facb7c8da1d63c58bc (diff) | |
download | haskell-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.hs | 2 | ||||
-rw-r--r-- | compiler/iface/LoadIface.hs | 2 | ||||
-rw-r--r-- | compiler/iface/MkIface.hs | 47 | ||||
-rw-r--r-- | compiler/main/DriverMkDepend.hs | 6 | ||||
-rw-r--r-- | compiler/main/DriverPhases.hs | 80 | ||||
-rw-r--r-- | compiler/main/DriverPipeline.hs | 248 | ||||
-rw-r--r-- | compiler/main/Finder.hs | 8 | ||||
-rw-r--r-- | compiler/main/GHC.hs | 2 | ||||
-rw-r--r-- | compiler/main/GhcMake.hs | 103 | ||||
-rw-r--r-- | compiler/main/HscMain.hs | 95 | ||||
-rw-r--r-- | compiler/main/HscTypes.hs | 40 | ||||
-rw-r--r-- | compiler/typecheck/TcBinds.hs | 4 | ||||
-rw-r--r-- | compiler/typecheck/TcInstDcls.hs | 4 | ||||
-rw-r--r-- | compiler/typecheck/TcRnDriver.hs | 43 | ||||
-rw-r--r-- | compiler/typecheck/TcRnMonad.hs | 2 |
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) } |