Skip to content

Commit 2da640b

Browse files
mergify[bot]mergify[bot]
authored
Merge branch 'master' into master
2 parents 68b7702 + 03e833b commit 2da640b

File tree

9 files changed

+97
-36
lines changed

9 files changed

+97
-36
lines changed

‎ghcide/ghcide.cabal‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,11 @@ source-repository head
2727
type: git
2828
location: https://github.com/haskell/ghcide.git
2929

30+
flag ghc-patched-unboxed-bytecode
31+
description: The GHC version we link against supports unboxed sums and tuples in bytecode
32+
default: False
33+
manual: True
34+
3035
library
3136
default-language: Haskell2010
3237
build-depends:
@@ -190,6 +195,9 @@ library
190195
Development.IDE.Types.Action
191196
ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors
192197

198+
if flag(ghc-patched-unboxed-bytecode)
199+
cpp-options: -DGHC_PATCHED_UNBOXED_BYTECODE
200+
193201
executable ghcide-test-preprocessor
194202
default-language: Haskell2010
195203
hs-source-dirs: test/preprocessor

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

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -325,7 +325,12 @@ generateObjectCode session summary guts = do
325325
(warnings, dot_o_fp) <-
326326
withWarnings "object" $ \_tweak -> do
327327
let summary' = _tweak summary
328-
session' = session { hsc_dflags = (ms_hspp_opts summary') { outputFile = Just dot_o }}
328+
#if MIN_GHC_API_VERSION(8,10,0)
329+
target = defaultObjectTarget $ hsc_dflags session
330+
#else
331+
target = defaultObjectTarget $ targetPlatform $ hsc_dflags session
332+
#endif
333+
session' = session { hsc_dflags = updOptLevel 0 $ (ms_hspp_opts summary') { outputFile = Just dot_o , hscTarget = target}}
329334
(outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts
330335
#if MIN_GHC_API_VERSION(8,10,0)
331336
(ms_location summary')

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

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -45,7 +45,9 @@ import Data.Int (Int64)
4545
import GHC.Serialized (Serialized)
4646

4747
data LinkableType = ObjectLinkable | BCOLinkable
48-
deriving (Eq,Ord,Show)
48+
deriving (Eq,Ord,Show, Generic)
49+
instance Hashable LinkableType
50+
instance NFData LinkableType
4951

5052
-- NOTATION
5153
-- Foo+ means Foo for the dependencies
@@ -337,7 +339,7 @@ instance NFData GetLocatedImports
337339
instance Binary GetLocatedImports
338340

339341
-- | Does this module need to be compiled?
340-
type instance RuleResult NeedsCompilation = Bool
342+
type instance RuleResult NeedsCompilation = Maybe LinkableType
341343

342344
data NeedsCompilation = NeedsCompilation
343345
deriving (Eq, Show, Typeable, Generic)

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

Lines changed: 43 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -1038,42 +1038,59 @@ getClientConfigAction defValue = do
10381038
Just (Success c) -> return c
10391039
_ -> return defValue
10401040

1041-
-- | For now we always use bytecode
1041+
-- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH
10421042
getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType)
1043-
getLinkableType f = do
1044-
needsComp <- use_ NeedsCompilation f
1045-
pure $ if needsComp then Just BCOLinkable else Nothing
1043+
getLinkableType f = use_ NeedsCompilation f
10461044

10471045
needsCompilationRule :: Rules ()
10481046
needsCompilationRule = defineEarlyCutoff $ \NeedsCompilation file -> do
1049-
-- It's important to use stale data here to avoid wasted work.
1050-
-- if NeedsCompilation fails for a module M its result will be under-approximated
1051-
-- to False in its dependencies. However, if M actually used TH, this will
1052-
-- cause a re-evaluation of GetModIface for all dependencies
1053-
-- (since we don't need to generate object code anymore).
1054-
-- Once M is fixed we will discover that we actually needed all the object code
1055-
-- that we just threw away, and thus have to recompile all dependencies once
1056-
-- again, this time keeping the object code.
1057-
(ms,_) <- fst <$> useWithStale_ GetModSummaryWithoutTimestamps file
1058-
-- A file needs object code if it uses TemplateHaskell or any file that depends on it uses TemplateHaskell
1059-
res <-
1060-
if uses_th_qq ms
1061-
then pure True
1062-
else do
1063-
graph <- useNoFile GetModuleGraph
1064-
case graph of
1065-
-- Treat as False if some reverse dependency header fails to parse
1066-
Nothing -> pure False
1067-
Just depinfo -> case immediateReverseDependencies file depinfo of
1068-
-- If we fail to get immediate reverse dependencies, fail with an error message
1069-
Nothing -> fail $ "Failed to get the immediate reverse dependencies of " ++ show file
1070-
Just revdeps -> anyM (fmap (fromMaybe False) . use NeedsCompilation) revdeps
1047+
graph <- useNoFile GetModuleGraph
1048+
res <- case graph of
1049+
-- Treat as False if some reverse dependency header fails to parse
1050+
Nothing -> pure Nothing
1051+
Just depinfo -> case immediateReverseDependencies file depinfo of
1052+
-- If we fail to get immediate reverse dependencies, fail with an error message
1053+
Nothing -> fail $ "Failed to get the immediate reverse dependencies of " ++ show file
1054+
Just revdeps -> do
1055+
-- It's important to use stale data here to avoid wasted work.
1056+
-- if NeedsCompilation fails for a module M its result will be under-approximated
1057+
-- to False in its dependencies. However, if M actually used TH, this will
1058+
-- cause a re-evaluation of GetModIface for all dependencies
1059+
-- (since we don't need to generate object code anymore).
1060+
-- Once M is fixed we will discover that we actually needed all the object code
1061+
-- that we just threw away, and thus have to recompile all dependencies once
1062+
-- again, this time keeping the object code.
1063+
-- A file needs to be compiled if any file that depends on it uses TemplateHaskell or needs to be compiled
1064+
(ms,_) <- fst <$> useWithStale_ GetModSummaryWithoutTimestamps file
1065+
(modsums,needsComps) <- par (map (fmap (fst . fst)) <$> usesWithStale GetModSummaryWithoutTimestamps revdeps)
1066+
(uses NeedsCompilation revdeps)
1067+
pure $ computeLinkableType ms modsums (map join needsComps)
10711068

10721069
pure (Just $ BS.pack $ show $ hash res, ([], Just res))
10731070
where
10741071
uses_th_qq (ms_hspp_opts -> dflags) =
10751072
xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
10761073

1074+
unboxed_tuples_or_sums (ms_hspp_opts -> d) =
1075+
xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d
1076+
1077+
computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType
1078+
computeLinkableType this deps xs
1079+
| Just ObjectLinkable `elem` xs = Just ObjectLinkable -- If any dependent needs object code, so do we
1080+
| Just BCOLinkable `elem` xs = Just this_type -- If any dependent needs bytecode, then we need to be compiled
1081+
| any (maybe False uses_th_qq) deps = Just this_type -- If any dependent needs TH, then we need to be compiled
1082+
| otherwise = Nothing -- If none of these conditions are satisfied, we don't need to compile
1083+
where
1084+
-- How should we compile this module? (assuming we do in fact need to compile it)
1085+
-- Depends on whether it uses unboxed tuples or sums
1086+
this_type
1087+
#if defined(GHC_PATCHED_UNBOXED_BYTECODE)
1088+
= BCOLinkable
1089+
#else
1090+
| unboxed_tuples_or_sums this = ObjectLinkable
1091+
| otherwise = BCOLinkable
1092+
#endif
1093+
10771094
-- | Tracks which linkables are current, so we don't need to unload them
10781095
newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) }
10791096
instance IsIdeGlobal CompiledLinkables

‎ghcide/test/data/THUnboxed/THA.hs‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
{-# LANGUAGE TemplateHaskell, UnboxedTuples #-}
2+
module THA where
3+
import Language.Haskell.TH
4+
5+
f :: Int -> (# Int, Int #)
6+
f x = (# x , x+1 #)
7+
8+
th_a :: DecsQ
9+
th_a = case f 1 of (# a , b #) -> [d| a = () |]

‎ghcide/test/data/THUnboxed/THB.hs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
{-# LANGUAGE TemplateHaskell #-}
2+
module THB where
3+
import THA
4+
5+
$th_a

‎ghcide/test/data/THUnboxed/THC.hs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
module THC where
2+
import THB
3+
4+
c ::()
5+
c = a

‎ghcide/test/data/THUnboxed/hie.yaml‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "THA", "THB", "THC"]}}

‎ghcide/test/exe/Main.hs‎

Lines changed: 16 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -3504,9 +3504,11 @@ thTests =
35043504
_ <- createDoc "A.hs" "haskell" sourceA
35053505
_ <- createDoc "B.hs" "haskell" sourceB
35063506
return ()
3507-
, thReloadingTest
3507+
, thReloadingTest False
3508+
, ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True
35083509
-- Regression test for https://github.com/haskell/haskell-language-server/issues/891
3509-
, thLinkingTest
3510+
, thLinkingTest False
3511+
, ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True
35103512
, testSessionWait "findsTHIdentifiers" $ do
35113513
let sourceA =
35123514
T.unlines
@@ -3539,8 +3541,8 @@ thTests =
35393541
]
35403542

35413543
-- | test that TH is reevaluated on typecheck
3542-
thReloadingTest :: TestTree
3543-
thReloadingTest = testCase "reloading-th-test" $ runWithExtraFiles "TH" $ \dir -> do
3544+
thReloadingTest :: Bool -> TestTree
3545+
thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do
35443546

35453547
let aPath = dir </> "THA.hs"
35463548
bPath = dir </> "THB.hs"
@@ -3572,9 +3574,13 @@ thReloadingTest = testCase "reloading-th-test" $ runWithExtraFiles "TH" $ \dir -
35723574
closeDoc adoc
35733575
closeDoc bdoc
35743576
closeDoc cdoc
3577+
where
3578+
name = "reloading-th-test" <> if unboxed then "-unboxed" else ""
3579+
dir | unboxed = "THUnboxed"
3580+
| otherwise = "TH"
35753581

3576-
thLinkingTest :: TestTree
3577-
thLinkingTest = testCase "th-linking-test" $ runWithExtraFiles "TH" $ \dir -> do
3582+
thLinkingTest :: Bool -> TestTree
3583+
thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do
35783584

35793585
let aPath = dir </> "THA.hs"
35803586
bPath = dir </> "THB.hs"
@@ -3598,7 +3604,10 @@ thLinkingTest = testCase "th-linking-test" $ runWithExtraFiles "TH" $ \dir -> do
35983604

35993605
closeDoc adoc
36003606
closeDoc bdoc
3601-
3607+
where
3608+
name = "th-linking-test" <> if unboxed then "-unboxed" else ""
3609+
dir | unboxed = "THUnboxed"
3610+
| otherwise = "TH"
36023611

36033612
completionTests :: TestTree
36043613
completionTests

0 commit comments

Comments
 (0)