From 53c78be0aab76a3107c4dacbb1d177afacdd37fa Mon Sep 17 00:00:00 2001
From: Douglas Wilson <douglas.wilson@gmail.com>
Date: Sat, 20 May 2017 12:47:41 -0400
Subject: 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
---
 compiler/main/DriverPipeline.hs | 73 ++++++++++++++++++++++-------------------
 1 file changed, 40 insertions(+), 33 deletions(-)

(limited to 'compiler/main/DriverPipeline.hs')

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
-- 
cgit v1.2.1