X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=f7644f67eb47d479a190f6679822b1003047756b;hp=fc951cc31d4ceb4e144a3707987808a690182e06;hb=9ffadf219cbc4f8ec57264786df936a3cee88aec;hpb=219f900f4e518e8158807cdda6fdec8331f701f0 diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index fc951cc..f7644f6 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -4,7 +4,8 @@ \section{Tidying up Core} \begin{code} -module TidyPgm( mkBootModDetailsDs, mkBootModDetailsTc, tidyProgram ) where +module TidyPgm( mkBootModDetailsDs, mkBootModDetailsTc, + tidyProgram, globaliseAndTidyId ) where #include "HsVersions.h" @@ -18,6 +19,7 @@ import CoreTidy import PprCore import CoreLint import CoreUtils +import Class ( classSelIds ) import VarEnv import VarSet import Var @@ -34,21 +36,17 @@ import OccName import TcType import DataCon import TyCon -import Class import Module import HscTypes import Maybes import ErrUtils import UniqSupply import Outputable -import FastTypes hiding (fastOr) +import FastBool hiding ( fastOr ) import Data.List ( partition ) import Data.Maybe ( isJust ) import Data.IORef ( IORef, readIORef, writeIORef ) - -_dummy :: FS.FastString -_dummy = FSLIT("") \end{code} @@ -137,7 +135,7 @@ mkBootModDetails hsc_env exports type_env insts fam_insts = do { let dflags = hsc_dflags hsc_env ; showPass dflags "Tidy [hoot] type env" - ; let { insts' = tidyInstances tidyExternalId insts + ; let { insts' = tidyInstances globaliseAndTidyId insts ; dfun_ids = map instanceDFunId insts' ; type_env1 = tidyBootTypeEnv (availsToNameSet exports) type_env ; type_env' = extendTypeEnvWithIds type_env1 dfun_ids @@ -146,6 +144,7 @@ mkBootModDetails hsc_env exports type_env insts fam_insts , md_insts = insts' , md_fam_insts = fam_insts , md_rules = [] + , md_anns = [] , md_exports = exports , md_vect_info = noVectInfo }) @@ -154,7 +153,7 @@ mkBootModDetails hsc_env exports type_env insts fam_insts tidyBootTypeEnv :: NameSet -> TypeEnv -> TypeEnv tidyBootTypeEnv exports type_env - = tidyTypeEnv True exports type_env final_ids + = tidyTypeEnv True False exports type_env final_ids where -- Find the LocalIds in the type env that are exported -- Make them into GlobalIds, and tidy their types @@ -163,7 +162,7 @@ tidyBootTypeEnv exports type_env -- because we don't tidy the OccNames, and if we don't remove -- the non-exported ones we'll get many things with the -- same name in the interface file, giving chaos. - final_ids = [ tidyExternalId id + final_ids = [ globaliseAndTidyId id | id <- typeEnvIds type_env , isLocalId id , keep_it id ] @@ -174,13 +173,17 @@ tidyBootTypeEnv exports type_env keep_it id = isExportedId id || idName id `elemNameSet` exports -tidyExternalId :: Id -> Id + +globaliseAndTidyId :: Id -> Id -- Takes an LocalId with an External Name, --- makes it into a GlobalId with VanillaIdInfo, and tidies its type --- (NB: vanillaIdInfo makes a conservative assumption about Caf-hood.) -tidyExternalId id - = ASSERT2( isLocalId id && isExternalName (idName id), ppr id ) - mkVanillaGlobal (idName id) (tidyTopType (idType id)) vanillaIdInfo +-- makes it into a GlobalId +-- * unchanged Name (might be Internal or External) +-- * unchanged details +-- * VanillaIdInfo (makes a conservative assumption about Caf-hood) +globaliseAndTidyId id + = Id.setIdType (globaliseId id) tidy_type + where + tidy_type = tidyTopType (idType id) \end{code} @@ -257,14 +260,14 @@ RHSs, so that they print nicely in interfaces. \begin{code} tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) -tidyProgram hsc_env - (ModGuts { mg_module = mod, mg_exports = exports, +tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, mg_types = type_env, mg_insts = insts, mg_fam_insts = fam_insts, mg_binds = binds, mg_rules = imp_rules, mg_vect_info = vect_info, mg_dir_imps = dir_imps, + mg_anns = anns, mg_deps = deps, mg_foreign = foreign_stubs, mg_hpc_info = hpc_info, @@ -274,6 +277,7 @@ tidyProgram hsc_env ; showPass dflags "Tidy Core" ; let { omit_prags = dopt Opt_OmitInterfacePragmas dflags + ; th = dopt Opt_TemplateHaskell dflags ; ext_ids = findExternalIds omit_prags binds ; ext_rules | omit_prags = [] @@ -292,8 +296,8 @@ tidyProgram hsc_env ; let { export_set = availsToNameSet exports ; final_ids = [ id | id <- bindersOfBinds tidy_binds, isExternalName (idName id)] - ; tidy_type_env = tidyTypeEnv omit_prags export_set type_env - final_ids + ; tidy_type_env = tidyTypeEnv omit_prags th export_set + type_env final_ids ; tidy_insts = tidyInstances (lookup_dfun tidy_type_env) insts -- A DFunId will have a binding in tidy_binds, and so -- will now be in final_env, replete with IdInfo @@ -306,8 +310,10 @@ tidyProgram hsc_env -- and indeed it does, but if omit_prags is on, ext_rules is -- empty - ; implicit_binds = getImplicitBinds type_env - ; all_tidy_binds = implicit_binds ++ tidy_binds + -- See Note [Injecting implicit bindings] + ; implicit_binds = getImplicitBinds type_env + ; all_tidy_binds = implicit_binds ++ tidy_binds + ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) } @@ -316,7 +322,7 @@ tidyProgram hsc_env "Tidy Core Rules" (pprRules tidy_rules) - ; let dir_imp_mods = map fst (moduleEnvElts dir_imps) + ; let dir_imp_mods = moduleEnvKeys dir_imps ; return (CgGuts { cg_module = mod, cg_tycons = alg_tycons, @@ -332,7 +338,8 @@ tidyProgram hsc_env md_insts = tidy_insts, md_fam_insts = fam_insts, md_exports = exports, - md_vect_info = vect_info -- is already tidy + md_anns = anns, -- are already tidy + md_vect_info = vect_info -- }) } @@ -343,7 +350,9 @@ lookup_dfun type_env dfun_id _other -> pprPanic "lookup_dfun" (ppr dfun_id) -------------------------- -tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [Id] -> TypeEnv +tidyTypeEnv :: Bool -- Compiling without -O, so omit prags + -> Bool -- Template Haskell is on + -> NameSet -> TypeEnv -> [Id] -> TypeEnv -- The competed type environment is gotten from -- Dropping any wired-in things, and then @@ -357,10 +366,10 @@ tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [Id] -> TypeEnv -- This truncates the type environment to include only the -- exported Ids and things needed from them, which saves space -tidyTypeEnv omit_prags exports type_env final_ids - = let type_env1 = filterNameEnv keep_it type_env +tidyTypeEnv omit_prags th exports type_env final_ids + = let type_env1 = filterNameEnv keep_it type_env type_env2 = extendTypeEnvWithIds type_env1 final_ids - type_env3 | omit_prags = mapNameEnv (trimThing exports) type_env2 + type_env3 | omit_prags = mapNameEnv (trimThing th exports) type_env2 | otherwise = type_env2 in type_env3 @@ -377,20 +386,32 @@ isWiredInThing :: TyThing -> Bool isWiredInThing thing = isWiredInName (getName thing) -------------------------- -trimThing :: NameSet -> TyThing -> TyThing +trimThing :: Bool -> NameSet -> TyThing -> TyThing -- Trim off inessentials, for boot files and no -O -trimThing exports (ATyCon tc) - | not (mustExposeTyCon exports tc) - = ATyCon (makeTyConAbstract tc) +trimThing th exports (ATyCon tc) + | not th && not (mustExposeTyCon exports tc) + = ATyCon (makeTyConAbstract tc) -- Note [Trimming and Template Haskell] -trimThing _exports (AnId id) +trimThing _th _exports (AnId id) | not (isImplicitId id) = AnId (id `setIdInfo` vanillaIdInfo) -trimThing _exports other_thing +trimThing _th _exports other_thing = other_thing +{- Note [Trimming and Template Haskell] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (Trac #2386) this + module M(T, makeOne) where + data T = Yay String + makeOne = [| Yay "Yep" |] +Notice that T is exported abstractly, but makeOne effectively exports it too! +A module that splices in $(makeOne) will then look for a declartion of Yay, +so it'd better be there. Hence, brutally but simply, we switch off type +constructor trimming if TH is enabled in this module. -} + + mustExposeTyCon :: NameSet -- Exports -> TyCon -- The tycon -> Bool -- Can its rep be hidden? @@ -425,31 +446,49 @@ tidyInstances tidy_dfun ispecs where tidy ispec = setInstanceDFunId ispec $ tidy_dfun (instanceDFunId ispec) +\end{code} + +%************************************************************************ +%* * + Implicit bindings +%* * +%************************************************************************ + +Note [Injecting implicit bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We inject the implict bindings right at the end, in CoreTidy. +Some of these bindings, notably record selectors, are not +constructed in an optimised form. E.g. record selector for + data T = MkT { x :: {-# UNPACK #-} !Int } +Then the unfolding looks like + x = \t. case t of MkT x1 -> let x = I# x1 in x +This generates bad code unless it's first simplified a bit. That is +why CoreUnfold.mkImplicitUnfolding uses simleExprOpt to do a bit of +optimisation first. (Only matters when the selector is used curried; +eg map x ys.) See Trac #2070. + +At one time I tried injecting the implicit bindings *early*, at the +beginning of SimplCore. But that gave rise to real difficulty, +becuase GlobalIds are supposed to have *fixed* IdInfo, but the +simplifier and other core-to-core passes mess with IdInfo all the +time. The straw that broke the camels back was when a class selector +got the wrong arity -- ie the simplifier gave it arity 2, whereas +importing modules were expecting it to have arity 1 (Trac #2844). +It's much safer just to inject them right at the end, after tidying. + + +\begin{code} getImplicitBinds :: TypeEnv -> [CoreBind] getImplicitBinds type_env - = map get_defn (concatMap implicit_con_ids (typeEnvTyCons type_env) - ++ concatMap other_implicit_ids (typeEnvElts type_env)) - -- Put the constructor wrappers first, because - -- other implicit bindings (notably the fromT functions arising - -- from generics) use the constructor wrappers. At least that's - -- what External Core likes + = map get_defn (concatMap implicit_ids (typeEnvElts type_env)) where - implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc) - - other_implicit_ids (ATyCon tc) = filter (not . isNaughtyRecordSelector) (tyConSelIds tc) - -- The "naughty" ones are not real functions at all - -- They are there just so we can get decent error messages - -- See Note [Naughty record selectors] in MkId.lhs - other_implicit_ids (AClass cl) = classSelIds cl - other_implicit_ids _other = [] + implicit_ids (ATyCon tc) = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc) + implicit_ids (AClass cls) = classSelIds cls + implicit_ids _ = [] get_defn :: Id -> CoreBind - get_defn id = NonRec id (tidyExpr emptyTidyEnv rhs) - where - rhs = unfoldingTemplate (idUnfolding id) - -- Don't forget to tidy the body ! Otherwise you get silly things like - -- \ tpl -> case tpl of tpl -> (tpl,tpl) -> tpl + get_defn id = NonRec id (unfoldingTemplate (idUnfolding id)) \end{code} @@ -744,12 +783,10 @@ tidyTopPair :: VarEnv Bool -- in the IdInfo of one early in the group tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) - | isGlobalId bndr -- Injected binding for record selector, etc - = (bndr, tidyExpr rhs_tidy_env rhs) - | otherwise = (bndr', rhs') where - bndr' = mkVanillaGlobal name' ty' idinfo' + bndr' = mkGlobalId details name' ty' idinfo' + details = idDetails bndr -- Preserve the IdDetails ty' = tidyTopType (idType bndr) rhs' = tidyExpr rhs_tidy_env rhs idinfo = idInfo bndr