diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 3055cb15c3..a04597da7d 100644 --- a/ghcide/ghcide.cabal +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 2ce4934cf3..9683f3b722 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/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') diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 9dc53acb65..1cda366009 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/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) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 3344d50b7c..75b0710535 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -1038,42 +1038,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 diff --git a/ghcide/test/data/THUnboxed/THA.hs b/ghcide/test/data/THUnboxed/THA.hs new file mode 100644 index 0000000000..a2bd3a70d9 --- /dev/null +++ b/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 = () |] diff --git a/ghcide/test/data/THUnboxed/THB.hs b/ghcide/test/data/THUnboxed/THB.hs new file mode 100644 index 0000000000..8d50b01eac --- /dev/null +++ b/ghcide/test/data/THUnboxed/THB.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module THB where +import THA + +$th_a diff --git a/ghcide/test/data/THUnboxed/THC.hs b/ghcide/test/data/THUnboxed/THC.hs new file mode 100644 index 0000000000..79a02ef601 --- /dev/null +++ b/ghcide/test/data/THUnboxed/THC.hs @@ -0,0 +1,5 @@ +module THC where +import THB + +c ::() +c = a diff --git a/ghcide/test/data/THUnboxed/hie.yaml b/ghcide/test/data/THUnboxed/hie.yaml new file mode 100644 index 0000000000..a65c7b79c4 --- /dev/null +++ b/ghcide/test/data/THUnboxed/hie.yaml @@ -0,0 +1 @@ +cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "THA", "THB", "THC"]}} diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 0a7465e519..4c15476bf8 100644 --- a/ghcide/test/exe/Main.hs +++ b/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