Skip to content

Typeclass dictionary selector unfolding sensitive to type parameter

In the following Haskell module, one method of C is, by default, implemented via the other method:

{-# LANGUAGE NoImplicitPrelude, NoPolyKinds #-}
{-# LANGUAGE CPP #-}
module RecDict () where

class C m where
#if HKT
    foo :: m a -> m a
    bar :: m a -> m a
#else
    foo :: m -> m
    bar :: m -> m
#endif

#if HKT
data T tag a
#else
data T tag
#endif

instance C (T tag) where
    foo x = x
    {-# NOINLINE bar #-}
    bar = foo

instance {-# INCOHERENT #-} C (T ()) where
    foo x = x
    {-# NOINLINE bar #-}
    bar = foo

With HKT set to 0, the generated (Prep) Core looks generally like what I'd expect: there are two dictionary definitions for C (T tag) and C (T ()), and both are simply the dictionary constructor applied on toplevel method bindings. For readabilty's sake, I present the Core in four groups:

$ ghc input/recursive-dict/RecDict.hs -fforce-recomp -dno-typeable-binds -ddump-prep -dsuppress-all -dno-suppress-type-signatures -O2 -DHKT=0
-- Group 1: dictionary constructor
C:C :: forall m. (m -> m) -=> (m -> m) -=> C m
C:C
  = \ (@m_ad) (eta_B0 :: m_ad -> m_ad) (eta_B1 :: m_ad -> m_ad) ->
      C:C eta_B0 eta_B1


-- Group 2: method selectors
foo :: forall m. C m => m -> m
foo
  = \ (@m_ad) (v_ss7 :: C m_ad) ->
      case v_ss7 of { C:C v2_ss9 _ -> v2_ss9 }

bar :: forall m. C m => m -> m
bar
  = \ (@m_ad) (v_ssb :: C m_ad) ->
      case v_ssb of { C:C _ v3_sse -> v3_sse }


-- Group 3: definition of C (T tag)
$fCT0_$cfoo :: forall tag. T tag -> T tag
$fCT0_$cfoo = \ (@tag_a7N) (x_ssf :: T tag_a7N) -> x_ssf

$fCT0_$cbar :: forall tag. T tag -> T tag
$fCT0_$cbar
  = \ (@tag_a7N) (eta_B0 :: T tag_a7N) -> $fCT0_$cfoo eta_B0

$fCT0 :: forall tag. C (T tag)
$fCT0 = \ (@tag_a7N) -> C:C $fCT0_$cfoo $fCT0_$cbar


-- Group 4: definition of C (T ())
$fCT_$cfoo :: T () -> T ()
$fCT_$cfoo = \ (x_ssg :: T ()) -> x_ssg

$fCT_$cbar :: T () -> T ()
$fCT_$cbar = \ (eta_B0 :: T ()) -> $fCT_$cfoo eta_B0

$fCT :: C (T ())
$fCT = C:C $fCT_$cfoo $fCT_$cbar

However, with HKT set to 1, suddenly the foo method selector is not inlined into $fCT0_$cbar, leading to mutual recursion between $fCT0_$cbar and $fCT0:

$ ghc input/recursive-dict/RecDict.hs -fforce-recomp -dno-typeable-binds -ddump-prep   -dsuppress-all -dno-suppress-type-signatures -O2 -DHKT=1

-- Group 1: dictionary constructor
C:C
  :: forall (m :: * -> *).
     (forall a. m a -> m a) -=> (forall a. m a -> m a) -=> C m
C:C
  = \ (@(m_ae :: * -> *))
      (eta_B0 :: forall a. m_ae a -> m_ae a)
      (eta_B1 :: forall a. m_ae a -> m_ae a) ->
      C:C eta_B0 eta_B1



-- Group 2: method selectors
foo :: forall (m :: * -> *) a. C m => m a -> m a
foo
  = \ (@(m_ae :: * -> *)) (v_ssx :: C m_ae) ->
      case v_ssx of { C:C v2_ssz _ -> v2_ssz }

bar :: forall (m :: * -> *) a. C m => m a -> m a
bar
  = \ (@(m_ae :: * -> *)) (v_ssB :: C m_ae) ->
      case v_ssB of { C:C _ v3_ssE -> v3_ssE }


-- Group 3: definition of C (T tag)
$fCT0_$cfoo :: forall tag a. T tag a -> T tag a
$fCT0_$cfoo
  = \ (@tag_a87) (@a_a8c) (x_ssF :: T tag_a87 a_a8c) -> x_ssF

Rec {
$fCT0 :: forall tag. C (T tag)
$fCT0 = \ (@tag_a87) -> C:C $fCT0_$cfoo $fCT0_$cbar

$fCT0_$cbar :: forall tag a. T tag a -> T tag a
$fCT0_$cbar = \ (@tag_a87) (@a_a8i) -> foo $fCT0
end Rec }


-- Group 4: definition of C (T ())
$fCT_$cfoo :: forall a. T () a -> T () a
$fCT_$cfoo = \ (@a_a7S) (x_ssG :: T () a_a7S) -> x_ssG

$fCT_$cbar :: forall a. T () a -> T () a
$fCT_$cbar = \ (@a_af) (eta_B0 :: T () a_af) -> $fCT_$cfoo eta_B0

$fCT :: C (T ())
$fCT = C:C $fCT_$cfoo $fCT_$cbar

What is the reason that group 3 is so wildly different between the two programs? Is there a way to produce the non-recursive Core a la the first version for the HKT=1 program?

Edited by sheaf
To upload designs, you'll need to enable LFS and have an admin enable hashed storage. More information