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
import DataCon
import TyCon
import Module
+import Packages( isDllName )
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 )
-> [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'
= do { let { dflags = hsc_dflags hsc_env
; omit_prags = dopt Opt_OmitInterfacePragmas dflags
- ; th = dopt Opt_TemplateHaskell dflags
+ ; expose_all = dopt Opt_ExposeAllUnfoldings dflags
+ ; th = xopt 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)
; 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,
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
})
| 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
= 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}
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 }
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
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 &&
(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
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 (dfunArgExprs 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
(occ_env', occ') = tidyOccName occ_env new_occ
- mk_new_local nc = (nc { nsUniqs = us2 }, mkInternalName uniq occ' loc)
+ mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc)
where
- (us1, us2) = splitUniqSupply (nsUniqs nc)
- uniq = uniqFromSupply us1
+ (uniq, us) = takeUniqFromSupply (nsUniqs nc)
mk_new_external nc = allocateGlobalBinder nc mod occ' loc
-- If we want to externalise a currently-local name, check
-- 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:
-- 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 unf_info unf_from_rhs
+ | otherwise = noUnfolding
+ unf_from_rhs = mkTopUnfolding is_bot tidy_rhs
+ is_bot = case final_sig of
+ Just sig -> isBottomingSig sig
+ Nothing -> False
+ -- 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@(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
+ --------- 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
\end{code}
%************************************************************************
\begin{code}
hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
hasCafRefs this_pkg p arity expr
- | is_caf || mentions_cafs
- = MayHaveCafRefs
+ | is_caf || mentions_cafs = MayHaveCafRefs
| otherwise = NoCafRefs
where
mentions_cafs = isFastTrue (cafRefs p expr)
- is_caf = not (arity > 0 || rhsIsStatic this_pkg expr)
+ is_dynamic_name = isDllName this_pkg
+ is_caf = not (arity > 0 || rhsIsStatic is_dynamic_name expr)
-- NB. we pass in the arity of the expression, which is expected
-- to be calculated by exprArity. This is because exprArity