import PprCore ( pprCoreBindings, pprCoreExpr, pprRules )
import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import IdInfo ( setNewStrictnessInfo, newStrictnessInfo,
- setUnfoldingInfo, unfoldingInfo, setSpecInfoHead,
+ setWorkerInfo, workerInfo, setSpecInfoHead,
setInlinePragInfo, inlinePragInfo,
setSpecInfo, specInfo, specInfoRules )
import CoreUtils ( coreBindsSize )
import FamInstEnv
import Id
import DataCon
-import TyCon ( tyConSelIds, tyConDataCons )
+import TyCon ( tyConDataCons )
import Class ( classSelIds )
import BasicTypes ( CompilerPhase, isActive )
import VarSet
-- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
-- would mean our cached value would go out of date.
let mod = mg_module guts
- (guts, stats) <- runCoreM hsc_env ann_env imp_rule_base cp_us mod $ do
+ (guts2, stats) <- runCoreM hsc_env ann_env imp_rule_base cp_us mod $ do
-- FIND BUILT-IN PASSES
let builtin_core_todos = getCoreToDo dflags
- -- Note [Injecting implicit bindings]
- let implicit_binds = getImplicitBinds (mg_types guts1)
- guts2 = guts1 { mg_binds = implicit_binds ++ mg_binds guts1 }
-
-- DO THE BUSINESS
- doCorePasses builtin_core_todos guts2
+ doCorePasses builtin_core_todos guts1
Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
"Grand total simplifier statistics"
(pprSimplCount stats)
- return guts
+ return guts2
type CorePass = CoreToDo
%************************************************************************
%* *
- Implicit bindings
-%* *
-%************************************************************************
-
-Note [Injecting implicit bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We used to inject the implict bindings right at the end, in CoreTidy.
-But 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.
-(Only matters when the selector is used curried; eg map x ys.)
-See Trac #2070.
-
-\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}
-
-
-%************************************************************************
-%* *
Dealing with rules
%* *
%************************************************************************
ModGuts) -- Modified fields are
-- (a) Bindings have rules attached,
- -- and INLINE rules simplified
-- (b) Rules are now just orphan rules
prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
guts@(ModGuts { mg_binds = binds, mg_deps = deps
, mg_rules = local_rules, mg_rdr_env = rdr_env })
us
- = do { us <- mkSplitUniqSupply 'w'
-
- ; let -- Simplify the local rules; boringly, we need to make an in-scope set
+ = do { let -- Simplify the local rules; boringly, we need to make an in-scope set
-- from the local binders, to avoid warnings from Simplify.simplVar
local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
env = setInScopeSet gentleSimplEnv local_ids
- (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
- mapM (simplRule env) local_rules
-
- ; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules
-
- home_pkg_rules = hptRules hsc_env (dep_mods deps)
- hpt_rule_base = mkRuleBase home_pkg_rules
- imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
-
- binds_w_rules = updateBinders rules_for_locals binds
-
+ (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
+ (mapM (simplRule env) local_rules)
+ home_pkg_rules = hptRules hsc_env (dep_mods deps)
+
+ -- Find the rules for locally-defined Ids; then we can attach them
+ -- to the binders in the top-level bindings
+ --
+ -- Reason
+ -- - It makes the rules easier to look up
+ -- - It means that transformation rules and specialisations for
+ -- locally defined Ids are handled uniformly
+ -- - It keeps alive things that are referred to only from a rule
+ -- (the occurrence analyser knows about rules attached to Ids)
+ -- - It makes sure that, when we apply a rule, the free vars
+ -- of the RHS are more likely to be in scope
+ -- - The imported rules are carried in the in-scope set
+ -- which is extended on each iteration by the new wave of
+ -- local binders; any rules which aren't on the binding will
+ -- thereby get dropped
+ (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
+ local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
+ binds_w_rules = updateBinders local_rule_base binds
+
+ hpt_rule_base = mkRuleBase home_pkg_rules
+ imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
(withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
- vcat [text "Local rules", pprRules simpl_rules,
+ vcat [text "Local rules", pprRules better_rules,
text "",
text "Imported rules", pprRuleBase imp_rule_base])
mg_rules = rules_for_imps })
}
--- Note [Attach rules to local ids]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Find the rules for locally-defined Ids; then we can attach them
--- to the binders in the top-level bindings
---
--- Reason
--- - It makes the rules easier to look up
--- - It means that transformation rules and specialisations for
--- locally defined Ids are handled uniformly
--- - It keeps alive things that are referred to only from a rule
--- (the occurrence analyser knows about rules attached to Ids)
--- - It makes sure that, when we apply a rule, the free vars
--- of the RHS are more likely to be in scope
--- - The imported rules are carried in the in-scope set
--- which is extended on each iteration by the new wave of
--- local binders; any rules which aren't on the binding will
--- thereby get dropped
-
-updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind]
-updateBinders rules_for_locals binds
- = map update_bind binds
+updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
+updateBinders local_rules binds
+ = map update_bndrs binds
where
- local_rules = extendRuleBaseList emptyRuleBase rules_for_locals
-
- update_bind (NonRec b r) = NonRec (add_rules b) r
- update_bind (Rec prs) = Rec (mapFst add_rules prs)
-
- -- See Note [Attach rules to local ids]
- -- NB: the binder might have some existing rules,
- -- arising from specialisation pragmas
- add_rules bndr
- | Just rules <- lookupNameEnv local_rules (idName bndr)
- = bndr `addIdSpecialisations` rules
- | otherwise
- = bndr
+ update_bndrs (NonRec b r) = NonRec (update_bndr b) r
+ update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
+
+ update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of
+ Nothing -> bndr
+ Just rules -> bndr `addIdSpecialisations` rules
+ -- The binder might have some existing rules,
+ -- arising from specialisation pragmas
\end{code}
Note [Simplifying the left-hand side of a RULE]
otherwise we don't match when given an argument like
augment (\a. h a a) (build h)
-The simplifier does indeed do eta reduction (it's in
-Simplify.completeLam) but only if -O is on.
-
\begin{code}
simplRule env rule@(BuiltinRule {})
= return rule
args' <- mapM (simplExprGently env) args
rhs' <- simplExprGently env rhs
return (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
+
+-- It's important that simplExprGently does eta reduction.
+-- For example, in a rule like:
+-- augment g (build h)
+-- we do not want to get
+-- augment (\a. g a) (build h)
+-- otherwise we don't match when given an argument like
+-- (\a. h a a)
+--
+-- The simplifier does indeed do eta reduction (it's in
+-- Simplify.completeLam) but only if -O is on.
\end{code}
\begin{code}
where
local_info = idInfo local_id
transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
- `setUnfoldingInfo` unfoldingInfo local_info
+ `setWorkerInfo` workerInfo local_info
`setInlinePragInfo` inlinePragInfo local_info
`setSpecInfo` addSpecInfo (specInfo exp_info) new_info
new_info = setSpecInfoHead (idName exported_id)