module GhcMake(
depanal, depanalPartial,
load, load', LoadHowMuch(..),
downsweep,
topSortModuleGraph,
ms_home_srcimps, ms_home_imps,
IsBoot(..),
summariseModule,
hscSourceToIsBoot,
findExtraSigImports,
implicitRequirements,
noModError, cyclicModuleErr,
moduleGraphNodes, SummaryNode
) where
#include "HsVersions.h"
import GhcPrelude
import qualified Linker ( unload )
import DriverPhases
import DriverPipeline
import DynFlags
import ErrUtils
import Finder
import GhcMonad
import HeaderInfo
import HscTypes
import Module
import TcIface ( typecheckIface )
import TcRnMonad ( initIfaceCheck )
import HscMain
import Bag ( unitBag, listToBag, unionManyBags, isEmptyBag )
import BasicTypes
import Digraph
import Exception ( tryIO, gbracket, gfinally )
import FastString
import Maybes ( expectJust )
import Name
import MonadUtils ( allM, MonadIO )
import Outputable
import Panic
import SrcLoc
import StringBuffer
import UniqFM
import UniqDSet
import TcBackpack
import Packages
import UniqSet
import Util
import NameEnv
import FileCleanup
import qualified GHC.LanguageExtensions as LangExt
import Data.Either ( rights, partitionEithers )
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import qualified FiniteMap as Map ( insertListWith )
import Control.Concurrent ( forkIOWithUnmask, killThread )
import qualified GHC.Conc as CC
import Control.Concurrent.MVar
import Control.Concurrent.QSem
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
import Data.IORef
import Data.List
import qualified Data.List as List
import Data.Foldable (toList)
import Data.Maybe
import Data.Ord ( comparing )
import Data.Time
import System.Directory
import System.FilePath
import System.IO ( fixIO )
import System.IO.Error ( isDoesNotExistError )
import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
label_self :: String -> IO ()
label_self thread_name = do
self_tid <- CC.myThreadId
CC.labelThread self_tid thread_name
depanal :: GhcMonad m =>
[ModuleName]
-> Bool
-> m ModuleGraph
depanal excluded_mods allow_dup_roots = do
hsc_env <- getSession
(errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots
if isEmptyBag errs
then do
warnMissingHomeModules hsc_env mod_graph
setSession hsc_env { hsc_mod_graph = mod_graph }
return mod_graph
else throwErrors errs
depanalPartial
:: GhcMonad m
=> [ModuleName]
-> Bool
-> m (ErrorMessages, ModuleGraph)
depanalPartial excluded_mods allow_dup_roots = do
hsc_env <- getSession
let
dflags = hsc_dflags hsc_env
targets = hsc_targets hsc_env
old_graph = hsc_mod_graph hsc_env
withTiming (pure dflags) (text "Chasing dependencies") (const ()) $ do
liftIO $ debugTraceMsg dflags 2 (hcat [
text "Chasing modules from: ",
hcat (punctuate comma (map pprTarget targets))])
liftIO $ flushFinderCaches hsc_env
mod_summariesE <- liftIO $ downsweep hsc_env (mgModSummaries old_graph)
excluded_mods allow_dup_roots
let
(errs, mod_summaries) = partitionEithers mod_summariesE
mod_graph = mkModuleGraph mod_summaries
return (unionManyBags errs, mod_graph)
warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m ()
warnMissingHomeModules hsc_env mod_graph =
when (wopt Opt_WarnMissingHomeModules dflags && not (null missing)) $
logWarnings (listToBag [warn])
where
dflags = hsc_dflags hsc_env
targets = map targetId (hsc_targets hsc_env)
is_known_module mod = any (is_my_target mod) targets
is_my_target mod (TargetModule name)
= moduleName (ms_mod mod) == name
is_my_target mod (TargetFile target_file _)
| Just mod_file <- ml_hs_file (ms_location mod)
= target_file == mod_file ||
addBootSuffix target_file == mod_file ||
mkModuleName (fst $ splitExtension target_file)
== moduleName (ms_mod mod)
is_my_target _ _ = False
missing = map (moduleName . ms_mod) $
filter (not . is_known_module) (mgModSummaries mod_graph)
msg
| gopt Opt_BuildingCabalPackage dflags
= hang
(text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ")
4
(sep (map ppr missing))
| otherwise
=
hang
(text "Modules are not listed in command line but needed for compilation: ")
4
(sep (map ppr missing))
warn = makeIntoWarning
(Reason Opt_WarnMissingHomeModules)
(mkPlainErrMsg dflags noSrcSpan msg)
data LoadHowMuch
= LoadAllTargets
| LoadUpTo ModuleName
| LoadDependenciesOf ModuleName
load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
load how_much = do
mod_graph <- depanal [] False
load' how_much (Just batchMsg) mod_graph
load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' how_much mHscMessage mod_graph = do
modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }
guessOutputFile
hsc_env <- getSession
let hpt1 = hsc_HPT hsc_env
let dflags = hsc_dflags hsc_env
let all_home_mods =
mkUniqSet [ ms_mod_name s
| s <- mgModSummaries mod_graph, not (isBootSummary s)]
let checkHowMuch (LoadUpTo m) = checkMod m
checkHowMuch (LoadDependenciesOf m) = checkMod m
checkHowMuch _ = id
checkMod m and_then
| m `elementOfUniqSet` all_home_mods = and_then
| otherwise = do
liftIO $ errorMsg dflags (text "no such module:" <+>
quotes (ppr m))
return Failed
checkHowMuch how_much $ do
let mg2_with_srcimps :: [SCC ModSummary]
mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
warnUnnecessarySourceImports mg2_with_srcimps
let
stable_mods@(stable_obj,stable_bco)
= checkStability hpt1 mg2_with_srcimps all_home_mods
pruned_hpt = pruneHomePackageTable hpt1
(flattenSCCs mg2_with_srcimps)
stable_mods
_ <- liftIO $ evaluate pruned_hpt
setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt }
liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
text "Stable BCO:" <+> ppr stable_bco)
let stable_linkables = [ linkable
| m <- nonDetEltsUniqSet stable_obj ++
nonDetEltsUniqSet stable_bco,
Just hmi <- [lookupHpt pruned_hpt m],
Just linkable <- [hm_linkable hmi] ]
liftIO $ unload hsc_env stable_linkables
let full_mg :: [SCC ModSummary]
full_mg = topSortModuleGraph False mod_graph Nothing
maybe_top_mod = case how_much of
LoadUpTo m -> Just m
LoadDependenciesOf m -> Just m
_ -> Nothing
partial_mg0 :: [SCC ModSummary]
partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
partial_mg
| LoadDependenciesOf _mod <- how_much
= ASSERT( case last partial_mg0 of
AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
List.init partial_mg0
| otherwise
= partial_mg0
stable_mg =
[ AcyclicSCC ms
| AcyclicSCC ms <- full_mg,
stable_mod_summary ms ]
stable_mod_summary ms =
ms_mod_name ms `elementOfUniqSet` stable_obj ||
ms_mod_name ms `elementOfUniqSet` stable_bco
unstable_mg = filter not_stable partial_mg
where not_stable (CyclicSCC _) = True
not_stable (AcyclicSCC ms)
= not $ stable_mod_summary ms
mg = stable_mg ++ unstable_mg
let cleanup = cleanCurrentModuleTempFiles . hsc_dflags
liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
2 (ppr mg))
n_jobs <- case parMakeCount dflags of
Nothing -> liftIO getNumProcessors
Just n -> return n
let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs
| otherwise = upsweep
setSession hsc_env{ hsc_HPT = emptyHomePackageTable }
(upsweep_ok, modsUpswept)
<- upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg
let modsDone = reverse modsUpswept
if succeeded upsweep_ok
then
do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
hsc_env1 <- getSession
liftIO $ cleanCurrentModuleTempFiles dflags
let ofile = outputFile dflags
let no_hs_main = gopt Opt_NoHsMain dflags
let
main_mod = mainModIs dflags
a_root_is_Main = mgElemModule mod_graph main_mod
do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib
linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
if ghcLink dflags == LinkBinary && isJust ofile && not do_linking
then do
liftIO $ errorMsg dflags $ text
("output was redirected with -o, " ++
"but no output will be generated\n" ++
"because there is no " ++
moduleNameString (moduleName main_mod) ++ " module.")
loadFinish Failed linkresult
else
loadFinish Succeeded linkresult
else
do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
let modsDone_names
= map ms_mod modsDone
let mods_to_zap_names
= findPartiallyCompletedCycles modsDone_names
mg2_with_srcimps
let (mods_to_clean, mods_to_keep) =
partition ((`Set.member` mods_to_zap_names).ms_mod) modsDone
hsc_env1 <- getSession
let hpt4 = hsc_HPT hsc_env1
unneeded_temps = concat
[ms_hspp_file : object_files
| ModSummary{ms_mod, ms_hspp_file} <- mods_to_clean
, let object_files = maybe [] linkableObjs $
lookupHpt hpt4 (moduleName ms_mod)
>>= hm_linkable
]
liftIO $
changeTempFilesLifetime dflags TFL_CurrentModule unneeded_temps
liftIO $ cleanCurrentModuleTempFiles dflags
let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
hpt4
let just_linkables =
isNoLink (ghcLink dflags)
|| allHpt (isJust.hm_linkable)
(filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)
hpt5)
ASSERT( just_linkables ) do
linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt5
modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }
loadFinish Failed linkresult
loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag
loadFinish _all_ok Failed
= do hsc_env <- getSession
liftIO $ unload hsc_env []
modifySession discardProg
return Failed
loadFinish all_ok Succeeded
= do modifySession discardIC
return all_ok
discardProg :: HscEnv -> HscEnv
discardProg hsc_env
= discardIC $ hsc_env { hsc_mod_graph = emptyMG
, hsc_HPT = emptyHomePackageTable }
discardIC :: HscEnv -> HscEnv
discardIC hsc_env
= hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print
, ic_monad = new_ic_monad } }
where
!new_ic_int_print = keep_external_name ic_int_print
!new_ic_monad = keep_external_name ic_monad
dflags = ic_dflags old_ic
old_ic = hsc_IC hsc_env
empty_ic = emptyInteractiveContext dflags
keep_external_name ic_name
| nameIsFromExternalPackage this_pkg old_name = old_name
| otherwise = ic_name empty_ic
where
this_pkg = thisPackage dflags
old_name = ic_name old_ic
guessOutputFile :: GhcMonad m => m ()
guessOutputFile = modifySession $ \env ->
let dflags = hsc_dflags env
!mod_graph = hsc_mod_graph env
mainModuleSrcPath :: Maybe String
mainModuleSrcPath = do
ms <- mgLookupModule mod_graph (mainModIs dflags)
ml_hs_file (ms_location ms)
name = fmap dropExtension mainModuleSrcPath
name_exe = do
#if defined(mingw32_HOST_OS)
name' <- fmap (<.> "exe") name
#else
name' <- name
#endif
mainModuleSrcPath' <- mainModuleSrcPath
if name' == mainModuleSrcPath'
then throwGhcException . UsageError $
"default output name would overwrite the input file; " ++
"must specify -o explicitly"
else Just name'
in
case outputFile dflags of
Just _ -> env
Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
pruneHomePackageTable :: HomePackageTable
-> [ModSummary]
-> StableModules
-> HomePackageTable
pruneHomePackageTable hpt summ (stable_obj, stable_bco)
= mapHpt prune hpt
where prune hmi
| is_stable modl = hmi'
| otherwise = hmi'{ hm_details = emptyModDetails }
where
modl = moduleName (mi_module (hm_iface hmi))
hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
= hmi{ hm_linkable = Nothing }
| otherwise
= hmi
where ms = expectJust "prune" (lookupUFM ms_map modl)
ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
is_stable m =
m `elementOfUniqSet` stable_obj ||
m `elementOfUniqSet` stable_bco
findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module
findPartiallyCompletedCycles modsDone theGraph
= Set.unions
[mods_in_this_cycle
| CyclicSCC vs <- theGraph
, let names_in_this_cycle = Set.fromList (map ms_mod vs)
mods_in_this_cycle =
Set.intersection (Set.fromList modsDone) names_in_this_cycle
, Set.size mods_in_this_cycle < Set.size names_in_this_cycle]
unload :: HscEnv -> [Linkable] -> IO ()
unload hsc_env stable_linkables
= case ghcLink (hsc_dflags hsc_env) of
LinkInMemory -> Linker.unload hsc_env stable_linkables
_other -> return ()
type StableModules =
( UniqSet ModuleName
, UniqSet ModuleName
)
checkStability
:: HomePackageTable
-> [SCC ModSummary]
-> UniqSet ModuleName
-> StableModules
checkStability hpt sccs all_home_mods =
foldl' checkSCC (emptyUniqSet, emptyUniqSet) sccs
where
checkSCC :: StableModules -> SCC ModSummary -> StableModules
checkSCC (stable_obj, stable_bco) scc0
| stableObjects = (addListToUniqSet stable_obj scc_mods, stable_bco)
| stableBCOs = (stable_obj, addListToUniqSet stable_bco scc_mods)
| otherwise = (stable_obj, stable_bco)
where
scc = flattenSCC scc0
scc_mods = map ms_mod_name scc
home_module m =
m `elementOfUniqSet` all_home_mods && m `notElem` scc_mods
scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))
stable_obj_imps = map (`elementOfUniqSet` stable_obj) scc_allimps
stable_bco_imps = map (`elementOfUniqSet` stable_bco) scc_allimps
stableObjects =
and stable_obj_imps
&& all object_ok scc
stableBCOs =
and (zipWith (||) stable_obj_imps stable_bco_imps)
&& all bco_ok scc
object_ok ms
| gopt Opt_ForceRecomp (ms_hspp_opts ms) = False
| Just t <- ms_obj_date ms = t >= ms_hs_date ms
&& same_as_prev t
| otherwise = False
where
same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of
Just hmi | Just l <- hm_linkable hmi
-> isObjectLinkable l && t == linkableTime l
_other -> True
bco_ok ms
| gopt Opt_ForceRecomp (ms_hspp_opts ms) = False
| otherwise = case lookupHpt hpt (ms_mod_name ms) of
Just hmi | Just l <- hm_linkable hmi ->
not (isObjectLinkable l) &&
linkableTime l >= ms_hs_date ms
_other -> False
data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, MsgDoc)])
!(MVar ())
type CompilationGraph = [(ModSummary, MVar SuccessFlag, LogQueue)]
buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary])
buildCompGraph [] = return ([], Nothing)
buildCompGraph (scc:sccs) = case scc of
AcyclicSCC ms -> do
mvar <- newEmptyMVar
log_queue <- do
ref <- newIORef []
sem <- newEmptyMVar
return (LogQueue ref sem)
(rest,cycle) <- buildCompGraph sccs
return ((ms,mvar,log_queue):rest, cycle)
CyclicSCC mss -> return ([], Just mss)
type BuildModule = (Module, IsBoot)
data IsBoot = IsBoot | NotBoot
deriving (Ord, Eq, Show, Read)
hscSourceToIsBoot :: HscSource -> IsBoot
hscSourceToIsBoot HsBootFile = IsBoot
hscSourceToIsBoot _ = NotBoot
mkBuildModule :: ModSummary -> BuildModule
mkBuildModule ms = (ms_mod ms, if isBootSummary ms then IsBoot else NotBoot)
parUpsweep
:: GhcMonad m
=> Int
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag,
[ModSummary])
parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
hsc_env <- getSession
let dflags = hsc_dflags hsc_env
when (not (null (unitIdsToCheck dflags))) $
throwGhcException (ProgramError "Backpack typechecking not supported with -j")
hsc_env_var <- liftIO $ newMVar hsc_env
old_hpt_var <- liftIO $ newIORef old_hpt
par_sem <- liftIO $ newQSem n_jobs
let updNumCapabilities = liftIO $ do
n_capabilities <- getNumCapabilities
n_cpus <- getNumProcessors
let n_caps = min n_jobs n_cpus
unless (n_capabilities /= 1) $ setNumCapabilities n_caps
return n_capabilities
let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n
gbracket updNumCapabilities resetNumCapabilities $ \_ -> do
let finallySyncSession io = io `gfinally` do
hsc_env <- liftIO $ readMVar hsc_env_var
setSession hsc_env
finallySyncSession $ do
(comp_graph,cycle) <- liftIO $ buildCompGraph sccs
let comp_graph_w_idx = zip comp_graph [1..]
let graph = map fstOf3 (reverse comp_graph)
boot_modules = mkModuleSet [ms_mod ms | ms <- graph, isBootSummary ms]
comp_graph_loops = go graph boot_modules
where
remove ms bm
| isBootSummary ms = delModuleSet bm (ms_mod ms)
| otherwise = bm
go [] _ = []
go mg@(ms:mss) boot_modules
| Just loop <- getModLoop ms mg (`elemModuleSet` boot_modules)
= map mkBuildModule (ms:loop) : go mss (remove ms boot_modules)
| otherwise
= go mss (remove ms boot_modules)
let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)
home_mod_map =
Map.fromList [ (mkBuildModule ms, (mvar, idx))
| ((ms,mvar,_),idx) <- comp_graph_w_idx ]
liftIO $ label_self "main --make thread"
let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) ->
forkIOWithUnmask $ \unmask -> do
liftIO $ label_self $ unwords
[ "worker --make thread"
, "for module"
, show (moduleNameString (ms_mod_name mod))
, "number"
, show mod_idx
]
lcl_files_to_clean <- newIORef emptyFilesToClean
let lcl_dflags = dflags { log_action = parLogAction log_queue
, filesToClean = lcl_files_to_clean }
m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $
parUpsweep_one mod home_mod_map comp_graph_loops
lcl_dflags mHscMessage cleanup
par_sem hsc_env_var old_hpt_var
stable_mods mod_idx (length sccs)
res <- case m_res of
Right flag -> return flag
Left exc -> do
when (fromException exc /= Just ThreadKilled)
(errorMsg lcl_dflags (text (show exc)))
return Failed
putMVar mvar res
writeLogQueue log_queue Nothing
FilesToClean
{ ftcCurrentModule = cm_files
, ftcGhcSession = gs_files
} <- readIORef (filesToClean lcl_dflags)
addFilesToClean dflags TFL_CurrentModule $ Set.toList cm_files
addFilesToClean dflags TFL_GhcSession $ Set.toList gs_files
; killWorkers = uninterruptibleMask_ . mapM_ killThread }
results <- liftIO $ bracket spawnWorkers killWorkers $ \_ ->
forM comp_graph $ \(mod,mvar,log_queue) -> do
printLogs dflags log_queue
result <- readMVar mvar
if succeeded result then return (Just mod) else return Nothing
let ok_results = reverse (catMaybes results)
case cycle of
Just mss -> do
liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss)
return (Failed,ok_results)
Nothing -> do
let success_flag = successIf (all isJust results)
return (success_flag,ok_results)
where
writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO ()
writeLogQueue (LogQueue ref sem) msg = do
atomicModifyIORef' ref $ \msgs -> (msg:msgs,())
_ <- tryPutMVar sem ()
return ()
parLogAction :: LogQueue -> LogAction
parLogAction log_queue _dflags !reason !severity !srcSpan !style !msg = do
writeLogQueue log_queue (Just (reason,severity,srcSpan,style,msg))
printLogs :: DynFlags -> LogQueue -> IO ()
printLogs !dflags (LogQueue ref sem) = read_msgs
where read_msgs = do
takeMVar sem
msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)
print_loop msgs
print_loop [] = read_msgs
print_loop (x:xs) = case x of
Just (reason,severity,srcSpan,style,msg) -> do
putLogMsg dflags reason severity srcSpan style msg
print_loop xs
Nothing -> return ()
parUpsweep_one
:: ModSummary
-> Map BuildModule (MVar SuccessFlag, Int)
-> [[BuildModule]]
-> DynFlags
-> Maybe Messager
-> (HscEnv -> IO ())
-> QSem
-> MVar HscEnv
-> IORef HomePackageTable
-> StableModules
-> Int
-> Int
-> IO SuccessFlag
parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem
hsc_env_var old_hpt_var stable_mods mod_index num_mods = do
let this_build_mod = mkBuildModule mod
let home_imps = map unLoc $ ms_home_imps mod
let home_src_imps = map unLoc $ ms_home_srcimps mod
let textual_deps = Set.fromList $ mapFst (mkModule (thisPackage lcl_dflags)) $
zip home_imps (repeat NotBoot) ++
zip home_src_imps (repeat IsBoot)
let finish_loop = listToMaybe
[ tail loop | loop <- comp_graph_loops
, head loop == this_build_mod ]
let int_loop_deps = Set.fromList $
case finish_loop of
Nothing -> []
Just loop -> filter (/= this_build_mod) loop
let ext_loop_deps = Set.fromList
[ head loop | loop <- comp_graph_loops
, any (`Set.member` textual_deps) loop
, this_build_mod `notElem` loop ]
let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps]
let home_deps_with_idx =
[ home_dep | dep <- Set.toList all_deps
, Just home_dep <- [Map.lookup dep home_mod_map] ]
let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx
deps_ok <- allM (fmap succeeded . readMVar) home_deps
if not deps_ok
then return Failed
else do
hsc_env <- readMVar hsc_env_var
old_hpt <- readIORef old_hpt_var
let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err)
let withSem sem = bracket_ (waitQSem sem) (signalQSem sem)
mb_mod_info <- withSem par_sem $
handleSourceError (\err -> do logger err; return Nothing) $ do
let lcl_mod = localize_mod mod
let lcl_hsc_env = localize_hsc_env hsc_env
type_env_var <- liftIO $ newIORef emptyNameEnv
let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var =
Just (ms_mod lcl_mod, type_env_var) }
lcl_hsc_env'' <- case finish_loop of
Nothing -> return lcl_hsc_env'
Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $
filter (/= moduleName (fst this_build_mod)) $
map (moduleName . fst) loop
mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods
lcl_mod mod_index num_mods
return (Just mod_info)
case mb_mod_info of
Nothing -> return Failed
Just mod_info -> do
let this_mod = ms_mod_name mod
unless (isBootSummary mod) $
atomicModifyIORef' old_hpt_var $ \old_hpt ->
(delFromHpt old_hpt this_mod, ())
lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do
let hsc_env' = hsc_env
{ hsc_HPT = addToHpt (hsc_HPT hsc_env)
this_mod mod_info }
hsc_env'' <- case finish_loop of
Nothing -> return hsc_env'
Just loop -> typecheckLoop lcl_dflags hsc_env' $
map (moduleName . fst) loop
return (hsc_env'', localize_hsc_env hsc_env'')
cleanup lcl_hsc_env'
return Succeeded
where
localize_mod mod
= mod { ms_hspp_opts = (ms_hspp_opts mod)
{ log_action = log_action lcl_dflags
, filesToClean = filesToClean lcl_dflags } }
localize_hsc_env hsc_env
= hsc_env { hsc_dflags = (hsc_dflags hsc_env)
{ log_action = log_action lcl_dflags
, filesToClean = filesToClean lcl_dflags } }
upsweep
:: GhcMonad m
=> Maybe Messager
-> HomePackageTable
-> StableModules
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag,
[ModSummary])
upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
dflags <- getSessionDynFlags
(res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs)
(unitIdsToCheck dflags) done_holes
return (res, reverse $ mgModSummaries done)
where
done_holes = emptyUniqSet
upsweep'
:: GhcMonad m
=> HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
upsweep' _old_hpt done
[] _ _ uids_to_check _
= do hsc_env <- getSession
liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) uids_to_check
return (Succeeded, done)
upsweep' _old_hpt done
(CyclicSCC ms:_) _ _ _ _
= do dflags <- getSessionDynFlags
liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
return (Failed, done)
upsweep' old_hpt done
(AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes
= do
let logger _mod = defaultWarnErrLogger
hsc_env <- getSession
let (ready_uids, uids_to_check')
= partition (\uid -> isEmptyUniqDSet
(unitIdFreeHoles uid `uniqDSetMinusUniqSet` done_holes))
uids_to_check
done_holes'
| ms_hsc_src mod == HsigFile
= addOneToUniqSet done_holes (ms_mod_name mod)
| otherwise = done_holes
liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) ready_uids
liftIO (cleanup hsc_env)
type_env_var <- liftIO $ newIORef emptyNameEnv
let hsc_env1 = hsc_env { hsc_type_env_var =
Just (ms_mod mod, type_env_var) }
setSession hsc_env1
hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done
setSession hsc_env2
mb_mod_info
<- handleSourceError
(\err -> do logger mod (Just err); return Nothing) $ do
mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods
mod mod_index nmods
logger mod Nothing
return (Just mod_info)
case mb_mod_info of
Nothing -> return (Failed, done)
Just mod_info -> do
let this_mod = ms_mod_name mod
hpt1 = addToHpt (hsc_HPT hsc_env2) this_mod mod_info
hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing }
old_hpt1 | isBootSummary mod = old_hpt
| otherwise = delFromHpt old_hpt this_mod
done' = extendMG done mod
hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done'
setSession hsc_env4
when (hscTarget (hsc_dflags hsc_env4) == HscInterpreted) $
liftIO $ hscAddSptEntries hsc_env4
[ spt
| Just linkable <- pure $ hm_linkable mod_info
, unlinked <- linkableUnlinked linkable
, BCOs _ spts <- pure unlinked
, spt <- spts
]
upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes'
unitIdsToCheck :: DynFlags -> [UnitId]
unitIdsToCheck dflags =
nubSort $ concatMap goUnitId (explicitPackages (pkgState dflags))
where
goUnitId uid =
case splitUnitIdInsts uid of
(_, Just indef) ->
let insts = indefUnitIdInsts indef
in uid : concatMap (goUnitId . moduleUnitId . snd) insts
_ -> []
maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate dflags location
| writeInterfaceOnlyMode dflags
= modificationTimeIfExists (ml_hi_file location)
| otherwise
= return Nothing
upsweep_mod :: HscEnv
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods
= let
this_mod_name = ms_mod_name summary
this_mod = ms_mod summary
mb_obj_date = ms_obj_date summary
mb_if_date = ms_iface_date summary
obj_fn = ml_obj_file (ms_location summary)
hs_date = ms_hs_date summary
is_stable_obj = this_mod_name `elementOfUniqSet` stable_obj
is_stable_bco = this_mod_name `elementOfUniqSet` stable_bco
old_hmi = lookupHpt old_hpt this_mod_name
dflags = ms_hspp_opts summary
prevailing_target = hscTarget (hsc_dflags hsc_env)
local_target = hscTarget dflags
target = if prevailing_target /= local_target
&& (not (isObjectTarget prevailing_target)
|| not (isObjectTarget local_target))
&& not (prevailing_target == HscNothing)
&& not (prevailing_target == HscInterpreted)
then prevailing_target
else local_target
summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
mb_old_iface
= case old_hmi of
Nothing -> Nothing
Just hm_info | isBootSummary summary -> Just iface
| not (mi_boot iface) -> Just iface
| otherwise -> Nothing
where
iface = hm_iface hm_info
compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it mb_linkable src_modified =
compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods
mb_old_iface mb_linkable src_modified
compile_it_discard_iface :: Maybe Linkable -> SourceModified
-> IO HomeModInfo
compile_it_discard_iface mb_linkable src_modified =
compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods
Nothing mb_linkable src_modified
is_fake_linkable
| Just hmi <- old_hmi, Just l <- hm_linkable hmi =
null (linkableUnlinked l)
| otherwise =
False
implies False _ = True
implies True x = x
in
case () of
_
| is_stable_obj, Just hmi <- old_hmi -> do
liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
(text "skipping stable obj mod:" <+> ppr this_mod_name)
return hmi
| is_stable_obj, isNothing old_hmi -> do
liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
(text "compiling stable on-disk mod:" <+> ppr this_mod_name)
linkable <- liftIO $ findObjectLinkable this_mod obj_fn
(expectJust "upsweep1" mb_obj_date)
compile_it (Just linkable) SourceUnmodifiedAndStable
| not (isObjectTarget target), is_stable_bco,
(target /= HscNothing) `implies` not is_fake_linkable ->
ASSERT(isJust old_hmi)
let Just hmi = old_hmi in do
liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
(text "skipping stable BCO mod:" <+> ppr this_mod_name)
return hmi
| not (isObjectTarget target),
Just hmi <- old_hmi,
Just l <- hm_linkable hmi,
not (isObjectLinkable l),
(target /= HscNothing) `implies` not is_fake_linkable,
linkableTime l >= ms_hs_date summary -> do
liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
(text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
compile_it (Just l) SourceUnmodified
| isObjectTarget target,
Just obj_date <- mb_obj_date,
obj_date >= hs_date -> do
case old_hmi of
Just hmi
| Just l <- hm_linkable hmi,
isObjectLinkable l && linkableTime l == obj_date -> do
liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
(text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
compile_it (Just l) SourceUnmodified
_otherwise -> do
liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
(text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
compile_it_discard_iface (Just linkable) SourceUnmodified
| writeInterfaceOnlyMode dflags,
Just if_date <- mb_if_date,
if_date >= hs_date -> do
liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
(text "skipping tc'd mod:" <+> ppr this_mod_name)
compile_it Nothing SourceUnmodified
_otherwise -> do
liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
(text "compiling mod:" <+> ppr this_mod_name)
compile_it Nothing SourceModified
retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs keep_these hpt
= listToHpt [ (mod, expectJust "retain" mb_mod_info)
| mod <- keep_these
, let mb_mod_info = lookupHpt hpt mod
, isJust mb_mod_info ]
reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop hsc_env ms graph
| Just loop <- getModLoop ms mss appearsAsBoot
, let non_boot = filter (\l -> not (isBootSummary l &&
ms_mod l == ms_mod ms)) loop
= typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot)
| otherwise
= return hsc_env
where
mss = mgModSummaries graph
appearsAsBoot = (`elemModuleSet` mgBootModules graph)
getModLoop
:: ModSummary
-> [ModSummary]
-> (Module -> Bool)
-> Maybe [ModSummary]
getModLoop ms graph appearsAsBoot
| not (isBootSummary ms)
, appearsAsBoot this_mod
, let mss = reachableBackwards (ms_mod_name ms) graph
= Just mss
| otherwise
= Nothing
where
this_mod = ms_mod ms
typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop dflags hsc_env mods = do
debugTraceMsg dflags 2 $
text "Re-typechecking loop: " <> ppr mods
new_hpt <-
fixIO $ \new_hpt -> do
let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $
mapM (typecheckIface . hm_iface) hmis
let new_hpt = addListToHpt old_hpt
(zip mods [ hmi{ hm_details = details }
| (hmi,details) <- zip hmis mds ])
return new_hpt
return hsc_env{ hsc_HPT = new_hpt }
where
old_hpt = hsc_HPT hsc_env
hmis = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods
reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
reachableBackwards mod summaries
= [ node_payload node | node <- reachableG (transposeG graph) root ]
where
(graph, lookup_node) = moduleGraphNodes False summaries
root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
topSortModuleGraph
:: Bool
-> ModuleGraph
-> Maybe ModuleName
-> [SCC ModSummary]
topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod
= map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
where
summaries = mgModSummaries module_graph
(graph, lookup_node) =
moduleGraphNodes drop_hs_boot_nodes (reverse summaries)
initial_graph = case mb_root_mod of
Nothing -> graph
Just root_mod ->
let root | Just node <- lookup_node HsSrcFile root_mod
, graph `hasVertexG` node
= node
| otherwise
= throwGhcException (ProgramError "module does not exist")
in graphFromEdgedVerticesUniq (seq root (reachableG graph root))
type SummaryNode = Node Int ModSummary
summaryNodeKey :: SummaryNode -> Int
summaryNodeKey = node_key
summaryNodeSummary :: SummaryNode -> ModSummary
summaryNodeSummary = node_payload
moduleGraphNodes :: Bool -> [ModSummary]
-> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
moduleGraphNodes drop_hs_boot_nodes summaries =
(graphFromEdgedVerticesUniq 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_key :: HscSource -> ModuleName -> Maybe Int
lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
node_map :: NodeMap SummaryNode
node_map = Map.fromList [ ((moduleName (ms_mod s),
hscSourceToIsBoot (ms_hsc_src s)), node)
| node <- nodes
, let s = summaryNodeSummary node ]
nodes :: [SummaryNode]
nodes = [ DigraphNode s key out_keys
| (s, key) <- numbered_summaries
, 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)) ++
(
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]) ]
hs_boot_key | drop_hs_boot_nodes = HsSrcFile
| otherwise = HsBootFile
out_edge_keys :: HscSource -> [ModuleName] -> [Int]
out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms
type NodeKey = (ModuleName, IsBoot)
type NodeMap a = Map.Map NodeKey a
msKey :: ModSummary -> NodeKey
msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot })
= (moduleName mod, hscSourceToIsBoot boot)
mkNodeMap :: [ModSummary] -> NodeMap ModSummary
mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]
nodeMapElts :: NodeMap a -> [a]
nodeMapElts = Map.elems
warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports sccs = do
dflags <- getDynFlags
when (wopt Opt_WarnUnusedImports dflags)
(logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs)))
where check dflags ms =
let mods_in_this_cycle = map ms_mod_name ms in
[ warn dflags i | m <- ms, i <- ms_home_srcimps m,
unLoc i `notElem` mods_in_this_cycle ]
warn :: DynFlags -> Located ModuleName -> WarnMsg
warn dflags (L loc mod) =
mkPlainErrMsg dflags loc
(text "Warning: {-# SOURCE #-} unnecessary in import of "
<+> quotes (ppr mod))
reportImportErrors :: MonadIO m => [Either ErrorMessages b] -> m [b]
reportImportErrors xs | null errs = return oks
| otherwise = throwErrors $ unionManyBags errs
where (errs, oks) = partitionEithers xs
downsweep :: HscEnv
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO [Either ErrorMessages ModSummary]
downsweep hsc_env old_summaries excl_mods allow_dup_roots
= do
rootSummaries <- mapM getRootSummary roots
rootSummariesOk <- reportImportErrors rootSummaries
let root_map = mkRootMap rootSummariesOk
checkDuplicates root_map
map0 <- loop (concatMap calcDeps rootSummariesOk) root_map
map1 <- if hscTarget dflags == HscNothing
then enableCodeGenForTH
(defaultObjectTarget (targetPlatform dflags))
map0
else if hscTarget dflags == HscInterpreted
then enableCodeGenForUnboxedTuples
(defaultObjectTarget (targetPlatform dflags))
map0
else return map0
return $ concat $ nodeMapElts map1
where
calcDeps = msDeps
dflags = hsc_dflags hsc_env
roots = hsc_targets hsc_env
old_summary_map :: NodeMap ModSummary
old_summary_map = mkNodeMap old_summaries
getRootSummary :: Target -> IO (Either ErrorMessages ModSummary)
getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
= do exists <- liftIO $ doesFileExist file
if exists || isJust maybe_buf
then summariseFile hsc_env old_summaries file mb_phase
obj_allowed maybe_buf
else return $ Left $ unitBag $ mkPlainErrMsg dflags noSrcSpan $
text "can't find file:" <+> text file
getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
= do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot
(L rootLoc modl) obj_allowed
maybe_buf excl_mods
case maybe_summary of
Nothing -> return $ Left $ moduleNotFoundErr dflags modl
Just s -> return s
rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
checkDuplicates :: NodeMap [Either ErrorMessages ModSummary] -> IO ()
checkDuplicates root_map
| allow_dup_roots = return ()
| null dup_roots = return ()
| otherwise = liftIO $ multiRootsErr dflags (head dup_roots)
where
dup_roots :: [[ModSummary]]
dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map
loop :: [(Located ModuleName,IsBoot)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop [] done = return done
loop ((wanted_mod, is_boot) : ss) done
| Just summs <- Map.lookup key done
= if isSingleton summs then
loop ss done
else
do { multiRootsErr dflags (rights summs); return Map.empty }
| otherwise
= do mb_s <- summariseModule hsc_env old_summary_map
is_boot wanted_mod True
Nothing excl_mods
case mb_s of
Nothing -> loop ss done
Just (Left e) -> loop ss (Map.insert key [Left e] done)
Just (Right s)-> do
new_map <-
loop (calcDeps s) (Map.insert key [Right s] done)
loop ss new_map
where
key = (unLoc wanted_mod, is_boot)
enableCodeGenForTH :: HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForTH =
enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession
where
condition = isTemplateHaskellOrQQNonBoot
should_modify (ModSummary { ms_hspp_opts = dflags }) =
hscTarget dflags == HscNothing &&
not (isIndefinite dflags)
enableCodeGenForUnboxedTuples :: HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForUnboxedTuples =
enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule
where
condition ms =
False &&
xopt LangExt.UnboxedTuples (ms_hspp_opts ms) &&
not (isBootSummary ms)
should_modify (ModSummary { ms_hspp_opts = dflags }) =
hscTarget dflags == HscInterpreted
enableCodeGenWhen
:: (ModSummary -> Bool)
-> (ModSummary -> Bool)
-> TempFileLifetime
-> TempFileLifetime
-> HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenWhen condition should_modify staticLife dynLife target nodemap =
traverse (traverse (traverse enable_code_gen)) nodemap
where
enable_code_gen ms
| ModSummary
{ ms_mod = ms_mod
, ms_location = ms_location
, ms_hsc_src = HsSrcFile
, ms_hspp_opts = dflags
} <- ms
, should_modify ms
, ms_mod `Set.member` needs_codegen_set
= do
let new_temp_file suf dynsuf = do
tn <- newTempName dflags staticLife suf
let dyn_tn = tn -<.> dynsuf
addFilesToClean dflags dynLife [dyn_tn]
return tn
hi_file <-
if gopt Opt_WriteInterface dflags
then return $ ml_hi_file ms_location
else new_temp_file (hiSuf dflags) (dynHiSuf dflags)
o_temp_file <- new_temp_file (objectSuf dflags) (dynObjectSuf dflags)
return $
ms
{ ms_location =
ms_location {ml_hi_file = hi_file, ml_obj_file = o_temp_file}
, ms_hspp_opts = updOptLevel 0 $ dflags {hscTarget = target}
}
| otherwise = return ms
needs_codegen_set = transitive_deps_set
[ ms
| mss <- Map.elems nodemap
, Right ms <- mss
, condition ms
]
transitive_deps_set modSums = foldl' go Set.empty modSums
where
go marked_mods ms@ModSummary{ms_mod}
| ms_mod `Set.member` marked_mods = marked_mods
| otherwise =
let deps =
[ dep_ms
| (L _ mn, NotBoot) <- msDeps ms
, dep_ms <-
toList (Map.lookup (mn, NotBoot) nodemap) >>= toList >>=
toList
]
new_marked_mods = Set.insert ms_mod marked_mods
in foldl' go new_marked_mods deps
mkRootMap :: [ModSummary] -> NodeMap [Either ErrorMessages ModSummary]
mkRootMap summaries = Map.insertListWith (flip (++))
[ (msKey s, [Right s]) | s <- summaries ]
Map.empty
msDeps :: ModSummary -> [(Located ModuleName, IsBoot)]
msDeps s =
concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ]
++ [ (m,NotBoot) | m <- ms_home_imps s ]
home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps,
isLocal mb_pkg ]
where isLocal Nothing = True
isLocal (Just pkg) | pkg == fsLit "this" = True
isLocal _ = False
ms_home_allimps :: ModSummary -> [ModuleName]
ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
ms_home_srcimps :: ModSummary -> [Located ModuleName]
ms_home_srcimps = home_imps . ms_srcimps
ms_home_imps :: ModSummary -> [Located ModuleName]
ms_home_imps = home_imps . ms_imps
summariseFile
:: HscEnv
-> [ModSummary]
-> FilePath
-> Maybe Phase
-> Bool
-> Maybe (StringBuffer,UTCTime)
-> IO (Either ErrorMessages ModSummary)
summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf
| Just old_summary <- findSummaryBySourceFile old_summaries src_fn
= do
let location = ms_location old_summary
dflags = hsc_dflags hsc_env
src_timestamp <- get_src_timestamp
checkSummaryTimestamp
hsc_env dflags obj_allowed NotBoot (new_summary src_fn)
old_summary location src_timestamp
| otherwise
= do src_timestamp <- get_src_timestamp
new_summary src_fn src_timestamp
where
get_src_timestamp = case maybe_buf of
Just (_,t) -> return t
Nothing -> liftIO $ getModificationUTCTime src_fn
new_summary src_fn src_timestamp = runExceptT $ do
preimps@PreprocessedImports {..}
<- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf
location <- liftIO $ mkHomeModLocation (hsc_dflags hsc_env) pi_mod_name src_fn
mod <- liftIO $ addHomeModuleToFinder hsc_env pi_mod_name location
liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
{ nms_src_fn = src_fn
, nms_src_timestamp = src_timestamp
, nms_is_boot = NotBoot
, nms_hsc_src =
if isHaskellSigFilename src_fn
then HsigFile
else HsSrcFile
, nms_location = location
, nms_mod = mod
, nms_obj_allowed = obj_allowed
, nms_preimps = preimps
}
findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
findSummaryBySourceFile summaries file
= case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
[] -> Nothing
(x:_) -> Just x
checkSummaryTimestamp
:: HscEnv -> DynFlags -> Bool -> IsBoot
-> (UTCTime -> IO (Either e ModSummary))
-> ModSummary -> ModLocation -> UTCTime
-> IO (Either e ModSummary)
checkSummaryTimestamp
hsc_env dflags obj_allowed is_boot new_summary
old_summary location src_timestamp
| ms_hs_date old_summary == src_timestamp &&
not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do
obj_timestamp <-
if isObjectTarget (hscTarget (hsc_dflags hsc_env))
|| obj_allowed
then liftIO $ getObjTimestamp location is_boot
else return Nothing
_ <- addHomeModuleToFinder hsc_env
(moduleName (ms_mod old_summary)) location
hi_timestamp <- maybeGetIfaceDate dflags location
hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
return $ Right old_summary
{ ms_obj_date = obj_timestamp
, ms_iface_date = hi_timestamp
, ms_hie_date = hie_timestamp
}
| otherwise =
new_summary src_timestamp
summariseModule
:: HscEnv
-> NodeMap ModSummary
-> IsBoot
-> Located ModuleName
-> Bool
-> Maybe (StringBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ModSummary))
summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
obj_allowed maybe_buf excl_mods
| wanted_mod `elem` excl_mods
= return Nothing
| Just old_summary <- Map.lookup (wanted_mod, is_boot) old_summary_map
= do
let location = ms_location old_summary
src_fn = expectJust "summariseModule" (ml_hs_file location)
case maybe_buf of
Just (_,t) ->
Just <$> check_timestamp old_summary location src_fn t
Nothing -> do
m <- tryIO (getModificationUTCTime src_fn)
case m of
Right t ->
Just <$> check_timestamp old_summary location src_fn t
Left e | isDoesNotExistError e -> find_it
| otherwise -> ioError e
| otherwise = find_it
where
dflags = hsc_dflags hsc_env
check_timestamp old_summary location src_fn =
checkSummaryTimestamp
hsc_env dflags obj_allowed is_boot
(new_summary location (ms_mod old_summary) src_fn)
old_summary location
find_it = do
found <- findImportedModule hsc_env wanted_mod Nothing
case found of
Found location mod
| isJust (ml_hs_file location) ->
Just <$> just_found location mod
_ -> return Nothing
just_found location mod = do
let location' | IsBoot <- is_boot = addBootSuffixLocn location
| otherwise = location
src_fn = expectJust "summarise2" (ml_hs_file location')
maybe_t <- modificationTimeIfExists src_fn
case maybe_t of
Nothing -> return $ Left $ noHsFileErr dflags loc src_fn
Just t -> new_summary location' mod src_fn t
new_summary location mod src_fn src_timestamp
= runExceptT $ do
preimps@PreprocessedImports {..}
<- getPreprocessedImports hsc_env src_fn Nothing maybe_buf
let hsc_src = case is_boot of
IsBoot -> HsBootFile
_ | isHaskellSigFilename src_fn -> HsigFile
| otherwise -> HsSrcFile
when (pi_mod_name /= wanted_mod) $
throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $
text "File name does not match module name:"
$$ text "Saw:" <+> quotes (ppr pi_mod_name)
$$ text "Expected:" <+> quotes (ppr wanted_mod)
when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (thisUnitIdInsts dflags))) $
let suggested_instantiated_with =
hcat (punctuate comma $
[ ppr k <> text "=" <> ppr v
| (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name)
: thisUnitIdInsts dflags)
])
in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $
text "Unexpected signature:" <+> quotes (ppr pi_mod_name)
$$ if gopt Opt_BuildingCabalPackage dflags
then parens (text "Try adding" <+> quotes (ppr pi_mod_name)
<+> text "to the"
<+> quotes (text "signatures")
<+> text "field in your Cabal file.")
else parens (text "Try passing -instantiated-with=\"" <>
suggested_instantiated_with <> text "\"" $$
text "replacing <" <> ppr pi_mod_name <> text "> as necessary.")
liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
{ nms_src_fn = src_fn
, nms_src_timestamp = src_timestamp
, nms_is_boot = is_boot
, nms_hsc_src = hsc_src
, nms_location = location
, nms_mod = mod
, nms_obj_allowed = obj_allowed
, nms_preimps = preimps
}
data MakeNewModSummary
= MakeNewModSummary
{ nms_src_fn :: FilePath
, nms_src_timestamp :: UTCTime
, nms_is_boot :: IsBoot
, nms_hsc_src :: HscSource
, nms_location :: ModLocation
, nms_mod :: Module
, nms_obj_allowed :: Bool
, nms_preimps :: PreprocessedImports
}
makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary hsc_env MakeNewModSummary{..} = do
let PreprocessedImports{..} = nms_preimps
let dflags = hsc_dflags hsc_env
obj_timestamp <- liftIO $
if isObjectTarget (hscTarget dflags)
|| nms_obj_allowed
then getObjTimestamp nms_location nms_is_boot
else return Nothing
hi_timestamp <- maybeGetIfaceDate dflags nms_location
hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)
extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name
required_by_imports <- implicitRequirements hsc_env pi_theimps
return $ ModSummary
{ ms_mod = nms_mod
, ms_hsc_src = nms_hsc_src
, ms_location = nms_location
, ms_hspp_file = pi_hspp_fn
, ms_hspp_opts = pi_local_dflags
, ms_hspp_buf = Just pi_hspp_buf
, ms_parsed_mod = Nothing
, ms_srcimps = pi_srcimps
, ms_textual_imps =
pi_theimps ++ extra_sig_imports ++ required_by_imports
, ms_hs_date = nms_src_timestamp
, ms_iface_date = hi_timestamp
, ms_hie_date = hie_timestamp
, ms_obj_date = obj_timestamp
}
getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime)
getObjTimestamp location is_boot
= if is_boot == IsBoot then return Nothing
else modificationTimeIfExists (ml_obj_file location)
data PreprocessedImports
= PreprocessedImports
{ pi_local_dflags :: DynFlags
, pi_srcimps :: [(Maybe FastString, Located ModuleName)]
, pi_theimps :: [(Maybe FastString, Located ModuleName)]
, pi_hspp_fn :: FilePath
, pi_hspp_buf :: StringBuffer
, pi_mod_name_loc :: SrcSpan
, pi_mod_name :: ModuleName
}
getPreprocessedImports
:: HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (StringBuffer, UTCTime)
-> ExceptT ErrorMessages IO PreprocessedImports
getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
(pi_local_dflags, pi_hspp_fn)
<- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase
pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn
(pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name)
<- ExceptT $ getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn
return PreprocessedImports {..}
noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg
noModError dflags loc wanted_mod err
= mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err
noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrorMessages
noHsFileErr dflags loc path
= unitBag $ mkPlainErrMsg dflags loc $ text "Can't find" <+> text path
moduleNotFoundErr :: DynFlags -> ModuleName -> ErrorMessages
moduleNotFoundErr dflags mod
= unitBag $ mkPlainErrMsg dflags noSrcSpan $
text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"
multiRootsErr :: DynFlags -> [ModSummary] -> IO ()
multiRootsErr _ [] = panic "multiRootsErr"
multiRootsErr dflags summs@(summ1:_)
= throwOneError $ mkPlainErrMsg dflags noSrcSpan $
text "module" <+> quotes (ppr mod) <+>
text "is defined in multiple files:" <+>
sep (map text files)
where
mod = ms_mod summ1
files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
cyclicModuleErr :: [ModSummary] -> SDoc
cyclicModuleErr mss
= ASSERT( not (null mss) )
case findCycle graph of
Nothing -> text "Unexpected non-cycle" <+> ppr mss
Just path -> vcat [ text "Module imports form a cycle:"
, nest 2 (show_path path) ]
where
graph :: [Node NodeKey ModSummary]
graph = [ DigraphNode ms (msKey ms) (get_deps ms) | ms <- mss]
get_deps :: ModSummary -> [NodeKey]
get_deps ms = ([ (unLoc m, IsBoot) | m <- ms_home_srcimps ms ] ++
[ (unLoc m, NotBoot) | m <- ms_home_imps ms ])
show_path [] = panic "show_path"
show_path [m] = text "module" <+> ppr_ms m
<+> text "imports itself"
show_path (m1:m2:ms) = vcat ( nest 7 (text "module" <+> ppr_ms m1)
: nest 6 (text "imports" <+> ppr_ms m2)
: go ms )
where
go [] = [text "which imports" <+> ppr_ms m1]
go (m:ms) = (text "which imports" <+> ppr_ms m) : go ms
ppr_ms :: ModSummary -> SDoc
ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>
(parens (text (msHsFilePath ms)))