[GHC] #16141: StrictData and TypeFamilies regression

[GHC]

#16141: StrictData and TypeFamilies regression
-------------------------------------+-------------------------------------
        Reporter:  RyanGlScott       |                Owner:  (none)
            Type:  bug               |               Status:  new
        Priority:  highest           |            Milestone:  8.8.1
       Component:  Compiler (Type    |              Version:  8.6.3
  checker)                           |
      Resolution:                    |             Keywords:
Operating System:  Unknown/Multiple  |         Architecture:
 Type of failure:  GHC rejects       |  Unknown/Multiple
  valid program                      |            Test Case:
      Blocked By:                    |             Blocking:
 Related Tickets:                    |  Differential Rev(s):
       Wiki Page:                    |
-------------------------------------+-------------------------------------

Comment (by RyanGlScott):

 My hunch appears to be correct. The
 [https://gitlab.haskell.org/ghc/ghc/blob/master/compiler/basicTypes/MkId.hs#L784-798
 dataConSrcToImplBang] function is what is responsible for making decisions
 about strictness/unpacking w.r.t. `StrictData`:

 {{{#!hs
 -- | 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
 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?

-- 
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/16141#comment:6>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler