Possible overzealous unfolding

I was investigating why (>>=) in the Haxl monad is being inlined more than I would expect, and I ran into something I don't fully understand, and looks dubious.

Start from this standalone example:

{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification #-}
module Haxl where

import Data.IORef
import Control.Exception

newtype GenHaxl u a = GenHaxl
  { unHaxl :: Int -> IORef () -> IO (Result u a) }

data Result u a
  = Done a
  | Throw SomeException
  | Blocked (Cont u a)

data Cont u a
  = forall b. Cont u b :>>= (b -> GenHaxl u a)
  | forall b. (b -> a) :<$> (Cont u b)

instance Monad (GenHaxl u) where
  return a = GenHaxl $ \_env _ref -> return (Done a)
  GenHaxl m >>= k = GenHaxl $ \env ref -> do
    e <- m env ref
    case e of
      Done a       -> unHaxl (k a) env ref
      Throw e      -> return (Throw e)
      Blocked cont -> return (Blocked (cont :>>= k))

instance Functor (GenHaxl u)
instance Applicative (GenHaxl u)

(it could be simplified further, but I've intentionally used the exact definition of >>= that is used in Haxl to be sure I'm not investigating the wrong thing)

Compile like this:

ghc -O -c Haxl.hs

and look at the .hi file:

ghc --show-iface Haxl.hi

see this:

ea159c3b107c307a4e76cd310efcc8bc
  $fMonadGenHaxl2 ::
    GenHaxl u a
    -> (a -> GenHaxl u b)
    -> Int
    -> IORef ()
    -> State# RealWorld
    -> (# State# RealWorld, Result u b #)
  {- Arity: 5, HasNoCafRefs,
     Strictness: <C(C(C(S(SS)))),1*C1(C1(C1(U(U,1*U))))><L,U><L,U><L,U><S,U>,
     Unfolding: InlineRule (5, True, False)
                (\ @ u
                   @ a
                   @ b
                   (ds :: GenHaxl u a)
                   (k :: a -> GenHaxl u b)
                   (env :: Int)
                   (ref :: IORef ())
                   (s :: State# RealWorld)[OneShot] ->
                 case (ds `cast` (N:GenHaxl[0] <u>_P <a>_R) env ref)
                        `cast`
                      (N:IO[0] <Result u a>_R)
                        s of ds1 { (#,#) ipv ipv1 ->
                 case ipv1 of wild {
                   Done a1
                   -> ((k a1) `cast` (N:GenHaxl[0] <u>_P <b>_R) env ref)
                        `cast`
                      (N:IO[0] <Result u b>_R)
                        ipv
                   Throw e -> (# ipv, Throw @ u @ b e #)
                   Blocked cont
                   -> (# ipv, Blocked @ u @ b (:>>= @ u @ b @ a cont k) #) } }) -}

That right there is the definition of >>=. Note that it has an InlineRule, which means that it will be unconditionally unfolded pretty much everywhere. I don't think this is right - there's no benefit to be had in inlining it unconditionally.

I delved in a bit more, and it seems this unfolding arises during worker-wrapper. Before WW we have

a_sVM
[LclId,
 Arity=5,
 Str=DmdType <C(C(C(S(SS)))),1*C1(C1(C1(U(U,1*U))))><L,U><L,U><L,U><S,U>,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True,
         Guidance=IF_ARGS [0 60 0 0 0] 94 60}]
a_sVM =
  \ @ u_XQR
    @ a_aPN
    @ b_aPO
    ds_dQP [Dmd=<C(C(C(S(SS)))),1*C1(C1(C1(U(U,1*U))))>]
    k_aEC
    env_aED
    ref_aEE
    s_aVC [Dmd=<S,U>, OS=OneShot] ->
    case (((ds_dQP `cast` ...) env_aED ref_aEE) `cast` ...) s_aVC
    of _ [Occ=Dead, Dmd=<L,A>]
    { (# ipv_aVF [Dmd=<S,U>], ipv1_aVG [Dmd=<S,1*U>] #) ->
    case ipv1_aVG of _ [Occ=Dead, Dmd=<L,A>] {
      Done a_aEG ->
        ((((k_aEC a_aEG) `cast` ...) env_aED ref_aEE) `cast` ...) ipv_aVF;
      Throw e_aEH -> (# ipv_aVF, Haxl.Throw e_aEH #);
      Blocked cont_aEI ->
        (# ipv_aVF, Haxl.Blocked (Haxl.:>>= cont_aEI k_aEC) #)
    }
    }

and after WW we have

a_sVM
[LclId,
 Arity=5,
 Str=DmdType <C(C(C(S(SS)))),1*C1(C1(C1(U(U,1*U))))><L,U><L,U><L,U><S,U>,
 Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(arity=5,unsat_ok=True,boring_ok=False)
         Tmpl= \ @ u_XQR
                 @ a_aPN
                 @ b_aPO
                 ds_dQP [Occ=Once]
                 k_aEC [Occ=Once*]
                 env_aED
                 ref_aEE
                 s_aVC [Occ=Once, OS=OneShot] ->
                 case (((ds_dQP `cast` ...) env_aED ref_aEE) `cast` ...) s_aVC
                 of _ [Occ=Dead]
                 { (# ipv_aVF [Occ=Once*], ipv1_aVG [Occ=Once!] #) ->
                 case ipv1_aVG of _ [Occ=Dead] {
                   Done a_aEG [Occ=Once] ->
                     ((((k_aEC a_aEG) `cast` ...) env_aED ref_aEE) `cast` ...) ipv_aVF;
                   Throw e_aEH [Occ=Once] -> (# ipv_aVF, Haxl.Throw e_aEH #);
                   Blocked cont_aEI [Occ=Once] ->
                     (# ipv_aVF, Haxl.Blocked (Haxl.:>>= cont_aEI k_aEC) #)
                 }
                 }}]
a_sVM =
  \ @ u_XQR
    @ a_aPN
    @ b_aPO
    ds_dQP [Dmd=<C(C(C(S(SS)))),1*C1(C1(C1(U(U,1*U))))>]
    k_aEC
    env_aED
    ref_aEE
    s_aVC [Dmd=<S,U>, OS=OneShot] ->
    case (((ds_dQP `cast` ...) env_aED ref_aEE) `cast` ...) s_aVC
    of _ [Occ=Dead, Dmd=<L,A>]
    { (# ipv_aVF [Dmd=<S,U>], ipv1_aVG [Dmd=<S,1*U>] #) ->
    case ipv1_aVG of _ [Occ=Dead, Dmd=<L,A>] {
      Done a_aEG ->
        ((((k_aEC a_aEG) `cast` ...) env_aED ref_aEE) `cast` ...) ipv_aVF;
      Throw e_aEH -> (# ipv_aVF, Haxl.Throw e_aEH #);
      Blocked cont_aEI ->
        (# ipv_aVF, Haxl.Blocked (Haxl.:>>= cont_aEI k_aEC) #)
    }
    }

For some unknown reason, this binding has acquired an always-on unfolding. There's no wrapper, we're just unfolding the whole thing.

Simon, can you shed any light here? I would like to tune unfolding sizes to reduce code bloat in our codebase, but with this unfolding being unconditional it doesn't work to use -funfolding-use-threshold, I can only use NOINLINE but that's too blunt.

Trac metadata

Trac field	Value
Version	8.1
Type	Bug
TypeOfFailure	OtherFailure
Priority	high
Resolution	Unresolved
Component	Compiler
Test case
Differential revisions
BlockedBy
Related
Blocking
CC	niteria
Operating system
Architecture