X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=530e54ccac8505e8eea82c8d5c0a18d81bf66f3c;hp=64f3498ad422aa5c8e76584d091a51b3f4366669;hb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2;hpb=30c122df62ec75f9ed7f392f24c2925675bf1d06 diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 64f3498..530e54c 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,9 +19,11 @@ import CoreTidy import PprCore import CoreLint import CoreUtils +import CoreArity ( exprArity ) +import Class ( classSelIds ) import VarEnv import VarSet -import Var hiding( mkGlobalId ) +import Var import Id import IdInfo import InstEnv @@ -30,7 +33,6 @@ import Name import NameSet import IfaceEnv import NameEnv -import OccName import TcType import DataCon import TyCon @@ -43,7 +45,6 @@ import Outputable import FastBool hiding ( fastOr ) import Data.List ( partition ) -import Data.Maybe ( isJust ) import Data.IORef ( IORef, readIORef, writeIORef ) \end{code} @@ -133,7 +134,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 @@ -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 @@ -159,7 +161,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 ] @@ -170,13 +172,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} @@ -253,14 +259,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 +276,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 +295,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,19 +309,23 @@ 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) - ; 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, - 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 +337,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 +349,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 +365,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 +385,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 +449,62 @@ 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. + +Oh: two other reasons for injecting them late: + - If implicit Ids are already in the bindings when we start TidyPgm, + we'd have to be careful not to treat them as external Ids (in + the sense of findExternalIds); else the Ids mentioned in *their* + RHSs will be treated as external and you get an interface file + saying a18 = + but nothing refererring to a18 (because the implicit Id is the + one that does). + + - More seriously, the tidied type-envt will include the implicit + Id replete with a18 in its unfolding; but we won't take account + of a18 when computing a fingerprint for the class; result chaos. + + +\begin{code} +getImplicitBinds :: TypeEnv -> [CoreBind] +getImplicitBinds type_env + = map get_defn (concatMap implicit_ids (typeEnvElts type_env)) + where + 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 (unfoldingTemplate (idUnfolding id)) +\end{code} + + +%************************************************************************ %* * \subsection{Step 1: finding externals} %* * @@ -477,7 +559,7 @@ addExternal (id,rhs) needed spec_ids idinfo = idInfo id - dont_inline = isNeverActive (inlinePragInfo idinfo) + dont_inline = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) loop_breaker = isNonRuleLoopBreaker (occInfo idinfo) bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig) spec_ids = specInfoFreeVars (specInfo idinfo) @@ -716,10 +798,7 @@ tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) = (bndr', rhs') where bndr' = mkGlobalId details name' ty' idinfo' - -- Preserve the GlobalIdDetails of existing global-ids - details = case globalIdDetails bndr of - NotGlobalId -> VanillaGlobal - old_details -> old_details + details = idDetails bndr -- Preserve the IdDetails ty' = tidyTopType (idType bndr) rhs' = tidyExpr rhs_tidy_env rhs idinfo = idInfo bndr