Use object code for TH+UnboxedTuples/Sums

ghcide/ghcide.cabal

@@ -27,6 +27,11 @@ source-repository head
     type:     git
     location: https://github.com/haskell/ghcide.git
 
+flag ghc-patched-unboxed-bytecode
+    description: The GHC version we link against supports unboxed sums and tuples in bytecode
+    default:     False
+    manual:      True
+
 library
     default-language:   Haskell2010
     build-depends:
@@ -190,6 +195,9 @@ library
         Development.IDE.Types.Action
     ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors
 
+    if flag(ghc-patched-unboxed-bytecode)
+      cpp-options: -DGHC_PATCHED_UNBOXED_BYTECODE
+
 executable ghcide-test-preprocessor
     default-language: Haskell2010
     hs-source-dirs: test/preprocessor

ghcide/src/Development/IDE/Core/Compile.hs

@@ -325,7 +325,12 @@ generateObjectCode session summary guts = do
               (warnings, dot_o_fp) <-
                 withWarnings "object" $ \_tweak -> do
                       let summary' = _tweak summary
-                          session' = session { hsc_dflags = (ms_hspp_opts summary') { outputFile = Just dot_o }}
+#if MIN_GHC_API_VERSION(8,10,0)
+                          target = defaultObjectTarget $ hsc_dflags session
+#else
+                          target = defaultObjectTarget $ targetPlatform $ hsc_dflags session
+#endif
+                          session' = session { hsc_dflags = updOptLevel 0 $ (ms_hspp_opts summary') { outputFile = Just dot_o , hscTarget = target}}
                       (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts
 #if MIN_GHC_API_VERSION(8,10,0)
                                 (ms_location summary')

ghcide/src/Development/IDE/Core/RuleTypes.hs

@@ -45,7 +45,9 @@ import Data.Int (Int64)
 import GHC.Serialized (Serialized)
 
 data LinkableType = ObjectLinkable | BCOLinkable
-  deriving (Eq,Ord,Show)
+  deriving (Eq,Ord,Show, Generic)
+instance Hashable LinkableType
+instance NFData   LinkableType
 
 -- NOTATION
 --   Foo+ means Foo for the dependencies
@@ -337,7 +339,7 @@ instance NFData   GetLocatedImports
 instance Binary   GetLocatedImports
 
 -- | Does this module need to be compiled?
-type instance RuleResult NeedsCompilation = Bool
+type instance RuleResult NeedsCompilation = Maybe LinkableType
 
 data NeedsCompilation = NeedsCompilation
     deriving (Eq, Show, Typeable, Generic)

ghcide/src/Development/IDE/Core/Rules.hs

@@ -1034,42 +1034,59 @@ getClientConfigAction defValue = do
     Just (Success c) -> return c
     _ -> return defValue
 
--- | For now we always use bytecode
+-- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH
 getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType)
-getLinkableType f = do
-  needsComp <- use_ NeedsCompilation f
-  pure $ if needsComp then Just BCOLinkable else Nothing
+getLinkableType f = use_ NeedsCompilation f
 
 needsCompilationRule :: Rules ()
 needsCompilationRule = defineEarlyCutoff $ \NeedsCompilation file -> do
-  -- It's important to use stale data here to avoid wasted work.
-  -- if NeedsCompilation fails for a module M its result will be  under-approximated
-  -- to False in its dependencies. However, if M actually used TH, this will
-  -- cause a re-evaluation of GetModIface for all dependencies
-  -- (since we don't need to generate object code anymore).
-  -- Once M is fixed we will discover that we actually needed all the object code
-  -- that we just threw away, and thus have to recompile all dependencies once
-  -- again, this time keeping the object code.
-  (ms,_) <- fst <$> useWithStale_ GetModSummaryWithoutTimestamps file
-  -- A file needs object code if it uses TemplateHaskell or any file that depends on it uses TemplateHaskell
-  res <-
-    if uses_th_qq ms
-    then pure True
-    else do
-      graph <- useNoFile GetModuleGraph
-      case graph of
-          -- Treat as False if some reverse dependency header fails to parse
-          Nothing -> pure False
-          Just depinfo -> case immediateReverseDependencies file depinfo of
-            -- If we fail to get immediate reverse dependencies, fail with an error message
-            Nothing -> fail $ "Failed to get the immediate reverse dependencies of " ++ show file
-            Just revdeps -> anyM (fmap (fromMaybe False) . use NeedsCompilation) revdeps
+  graph <- useNoFile GetModuleGraph
+  res <- case graph of
+    -- Treat as False if some reverse dependency header fails to parse
+    Nothing -> pure Nothing
+    Just depinfo -> case immediateReverseDependencies file depinfo of
+      -- If we fail to get immediate reverse dependencies, fail with an error message
+      Nothing -> fail $ "Failed to get the immediate reverse dependencies of " ++ show file
+      Just revdeps -> do
+        -- It's important to use stale data here to avoid wasted work.
+        -- if NeedsCompilation fails for a module M its result will be  under-approximated
+        -- to False in its dependencies. However, if M actually used TH, this will
+        -- cause a re-evaluation of GetModIface for all dependencies
+        -- (since we don't need to generate object code anymore).
+        -- Once M is fixed we will discover that we actually needed all the object code
+        -- that we just threw away, and thus have to recompile all dependencies once
+        -- again, this time keeping the object code.
+        -- A file needs to be compiled if any file that depends on it uses TemplateHaskell or needs to be compiled
+        (ms,_) <- fst <$> useWithStale_ GetModSummaryWithoutTimestamps file
+        (modsums,needsComps) <- par (map (fmap (fst . fst)) <$> usesWithStale GetModSummaryWithoutTimestamps revdeps)
+                                    (uses NeedsCompilation revdeps)
+        pure $ computeLinkableType ms modsums (map join needsComps)
 
   pure (Just $ BS.pack $ show $ hash res, ([], Just res))
   where
     uses_th_qq (ms_hspp_opts -> dflags) =
       xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
 
+    unboxed_tuples_or_sums (ms_hspp_opts -> d) =
+      xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d
+
+    computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType
+    computeLinkableType this deps xs
+      | Just ObjectLinkable `elem` xs     = Just ObjectLinkable -- If any dependent needs object code, so do we
+      | Just BCOLinkable    `elem` xs     = Just this_type      -- If any dependent needs bytecode, then we need to be compiled
+      | any (maybe False uses_th_qq) deps = Just this_type      -- If any dependent needs TH, then we need to be compiled
+      | otherwise                         = Nothing             -- If none of these conditions are satisfied, we don't need to compile
+      where
+        -- How should we compile this module? (assuming we do in fact need to compile it)
+        -- Depends on whether it uses unboxed tuples or sums
+        this_type
+#if defined(GHC_PATCHED_UNBOXED_BYTECODE)
+          = BCOLinkable
+#else
+          | unboxed_tuples_or_sums this = ObjectLinkable
+          | otherwise                   = BCOLinkable
+#endif
+
 -- | Tracks which linkables are current, so we don't need to unload them
 newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) }
 instance IsIdeGlobal CompiledLinkables

ghcide/test/data/THUnboxed/THA.hs

@@ -0,0 +1,9 @@
+{-# LANGUAGE TemplateHaskell, UnboxedTuples #-}
+module THA where
+import Language.Haskell.TH
+
+f :: Int -> (# Int, Int #)
+f x = (# x , x+1 #)
+
+th_a :: DecsQ
+th_a = case f 1 of (# a , b #) -> [d| a = () |]

ghcide/test/data/THUnboxed/THB.hs

@@ -0,0 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+module THB where
+import THA
+
+$th_a

ghcide/test/data/THUnboxed/THC.hs

@@ -0,0 +1,5 @@
+module THC where
+import THB
+
+c ::()
+c = a

ghcide/test/data/THUnboxed/hie.yaml

@@ -0,0 +1 @@
+cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "THA", "THB", "THC"]}}

ghcide/test/exe/Main.hs

@@ -3504,9 +3504,11 @@ thTests =
         _ <- createDoc "A.hs" "haskell" sourceA
         _ <- createDoc "B.hs" "haskell" sourceB
         return ()
-    , thReloadingTest
+    , thReloadingTest False
+    , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True
     -- Regression test for https://github.com/haskell/haskell-language-server/issues/891
-    , thLinkingTest
+    , thLinkingTest False
+    , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True
     , testSessionWait "findsTHIdentifiers" $ do
         let sourceA =
               T.unlines
@@ -3539,8 +3541,8 @@ thTests =
     ]
 
 -- | test that TH is reevaluated on typecheck
-thReloadingTest :: TestTree
-thReloadingTest = testCase "reloading-th-test" $ runWithExtraFiles "TH" $ \dir -> do
+thReloadingTest :: Bool -> TestTree
+thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do
 
     let aPath = dir </> "THA.hs"
         bPath = dir </> "THB.hs"
@@ -3572,9 +3574,13 @@ thReloadingTest = testCase "reloading-th-test" $ runWithExtraFiles "TH" $ \dir -
     closeDoc adoc
     closeDoc bdoc
     closeDoc cdoc
+  where
+    name = "reloading-th-test" <> if unboxed then "-unboxed" else ""
+    dir | unboxed = "THUnboxed"
+        | otherwise = "TH"
 
-thLinkingTest :: TestTree
-thLinkingTest = testCase "th-linking-test" $ runWithExtraFiles "TH" $ \dir -> do
+thLinkingTest :: Bool -> TestTree
+thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do
 
     let aPath = dir </> "THA.hs"
         bPath = dir </> "THB.hs"
@@ -3598,7 +3604,10 @@ thLinkingTest = testCase "th-linking-test" $ runWithExtraFiles "TH" $ \dir -> do
 
     closeDoc adoc
     closeDoc bdoc
-
+  where
+    name = "th-linking-test" <> if unboxed then "-unboxed" else ""
+    dir | unboxed = "THUnboxed"
+        | otherwise = "TH"
 
 completionTests :: TestTree
 completionTests