Make worker-wrapper unbox data families

by passing the FamInstEnvs all the way down. This closes #7619.

7 files changed, 118 insertions, 74 deletions

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 071f7ef55f..c61c8ec56d 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -39,7 +39,7 @@ module HscTypes (
         PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,
         lookupIfaceByModule, emptyModIface,
 
-        PackageInstEnv, PackageRuleBase,
+        PackageInstEnv, PackageFamInstEnv, PackageRuleBase,
 
         mkSOName, mkHsSOName, soExt,
 
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index 3f895080a6..7f45850d38 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -34,7 +34,7 @@ module CoreMonad (
     
     -- ** Reading from the monad
     getHscEnv, getRuleBase, getModule,
-    getDynFlags, getOrigNameCache,
+    getDynFlags, getOrigNameCache, getPackageFamInstEnv,
     
     -- ** Writing to the monad
     addSimplCount,
@@ -953,6 +953,12 @@ getOrigNameCache :: CoreM OrigNameCache
 getOrigNameCache = do
     nameCacheRef <- fmap hsc_NC getHscEnv
     liftIO $ fmap nsNames $ readIORef nameCacheRef
+
+getPackageFamInstEnv :: CoreM PackageFamInstEnv
+getPackageFamInstEnv = do
+    hsc_env <- getHscEnv
+    eps <- liftIO $ hscEPS hsc_env
+    return $ eps_fam_inst_env eps
 \end{code}
 
 %************************************************************************
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 7adee7d509..eb306aea0d 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -36,7 +36,7 @@ import LiberateCase     ( liberateCase )
 import SAT              ( doStaticArgs )
 import Specialise       ( specProgram)
 import SpecConstr       ( specConstrProgram)
-import DmdAnal       ( dmdAnalProgram )
+import DmdAnal          ( dmdAnalProgram )
 import WorkWrap         ( wwTopBinds )
 import Vectorise        ( vectorise )
 import FastString
@@ -387,8 +387,8 @@ doCorePass _      CoreCSE                   = {-# SCC "CommonSubExpr" #-}
 doCorePass _      CoreLiberateCase          = {-# SCC "LiberateCase" #-}
                                               doPassD liberateCase
 
-doCorePass dflags CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
-                                              doPass (floatInwards dflags)
+doCorePass _      CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
+                                              doPassD floatInwards
 
 doCorePass _      (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
                                               doPassDUM (floatOutwards f)
@@ -397,10 +397,10 @@ doCorePass _      CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
                                               doPassU doStaticArgs
 
 doCorePass _      CoreDoStrictness          = {-# SCC "NewStranal" #-}
-                                              doPassDM dmdAnalProgram
+                                              doPassDFM dmdAnalProgram
 
-doCorePass dflags CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
-                                              doPassU (wwTopBinds dflags)
+doCorePass _      CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
+                                              doPassDFU wwTopBinds
 
 doCorePass dflags CoreDoSpecialising        = {-# SCC "Specialise" #-}
                                               specProgram dflags
@@ -462,6 +462,21 @@ doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
 doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
 doPassU do_pass = doPassDU (const do_pass)
 
+doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassDFM do_pass guts = do
+    dflags <- getDynFlags
+    p_fam_env <- getPackageFamInstEnv
+    let fam_envs = (p_fam_env, mg_fam_inst_env guts)
+    doPassM (liftIO . do_pass dflags fam_envs) guts
+
+doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassDFU do_pass guts = do
+    dflags <- getDynFlags
+    us     <- getUniqueSupplyM
+    p_fam_env <- getPackageFamInstEnv
+    let fam_envs = (p_fam_env, mg_fam_inst_env guts)
+    doPass (do_pass dflags fam_envs us) guts
+
 -- Most passes return no stats and don't change rules: these combinators
 -- let us lift them to the full blown ModGuts+CoreM world
 doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index a942c4eab6..9a7c985e46 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -31,6 +31,7 @@ import TyCon
 import Type		( eqType )
 -- import Pair
 -- import Coercion         ( coercionKind )
+import FamInstEnv
 import Util
 import Maybes		( isJust )
 import TysWiredIn	( unboxedPairDataCon )
@@ -47,8 +48,8 @@ import Data.Function    ( on )
 %************************************************************************
 
 \begin{code}
-dmdAnalProgram :: DynFlags -> CoreProgram -> IO CoreProgram
-dmdAnalProgram dflags binds
+dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
+dmdAnalProgram dflags fam_envs binds
   = do {
 	let { binds_plus_dmds = do_prog binds } ;
         dumpIfSet_dyn dflags Opt_D_dump_strsigs "Strictness signatures" $
@@ -57,7 +58,7 @@ dmdAnalProgram dflags binds
     }
   where
     do_prog :: CoreProgram -> CoreProgram
-    do_prog binds = snd $ mapAccumL dmdAnalTopBind (emptyAnalEnv dflags) binds
+    do_prog binds = snd $ mapAccumL dmdAnalTopBind (emptyAnalEnv dflags fam_envs) binds
 
 -- Analyse a (group of) top-level binding(s)
 dmdAnalTopBind :: AnalEnv
@@ -611,7 +612,7 @@ dmdAnalRhs top_lvl rec_flag env id rhs
 	-- See Note [NOINLINE and strictness]
 
     -- See Note [Product demands for function body]
-    body_dmd = case deepSplitProductType_maybe (exprType body) of
+    body_dmd = case deepSplitProductType_maybe (ae_fam_envs env) (exprType body) of
                  Nothing            -> cleanEvalDmd
                  Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc)
 
@@ -1006,6 +1007,7 @@ data AnalEnv
        , ae_virgin :: Bool    -- True on first iteration only
 		              -- See Note [Initialising strictness]
        , ae_rec_tc :: RecTcChecker
+       , ae_fam_envs :: FamInstEnvs
  }
 
 	-- We use the se_env to tell us whether to
@@ -1023,9 +1025,14 @@ instance Outputable AnalEnv where
          [ ptext (sLit "ae_virgin =") <+> ppr virgin
          , ptext (sLit "ae_sigs =") <+> ppr env ])
 
-emptyAnalEnv :: DynFlags -> AnalEnv
-emptyAnalEnv dflags = AE { ae_dflags = dflags, ae_sigs = emptySigEnv
-                         , ae_virgin = True, ae_rec_tc = initRecTc }
+emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv
+emptyAnalEnv dflags fam_envs
+    = AE { ae_dflags = dflags
+         , ae_sigs = emptySigEnv
+         , ae_virgin = True
+         , ae_rec_tc = initRecTc
+         , ae_fam_envs = fam_envs
+         }
 
 emptySigEnv :: SigEnv
 emptySigEnv = emptyVarEnv
@@ -1071,7 +1078,7 @@ extendSigsWithLam env id
   , isStrictDmd (idDemandInfo id) || ae_virgin env  
        -- See Note [Optimistic CPR in the "virgin" case]
        -- See Note [Initial CPR for strict binders]
-  , Just (dc,_,_,_) <- deepSplitProductType_maybe $ idType id
+  , Just (dc,_,_,_) <- deepSplitProductType_maybe (ae_fam_envs env) $ idType id
   = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc))
 
   | otherwise 
diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs
index 9aa36c282d..f5bc18b69e 100644
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.lhs
@@ -28,6 +28,7 @@ import Demand
 import WwLib
 import Util
 import Outputable
+import FamInstEnv
 import MonadUtils
 
 #include "HsVersions.h"
@@ -60,11 +61,11 @@ info for exported values).
 \end{enumerate}
 
 \begin{code}
-wwTopBinds :: DynFlags -> UniqSupply -> CoreProgram -> CoreProgram
+wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram
 
-wwTopBinds dflags us top_binds
+wwTopBinds dflags fam_envs us top_binds
   = initUs_ us $ do
-    top_binds' <- mapM (wwBind dflags) top_binds
+    top_binds' <- mapM (wwBind dflags fam_envs) top_binds
     return (concat top_binds')
 \end{code}
 
@@ -79,23 +80,24 @@ turn.  Non-recursive case first, then recursive...
 
 \begin{code}
 wwBind  :: DynFlags
+        -> FamInstEnvs
         -> CoreBind
 	-> UniqSM [CoreBind]	-- returns a WwBinding intermediate form;
 				-- the caller will convert to Expr/Binding,
 				-- as appropriate.
 
-wwBind dflags (NonRec binder rhs) = do
-    new_rhs <- wwExpr dflags rhs
-    new_pairs <- tryWW dflags NonRecursive binder new_rhs
+wwBind dflags fam_envs (NonRec binder rhs) = do
+    new_rhs <- wwExpr dflags fam_envs rhs
+    new_pairs <- tryWW dflags fam_envs NonRecursive binder new_rhs
     return [NonRec b e | (b,e) <- new_pairs]
       -- Generated bindings must be non-recursive
       -- because the original binding was.
 
-wwBind dflags (Rec pairs)
+wwBind dflags fam_envs (Rec pairs)
   = return . Rec <$> concatMapM do_one pairs
   where
-    do_one (binder, rhs) = do new_rhs <- wwExpr dflags rhs
-                              tryWW dflags Recursive binder new_rhs
+    do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs
+                              tryWW dflags fam_envs Recursive binder new_rhs
 \end{code}
 
 @wwExpr@ basically just walks the tree, looking for appropriate
@@ -104,36 +106,36 @@ matching by looking for strict arguments of the correct type.
 @wwExpr@ is a version that just returns the ``Plain'' Tree.
 
 \begin{code}
-wwExpr :: DynFlags -> CoreExpr -> UniqSM CoreExpr
+wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr
 
-wwExpr _      e@(Type {}) = return e
-wwExpr _      e@(Coercion {}) = return e
-wwExpr _      e@(Lit  {}) = return e
-wwExpr _      e@(Var  {}) = return e
+wwExpr _      _ e@(Type {}) = return e
+wwExpr _      _ e@(Coercion {}) = return e
+wwExpr _      _ e@(Lit  {}) = return e
+wwExpr _      _ e@(Var  {}) = return e
 
-wwExpr dflags (Lam binder expr)
-  = Lam binder <$> wwExpr dflags expr
+wwExpr dflags fam_envs (Lam binder expr)
+  = Lam binder <$> wwExpr dflags fam_envs expr
 
-wwExpr dflags (App f a)
-  = App <$> wwExpr dflags f <*> wwExpr dflags a
+wwExpr dflags fam_envs (App f a)
+  = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a
 
-wwExpr dflags (Tick note expr)
-  = Tick note <$> wwExpr dflags expr
+wwExpr dflags fam_envs (Tick note expr)
+  = Tick note <$> wwExpr dflags fam_envs expr
 
-wwExpr dflags (Cast expr co) = do
-    new_expr <- wwExpr dflags expr
+wwExpr dflags fam_envs (Cast expr co) = do
+    new_expr <- wwExpr dflags fam_envs expr
     return (Cast new_expr co)
 
-wwExpr dflags (Let bind expr)
-  = mkLets <$> wwBind dflags bind <*> wwExpr dflags expr
+wwExpr dflags fam_envs (Let bind expr)
+  = mkLets <$> wwBind dflags fam_envs bind <*> wwExpr dflags fam_envs expr
 
-wwExpr dflags (Case expr binder ty alts) = do
-    new_expr <- wwExpr dflags expr
+wwExpr dflags fam_envs (Case expr binder ty alts) = do
+    new_expr <- wwExpr dflags fam_envs expr
     new_alts <- mapM ww_alt alts
     return (Case new_expr binder ty new_alts)
   where
     ww_alt (con, binders, rhs) = do
-        new_rhs <- wwExpr dflags rhs
+        new_rhs <- wwExpr dflags fam_envs rhs
         return (con, binders, new_rhs)
 \end{code}
 
@@ -238,6 +240,7 @@ it appears in the first place in the defining module.
 
 \begin{code}
 tryWW   :: DynFlags
+        -> FamInstEnvs
         -> RecFlag
 	-> Id				-- The fn binder
 	-> CoreExpr			-- The bound rhs; its innards
@@ -247,7 +250,7 @@ tryWW   :: DynFlags
 					-- the orig "wrapper" lives on);
 					-- if two, then a worker and a
 					-- wrapper.
-tryWW dflags is_rec fn_id rhs
+tryWW dflags fam_envs is_rec fn_id rhs
   | isNeverActive inline_act
 	-- No point in worker/wrappering if the thing is never inlined!
 	-- Because the no-inline prag will prevent the wrapper ever
@@ -258,8 +261,8 @@ tryWW dflags is_rec fn_id rhs
 
   | otherwise
   = do
-    let doSplit | is_fun    = splitFun dflags new_fn_id fn_info wrap_dmds res_info rhs
-                | is_thunk  = splitThunk dflags is_rec new_fn_id rhs
+    let doSplit | is_fun    = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds res_info rhs
+                | is_thunk  = splitThunk dflags fam_envs is_rec new_fn_id rhs
 	                                        -- See Note [Thunk splitting]
                 | otherwise = return Nothing
     try <- doSplit
@@ -309,12 +312,12 @@ checkSize dflags fn_id rhs thing_inside
     inline_rule = mkInlineUnfolding Nothing rhs
 
 ---------------------
-splitFun :: DynFlags -> Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr
+splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr
          -> UniqSM (Maybe [(Id, CoreExpr)])
-splitFun dflags fn_id fn_info wrap_dmds res_info rhs
+splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs
   = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) do
     -- The arity should match the signature
-    stuff <- mkWwBodies dflags fun_ty wrap_dmds res_info one_shots
+    stuff <- mkWwBodies dflags fam_envs fun_ty wrap_dmds res_info one_shots
     case stuff of
       Just (work_demands, wrap_fn, work_fn) -> do
         work_uniq <- getUniqueM
@@ -449,9 +452,9 @@ then the splitting will go deeper too.
 --     -->  x = let x = e in
 --              case x of (a,b) -> let x = (a,b)  in x
 
-splitThunk :: DynFlags -> RecFlag -> Var -> Expr Var -> UniqSM (Maybe [(Var, Expr Var)])
-splitThunk dflags is_rec fn_id rhs = do
-    (useful,_, wrap_fn, work_fn) <- mkWWstr dflags [fn_id]
+splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM (Maybe [(Var, Expr Var)])
+splitThunk dflags fam_envs is_rec fn_id rhs = do
+    (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs [fn_id]
     let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]
     if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive
                    return (Just res)
diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs
index 8cfc0c998d..57937d696f 100644
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -23,6 +23,7 @@ import TysPrim          ( voidPrimTy )
 import TysWiredIn       ( tupleCon )
 import Type
 import Coercion hiding  ( substTy, substTyVarBndr )
+import FamInstEnv
 import BasicTypes       ( TupleSort(..), OneShotInfo(..), worstOneShot )
 import Literal          ( absentLiteralOf )
 import TyCon
@@ -105,6 +106,7 @@ the unusable strictness-info into the interfaces.
 
 \begin{code}
 mkWwBodies :: DynFlags
+           -> FamInstEnvs
            -> Type                                  -- Type of original function
            -> [Demand]                              -- Strictness of original function
            -> DmdResult                             -- Info about function result
@@ -124,14 +126,14 @@ mkWwBodies :: DynFlags
 --                        let x = (a,b) in
 --                        E
 
-mkWwBodies dflags fun_ty demands res_info one_shots
+mkWwBodies dflags fam_envs fun_ty demands res_info one_shots
   = do  { let arg_info = demands `zip` (one_shots ++ repeat NoOneShotInfo)
               all_one_shots = foldr (worstOneShot . snd) OneShotLam arg_info
         ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs emptyTvSubst fun_ty arg_info
-        ; (useful1, work_args, wrap_fn_str, work_fn_str) <- mkWWstr dflags wrap_args
+        ; (useful1, work_args, wrap_fn_str, work_fn_str) <- mkWWstr dflags fam_envs wrap_args
 
         -- Do CPR w/w.  See Note [Always do CPR w/w]
-        ; (useful2, wrap_fn_cpr, work_fn_cpr,  cpr_res_ty) <- mkWWcpr res_ty res_info
+        ; (useful2, wrap_fn_cpr, work_fn_cpr,  cpr_res_ty) <- mkWWcpr fam_envs res_ty res_info
 
         ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args all_one_shots cpr_res_ty
               worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]
@@ -371,6 +373,7 @@ That's why we carry the TvSubst through mkWWargs
 
 \begin{code}
 mkWWstr :: DynFlags
+        -> FamInstEnvs
         -> [Var]                                -- Wrapper args; have their demand info on them
                                                 --  *Includes type variables*
         -> UniqSM (Bool,                        -- Is this useful
@@ -382,12 +385,12 @@ mkWWstr :: DynFlags
                    CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,
                                                 -- and lacking its lambdas.
                                                 -- This fn does the reboxing
-mkWWstr _ []
+mkWWstr _ _ []
   = return (False, [], nop_fn, nop_fn)
 
-mkWWstr dflags (arg : args) = do
-    (useful1, args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags arg
-    (useful2, args2, wrap_fn2, work_fn2) <- mkWWstr dflags args
+mkWWstr dflags fam_envs (arg : args) = do
+    (useful1, args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags fam_envs arg
+    (useful2, args2, wrap_fn2, work_fn2) <- mkWWstr dflags fam_envs args
     return (useful1 || useful2, args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
 
 \end{code}
@@ -426,8 +429,9 @@ as-yet-un-filled-in pkgState files.
 --        brings into scope work_args (via cases)
 --   * work_fn assumes work_args are in scope, a
 --        brings into scope wrap_arg (via lets)
-mkWWstr_one :: DynFlags -> Var -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-mkWWstr_one dflags arg
+mkWWstr_one :: DynFlags -> FamInstEnvs -> Var
+    -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
+mkWWstr_one dflags fam_envs arg
   | isTyVar arg
   = return (False, [arg],  nop_fn, nop_fn)
 
@@ -463,7 +467,7 @@ mkWWstr_one dflags arg
   , Just cs <- splitProdDmd_maybe dmd
       -- See Note [Unpacking arguments with product and polymorphic demands]
   , Just (data_con, inst_tys, inst_con_arg_tys, co)
-             <- deepSplitProductType_maybe (idType arg)
+             <- deepSplitProductType_maybe fam_envs (idType arg)
   , cs `equalLength` inst_con_arg_tys
       -- See Note [mkWWstr and unsafeCoerce]
   =  do { (uniq1:uniqs) <- getUniquesM
@@ -473,7 +477,7 @@ mkWWstr_one dflags arg
                                               data_con unpk_args
                 rebox_fn       = Let (NonRec arg con_app)
                 con_app        = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
-         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags unpk_args_w_ds
+         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs unpk_args_w_ds
          ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
                            -- Don't pass the arg, rebox instead
 
@@ -503,29 +507,31 @@ If so, the worker/wrapper split doesn't work right and we get a Core Lint
 bug.  The fix here is simply to decline to do w/w if that happens.
 
 \begin{code}
-deepSplitProductType_maybe :: Type -> Maybe (DataCon, [Type], [Type], Coercion)
+deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe (DataCon, [Type], [Type], Coercion)
 -- If    deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)
 -- then  dc @ tys (args::arg_tys) :: rep_ty
 --       co :: ty ~ rep_ty
-deepSplitProductType_maybe ty
-  | let (co, ty1) = topNormaliseNewType_maybe ty `orElse` (mkReflCo Representational ty, ty)
+deepSplitProductType_maybe fam_envs ty
+  | let (co, ty1) = topNormaliseType_maybe fam_envs ty
+                    `orElse` (mkReflCo Representational ty, ty)
   , Just (tc, tc_args) <- splitTyConApp_maybe ty1
   , Just con <- isDataProductTyCon_maybe tc
   = Just (con, tc_args, dataConInstArgTys con tc_args, co)
-deepSplitProductType_maybe _ = Nothing
+deepSplitProductType_maybe _ _ = Nothing
 
-deepSplitCprType_maybe :: ConTag -> Type -> Maybe (DataCon, [Type], [Type], Coercion)
+deepSplitCprType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe (DataCon, [Type], [Type], Coercion)
 -- If    deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co)
 -- then  dc @ tys (args::arg_tys) :: rep_ty
 --       co :: ty ~ rep_ty
-deepSplitCprType_maybe con_tag ty
-  | let (co, ty1) = topNormaliseNewType_maybe ty `orElse` (mkReflCo Representational ty, ty)
+deepSplitCprType_maybe fam_envs con_tag ty
+  | let (co, ty1) = topNormaliseType_maybe fam_envs ty
+                    `orElse` (mkReflCo Representational ty, ty)
   , Just (tc, tc_args) <- splitTyConApp_maybe ty1
   , isDataTyCon tc
   , let cons = tyConDataCons tc
         con = ASSERT( cons `lengthAtLeast` con_tag ) cons !! (con_tag - fIRST_TAG)
   = Just (con, tc_args, dataConInstArgTys con tc_args, co)
-deepSplitCprType_maybe _ _ = Nothing
+deepSplitCprType_maybe _ _ _ = Nothing
 \end{code}
 
 
@@ -546,17 +552,18 @@ left-to-right traversal of the result structure.
 
 
 \begin{code}
-mkWWcpr :: Type                              -- function body type
+mkWWcpr :: FamInstEnvs
+        -> Type                              -- function body type
         -> DmdResult                         -- CPR analysis results
         -> UniqSM (Bool,                     -- Is w/w'ing useful?
                    CoreExpr -> CoreExpr,     -- New wrapper
                    CoreExpr -> CoreExpr,     -- New worker
                    Type)                     -- Type of worker's body
 
-mkWWcpr body_ty res
+mkWWcpr fam_envs body_ty res
   = case returnsCPR_maybe res of
        Nothing      -> return (False, id, id, body_ty)  -- No CPR info
-       Just con_tag | Just stuff <- deepSplitCprType_maybe con_tag body_ty
+       Just con_tag | Just stuff <- deepSplitCprType_maybe fam_envs con_tag body_ty
                     -> mkWWcpr_help stuff
                     |  otherwise
                        -- See Note [non-algebraic or open body type warning]
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 0887bf7b99..af2b2fa483 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -1185,6 +1185,12 @@ topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)
 --
 -- The function returns @Nothing@ for non-@newtypes@,
 -- or unsaturated applications
+--
+-- This function does *not* look through type families, because it has no access to
+-- the type family environment. If you do have that at hand, consider to use
+-- topNormaliseType_maybe, which should be a drop-in replacement for
+-- topNormaliseNewType_maybe
+--
 topNormaliseNewType_maybe ty
   = go initRecTc Nothing ty
   where