Generate Typeable info at definition sites

This patch implements the idea floated in Trac #9858, namely that we
should generate type-representation information at the data type
declaration site, rather than when solving a Typeable constraint.

However, this turned out quite a bit harder than I expected. I still
think it's the right thing to do, and it's done now, but it was quite
a struggle.

See particularly

 * Note [Grand plan for Typeable] in TcTypeable (which is a new module)
 * Note [The overall promotion story] in DataCon (clarifies existing stuff)

The most painful bit was that to generate Typeable instances (ie
TyConRepName bindings) for every TyCon is tricky for types in ghc-prim
etc:

 * We need to have enough data types around to *define* a TyCon
 * Many of these types are wired-in

Also, to minimise the code generated for each data type, I wanted to
generate pure data, not CAFs with unpackCString# stuff floating about.

Performance
~~~~~~~~~~~
Three perf/compiler tests start to allocate quite a bit more. This isn't
surprising, because they all allocate zillions of data types, with
practically no other code, esp. T1969

 * T3294:   GHC allocates 110% more (filed #11030 to track this)
 * T1969:   GHC allocates 30% more
 * T4801:   GHC allocates 14% more
 * T5321FD: GHC allocates 13% more
 * T783:    GHC allocates 12% more
 * T9675:   GHC allocates 12% more
 * T5642:   GHC allocates 10% more
 * T9961:   GHC allocates 6% more

 * T9203:   Program allocates 54% less

I'm treating this as acceptable. The payoff comes in Typeable-heavy
code.

Remaining to do
~~~~~~~~~~~~~~~

 * I think that "TyCon" and "Module" are over-generic names to use for
   the runtime type representations used in GHC.Typeable. Better might be
   "TrTyCon" and "TrModule". But I have not yet done this

 * Add more info the the "TyCon" e.g. source location where it was
   defined

 * Use the new "Module" type to help with Trac Trac #10068

 * It would be possible to generate TyConRepName (ie Typeable
   instances) selectively rather than all the time. We'd need to persist
   the information in interface files. Lacking a motivating reason I have
   not done this, but it would not be difficult.

Refactoring
~~~~~~~~~~~
As is so often the case, I ended up refactoring more than I intended.
In particular

 * In TyCon, a type *family* (whether type or data) is repesented by a
   FamilyTyCon
     * a algebraic data type (including data/newtype instances) is
       represented by AlgTyCon This wasn't true before; a data family
       was represented as an AlgTyCon. There are some corresponding
       changes in IfaceSyn.

     * Also get rid of the (unhelpfully named) tyConParent.

 * In TyCon define 'Promoted', isomorphic to Maybe, used when things are
   optionally promoted; and use it elsewhere in GHC.

 * Cleanup handling of knownKeyNames

 * Each TyCon, including promoted TyCons, contains its TyConRepName, if
   it has one. This is, in effect, the name of its Typeable instance.

Requires update of the haddock submodule.

Differential Revision: https://phabricator.haskell.org/D757

1 files changed, 59 insertions, 107 deletions

diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index 0da0cb1382..bba808063c 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -14,28 +14,33 @@ files for imported data types.
 module TcTyDecls(
         calcRecFlags, RecTyInfo(..),
         calcSynCycles, calcClassCycles,
+
+        -- * Roles
         RoleAnnots, extractRoleAnnots, emptyRoleAnnots, lookupRoleAnnots,
-        mkDefaultMethodIds, mkRecSelBinds, mkOneRecordSelector
+
+        -- * Implicits
+        tcAddImplicits
     ) where
 
 #include "HsVersions.h"
 
 import TcRnMonad
 import TcEnv
+import TcTypeable( mkTypeableBinds )
+import TcBinds( tcValBinds, addTypecheckedBinds )
+import TypeRep( Type(..) )
 import TcType
 import TysWiredIn( unitTy )
 import MkCore( rEC_SEL_ERROR_ID )
-import TypeRep
 import HsSyn
 import Class
 import Type
+import HscTypes
 import TyCon
-import ConLike
 import DataCon
 import Name
 import NameEnv
 import RdrName ( mkVarUnqual )
-import Var ( tyVarKind )
 import Id
 import IdInfo
 import VarEnv
@@ -379,7 +384,7 @@ calcRecFlags boot_details is_boot mrole_env tyclss
                    -- Recursion of newtypes/data types can happen via
                    -- the class TyCon, so tyclss includes the class tycons
 
-    is_promotable = all (isPromotableTyCon rec_tycon_names) all_tycons
+    is_promotable = all (computeTyConPromotability rec_tycon_names) all_tycons
 
     roles = inferRoles is_boot mrole_env all_tycons
 
@@ -473,70 +478,6 @@ findLoopBreakers deps
 {-
 ************************************************************************
 *                                                                      *
-                  Promotion calculation
-*                                                                      *
-************************************************************************
-
-See Note [Checking whether a group is promotable]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We only want to promote a TyCon if all its data constructors
-are promotable; it'd be very odd to promote some but not others.
-
-But the data constructors may mention this or other TyCons.
-
-So we treat the recursive uses as all OK (ie promotable) and
-do one pass to check that each TyCon is promotable.
-
-Currently type synonyms are not promotable, though that
-could change.
--}
-
-isPromotableTyCon :: NameSet -> TyCon -> Bool
-isPromotableTyCon rec_tycons tc
-  =  isAlgTyCon tc    -- Only algebraic; not even synonyms
-                      -- (we could reconsider the latter)
-  && ok_kind (tyConKind tc)
-  && case algTyConRhs tc of
-       DataTyCon { data_cons = cs }   -> all ok_con cs
-       NewTyCon { data_con = c }      -> ok_con c
-       AbstractTyCon {}               -> False
-       DataFamilyTyCon {}             -> False
-       TupleTyCon { tup_sort = sort } -> case sort of
-                                           BoxedTuple      -> True
-                                           UnboxedTuple    -> False
-                                           ConstraintTuple -> False
-  where
-    ok_kind kind = all isLiftedTypeKind args && isLiftedTypeKind res
-            where  -- Checks for * -> ... -> * -> *
-              (args, res) = splitKindFunTys kind
-
-    -- See Note [Promoted data constructors] in TyCon
-    ok_con con = all (isLiftedTypeKind . tyVarKind) ex_tvs
-              && null eq_spec   -- No constraints
-              && null theta
-              && all (isPromotableType rec_tycons) orig_arg_tys
-       where
-         (_, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig con
-
-
-isPromotableType :: NameSet -> Type -> Bool
--- Must line up with DataCon.promoteType
--- But the function lives here because we must treat the
--- *recursive* tycons as promotable
-isPromotableType rec_tcs con_arg_ty
-  = go con_arg_ty
-  where
-    go (TyConApp tc tys) =  tys `lengthIs` tyConArity tc
-                         && (tyConName tc `elemNameSet` rec_tcs
-                             || isJust (promotableTyCon_maybe tc))
-                         && all go tys
-    go (FunTy arg res)   = go arg && go res
-    go (TyVarTy {})      = True
-    go _                 = False
-
-{-
-************************************************************************
-*                                                                      *
         Role annotations
 *                                                                      *
 ************************************************************************
@@ -859,6 +800,27 @@ updateRoleEnv name n role
                               RIS { role_env = role_env', update = True }
                          else state )
 
+
+{- *********************************************************************
+*                                                                      *
+                Building implicits
+*                                                                      *
+********************************************************************* -}
+
+tcAddImplicits :: [TyThing] -> TcM TcGblEnv
+tcAddImplicits tyclss
+  = discardWarnings $
+    tcExtendGlobalEnvImplicit implicit_things  $
+    tcExtendGlobalValEnv def_meth_ids          $
+    do { (rec_sel_ids, rec_sel_binds)   <- mkRecSelBinds tycons
+       ; (typeable_ids, typeable_binds) <- mkTypeableBinds tycons
+       ; gbl_env <- tcExtendGlobalValEnv (rec_sel_ids ++ typeable_ids) getGblEnv
+       ; return (gbl_env `addTypecheckedBinds` (rec_sel_binds ++ typeable_binds)) }
+ where
+   implicit_things = concatMap implicitTyThings tyclss
+   tycons          = [tc | ATyCon tc <- tyclss]
+   def_meth_ids    = mkDefaultMethodIds tyclss
+
 {-
 ************************************************************************
 *                                                                      *
@@ -893,53 +855,49 @@ must bring the default method Ids into scope first (so they can be seen
 when typechecking the [d| .. |] quote, and typecheck them later.
 -}
 
-mkRecSelBinds :: [TyThing] -> HsValBinds Name
--- NB We produce *un-typechecked* bindings, rather like 'deriving'
---    This makes life easier, because the later type checking will add
---    all necessary type abstractions and applications
+mkRecSelBinds :: [TyCon] -> TcM ([Id], [LHsBinds Id])
 mkRecSelBinds tycons
-  = ValBindsOut [(NonRecursive, b) | b <- binds] sigs
-  where
-    (sigs, binds) = unzip rec_sels
-    rec_sels = map mkRecSelBind [ (tc,fld)
-                                | ATyCon tc <- tycons
-                                , fld <- tyConFieldLabels tc ]
-
-
-mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
+  = do { -- We generate *un-typechecked* bindings in mkRecSelBind, and
+         -- then typecheck them, rather like 'deriving'. This makes life
+         -- easier, because the later type checking will add all necessary
+         -- type abstractions and applications
+
+         let sel_binds :: [(RecFlag, LHsBinds Name)]
+             sel_sigs  :: [LSig Name]
+             (sel_sigs, sel_binds)
+                = mapAndUnzip mkRecSelBind [ (tc,fld)
+                                           | tc <- tycons
+                                           , fld <- tyConFieldLabels tc ]
+             sel_ids = [sel_id | L _ (IdSig sel_id) <- sel_sigs]
+       ; (sel_binds, _) <- tcValBinds TopLevel sel_binds sel_sigs (return ())
+       ; return (sel_ids, map snd sel_binds) }
+
+mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, (RecFlag, LHsBinds Name))
 mkRecSelBind (tycon, fl)
-  = mkOneRecordSelector all_cons (RecSelData tycon) fl
-  where
-    all_cons     = map RealDataCon (tyConDataCons tycon)
-
-mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel
-              -> (LSig Name, LHsBinds Name)
-mkOneRecordSelector all_cons idDetails fl =
-    (L loc (IdSig sel_id), unitBag (L loc sel_bind))
+  = (L loc (IdSig sel_id), (NonRecursive, unitBag (L loc sel_bind)))
   where
     loc    = getSrcSpan sel_name
+    sel_id = mkExportedLocalId rec_details sel_name sel_ty
     lbl      = flLabel fl
     sel_name = flSelector fl
-
-    sel_id = mkExportedLocalId rec_details sel_name sel_ty
-    rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty }
+    rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
 
     -- Find a representative constructor, con1
-
-    cons_w_field = conLikesWithFields all_cons [lbl]
+    all_cons     = tyConDataCons tycon
+    cons_w_field = tyConDataConsWithFields tycon [lbl]
     con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
+
     -- Selector type; Note [Polymorphic selectors]
-    field_ty   = conLikeFieldType con1 lbl
+    field_ty   = dataConFieldType con1 lbl
+    data_ty    = dataConOrigResTy con1
     data_tvs   = tyVarsOfType data_ty
     is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)
     (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
     sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]
            | otherwise  = mkForAllTys (varSetElemsKvsFirst $
                                        data_tvs `extendVarSetList` field_tvs) $
-                          mkPhiTy (conLikeStupidTheta con1) $   -- Urgh!
+                          mkPhiTy (dataConStupidTheta con1) $   -- Urgh!
                           mkPhiTy field_theta               $   -- Urgh!
-                          -- req_theta is empty for normal DataCon
-                          mkPhiTy req_theta                 $
                           mkFunTy data_ty field_tau
 
     -- Make the binding: sel (C2 { fld = x }) = x
@@ -976,14 +934,8 @@ mkOneRecordSelector all_cons idDetails fl =
         --              data instance T Int a where
         --                 A :: { fld :: Int } -> T Int Bool
         --                 B :: { fld :: Int } -> T Int Char
-    dealt_with :: ConLike -> Bool
-    dealt_with (PatSynCon _) = False -- We can't predict overlap
-    dealt_with con@(RealDataCon dc) =
-      con `elem` cons_w_field || dataConCannotMatch inst_tys dc
-
-    (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1
-
-    inst_tys = substTyVars (mkTopTvSubst eq_spec) univ_tvs
+    dealt_with con = con `elem` cons_w_field || dataConCannotMatch inst_tys con
+    inst_tys = substTyVars (mkTopTvSubst (dataConEqSpec con1)) (dataConUnivTyVars con1)
 
     unit_rhs = mkLHsTupleExpr []
     msg_lit = HsStringPrim "" (fastStringToByteString lbl)