X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=2f5d31affa875922e7c2edb888e445af79f72cb1;hp=fc951cc31d4ceb4e144a3707987808a690182e06;hb=d95ce839533391e7118257537044f01cbb1d6694;hpb=219f900f4e518e8158807cdda6fdec8331f701f0 diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index fc951cc..2f5d31a 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -34,21 +34,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} @@ -146,6 +142,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 +151,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 @@ -180,7 +177,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} @@ -211,7 +208,7 @@ unit. These are This exercise takes a sweep of the bindings bottom to top. Actually, in Step 2 we're also going to need to know which Ids should be exported with their unfoldings, so we produce not an IdSet but an -IdEnv Bool +ExtIdEnv = IdEnv Bool Step 2: Tidy the program @@ -257,14 +254,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 +271,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 +290,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,21 +304,19 @@ 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 ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) } - ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds + ; endPass dflags "Tidy Core" Opt_D_dump_simpl 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 = all_tidy_binds, + cg_binds = tidy_binds, cg_dir_imps = dir_imp_mods, cg_foreign = foreign_stubs, cg_dep_pkgs = dep_pkgs deps, @@ -332,7 +328,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 +340,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 +356,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 +376,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 +436,6 @@ tidyInstances tidy_dfun ispecs where tidy ispec = setInstanceDFunId ispec $ tidy_dfun (instanceDFunId ispec) - -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 (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 \end{code} @@ -460,10 +446,12 @@ getImplicitBinds type_env %************************************************************************ \begin{code} -findExternalIds :: Bool - -> [CoreBind] - -> IdEnv Bool -- In domain => external - -- Range = True <=> show unfolding +type ExtIdEnv = IdEnv Bool + -- In domain => Id is external + -- Range = True <=> show unfolding, + -- Always True for InlineRule + +findExternalIds :: Bool -> [CoreBind] -> ExtIdEnv -- Step 1 from the notes above findExternalIds omit_prags binds | omit_prags @@ -503,8 +491,7 @@ addExternal (id,rhs) needed -- "False" because we don't know we need the Id's unfolding -- Don't override existing bindings; we might have already set it to True - new_needed_ids = worker_ids `unionVarSet` - unfold_ids `unionVarSet` + new_needed_ids = (mb_unfold_ids `orElse` emptyVarSet) `unionVarSet` spec_ids idinfo = idInfo id @@ -512,29 +499,25 @@ addExternal (id,rhs) needed loop_breaker = isNonRuleLoopBreaker (occInfo idinfo) bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig) spec_ids = specInfoFreeVars (specInfo idinfo) - worker_info = workerInfo idinfo -- Stuff to do with the Id's unfolding - -- The simplifier has put an up-to-date unfolding - -- in the IdInfo, but the RHS will do just as well - unfolding = unfoldingInfo idinfo - rhs_is_small = not (neverUnfold unfolding) - -- We leave the unfolding there even if there is a worker -- In GHCI the unfolding is used by importers - -- When writing an interface file, we omit the unfolding - -- if there is a worker - show_unfold = not bottoming_fn && -- Not necessary - not dont_inline && - not loop_breaker && - rhs_is_small -- Small enough - - unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs - | otherwise = emptyVarSet - - worker_ids = case worker_info of - HasWorker work_id _ -> unitVarSet work_id - _otherwise -> emptyVarSet + show_unfold = isJust mb_unfold_ids + + mb_unfold_ids :: Maybe IdSet -- Nothing => don't unfold + mb_unfold_ids = case unfoldingInfo idinfo of + InlineRule { uf_worker = Just wkr_id } -> Just (unitVarSet wkr_id) + InlineRule { uf_tmpl = rhs } -> Just (exprFreeIds rhs) + CoreUnfolding { uf_guidance = guide } + | not bottoming_fn -- Not necessary + , not dont_inline + , not loop_breaker + , not (neverUnfoldGuidance guide) + -> Just (exprFreeIds rhs) -- The simplifier has put an up-to-date unfolding + -- in the IdInfo, but the RHS will do just as well + + _ -> Nothing \end{code} @@ -591,8 +574,7 @@ findExternalRules binds non_local_rules ext_ids tidyTopBinds :: HscEnv -> Module -> TypeEnv - -> IdEnv Bool -- Domain = Ids that should be external - -- True <=> their unfolding is external too + -> ExtIdEnv -> [CoreBind] -> IO (TidyEnv, [CoreBind]) @@ -631,8 +613,7 @@ tidyTopBinds hsc_env mod type_env ext_ids binds tidyTopBind :: PackageId -> Module -> IORef NameCache -- For allocating new unique names - -> IdEnv Bool -- Domain = Ids that should be external - -- True <=> their unfolding is external too + -> ExtIdEnv -> TidyEnv -> CoreBind -> IO (TidyEnv, CoreBind) @@ -744,17 +725,18 @@ 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' + -- Preserve the GlobalIdDetails of existing global-ids + details = case globalIdDetails bndr of + NotGlobalId -> VanillaGlobal + old_details -> old_details ty' = tidyTopType (idType bndr) rhs' = tidyExpr rhs_tidy_env rhs idinfo = idInfo bndr idinfo' = tidyTopIdInfo (isJust maybe_external) - idinfo unfold_info worker_info + idinfo unfold_info arity caf_info -- Expose an unfolding if ext_ids tells us to @@ -762,9 +744,21 @@ tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) -- True to show the unfolding, False to hide it maybe_external = lookupVarEnv ext_ids bndr show_unfold = maybe_external `orElse` False - unfold_info | show_unfold = mkTopUnfolding rhs' + unfold_info | show_unfold = tidyUnfolding rhs_tidy_env rhs' (unfoldingInfo idinfo) | otherwise = noUnfolding - worker_info = tidyWorker rhs_tidy_env show_unfold (workerInfo idinfo) + -- NB: do *not* expose the worker if show_unfold is off, + -- because that means this thing is a loop breaker or + -- marked NOINLINE or something like that + -- This is important: if you expose the worker for a loop-breaker + -- then you can make the simplifier go into an infinite loop, because + -- in effect the unfolding is exposed. See Trac #1709 + -- + -- You might think that if show_unfold is False, then the thing should + -- not be w/w'd in the first place. But a legitimate reason is this: + -- the function returns bottom + -- In this case, show_unfold will be false (we don't expose unfoldings + -- for bottoming functions), but we might still have a worker/wrapper + -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.lhs -- Usually the Id will have an accurate arity on it, because -- the simplifier has just run, but not always. @@ -788,9 +782,9 @@ tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) -- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. -- CoreToStg makes use of this when constructing SRTs. tidyTopIdInfo :: Bool -> IdInfo -> Unfolding - -> WorkerInfo -> ArityInfo -> CafInfo + -> ArityInfo -> CafInfo -> IdInfo -tidyTopIdInfo is_external idinfo unfold_info worker_info arity caf_info +tidyTopIdInfo is_external idinfo unfold_info arity caf_info | not is_external -- For internal Ids (not externally visible) = vanillaIdInfo -- we only need enough info for code generation -- Arity and strictness info are enough; @@ -806,32 +800,19 @@ tidyTopIdInfo is_external idinfo unfold_info worker_info arity caf_info `setAllStrictnessInfo` newStrictnessInfo idinfo `setInlinePragInfo` inlinePragInfo idinfo `setUnfoldingInfo` unfold_info - `setWorkerInfo` worker_info -- NB: we throw away the Rules -- They have already been extracted by findExternalRules ------------- Worker -------------- -tidyWorker :: TidyEnv -> Bool -> WorkerInfo -> WorkerInfo -tidyWorker _tidy_env _show_unfold NoWorker - = NoWorker -tidyWorker tidy_env show_unfold (HasWorker work_id wrap_arity) - | show_unfold = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity - | otherwise = NoWorker - -- NB: do *not* expose the worker if show_unfold is off, - -- because that means this thing is a loop breaker or - -- marked NOINLINE or something like that - -- This is important: if you expose the worker for a loop-breaker - -- then you can make the simplifier go into an infinite loop, because - -- in effect the unfolding is exposed. See Trac #1709 - -- - -- You might think that if show_unfold is False, then the thing should - -- not be w/w'd in the first place. But a legitimate reason is this: - -- the function returns bottom - -- In this case, show_unfold will be false (we don't expose unfoldings - -- for bottoming functions), but we might still have a worker/wrapper - -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.lhs +------------ Unfolding -------------- +tidyUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding +tidyUnfolding tidy_env _ unf@(InlineRule { uf_tmpl = rhs, uf_worker = mb_wkr }) + = unf { uf_tmpl = tidyExpr tidy_env rhs, + uf_worker = fmap (tidyVarOcc tidy_env) mb_wkr } +tidyUnfolding _ tidy_rhs (CoreUnfolding {}) + = mkTopUnfolding tidy_rhs +tidyUnfolding _ _ unf = unf \end{code} %************************************************************************