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

1 files changed, 165 insertions, 17 deletions

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 ]