SimplCore.lhs 27.3 KB
 simonpj committed Jun 22, 1999 1 2 3 4 5 6 % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[SimplCore]{Driver for simplifying @Core@ programs} \begin{code}  Ian Lynagh committed Sep 03, 2007 7 {-# OPTIONS -w #-}  Ian Lynagh committed Sep 01, 2007 8 9 10 -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See  Ian Lynagh committed Sep 04, 2007 11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings  Ian Lynagh committed Sep 01, 2007 12 13 -- for details  simonpj committed Nov 16, 2000 14 module SimplCore ( core2core, simplifyExpr ) where  simonpj committed Jun 22, 1999 15 16 17  #include "HsVersions.h"  simonmar committed Mar 18, 2005 18 import DynFlags ( CoreToDo(..), SimplifierSwitch(..),  chak committed Feb 11, 2002 19  SimplifierMode(..), DynFlags, DynFlag(..), dopt,  rl@cse.unsw.edu.au committed Feb 11, 2008 20  getCoreToDo, shouldDumpSimplPhase )  simonpj committed Jun 22, 1999 21 import CoreSyn  simonpj@microsoft.com committed Feb 05, 2008 22 import HscTypes  simonpj committed Jun 22, 1999 23 import CSE ( cseProgram )  simonpj committed Apr 28, 2005 24 25 import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase, extendRuleBaseList, pprRuleBase, ruleCheckProgram,  simonpj committed Jul 28, 2005 26  addSpecInfo, addIdSpecialisations )  simonpj committed Apr 28, 2005 27 import PprCore ( pprCoreBindings, pprCoreExpr, pprRules )  simonpj committed Jul 19, 2005 28 import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )  simonpj committed Mar 07, 2005 29 import IdInfo ( setNewStrictnessInfo, newStrictnessInfo,  simonpj@microsoft.com committed Dec 20, 2007 30  setWorkerInfo, workerInfo, setSpecInfoHead,  simonpj@microsoft.com committed May 17, 2006 31  setInlinePragInfo, inlinePragInfo,  simonpj committed Apr 28, 2005 32  setSpecInfo, specInfo, specInfoRules )  simonpj committed Jan 25, 2001 33 import CoreUtils ( coreBindsSize )  simonpj committed Jun 22, 1999 34 import Simplify ( simplTopBinds, simplExpr )  simonpj committed Dec 24, 2004 35 import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )  simonpj committed Jun 22, 1999 36 import SimplMonad  simonpj committed Sep 14, 2001 37 import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )  rl@cse.unsw.edu.au committed Feb 11, 2008 38 import CoreLint ( endPassIf, endIteration )  simonpj committed Jun 22, 1999 39 40 import FloatIn ( floatInwards ) import FloatOut ( floatOutwards )  simonpj@microsoft.com committed May 23, 2007 41 import FamInstEnv  simonpj@microsoft.com committed Feb 05, 2008 42 43 44 45 import Id import DataCon import TyCon ( tyConSelIds, tyConDataCons ) import Class ( classSelIds )  simonpj committed Jun 22, 1999 46 import VarSet  simonpj committed Mar 07, 2005 47 import VarEnv  simonpj committed Apr 28, 2005 48 import NameEnv ( lookupNameEnv )  simonpj committed Jun 22, 1999 49 50 51 import LiberateCase ( liberateCase ) import SAT ( doStaticArgs ) import Specialise ( specProgram)  simonpj committed Feb 28, 2001 52 import SpecConstr ( specConstrProgram)  simonpj committed Jul 17, 2001 53 import DmdAnal ( dmdAnalPgm )  simonpj committed Jun 22, 1999 54 import WorkWrap ( wwTopBinds )  simonpj committed Apr 22, 2002 55 56 #ifdef OLD_STRICTNESS import StrictAnal ( saBinds )  simonpj committed Jun 22, 1999 57 import CprAnalyse ( cprAnalyse )  simonpj committed Apr 22, 2002 58 #endif  rl@cse.unsw.edu.au committed Jul 16, 2007 59 import Vectorise ( vectorise )  Ian Lynagh committed Mar 29, 2008 60 import Util  simonpj committed Jun 22, 1999 61   simonmar committed Jul 11, 2000 62 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )  simonpj committed Jun 22, 1999 63 64 import IO ( hPutStr, stderr ) import Outputable  Ian Lynagh committed Mar 29, 2008 65 import Control.Monad  rl@cse.unsw.edu.au committed Feb 11, 2008 66 import List ( partition, intersperse )  simonpj@microsoft.com committed Feb 05, 2008 67 import Maybes  simonpj committed Jun 22, 1999 68 69 70 71 72 73 74 75 76 \end{code} %************************************************************************ %* * \subsection{The driver for the simplifier} %* * %************************************************************************ \begin{code}  simonpj committed Sep 13, 2002 77 78 79 core2core :: HscEnv -> ModGuts -> IO ModGuts  simonpj committed Jun 22, 1999 80   simonpj committed Apr 21, 2004 81 core2core hsc_env guts  simonpj@microsoft.com committed Feb 05, 2008 82 83 84  = do { ; let dflags = hsc_dflags hsc_env core_todos = getCoreToDo dflags  simonpj committed Nov 16, 2000 85   simonpj@microsoft.com committed Feb 05, 2008 86 87  ; us <- mkSplitUniqSupply 's' ; let (cp_us, ru_us) = splitUniqSupply us  simonpj committed Jun 22, 1999 88   simonpj committed Oct 25, 2000 89  -- COMPUTE THE RULE BASE TO USE  simonpj@microsoft.com committed Feb 05, 2008 90 91 92 93 94  ; (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us -- Note [Injecting implicit bindings] ; let implicit_binds = getImplicitBinds (mg_types guts1) guts2 = guts1 { mg_binds = implicit_binds ++ mg_binds guts1 }  keithw committed May 15, 2000 95   simonpj committed Oct 25, 2000 96  -- DO THE BUSINESS  simonpj@microsoft.com committed Feb 05, 2008 97 98 99  ; (stats, guts3) <- doCorePasses hsc_env imp_rule_base cp_us (zeroSimplCount dflags) guts2 core_todos  simonpj committed Jun 22, 1999 100   simonpj@microsoft.com committed Feb 05, 2008 101  ; dumpIfSet_dyn dflags Opt_D_dump_simpl_stats  simonpj committed Jun 22, 1999 102 103 104  "Grand total simplifier statistics" (pprSimplCount stats)  simonpj@microsoft.com committed Feb 05, 2008 105  ; return guts3 }  keithw committed May 15, 2000 106 107   simonmar committed Nov 17, 2000 108 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do  simonpj committed Nov 16, 2000 109 110  -> CoreExpr -> IO CoreExpr  simonpj committed Jan 12, 2001 111 112 -- simplifyExpr is called by the driver to simplify an -- expression typed in at the interactive prompt  simonpj committed Sep 13, 2002 113 simplifyExpr dflags expr  simonpj committed Nov 16, 2000 114  = do {  simonmar committed Nov 17, 2000 115 116  ; showPass dflags "Simplify"  simonpj committed Nov 16, 2000 117 118  ; us <- mkSplitUniqSupply 's'  simonpj@microsoft.com committed May 23, 2007 119  ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ simonpj committed Dec 24, 2004 120  simplExprGently gentleSimplEnv expr  simonpj committed Nov 16, 2000 121   simonpj committed Jan 12, 2001 122  ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"  simonpj committed Nov 16, 2000 123 124 125 126 127  (pprCoreExpr expr') ; return expr' }  simonpj committed Dec 24, 2004 128 gentleSimplEnv :: SimplEnv  simonpj@microsoft.com committed May 23, 2007 129 gentleSimplEnv = mkSimplEnv SimplGently (isAmongSimpl [])  simonpj committed Dec 24, 2004 130   simonpj committed Apr 21, 2004 131 doCorePasses :: HscEnv  simonpj committed Apr 28, 2005 132  -> RuleBase -- the imported main rule base  keithw committed May 15, 2000 133  -> UniqSupply -- uniques  simonpj committed Apr 21, 2004 134 135  -> SimplCount -- simplifier stats -> ModGuts -- local binds in (with rules attached)  keithw committed May 15, 2000 136  -> [CoreToDo] -- which passes to do  simonpj committed Apr 21, 2004 137  -> IO (SimplCount, ModGuts)  simonpj committed Jun 22, 1999 138   simonpj committed Apr 28, 2005 139 doCorePasses hsc_env rb us stats guts []  simonpj committed Apr 21, 2004 140  = return (stats, guts)  simonpj committed Jun 22, 1999 141   simonpj@microsoft.com committed Feb 09, 2007 142 143 144 doCorePasses hsc_env rb us stats guts (CoreDoPasses to_dos1 : to_dos2) = doCorePasses hsc_env rb us stats guts (to_dos1 ++ to_dos2)  simonpj committed Apr 28, 2005 145 doCorePasses hsc_env rb us stats guts (to_do : to_dos)  simonpj committed Jun 22, 1999 146  = do  keithw committed May 15, 2000 147  let (us1, us2) = splitUniqSupply us  simonpj committed Apr 28, 2005 148 149  (stats1, guts1) <- doCorePass to_do hsc_env us1 rb guts doCorePasses hsc_env rb us2 (stats plusSimplCount stats1) guts1 to_dos  simonpj committed Apr 21, 2004 150   simonpj@microsoft.com committed Feb 09, 2007 151 152 doCorePass :: CoreToDo -> HscEnv -> UniqSupply -> RuleBase -> ModGuts -> IO (SimplCount, ModGuts)  Ian Lynagh committed Aug 16, 2007 153 154 155 156 157 doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-} simplifyPgm mode sws doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} trBinds cseProgram doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} liberateCase doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} trBinds floatInwards doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} trBindsU (floatOutwards f)  simonpj@microsoft.com committed Apr 11, 2008 158 doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} trBindsU doStaticArgs  Ian Lynagh committed Aug 16, 2007 159 160 161 162 doCorePass CoreDoStrictness = {-# SCC "Stranal" #-} trBinds dmdAnalPgm doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} trBindsU wwTopBinds doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} trBindsU specProgram doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} trBindsU specConstrProgram  simonpj committed Apr 21, 2004 163 doCorePass CoreDoGlomBinds = trBinds glomBinds  Ian Lynagh committed Aug 16, 2007 164 doCorePass CoreDoVectorisation = {-# SCC "Vectorise" #-} vectorise  simonpj committed Apr 21, 2004 165 doCorePass CoreDoPrintCore = observe printCore  simonpj@microsoft.com committed Jan 16, 2008 166 doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat  simonpj committed Apr 21, 2004 167 168 doCorePass CoreDoNothing = observe (\ _ _ -> return ()) #ifdef OLD_STRICTNESS  Ian Lynagh committed Aug 16, 2007 169 doCorePass CoreDoOldStrictness = {-# SCC "OldStrictness" #-} trBinds doOldStrictness  simonpj@microsoft.com committed Jan 11, 2007 170 171 #else doCorePass CoreDoOldStrictness = panic "CoreDoOldStrictness"  simonmar committed Dec 10, 2001 172 #endif  simonpj@microsoft.com committed Feb 09, 2007 173 doCorePass (CoreDoPasses _) = panic "CoreDoPasses"  simonpj committed Jun 22, 1999 174   simonmar committed Mar 15, 2002 175 #ifdef OLD_STRICTNESS  simonpj committed Apr 21, 2004 176 doOldStrictness dfs binds  simonpj committed Apr 22, 2002 177 178 179  = do binds1 <- saBinds dfs binds binds2 <- cprAnalyse dfs binds1 return binds2  simonmar committed Dec 10, 2001 180 181 #endif  simonpj committed Apr 21, 2004 182 printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)  simonpj committed Jun 22, 1999 183   simonpj@microsoft.com committed Jan 16, 2008 184 185 186 187 188 ruleCheck phase pat hsc_env us rb guts = do let dflags = hsc_dflags hsc_env showPass dflags "RuleCheck" printDump (ruleCheckProgram phase pat rb (mg_binds guts)) return (zeroSimplCount dflags, guts)  simonpj committed Sep 14, 2001 189   simonpj committed Apr 21, 2004 190 191 192 -- Most passes return no stats and don't change rules trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> HscEnv -> UniqSupply -> RuleBase -> ModGuts  simonpj committed Apr 28, 2005 193  -> IO (SimplCount, ModGuts)  simonpj committed Apr 21, 2004 194 195 trBinds do_pass hsc_env us rb guts = do { binds' <- do_pass dflags (mg_binds guts)  simonpj committed Apr 28, 2005 196  ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }  simonpj committed Apr 21, 2004 197 198 199 200 201  where dflags = hsc_dflags hsc_env trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> HscEnv -> UniqSupply -> RuleBase -> ModGuts  simonpj committed Apr 28, 2005 202  -> IO (SimplCount, ModGuts)  simonpj committed Apr 21, 2004 203 204 trBindsU do_pass hsc_env us rb guts = do { binds' <- do_pass dflags us (mg_binds guts)  simonpj committed Apr 28, 2005 205  ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }  simonpj committed Apr 21, 2004 206 207 208 209 210 211  where dflags = hsc_dflags hsc_env -- Observer passes just peek; don't modify the bindings at all observe :: (DynFlags -> [CoreBind] -> IO a) -> HscEnv -> UniqSupply -> RuleBase -> ModGuts  simonpj committed Apr 28, 2005 212  -> IO (SimplCount, ModGuts)  simonpj committed Apr 21, 2004 213 214 observe do_pass hsc_env us rb guts = do { binds <- do_pass dflags (mg_binds guts)  simonpj committed Apr 28, 2005 215  ; return (zeroSimplCount dflags, guts) }  simonpj committed Apr 21, 2004 216 217  where dflags = hsc_dflags hsc_env  simonpj committed Jun 22, 1999 218 219 220 \end{code}  simonpj@microsoft.com committed Feb 05, 2008 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 %************************************************************************ %* * 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}  simonpj committed Sep 07, 2000 262   simonpj committed Jun 22, 1999 263 264 %************************************************************************ %* *  simonpj@microsoft.com committed Feb 05, 2008 265  Dealing with rules  simonpj committed Jun 22, 1999 266 267 268 %* * %************************************************************************  simonpj committed Oct 25, 2000 269 270 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module. -- It attaches those rules that are for local Ids to their binders, and  simonpj committed Apr 21, 2004 271 -- returns the remainder attached to Ids in an IdSet.  simonpj committed Jun 22, 1999 272 273  \begin{code}  simonpj committed Oct 09, 2003 274 prepareRules :: HscEnv  simonpj committed Oct 10, 2003 275  -> ModGuts  simonpj committed Oct 25, 2000 276  -> UniqSupply  simonpj committed Apr 21, 2004 277 278  -> IO (RuleBase, -- Rule base for imported things, incl -- (a) rules defined in this module (orphans)  simonpj committed Apr 28, 2005 279 280 281  -- (b) rules from other modules in home package -- but not things from other packages  simonpj committed Apr 21, 2004 282 283 284  ModGuts) -- Modified fields are -- (a) Bindings have rules attached, -- (b) Rules are now just orphan rules  simonpj committed Oct 25, 2000 285   simonpj committed Oct 09, 2003 286 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })  simonpj committed Jan 18, 2005 287  guts@(ModGuts { mg_binds = binds, mg_deps = deps, mg_rules = local_rules })  simonpj committed Oct 10, 2003 288  us  simonpj committed Apr 28, 2005 289  = do { let -- Simplify the local rules; boringly, we need to make an in-scope set  simonpj committed Apr 21, 2004 290 291  -- from the local binders, to avoid warnings from Simplify.simplVar local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))  simonpj committed Dec 24, 2004 292  env = setInScopeSet gentleSimplEnv local_ids  simonpj@microsoft.com committed May 23, 2007 293  (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us$  twanvl committed Jan 17, 2008 294  (mapM (simplRule env) local_rules)  simonpj committed Jan 18, 2005 295  home_pkg_rules = hptRules hsc_env (dep_mods deps)  simonpj committed Oct 25, 2000 296   simonpj committed Apr 28, 2005 297 298  -- Find the rules for locally-defined Ids; then we can attach them -- to the binders in the top-level bindings  simonpj committed Apr 21, 2004 299 300 301 302 303 304 305 306 307 308 309 310 311  -- -- 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  simonpj committed Apr 28, 2005 312  (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules  simonpj committed Apr 21, 2004 313 314  local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals binds_w_rules = updateBinders local_rule_base binds  simonpj committed Mar 05, 2001 315   simonpj committed Apr 28, 2005 316 317 318  hpt_rule_base = mkRuleBase home_pkg_rules imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps  simonpj committed Mar 05, 2001 319  ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"  simonpj committed Apr 28, 2005 320  (vcat [text "Local rules", pprRules better_rules,  simonpj committed Mar 05, 2001 321  text "",  simonpj committed Apr 21, 2004 322  text "Imported rules", pprRuleBase imp_rule_base])  simonpj committed Mar 05, 2001 323   simonpj committed Apr 28, 2005 324 325  ; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = rules_for_imps })  simonpj committed Oct 25, 2000 326  }  simonpj committed Jun 22, 1999 327   simonpj committed Apr 21, 2004 328 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]  simonpj committed Apr 28, 2005 329 updateBinders local_rules binds  simonpj committed Nov 14, 2000 330  = map update_bndrs binds  simonpj committed Oct 25, 2000 331  where  simonpj committed Nov 14, 2000 332 333 334  update_bndrs (NonRec b r) = NonRec (update_bndr b) r update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]  simonpj committed Apr 28, 2005 335 336  update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of Nothing -> bndr  simonpj committed Jul 28, 2005 337 338 339  Just rules -> bndr addIdSpecialisations rules -- The binder might have some existing rules, -- arising from specialisation pragmas  simonpj committed Oct 25, 2000 340 341 \end{code}  simonpj@microsoft.com committed Apr 22, 2008 342 343 344 345 Note [Simplifying the left-hand side of a RULE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must do some gentle simplification on the lhs (template) of each rule. The case that forced me to add this was the fold/build rule,  simonpj committed Oct 25, 2000 346 347 348 which without simplification looked like: fold k z (build (/\a. g a)) ==> ... This doesn't match unless you do eta reduction on the build argument.  simonpj@microsoft.com committed Apr 22, 2008 349 350 351 352 353 354 Similarly for a LHS 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 augment (\a. h a a) (build h)  simonpj committed Jun 22, 1999 355   simonpj committed Oct 25, 2000 356 \begin{code}  simonpj committed Apr 28, 2005 357 simplRule env rule@(BuiltinRule {})  twanvl committed Jan 17, 2008 358  = return rule  simonpj committed Apr 28, 2005 359 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })  twanvl committed Jan 17, 2008 360 361 362 363  = 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' })  simonpj committed Jan 04, 2000 364   simonpj committed Jan 12, 2001 365 366 -- It's important that simplExprGently does eta reduction. -- For example, in a rule like:  simonpj committed Jan 04, 2000 367 -- augment g (build h)  simonpj committed Jan 12, 2001 368 -- we do not want to get  simonpj committed Jan 04, 2000 369 -- augment (\a. g a) (build h)  simonpj committed Jan 12, 2001 370 -- otherwise we don't match when given an argument like  simonpj committed Jan 04, 2000 371 -- (\a. h a a)  simonpj committed Jan 12, 2001 372 373 374 375 376 377 -- -- The simplifier does indeed do eta reduction (it's in -- Simplify.completeLam) but only if -O is on. \end{code} \begin{code}  simonpj committed Sep 26, 2001 378 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr  simonpj committed Jan 12, 2001 379 380 381 382 383 384 -- Simplifies an expression -- does occurrence analysis, then simplification -- and repeats (twice currently) because one pass -- alone leaves tons of crud. -- Used (a) for user expressions typed in at the interactive prompt -- (b) the LHS and RHS of a RULE  simonpj@microsoft.com committed Apr 22, 2008 385 -- (c) Template Haskell splices  simonpj committed Nov 08, 2002 386 387 388 389 390 -- -- The name 'Gently' suggests that the SimplifierMode is SimplGently, -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't -- enforce that; it just simplifies the expression twice  simonpj@microsoft.com committed Apr 22, 2008 391 392 393 394 395 -- It's important that simplExprGently does eta reduction; see -- Note [Simplifying the left-hand side of a RULE] above. The -- simplifier does indeed do eta reduction (it's in Simplify.completeLam) -- but only if -O is on.  twanvl committed Jan 17, 2008 396 397 simplExprGently env expr = do expr1 <- simplExpr env (occurAnalyseExpr expr)  simonpj committed Jul 19, 2005 398  simplExpr env (occurAnalyseExpr expr1)  simonpj committed Jun 22, 1999 399 400 \end{code}  simonpj committed Oct 25, 2000 401 402 403 404 405 406 407  %************************************************************************ %* * \subsection{Glomming} %* * %************************************************************************  simonpj committed Sep 07, 2000 408 \begin{code}  sewardj committed Oct 19, 2000 409 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]  simonpj committed Sep 07, 2000 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 -- Glom all binds together in one Rec, in case any -- transformations have introduced any new dependencies -- -- NB: the global invariant is this: -- *** the top level bindings are never cloned, and are always unique *** -- -- We sort them into dependency order, but applying transformation rules may -- make something at the top refer to something at the bottom: -- f = \x -> p (q x) -- h = \y -> 3 -- -- RULE: p (q x) = h x -- -- Applying this rule makes f refer to h, -- although it doesn't appear to in the source program. -- This pass lets us control where it happens. -- -- NOTICE that this cannot happen for rules whose head is a locally-defined -- function. It only happens for rules whose head is an imported function -- (p in the example above). So, for example, the rule had been -- RULE: f (p x) = h x -- then the rule for f would be attached to f itself (in its IdInfo) -- by prepareLocalRuleBase and h would be regarded by the occurrency -- analyser as free in f.  sewardj committed Oct 19, 2000 435 glomBinds dflags binds  simonpj committed Nov 10, 2000 436  = do { showPass dflags "GlomBinds" ;  simonpj committed Sep 07, 2000 437 438 439 440 441 442  let { recd_binds = [Rec (flattenBinds binds)] } ; return recd_binds } -- Not much point in printing the result... -- just consumes output bandwidth \end{code}  simonpj committed Oct 25, 2000 443   simonpj committed Jun 22, 1999 444 445 446 447 448 449 450 %************************************************************************ %* * \subsection{The driver for the simplifier} %* * %************************************************************************ \begin{code}  simonpj committed Apr 21, 2004 451 simplifyPgm :: SimplifierMode  simonpj committed Sep 26, 2001 452  -> [SimplifierSwitch]  simonpj committed Apr 21, 2004 453  -> HscEnv  simonpj committed Jun 22, 1999 454  -> UniqSupply  simonpj committed Apr 21, 2004 455 456  -> RuleBase -> ModGuts  simonpj committed Apr 28, 2005 457  -> IO (SimplCount, ModGuts) -- New bindings  simonpj committed Jun 22, 1999 458   simonpj committed Apr 28, 2005 459 simplifyPgm mode switches hsc_env us imp_rule_base guts  simonpj committed Jun 22, 1999 460  = do {  simonpj committed Nov 10, 2000 461  showPass dflags "Simplify";  simonpj committed Jun 22, 1999 462   simonpj committed Apr 28, 2005 463 464  (termination_msg, it_count, counts_out, binds') <- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ;  simonpj committed Jun 22, 1999 465   rl@cse.unsw.edu.au committed Feb 11, 2008 466  dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)  simonpj committed Jun 22, 1999 467 468 469 470 471  "Simplifier statistics" (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations", text "", pprSimplCount counts_out]);  rl@cse.unsw.edu.au committed Feb 11, 2008 472 473 474  endPassIf dump_phase dflags ("Simplify phase " ++ phase_info ++ " done") Opt_D_dump_simpl_phases binds';  simonpj committed Jun 22, 1999 475   simonpj committed Apr 28, 2005 476  return (counts_out, guts { mg_binds = binds' })  simonpj committed Jun 22, 1999 477 478  } where  simonpj committed Apr 28, 2005 479 480  dflags = hsc_dflags hsc_env phase_info = case mode of  rl@cse.unsw.edu.au committed Feb 11, 2008 481 482 483 484 485  SimplGently -> "gentle" SimplPhase n ss -> shows n . showString " [" . showString (concat $intersperse "," ss)$ "]"  rl@cse.unsw.edu.au committed Feb 11, 2008 486 487  dump_phase = shouldDumpSimplPhase dflags mode  simonpj committed Apr 28, 2005 488 489 490  sw_chkr = isAmongSimpl switches max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations orElse 2  simonpj committed Oct 25, 2000 491   simonpj committed Apr 28, 2005 492  do_iteration us iteration_no counts binds  simonpj committed Feb 07, 2003 493 494 495 496  -- 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 = do {  Ian Lynagh committed Mar 29, 2008 497 498  when (debugIsOn && (max_iterations > 2)) \$ hPutStr stderr ("NOTE: Simplifier still going after " ++  simonpj committed Feb 07, 2003 499  show max_iterations ++  simonpj@microsoft.com committed Oct 26, 2007 500  " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" )  simonpj committed Feb 07, 2003 501 502  -- Subtract 1 from iteration_no to get the -- number of iterations we actually completed  Ian Lynagh committed Mar 29, 2008 503  ; return ("Simplifier bailed out", iteration_no - 1, counts, binds)  simonpj committed Feb 07, 2003 504 505  }  sewardj committed Jun 20, 2000 506 507  -- Try and force thunks off the binds; significantly reduces -- space usage, especially with -O. JRS, 000620.  simonpj committed Mar 09, 2005 508  | let sz = coreBindsSize binds in sz == sz  simonpj committed Jun 22, 1999 509 510  = do { -- Occurrence analysis  Ian Lynagh committed Aug 16, 2007 511  let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ;  sewardj committed Oct 19, 2000 512  dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"  simonpj committed Jun 22, 1999 513 514  (pprCoreBindings tagged_binds);  simonpj committed Apr 21, 2004 515 516 517 518 519  -- Get any new rules, and extend the rule base -- We need to do this regularly, because simplification can -- poke on IdInfo thunks, which in turn brings in new rules -- behind the scenes. Otherwise there's a danger we'll simply -- miss the rules for Ids hidden inside imported inlinings  simonpj committed Apr 28, 2005 520 521  eps <- hscEPS hsc_env ; let { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)  simonpj@microsoft.com committed May 23, 2007 522  ; simpl_env = mkSimplEnv mode sw_chkr  Ian Lynagh committed Aug 16, 2007 523  ; simpl_binds = {-# SCC "SimplTopBinds" #-}  simonpj@microsoft.com committed May 23, 2007 524 525  simplTopBinds simpl_env tagged_binds ; fam_envs = (eps_fam_inst_env eps, mg_fam_inst_env guts) } ;  simonpj committed Apr 21, 2004 526 527  -- Simplify the program  simonmar committed Apr 19, 2000 528 529 530 531 532 533 534  -- We do this with a *case* not a *let* because lazy pattern -- matching bit us with bad space leak! -- With a let, we ended up with -- let -- t = initSmpl ... -- counts' = snd t -- in  simonpj committed Feb 07, 2003 535  -- case t of {(_,counts') -> if counts'=0 then ... }  simonmar committed Apr 19, 2000 536 537  -- So the conditional didn't force counts', because the -- selection got duplicated. Sigh!  simonpj@microsoft.com committed May 23, 2007 538  case initSmpl dflags rule_base' fam_envs us1 simpl_binds of {  simonpj committed Sep 26, 2001 539  (binds', counts') -> do {  simonpj committed Sep 17, 1999 540   simonpj committed Mar 09, 2005 541  let { all_counts = counts plusSimplCount counts'  simonpj committed Apr 21, 2004 542  ; herald = "Simplifier phase " ++ phase_info ++  simonpj committed Sep 26, 2001 543 544 545  ", iteration " ++ show iteration_no ++ " out of " ++ show max_iterations } ;  simonpj committed Jun 22, 1999 546 547 548  -- Stop if nothing happened; don't dump output if isZeroSimplCount counts' then  simonpj committed Apr 21, 2004 549  return ("Simplifier reached fixed point", iteration_no,  simonpj committed Apr 28, 2005 550  all_counts, binds')  simonpj committed Jun 22, 1999 551  else do {  simonpj committed Mar 09, 2005 552 553 554 555 556  -- Short out indirections -- We do this *after* at least one run of the simplifier -- because indirection-shorting uses the export flag on *occurrences* -- and that isn't guaranteed to be ok until after the first run propagates -- stuff from the binding site to its occurrences  simonpj@microsoft.com committed May 17, 2006 557 558 559  -- -- ToDo: alas, this means that indirection-shorting does not happen at all -- if the simplifier does nothing (not common, I know, but unsavoury)  Ian Lynagh committed Aug 16, 2007 560  let { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ;  simonpj committed Jun 22, 1999 561 562  -- Dump the result of this iteration  simonpj committed Sep 26, 2001 563  dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald  simonpj committed Feb 07, 2003 564  (pprSimplCount counts') ;  rl@cse.unsw.edu.au committed Dec 13, 2007 565  endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ;  simonpj committed Jun 22, 1999 566   simonpj committed Feb 07, 2003 567  -- Loop  simonpj committed Apr 28, 2005 568  do_iteration us2 (iteration_no + 1) all_counts binds''  simonmar committed Apr 19, 2000 569  } } } }  simonpj committed Jun 22, 1999 570 571 572  where (us1, us2) = splitUniqSupply us \end{code}  simonpj committed Mar 07, 2005 573 574 575 576  %************************************************************************ %* *  simonpj committed Mar 09, 2005 577  Shorting out indirections  simonpj committed Mar 07, 2005 578 579 580 %* * %************************************************************************  simonpj committed Mar 09, 2005 581 If we have this:  simonpj committed Mar 07, 2005 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691  x_local = ...bindings... x_exported = x_local where x_exported is exported, and x_local is not, then we replace it with this: x_exported = x_local = x_exported ...bindings... Without this we never get rid of the x_exported = x_local thing. This save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and makes strictness information propagate better. This used to happen in the final phase, but it's tidier to do it here. 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: iterate :: (a -> a) -> a -> [a] [Exported] iterate = iterateList iterateFB c f x = x c iterateFB c f (f x) iterateList f x = x : iterateList f (f x) [Not exported] {-# RULES "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) "iterateFB" iterateFB (:) = iterateList #-} This got shorted out to: iterateList :: (a -> a) -> a -> [a] iterateList = iterate iterateFB c f x = x c iterateFB c f (f x) iterate f x = x : iterate f (f x) {-# RULES "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) "iterateFB" iterateFB (:) = iterate #-} And now we get an infinite loop in the rule system iterate f x -> build (\cn -> iterateFB c f x) -> 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): use rule switching-off pragmas to get rid of iterateList in the first place Other remarks ~~~~~~~~~~~~~ If more than one exported thing is equal to a local thing (i.e., the local thing really is shared), then we do one only: \begin{verbatim} x_local = .... x_exported1 = x_local x_exported2 = x_local ==> x_exported1 = .... x_exported2 = x_exported1 \end{verbatim} We rely on prior eta reduction to simplify things like \begin{verbatim} x_exported = /\ tyvars -> x_local tyvars ==> x_exported = x_local \end{verbatim} Hence,there's a possibility of leaving unchanged something like this: \begin{verbatim} x_local = .... x_exported1 = x_local Int \end{verbatim} By the time we've thrown away the types in STG land this could be eliminated. But I don't think it's very common and it's dangerous to do this fiddling in STG land because we might elminate a binding that's mentioned in the unfolding for something. \begin{code} type IndEnv = IdEnv Id -- Maps local_id -> exported_id shortOutIndirections :: [CoreBind] -> [CoreBind] shortOutIndirections binds | isEmptyVarEnv ind_env = binds  simonpj@microsoft.com committed May 17, 2006 692 693  | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping] | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff  simonpj committed Mar 07, 2005 694 695  where ind_env = makeIndEnv binds  simonpj committed Mar 17, 2005 696 697  exp_ids = varSetElems ind_env -- These exported Ids are the subjects exp_id_set = mkVarSet exp_ids -- of the indirection-elimination  simonpj committed Apr 28, 2005 698  no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids  simonpj committed Mar 07, 2005 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740  binds' = concatMap zap binds zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] zap (Rec pairs) = [Rec (concatMap zapPair pairs)] zapPair (bndr, rhs) | bndr elemVarSet exp_id_set = [] | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs), (bndr, Var exp_id)] | otherwise = [(bndr,rhs)] makeIndEnv :: [CoreBind] -> IndEnv makeIndEnv binds = foldr add_bind emptyVarEnv binds where add_bind :: CoreBind -> IndEnv -> IndEnv add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env add_bind (Rec pairs) env = foldr add_pair env pairs add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv add_pair (exported_id, Var local_id) env | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id 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 = if isExportedId exported_id && -- Only if this is exported isLocalId local_id && -- Only if this one is defined in this -- module, so that we *can* change its -- binding to be the exported thing! not (isExportedId local_id) && -- Only if this one is not itself exported, -- since the transformation will nuke it not (local_id elemVarEnv ind_env) -- Only if not already substituted for then True {- No longer needed  simonpj committed Apr 28, 2005 741  if isEmptySpecInfo (specInfo (idInfo exported_id)) -- Only if no rules  simonpj committed Mar 07, 2005 742 743 744 745 746 747 748 749 750 751 752 753 754  then True -- See note on "Messing up rules" else #ifdef DEBUG pprTrace "shortMeOut:" (ppr exported_id) #endif False -} else False ----------------- transferIdInfo :: Id -> Id -> Id  simonpj@microsoft.com committed May 17, 2006 755 756 757 758 759 760 -- 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 -- gbl_id = e; lcl_id = gbl_id -- Instead, transfer IdInfo from lcl_id to exp_id -- Overwriting, rather than merging, seems to work ok.  simonpj committed Mar 07, 2005 761 762 763 764 765 766 transferIdInfo exported_id local_id = modifyIdInfo transfer exported_id where local_info = idInfo local_id transfer exp_info = exp_info setNewStrictnessInfo newStrictnessInfo local_info setWorkerInfo workerInfo local_info  simonpj@microsoft.com committed May 17, 2006 767  setInlinePragInfo inlinePragInfo local_info  simonpj@microsoft.com committed Dec 20, 2007 768 769 770 771 772  setSpecInfo addSpecInfo (specInfo exp_info) new_info new_info = setSpecInfoHead (idName exported_id) (specInfo local_info) -- Remember to set the function-name field of the -- rules as we transfer them from one function to another  simonpj committed Mar 07, 2005 773 \end{code}