Skip to content

Simplifier generates incorrect (albeit transient) cast

As of GHC 75f0091b, compiling the following program with comp marked as OPAQUE results in a warning about an incorrect cast generated by the simplifier:

{-# LANGUAGE NoImplicitPrelude #-}
module Endo where

newtype Endo a = Endo { appEndo :: a -> a }

foo :: Endo a -> Endo a -> Endo a
foo (Endo f) (Endo g) = Endo (comp f g)

comp :: (b -> c) -> (a -> b) -> (a -> c)
comp f g x = f (g x)
{-# OPAQUE comp #-}

Compiling with -ddump-simpl-trace -O I get the same warning message repeated for the various simplifier iterations:

==================== Simpl Trace ====================
tcww:no
  bndr: Endo.comp
  rhs: \ (@b_ahm)
         (@c_ahn)
         (@a_aho)
         (f_at :: b_ahm -> c_ahn)
         (g_au :: a_aho -> b_ahm)
         (x_av :: a_aho) ->
         f_at (g_au x_av)


WARNING:
  Trying to coerce
  (comp @a_ahr @a_ahr
  :: forall a. (a_ahr -> a_ahr) -> (a -> a_ahr) -> a -> a_ahr)
  forall (a :: <Type>_N).
  Sym (N:Endo[0] <a>_R)
  %<'Many>_N ->_R Sym (N:Endo[0] <a>_R)
  %<'Many>_N ->_R Sym (N:Endo[0] <a>_R)
  (forall {a}. (a -> a) -> (a -> a) -> a -> a :: Type)
  ~R# (forall {a}. Endo a -> Endo a -> Endo a :: Type)
  Call stack:
      CallStack (from HasCallStack):
        callStackDoc, called at compiler/GHC/Core/Utils.hs:311:14 in ghc:GHC.Core.Utils
  Call stack:
      CallStack (from HasCallStack):
        warnPprTrace, called at compiler/GHC/Core/Utils.hs:307:5 in ghc:GHC.Core.Utils

Note that comp @a_ahr @a_ahr is only partially instantiated, hence its residual polymorphic type forall a. (a_ahr -> a_ahr) -> (a -> a_ahr) -> (a -> a_ahr). The cast seems to assume it should be \@a -> comp @a @a @a instead.

I don't see any problem in the input and the output (and neither does -dcore-lint), so it seems the wrong cast is some intermediate expression that is then processed further by the simplifier. Still, is this the sign of a bug in waiting?

-- RHS size: {terms: 9, types: 8, coercions: 0, joins: 0/0}
comp [InlPrag=OPAQUE]
  :: forall b c a. (b -> c) -> (a -> b) -> a -> c
[LclIdX,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=True)}]
comp
  = \ (@b_ahe)
      (@c_ahf)
      (@a_ahg)
      (f_ag :: b_ahe -> c_ahf)
      (g_ah :: a_ahg -> b_ahe)
      (x_ai :: a_ahg) ->
      f_ag (g_ah x_ai)

-- RHS size: {terms: 6, types: 8, coercions: 7, joins: 0/0}
foo :: forall a. Endo a -> Endo a -> Endo a
[LclIdX,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=True)}]
foo
  = \ (@a_ahj) (ds_dhw :: Endo a_ahj) (ds_dhx :: Endo a_ahj) ->
      (comp
         @a_ahj
         @a_ahj
         @a_ahj
         (ds_dhw
          `cast` (Endo.N:Endo[0] <a_ahj>_R
                  :: Endo a_ahj ~R# (a_ahj -> a_ahj)))
         (ds_dhx
          `cast` (Endo.N:Endo[0] <a_ahj>_R
                  :: Endo a_ahj ~R# (a_ahj -> a_ahj))))
      `cast` (Sym (Endo.N:Endo[0] <a_ahj>_R)
              :: (a_ahj -> a_ahj) ~R# Endo a_ahj)
-- RHS size: {terms: 9, types: 8, coercions: 0, joins: 0/0}
comp [InlPrag=OPAQUE]
  :: forall b c a. (b -> c) -> (a -> b) -> a -> c
[LclIdX,
 Arity=3,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=True)}]
comp
  = \ (@b_ahm)
      (@c_ahn)
      (@a_aho)
      (f_at :: b_ahm -> c_ahn)
      (g_au :: a_aho -> b_ahm)
      (x_av :: a_aho) ->
      f_at (g_au x_av)

-- RHS size: {terms: 6, types: 8, coercions: 4, joins: 0/0}
foo_si3 :: forall {a}. Endo a -> Endo a -> a -> a
[LclId,
 Arity=3,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=True)}]
foo_si3
  = \ (@a_ahr) (ds_dhX :: Endo a_ahr) (ds_dhY :: Endo a_ahr) ->
      comp
        @a_ahr
        @a_ahr
        @a_ahr
        (ds_dhX
         `cast` (Endo.N:Endo[0] <a_ahr>_R
                 :: Endo a_ahr ~R# (a_ahr -> a_ahr)))
        (ds_dhY
         `cast` (Endo.N:Endo[0] <a_ahr>_R
                 :: Endo a_ahr ~R# (a_ahr -> a_ahr)))

-- RHS size: {terms: 1, types: 0, coercions: 13, joins: 0/0}
foo :: forall a. Endo a -> Endo a -> Endo a
[LclIdX,
 Arity=3,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
foo
  = foo_si3
    `cast` (forall (a :: <*>_N).
            <Endo a>_R
            %<'Many>_N ->_R <Endo a>_R
            %<'Many>_N ->_R Sym (Endo.N:Endo[0] <a>_R)
            :: (forall {a}. Endo a -> Endo a -> a -> a)
               ~R# (forall {a}. Endo a -> Endo a -> Endo a))
To upload designs, you'll need to enable LFS and have an admin enable hashed storage. More information