diff options
| -rw-r--r-- | compiler/GHC/CoreToIface.hs | 13 | ||||
| -rw-r--r-- | compiler/GHC/IfaceToCore.hs | 8 | ||||
| -rw-r--r-- | testsuite/tests/driver/fat-iface/Makefile | 7 | ||||
| -rw-r--r-- | testsuite/tests/driver/fat-iface/T22807.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/driver/fat-iface/T22807A.hs | 6 | ||||
| -rw-r--r-- | testsuite/tests/driver/fat-iface/T22807B.hs | 5 | ||||
| -rw-r--r-- | testsuite/tests/driver/fat-iface/T22807_ghci.hs | 8 | ||||
| -rw-r--r-- | testsuite/tests/driver/fat-iface/T22807_ghci.script | 6 | ||||
| -rw-r--r-- | testsuite/tests/driver/fat-iface/T22807_ghci.stdout | 1 | ||||
| -rw-r--r-- | testsuite/tests/driver/fat-iface/all.T | 4 |
10 files changed, 56 insertions, 4 deletions
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index 87fe4793b8..f0e2c0ad5f 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -604,8 +604,12 @@ toIfaceTopBind b = IfLclTopBndr {} -> IfRhs (toIfaceExpr rhs) in (top_bndr, rhs') - already_has_unfolding b = - -- The identifier has an unfolding, which we are going to serialise anyway + -- The sharing behaviour is currently disabled due to #22807, and relies on + -- finished #220056 to be re-enabled. + disabledDueTo22807 = True + + already_has_unfolding b = not disabledDueTo22807 + && -- The identifier has an unfolding, which we are going to serialise anyway hasCoreUnfolding (realIdUnfolding b) -- But not a stable unfolding, we want the optimised unfoldings. && not (isStableUnfolding (realIdUnfolding b)) @@ -771,7 +775,10 @@ is that these NOINLINE'd functions now can't be profitably inlined outside of the hs-boot loop. Note [Interface File with Core: Sharing RHSs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +IMPORTANT: This optimisation is currently disabled due to #22027, it can be + re-enabled once #220056 is implemented. In order to avoid duplicating definitions for bindings which already have unfoldings we do some minor headstands to avoid serialising the RHS of a definition if it has diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 93a3bce842..7138c0433e 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -933,7 +933,13 @@ tc_iface_bindings (IfaceRec bs) = do -- | See Note [Interface File with Core: Sharing RHSs] tc_iface_binding :: Id -> IfaceMaybeRhs -> IfL CoreExpr -tc_iface_binding i IfUseUnfoldingRhs = return (unfoldingTemplate $ realIdUnfolding i) +tc_iface_binding i IfUseUnfoldingRhs = + case maybeUnfoldingTemplate $ realIdUnfolding i of + Just e -> return e + Nothing -> pprPanic "tc_iface_binding" (vcat [text "Binding" <+> quotes (ppr i) <+> text "had an unfolding when the interface file was created" + , text "which has now gone missing, something has badly gone wrong." + , text "Unfolding:" <+> ppr (realIdUnfolding i)]) + tc_iface_binding _ (IfRhs rhs) = tcIfaceExpr rhs mk_top_id :: IfaceTopBndrInfo -> IfL Id diff --git a/testsuite/tests/driver/fat-iface/Makefile b/testsuite/tests/driver/fat-iface/Makefile index 7241e48333..e74578a491 100644 --- a/testsuite/tests/driver/fat-iface/Makefile +++ b/testsuite/tests/driver/fat-iface/Makefile @@ -49,4 +49,11 @@ fat010: clean echo >> "THB.hs" "$(TEST_HC)" $(TEST_HC_OPTS) THC.hs -fhide-source-paths -fwrite-if-simplified-core -fprefer-byte-code +T22807: clean + "$(TEST_HC)" $(TEST_HC_OPTS) T22807A.hs -fhide-source-paths -fwrite-if-simplified-core -fbyte-code-and-object-code -fno-omit-interface-pragmas -fprefer-byte-code + "$(TEST_HC)" $(TEST_HC_OPTS) T22807B.hs -fhide-source-paths -fwrite-if-simplified-core -fprefer-byte-code -fbyte-code-and-object-code -fno-omit-interface-pragmas + +T22807_ghci: clean + "$(TEST_HC)" $(TEST_HC_OPTS) T22807_ghci.hs -fno-full-laziness -fhide-source-paths -fwrite-if-simplified-core -O2 -dynamic -v0 + "$(TEST_HC)" $(TEST_HC_OPTS) -v0 --interactive -fhide-source-paths -fno-full-laziness < T22807_ghci.script diff --git a/testsuite/tests/driver/fat-iface/T22807.stdout b/testsuite/tests/driver/fat-iface/T22807.stdout new file mode 100644 index 0000000000..173c70efee --- /dev/null +++ b/testsuite/tests/driver/fat-iface/T22807.stdout @@ -0,0 +1,2 @@ +[1 of 1] Compiling T22807A +[2 of 2] Compiling T22807B diff --git a/testsuite/tests/driver/fat-iface/T22807A.hs b/testsuite/tests/driver/fat-iface/T22807A.hs new file mode 100644 index 0000000000..8a86caf95e --- /dev/null +++ b/testsuite/tests/driver/fat-iface/T22807A.hs @@ -0,0 +1,6 @@ +module T22807A where + +xs :: [a] +xs = [] + + diff --git a/testsuite/tests/driver/fat-iface/T22807B.hs b/testsuite/tests/driver/fat-iface/T22807B.hs new file mode 100644 index 0000000000..5f1dd047cd --- /dev/null +++ b/testsuite/tests/driver/fat-iface/T22807B.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module T22807B where +import T22807A + +$(pure xs) diff --git a/testsuite/tests/driver/fat-iface/T22807_ghci.hs b/testsuite/tests/driver/fat-iface/T22807_ghci.hs new file mode 100644 index 0000000000..1d603b16d8 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/T22807_ghci.hs @@ -0,0 +1,8 @@ +module T22807_ghci where + + +foo b = + let x = Just [1..1000] + in if b + then Left x + else Right x diff --git a/testsuite/tests/driver/fat-iface/T22807_ghci.script b/testsuite/tests/driver/fat-iface/T22807_ghci.script new file mode 100644 index 0000000000..be68d82d12 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/T22807_ghci.script @@ -0,0 +1,6 @@ +:l T22807_ghci.hs + +import T22807_ghci +import Data.Either + +isLeft (foo True) diff --git a/testsuite/tests/driver/fat-iface/T22807_ghci.stdout b/testsuite/tests/driver/fat-iface/T22807_ghci.stdout new file mode 100644 index 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/driver/fat-iface/T22807_ghci.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/driver/fat-iface/all.T b/testsuite/tests/driver/fat-iface/all.T index c526aa7493..18837711de 100644 --- a/testsuite/tests/driver/fat-iface/all.T +++ b/testsuite/tests/driver/fat-iface/all.T @@ -15,5 +15,9 @@ test('fat013', [req_th, extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_comp # When using interpreter should not produce objects test('fat014', [req_th, extra_files(['FatTH.hs', 'FatQuote.hs']), extra_run_opts('-fno-code')], ghci_script, ['fat014.script']) test('fat015', [req_th, unless(ghc_dynamic(), skip), extra_files(['FatQuote.hs', 'FatQuote1.hs', 'FatQuote2.hs', 'FatTH1.hs', 'FatTH2.hs', 'FatTHTop.hs'])], multimod_compile, ['FatTHTop', '-fno-code -fwrite-interface']) +test('T22807', [req_th, unless(ghc_dynamic(), skip), extra_files(['T22807A.hs', 'T22807B.hs'])] + , makefile_test, ['T22807']) +test('T22807_ghci', [req_th, unless(ghc_dynamic(), skip), extra_files(['T22807_ghci.hs'])] + , makefile_test, ['T22807_ghci']) |