diff options
| -rw-r--r-- | compiler/GHC/Tc/Gen/Sig.hs | 36 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T19246.hs | 5 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T19246.stderr | 11 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T19246a.hs | 8 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 1 |
5 files changed, 52 insertions, 9 deletions
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 466191b3c7..6d6a74c65d 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -41,6 +41,7 @@ import GHC.Tc.Utils.Unify( tcSkolemise, unifyType ) import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) import GHC.Tc.Utils.Env( tcLookupId ) import GHC.Tc.Types.Evidence( HsWrapper, (<.>) ) +import GHC.Core( hasSomeUnfolding ) import GHC.Core.Type ( mkTyVarBinders ) import GHC.Core.Multiplicity @@ -48,7 +49,8 @@ import GHC.Driver.Session import GHC.Driver.Backend import GHC.Driver.Ppr import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars ) -import GHC.Types.Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) +import GHC.Types.Id ( Id, idName, idType, setInlinePragma + , mkLocalId, realIdUnfolding ) import GHC.Builtin.Names( mkUnboundName ) import GHC.Types.Basic import GHC.Unit.Module( getModule ) @@ -807,20 +809,36 @@ tcImpPrags prags tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag] tcImpSpec (name, prag) = do { id <- tcLookupId name - ; if isAnyInlinePragma (idInlinePragma id) + ; if hasSomeUnfolding (realIdUnfolding id) + -- See Note [SPECIALISE pragmas for imported Ids] then tcSpecPrag id prag else do { addWarnTc NoReason (impSpecErr name) ; return [] } } - -- If there is no INLINE/INLINABLE pragma there will be no unfolding. In - -- that case, just delete the SPECIALISE pragma altogether, lest the - -- desugarer fall over because it can't find the unfolding. See #18118. impSpecErr :: Name -> SDoc impSpecErr name = hang (text "You cannot SPECIALISE" <+> quotes (ppr name)) - 2 (vcat [ text "because its definition has no INLINE/INLINABLE pragma" - , parens $ sep - [ text "or its defining module" <+> quotes (ppr mod) - , text "was compiled without -O"]]) + 2 (vcat [ text "because its definition is not visible in this module" + , text "Hint: make sure" <+> ppr mod <+> text "is compiled with -O" + , text " and that" <+> quotes (ppr name) + <+> text "has an INLINABLE pragma" ]) where mod = nameModule name + +{- Note [SPECIALISE pragmas for imported Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An imported Id may or may not have an unfolding. If not, we obviously +can't specialise it here; indeed the desugar falls over (#18118). + +We used to test whether it had a user-specified INLINABLE pragma but, +because of Note [Worker-wrapper for INLINABLE functions] in +GHC.Core.Opt.WorkWrap, even an INLINABLE function may end up with +a wrapper that has no pragma, just an unfolding (#19246). So now +we just test whether the function has an unfolding. + +There's a risk that a pragma-free function may have an unfolding now +(because it is fairly small), and then gets a bit bigger, and no +longer has an unfolding in the future. But then you'll get a helpful +error message suggesting an INLINABLE pragma, which you can follow. +That seems enough for now. +-} diff --git a/testsuite/tests/simplCore/should_compile/T19246.hs b/testsuite/tests/simplCore/should_compile/T19246.hs new file mode 100644 index 0000000000..fba3f47b4f --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T19246.hs @@ -0,0 +1,5 @@ +module T19246 where + +import T19246a + +{-# SPECIALISE f :: [Int] -> ([Int], Int) #-} diff --git a/testsuite/tests/simplCore/should_compile/T19246.stderr b/testsuite/tests/simplCore/should_compile/T19246.stderr new file mode 100644 index 0000000000..0c7894e56d --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T19246.stderr @@ -0,0 +1,11 @@ + +==================== Tidy Core rules ==================== + + + +==================== Tidy Core rules ==================== +"SPEC f" [2] forall ($dOrd :: Ord Int). f @Int $dOrd = $sf +"SPEC/T19246 $wf @Int" [2] + forall (w :: Ord Int). $wf @Int w = $s$wf + + diff --git a/testsuite/tests/simplCore/should_compile/T19246a.hs b/testsuite/tests/simplCore/should_compile/T19246a.hs new file mode 100644 index 0000000000..7a68ff2efa --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T19246a.hs @@ -0,0 +1,8 @@ +module T19246a where + +f :: Ord a => [a] -> ([a], a) +{-# INLINABLE f #-} +f xs = (ys, maximum ys) + where + ys = reverse . reverse . reverse . reverse . reverse . reverse $ xs + diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index e892ad7194..b3936d11e6 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -345,3 +345,4 @@ test('T18815', only_ways(['optasm']), makefile_test, ['T18815']) test('T18668', normal, compile, ['-dsuppress-uniques']) test('T18995', [ grep_errmsg(r'print') ], compile, ['-O -ddump-simpl -dsuppress-uniques']) test('T19168', normal, compile, ['']) +test('T19246', only_ways(['optasm']), multimod_compile, ['T19246', '-v0 -ddump-rules']) |