Commit 53c78be0 authored by Douglas Wilson's avatar Douglas Wilson Committed by Ben Gamari
Browse files

Compile modules that are needed by template haskell, even with -fno-code.

This patch relates to Trac #8025

The goal here is to enable typechecking of packages that contain some
template haskell. Prior to this patch, compilation of a package with
-fno-code would fail if any functions in the package were called from
within a splice.

downsweep is changed to do an additional pass over the modules,
targetting any ModSummaries transitively depended on by a module that
has LangExt.TemplateHaskell enabled. Those targeted modules have
hscTarget changed from HscNothing to the default target of the platform.

There is a small change to the prevailing_target logic to enable this.

A simple test is added.

I have benchmarked with and without a patched haddock
(available:https://github.com/duog/haddock/tree/wip-no-explicit-th-compi
lation).  Running cabal haddock on the wreq package results in a 25%
speedup on my machine:

time output from patched cabal haddock:

real    0m5.780s
user    0m5.304s
sys     0m0.496s
time output from unpatched cabal haddock:

real    0m7.712s
user    0m6.888s
sys     0m0.736s

Reviewers: austin, bgamari, ezyang

Reviewed By: bgamari

Subscribers: bgamari, DanielG, rwbarton, thomie

GHC Trac Issues: #8025

Differential Revision: https://phabricator.haskell.org/D3441
parent 0102e2b7
......@@ -155,6 +155,7 @@ withBkpSession cid insts deps session_type do_this = do
-- turn on interface writing. However, if the user also
-- explicitly passed in `-fno-code`, we DON'T want to write
-- interfaces unless the user also asked for `-fwrite-interface`.
-- See Note [-fno-code mode]
(case session_type of
-- Make sure to write interfaces when we are type-checking
-- indefinite packages.
......
......@@ -1570,39 +1570,46 @@ getLocation src_flavour mod_name = do
PipeEnv{ src_basename=basename,
src_suffix=suff } <- getPipeEnv
-- Build a ModLocation to pass to hscMain.
-- The source filename is rather irrelevant by now, but it's used
-- by hscMain for messages. hscMain also needs
-- the .hi and .o filenames, and this is as good a way
-- as any to generate them, and better than most. (e.g. takes
-- into account the -osuf flags)
location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
-- Boot-ify it if necessary
let location2 | HsBootFile <- src_flavour = addBootSuffixLocn location1
| otherwise = location1
-- Take -ohi into account if present
-- This can't be done in mkHomeModuleLocation because
-- it only applies to the module being compiles
let ohi = outputHi dflags
location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
| otherwise = location2
-- Take -o into account if present
-- Very like -ohi, but we must *only* do this if we aren't linking
-- (If we're linking then the -o applies to the linked thing, not to
-- the object file for one module.)
-- Note the nasty duplication with the same computation in compileFile above
let expl_o_file = outputFile dflags
location4 | Just ofile <- expl_o_file
, isNoLink (ghcLink dflags)
= location3 { ml_obj_file = ofile }
| otherwise = location3
return location4
PipeState { maybe_loc=maybe_loc} <- getPipeState
case maybe_loc of
-- Build a ModLocation to pass to hscMain.
-- The source filename is rather irrelevant by now, but it's used
-- by hscMain for messages. hscMain also needs
-- the .hi and .o filenames. If we already have a ModLocation
-- then simply update the extensions of the interface and object
-- files to match the DynFlags, otherwise use the logic in Finder.
Just l -> return $ l
{ ml_hs_file = Just $ basename <.> suff
, ml_hi_file = ml_hi_file l -<.> hiSuf dflags
, ml_obj_file = ml_obj_file l -<.> objectSuf dflags
}
_ -> do
location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
-- Boot-ify it if necessary
let location2 | HsBootFile <- src_flavour = addBootSuffixLocn location1
| otherwise = location1
-- Take -ohi into account if present
-- This can't be done in mkHomeModuleLocation because
-- it only applies to the module being compiles
let ohi = outputHi dflags
location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
| otherwise = location2
-- Take -o into account if present
-- Very like -ohi, but we must *only* do this if we aren't linking
-- (If we're linking then the -o applies to the linked thing, not to
-- the object file for one module.)
-- Note the nasty duplication with the same computation in compileFile
-- above
let expl_o_file = outputFile dflags
location4 | Just ofile <- expl_o_file
, isNoLink (ghcLink dflags)
= location3 { ml_obj_file = ofile }
| otherwise = location3
return location4
mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath
mkExtraObj dflags extn xs
......
......@@ -1144,12 +1144,10 @@ versionedFilePath dflags = TARGET_ARCH
-- 'HscNothing' can be used to avoid generating any output, however, note
-- that:
--
-- * If a program uses Template Haskell the typechecker may try to run code
-- from an imported module. This will fail if no code has been generated
-- for this module. You can use 'GHC.needsTemplateHaskell' to detect
-- whether this might be the case and choose to either switch to a
-- different target or avoid typechecking such modules. (The latter may be
-- preferable for security reasons.)
-- * If a program uses Template Haskell the typechecker may need to run code
-- from an imported module. To facilitate this, code generation is enabled
-- for modules imported by modules that use template haskell.
-- See Note [-fno-code mode].
--
data HscTarget
= HscC -- ^ Generate C code.
......
......@@ -84,6 +84,7 @@ import Control.Monad
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
......@@ -1356,11 +1357,13 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind
-- If OPTIONS_GHC contains -fasm or -fllvm, be careful that
-- we don't do anything dodgy: these should only work to change
-- from -fllvm to -fasm and vice-versa, otherwise we could
-- end up trying to link object code to byte code.
-- from -fllvm to -fasm and vice-versa, or away from -fno-code,
-- otherwise we could end up trying to link object code to byte
-- code.
target = if prevailing_target /= local_target
&& (not (isObjectTarget prevailing_target)
|| not (isObjectTarget local_target))
&& not (prevailing_target == HscNothing)
then prevailing_target
else local_target
......@@ -1477,7 +1480,7 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind
linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
compile_it_discard_iface (Just linkable) SourceUnmodified
-- See Note [Recompilation checking when typechecking only]
-- See Note [Recompilation checking in -fno-code mode]
| writeInterfaceOnlyMode dflags,
Just if_date <- mb_if_date,
if_date >= hs_date -> do
......@@ -1490,7 +1493,71 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind
(text "compiling mod:" <+> ppr this_mod_name)
compile_it Nothing SourceModified
-- Note [Recompilation checking when typechecking only]
{- Note [-fno-code mode]
~~~~~~~~~~~~~~~~~~~~~~~~
GHC offers the flag -fno-code for the purpose of parsing and typechecking a
program without generating object files. This is intended to be used by tooling
and IDEs to provide quick feedback on any parser or type errors as cheaply as
possible.
When GHC is invoked with -fno-code no object files or linked output will be
generated. As many errors and warnings as possible will be generated, as if
-fno-code had not been passed. The session DynFlags will have
hscTarget == HscNothing.
-fwrite-interface
~~~~~~~~~~~~~~~~
Whether interface files are generated in -fno-code mode is controlled by the
-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is
not also passed. Recompilation avoidance requires interface files, so passing
-fno-code without -fwrite-interface should be avoided. If -fno-code were
re-implemented today, -fwrite-interface would be discarded and it would be
considered always on; this behaviour is as it is for backwards compatibility.
================================================================
IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER
================================================================
Template Haskell
~~~~~~~~~~~~~~~~
A module using template haskell may invoke an imported function from inside a
splice. This will cause the type-checker to attempt to execute that code, which
would fail if no object files had been generated. See #8025. To rectify this,
during the downsweep we patch the DynFlags in the ModSummary of any home module
that is imported by a module that uses template haskell, to generate object
code.
The flavour of generated object code is chosen by defaultObjectTarget for the
target platform. It would likely be faster to generate bytecode, but this is not
supported on all platforms(?Please Confirm?), and does not support the entirety
of GHC haskell. See #1257.
The object files (and interface files if -fwrite-interface is disabled) produced
for template haskell are written to temporary files.
Note that since template haskell can run arbitrary IO actions, -fno-code mode
is no more secure than running without it.
Potential TODOS:
~~~~~
* Remove -fwrite-interface and have interface files always written in -fno-code
mode
* Both .o and .dyn_o files are generated for template haskell, but we only need
.dyn_o. Fix it.
* In make mode, a message like
Compiling A (A.hs, /tmp/ghc_123.o)
is shown if downsweep enabled object code generation for A. Perhaps we should
show "nothing" or "temporary object file" instead. Note that one
can currently use -keep-tmp-files and inspect the generated file with the
current behaviour.
* Offer a -no-codedir command line option, and write what were temporary
object files there. This would speed up recompilation.
* Use existing object files (if they are up to date) instead of always
generating temporary ones.
-}
-- Note [Recompilation checking in -fno-code mode]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- If we are compiling with -fno-code -fwrite-interface, there won't
-- be any object code that we can compare against, nor should there
......@@ -1498,7 +1565,6 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind
-- want to check if the interface file is new, in lieu of the object
-- file. See also Trac #9243.
-- Filter modules in the HPT
retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs keep_these hpt
......@@ -1614,7 +1680,8 @@ topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
where
-- stronglyConnCompG flips the original order, so if we reverse
-- the summaries we get a stable topological sort.
(graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes (reverse summaries)
(graph, lookup_node) =
moduleGraphNodes drop_hs_boot_nodes (reverse summaries)
initial_graph = case mb_root_mod of
Nothing -> graph
......@@ -1623,8 +1690,11 @@ 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
| otherwise = throwGhcException (ProgramError "module does not exist")
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
......@@ -1764,8 +1834,17 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
rootSummariesOk <- reportImportErrors rootSummaries
let root_map = mkRootMap rootSummariesOk
checkDuplicates root_map
summs <- loop (concatMap calcDeps rootSummariesOk) root_map
return summs
map0 <- loop (concatMap calcDeps rootSummariesOk) root_map
-- if we have been passed -fno-code, we enable code generation
-- for dependencies of modules that have -XTemplateHaskell,
-- otherwise those modules will fail to compile.
-- See Note [-fno-code mode] #8025
map1 <- if hscTarget dflags == HscNothing
then enableCodeGenForTH
(defaultObjectTarget (targetPlatform dflags))
map0
else return map0
return $ concat $ nodeMapElts map1
where
calcDeps = msDeps
......@@ -1812,16 +1891,15 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
-- Visited set; the range is a list because
-- the roots can have the same module names
-- if allow_dup_roots is True
-> IO [Either ErrMsg ModSummary]
-- The result includes the worklist, except
-- for those mentioned in the visited set
loop [] done = return (concat (nodeMapElts done))
-> IO (NodeMap [Either ErrMsg ModSummary])
-- The result is the completed NodeMap
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 [] }
do { multiRootsErr dflags (rights summs); return Map.empty }
| otherwise
= do mb_s <- summariseModule hsc_env old_summary_map
is_boot wanted_mod True
......@@ -1829,11 +1907,81 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
case mb_s of
Nothing -> loop ss done
Just (Left e) -> loop ss (Map.insert key [Left e] done)
Just (Right s)-> loop (calcDeps s ++ ss)
(Map.insert key [Right s] 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)
-- | Update the every ModSummary that is depended on
-- by a module that needs template haskell. We enable codegen to
-- the specified target, disable optimization and change the .hi
-- and .o file locations to be temporary files.
-- See Note [-fno-code mode]
enableCodeGenForTH :: HscTarget
-> NodeMap [Either ErrMsg ModSummary]
-> IO (NodeMap [Either ErrMsg ModSummary])
enableCodeGenForTH 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@DynFlags
{hscTarget = HscNothing}
} <- ms
, ms_mod `Set.member` needs_codegen_set
= do
let add_intermediate_file f =
consIORef (filesToNotIntermediateClean dflags) f
new_temp_file suf dynsuf = do
tn <- newTempName dflags suf
let dyn_tn = tn -<.> dynsuf
add_intermediate_file tn
add_intermediate_file dyn_tn
addFilesToClean dflags [dyn_tn]
return tn
-- We don't want to create .o or .hi files unless we have been asked
-- to by the user. But we need them, so we patch their locations in
-- the ModSummary with temporary files.
--
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 Set.empty th_modSums
th_modSums =
[ ms
| mss <- Map.elems nodemap
, Right ms <- mss
, xopt LangExt.TemplateHaskell (ms_hspp_opts ms)
]
transitive_deps_set marked_mods modSums = foldl' go marked_mods modSums
go marked_mods ms
| Set.member (ms_mod ms) 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 =
marked_mods `Set.union` Set.fromList (fmap ms_mod deps)
in transitive_deps_set new_marked_mods deps
mkRootMap :: [ModSummary] -> NodeMap [Either ErrMsg ModSummary]
mkRootMap summaries = Map.insertListWith (flip (++))
[ (msKey s, [Right s]) | s <- summaries ]
......
......@@ -2624,7 +2624,7 @@ data ModSummary
ms_iface_date :: Maybe UTCTime,
-- ^ Timestamp of hi file, if we *only* are typechecking (it is
-- 'Nothing' otherwise.
-- See Note [Recompilation checking when typechecking only] and #9243
-- See Note [Recompilation checking in -fno-code mode] and #9243
ms_srcimps :: [(Maybe FastString, Located ModuleName)],
-- ^ Source imports of the module
ms_textual_imps :: [(Maybe FastString, Located ModuleName)],
......
{-# LANGUAGE TemplateHaskell #-}
module A where
a = [|3|]
-- B.hs
{-# LANGUAGE TemplateHaskell #-}
module B where
import A
x = $(a)
TOP=../../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
test('T8025', extra_files(['A.hs', 'B.hs']), multimod_compile,
['A B', '-fno-code -v0'])
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment