Improve specialisation for imported functionswip/T19246

At a SPECIALSE pragma for an imported Id, we used to check that
it was marked INLINABLE.  But that turns out to interact badly with
worker/wrapper: see Note [Worker-wrapper for INLINABLE functions] in
GHC.Core.Opt.WorkWrap.

So this small patch instead simply tests that we have an unfolding
for the function; see Note [SPECIALISE pragmas for imported Ids]
in GHC.Tc.Gen.Sig.

Fixes #19246

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'])