X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=7d045632ba52a09577c9fa270c566c7ba81c0e05;hp=291887539345e0b51ed1ea683fad1d55759d0493;hb=a51fe79ebcdcb8285573a18f12cade2101533419;hpb=72462499b891d5779c19f3bda03f96e24f9554ae diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 2918875..7d04563 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -18,15 +18,16 @@ import CoreFVs import CoreTidy import CoreMonad import CoreUtils -import CoreArity ( exprArity ) -import Class ( classSelIds ) +import Rules +import CoreArity ( exprArity, exprBotStrictness_maybe ) +import Class ( classAllSelIds ) import VarEnv import VarSet import Var import Id import IdInfo import InstEnv -import NewDemand +import Demand import BasicTypes import Name hiding (varName) import NameSet @@ -38,11 +39,11 @@ import TyCon import Module import HscTypes import Maybes -import ErrUtils import UniqSupply import Outputable import FastBool hiding ( fastOr ) import Util +import FastString import Data.List ( sortBy ) import Data.IORef ( IORef, readIORef, writeIORef ) @@ -133,7 +134,7 @@ mkBootModDetails :: HscEnv -> [AvailInfo] -> NameEnv TyThing -> [Instance] -> [FamInstEnv.FamInst] -> IO ModDetails mkBootModDetails hsc_env exports type_env insts fam_insts = do { let dflags = hsc_dflags hsc_env - ; showPass dflags "Tidy [hoot] type env" + ; showPass dflags CoreTidy ; let { insts' = tidyInstances globaliseAndTidyId insts ; dfun_ids = map instanceDFunId insts' @@ -298,16 +299,20 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, = do { let { dflags = hsc_dflags hsc_env ; omit_prags = dopt Opt_OmitInterfacePragmas dflags + ; expose_all = dopt Opt_ExposeAllUnfoldings dflags ; th = dopt Opt_TemplateHaskell dflags } - ; showPass dflags "Tidy Core" + ; showPass dflags CoreTidy ; let { implicit_binds = getImplicitBinds type_env } ; (unfold_env, tidy_occ_env) - <- chooseExternalIds hsc_env mod omit_prags binds implicit_binds imp_rules + <- chooseExternalIds hsc_env mod omit_prags expose_all + binds implicit_binds imp_rules ; let { ext_rules = findExternalRules omit_prags binds imp_rules unfold_env } + -- Glom together imp_rules and rules currently attached to binders + -- Then pick just the ones we need to expose -- See Note [Which rules to expose] ; let { (tidy_env, tidy_binds) @@ -338,7 +343,15 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) } - ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds tidy_rules + ; endPass dflags CoreTidy all_tidy_binds tidy_rules + + -- If the endPass didn't print the rules, but ddump-rules is on, print now + ; dumpIfSet (dopt Opt_D_dump_rules dflags + && (not (dopt Opt_D_dump_simpl dflags))) + CoreTidy + (ptext (sLit "rules")) + (pprRulesForUser tidy_rules) + ; let dir_imp_mods = moduleEnvKeys dir_imps ; return (CgGuts { cg_module = mod, @@ -353,7 +366,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, ModDetails { md_types = tidy_type_env, md_rules = tidy_rules, md_insts = tidy_insts, - md_vect_info = tidy_vect_info, md_fam_insts = fam_insts, + md_vect_info = tidy_vect_info, + md_fam_insts = fam_insts, md_exports = exports, md_anns = anns -- are already tidy }) @@ -440,7 +454,7 @@ mustExposeTyCon exports tc | isEnumerationTyCon tc -- For an enumeration, exposing the constructors = True -- won't lead to the need for further exposure -- (This includes data types with no constructors.) - | isOpenTyCon tc -- Open type family + | isFamilyTyCon tc -- Open type family = True | otherwise -- Newtype, datatype @@ -546,11 +560,11 @@ 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 (AClass cls) = classAllSelIds cls implicit_ids _ = [] get_defn :: Id -> CoreBind - get_defn id = NonRec id (unfoldingTemplate (idUnfolding id)) + get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) \end{code} @@ -572,14 +586,14 @@ type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-}) chooseExternalIds :: HscEnv -> Module - -> Bool + -> Bool -> Bool -> [CoreBind] -> [CoreBind] -> [CoreRule] -> IO (UnfoldEnv, TidyOccEnv) -- Step 1 from the notes above -chooseExternalIds hsc_env mod omit_prags binds implicit_binds imp_id_rules +chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders ; tidy_internal internal_ids unfold_env1 occ_env1 } @@ -650,7 +664,7 @@ chooseExternalIds hsc_env mod omit_prags binds implicit_binds imp_id_rules let (new_ids, show_unfold) | omit_prags = ([], False) - | otherwise = addExternal refined_id + | otherwise = addExternal expose_all refined_id -- 'idocc' is an *occurrence*, but we need to see the -- unfolding in the *definition*; so look up in binder_set @@ -672,8 +686,8 @@ chooseExternalIds hsc_env mod omit_prags binds implicit_binds imp_id_rules let unfold_env' = extendVarEnv unfold_env id (name',False) tidy_internal ids unfold_env' occ_env' -addExternal :: Id -> ([Id],Bool) -addExternal id = (new_needed_ids, show_unfold) +addExternal :: Bool -> Id -> ([Id],Bool) +addExternal expose_all id = (new_needed_ids, show_unfold) where new_needed_ids = unfold_ids ++ filter (\id -> isLocalId id && @@ -681,9 +695,9 @@ addExternal id = (new_needed_ids, show_unfold) (varSetElems spec_ids) -- XXX non-det ordering idinfo = idInfo id - dont_inline = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) + never_active = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) loop_breaker = isNonRuleLoopBreaker (occInfo idinfo) - bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig) + bottoming_fn = isBottomingSig (strictnessInfo idinfo `orElse` topSig) spec_ids = specInfoFreeVars (specInfo idinfo) -- Stuff to do with the Id's unfolding @@ -694,14 +708,30 @@ addExternal id = (new_needed_ids, show_unfold) mb_unfold_ids :: Maybe (IdSet, [Id]) -- Nothing => don't unfold mb_unfold_ids = case unfoldingInfo idinfo of - CoreUnfolding { uf_tmpl = unf_rhs, uf_guidance = guide } - | not bottoming_fn -- Not necessary - , not dont_inline - , not loop_breaker - , not (neverUnfoldGuidance guide) - -> Just (exprFvsInOrder unf_rhs) - DFunUnfolding _ ops -> Just (exprsFvsInOrder ops) - _ -> Nothing + CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_guidance = guide } + | show_unfolding src guide + -> Just (unf_ext_ids src unf_rhs) + DFunUnfolding _ _ ops -> Just (exprsFvsInOrder ops) + _ -> Nothing + where + unf_ext_ids (InlineWrapper v) _ = (unitVarSet v, [v]) + unf_ext_ids _ unf_rhs = exprFvsInOrder unf_rhs + -- For a wrapper, externalise the wrapper id rather than the + -- fvs of the rhs. The two usually come down to the same thing + -- but I've seen cases where we had a wrapper id $w but a + -- rhs where $w had been inlined; see Trac #3922 + + show_unfolding unf_source unf_guidance + = expose_all -- 'expose_all' says to expose all + -- unfoldings willy-nilly + + || isStableSource unf_source -- Always expose things whose + -- source is an inline rule + + || not (bottoming_fn -- No need to inline bottom functions + || never_active -- Or ones that say not to + || loop_breaker -- Or that are loop breakers + || neverUnfoldGuidance unf_guidance) -- We want a deterministic free-variable list. exprFreeVars gives us -- a VarSet, which is in a non-deterministic order when converted to a @@ -969,41 +999,14 @@ tidyTopPair :: Bool -- show unfolding -- in the IdInfo of one early in the group tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs) - = (bndr', rhs') + = (bndr1, rhs1) where - 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 - idinfo' = tidyTopIdInfo (isExternalName name') - idinfo unfold_info - arity caf_info - - unfold_info | show_unfold = tidyUnfolding rhs_tidy_env rhs' (unfoldingInfo idinfo) - | otherwise = noUnfolding - -- 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. - -- One case I found was when the last thing the simplifier - -- did was to let-bind a non-atomic argument and then float - -- it to the top level. So it seems more robust just to - -- fix it here. - arity = exprArity rhs - + bndr1 = mkGlobalId details name' ty' idinfo' + details = idDetails bndr -- Preserve the IdDetails + ty' = tidyTopType (idType bndr) + rhs1 = tidyExpr rhs_tidy_env rhs + idinfo' = tidyTopIdInfo rhs_tidy_env name' rhs rhs1 (idInfo bndr) + show_unfold caf_info -- tidyTopIdInfo creates the final IdInfo for top-level -- binders. There are two delicate pieces: @@ -1017,45 +1020,99 @@ tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs) -- occurrences of the binders in RHSs, and hence to occurrences in -- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. -- CoreToStg makes use of this when constructing SRTs. -tidyTopIdInfo :: Bool -> IdInfo -> Unfolding - -> ArityInfo -> CafInfo - -> IdInfo -tidyTopIdInfo is_external idinfo unfold_info arity caf_info +tidyTopIdInfo :: TidyEnv -> Name -> CoreExpr -> CoreExpr + -> IdInfo -> Bool -> CafInfo -> IdInfo +tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold 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; -- c.f. CoreTidy.tidyLetBndr - `setCafInfo` caf_info - `setArityInfo` arity - `setAllStrictnessInfo` newStrictnessInfo idinfo + `setCafInfo` caf_info + `setArityInfo` arity + `setStrictnessInfo` final_sig | otherwise -- Externally-visible Ids get the whole lot = vanillaIdInfo `setCafInfo` caf_info `setArityInfo` arity - `setAllStrictnessInfo` newStrictnessInfo idinfo - `setInlinePragInfo` inlinePragInfo idinfo + `setStrictnessInfo` final_sig + `setOccInfo` robust_occ_info + `setInlinePragInfo` (inlinePragInfo idinfo) `setUnfoldingInfo` unfold_info -- NB: we throw away the Rules -- They have already been extracted by findExternalRules + where + is_external = isExternalName name + + --------- OccInfo ------------ + robust_occ_info = zapFragileOcc (occInfo idinfo) + -- It's important to keep loop-breaker information + -- when we are doing -fexpose-all-unfoldings + + --------- Strictness ------------ + final_sig | Just sig <- strictnessInfo idinfo + = WARN( _bottom_hidden sig, ppr name ) Just sig + | Just (_, sig) <- mb_bot_str = Just sig + | otherwise = Nothing + + -- If the cheap-and-cheerful bottom analyser can see that + -- the RHS is bottom, it should jolly well be exposed + _bottom_hidden id_sig = case mb_bot_str of + Nothing -> False + Just (arity, _) -> not (appIsBottom id_sig arity) + + mb_bot_str = exprBotStrictness_maybe orig_rhs + + --------- Unfolding ------------ + unf_info = unfoldingInfo idinfo + unfold_info | show_unfold = tidyUnfolding rhs_tidy_env tidy_rhs final_sig unf_info + | otherwise = noUnfolding + -- 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 + + --------- Arity ------------ + -- Usually the Id will have an accurate arity on it, because + -- the simplifier has just run, but not always. + -- One case I found was when the last thing the simplifier + -- did was to let-bind a non-atomic argument and then float + -- it to the top level. So it seems more robust just to + -- fix it here. + arity = exprArity orig_rhs ------------ Unfolding -------------- -tidyUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding -tidyUnfolding tidy_env _ unf@(CoreUnfolding { uf_tmpl = rhs - , uf_guidance = guide@(InlineRule {}) }) - = unf { uf_tmpl = tidyExpr tidy_env rhs, -- Preserves OccInfo - uf_guidance = guide { ug_ir_info = tidyInl tidy_env (ug_ir_info guide) } } -tidyUnfolding tidy_env _ (DFunUnfolding con ids) - = DFunUnfolding con (map (tidyExpr tidy_env) ids) -tidyUnfolding _ tidy_rhs (CoreUnfolding {}) - = mkTopUnfolding tidy_rhs -tidyUnfolding _ _ unf = unf - -tidyInl :: TidyEnv -> InlineRuleInfo -> InlineRuleInfo -tidyInl tidy_env (InlWrapper w) = InlWrapper (tidyVarOcc tidy_env w) -tidyInl _ inl_info = inl_info +tidyUnfolding :: TidyEnv -> CoreExpr -> Maybe StrictSig -> Unfolding -> Unfolding +tidyUnfolding tidy_env _ _ (DFunUnfolding ar con ids) + = DFunUnfolding ar con (map (tidyExpr tidy_env) ids) +tidyUnfolding tidy_env tidy_rhs strict_sig + unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) + | isStableSource src + = unf { uf_tmpl = tidyExpr tidy_env unf_rhs, -- Preserves OccInfo + uf_src = tidyInl tidy_env src } + | otherwise + = mkTopUnfolding is_bot tidy_rhs + where + is_bot = case strict_sig of + Just sig -> isBottomingSig sig + Nothing -> False + +tidyUnfolding _ _ _ unf = unf + +tidyInl :: TidyEnv -> UnfoldingSource -> UnfoldingSource +tidyInl tidy_env (InlineWrapper w) = InlineWrapper (tidyVarOcc tidy_env w) +tidyInl _ inl_info = inl_info \end{code} %************************************************************************