Add missing dict binds to specialiserwip/T21470

I had forgotten to add the auxiliary dict bindings to the
/unfolding/ of a specialised function.  This caused #22358,
which reports failures when compiling Hackage packages
     fixed-vector
     indexed-traversable

Regression test T22357 is snarfed from indexed-traversable

4 files changed, 741 insertions, 14 deletions

diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index d7f29afd6c..7d7f37b741 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -1627,8 +1627,8 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
            ; (rhs_body', rhs_uds) <- specExpr rhs_env2 rhs_body
                 -- Add the { d1' = dx1; d2' = dx2 } usage stuff
                 -- to the rhs_uds; see Note [Specialising Calls]
-           ; let rhs_uds_w_dx = foldr consDictBind rhs_uds dx_binds
-                 spec_rhs_bndrs  = spec_bndrs1 ++ leftover_bndrs
+           ; let rhs_uds_w_dx   = dx_binds `consDictBinds` rhs_uds
+                 spec_rhs_bndrs = spec_bndrs1 ++ leftover_bndrs
                  (spec_uds, dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds_w_dx
                  spec_rhs1 = mkLams spec_rhs_bndrs $
                              wrapDictBindsE dumped_dbs rhs_body'
@@ -1671,7 +1671,10 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
 
                 --------------------------------------
                 -- Add a suitable unfolding; see Note [Inline specialisations]
-                spec_unf = specUnfolding simpl_opts spec_bndrs (`mkApps` spec_args)
+                -- The wrap_unf_body applies the original unfolding to the specialised
+                -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)
+                wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds
+                spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body
                                          rule_lhs_args fn_unf
 
                 spec_inl_prag
@@ -3048,11 +3051,6 @@ snocDictBinds uds@MkUD{ud_binds=FDB{ fdb_binds = binds, fdb_bndrs = bs }} dbs
   = uds { ud_binds = FDB { fdb_binds = binds `appOL`        (toOL dbs)
                          , fdb_bndrs = bs    `extendVarSetList` bindersOfDictBinds dbs } }
 
-consDictBind :: DictBind -> UsageDetails -> UsageDetails
-consDictBind db uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs=bs}}
-  = uds { ud_binds = FDB { fdb_binds = db `consOL` binds
-                         , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } }
-
 consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails
 consDictBinds dbs uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}}
   = uds { ud_binds = FDB{ fdb_binds = toOL dbs `appOL` binds
diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs
index e545f4a9f3..adbbdec763 100644
--- a/compiler/GHC/Core/Unfold/Make.hs
+++ b/compiler/GHC/Core/Unfold/Make.hs
@@ -227,14 +227,15 @@ specUnfolding to specialise its unfolding.  Some important points:
   This happens with Control.Monad.liftM3, and can cause a lot more
   allocation as a result (nofib n-body shows this).
 
-  Moreover, keeping the stable unfoldign isn't much help, because
+  Moreover, keeping the stable unfolding isn't much help, because
   the specialised function (probably) isn't overloaded any more.
 
-  TL;DR: we simply drop the stable unfolding when specialising. It's
-  not really a complete solution; ignoring specialisation for now,
-  INLINABLE functions don't get properly strictness analysed, for
-  example. But it works well for examples involving specialisation,
-  which is the dominant use of INLINABLE.
+  TL;DR: we simply drop the stable unfolding when specialising. It's not
+  really a complete solution; ignoring specialisation for now, INLINABLE
+  functions don't get properly strictness analysed, for example.
+  Moreover, it means that the specialised function has an INLINEABLE
+  pragma, but no stable unfolding. But it works well for examples
+  involving specialisation, which is the dominant use of INLINABLE.
 
 Note [Honour INLINE on 0-ary bindings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/testsuite/tests/simplCore/should_compile/T22357.hs b/testsuite/tests/simplCore/should_compile/T22357.hs
new file mode 100644
index 0000000000..1e100cfa23
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T22357.hs
@@ -0,0 +1,727 @@
+{-# LANGUAGE CPP                    #-}
+{-# LANGUAGE BangPatterns           #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs                  #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE UndecidableInstances   #-}
+
+#if __GLASGOW_HASKELL__ >= 702
+{-# LANGUAGE Trustworthy            #-}
+{-# LANGUAGE DefaultSignatures      #-}
+#endif
+
+#if __GLASGOW_HASKELL__ >= 706
+{-# LANGUAGE PolyKinds #-}
+#endif
+module WithIndex where
+
+import Prelude
+       (Either (..), Functor (..), Int, Maybe (..), Monad (..), Num (..), error,
+       flip, id, seq, snd, ($!), ($), (.), zip)
+
+import Control.Applicative
+       (Applicative (..), Const (..), ZipList (..), (<$>), liftA2)
+import Control.Applicative.Backwards (Backwards (..))
+import Control.Monad.Trans.Identity  (IdentityT (..))
+import Control.Monad.Trans.Reader    (ReaderT (..))
+import Data.Array                    (Array)
+import Data.Foldable                 (Foldable (..))
+import Data.Functor.Compose          (Compose (..))
+import Data.Functor.Constant         (Constant (..))
+import Data.Functor.Identity         (Identity (..))
+import Data.Functor.Product          (Product (..))
+import Data.Functor.Reverse          (Reverse (..))
+import Data.Functor.Sum              (Sum (..))
+import Data.IntMap                   (IntMap)
+import Data.Ix                       (Ix (..))
+import Data.List.NonEmpty            (NonEmpty (..))
+import Data.Map                      (Map)
+import Data.Monoid                   (Dual (..), Endo (..), Monoid (..))
+import Data.Proxy                    (Proxy (..))
+import Data.Semigroup                (Semigroup (..))
+import Data.Sequence                 (Seq)
+import Data.Traversable              (Traversable (..))
+import Data.Tree                     (Tree (..))
+import Data.Void                     (Void)
+
+#if __GLASGOW_HASKELL__ >= 702
+import GHC.Generics
+       (K1 (..), Par1 (..), Rec1 (..), U1 (..), V1, (:*:) (..), (:+:) (..),
+       (:.:) (..))
+#else
+import Generics.Deriving
+       (K1 (..), Par1 (..), Rec1 (..), U1 (..), V1, (:*:) (..), (:+:) (..),
+       (:.:) (..))
+#endif
+
+import Data.Type.Equality
+import qualified Data.Array    as Array
+import qualified Data.IntMap   as IntMap
+import qualified Data.Map      as Map
+import qualified Data.Sequence as Seq
+
+#ifdef MIN_VERSION_base_orphans
+import Data.Orphans ()
+#endif
+
+#if __GLASGOW_HASKELL__ >=708
+import Data.Coerce (Coercible, coerce)
+#else
+import Unsafe.Coerce (unsafeCoerce)
+#endif
+
+-------------------------------------------------------------------------------
+-- FunctorWithIndex
+-------------------------------------------------------------------------------
+
+-- | A 'Functor' with an additional index.
+--
+-- Instances must satisfy a modified form of the 'Functor' laws:
+--
+-- @
+-- 'imap' f '.' 'imap' g ≡ 'imap' (\\i -> f i '.' g i)
+-- 'imap' (\\_ a -> a) ≡ 'id'
+-- @
+class Functor f => FunctorWithIndex i f | f -> i where
+  -- | Map with access to the index.
+  imap :: (i -> a -> b) -> f a -> f b
+
+#if __GLASGOW_HASKELL__ >= 704
+  default imap :: TraversableWithIndex i f => (i -> a -> b) -> f a -> f b
+  imap = imapDefault
+  {-# INLINE imap #-}
+#endif
+
+imapDefault :: TraversableWithIndex i f => (i -> a -> b) -> f a -> f b
+-- imapDefault f = runIdentity #. itraverse (\i a -> Identity (f i a))
+imapDefault f = runIdentity #. itraverse (Identity #.. f)
+{-# INLINE imapDefault #-}
+
+-------------------------------------------------------------------------------
+-- FoldableWithIndex
+-------------------------------------------------------------------------------
+
+-- | A container that supports folding with an additional index.
+class Foldable f => FoldableWithIndex i f | f -> i where
+  --
+  -- | Fold a container by mapping value to an arbitrary 'Monoid' with access to the index @i@.
+  --
+  -- When you don't need access to the index then 'foldMap' is more flexible in what it accepts.
+  --
+  -- @
+  -- 'foldMap' ≡ 'ifoldMap' '.' 'const'
+  -- @
+  ifoldMap :: Monoid m => (i -> a -> m) -> f a -> m
+
+#if __GLASGOW_HASKELL__ >= 704
+  default ifoldMap :: (TraversableWithIndex i f, Monoid m) => (i -> a -> m) -> f a -> m
+  ifoldMap = ifoldMapDefault
+  {-# INLINE ifoldMap #-}
+#endif
+
+  -- | A variant of 'ifoldMap' that is strict in the accumulator.
+  --
+  -- When you don't need access to the index then 'Data.Foldable.foldMap'' is more flexible in what it accepts.
+  --
+  -- @
+  -- 'foldMap'' ≡ 'ifoldMap'' '.' 'const'
+  -- @
+  ifoldMap' :: Monoid m => (i -> a -> m) -> f a -> m
+  ifoldMap' f = ifoldl' (\i acc a -> mappend acc (f i a)) mempty
+  {-# INLINE ifoldMap' #-}
+
+  -- | Right-associative fold of an indexed container with access to the index @i@.
+  --
+  -- When you don't need access to the index then 'Data.Foldable.foldr' is more flexible in what it accepts.
+  --
+  -- @
+  -- 'Data.Foldable.foldr' ≡ 'ifoldr' '.' 'const'
+  -- @
+  ifoldr   :: (i -> a -> b -> b) -> b -> f a -> b
+  ifoldr f z t = appEndo (ifoldMap (Endo #.. f) t) z
+  {-# INLINE ifoldr #-}
+
+  -- | Left-associative fold of an indexed container with access to the index @i@.
+  --
+  -- When you don't need access to the index then 'Data.Foldable.foldl' is more flexible in what it accepts.
+  --
+  -- @
+  -- 'Data.Foldable.foldl' ≡ 'ifoldl' '.' 'const'
+  -- @
+  ifoldl :: (i -> b -> a -> b) -> b -> f a -> b
+  ifoldl f z t = appEndo (getDual (ifoldMap (\ i -> Dual #. Endo #. flip (f i)) t)) z
+  {-# INLINE ifoldl #-}
+
+  -- | /Strictly/ fold right over the elements of a structure with access to the index @i@.
+  --
+  -- When you don't need access to the index then 'foldr'' is more flexible in what it accepts.
+  --
+  -- @
+  -- 'foldr'' ≡ 'ifoldr'' '.' 'const'
+  -- @
+  ifoldr' :: (i -> a -> b -> b) -> b -> f a -> b
+  ifoldr' f z0 xs = ifoldl f' id xs z0
+    where f' i k x z = k $! f i x z
+  {-# INLINE ifoldr' #-}
+
+  -- | Fold over the elements of a structure with an index, associating to the left, but /strictly/.
+  --
+  -- When you don't need access to the index then 'Control.Lens.Fold.foldlOf'' is more flexible in what it accepts.
+  --
+  -- @
+  -- 'Data.Foldable.foldl'' l ≡ 'ifoldl'' l '.' 'const'
+  -- @
+  ifoldl' :: (i -> b -> a -> b) -> b -> f a -> b
+  ifoldl' f z0 xs = ifoldr f' id xs z0
+    where f' i x k z = k $! f i z x
+  {-# INLINE ifoldl' #-}
+
+ifoldMapDefault :: (TraversableWithIndex i f, Monoid m) => (i -> a -> m) -> f a -> m
+ifoldMapDefault f = getConst #. itraverse (Const #.. f)
+{-# INLINE ifoldMapDefault #-}
+
+-------------------------------------------------------------------------------
+-- TraversableWithIndex
+-------------------------------------------------------------------------------
+
+-- | A 'Traversable' with an additional index.
+--
+-- An instance must satisfy a (modified) form of the 'Traversable' laws:
+--
+-- @
+-- 'itraverse' ('const' 'Identity') ≡ 'Identity'
+-- 'fmap' ('itraverse' f) '.' 'itraverse' g ≡ 'Data.Functor.Compose.getCompose' '.' 'itraverse' (\\i -> 'Data.Functor.Compose.Compose' '.' 'fmap' (f i) '.' g i)
+-- @
+class (FunctorWithIndex i t, FoldableWithIndex i t, Traversable t) => TraversableWithIndex i t | t -> i where
+  -- | Traverse an indexed container.
+  --
+  -- @
+  -- 'itraverse' ≡ 'itraverseOf' 'itraversed'
+  -- @
+  itraverse :: Applicative f => (i -> a -> f b) -> t a -> f (t b)
+
+#if __GLASGOW_HASKELL__ >= 704
+  default itraverse :: (i ~ Int, Applicative f) => (i -> a -> f b) -> t a -> f (t b)
+  itraverse f s = snd $ runIndexing (traverse (\a -> Indexing (\i -> i `seq` (i + 1, f i a))) s) 0
+  {-# INLINE itraverse #-}
+#endif
+
+-------------------------------------------------------------------------------
+-- base
+-------------------------------------------------------------------------------
+
+instance FunctorWithIndex r ((->) r) where
+  imap f g x = f x (g x)
+  {-# INLINE imap #-}
+
+instance FunctorWithIndex () Maybe where
+  imap f = fmap (f ())
+  {-# INLINE imap #-}
+instance FoldableWithIndex () Maybe where
+  ifoldMap f = foldMap (f ())
+  {-# INLINE ifoldMap #-}
+instance TraversableWithIndex () Maybe where
+  itraverse f = traverse (f ())
+  {-# INLINE itraverse #-}
+
+instance FunctorWithIndex Void Proxy where
+  imap _ Proxy = Proxy
+  {-# INLINE imap #-}
+
+instance FoldableWithIndex Void Proxy where
+  ifoldMap _ _ = mempty
+  {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex Void Proxy where
+  itraverse _ _ = pure Proxy
+  {-# INLINE itraverse #-}
+
+instance FunctorWithIndex k ((,) k) where
+  imap f (k,a) = (k, f k a)
+  {-# INLINE imap #-}
+
+instance FoldableWithIndex k ((,) k) where
+  ifoldMap = uncurry'
+  {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex k ((,) k) where
+  itraverse f (k, a) = (,) k <$> f k a
+  {-# INLINE itraverse #-}
+
+-- | The position in the list is available as the index.
+instance FunctorWithIndex Int [] where
+  imap f = go 0 where
+    go !_ []     = []
+    go !n (x:xs) = f n x : go (n + 1) xs
+  {-# INLINE imap #-}
+instance FoldableWithIndex Int [] where
+  ifoldMap = ifoldMapDefault
+  {-# INLINE ifoldMap #-}
+  ifoldr f z = go 0 where
+    go !_ []     = z
+    go !n (x:xs) = f n x (go (n + 1) xs)
+  {-# INLINE ifoldr #-}
+instance TraversableWithIndex Int [] where
+  itraverse f = traverse (uncurry' f) . zip [0..]
+  {-# INLINE itraverse #-}
+
+-- TODO: we could experiment with streaming framework
+-- imapListFB f xs = build (\c n -> ifoldr (\i a -> c (f i a)) n xs)
+
+-- | Same instance as for @[]@.
+instance FunctorWithIndex Int ZipList where
+  imap f (ZipList xs) = ZipList (imap f xs)
+  {-# INLINE imap #-}
+instance FoldableWithIndex Int ZipList where
+  ifoldMap f (ZipList xs) = ifoldMap f xs
+  {-# INLINE ifoldMap #-}
+instance TraversableWithIndex Int ZipList where
+  itraverse f (ZipList xs) = ZipList <$> itraverse f xs
+  {-# INLINE itraverse #-}
+
+-------------------------------------------------------------------------------
+-- (former) semigroups
+-------------------------------------------------------------------------------
+
+instance FunctorWithIndex Int NonEmpty where
+  imap = imapDefault
+  {-# INLINE imap #-}
+instance FoldableWithIndex Int NonEmpty where
+  ifoldMap = ifoldMapDefault
+  {-# INLINE ifoldMap #-}
+instance TraversableWithIndex Int NonEmpty where
+  itraverse f ~(a :| as) =
+    liftA2 (:|) (f 0 a) (traverse (uncurry' f) (zip [1..] as))
+  {-# INLINE itraverse #-}
+
+-------------------------------------------------------------------------------
+-- Functors (formely) from transformers
+-------------------------------------------------------------------------------
+
+instance FunctorWithIndex () Identity where
+  imap f (Identity a) = Identity (f () a)
+  {-# INLINE imap #-}
+
+instance FoldableWithIndex () Identity where
+  ifoldMap f (Identity a) = f () a
+  {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex () Identity where
+  itraverse f (Identity a) = Identity <$> f () a
+  {-# INLINE itraverse #-}
+
+instance FunctorWithIndex Void (Const e) where
+  imap _ (Const a) = Const a
+  {-# INLINE imap #-}
+
+instance FoldableWithIndex Void (Const e) where
+  ifoldMap _ _ = mempty
+  {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex Void (Const e) where
+  itraverse _ (Const a) = pure (Const a)
+  {-# INLINE itraverse #-}
+
+instance FunctorWithIndex Void (Constant e) where
+  imap _ (Constant a) = Constant a
+  {-# INLINE imap #-}
+
+instance FoldableWithIndex Void (Constant e) where
+  ifoldMap _ _ = mempty
+  {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex Void (Constant e) where
+  itraverse _ (Constant a) = pure (Constant a)
+  {-# INLINE itraverse #-}
+
+instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (i, j) (Compose f g) where
+  imap f (Compose fg) = Compose $ imap (\k -> imap (f . (,) k)) fg
+  {-# INLINE imap #-}
+
+instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (i, j) (Compose f g) where
+  ifoldMap f (Compose fg) = ifoldMap (\k -> ifoldMap (f . (,) k)) fg
+  {-# INLINE ifoldMap #-}
+
+instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (i, j) (Compose f g) where
+  itraverse f (Compose fg) = Compose <$> itraverse (\k -> itraverse (f . (,) k)) fg
+  {-# INLINE itraverse #-}
+
+instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (Either i j) (Sum f g) where
+  imap q (InL fa) = InL (imap (q . Left)  fa)
+  imap q (InR ga) = InR (imap (q . Right) ga)
+  {-# INLINE imap #-}
+
+instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (Either i j) (Sum f g) where
+  ifoldMap q (InL fa) = ifoldMap (q . Left)  fa
+  ifoldMap q (InR ga) = ifoldMap (q . Right) ga
+  {-# INLINE ifoldMap #-}
+
+instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (Either i j) (Sum f g) where
+  itraverse q (InL fa) = InL <$> itraverse (q . Left)  fa
+  itraverse q (InR ga) = InR <$> itraverse (q . Right) ga
+  {-# INLINE itraverse #-}
+
+instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (Either i j) (Product f g) where
+  imap f (Pair a b) = Pair (imap (f . Left) a) (imap (f . Right) b)
+  {-# INLINE imap #-}
+
+instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (Either i j) (Product f g) where
+  ifoldMap f (Pair a b) = ifoldMap (f . Left) a `mappend` ifoldMap (f . Right) b
+  {-# INLINE ifoldMap #-}
+
+instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (Either i j) (Product f g) where
+  itraverse f (Pair a b) = liftA2 Pair (itraverse (f . Left) a) (itraverse (f . Right) b)
+  {-# INLINE itraverse #-}
+
+-------------------------------------------------------------------------------
+-- transformers
+-------------------------------------------------------------------------------
+
+instance FunctorWithIndex i m => FunctorWithIndex i (IdentityT m) where
+  imap f (IdentityT m) = IdentityT $ imap f m
+  {-# INLINE imap #-}
+
+instance FoldableWithIndex i m => FoldableWithIndex i (IdentityT m) where
+  ifoldMap f (IdentityT m) = ifoldMap f m
+  {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex i m => TraversableWithIndex i (IdentityT m) where
+  itraverse f (IdentityT m) = IdentityT <$> itraverse f m
+  {-# INLINE itraverse #-}
+
+instance FunctorWithIndex i m => FunctorWithIndex (e, i) (ReaderT e m) where
+  imap f (ReaderT m) = ReaderT $ \k -> imap (f . (,) k) (m k)
+  {-# INLINE imap #-}
+
+instance FunctorWithIndex i f => FunctorWithIndex i (Backwards f) where
+  imap f  = Backwards . imap f . forwards
+  {-# INLINE imap #-}
+
+instance FoldableWithIndex i f => FoldableWithIndex i (Backwards f) where
+  ifoldMap f = ifoldMap f . forwards
+  {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex i f => TraversableWithIndex i (Backwards f) where
+  itraverse f = fmap Backwards . itraverse f . forwards
+  {-# INLINE itraverse #-}
+
+instance FunctorWithIndex i f => FunctorWithIndex i (Reverse f) where
+  imap f = Reverse . imap f . getReverse
+  {-# INLINE imap #-}
+
+instance FoldableWithIndex i f => FoldableWithIndex i (Reverse f) where
+  ifoldMap f = getDual #. ifoldMap (Dual #.. f) . getReverse
+  {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex i f => TraversableWithIndex i (Reverse f) where
+  itraverse f = fmap Reverse . forwards . itraverse (Backwards #.. f) . getReverse
+  {-# INLINE itraverse #-}
+
+-------------------------------------------------------------------------------
+-- array
+-------------------------------------------------------------------------------
+
+instance Ix i => FunctorWithIndex i (Array i) where
+  imap f arr = Array.listArray (Array.bounds arr) . fmap (uncurry' f) $ Array.assocs arr
+  {-# INLINE imap #-}
+
+instance Ix i => FoldableWithIndex i (Array i) where
+  ifoldMap f = foldMap (uncurry' f) . Array.assocs
+  {-# INLINE ifoldMap #-}
+
+instance Ix i => TraversableWithIndex i (Array i) where
+  itraverse f arr = Array.listArray (Array.bounds arr) <$> traverse (uncurry' f) (Array.assocs arr)
+  {-# INLINE itraverse #-}
+
+-------------------------------------------------------------------------------
+-- containers
+-------------------------------------------------------------------------------
+
+instance FunctorWithIndex [Int] Tree where
+  imap f (Node a as) = Node (f [] a) $ imap (\i -> imap (f . (:) i)) as
+  {-# INLINE imap #-}
+
+instance FoldableWithIndex [Int] Tree where
+  ifoldMap f (Node a as) = f [] a `mappend` ifoldMap (\i -> ifoldMap (f . (:) i)) as
+  {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex [Int] Tree where
+  itraverse f (Node a as) = liftA2 Node (f [] a) (itraverse (\i -> itraverse (f . (:) i)) as)
+  {-# INLINE itraverse #-}
+--
+-- | The position in the 'Seq' is available as the index.
+instance FunctorWithIndex Int Seq where
+  imap = Seq.mapWithIndex
+  {-# INLINE imap #-}
+instance FoldableWithIndex Int Seq where
+#if MIN_VERSION_containers(0,5,8)
+  ifoldMap = Seq.foldMapWithIndex
+#else
+  ifoldMap f = Data.Foldable.fold . Seq.mapWithIndex f
+#endif
+  {-# INLINE ifoldMap #-}
+  ifoldr = Seq.foldrWithIndex
+  {-# INLINE ifoldr #-}
+  ifoldl f = Seq.foldlWithIndex (flip f)
+  {-# INLINE ifoldl #-}
+instance TraversableWithIndex Int Seq where
+#if MIN_VERSION_containers(0,6,0)
+  itraverse = Seq.traverseWithIndex
+#else
+  -- Much faster than Seq.traverseWithIndex for containers < 0.6.0, see
+  -- https://github.com/haskell/containers/issues/603.
+  itraverse f = sequenceA . Seq.mapWithIndex f
+#endif
+  {-# INLINE itraverse #-}
+
+instance FunctorWithIndex Int IntMap where
+  imap = IntMap.mapWithKey 
+  {-# INLINE imap #-}
+
+instance FoldableWithIndex Int IntMap where
+#if MIN_VERSION_containers(0,5,4)
+  ifoldMap = IntMap.foldMapWithKey
+#else
+  ifoldMap = ifoldMapDefault
+#endif
+  {-# INLINE ifoldMap #-}
+#if MIN_VERSION_containers(0,5,0)
+  ifoldr   = IntMap.foldrWithKey
+  ifoldl'  = IntMap.foldlWithKey' . flip
+  {-# INLINE ifoldr #-}
+  {-# INLINE ifoldl' #-}
+#endif
+
+instance TraversableWithIndex Int IntMap where
+#if MIN_VERSION_containers(0,5,0)
+  itraverse = IntMap.traverseWithKey
+#else
+  itraverse f = sequenceA . IntMap.mapWithKey f
+#endif
+  {-# INLINE itraverse #-}
+
+instance FunctorWithIndex k (Map k) where
+  imap = Map.mapWithKey
+  {-# INLINE imap #-}
+  
+instance FoldableWithIndex k (Map k) where
+#if MIN_VERSION_containers(0,5,4)
+  ifoldMap = Map.foldMapWithKey
+#else
+  ifoldMap = ifoldMapDefault
+#endif
+  {-# INLINE ifoldMap #-}
+#if MIN_VERSION_containers(0,5,0)
+  ifoldr   = Map.foldrWithKey
+  ifoldl'  = Map.foldlWithKey' . flip
+  {-# INLINE ifoldr #-}
+  {-# INLINE ifoldl' #-}
+#endif
+
+instance TraversableWithIndex k (Map k) where
+#if MIN_VERSION_containers(0,5,0)
+  itraverse = Map.traverseWithKey
+#else
+  itraverse f = sequenceA . Map.mapWithKey f
+#endif
+  {-# INLINE itraverse #-}
+
+-------------------------------------------------------------------------------
+-- GHC.Generics
+-------------------------------------------------------------------------------
+
+instance FunctorWithIndex Void V1 where
+  imap _ v = v `seq` error "imap @V1"
+  {-# INLINE imap #-}
+
+instance FoldableWithIndex Void V1 where
+  ifoldMap _ v = v `seq` error "ifoldMap @V1"
+
+instance TraversableWithIndex Void V1 where
+  itraverse _ v = v `seq` error "itraverse @V1"
+
+instance FunctorWithIndex Void U1 where
+  imap _ U1 = U1
+  {-# INLINE imap #-}
+
+instance FoldableWithIndex Void U1 where
+  ifoldMap _ _ = mempty
+  {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex Void U1 where
+  itraverse _ U1 = pure U1
+  {-# INLINE itraverse #-}
+
+instance FunctorWithIndex () Par1 where
+  imap f = fmap (f ())
+  {-# INLINE imap #-}
+
+instance FoldableWithIndex () Par1 where
+  ifoldMap f (Par1 a) = f () a
+  {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex () Par1 where
+  itraverse f (Par1 a) = Par1 <$> f () a
+  {-# INLINE itraverse #-}
+
+instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (i, j) (f :.: g) where
+  imap q (Comp1 fga) = Comp1 (imap (\k -> imap (q . (,) k)) fga)
+  {-# INLINE imap #-}
+
+instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (i, j) (f :.: g) where
+  ifoldMap q (Comp1 fga) = ifoldMap (\k -> ifoldMap (q . (,) k)) fga
+  {-# INLINE ifoldMap #-}
+
+instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (i, j) (f :.: g) where
+  itraverse q (Comp1 fga) = Comp1 <$> itraverse (\k -> itraverse (q . (,) k)) fga
+  {-# INLINE itraverse #-}
+
+instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (Either i j) (f :*: g) where
+  imap q (fa :*: ga) = imap (q . Left) fa :*: imap (q . Right) ga
+  {-# INLINE imap #-}
+
+instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (Either i j) (f :*: g) where
+  ifoldMap q (fa :*: ga) = ifoldMap (q . Left) fa `mappend` ifoldMap (q . Right) ga
+  {-# INLINE ifoldMap #-}
+
+instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (Either i j) (f :*: g) where
+  itraverse q (fa :*: ga) = liftA2 (:*:) (itraverse (q . Left) fa) (itraverse (q . Right) ga)
+  {-# INLINE itraverse #-}
+
+instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (Either i j) (f :+: g) where
+  imap q (L1 fa) = L1 (imap (q . Left) fa)
+  imap q (R1 ga) = R1 (imap (q . Right) ga)
+  {-# INLINE imap #-}
+
+instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (Either i j) (f :+: g) where
+  ifoldMap q (L1 fa) = ifoldMap (q . Left) fa
+  ifoldMap q (R1 ga) = ifoldMap (q . Right) ga
+  {-# INLINE ifoldMap #-}
+
+instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (Either i j) (f :+: g) where
+  itraverse q (L1 fa) = L1 <$> itraverse (q . Left) fa
+  itraverse q (R1 ga) = R1 <$> itraverse (q . Right) ga
+  {-# INLINE itraverse #-}
+
+instance FunctorWithIndex i f => FunctorWithIndex i (Rec1 f) where
+  imap q (Rec1 f) = Rec1 (imap q f)
+  {-# INLINE imap #-}
+
+instance FoldableWithIndex i f => FoldableWithIndex i (Rec1 f) where
+  ifoldMap q (Rec1 f) = ifoldMap q f
+  {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex i f => TraversableWithIndex i (Rec1 f) where
+  itraverse q (Rec1 f) = Rec1 <$> itraverse q f
+  {-# INLINE itraverse #-}
+
+instance FunctorWithIndex Void (K1 i c) where
+  imap _ (K1 c) = K1 c
+  {-# INLINE imap #-}
+
+instance FoldableWithIndex Void (K1 i c) where
+  ifoldMap _ _ = mempty
+  {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex Void (K1 i c) where
+  itraverse _ (K1 a) = pure (K1 a)
+  {-# INLINE itraverse #-}
+
+-------------------------------------------------------------------------------
+-- Misc.
+-------------------------------------------------------------------------------
+
+#if __GLASGOW_HASKELL__ >=708
+(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)
+_ #. x = coerce x
+
+(#..) :: Coercible b c => (b -> c) -> (i -> a -> b) -> (i -> a -> c)
+_ #.. x = coerce x
+#else
+(#.) :: (b -> c) -> (a -> b) -> (a -> c)
+_ #. x = unsafeCoerce x
+
+(#..) :: (b -> c) -> (i -> a -> b) -> (i -> a -> c)
+_ #.. x = unsafeCoerce x
+#endif
+infixr 9 #., #..
+{-# INLINE (#.) #-}
+{-# INLINE (#..)#-}
+
+skip :: a -> ()
+skip _ = ()
+{-# INLINE skip #-}
+
+------------------------------------------------------------------------------
+-- Traversed
+------------------------------------------------------------------------------
+
+-- | Used internally by 'Control.Lens.Traversal.traverseOf_' and the like.
+--
+-- The argument 'a' of the result should not be used!
+newtype Traversed a f = Traversed { getTraversed :: f a }
+
+-- See 4.16 Changelog entry for the explanation of "why not Apply f =>"?
+instance Applicative f => Semigroup (Traversed a f) where
+  Traversed ma <> Traversed mb = Traversed (ma *> mb)
+  {-# INLINE (<>) #-}
+
+instance Applicative f => Monoid (Traversed a f) where
+  mempty = Traversed (pure (error "Traversed: value used"))
+  {-# INLINE mempty #-}
+
+------------------------------------------------------------------------------
+-- Sequenced
+------------------------------------------------------------------------------
+
+-- | Used internally by 'Control.Lens.Traversal.mapM_' and the like.
+--
+-- The argument 'a' of the result should not be used!
+--
+-- See 4.16 Changelog entry for the explanation of "why not Apply f =>"?
+newtype Sequenced a m = Sequenced { getSequenced :: m a }
+
+instance Monad m => Semigroup (Sequenced a m) where
+  Sequenced ma <> Sequenced mb = Sequenced (ma >> mb)
+  {-# INLINE (<>) #-}
+
+instance Monad m => Monoid (Sequenced a m) where
+  mempty = Sequenced (return (error "Sequenced: value used"))
+  {-# INLINE mempty #-}
+
+------------------------------------------------------------------------------
+-- Indexing
+------------------------------------------------------------------------------
+
+-- | 'Applicative' composition of @'Control.Monad.Trans.State.Lazy.State' 'Int'@ with a 'Functor', used
+-- by 'Control.Lens.Indexed.indexed'.
+newtype Indexing f a = Indexing { runIndexing :: Int -> (Int, f a) }
+
+instance Functor f => Functor (Indexing f) where
+  fmap f (Indexing m) = Indexing $ \i -> case m i of
+    (j, x) -> (j, fmap f x)
+  {-# INLINE fmap #-}
+
+instance Applicative f => Applicative (Indexing f) where
+  pure x = Indexing $ \i -> (i, pure x)
+  {-# INLINE pure #-}
+  Indexing mf <*> Indexing ma = Indexing $ \i -> case mf i of
+    (j, ff) -> case ma j of
+       ~(k, fa) -> (k, ff <*> fa)
+  {-# INLINE (<*>) #-}
+#if __GLASGOW_HASKELL__ >=821
+  liftA2 f (Indexing ma) (Indexing mb) = Indexing $ \ i -> case ma i of
+     (j, ja) -> case mb j of
+        ~(k, kb) -> (k, liftA2 f ja kb)
+  {-# INLINE liftA2 #-}
+#endif
+
+-------------------------------------------------------------------------------
+-- Strict curry
+-------------------------------------------------------------------------------
+
+uncurry' :: (a -> b -> c) -> (a, b) -> c
+uncurry' f (a, b) = f a b
+{-# INLINE uncurry' #-}
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index d4ad82e0d9..68091f3d23 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -436,4 +436,5 @@ test('T21851', [grep_errmsg(r'case.*w\$sf') ], multimod_compile, ['T21851', '-O
 test('T22097', [grep_errmsg(r'case.*wgoEven') ], multimod_compile, ['T22097', '-O -dno-typeable-binds -dsuppress-uniques'])
 
 test('T13873',  [ grep_errmsg(r'SPEC') ], compile, ['-O -ddump-rules'])
+test('T22357',  normal, compile, ['-O'])