-- If we can determine that any of the {-# SOURCE #-} imports
-- are definitely unnecessary, then emit a warning.
- warnUnnecessarySourceImports dflags mg2_with_srcimps
+ warnUnnecessarySourceImports mg2_with_srcimps
let
-- check the stability property for each module.
-- Throws a 'SourceError' on parse error.
parseModule :: GhcMonad m => ModSummary -> m ParsedModule
parseModule ms = do
- hsc_env0 <- getSession
- let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
- rdr_module <- parseFile hsc_env ms
+ rdr_module <- withTempSession
+ (\e -> e { hsc_dflags = ms_hspp_opts ms }) $
+ hscParse ms
return (ParsedModule ms rdr_module)
-- | Typecheck and rename a parsed module.
-- Throws a 'SourceError' if either fails.
typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
typecheckModule pmod = do
- let ms = modSummary pmod
- hsc_env0 <- getSession
- let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
+ let ms = modSummary pmod
+ withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
(tc_gbl_env, rn_info)
- <- typecheckRenameModule hsc_env ms (parsedSource pmod)
- details <- liftIO $ makeSimpleDetails hsc_env tc_gbl_env
+ <- hscTypecheckRename ms (parsedSource pmod)
+ details <- makeSimpleDetails tc_gbl_env
return $
TypecheckedModule {
tm_internals_ = (tc_gbl_env, details),
-- | Desugar a typechecked module.
desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
desugarModule tcm = do
- let ms = modSummary tcm
- hsc_env0 <- getSession
- let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
+ let ms = modSummary tcm
+ withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
let (tcg, _) = tm_internals tcm
- guts <- deSugarModule hsc_env ms tcg
+ guts <- hscDesugar ms tcg
return $
DesugaredModule {
dm_typechecked_module = tcm,
loadModule tcm = do
let ms = modSummary tcm
let mod = ms_mod_name ms
- hsc_env0 <- getSession
- let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
let (tcg, details) = tm_internals tcm
- (iface,_) <- liftIO $ makeSimpleIface hsc_env Nothing tcg details
- let mod_info = HomeModInfo {
- hm_iface = iface,
- hm_details = details,
- hm_linkable = Nothing }
- let hpt_new = addToUFM (hsc_HPT hsc_env) mod mod_info
- modifySession $ \_ -> hsc_env0{ hsc_HPT = hpt_new }
+ hpt_new <-
+ withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
+ (iface, _) <- makeSimpleIface Nothing tcg details
+ let mod_info = HomeModInfo {
+ hm_iface = iface,
+ hm_details = details,
+ hm_linkable = Just (LM (ms_hs_date ms)
+ (ms_mod ms)
+ []) }
+ hsc_env <- getSession
+ return $ addToUFM (hsc_HPT hsc_env) mod mod_info
+ modifySession $ \e -> e{ hsc_HPT = hpt_new }
return tcm
-- | This is the way to get access to the Core bindings corresponding
-- whether to run the simplifier.
-- The resulting .o, .hi, and executable files, if any, are stored in the
-- current directory, and named according to the module name.
--- Returns True iff compilation succeeded.
-- This has only so far been tested with a single self-contained module.
compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m ()
compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
- hscEnv <- getSession
dflags <- getSessionDynFlags
currentTime <- liftIO $ getClockTime
cwd <- liftIO $ getCurrentDirectory
ms_hspp_buf = Nothing
}
- ioMsgMaybe $ flip evalComp (CompState{ compHscEnv=hscEnv,
- compModSummary=modSummary,
- compOldIface=Nothing}) $
- let maybe_simplify mod_guts | simplify = hscSimplify mod_guts
- | otherwise = return mod_guts
- in maybe_simplify (mkModGuts cm)
- >>= hscNormalIface
- >>= hscWriteIface
- >>= hscOneShot
+ let maybe_simplify mod_guts | simplify = hscSimplify mod_guts
+ | otherwise = return mod_guts
+ guts <- maybe_simplify (mkModGuts cm)
+ (iface, changed, _details, cgguts)
+ <- hscNormalIface guts Nothing
+ hscWriteIface iface changed modSummary
+ hscGenHardCode cgguts modSummary
return ()
-- Makes a "vanilla" ModGuts.
-- Now we have the module name;
-- parse, typecheck and desugar the module
mod_guts <- coreModule `fmap`
+ -- TODO: space leaky: call hsc* directly?
(desugarModule =<< typecheckModule =<< parseModule modSummary)
liftM gutsToCoreModule $
if simplify
-- If simplify is true: simplify (hscSimplify), then tidy
-- (tidyProgram).
hsc_env <- getSession
- simpl_guts <- ioMsg $ evalComp (hscSimplify mod_guts)
- (CompState{
- compHscEnv = hsc_env,
- compModSummary = modSummary,
- compOldIface = Nothing})
+ simpl_guts <- hscSimplify mod_guts
tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
return $ Left tidy_guts
else
compile_it_discard_iface
= compile hsc_env summary' mod_index nmods Nothing
- in
- case target of
+ -- With the HscNothing target we create empty linkables to avoid
+ -- recompilation. We have to detect these to recompile anyway if
+ -- the target changed since the last compile.
+ is_fake_linkable
+ | Just hmi <- old_hmi, Just l <- hm_linkable hmi =
+ null (linkableUnlinked l)
+ | otherwise =
+ -- we have no linkable, so it cannot be fake
+ False
+
+ implies False _ = True
+ implies True x = x
- _any
+ in
+ case () of
+ _
-- Regardless of whether we're generating object code or
-- byte code, we can always use an existing object file
-- if it is *stable* (see checkStability).
- | is_stable_obj, isJust old_hmi ->
- let Just hmi = old_hmi in
- return hmi
- -- object is stable, and we have an entry in the
- -- old HPT: nothing to do
-
- | is_stable_obj, isNothing old_hmi -> do
- linkable <- liftIO $ findObjectLinkable this_mod obj_fn
- (expectJust "upsweep1" mb_obj_date)
- compile_it (Just linkable)
- -- object is stable, but we need to load the interface
- -- off disk to make a HMI.
-
- HscInterpreted
- | is_stable_bco ->
- ASSERT(isJust old_hmi) -- must be in the old_hpt
- let Just hmi = old_hmi in
- return hmi
- -- BCO is stable: nothing to do
-
- | Just hmi <- old_hmi,
- Just l <- hm_linkable hmi, not (isObjectLinkable l),
- linkableTime l >= ms_hs_date summary ->
- compile_it (Just l)
- -- we have an old BCO that is up to date with respect
- -- to the source: do a recompilation check as normal.
-
- | otherwise ->
- compile_it Nothing
- -- no existing code at all: we must recompile.
-
- -- When generating object code, if there's an up-to-date
- -- object file on the disk, then we can use it.
- -- However, if the object file is new (compared to any
- -- linkable we had from a previous compilation), then we
- -- must discard any in-memory interface, because this
- -- means the user has compiled the source file
- -- separately and generated a new interface, that we must
- -- read from the disk.
- --
- obj | isObjectTarget obj,
- 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
- -> compile_it (Just l)
- _otherwise -> do
- linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
+ | 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
+ -- object is stable, and we have an entry in the
+ -- old HPT: nothing to do
+
+ | 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)
+ -- object is stable, but we need to load the interface
+ -- off disk to make a HMI.
+
+ | not (isObjectTarget target), is_stable_bco,
+ (target /= HscNothing) `implies` not is_fake_linkable ->
+ ASSERT(isJust old_hmi) -- must be in the old_hpt
+ 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
+ -- BCO is stable: nothing to do
+
+ | 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)
+ -- we have an old BCO that is up to date with respect
+ -- to the source: do a recompilation check as normal.
+
+ -- When generating object code, if there's an up-to-date
+ -- object file on the disk, then we can use it.
+ -- However, if the object file is new (compared to any
+ -- linkable we had from a previous compilation), then we
+ -- must discard any in-memory interface, because this
+ -- means the user has compiled the source file
+ -- separately and generated a new interface, that we must
+ -- read from the disk.
+ --
+ | 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)
+ _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)
- _otherwise ->
- compile_it Nothing
+ _otherwise -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "compiling mod:" <+> ppr this_mod_name)
+ compile_it Nothing
-- components in the topological sort, then those imports can
-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
-- were necessary, then the edge would be part of a cycle.
-warnUnnecessarySourceImports :: GhcMonad m => DynFlags -> [SCC ModSummary] -> m ()
-warnUnnecessarySourceImports dflags sccs =
- liftIO $ printBagOfWarnings dflags (listToBag (concatMap (check.flattenSCC) sccs))
+warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
+warnUnnecessarySourceImports sccs =
+ logWarnings (listToBag (concatMap (check.flattenSCC) sccs))
where check ms =
let mods_in_this_cycle = map ms_mod_name ms in
[ warn i | m <- ms, i <- ms_srcimps m,
(dflags', hspp_fn, buf)
<- preprocessFile hsc_env file mb_phase maybe_buf
- (srcimps,the_imps, L _ mod_name) <- liftIO $ getImports dflags' buf hspp_fn file
+ (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
-- Make a ModLocation for this file
location <- liftIO $ mkHomeModLocation dflags mod_name file
-- Preprocess the source file and get its imports
-- The dflags' contains the OPTIONS pragmas
(dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
- (srcimps, the_imps, L mod_loc mod_name) <- liftIO $ getImports dflags' buf hspp_fn src_fn
+ (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
when (mod_name /= wanted_mod) $
throwOneError $ mkPlainErrMsg mod_loc $
--
(dflags', leftovers, warns)
<- parseDynamicNoPackageFlags dflags local_opts
- liftIO $ checkProcessArgsResult leftovers -- XXX: throws exceptions
- liftIO $ handleFlagWarnings dflags' warns -- XXX: throws exceptions
+ checkProcessArgsResult leftovers
+ handleFlagWarnings dflags' warns
let
needs_preprocessing
projects / ghc-hetmet.git / blobdiff