Commit 06d46b1e authored by Edward Z. Yang's avatar Edward Z. Yang

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: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: simonpj, austin, bgamari, spinda

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1098
parent 09d214dc
...@@ -106,7 +106,7 @@ deSugar hsc_env ...@@ -106,7 +106,7 @@ deSugar hsc_env
hpcInfo = emptyHpcInfo other_hpc_info hpcInfo = emptyHpcInfo other_hpc_info
; (binds_cvr, ds_hpc_info, modBreaks) ; (binds_cvr, ds_hpc_info, modBreaks)
<- if not (isHsBootOrSig hsc_src) <- if not (isHsBoot hsc_src)
then addTicksToBinds dflags mod mod_loc export_set then addTicksToBinds dflags mod mod_loc export_set
(typeEnvTyCons type_env) binds (typeEnvTyCons type_env) binds
else return (binds, hpcInfo, emptyModBreaks) else return (binds, hpcInfo, emptyModBreaks)
......
...@@ -896,7 +896,7 @@ pprModIface iface ...@@ -896,7 +896,7 @@ pprModIface iface
] ]
where where
pp_hsc_src HsBootFile = ptext (sLit "[boot]") 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 pp_hsc_src HsSrcFile = Outputable.empty
{- {-
......
...@@ -15,6 +15,7 @@ module MkIface ( ...@@ -15,6 +15,7 @@ module MkIface (
-- including computing version information -- including computing version information
mkIfaceTc, mkIfaceTc,
mkIfaceDirect,
writeIfaceFile, -- Write the interface file writeIfaceFile, -- Write the interface file
...@@ -160,6 +161,35 @@ mkIface hsc_env maybe_old_fingerprint mod_details ...@@ -160,6 +161,35 @@ mkIface hsc_env maybe_old_fingerprint mod_details
warns hpc_info dir_imp_mods self_trust dependent_files warns hpc_info dir_imp_mods self_trust dependent_files
safe_mode mod_details 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 -- | make an interface from the results of typechecking only. Useful
-- for non-optimising compilation, or where we aren't generating any -- for non-optimising compilation, or where we aren't generating any
-- object code at all ('HscNothing'). -- object code at all ('HscNothing').
...@@ -357,11 +387,6 @@ mkIface_ hsc_env maybe_old_fingerprint ...@@ -357,11 +387,6 @@ mkIface_ hsc_env maybe_old_fingerprint
return (errs_and_warns, Just (final_iface, no_change_at_all)) return (errs_and_warns, Just (final_iface, no_change_at_all))
where 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 dflags = hsc_dflags hsc_env
...@@ -379,8 +404,6 @@ mkIface_ hsc_env maybe_old_fingerprint ...@@ -379,8 +404,6 @@ mkIface_ hsc_env maybe_old_fingerprint
deliberatelyOmitted :: String -> a deliberatelyOmitted :: String -> a
deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
ifFamInstTcName = ifFamInstFam
flattenVectInfo (VectInfo { vectInfoVar = vVar flattenVectInfo (VectInfo { vectInfoVar = vVar
, vectInfoTyCon = vTyCon , vectInfoTyCon = vTyCon
, vectInfoParallelVars = vParallelVars , vectInfoParallelVars = vParallelVars
...@@ -394,6 +417,16 @@ mkIface_ hsc_env maybe_old_fingerprint ...@@ -394,6 +417,16 @@ mkIface_ hsc_env maybe_old_fingerprint
, ifaceVectInfoParallelTyCons = nameSetElems vParallelTyCons , 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 :: DynFlags -> FilePath -> ModIface -> IO ()
writeIfaceFile dflags hi_file_path new_iface writeIfaceFile dflags hi_file_path new_iface
......
...@@ -199,9 +199,9 @@ processDeps dflags _ _ _ _ (CyclicSCC nodes) ...@@ -199,9 +199,9 @@ processDeps dflags _ _ _ _ (CyclicSCC nodes)
throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes)) throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))
processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node) processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
| Just src_file <- msHsFilePath node
= do { let extra_suffixes = depSuffixes dflags = do { let extra_suffixes = depSuffixes dflags
include_pkg_deps = depIncludePkgDeps dflags include_pkg_deps = depIncludePkgDeps dflags
src_file = msHsFilePath node
obj_file = msObjFilePath node obj_file = msObjFilePath node
obj_files = insertSuffixes obj_file extra_suffixes obj_files = insertSuffixes obj_file extra_suffixes
...@@ -236,6 +236,10 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node) ...@@ -236,6 +236,10 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
; do_imps False (ms_imps node) ; do_imps False (ms_imps node)
} }
| otherwise
= ASSERT( ms_hsc_src node == HsBootMerge )
panic "HsBootMerge not supported in DriverMkDepend yet"
findDependency :: HscEnv findDependency :: HscEnv
-> SrcSpan -> SrcSpan
......
...@@ -10,7 +10,7 @@ ...@@ -10,7 +10,7 @@
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module DriverPhases ( module DriverPhases (
HscSource(..), isHsBootOrSig, hscSourceString, HscSource(..), isHsBoot, hscSourceString,
Phase(..), Phase(..),
happensBefore, eqPhase, anyHsc, isStopLn, happensBefore, eqPhase, anyHsc, isStopLn,
startPhase, startPhase,
...@@ -22,12 +22,10 @@ module DriverPhases ( ...@@ -22,12 +22,10 @@ module DriverPhases (
isCishSuffix, isCishSuffix,
isDynLibSuffix, isDynLibSuffix,
isHaskellUserSrcSuffix, isHaskellUserSrcSuffix,
isHaskellSigSuffix,
isSourceSuffix, isSourceSuffix,
isHaskellishFilename, isHaskellishFilename,
isHaskellSrcFilename, isHaskellSrcFilename,
isHaskellSigFilename,
isObjectFilename, isObjectFilename,
isCishFilename, isCishFilename,
isDynLibFilename, isDynLibFilename,
...@@ -60,63 +58,51 @@ import Binary ...@@ -60,63 +58,51 @@ import Binary
-- Note [HscSource types] -- 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, -- * HsSrcFile is an ordinary hs file which contains code,
-- --
-- * HsBootFile is an hs-boot file, which is used to break -- * HsBootFile is an hs-boot file. Within a unit, it can
-- recursive module imports (there will always be an -- be used to break recursive module imports, in which case there's an
-- HsSrcFile associated with it), and -- 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 -- An HsBootMerge is a "fake" source file, which is constructed
-- signatures and is used to specify signatures for -- by collecting up non-recursive HsBootFiles into a single interface.
-- modules. -- HsBootMerges get an hi and o file, and are treated as "non-boot"
-- -- sources.
-- Syntactically, hs-boot files and hsig files are quite similar: they
-- only include type signatures and must be associated with an
-- actual HsSrcFile. isHsBootOrSig allows us to abstract over code
-- which is indifferent to which. However, there are some important
-- differences, mostly owing to the fact that hsigs are proper
-- modules (you `import Sig` directly) whereas HsBootFiles are
-- temporary placeholders (you `import {-# SOURCE #-} Mod).
-- When we finish compiling the true implementation of an hs-boot,
-- we replace the HomeModInfo with the real HsSrcFile. An HsigFile, on the
-- other hand, is never replaced (in particular, we *cannot* use the
-- HomeModInfo of the original HsSrcFile backing the signature, since it
-- will export too many symbols.)
--
-- Additionally, while HsSrcFile is the only Haskell file
-- which has *code*, we do generate .o files for HsigFile, because
-- this is how the recompilation checker figures out if a file
-- needs to be recompiled. These are fake object files which
-- should NOT be linked against.
data HscSource data HscSource
= HsSrcFile | HsBootFile | HsigFile = HsSrcFile | HsBootFile | HsBootMerge
deriving( Eq, Ord, Show ) deriving( Eq, Ord, Show )
-- Ord needed for the finite maps we build in CompManager -- 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 instance Binary HscSource where
put_ bh HsSrcFile = putByte bh 0 put_ bh HsSrcFile = putByte bh 0
put_ bh HsBootFile = putByte bh 1 put_ bh HsBootFile = putByte bh 1
put_ bh HsigFile = putByte bh 2 put_ bh HsBootMerge = putByte bh 2
get bh = do get bh = do
h <- getByte bh h <- getByte bh
case h of case h of
0 -> return HsSrcFile 0 -> return HsSrcFile
1 -> return HsBootFile 1 -> return HsBootFile
_ -> return HsigFile _ -> return HsBootMerge
hscSourceString :: HscSource -> String hscSourceString :: HscSource -> String
hscSourceString HsSrcFile = "" hscSourceString HsSrcFile = ""
hscSourceString HsBootFile = "[boot]" hscSourceString HsBootFile = "[boot]"
hscSourceString HsigFile = "[sig]" hscSourceString HsBootMerge = "[merge]"
-- See Note [isHsBootOrSig] isHsBoot :: HscSource -> Bool
isHsBootOrSig :: HscSource -> Bool isHsBoot HsBootFile = True
isHsBootOrSig HsBootFile = True isHsBoot HsSrcFile = False
isHsBootOrSig HsigFile = True isHsBoot HsBootMerge = False
isHsBootOrSig _ = False
data Phase data Phase
= Unlit HscSource = Unlit HscSource
...@@ -232,10 +218,8 @@ nextPhase dflags p ...@@ -232,10 +218,8 @@ nextPhase dflags p
startPhase :: String -> Phase startPhase :: String -> Phase
startPhase "lhs" = Unlit HsSrcFile startPhase "lhs" = Unlit HsSrcFile
startPhase "lhs-boot" = Unlit HsBootFile startPhase "lhs-boot" = Unlit HsBootFile
startPhase "lhsig" = Unlit HsigFile
startPhase "hs" = Cpp HsSrcFile startPhase "hs" = Cpp HsSrcFile
startPhase "hs-boot" = Cpp HsBootFile startPhase "hs-boot" = Cpp HsBootFile
startPhase "hsig" = Cpp HsigFile
startPhase "hscpp" = HsPp HsSrcFile startPhase "hscpp" = HsPp HsSrcFile
startPhase "hspp" = Hsc HsSrcFile startPhase "hspp" = Hsc HsSrcFile
startPhase "hc" = HCc startPhase "hc" = HCc
...@@ -264,7 +248,9 @@ startPhase _ = StopLn -- all unknown file types ...@@ -264,7 +248,9 @@ startPhase _ = StopLn -- all unknown file types
phaseInputExt :: Phase -> String phaseInputExt :: Phase -> String
phaseInputExt (Unlit HsSrcFile) = "lhs" phaseInputExt (Unlit HsSrcFile) = "lhs"
phaseInputExt (Unlit HsBootFile) = "lhs-boot" 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 (Cpp _) = "lpp" -- intermediate only
phaseInputExt (HsPp _) = "hscpp" -- intermediate only phaseInputExt (HsPp _) = "hscpp" -- intermediate only
phaseInputExt (Hsc _) = "hspp" -- intermediate only phaseInputExt (Hsc _) = "hspp" -- intermediate only
...@@ -289,7 +275,7 @@ phaseInputExt MergeStub = "o" ...@@ -289,7 +275,7 @@ phaseInputExt MergeStub = "o"
phaseInputExt StopLn = "o" phaseInputExt StopLn = "o"
haskellish_src_suffixes, haskellish_suffixes, cish_suffixes, haskellish_src_suffixes, haskellish_suffixes, cish_suffixes,
haskellish_user_src_suffixes, haskellish_sig_suffixes haskellish_user_src_suffixes
:: [String] :: [String]
-- When a file with an extension in the haskellish_src_suffixes group is -- When a file with an extension in the haskellish_src_suffixes group is
-- loaded in --make mode, its imports will be loaded too. -- loaded in --make mode, its imports will be loaded too.
...@@ -300,9 +286,7 @@ haskellish_suffixes = haskellish_src_suffixes ++ ...@@ -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" ] cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ]
-- Will not be deleted as temp files: -- Will not be deleted as temp files:
haskellish_user_src_suffixes = haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ]
haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ]
haskellish_sig_suffixes = [ "hsig", "lhsig" ]
objish_suffixes :: Platform -> [String] objish_suffixes :: Platform -> [String]
-- Use the appropriate suffix for the system on which -- Use the appropriate suffix for the system on which
...@@ -318,10 +302,9 @@ dynlib_suffixes platform = case platformOS platform of ...@@ -318,10 +302,9 @@ dynlib_suffixes platform = case platformOS platform of
_ -> ["so"] _ -> ["so"]
isHaskellishSuffix, isHaskellSrcSuffix, isCishSuffix, isHaskellishSuffix, isHaskellSrcSuffix, isCishSuffix,
isHaskellUserSrcSuffix, isHaskellSigSuffix isHaskellUserSrcSuffix
:: String -> Bool :: String -> Bool
isHaskellishSuffix s = s `elem` haskellish_suffixes isHaskellishSuffix s = s `elem` haskellish_suffixes
isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes
isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes
isCishSuffix s = s `elem` cish_suffixes isCishSuffix s = s `elem` cish_suffixes
isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes
...@@ -334,7 +317,7 @@ isSourceSuffix :: String -> Bool ...@@ -334,7 +317,7 @@ isSourceSuffix :: String -> Bool
isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff
isHaskellishFilename, isHaskellSrcFilename, isCishFilename, isHaskellishFilename, isHaskellSrcFilename, isCishFilename,
isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename isHaskellUserSrcFilename, isSourceFilename
:: FilePath -> Bool :: FilePath -> Bool
-- takeExtension return .foo, so we drop 1 to get rid of the . -- takeExtension return .foo, so we drop 1 to get rid of the .
isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f) isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f)
...@@ -342,7 +325,6 @@ isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f) ...@@ -342,7 +325,6 @@ isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f)
isCishFilename f = isCishSuffix (drop 1 $ takeExtension f) isCishFilename f = isCishSuffix (drop 1 $ takeExtension f)
isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f) isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f)
isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f) isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f)
isHaskellSigFilename f = isHaskellSigSuffix (drop 1 $ takeExtension f)
isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool
isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f) isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f)
......
This diff is collapsed.
...@@ -228,8 +228,11 @@ findHomeModule hsc_env mod_name = ...@@ -228,8 +228,11 @@ findHomeModule hsc_env mod_name =
source_exts = source_exts =
[ ("hs", mkHomeModLocationSearched dflags mod_name "hs") [ ("hs", mkHomeModLocationSearched dflags mod_name "hs")
, ("lhs", mkHomeModLocationSearched dflags mod_name "lhs") , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs")
, ("hsig", mkHomeModLocationSearched dflags mod_name "hsig") -- TODO: This is a giant hack! If we find an hs-boot file,
, ("lhsig", mkHomeModLocationSearched dflags mod_name "lhsig") -- 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) hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf)
...@@ -250,7 +253,6 @@ findHomeModule hsc_env mod_name = ...@@ -250,7 +253,6 @@ findHomeModule hsc_env mod_name =
then return (Found (error "GHC.Prim ModLocation") mod) then return (Found (error "GHC.Prim ModLocation") mod)
else searchPathExts home_path mod exts else searchPathExts home_path mod exts
-- | Search for a module in external packages only. -- | Search for a module in external packages only.
findPackageModule :: HscEnv -> Module -> IO FindResult findPackageModule :: HscEnv -> Module -> IO FindResult
findPackageModule hsc_env mod = do findPackageModule hsc_env mod = do
......
...@@ -989,7 +989,7 @@ compileCore simplify fn = do ...@@ -989,7 +989,7 @@ compileCore simplify fn = do
_ <- load LoadAllTargets _ <- load LoadAllTargets
-- Then find dependencies -- Then find dependencies
modGraph <- depanal [] True modGraph <- depanal [] True
case find ((== fn) . msHsFilePath) modGraph of case find ((== Just fn) . msHsFilePath) modGraph of
Just modSummary -> do Just modSummary -> do
-- Now we have the module name; -- Now we have the module name;
-- parse, typecheck and desugar the module -- parse, typecheck and desugar the module
......
This diff is collapsed.
...@@ -41,6 +41,7 @@ module HscMain ...@@ -41,6 +41,7 @@ module HscMain
, hscCompileCore , hscCompileCore
, genericHscCompileGetFrontendResult , genericHscCompileGetFrontendResult
, genericHscMergeRequirement
, genModDetails , genModDetails
, hscSimpleIface , hscSimpleIface
...@@ -94,12 +95,12 @@ import CoreTidy ( tidyExpr ) ...@@ -94,12 +95,12 @@ import CoreTidy ( tidyExpr )
import Type ( Type, Kind ) import Type ( Type, Kind )
import CoreLint ( lintInteractiveExpr ) import CoreLint ( lintInteractiveExpr )
import VarEnv ( emptyTidyEnv ) import VarEnv ( emptyTidyEnv )
import Panic
import ConLike import ConLike
import GHC.Exts import GHC.Exts
#endif #endif
import Panic
import Module import Module
import Packages import Packages
import RdrName import RdrName
...@@ -113,7 +114,8 @@ import TcRnDriver ...@@ -113,7 +114,8 @@ import TcRnDriver
import TcIface ( typecheckIface ) import TcIface ( typecheckIface )
import TcRnMonad import TcRnMonad
import IfaceEnv ( initNameCache ) import IfaceEnv ( initNameCache )
import LoadIface ( ifaceStats, initExternalPackageState ) import LoadIface ( ifaceStats, initExternalPackageState
, findAndReadIface )
import PrelInfo import PrelInfo
import MkIface import MkIface
import Desugar import Desugar
...@@ -140,6 +142,7 @@ import InstEnv ...@@ -140,6 +142,7 @@ import InstEnv
import FamInstEnv import FamInstEnv
import Fingerprint ( Fingerprint ) import Fingerprint ( Fingerprint )
import Hooks import Hooks
import Maybes
import DynFlags import DynFlags
import ErrUtils import ErrUtils
...@@ -158,7 +161,6 @@ import Util ...@@ -158,7 +161,6 @@ import Util
import Data.List import Data.List
import Control.Monad import Control.Monad
import Data.Maybe
import Data.IORef import Data.IORef
import System.FilePath as FilePath import System.FilePath as FilePath
import System.Directory import System.Directory
...@@ -511,6 +513,45 @@ This is the only thing that isn't caught by the type-system. ...@@ -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 () 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 :: genericHscCompileGetFrontendResult ::
Bool -- always do basic recompilation check? Bool -- always do basic recompilation check?
-> Maybe TcGblEnv -> Maybe TcGblEnv
...@@ -635,18 +676,16 @@ hscCompileOneShot' hsc_env mod_summary src_changed ...@@ -635,18 +676,16 @@ hscCompileOneShot' hsc_env mod_summary src_changed
return HscNotGeneratingCode return HscNotGeneratingCode
_ -> _ ->
case ms_hsc_src mod_summary of case ms_hsc_src mod_summary of
t | isHsBootOrSig t -> HsBootFile ->
do (iface, changed, _) <- hscSimpleIface' tc_result mb_old_hash do (iface, changed, _) <- hscSimpleIface' tc_result mb_old_hash
liftIO $ hscWriteIface dflags iface changed mod_summary liftIO $ hscWriteIface dflags iface changed mod_summary
return (case t of return HscUpdateBoot
HsBootFile -> HscUpdateBoot HsSrcFile ->
HsigFile -> HscUpdateSig
HsSrcFile -> panic "hscCompileOneShot Src")
_ ->
do guts <- hscSimplify' guts0 do guts <- hscSimplify' guts0
(iface, changed, _details, cgguts) <- hscNormalIface' guts mb_old_hash (iface, changed, _details, cgguts) <- hscNormalIface' guts mb_old_hash
liftIO $ hscWriteIface dflags iface changed mod_summary liftIO $ hscWriteIface dflags iface changed mod_summary
return $ HscRecomp cgguts mod_summary return $ HscRecomp cgguts mod_summary
HsBootMerge -> panic "hscCompileOneShot HsBootMerge"
-- XXX This is always False, because in one-shot mode the -- XXX This is always False, because in one-shot mode the
-- concept of stability does not exist. The driver never -- concept of stability does not exist. The driver never
...@@ -727,8 +766,46 @@ batchMsg hsc_env mod_index recomp mod_summary = ...@@ -727,8 +766,46 @@ batchMsg hsc_env mod_index recomp mod_summary =
-- FrontEnds -- 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 :: ModSummary -> Hsc TcGblEnv
hscFileFrontEnd mod_summary = do hscFileFrontEnd mod_summary = do
MASSERT( ms_hsc_src mod_summary == HsBootFile ||
ms_hsc_src mod_summary == HsSrcFile )
hpm <- hscParse' mod_summary hpm <- hscParse' mod_summary
hsc_env <- getHscEnv hsc_env <- getHscEnv
tcg_env <- tcRnModule' hsc_env mod_summary False hpm tcg_env <- tcRnModule' hsc_env mod_summary False hpm
......
...@@ -29,7 +29,7 @@ module HscTypes ( ...@@ -29,7 +29,7 @@ module HscTypes (
-- * Information about the module being compiled -- * Information about the module being compiled
-- (re-exported from DriverPhases) -- (re-exported from DriverPhases)
HscSource(..), isHsBootOrSig, hscSourceString, HscSource(..), isHsBoot, hscSourceString,
-- * State relating to modules in this package -- * State relating to modules in this package
...@@ -162,7 +162,7 @@ import PatSyn ...@@ -162,7 +162,7 @@ import PatSyn
import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule ) import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule )
import Packages hiding ( Version(..) ) import Packages hiding ( Version(..) )
import DynFlags import DynFlags
import DriverPhases ( Phase, HscSource(..), isHsBootOrSig, hscSourceString ) import DriverPhases ( Phase, HscSource(..), isHsBoot, hscSourceString )
import BasicTypes import BasicTypes
import IfaceSyn import IfaceSyn
import CoreSyn ( CoreRule, CoreVect ) import CoreSyn ( CoreRule, CoreVect )
...@@ -202,7 +202,7 @@ data HscStatus ...@@ -202,7 +202,7 @@ data HscStatus