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, 206 insertions, 0 deletions

diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs
new file mode 100644
index 0000000000..f015eec79f
--- /dev/null
+++ b/compiler/typecheck/TcTypeable.hs
@@ -0,0 +1,206 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1999
+-}
+
+module TcTypeable(
+    mkTypeableBinds, mkModIdBindings
+  ) where
+
+
+import TcBinds( addTypecheckedBinds )
+import IfaceEnv( newGlobalBinder )
+import TcEnv
+import TcRnMonad
+import PrelNames( gHC_TYPES, trModuleDataConName, trTyConDataConName, trNameSDataConName )
+import Id
+import IdInfo( IdDetails(..) )
+import Type
+import TyCon
+import DataCon
+import Name( getOccName )
+import OccName
+import Module
+import HsSyn
+import DynFlags
+import Bag
+import Fingerprint(Fingerprint(..), fingerprintString)
+import Outputable
+import Data.Word( Word64 )
+import FastString ( FastString, mkFastString )
+
+{- Note [Grand plan for Typeable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The overall plan is this:
+
+1. Generate a binding for each module p:M
+   (done in TcTypeable by mkModIdBindings)
+       M.$trModule :: GHC.Types.Module
+       M.$trModule = Module "p" "M"
+   ("tr" is short for "type representation"; see GHC.Types)
+
+   We might want to add the filename too.
+   This can be used for the lightweight stack-tracing stuff too
+
+   Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv
+
+2. Generate a binding for every data type declaration T in module M,
+       M.$tcT :: GHC.Types.TyCon
+       M.$tcT = TyCon ...fingerprint info...
+                      $trModule
+                      "T"
+   We define (in TyCon)
+      type TyConRepName = Name
+   to use for these M.$tcT "tycon rep names".
+
+3. Record the TyConRepName in T's TyCon, including for promoted
+   data and type constructors, and kinds like * and #.
+
+   The TyConRepNaem is not an "implicit Id".  It's more like a record
+   selector: the TyCon knows its name but you have to go to the
+   interface file to find its type, value, etc
+
+4. Solve Typeable costraints.  This is done by a custom Typeable solver,
+   currently in TcInteract, that use M.$tcT so solve (Typeable T).
+
+There are many wrinkles:
+
+* Since we generate $tcT for every data type T, the types TyCon and
+  Module must be available right from the start; so they are defined
+  in ghc-prim:GHC.Types
+
+* To save space and reduce dependencies, we need use quite low-level
+  representations for TyCon and Module.  See GHC.Types
+  Note [Runtime representation of modules and tycons]
+
+* It's hard to generate the TyCon/Module bindings when the types TyCon
+  and Module aren't yet available; i.e. when compiling GHC.Types
+  itself.  So we *don't* generate them for types in GHC.Types.  Instead
+  we write them by hand in base:GHC.Typeable.Internal.
+
+* To be able to define them by hand, they need to have user-writable
+  names, thus
+        tcBool    not $tcBool    for the type-rep TyCon for Bool
+  Hence PrelNames.tyConRepModOcc
+
+* Moreover for type constructors with special syntax, they need to have
+  completely hand-crafted names
+    lists    tcList         not $tc[]   for the type-rep TyCon for []
+    kinds    tcLiftedKind   not $tc*    for the type-rep TyCon for *
+  Hence PrelNames.mkSpecialTyConRepName, which takes an extra FastString
+  to use for the TyConRepName
+
+* Since listTyCon, boolTyCon etd are wired in, their TyConRepNames must
+  be wired in as well.  For these wired-in TyCons we generate the
+  TyConRepName's unique from that of the TyCon; see
+  Unique.tyConRepNameUnique, dataConRepNameUnique.
+
+-}
+
+{- *********************************************************************
+*                                                                      *
+            Building top-level binding for $trModule
+*                                                                      *
+********************************************************************* -}
+
+mkModIdBindings :: TcM TcGblEnv
+mkModIdBindings
+  = do { mod <- getModule
+       ; if mod == gHC_TYPES
+         then getGblEnv  -- Do not generate bindings for modules in GHC.Types
+         else
+    do { loc <- getSrcSpanM
+       ; tr_mod_dc  <- tcLookupDataCon trModuleDataConName
+       ; tr_name_dc <- tcLookupDataCon trNameSDataConName
+       ; mod_nm     <- newGlobalBinder mod (mkVarOcc "$trModule") loc
+       ; let mod_id   = mkExportedLocalId ReflectionId mod_nm
+                                          (mkTyConApp (dataConTyCon tr_mod_dc) [])
+             mod_bind = mkVarBind mod_id mod_rhs
+             mod_rhs  = nlHsApps (dataConWrapId tr_mod_dc)
+                           [ trNameLit tr_name_dc (unitIdFS (moduleUnitId mod))
+                           , trNameLit tr_name_dc (moduleNameFS (moduleName mod)) ]
+
+       ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
+       ; return (tcg_env { tcg_tr_module = Just mod_id }
+                 `addTypecheckedBinds` [unitBag mod_bind]) } }
+
+
+{- *********************************************************************
+*                                                                      *
+                Building type-representation bindings
+*                                                                      *
+********************************************************************* -}
+
+mkTypeableBinds :: [TyCon] -> TcM ([Id], [LHsBinds Id])
+mkTypeableBinds tycons
+  = do { dflags  <- getDynFlags
+       ; gbl_env <- getGblEnv
+       ; mod <- getModule
+       ; if mod == gHC_TYPES
+         then return ([], [])  -- Do not generate bindings for modules in GHC.Types
+         else
+    do { tr_datacon  <- tcLookupDataCon trTyConDataConName
+       ; trn_datacon <- tcLookupDataCon trNameSDataConName
+       ; let pkg_str  = unitIdString (moduleUnitId mod)
+             mod_str  = moduleNameString (moduleName mod)
+             mod_expr = case tcg_tr_module gbl_env of  -- Should be set by now
+                           Just mod_id -> nlHsVar mod_id
+                           Nothing     -> pprPanic "tcMkTypeableBinds" (ppr tycons)
+             stuff    = (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon)
+             tc_binds = map (mk_typeable_binds stuff) tycons
+             tycon_rep_ids = foldr ((++) . collectHsBindsBinders) [] tc_binds
+       ; return (tycon_rep_ids, tc_binds) } }
+
+trNameLit :: DataCon -> FastString -> LHsExpr Id
+trNameLit tr_name_dc fs
+  = nlHsApps (dataConWrapId tr_name_dc) [nlHsLit (mkHsStringPrimLit fs)]
+
+type TypeableStuff
+  = ( DynFlags
+    , LHsExpr Id  -- Of type GHC.Types.Module
+    , String      -- Package name
+    , String      -- Module name
+    , DataCon     -- Data constructor GHC.Types.TyCon
+    , DataCon )   -- Data constructor GHC.Types.TrNameS
+
+mk_typeable_binds :: TypeableStuff -> TyCon -> LHsBinds Id
+mk_typeable_binds stuff tycon
+  = mkTyConRepBinds stuff tycon
+    `unionBags`
+    unionManyBags (map (mkTypeableDataConBinds stuff) (tyConDataCons tycon))
+
+mkTyConRepBinds :: TypeableStuff -> TyCon -> LHsBinds Id
+mkTyConRepBinds (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon) tycon
+  = case tyConRepName_maybe tycon of
+      Just rep_name -> unitBag (mkVarBind rep_id rep_rhs)
+         where
+           rep_id  = mkExportedLocalId ReflectionId rep_name (mkTyConApp tr_tycon [])
+      _ -> emptyBag
+  where
+    tr_tycon = dataConTyCon tr_datacon
+    rep_rhs = nlHsApps (dataConWrapId tr_datacon)
+                       [ nlHsLit (word64 high), nlHsLit (word64 low)
+                       , mod_expr
+                       , trNameLit trn_datacon (mkFastString tycon_str) ]
+
+    tycon_str = add_tick (occNameString (getOccName tycon))
+    add_tick s | isPromotedDataCon tycon = '\'' : s
+               | isPromotedTyCon   tycon = '\'' : s
+               | otherwise               = s
+
+    hashThis :: String
+    hashThis = unwords [pkg_str, mod_str, tycon_str]
+
+    Fingerprint high low
+       | gopt Opt_SuppressUniques dflags = Fingerprint 0 0
+       | otherwise                       = fingerprintString hashThis
+
+    word64 :: Word64 -> HsLit
+    word64 | wORD_SIZE dflags == 4 = \n -> HsWord64Prim (show n) (toInteger n)
+           | otherwise             = \n -> HsWordPrim   (show n) (toInteger n)
+
+mkTypeableDataConBinds :: TypeableStuff -> DataCon -> LHsBinds Id
+mkTypeableDataConBinds stuff dc
+  = case promoteDataCon_maybe dc of
+      Promoted tc -> mkTyConRepBinds stuff tc
+      NotPromoted -> emptyBag