From 9377ce58117b02827f3c137bcf48c36a94d1b990 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 16 Feb 2021 17:35:04 +0530 Subject: [PATCH 1/3] Use object code for TH+UnboxedTuples/Sums --- ghcide/src/Development/IDE/Core/Compile.hs | 7 ++- ghcide/src/Development/IDE/Core/RuleTypes.hs | 6 +- ghcide/src/Development/IDE/Core/Rules.hs | 65 ++++++++++++-------- ghcide/test/data/THUnboxed/THA.hs | 9 +++ ghcide/test/data/THUnboxed/THB.hs | 5 ++ ghcide/test/data/THUnboxed/THC.hs | 5 ++ ghcide/test/data/THUnboxed/hie.yaml | 1 + ghcide/test/exe/Main.hs | 23 ++++--- 8 files changed, 85 insertions(+), 36 deletions(-) create mode 100644 ghcide/test/data/THUnboxed/THA.hs create mode 100644 ghcide/test/data/THUnboxed/THB.hs create mode 100644 ghcide/test/data/THUnboxed/THC.hs create mode 100644 ghcide/test/data/THUnboxed/hie.yaml 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 8561e4a834..300393de72 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -1052,42 +1052,55 @@ 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 + | unboxed_tuples_or_sums this = ObjectLinkable + | otherwise = BCOLinkable + -- | 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 831acf2e93..5c1d72c366 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 + , thReloadingTest True -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 - , thLinkingTest + , thLinkingTest False + , 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 From 84ab970c896b6edc355155184488f62e8bf5eb3c Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 16 Feb 2021 19:01:00 +0530 Subject: [PATCH 2/3] ignore tests in windows --- ghcide/test/exe/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 5c1d72c366..44fad43b57 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -3505,10 +3505,10 @@ thTests = _ <- createDoc "B.hs" "haskell" sourceB return () , thReloadingTest False - , thReloadingTest True + , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 , thLinkingTest False - , thLinkingTest True + , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True , testSessionWait "findsTHIdentifiers" $ do let sourceA = T.unlines From 151df77bf653ba75ab707a38341620eb1ae18bdc Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Wed, 17 Feb 2021 16:17:24 +0530 Subject: [PATCH 3/3] add cabal flag for patched GHCs --- ghcide/ghcide.cabal | 8 ++++++++ ghcide/src/Development/IDE/Core/Rules.hs | 4 ++++ 2 files changed, 12 insertions(+) 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/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 37513a418b..40118f792b 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -1080,8 +1080,12 @@ needsCompilationRule = defineEarlyCutoff $ \NeedsCompilation file -> do -- 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) }