Generate Typeable info at definition sites

This is the second attempt at merging D757.

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

 * T1969:    GHC allocates 19% more
 * T4801:    GHC allocates 13% more
 * T5321FD:  GHC allocates 13% more
 * T9675:    GHC allocates 11% more
 * T783:     GHC allocates 11% more
 * T5642:    GHC allocates 10% more

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.

Updates haddock submodule

Test Plan: Let Harbormaster validate

Reviewers: austin, hvr, goldfire

Subscribers: goldfire, thomie

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

GHC Trac Issues: #9858

1 files changed, 139 insertions, 142 deletions

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 4fa09cb42a..93b50dfc7c 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -44,10 +44,11 @@ import TyCon
 import TcEvidence
 import TcType
 import Type
-import Kind (returnsConstraintKind)
+import Kind( isKind )
 import Coercion hiding (substCo)
 import TysWiredIn ( eqBoxDataCon, coercibleDataCon, mkListTy
-                  , mkBoxedTupleTy, charTy, typeNatKind, typeSymbolKind )
+                  , mkBoxedTupleTy, charTy
+                  , typeNatKind, typeSymbolKind )
 import Id
 import MkId(proxyHashId)
 import Class
@@ -70,15 +71,12 @@ import FastString
 import Util
 import MonadUtils
 import Control.Monad(liftM,when)
-import Fingerprint(Fingerprint(..), fingerprintString)
 
-{-
-************************************************************************
+{-**********************************************************************
 *                                                                      *
-\subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
+           Desugaring a MonoBinds
 *                                                                      *
-************************************************************************
--}
+**********************************************************************-}
 
 dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
 dsTopLHsBinds binds = ds_lhs_binds binds
@@ -815,7 +813,7 @@ dsHsWrapper (WpCompose c1 c2) e = do { e1 <- dsHsWrapper c2 e
                                      ; dsHsWrapper c1 e1 }
 dsHsWrapper (WpFun c1 c2 t1 _) e = do { x <- newSysLocalDs t1
                                       ; e1 <- dsHsWrapper c1 (Var x)
-                                      ; e2 <- dsHsWrapper c2 (e `mkCoreAppDs` e1)
+                                      ; e2 <- dsHsWrapper c2 (mkCoreAppDs (text "dsHsWrapper") e e1)
                                       ; return (Lam x e2) }
 dsHsWrapper (WpCast co)       e = ASSERT(tcCoercionRole co == Representational)
                                   dsTcCoercion co (mkCastDs e)
@@ -853,154 +851,145 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
        = (b, var, varSetElems (evVarsOfTerm term))
 
 
----------------------------------------
+{-**********************************************************************
+*                                                                      *
+           Desugaring EvTerms
+*                                                                      *
+**********************************************************************-}
+
 dsEvTerm :: EvTerm -> DsM CoreExpr
-dsEvTerm (EvId v) = return (Var v)
+dsEvTerm (EvId v)           = return (Var v)
+dsEvTerm (EvCallStack cs)   = dsEvCallStack cs
+dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev
+dsEvTerm (EvLit (EvNum n))  = mkIntegerExpr n
+dsEvTerm (EvLit (EvStr s))  = mkStringExprFS s
 
 dsEvTerm (EvCast tm co)
   = do { tm' <- dsEvTerm tm
        ; dsTcCoercion co $ mkCastDs tm' }
-                        -- 'v' is always a lifted evidence variable so it is
-                        -- unnecessary to call varToCoreExpr v here.
+         -- 'v' is always a lifted evidence variable so it is
+         -- unnecessary to call varToCoreExpr v here.
+
+dsEvTerm (EvDFunApp df tys tms)
+  = return (Var df `mkTyApps` tys `mkApps` (map Var tms))
 
-dsEvTerm (EvDFunApp df tys tms)     = return (Var df `mkTyApps` tys `mkApps` (map Var tms))
 dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v)  -- See Note [Simple coercions]
 dsEvTerm (EvCoercion co)            = dsTcCoercion co mkEqBox
+
 dsEvTerm (EvSuperClass d n)
   = do { d' <- dsEvTerm d
        ; let (cls, tys) = getClassPredTys (exprType d')
              sc_sel_id  = classSCSelId cls n    -- Zero-indexed
        ; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
 
-dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
+dsEvTerm (EvDelayedError ty msg)
+  = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
   where
     errorId = tYPE_ERROR_ID
     litMsg  = Lit (MachStr (fastStringToByteString msg))
 
-dsEvTerm (EvLit l) =
-  case l of
-    EvNum n -> mkIntegerExpr n
-    EvStr s -> mkStringExprFS s
-
-dsEvTerm (EvCallStack cs) = dsEvCallStack cs
-
-dsEvTerm (EvTypeable ev) = dsEvTypeable ev
-
-dsEvTypeable :: EvTypeable -> DsM CoreExpr
-dsEvTypeable ev =
-  do tyCl      <- dsLookupTyCon typeableClassName
-     typeRepTc <- dsLookupTyCon typeRepTyConName
-     let tyRepType = mkTyConApp typeRepTc []
-
-     (ty, rep) <-
-        case ev of
-
-          EvTypeableTyCon tc ks ->
-            do ctr       <- dsLookupGlobalId mkPolyTyConAppName
-               mkTyCon   <- dsLookupGlobalId mkTyConName
-               dflags    <- getDynFlags
-               let mkRep cRep kReps tReps =
-                     mkApps (Var ctr) [ cRep, mkListExpr tyRepType kReps
-                                            , mkListExpr tyRepType tReps ]
-
-               let kindRep k =
-                     case splitTyConApp_maybe k of
-                       Nothing -> panic "dsEvTypeable: not a kind constructor"
-                       Just (kc,ks) ->
-                         do kcRep <- tyConRep dflags mkTyCon kc
-                            reps  <- mapM kindRep ks
-                            return (mkRep kcRep [] reps)
-
-               tcRep     <- tyConRep dflags mkTyCon tc
-
-               kReps     <- mapM kindRep ks
-
-               return ( mkTyConApp tc ks
-                      , mkRep tcRep kReps []
-                      )
-
-          EvTypeableTyApp t1 t2 ->
-            do e1  <- getRep tyCl t1
-               e2  <- getRep tyCl t2
-               ctr <- dsLookupGlobalId mkAppTyName
-
-               return ( mkAppTy (snd t1) (snd t2)
-                      , mkApps (Var ctr) [ e1, e2 ]
-                      )
-
-          EvTypeableTyLit t ->
-            do e <- tyLitRep t
-               return (snd t, e)
-
-     -- TyRep -> Typeable t
-     -- see also: Note [Memoising typeOf]
-     repName <- newSysLocalDs tyRepType
-     let proxyT = mkProxyPrimTy (typeKind ty) ty
-         method = bindNonRec repName rep
-                $ mkLams [mkWildValBinder proxyT] (Var repName)
-
-     -- package up the method as `Typeable` dictionary
-     return $ mkCastDs method $ mkSymCo $ getTypeableCo tyCl ty
-
+{-**********************************************************************
+*                                                                      *
+           Desugaring Typeable dictionaries
+*                                                                      *
+**********************************************************************-}
+
+dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr
+-- Return a CoreExpr :: Typeable ty
+-- This code is tightly coupled to the representation
+-- of TypeRep, in base library Data.Typeable.Internals
+dsEvTypeable ty ev
+  = do { tyCl <- dsLookupTyCon typeableClassName   -- Typeable
+       ; let kind = typeKind ty
+             Just typeable_data_con
+                 = tyConSingleDataCon_maybe tyCl      -- "Data constructor"
+                                                      -- for Typeable
+
+       ; rep_expr <- ds_ev_typeable ty ev
+
+       -- Build Core for (let r::TypeRep = rep in \proxy. rep)
+       -- See Note [Memoising typeOf]
+       ; repName <- newSysLocalDs (exprType rep_expr)
+       ; let proxyT = mkProxyPrimTy kind ty
+             method = bindNonRec repName rep_expr
+                      $ mkLams [mkWildValBinder proxyT] (Var repName)
+
+       -- Package up the method as `Typeable` dictionary
+       ; return $ mkConApp typeable_data_con [Type kind, Type ty, method] }
+
+
+ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr
+-- Returns a CoreExpr :: TypeRep ty
+ds_ev_typeable ty EvTypeableTyCon
+  | Just (tc, ks) <- splitTyConApp_maybe ty
+  = ASSERT( all isKind ks )
+    do { ctr <- dsLookupGlobalId mkPolyTyConAppName
+                    -- mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep
+       ; tyRepTc <- dsLookupTyCon typeRepTyConName  -- TypeRep (the TyCon)
+       ; let tyRepType = mkTyConApp tyRepTc []      -- TypeRep (the Type)
+             mkRep cRep kReps tReps
+               = mkApps (Var ctr) [ cRep
+                                  , mkListExpr tyRepType kReps
+                                  , mkListExpr tyRepType tReps ]
+
+             kindRep k  -- Returns CoreExpr :: TypeRep for that kind k
+               = case splitTyConApp_maybe k of
+                   Nothing -> panic "dsEvTypeable: not a kind constructor"
+                   Just (kc,ks) -> do { kcRep <- tyConRep kc
+                                      ; reps  <- mapM kindRep ks
+                                      ; return (mkRep kcRep [] reps) }
+
+       ; tcRep <- tyConRep tc
+       ; kReps <- mapM kindRep ks
+       ; return (mkRep tcRep kReps []) }
+
+ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)
+  | Just (t1,t2) <- splitAppTy_maybe ty
+  = do { e1  <- getRep ev1 t1
+       ; e2  <- getRep ev2 t2
+       ; ctr <- dsLookupGlobalId mkAppTyName
+       ; return ( mkApps (Var ctr) [ e1, e2 ] ) }
+
+ds_ev_typeable ty (EvTypeableTyLit ev)
+  = do { fun  <- dsLookupGlobalId tr_fun
+       ; dict <- dsEvTerm ev       -- Of type KnownNat/KnownSym
+       ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty]
+       ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) }
   where
-  -- co: method -> Typeable k t
-  getTypeableCo tc t =
-    case instNewTyCon_maybe tc [typeKind t, t] of
-      Just (_,co) -> co
-      _           -> panic "Class `Typeable` is not a `newtype`."
-
-  -- Typeable t -> TyRep
-  getRep tc (ev,t) =
-    do typeableExpr <- dsEvTerm ev
-       let co     = getTypeableCo tc t
-           method = mkCastDs typeableExpr co
-           proxy  = mkTyApps (Var proxyHashId) [typeKind t, t]
-       return (mkApps method [proxy])
-
-  -- KnownNat t -> TyRep      (also used for KnownSymbol)
-  tyLitRep (ev,t) =
-    do dict <- dsEvTerm ev
-       fun  <- dsLookupGlobalId $
-               case typeKind t of
-                 k | eqType k typeNatKind    -> typeNatTypeRepName
-                   | eqType k typeSymbolKind -> typeSymbolTypeRepName
-                   | otherwise -> panic "dsEvTypeable: unknown type lit kind"
-       let finst  = mkTyApps (Var fun) [t]
-           proxy  = mkTyApps (Var proxyHashId) [typeKind t, t]
-       return (mkApps finst [ dict, proxy ])
-
-  -- This part could be cached
-  tyConRep dflags mkTyCon tc =
-    do pkgStr  <- mkStringExprFS pkg_fs
-       modStr  <- mkStringExprFS modl_fs
-       nameStr <- mkStringExprFS name_fs
-       return (mkApps (Var mkTyCon) [ int64 high, int64 low
-                                    , pkgStr, modStr, nameStr
-                                    ])
-    where
-    tycon_name                = tyConName tc
-    modl                      = nameModule tycon_name
-    pkg                       = moduleUnitId modl
-
-    modl_fs                   = moduleNameFS (moduleName modl)
-    pkg_fs                    = unitIdFS pkg
-    name_fs                   = occNameFS (nameOccName tycon_name)
-    hash_name_fs
-      | isPromotedTyCon tc    = appendFS (mkFastString "$k") name_fs
-      | isPromotedDataCon tc  = appendFS (mkFastString "$c") name_fs
-      | isTupleTyCon tc &&
-        returnsConstraintKind (tyConKind tc)
-                              = appendFS (mkFastString "$p") name_fs
-      | otherwise             = name_fs
-
-    hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, hash_name_fs]
-    Fingerprint high low = fingerprintString hashThis
-
-    int64
-      | wORD_SIZE dflags == 4 = mkWord64LitWord64
-      | otherwise             = mkWordLit dflags . fromIntegral
-
-
+    ty_kind = typeKind ty
+
+    -- tr_fun is the Name of
+    --       typeNatTypeRep    :: KnownNat    a => Proxy# a -> TypeRep
+    -- of    typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep
+    tr_fun | ty_kind `eqType` typeNatKind    = typeNatTypeRepName
+           | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName
+           | otherwise = panic "dsEvTypeable: unknown type lit kind"
+
+
+ds_ev_typeable ty ev
+  = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev)
+
+getRep :: EvTerm -> Type  -- EvTerm for Typeable ty, and ty
+       -> DsM CoreExpr    -- Return CoreExpr :: TypeRep (of ty)
+                          -- namely (typeRep# dict proxy)
+-- Remember that
+--   typeRep# :: forall k (a::k). Typeable k a -> Proxy k a -> TypeRep
+getRep ev ty
+  = do { typeable_expr <- dsEvTerm ev
+       ; typeRepId     <- dsLookupGlobalId typeRepIdName
+       ; let ty_args = [typeKind ty, ty]
+       ; return (mkApps (mkTyApps (Var typeRepId) ty_args)
+                        [ typeable_expr
+                        , mkTyApps (Var proxyHashId) ty_args ]) }
+
+tyConRep :: TyCon -> DsM CoreExpr
+-- Returns CoreExpr :: TyCon
+tyConRep tc
+  | Just tc_rep_nm <- tyConRepName_maybe tc
+  = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm
+       ; return (Var tc_rep_id) }
+  | otherwise
+  = pprPanic "tyConRep" (ppr tc)
 
 {- Note [Memoising typeOf]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1012,8 +1001,11 @@ help GHC by manually keeping the 'rep' *outside* the lambda.
 -}
 
 
-
-
+{-**********************************************************************
+*                                                                      *
+           Desugaring EvCallStack evidence
+*                                                                      *
+**********************************************************************-}
 
 dsEvCallStack :: EvCallStack -> DsM CoreExpr
 -- See Note [Overview of implicit CallStacks] in TcEvidence.hs
@@ -1025,7 +1017,7 @@ dsEvCallStack cs = do
   let srcLocTy     = mkTyConTy srcLocTyCon
   let mkSrcLoc l =
         liftM (mkCoreConApps srcLocDataCon)
-              (sequence [ mkStringExpr (showPpr df $ moduleUnitId m)
+              (sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)
                         , mkStringExprFS (moduleNameFS $ moduleName m)
                         , mkStringExprFS (srcSpanFile l)
                         , return $ mkIntExprInt df (srcSpanStartLine l)
@@ -1071,7 +1063,12 @@ dsEvCallStack cs = do
     EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
     EvCsEmpty -> panic "Cannot have an empty CallStack"
 
----------------------------------------
+{-**********************************************************************
+*                                                                      *
+           Desugaring Coercions
+*                                                                      *
+**********************************************************************-}
+
 dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
 -- This is the crucial function that moves
 -- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion