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

9 files changed, 224 insertions, 57 deletions

diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs
index 86e84d13f9..a82e66b7b0 100644
--- a/compiler/backpack/DriverBkp.hs
+++ b/compiler/backpack/DriverBkp.hs
@@ -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.
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 07e5eddcc4..e400461fb6 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -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
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 5771fd6b57..a166993089 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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.
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 176c0862fe..60f38d4bf4 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -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 ]
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 56d2ac5eb9..62ae8cce5a 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -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)],
diff --git a/testsuite/tests/th/should_compile/T8025/A.hs b/testsuite/tests/th/should_compile/T8025/A.hs
new file mode 100644
index 0000000000..c0e3083a01
--- /dev/null
+++ b/testsuite/tests/th/should_compile/T8025/A.hs
@@ -0,0 +1,3 @@
+{-# LANGUAGE TemplateHaskell #-}
+module A where
+a = [|3|]
diff --git a/testsuite/tests/th/should_compile/T8025/B.hs b/testsuite/tests/th/should_compile/T8025/B.hs
new file mode 100644
index 0000000000..9bdbc83ac6
--- /dev/null
+++ b/testsuite/tests/th/should_compile/T8025/B.hs
@@ -0,0 +1,5 @@
+-- B.hs
+{-# LANGUAGE TemplateHaskell #-}
+module B where
+import A
+x = $(a)
diff --git a/testsuite/tests/th/should_compile/T8025/Makefile b/testsuite/tests/th/should_compile/T8025/Makefile
new file mode 100644
index 0000000000..1c39d1c1fe
--- /dev/null
+++ b/testsuite/tests/th/should_compile/T8025/Makefile
@@ -0,0 +1,3 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/th/should_compile/T8025/all.T b/testsuite/tests/th/should_compile/T8025/all.T
new file mode 100644
index 0000000000..81e6d5e5fd
--- /dev/null
+++ b/testsuite/tests/th/should_compile/T8025/all.T
@@ -0,0 +1,2 @@
+test('T8025', extra_files(['A.hs', 'B.hs']), multimod_compile,
+     ['A B', '-fno-code -v0'])
\ No newline at end of file