diff options
Diffstat (limited to 'compiler/typecheck/TcTypeable.hs')
| -rw-r--r-- | compiler/typecheck/TcTypeable.hs | 155 |
1 files changed, 93 insertions, 62 deletions
diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs index b750340720..0be765c949 100644 --- a/compiler/typecheck/TcTypeable.hs +++ b/compiler/typecheck/TcTypeable.hs @@ -4,7 +4,7 @@ -} module TcTypeable( - mkTypeableBinds, mkModIdBindings + mkTypeableBinds, mkPrimTypeableBinds, mkModIdBindings ) where @@ -12,7 +12,10 @@ import TcBinds( addTypecheckedBinds ) import IfaceEnv( newGlobalBinder ) import TcEnv import TcRnMonad -import PrelNames( gHC_TYPES, trModuleDataConName, trTyConDataConName, trNameSDataConName ) +import PrelNames +import TysPrim ( primTyCons ) +import TysWiredIn ( trModuleTyCon, trModuleDataCon, trTyConTyCon + , trTyConDataCon, trNameSDataCon ) import Id import Type import TyCon @@ -55,45 +58,32 @@ The overall plan is this: 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 + The TyConRepName 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, +4. Solve Typeable constraints. 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 + Module must be available right from the start; so they are wired in (and + defined in ghc-prim:GHC.Types). + +* GHC.Prim doesn't have any associated object code, so we need to put the + representations for types defined in this module elsewhere. We put these + in GHC.Types. TcTypeable.mkPrimTypeableBinds is responsible for injecting + the bindings for the GHC.Prim representions when compiling GHC.Types. + +* TyCon.tyConRepModOcc is responsible for determining where to find + the representation binding for a given type. This is where we handle + the special case for GHC.Prim. * 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. - -} {- ********************************************************************* @@ -105,24 +95,21 @@ There are many wrinkles: 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 + ; loc <- getSrcSpanM ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc - ; let mod_ty = mkTyConApp (dataConTyCon tr_mod_dc) [] - mod_id = mkExportedVanillaId mod_nm mod_ty - 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)) ] + ; let mod_id = mkExportedVanillaId mod_nm + (mkTyConApp trModuleTyCon []) + mod_bind = mkVarBind mod_id (mkModIdRHS mod) ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv ; return (tcg_env { tcg_tr_module = Just mod_id } - `addTypecheckedBinds` [unitBag mod_bind]) } } + `addTypecheckedBinds` [unitBag mod_bind]) } +mkModIdRHS :: Module -> LHsExpr Id +mkModIdRHS mod + = nlHsApps (dataConWrapId trModuleDataCon) + [ trNameLit (unitIdFS (moduleUnitId mod)) + , trNameLit (moduleNameFS (moduleName mod)) ] {- ********************************************************************* * * @@ -132,40 +119,79 @@ mkModIdBindings mkTypeableBinds :: [TyCon] -> TcM TcGblEnv mkTypeableBinds tycons - = do { dflags <- getDynFlags + = do { dflags <- getDynFlags ; gbl_env <- getGblEnv ; mod <- getModule - ; if mod == gHC_TYPES - then return gbl_env -- 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) + stuff = (dflags, mod_expr, pkg_str, mod_str) all_tycons = [ tc' | tc <- tycons, tc' <- tc : tyConATs tc ] -- We need type representations for any associated types tc_binds = map (mk_typeable_binds stuff) all_tycons tycon_rep_ids = foldr ((++) . collectHsBindsBinders) [] tc_binds ; gbl_env <- tcExtendGlobalValEnv tycon_rep_ids getGblEnv - ; return (gbl_env `addTypecheckedBinds` tc_binds) } } + ; return (gbl_env `addTypecheckedBinds` tc_binds) } + +-- | Generate bindings for the type representation of a wired-in TyCon defined +-- by the virtual "GHC.Prim" module. This is where we inject the representation +-- bindings for primitive types into "GHC.Types" +-- +-- See Note [Grand plan for Typeable] in this module. +mkPrimTypeableBinds :: TcM TcGblEnv +mkPrimTypeableBinds + = do { dflags <- getDynFlags + ; mod <- getModule + ; let prim_binds :: LHsBinds Id + prim_binds + | mod == gHC_TYPES = ghcPrimTypeableBinds dflags + | otherwise = emptyBag + prim_rep_ids = collectHsBindsBinders prim_binds + ; gbl_env <- tcExtendGlobalValEnv prim_rep_ids getGblEnv + ; return (gbl_env `addTypecheckedBinds` [prim_binds]) } + +-- | Generate bindings for the type representation of the wired-in TyCons defined +-- by the virtual "GHC.Prim" module. This differs from the usual +-- @mkTypeableBinds@ path in that here we need to lie to 'mk_typeable_binds' +-- about the module we are compiling (since we are currently compiling +-- "GHC.Types" yet are producing representations for types in "GHC.Prim"). +-- +-- See Note [Grand plan for Typeable] in this module. +ghcPrimTypeableBinds :: DynFlags -> LHsBinds Id +ghcPrimTypeableBinds dflags + = ghc_prim_module_bind `unionBags` unionManyBags (map mkBind all_prim_tys) + where + all_prim_tys :: [TyCon] + all_prim_tys = [ tc' | tc <- funTyCon : primTyCons + , tc' <- tc : tyConATs tc ] + + ghc_prim_module_id = + mkExportedVanillaId trGhcPrimModuleName (mkTyConTy trModuleTyCon) + ghc_prim_module_bind = + unitBag $ mkVarBind ghc_prim_module_id (mkModIdRHS gHC_PRIM) + + stuff :: TypeableStuff + stuff = (dflags, nlHsVar ghc_prim_module_id, "ghc-prim", "GHC.Prim") -trNameLit :: DataCon -> FastString -> LHsExpr Id -trNameLit tr_name_dc fs - = nlHsApps (dataConWrapId tr_name_dc) [nlHsLit (mkHsStringPrimLit fs)] + mkBind :: TyCon -> LHsBinds Id + mkBind = mk_typeable_binds stuff + +trNameLit :: FastString -> LHsExpr Id +trNameLit fs + = nlHsApps (dataConWrapId trNameSDataCon) [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 + ) +-- | Make bindings for the type representations of a 'TyCon' and its +-- promoted constructors. mk_typeable_binds :: TypeableStuff -> TyCon -> LHsBinds Id mk_typeable_binds stuff tycon = mkTyConRepBinds stuff tycon @@ -173,18 +199,26 @@ mk_typeable_binds stuff tycon unionManyBags (map (mkTypeableDataConBinds stuff) (tyConDataCons tycon)) mkTyConRepBinds :: TypeableStuff -> TyCon -> LHsBinds Id -mkTyConRepBinds (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon) tycon +mkTyConRepBinds stuff tycon = case tyConRepName_maybe tycon of Just rep_name -> unitBag (mkVarBind rep_id rep_rhs) where - rep_id = mkExportedVanillaId rep_name (mkTyConApp tr_tycon []) + rep_id = mkExportedVanillaId rep_name (mkTyConApp trTyConTyCon []) + rep_rhs = mkTyConRepRHS stuff tycon _ -> emptyBag + +-- | Produce typeable binds for the promoted 'TyCon' of a data constructor +mkTypeableDataConBinds :: TypeableStuff -> DataCon -> LHsBinds Id +mkTypeableDataConBinds stuff dc + = mkTyConRepBinds stuff (promoteDataCon dc) + +mkTyConRepRHS :: TypeableStuff -> TyCon -> LHsExpr Id +mkTyConRepRHS (dflags, mod_expr, pkg_str, mod_str) tycon = rep_rhs where - tr_tycon = dataConTyCon tr_datacon - rep_rhs = nlHsApps (dataConWrapId tr_datacon) + rep_rhs = nlHsApps (dataConWrapId trTyConDataCon) [ nlHsLit (word64 high), nlHsLit (word64 low) , mod_expr - , trNameLit trn_datacon (mkFastString tycon_str) ] + , trNameLit (mkFastString tycon_str) ] tycon_str = add_tick (occNameString (getOccName tycon)) add_tick s | isPromotedDataCon tycon = '\'' : s @@ -199,6 +233,3 @@ mkTyConRepBinds (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon) ty 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 - = mkTyConRepBinds stuff (promoteDataCon dc) |