Casts and `coerce` defeat inlining though `Exts.inline`

Summary

Exts.inline is supposed to force inlining, however in the presence of casts this fails. Most explicitly this happens when manually inserting coerce.

Steps to reproduce

When compiling this module:

{-# OPTIONS_GHC -O -fno-cse -dno-typeable-binds #-}

module M where

import GHC.Exts (inline)

import Data.Coerce

-- A type we can coerce
newtype MyMaybe = MyMaybe { getMaybe :: (Maybe Int) }

myFunction :: MyMaybe -> MyMaybe
myFunction (MyMaybe m) = case m of
    Nothing -> MyMaybe Nothing
    -- Make it largeish
    Just n -> MyMaybe $ Just $ succ . succ . succ . succ . succ . succ . succ . succ . succ . succ $ n

-- Inlines as expected
bar :: MyMaybe -> MyMaybe
bar = inline myFunction

-- Doesn't inline - but I think it should.
foo :: MyMaybe -> Maybe Int
foo = (inline (coerce myFunction))

Expected behavior

I would expect myFunction to inline into foo despite the cast being "in the way".

While it might be debatable if we should inline here, after all one might consider coerce to be the function to be inlined the same happens when casts occur in a program through other means, as it happened in #24765 (closed) .

The relevant core for the reproducer in this ticket looks like this:

-- RHS size: {terms: 2, types: 3, coercions: 4, joins: 0/0}
foo :: MyMaybe -> Maybe Int
[LclIdX,
 Unf=Unf{Src=<vanilla>, TopLvl=False,
         Value=False, ConLike=False, WorkFree=False, Expandable=False,
         Guidance=IF_ARGS [] 20 0}]
foo
  = inline
      @(MyMaybe -> Maybe Int)
      (myFunction
       `cast` (<MyMaybe>_R %<Many>_N ->_R M.N:MyMaybe[0]
               :: (MyMaybe -> MyMaybe) ~R# (MyMaybe -> Maybe Int)))

Which to to me makes it obvious that inlining is desired in this case.

Environment

• GHC version used: GHC-HEAD and 9.6.2

added needs triage label

changed the description

I also condensed 24765 down into a reproducer for the inline part of that issue:

MyMerge.hs:

{-# OPTIONS_GHC -dno-typeable-binds #-}
{-# OPTIONS_GHC -ddump-spec -ddump-to-file #-}
{-# OPTIONS_GHC -ddump-spec -ddump-simpl -ddump-ds -dno-typeable-binds #-}

-- Otherwise we get a wrapper that always get's inlined.
{-# OPTIONS_GHC -fno-worker-wrapper #-}

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FlexibleInstances #-}

module MyMerge
       ( sort
       , MyVector(..)
       , MyMVector(..)
       )
       where

import Prelude hiding (read, length)

import Control.Monad.ST


-- vector stuff
data MyVector s = MyVector
class MyMVector v where
instance MyMVector (MyVector) where

-- primitive stuff
class Monad m => MyPrimMonad m where
  type MyPrimState m

instance MyPrimMonad (ST s) where
  type MyPrimState (ST s) = s

instance MyPrimMonad IO where
  type MyPrimState IO = RealWorld


-- | Sorts an array using the default comparison.
sort :: (Monad m, MyMVector v) => v (MyPrimState m) -> m ()
sort v = sortBy undefined v
{-# INLINABLE sort #-}

sortBy :: (Monad m, MyMVector v) => (e -> e -> Ordering)
        -> v (MyPrimState m)
        -> m ()
sortBy cmp vec = undefined
{-# OPAQUE sortBy #-}

MyLib.hs:

{-# OPTIONS_GHC -dno-typeable-binds #-}
{-# OPTIONS_GHC -ddump-simpl-iterations #-}
{-# OPTIONS_GHC -ddump-spec -ddump-simpl -ddump-ds -fno-worker-wrapper -fno-specialise #-}

-- Without this we would need to use ST instead of IO as sort would get specialized.
-- Just makes the reproducer slightly simpler.
{-# OPTIONS_GHC -fno-specialise #-}

-- Just makes the core easier to read
{-# OPTIONS_GHC -fno-full-laziness #-}

module MyLib (fooSTInline2) where

import Control.Monad.ST
import qualified MyMerge as MyMerge -- from vector-algorithms

import GHC.Exts (inline)

fooSTInline2 :: (MyMerge.MyVector RealWorld) -> IO ()
fooSTInline2 v = inline MyMerge.sort v

Compiling with /mnt/ghc_head/_build/stage1/bin/ghc MyMerge.hs MyLib.hs -O -ddump-to-file -ddump-simpl -fforce-recomp we get:

Core for the sort definition, important to note really just that it's something that can be inlined.

-- RHS size: {terms: 10, types: 17, coercions: 0, joins: 0/0}
sort [InlPrag=INLINABLE]
  :: forall (m :: * -> *) (v :: * -> *).
     (Monad m, MyMVector v) =>
     v (MyPrimState m) -> m ()
[GblId,
 Arity=3,
 Str=<B><B><B>b{rh->SC(S,L) sZu->B},
 Cpr=b,
 Unf=Unf{Src=StableUser, TopLvl=True,
         Value=True, ConLike=True, WorkFree=True, Expandable=True,
         Guidance=NEVER
         Tmpl= \ (@(m_aUO :: * -> *))
                 (@(v_aUP :: * -> *))
                 ($dMonad_aUQ [Occ=Once1!] :: Monad m_aUO)
                 ($dMyMVector_aUR [Occ=Once1!] :: MyMVector v_aUP)
                 (eta_B0 [Occ=Once1!, OS=OneShot] :: v_aUP (MyPrimState m_aUO)) ->
                 sortBy
                   @m_aUO
                   @v_aUP
                   @GHC.Types.Any
                   $dMonad_aUQ
                   $dMyMVector_aUR
                   (undefined
                      @GHC.Types.LiftedRep
                      @(GHC.Types.Any -> GHC.Types.Any -> Ordering)
                      ((GHC.Internal.Stack.Types.PushCallStack
                          (GHC.Internal.Base.build
                             @Char
                             (\ (@b_aYk) ->
                                GHC.CString.unpackFoldrCString# @b_aYk "undefined"#))
                          (GHC.Internal.Stack.Types.SrcLoc
                             (GHC.Internal.Base.build
                                @Char
                                (\ (@b_aYk) -> GHC.CString.unpackFoldrCString# @b_aYk "main"#))
                             (GHC.Internal.Base.build
                                @Char
                                (\ (@b_aYk) -> GHC.CString.unpackFoldrCString# @b_aYk "MyMerge"#))
                             (GHC.Internal.Base.build
                                @Char
                                (\ (@b_aYk) ->
                                   GHC.CString.unpackFoldrCString# @b_aYk "MyMerge.hs"#))
                             (GHC.Types.I# 44#)
                             (GHC.Types.I# 17#)
                             (GHC.Types.I# 44#)
                             (GHC.Types.I# 26#))
                          GHC.Internal.Stack.Types.EmptyCallStack)
                       `cast` (Sym (GHC.Classes.N:IP[0]
                                        <"callStack">_N <GHC.Internal.Stack.Types.CallStack>_N)
                               :: GHC.Internal.Stack.Types.CallStack
                                  ~R# (?callStack::GHC.Internal.Stack.Types.CallStack))))
                   eta_B0}]
sort

And at the use site we get after desugaring:

-- RHS size: {terms: 6, types: 12, coercions: 12, joins: 0/0}
fooSTInline2 :: MyMerge.MyVector RealWorld -> IO ()
[LclIdX,
 Unf=Unf{Src=<vanilla>, TopLvl=True,
         Value=True, ConLike=True, WorkFree=True, Expandable=True,
         Guidance=IF_ARGS [0] 60 0}]
fooSTInline2
  = \ (v_a1BN :: MyMerge.MyVector RealWorld) ->
      inline
        @(MyMerge.MyVector RealWorld -> IO ())
        ((MyMerge.sort
            @IO
            @MyMerge.MyVector
            GHC.Internal.Base.$fMonadIO
            (MyMerge.$fMyMVectorFUNMyVector @(*)))
         `cast` ((MyMerge.MyVector
                    <*>_N
                    Univ(phantom phantom <*>_N :: MyMerge.MyPrimState IO, RealWorld))_R
                 %<Many>_N ->_R <IO ()>_R
                 :: (MyMerge.MyVector (MyMerge.MyPrimState IO) -> IO ())
                    ~R# (MyMerge.MyVector RealWorld -> IO ())))
        v_a1BN

Which eventually ends up being:

-- RHS size: {terms: 5, types: 7, coercions: 8, joins: 0/0}
fooSTInline2 :: MyMerge.MyVector RealWorld -> IO ()
[GblId,
 Arity=1,
 Str=<B>b{rh->SC(S,L) sZu->B},
 Cpr=b,
 Unf=OtherCon []]
fooSTInline2
  = \ (v_a1BN :: MyMerge.MyVector RealWorld) ->
      MyMerge.sort
        @IO
        @MyMerge.MyVector
        GHC.Internal.Base.$fMonadIO
        (MyMerge.$fMyMVectorFUNMyVector @(*))
        (v_a1BN
         `cast` ((MyMerge.MyVector
                    <*>_N
                    Univ(phantom phantom <*>_N :: RealWorld, MyMerge.MyPrimState IO))_R
                 :: MyMerge.MyVector RealWorld
                    ~R# MyMerge.MyVector (MyMerge.MyPrimState IO)))

I will put up a patch.

mentioned in commit dc00e8ba

mentioned in merge request !12623 (closed)

mentioned in commit 7377f52c

removed needs triage label

added Pnormal Tbug inlining simplifier labels

mentioned in issue #24765 (closed)

mentioned in commit e6779d81

closed with commit a593f284

mentioned in commit a593f284

Fixed by

commit a593f28426ca508a72b49d0112ef934ce9f453fd
Author: Andreas Klebinger <klebinger.andreas@gmx.at>
Date:   Mon May 13 19:52:13 2024 +0200

    Expand the `inline` rule to look through casts/ticks.
    
    Fixes #24808

 compiler/GHC/Core/Opt/ConstantFold.hs                  |  20 +++--
 testsuite/tests/simplCore/should_compile/T24808.hs     |  27 ++++++
 testsuite/tests/simplCore/should_compile/T24808.stderr | 151 +++++++++++++++++++++++++++++++++
 testsuite/tests/simplCore/should_compile/all.T         |   1 +
 4 files changed, 194 insertions(+), 5 deletions(-)

mentioned in commit e417441e