More improvements to worker/wrapper

This patch fixes #21888, and simplifies finaliseArgBoxities
by eliminating the (recently introduced) data type FinalDecision.

A delicate interaction meant that this patch
   commit d1c25a48154236861a413e058ea38d1b8320273f
   Date:   Tue Jul 12 16:33:46 2022 +0100
   Refactor wantToUnboxArg a bit

make worker/wrapper go into an infinite loop.  This patch
fixes it by narrowing the handling of case (B) of
Note [Boxity for bottoming functions], to deal only the
arguemnts that are type variables.  Only then do we drop
the trimBoxity call, which is what caused the bug.

I also
* Added documentation of case (B), which was previously
  completely un-mentioned.  And a regression test,
  T21888a, to test it.

* Made unboxDeeplyDmd stop at lazy demands.  It's rare anyway
  for a bottoming function to have a lazy argument (mainly when
  the data type is recursive and then we don't want to unbox
  deeply).  Plus there is Note [No lazy, Unboxed demands in
  demand signature]

* Refactored the Case equation for dmdAnal a bit, to do less
  redundant pattern matching.

8 files changed, 143 insertions, 8 deletions

diff --git a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
index 8784af67b7..953727a119 100644
--- a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
+++ b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
@@ -1,7 +1,7 @@
 
 ==================== Strictness signatures ====================
 BottomFromInnerLambda.expensive: <1!P(SL)>
-BottomFromInnerLambda.f: <1!S><1!S>b
+BottomFromInnerLambda.f: <1!P(S)><1!P(S)>b
 
 
 
@@ -13,6 +13,6 @@ BottomFromInnerLambda.f: b
 
 ==================== Strictness signatures ====================
 BottomFromInnerLambda.expensive: <1!P(1L)>
-BottomFromInnerLambda.f: <1!P(1!S)><1!S>b
+BottomFromInnerLambda.f: <1!P(1S)><1!P(S)>b
 
 
diff --git a/testsuite/tests/stranal/sigs/T21119.stderr b/testsuite/tests/stranal/sigs/T21119.stderr
index dade4dc2a6..ca60a36995 100644
--- a/testsuite/tests/stranal/sigs/T21119.stderr
+++ b/testsuite/tests/stranal/sigs/T21119.stderr
@@ -4,7 +4,7 @@ T21119.$fMyShow(,): <1!A>
 T21119.$fMyShowInt: <1!A>
 T21119.get: <1!P(1!P(L),1!P(L))><1!P(L)><1L>
 T21119.getIO: <1P(1L,ML)><1L><ML><L>
-T21119.indexError: <1C1(S)><1!B><S!S><S!S>b
+T21119.indexError: <1C1(S)><1!B><S!S><S>b
 T21119.throwIndexError: <MC1(L)><MA><L><L><L>x
 
 
@@ -24,7 +24,7 @@ T21119.$fMyShow(,): <1!A>
 T21119.$fMyShowInt: <1!A>
 T21119.get: <1!P(1!P(L),1!P(L))><1!P(L)><1L>
 T21119.getIO: <1P(1L,ML)><1L><ML><L>
-T21119.indexError: <1C1(S)><1!B><S!S><S!S>b
+T21119.indexError: <1C1(S)><1!B><S!S><S>b
 T21119.throwIndexError: <MC1(L)><MA><L><L><L>x
 
 
diff --git a/testsuite/tests/stranal/sigs/T21888.hs b/testsuite/tests/stranal/sigs/T21888.hs
new file mode 100644
index 0000000000..7b7daec85b
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/T21888.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+module Data.MemoTrie (HasTrie(..)) where
+
+import Control.Arrow (Arrow(first))
+import Data.Bits (Bits((.|.), shiftL))
+import Data.Kind (Type)
+
+infixr 0 :->:
+
+class HasTrie a where
+    data (:->:) a :: Type -> Type
+    enumerate :: (a :->: b) -> [(a,b)]
+
+instance HasTrie () where
+  newtype () :->: a = UnitTrie a
+  enumerate (UnitTrie a) = [((),a)]
+
+instance HasTrie Bool where
+  data Bool :->: x = BoolTrie x x
+  enumerate (BoolTrie f t) = [(False,f),(True,t)]
+
+instance (HasTrie a, HasTrie b) => HasTrie (Either a b) where
+  data (Either a b) :->: x = EitherTrie (a :->: x) (b :->: x)
+  enumerate (EitherTrie s t) = enum' Left s `weave` enum' Right t
+
+enum' :: (HasTrie a) => (a -> a') -> (a :->: b) -> [(a', b)]
+enum' f = (fmap.first) f . enumerate
+
+weave :: [a] -> [a] -> [a]
+[] `weave` as = as
+as `weave` [] = as
+(a:as) `weave` bs = a : (bs `weave` as)
+
+instance (HasTrie a, HasTrie b) => HasTrie (a,b) where
+  newtype (a,b) :->: x = PairTrie (a :->: (b :->: x))
+  enumerate (PairTrie tt) =
+    [ ((a,b),x) | (a,t) <- enumerate tt , (b,x) <- enumerate t ]
+
+instance HasTrie x => HasTrie [x] where
+  newtype [x] :->: a = ListTrie (Either () (x,[x]) :->: a)
+  enumerate (ListTrie t) = enum' list t
+
+list :: Either () (x,[x]) -> [x]
+list = either (const []) (uncurry (:))
+
+unbit :: Num t => Bool -> t
+unbit False = 0
+unbit True  = 1
+
+unbits :: (Num t, Bits t) => [Bool] -> t
+unbits [] = 0
+unbits (x:xs) = unbit x .|. shiftL (unbits xs) 1
+
+instance HasTrie Integer where
+  newtype Integer :->: a = IntegerTrie ((Bool,[Bool]) :->: a)
+  enumerate (IntegerTrie t) = enum' unbitsZ t
+
+unbitsZ :: (Num n, Bits n) => (Bool,[Bool]) -> n
+unbitsZ (positive,bs) = sig (unbits bs)
+ where
+   sig | positive  = id
+       | otherwise = negate
diff --git a/testsuite/tests/stranal/sigs/T21888.stderr b/testsuite/tests/stranal/sigs/T21888.stderr
new file mode 100644
index 0000000000..26681355f0
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/T21888.stderr
@@ -0,0 +1,30 @@
+
+==================== Strictness signatures ====================
+Data.MemoTrie.$fHasTrie(): <L>
+Data.MemoTrie.$fHasTrie(,): <1C1(L)><LCS(L)><L>
+Data.MemoTrie.$fHasTrieBool: <1!P(L,L)>
+Data.MemoTrie.$fHasTrieEither: <1C1(L)><1C1(L)><1!P(L,L)>
+Data.MemoTrie.$fHasTrieInteger: <1!P(1!P(S,1!P(1!P(S,1L),1!P(S,1L))),1!P(S,1!P(1!P(S,1L),1!P(S,1L))))>b
+Data.MemoTrie.$fHasTrieList: <SCS(L)><1!P(L,L)>
+
+
+
+==================== Cpr signatures ====================
+Data.MemoTrie.$fHasTrie():
+Data.MemoTrie.$fHasTrie(,):
+Data.MemoTrie.$fHasTrieBool:
+Data.MemoTrie.$fHasTrieEither:
+Data.MemoTrie.$fHasTrieInteger:
+Data.MemoTrie.$fHasTrieList:
+
+
+
+==================== Strictness signatures ====================
+Data.MemoTrie.$fHasTrie(): <L>
+Data.MemoTrie.$fHasTrie(,): <1C1(L)><LCS(L)><L>
+Data.MemoTrie.$fHasTrieBool: <1!P(L,L)>
+Data.MemoTrie.$fHasTrieEither: <1C1(L)><1C1(L)><1!P(L,L)>
+Data.MemoTrie.$fHasTrieInteger: <1!P(1!P(B,1!P(1!P(B,1!P(L,L)),1!P(B,1!P(L,L)))),1!P(B,1!P(1!B,1!B)))>b
+Data.MemoTrie.$fHasTrieList: <SCS(L)><1!P(L,L)>
+
+
diff --git a/testsuite/tests/stranal/sigs/T21888a.hs b/testsuite/tests/stranal/sigs/T21888a.hs
new file mode 100644
index 0000000000..6a72d89ec1
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/T21888a.hs
@@ -0,0 +1,19 @@
+module T21888a where
+
+-- This tests case (B) of
+-- Note [No lazy, Unboxed demands in demand signature]
+-- in GHC.Core.Opt.DmdAnal
+
+-- We should get a worker-wrapper split on g
+-- and on wombat, even though f uses x unboxed
+
+{-# NOINLINE f #-}
+f x = Just x
+
+wombat :: Int -> a
+wombat x = error (show (f x))
+
+g :: Bool -> Int -> Int
+g True x  | x>0 = g True (x-1)
+          | otherwise = x+1
+g False x = wombat x
diff --git a/testsuite/tests/stranal/sigs/T21888a.stderr b/testsuite/tests/stranal/sigs/T21888a.stderr
new file mode 100644
index 0000000000..21127cc2a5
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/T21888a.stderr
@@ -0,0 +1,21 @@
+
+==================== Strictness signatures ====================
+T21888a.f: <L>
+T21888a.g: <1L><S!P(L)>
+T21888a.wombat: <S!P(S)>b
+
+
+
+==================== Cpr signatures ====================
+T21888a.f: 2
+T21888a.g: 1
+T21888a.wombat: b
+
+
+
+==================== Strictness signatures ====================
+T21888a.f: <L>
+T21888a.g: <1L><1!P(L)>
+T21888a.wombat: <1!P(S)>b
+
+
diff --git a/testsuite/tests/stranal/sigs/UnsatFun.stderr b/testsuite/tests/stranal/sigs/UnsatFun.stderr
index c659311b22..cb606f5c02 100644
--- a/testsuite/tests/stranal/sigs/UnsatFun.stderr
+++ b/testsuite/tests/stranal/sigs/UnsatFun.stderr
@@ -1,7 +1,7 @@
 
 ==================== Strictness signatures ====================
-UnsatFun.f: <1!S><B>b
-UnsatFun.g: <1!S>b
+UnsatFun.f: <1!P(S)><B>b
+UnsatFun.g: <1!P(S)>b
 UnsatFun.g': <MS>
 UnsatFun.g3: <A>
 UnsatFun.h: <1C1(L)>
@@ -22,8 +22,8 @@ UnsatFun.h3: 1
 
 
 ==================== Strictness signatures ====================
-UnsatFun.f: <1!S><B>b
-UnsatFun.g: <1!S>b
+UnsatFun.f: <1!P(S)><B>b
+UnsatFun.g: <1!P(S)>b
 UnsatFun.g': <MS>
 UnsatFun.g3: <A>
 UnsatFun.h: <1C1(L)>
diff --git a/testsuite/tests/stranal/sigs/all.T b/testsuite/tests/stranal/sigs/all.T
index 3ebfe287ec..211cbda94d 100644
--- a/testsuite/tests/stranal/sigs/all.T
+++ b/testsuite/tests/stranal/sigs/all.T
@@ -33,3 +33,5 @@ test('T20746', normal, compile, [''])
 test('T20746b', normal, compile, [''])
 test('T21081', normal, compile, [''])
 test('T21119', normal, compile, [''])
+test('T21888', normal, compile, [''])
+test('T21888a', normal, compile, [''])