X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=82021b813384a30bf36c0c73318bd627b72cfe74;hb=6c2ae9c152d147623ac45a5fe52534c99d6ba835;hp=3779a0af6b792580f5b353cc980dc61dca4b3fa3;hpb=526c3af1dc98987b6949f4df73c0debccf9875bd;p=ghc-hetmet.git diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 3779a0a..82021b8 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -20,8 +20,9 @@ import CoreLint import CoreUtils import VarEnv import VarSet -import Var hiding( mkGlobalId ) +import Var import Id +import Class import IdInfo import InstEnv import NewDemand @@ -142,6 +143,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 }) @@ -150,7 +152,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 @@ -176,7 +178,7 @@ tidyExternalId :: Id -> Id -- (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 + mkVanillaGlobal (idName id) (tidyTopType (idType id)) \end{code} @@ -253,14 +255,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, @@ -270,6 +272,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 = [] @@ -288,8 +291,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 @@ -302,10 +305,14 @@ tidyProgram hsc_env -- and indeed it does, but if omit_prags is on, ext_rules is -- empty + -- See Note [Injecting implicit bindings] + ; implicit_binds = getImplicitBinds type_env + ; all_tidy_binds = implicit_binds ++ tidy_binds + ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) } - ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds + ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds ; dumpIfSet_core dflags Opt_D_dump_simpl "Tidy Core Rules" (pprRules tidy_rules) @@ -314,7 +321,7 @@ tidyProgram hsc_env ; return (CgGuts { cg_module = mod, cg_tycons = alg_tycons, - cg_binds = tidy_binds, + cg_binds = all_tidy_binds, cg_dir_imps = dir_imp_mods, cg_foreign = foreign_stubs, cg_dep_pkgs = dep_pkgs deps, @@ -326,7 +333,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 -- }) } @@ -337,7 +345,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 @@ -351,10 +361,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 @@ -371,20 +381,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? @@ -423,6 +445,59 @@ tidyInstances tidy_dfun ispecs %************************************************************************ +%* * + 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 + 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 = [] + + get_defn :: Id -> CoreBind + get_defn id = NonRec id (unfoldingTemplate (idUnfolding id)) +\end{code} + + +%************************************************************************ %* * \subsection{Step 1: finding externals} %* *