SimplifierMode(..), DynFlags, DynFlag(..), dopt,
getCoreToDo, shouldDumpSimplPhase )
import CoreSyn
+import CoreSubst
import HscTypes
import CSE ( cseProgram )
import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
addSpecInfo, addIdSpecialisations )
import PprCore ( pprCoreBindings, pprCoreExpr, pprRules )
import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
-import IdInfo ( setNewStrictnessInfo, newStrictnessInfo,
- setUnfoldingInfo, unfoldingInfo, setSpecInfoHead,
- setInlinePragInfo, inlinePragInfo,
- setSpecInfo, specInfo, specInfoRules )
+import IdInfo
import CoreUtils ( coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
-import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
+import SimplUtils ( simplEnvForGHCi, simplEnvForRules )
+import SimplEnv
import SimplMonad
import CoreMonad
-import qualified ErrUtils as Err ( dumpIfSet_dyn, dumpIfSet, showPass )
-import CoreLint ( showPass, endPass, endPassIf, endIteration )
+import qualified ErrUtils as Err
+import CoreLint
+import CoreMonad ( endPass )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import FamInstEnv
import Id
import DataCon
-import TyCon ( tyConSelIds, tyConDataCons )
+import TyCon ( tyConDataCons )
import Class ( classSelIds )
-import BasicTypes ( CompilerPhase, isActive )
+import BasicTypes ( CompilerPhase, isActive, isDefaultInlinePragma )
import VarSet
import VarEnv
import NameEnv ( lookupNameEnv )
import SpecConstr ( specConstrProgram)
import DmdAnal ( dmdAnalPgm )
import WorkWrap ( wwTopBinds )
-#ifdef OLD_STRICTNESS
-import StrictAnal ( saBinds )
-import CprAnalyse ( cprAnalyse )
-#endif
import Vectorise ( vectorise )
import FastString
import Util
import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
-import IO ( hPutStr, stderr )
import Outputable
import Control.Monad
-import List ( partition, intersperse )
+import Data.List
+import System.IO
import Maybes
\end{code}
ann_env <- prepareAnnotations hsc_env (Just guts)
-- COMPUTE THE RULE BASE TO USE
- (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us
+ (hpt_rule_base, guts1) <- prepareRules hsc_env guts ru_us
-- Get the module out of the current HscEnv so we can retrieve it from the monad.
-- This is very convienent for the users of the monad (e.g. plugins do not have to
-- _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 hpt_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
-> IO CoreExpr
-- simplifyExpr is called by the driver to simplify an
-- expression typed in at the interactive prompt
+--
+-- Also used by Template Haskell
simplifyExpr dflags expr
= do {
; Err.showPass dflags "Simplify"
; us <- mkSplitUniqSupply 's'
; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
- simplExprGently gentleSimplEnv expr
+ simplExprGently simplEnvForGHCi expr
; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
(pprCoreExpr expr')
; return expr'
}
-gentleSimplEnv :: SimplEnv
-gentleSimplEnv = mkSimplEnv SimplGently (isAmongSimpl [])
-
doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
doCorePasses passes guts = foldM (flip doCorePass) guts passes
doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
describePassR "SpecConstr" Opt_D_dump_spec $
- doPassDU specConstrProgram
+ specConstrProgram
doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-}
describePass "Vectorisation" Opt_D_dump_vect $
doCorePass CoreDoPrintCore = dontDescribePass $ observe printCore
doCorePass (CoreDoRuleCheck phase pat) = dontDescribePass $ ruleCheck phase pat
-#ifdef OLD_STRICTNESS
-doCorePass CoreDoOldStrictness = {-# SCC "OldStrictness" #-} doOldStrictness
-#endif
-
doCorePass CoreDoNothing = return
doCorePass (CoreDoPasses passes) = doCorePasses passes
-
-#ifdef OLD_STRICTNESS
-doOldStrictness :: ModGuts -> CoreM ModGuts
-doOldStrictness guts
- = do dfs <- getDynFlags
- guts' <- describePass "Strictness analysis" Opt_D_dump_stranal $
- doPassM (saBinds dfs) guts
- guts'' <- describePass "Constructed Product analysis" Opt_D_dump_cpranal $
- doPass cprAnalyse guts'
- return guts''
-#endif
-
\end{code}
%************************************************************************
describePass name dflag pass guts = do
dflags <- getDynFlags
- liftIO $ showPass dflags name
+ liftIO $ Err.showPass dflags name
guts' <- pass guts
- liftIO $ endPass dflags name dflag (mg_binds guts')
-
+ liftIO $ endPass dflags name dflag (mg_binds guts') (mg_rules guts')
+
return guts'
describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
%************************************************************************
%* *
- 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
%* *
%************************************************************************
; 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
+ env = setInScopeSet simplEnvForRules local_ids
(simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
mapM (simplRule env) local_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
+ binds_w_rules = updateBinders rules_for_locals binds
; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
(withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
vcat [text "Local rules", pprRules simpl_rules,
- text "",
- text "Imported rules", pprRuleBase imp_rule_base])
+ blankLine,
+ text "Imported rules", pprRuleBase hpt_rule_base])
- ; return (imp_rule_base, guts { mg_binds = binds_w_rules,
+ ; return (hpt_rule_base, guts { mg_binds = binds_w_rules,
mg_rules = rules_for_imps })
}
Simplify.completeLam) but only if -O is on.
\begin{code}
+simplRule :: SimplEnv -> CoreRule -> SimplM CoreRule
simplRule env rule@(BuiltinRule {})
= return rule
simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
= do (env, bndrs') <- simplBinders env bndrs
args' <- mapM (simplExprGently env) args
rhs' <- simplExprGently env rhs
- return (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
+ return (rule { ru_bndrs = bndrs', ru_args = args'
+ , ru_rhs = occurAnalyseExpr rhs' })
\end{code}
\begin{code}
do { hsc_env <- getHscEnv
; us <- getUniqueSupplyM
; rb <- getRuleBase
- ; let fam_inst_env = mg_fam_inst_env guts
- dump_phase = shouldDumpSimplPhase (hsc_dflags hsc_env) mode
- simplify_pgm = simplifyPgmIO dump_phase mode switches
- hsc_env us rb fam_inst_env
-
- ; doPassM (liftIOWithCount . simplify_pgm) guts }
+ ; liftIOWithCount $
+ simplifyPgmIO mode switches hsc_env us rb guts }
where
doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode)
-simplifyPgmIO :: Bool
- -> SimplifierMode
- -> [SimplifierSwitch]
- -> HscEnv
- -> UniqSupply
- -> RuleBase
- -> FamInstEnv
- -> [CoreBind]
- -> IO (SimplCount, [CoreBind]) -- New bindings
-
-simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env binds
+simplifyPgmIO :: SimplifierMode
+ -> [SimplifierSwitch]
+ -> HscEnv
+ -> UniqSupply
+ -> RuleBase
+ -> ModGuts
+ -> IO (SimplCount, ModGuts) -- New bindings
+
+simplifyPgmIO mode switches hsc_env us hpt_rule_base
+ guts@(ModGuts { mg_binds = binds, mg_rules = rules
+ , mg_fam_inst_env = fam_inst_env })
= do {
- (termination_msg, it_count, counts_out, binds')
- <- do_iteration us 1 (zeroSimplCount dflags) binds ;
+ (termination_msg, it_count, counts_out, guts')
+ <- do_iteration us 1 (zeroSimplCount dflags) binds rules ;
Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
"Simplifier statistics for following pass"
(vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
- text "",
+ blankLine,
pprSimplCount counts_out]);
- return (counts_out, binds')
+ return (counts_out, guts')
}
where
- dflags = hsc_dflags hsc_env
+ dflags = hsc_dflags hsc_env
+ dump_phase = shouldDumpSimplPhase dflags mode
sw_chkr = isAmongSimpl switches
max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
- do_iteration us iteration_no counts binds
+ do_iteration :: UniqSupply
+ -> Int -- Counts iterations
+ -> SimplCount -- Logs optimisations performed
+ -> [CoreBind] -- Bindings in
+ -> [CoreRule] -- and orphan rules
+ -> IO (String, Int, SimplCount, ModGuts)
+
+ do_iteration us iteration_no counts binds rules
-- iteration_no is the number of the iteration we are
-- about to begin, with '1' for the first
| iteration_no > max_iterations -- Stop if we've run out of iterations
" iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" ))
-- Subtract 1 from iteration_no to get the
-- number of iterations we actually completed
- return ("Simplifier bailed out", iteration_no - 1, counts, binds)
+ return ("Simplifier bailed out", iteration_no - 1, counts,
+ guts { mg_binds = binds, mg_rules = rules })
-- Try and force thunks off the binds; significantly reduces
-- space usage, especially with -O. JRS, 000620.
| let sz = coreBindsSize binds in sz == sz
= do {
-- Occurrence analysis
- let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ;
+ let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;
Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings tagged_binds);
-- behind the scenes. Otherwise there's a danger we'll simply
-- miss the rules for Ids hidden inside imported inlinings
eps <- hscEPS hsc_env ;
- let { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
- ; simpl_env = mkSimplEnv mode sw_chkr
+ let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
+ ; rule_base2 = extendRuleBaseList rule_base1 rules
+ ; simpl_env = mkSimplEnv sw_chkr mode
; simpl_binds = {-# SCC "SimplTopBinds" #-}
simplTopBinds simpl_env tagged_binds
; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
-- case t of {(_,counts') -> if counts'=0 then ... }
-- So the conditional didn't force counts', because the
-- selection got duplicated. Sigh!
- case initSmpl dflags rule_base' fam_envs us1 simpl_binds of {
- (binds', counts') -> do {
+ case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
+ (env1, counts1) -> do {
- let { all_counts = counts `plusSimplCount` counts'
- ; herald = "Simplifier mode " ++ showPpr mode ++
- ", iteration " ++ show iteration_no ++
- " out of " ++ show max_iterations
+ let { all_counts = counts `plusSimplCount` counts1
+ ; binds1 = getFloats env1
+ ; rules1 = substRulesForImportedIds (mkCoreSubst env1) rules
} ;
-- Stop if nothing happened; don't dump output
- if isZeroSimplCount counts' then
- return ("Simplifier reached fixed point", iteration_no,
- all_counts, binds')
+ if isZeroSimplCount counts1 then
+ return ("Simplifier reached fixed point", iteration_no, all_counts,
+ guts { mg_binds = binds1, mg_rules = rules1 })
else do {
-- Short out indirections
-- We do this *after* at least one run of the simplifier
--
-- ToDo: alas, this means that indirection-shorting does not happen at all
-- if the simplifier does nothing (not common, I know, but unsavoury)
- let { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ;
+ let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
-- Dump the result of this iteration
- Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
- (pprSimplCount counts') ;
- endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ;
+ end_iteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ;
-- Loop
- do_iteration us2 (iteration_no + 1) all_counts binds''
+ do_iteration us2 (iteration_no + 1) all_counts binds2 rules1
} } } }
where
(us1, us2) = splitUniqSupply us
+
+-------------------
+end_iteration :: DynFlags -> SimplifierMode -> Int -> Int
+ -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
+-- Same as endIteration but with simplifier counts
+end_iteration dflags mode iteration_no max_iterations counts binds rules
+ = do { Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations pass_name
+ (pprSimplCount counts) ;
+
+ ; endIteration dflags pass_name Opt_D_dump_simpl_iterations binds rules }
+ where
+ pass_name = "Simplifier mode " ++ showPpr mode ++
+ ", iteration " ++ show iteration_no ++
+ " out of " ++ show max_iterations
\end{code}
makes strictness information propagate better. This used to happen in
the final phase, but it's tidier to do it here.
+Note [Transferring IdInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to propagage any useful IdInfo on x_local to x_exported.
+
STRICTNESS: if we have done strictness analysis, we want the strictness info on
x_local to transfer to x_exported. Hence the copyIdInfo call.
RULES: we want to *add* any RULES for x_local to x_exported.
-Note [Rules and indirection-zapping]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Problem: what if x_exported has a RULE that mentions something in ...bindings...?
-Then the things mentioned can be out of scope! Solution
- a) Make sure that in this pass the usage-info from x_exported is
- available for ...bindings...
- b) If there are any such RULES, rec-ify the entire top-level.
- It'll get sorted out next time round
-Messing up the rules
-~~~~~~~~~~~~~~~~~~~~
-The example that went bad on me at one stage was this one:
+Note [Messing up the exported Id's RULES]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must be careful about discarding (obviously) or even merging the
+RULES on the exported Id. The example that went bad on me at one stage
+was this one:
iterate :: (a -> a) -> a -> [a]
[Exported]
-> iterateFB (:) f x
-> iterate f x
-Tiresome old solution:
- don't do shorting out if f has rewrite rules (see shortableIdInfo)
-
-New solution (I think):
+Old "solution":
use rule switching-off pragmas to get rid
of iterateList in the first place
+But in principle the user *might* want rules that only apply to the Id
+he says. And inline pragmas are similar
+ {-# NOINLINE f #-}
+ f = local
+ local = <stuff>
+Then we do not want to get rid of the NOINLINE.
+
+Hence hasShortableIdinfo.
+
+
+Note [Rules and indirection-zapping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Problem: what if x_exported has a RULE that mentions something in ...bindings...?
+Then the things mentioned can be out of scope! Solution
+ a) Make sure that in this pass the usage-info from x_exported is
+ available for ...bindings...
+ b) If there are any such RULES, rec-ify the entire top-level.
+ It'll get sorted out next time round
Other remarks
~~~~~~~~~~~~~
add_pair (exported_id, rhs) env
= env
+-----------------
shortMeOut ind_env exported_id local_id
-- The if-then-else stuff is just so I can get a pprTrace to see
-- how often I don't get shorting out becuase of IdInfo stuff
not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
then
- True
-
-{- No longer needed
- if isEmptySpecInfo (specInfo (idInfo exported_id)) -- Only if no rules
- then True -- See note on "Messing up rules"
- else
-#ifdef DEBUG
- pprTrace "shortMeOut:" (ppr exported_id)
-#endif
- False
--}
+ if hasShortableIdInfo exported_id
+ then True -- See Note [Messing up the exported Id's IdInfo]
+ else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
+ False
else
- False
+ False
+-----------------
+hasShortableIdInfo :: Id -> Bool
+-- True if there is no user-attached IdInfo on exported_id,
+-- so we can safely discard it
+-- See Note [Messing up the exported Id's IdInfo]
+hasShortableIdInfo id
+ = isEmptySpecInfo (specInfo info)
+ && isDefaultInlinePragma (inlinePragInfo info)
+ where
+ info = idInfo id
-----------------
transferIdInfo :: Id -> Id -> Id
+-- See Note [Transferring IdInfo]
-- If we have
-- lcl_id = e; exp_id = lcl_id
-- and lcl_id has useful IdInfo, we don't want to discard it by going
= modifyIdInfo transfer exported_id
where
local_info = idInfo local_id
- transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
+ transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info
`setUnfoldingInfo` unfoldingInfo local_info
`setInlinePragInfo` inlinePragInfo local_info
`setSpecInfo` addSpecInfo (specInfo exp_info) new_info
projects / ghc-hetmet.git / blobdiff