Fix strictness and arity info in SpecConstr

In GHC.Core.Opt.SpecConstr.spec_one we were giving join-points an
incorrect join-arity -- this was fallout from

    commit c71b220491a6ae46924cc5011b80182bcc773a58
    Author: Simon Peyton Jones <simonpj@microsoft.com>
    Date:   Thu Apr 8 23:36:24 2021 +0100

        Improvements in SpecConstr

        * Allow under-saturated calls to specialise
          See Note [SpecConstr call patterns]
          This just allows a bit more specialisation to take place.

and showed up in #19780. I refactored the code to make the new
function calcSpecInfo which treats join points separately.

In doing this I discovered two other small bugs:

* In the Var case of argToPat we were treating UnkOcc as
  uninteresting, but (by omission) NoOcc as interesting. As a
  result we were generating SpecConstr specialisations for functions
  with unused arguments.  But the absence anlyser does that much
  better; doing it here just generates more code.  Easily fixed.

* The lifted/unlifted test in GHC.Core.Opt.WorkWrap.Utils.mkWorkerArgs
  was back to front (#19794).  Easily fixed.

* In the same function, mkWorkerArgs, we were adding an extra argument
  nullary join points, which isn't necessary.  I added a test for
  this.  That in turn meant I had to remove an ASSERT in
  CoreToStg.mkStgRhs for nullary join points, which was always bogus
  but now trips; I added a comment to explain.

4 files changed, 126 insertions, 15 deletions

diff --git a/testsuite/tests/simplCore/should_compile/T18328.stderr b/testsuite/tests/simplCore/should_compile/T18328.stderr
index d32f553114..78e3430b88 100644
--- a/testsuite/tests/simplCore/should_compile/T18328.stderr
+++ b/testsuite/tests/simplCore/should_compile/T18328.stderr
@@ -1,38 +1,38 @@
 
 ==================== Tidy Core ====================
 Result size of Tidy Core
-  = {terms: 69, types: 61, coercions: 0, joins: 1/1}
+  = {terms: 65, types: 53, coercions: 0, joins: 1/1}
 
--- RHS size: {terms: 42, types: 28, coercions: 0, joins: 1/1}
+-- RHS size: {terms: 38, types: 23, coercions: 0, joins: 1/1}
 T18328.$wf [InlPrag=[2]]
   :: forall {a}. GHC.Prim.Int# -> [a] -> [a] -> [a]
 [GblId,
  Arity=3,
- Str=<SU><U><U>,
+ Str=<SL><SL><ML>,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [182 0 0] 312 0}]
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [176 0 0] 306 0}]
 T18328.$wf
   = \ (@a) (ww :: GHC.Prim.Int#) (w :: [a]) (w1 :: [a]) ->
       join {
-        $wj [InlPrag=NOINLINE, Dmd=1C1(U)] :: forall {p}. (# #) -> [a]
-        [LclId[JoinId(2)], Arity=1, Str=<A>, Unf=OtherCon []]
-        $wj (@p) _ [Occ=Dead, OS=OneShot]
+        $wj [InlPrag=NOINLINE, Dmd=ML] :: forall {p}. [a]
+        [LclId[JoinId(1)]]
+        $wj (@p)
           = case ww of {
               __DEFAULT -> ++ @a w (++ @a w (++ @a w w1));
               3# -> ++ @a w (++ @a w (++ @a w (++ @a w w1)))
             } } in
       case ww of {
         __DEFAULT -> ++ @a w w1;
-        1# -> jump $wj @Integer GHC.Prim.(##);
-        2# -> jump $wj @Integer GHC.Prim.(##);
-        3# -> jump $wj @Integer GHC.Prim.(##)
+        1# -> jump $wj @Integer;
+        2# -> jump $wj @Integer;
+        3# -> jump $wj @Integer
       }
 
--- RHS size: {terms: 11, types: 10, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 11, types: 9, coercions: 0, joins: 0/0}
 f [InlPrag=[2]] :: forall a. Int -> [a] -> [a] -> [a]
 [GblId,
  Arity=3,
- Str=<S(SU)><U><U>,
+ Str=<1P(SL)><SL><ML>,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=False)
@@ -40,11 +40,11 @@ f [InlPrag=[2]] :: forall a. Int -> [a] -> [a] -> [a]
                  (w [Occ=Once1!] :: Int)
                  (w1 [Occ=Once1] :: [a])
                  (w2 [Occ=Once1] :: [a]) ->
-                 case w of { GHC.Types.I# ww1 [Occ=Once1] ->
-                 T18328.$wf @a ww1 w1 w2
+                 case w of { GHC.Types.I# ww [Occ=Once1] ->
+                 T18328.$wf @a ww w1 w2
                  }}]
 f = \ (@a) (w :: Int) (w1 :: [a]) (w2 :: [a]) ->
-      case w of { GHC.Types.I# ww1 -> T18328.$wf @a ww1 w1 w2 }
+      case w of { GHC.Types.I# ww -> T18328.$wf @a ww w1 w2 }
 
 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
 T18328.$trModule4 :: GHC.Prim.Addr#
diff --git a/testsuite/tests/simplCore/should_compile/T19780.hs b/testsuite/tests/simplCore/should_compile/T19780.hs
new file mode 100644
index 0000000000..5acc896f60
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T19780.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE BangPatterns #-}
+module Data.ByteString.Search.DFA (strictSearcher) where
+
+import qualified Data.ByteString as S
+import Data.ByteString.Unsafe (unsafeIndex)
+
+import Control.Monad (when)
+import Data.Array.Base (unsafeRead, unsafeWrite, unsafeAt)
+import Data.Array.ST (newArray, newArray_, runSTUArray)
+import Data.Array.Unboxed (UArray)
+import Data.Bits (Bits(..))
+import Data.Word (Word8)
+
+------------------------------------------------------------------------------
+--                            Searching Function                            --
+------------------------------------------------------------------------------
+
+strictSearcher :: Bool -> S.ByteString -> S.ByteString -> [Int]
+strictSearcher _ !pat
+    | S.null pat = enumFromTo 0 . S.length
+    | S.length pat == 1 = let !w = S.head pat in S.elemIndices w
+strictSearcher !overlap pat = search
+  where
+    !patLen = S.length pat
+    !auto   = automaton pat
+    !p0     = unsafeIndex pat 0
+    !ams    = if overlap then patLen else 0
+    search str = match 0 0
+      where
+        !strLen = S.length str
+        {-# INLINE strAt #-}
+        strAt :: Int -> Int
+        strAt !i = fromIntegral (unsafeIndex str i)
+        match 0 idx
+          | idx == strLen               = []
+          | unsafeIndex str idx == p0   = match 1 (idx + 1)
+          | otherwise                   = match 0 (idx + 1)
+        match state idx
+          | idx == strLen   = []
+          | otherwise       =
+            let !nstate = unsafeAt auto ((state `shiftL` 8) + strAt idx)
+                !nxtIdx = idx + 1
+            in if nstate == patLen
+                then (nxtIdx - patLen) : match ams nxtIdx
+                else match nstate nxtIdx
+
+------------------------------------------------------------------------------
+--                              Preprocessing                               --
+------------------------------------------------------------------------------
+
+{-# INLINE automaton #-}
+automaton :: S.ByteString -> UArray Int Int
+automaton !pat = runSTUArray (do
+    let !patLen = S.length pat
+        {-# INLINE patAt #-}
+        patAt !i = fromIntegral (unsafeIndex pat i)
+        !bord = kmpBorders pat
+    aut <- newArray (0, (patLen + 1)*256 - 1) 0
+    unsafeWrite aut (patAt 0) 1
+    let loop !state = do
+            let !base = state `shiftL` 8
+                inner j
+                    | j < 0     = if state == patLen
+                                    then return aut
+                                    else loop (state+1)
+                    | otherwise = do
+                        let !i = base + patAt j
+                        s <- unsafeRead aut i
+                        when (s == 0) (unsafeWrite aut i (j+1))
+                        inner (unsafeAt bord j)
+            if state == patLen
+                then inner (unsafeAt bord state)
+                else inner state
+    loop 1)
+
+-- kmpBorders calculates the width of the widest borders of the prefixes
+-- of the pattern which are not extensible to borders of the next
+-- longer prefix. Most entries will be 0.
+{-# INLINE kmpBorders #-}
+kmpBorders :: S.ByteString -> UArray Int Int
+kmpBorders pat = runSTUArray (do
+    let !patLen = S.length pat
+        {-# INLINE patAt #-}
+        patAt :: Int -> Word8
+        patAt i = unsafeIndex pat i
+    ar <- newArray_ (0, patLen)
+    unsafeWrite ar 0 (-1)
+    let dec w j
+            | j < 0 || w == patAt j = return $! j+1
+            | otherwise = unsafeRead ar j >>= dec w
+        bordLoop !i !j
+            | patLen < i    = return ar
+            | otherwise     = do
+                let !w = patAt (i-1)
+                j' <- dec w j
+                if i < patLen && patAt j' == patAt i
+                    then unsafeRead ar j' >>= unsafeWrite ar i
+                    else unsafeWrite ar i j'
+                bordLoop (i+1) j'
+    bordLoop 1 (-1))
diff --git a/testsuite/tests/simplCore/should_compile/T19794.hs b/testsuite/tests/simplCore/should_compile/T19794.hs
new file mode 100644
index 0000000000..c8f6897468
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T19794.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE MagicHash #-}
+{-# OPTIONS_GHC -ffun-to-thunk #-}   -- This is essential for the test
+
+module Foo where
+import GHC.Exts
+
+f :: Int -> Int#
+f x = f (x+1)
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 935c10d6fc..e0f4338328 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -361,3 +361,6 @@ test('T13873',  [ grep_errmsg(r'SPEC') ], compile, ['-O -ddump-rules'])
 
 # Look for a specialisation rule for wimwam
 test('T19672', normal, compile, ['-O2 -ddump-rules'])
+
+test('T19780', normal, compile, ['-O2'])
+test('T19794', normal, compile, ['-O'])