StrictData and TypeFamilies regression

The credit goes to wuzzeb for originally discovering this bug here. I've minimized their test case slightly below:

{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilies #-}
module Bug where

data family T
newtype instance T = MkT Int deriving Eq

With optimization enabled, this program compiles with GHC 8.0.2 through 8.4.4, but not with 8.6.3 or HEAD:

$ /opt/ghc/8.4.4/bin/ghc -fforce-recomp -O Bug.hs
[1 of 1] Compiling Bug              ( Bug.hs, Bug.o )

$ /opt/ghc/8.6.3/bin/ghc -fforce-recomp -O Bug.hs
[1 of 1] Compiling Bug              ( Bug.hs, Bug.o )

Bug.hs:6:39: error:
    • Couldn't match a lifted type with an unlifted type
        arising from the coercion of the method ‘==’
          from type ‘GHC.Prim.Int# -> GHC.Prim.Int# -> Bool’
            to type ‘T -> T -> Bool’
    • When deriving the instance for (Eq T)
  |
6 | newtype instance T = MkT Int deriving Eq
  |                                       ^^

Based on the error message, it appears as if GHC mistakenly believes that the representation type of the T instance is Int#, rather than Int.

Trac metadata

Trac field	Value
Version	8.6.3
Type	Bug
TypeOfFailure	OtherFailure
Priority	highest
Resolution	Unresolved
Component	Compiler (Type checker)
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system
Architecture

changed milestone to %8.8.1

changed weight to 10

added Tbug Trac import typechecker labels

Hm, this appears to be my fault, as this regression was introduced in commit eb680f2c (Fix newtype instance GADTs).

It turns out you don't need deriving to notice something afoot with this program. Even if you just have this:

{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilies #-}
module Bug where

data family T
newtype instance T = MkT Int

And compile this with -O -dcore-lint, it blows up:

$ /opt/ghc/8.6.3/bin/ghc Bug.hs -O -dcore-lint    
[1 of 1] Compiling Bug              ( Bug.hs, Bug.o )
*** Core Lint errors : in result of Tidy Core ***
<no location info>: warning:
    In a case alternative: (I# dt_aXp :: Int#)
    Type of case alternatives not the same as the annotation on case:
        Actual type: R:T
        Annotation on case: T
        Alt Rhs: dt_aXp `cast` (Sym (N:R:T[0]) :: Int# ~R# R:T)
*** Offending Program ***
$WMkT [InlPrag=INLINE[2]] :: Int -> T
[GblId[DataConWrapper],
 Arity=1,
 Caf=NoCafRefs,
 Str=<S,U>,
 Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
         Tmpl= \ (dt_aXo [Occ=Once!] :: Int) ->
                 (case dt_aXo of { I# dt_aXp [Occ=Once] ->
                  dt_aXp `cast` (Sym (N:R:T[0]) :: Int# ~R# R:T)
                  })
                 `cast` (Sym (D:R:T0[0]) :: R:T ~R# T)}]
$WMkT
  = \ (dt_aXo [Occ=Once!] :: Int) ->
      (case dt_aXo of { I# dt_aXp [Occ=Once] ->
       dt_aXp `cast` (Sym (N:R:T[0]) :: Int# ~R# R:T)
       })
      `cast` (Sym (D:R:T0[0]) :: R:T ~R# T)

<elided>

I'm starting to think that this is actually an old bug with StrictData, since the following program (which uses a plain old newtype, not a data family) also breaks Core Lint in a similar fashion with GHC 8.4.4 or later:

{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
module Bug where

newtype T a b where
  MkT :: forall b a. Int -> T a b

$ /opt/ghc/8.4.4/bin/ghc -O -dcore-lint Bug.hs   
[1 of 1] Compiling Bug              ( Bug.hs, Bug.o )
*** Core Lint errors : in result of Tidy Core ***
<no location info>: warning:
    In a case alternative: (I# dt_aXx :: Int#)
    Type of case alternatives not the same as the annotation on case:
        Actual type: T a_atk b_atj
        Annotation on case: T b_atj a_atk
        Alt Rhs: dt_aXx
                 `cast` (Sym (N:T[0] <a_atk>_P <b_atj>_P)
                         :: (Int# :: TYPE 'IntRep) ~R# (T a_atk b_atj :: *))
*** Offending Program ***
$WMkT [InlPrag=INLINE[2]] :: forall b a. Int -> T a b
[GblId[DataConWrapper],
 Arity=1,
 Caf=NoCafRefs,
 Str=<S,U>,
 Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
         Tmpl= \ (@ b_atj) (@ a_atk) (dt_aXw [Occ=Once!] :: Int) ->
                 case dt_aXw of { I# dt_aXx [Occ=Once] ->
                 dt_aXx
                 `cast` (Sym (N:T[0] <a_atk>_P <b_atj>_P)
                         :: (Int# :: TYPE 'IntRep) ~R# (T a_atk b_atj :: *))
                 }}]
$WMkT
  = \ (@ b_atj) (@ a_atk) (dt_aXw [Occ=Once!] :: Int) ->
      case dt_aXw of { I# dt_aXx [Occ=Once] ->
      dt_aXx
      `cast` (Sym (N:T[0] <a_atk>_P <b_atj>_P)
              :: (Int# :: TYPE 'IntRep) ~R# (T a_atk b_atj :: *))
      }

<elided>

The issue appears to involve newtypes with wrappers in general. (The reason why the original program only started breaking with GHC 8.6 is because commit eb680f2c changed GHC's treatment of newtype instances so that they would have wrappers where they didn't before.)

The mention of Int# has me wondering: is GHC trying to unpack the Int field of MkT? If so, I would surely think that that's incorrect, since the idea of unpacking a newtype seems bogus, especially since GHC rejects this program:

λ> newtype T = MkT {-# UNPACK #-} !Int

<interactive>:1:13: error:
    • A newtype constructor cannot have a strictness annotation,
        but ‘MkT’ does
    • In the definition of data constructor ‘MkT’
      In the newtype declaration for ‘T’

Perhaps the implementation of StrictData misses this fact, however. I'll check the code to see if that is the case.

My hunch appears to be correct. The dataConSrcToImplBang function is what is responsible for making decisions about strictness/unpacking w.r.t. StrictData:

-- | Unpack/Strictness decisions from source module
dataConSrcToImplBang
   :: DynFlags
   -> FamInstEnvs
   -> Type
   -> HsSrcBang
   -> HsImplBang

dataConSrcToImplBang dflags fam_envs arg_ty
                     (HsSrcBang ann unpk NoSrcStrict)
  | xopt LangExt.StrictData dflags -- StrictData => strict field
  = dataConSrcToImplBang dflags fam_envs arg_ty
                  (HsSrcBang ann unpk SrcStrict)
  | otherwise -- no StrictData => lazy field
  = HsLazy

Notice that this does not take into account whether the Type of the field belongs to a newtype or not, so this will indeed unpack the field of a newtype with StrictData + -O enabled. Yikes.

One could fix this by propagating information about whether we're in a newtype or not to dataConSrcToImplBang. But then again, should we really even need to call dataConSrcToImplBang if we're dealing with a newtype? dataConSrcToImplBang is internal to MkId and only has one call site, so I'm inclined to just avoid invoking it at its call site, like so:

diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index 5a6f1fbf96..fa3d6785b7 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -637,11 +637,15 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
              -- Because we are going to apply the eq_spec args manually in the
              -- wrapper
 
-    arg_ibangs =
-      case mb_bangs of
-        Nothing    -> zipWith (dataConSrcToImplBang dflags fam_envs)
-                              orig_arg_tys orig_bangs
-        Just bangs -> bangs
+    new_tycon = isNewTyCon tycon
+    arg_ibangs
+      | new_tycon
+      = nOfThem (length orig_arg_tys) HsLazy
+      | otherwise
+      = case mb_bangs of
+          Nothing    -> zipWith (dataConSrcToImplBang dflags fam_envs)
+                                orig_arg_tys orig_bangs
+          Just bangs -> bangs
 
     (rep_tys_w_strs, wrappers)
       = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs))
@@ -650,7 +654,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
     (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)
 
     wrapper_reqd =
-        (not (isNewTyCon tycon)
+        (not new_tycon
                      -- (Most) newtypes have only a worker, with the exception
                      -- of some newtypes written with GADT syntax. See below.
          && (any isBanged (ev_ibangs ++ arg_ibangs)

This certainly fixes the two programs in this ticket, and it passes the rest of the testsuite. Does this sound like the right approach?

Good catch. I think you have the right approach.

closed

Landed in 076f5862a9e46eef762ba19fb7b14e75fa03c2c0:

commit 076f5862a9e46eef762ba19fb7b14e75fa03c2c0
Author: Ryan Scott <ryan.gl.scott@gmail.com>
Date:   Sat Jan 12 19:05:46 2019 -0500

    Don't invoke dataConSrcToImplBang on newtypes

Trac metadata

Trac field	Value
Resolution	Unresolved → ResolvedFixed
Test case	- → typecheck/should_compile/T16141

mentioned in issue #16191 (closed)

reopened

changed milestone to %8.6.4

Given the severity of this bug, and that fact that there have been multiple bug reports about this (see #16191 (closed) for another one), I'll optimistically mark this as a candidate for merging into the upcoming 8.6.4 release.

Trac metadata

Trac field	Value
Related	- → #16191 (closed)

added 1 deleted label

mentioned in commit a5373c1f

closed

removed 1 deleted label

Merged with ff47e60a.

reopened

changed milestone to %8.8.1

Also needs merging for 8.8.1.

added 1 deleted label

added backport label

added 1 deleted label and removed backport label

mentioned in commit 53b76557

mentioned in commit ff47e60a

Backported to ghc-8.8 in 53b76557.

closed

removed 1 deleted label

added Phighest label

marked #16939 (closed) as a duplicate of this issue

mentioned in issue #16939 (closed)