2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[SimplCore]{Driver for simplifying @Core@ programs}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 module SimplCore ( core2core, simplifyExpr ) where
16 #include "HsVersions.h"
18 import DynFlags ( DynFlags, DynFlag(..), dopt )
22 import CSE ( cseProgram )
23 import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
24 extendRuleBaseList, pprRuleBase, pprRulesForUser,
25 ruleCheckProgram, rulesOfBinds,
26 addSpecInfo, addIdSpecialisations )
27 import PprCore ( pprCoreBindings, pprCoreExpr, pprRules )
28 import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
30 import CoreUtils ( coreBindsSize )
31 import Simplify ( simplTopBinds, simplExpr )
32 import SimplUtils ( simplEnvForGHCi, simplEnvForRules )
36 import qualified ErrUtils as Err
38 import FloatIn ( floatInwards )
39 import FloatOut ( floatOutwards )
43 import TyCon ( tyConDataCons )
44 import BasicTypes ( CompilerPhase, isActive, isDefaultInlinePragma )
47 import NameEnv ( lookupNameEnv )
48 import LiberateCase ( liberateCase )
49 import SAT ( doStaticArgs )
50 import Specialise ( specProgram)
51 import SpecConstr ( specConstrProgram)
52 import DmdAnal ( dmdAnalPgm )
53 import WorkWrap ( wwTopBinds )
54 import Vectorise ( vectorise )
58 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
66 %************************************************************************
68 \subsection{The driver for the simplifier}
70 %************************************************************************
73 core2core :: HscEnv -> ModGuts -> IO ModGuts
74 core2core hsc_env guts
75 = do { us <- mkSplitUniqSupply 's'
76 ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $
77 doCorePasses (getCoreToDo dflags) guts
79 ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
80 "Grand total simplifier statistics"
85 dflags = hsc_dflags hsc_env
86 home_pkg_rules = hptRules hsc_env (dep_mods (mg_deps guts))
87 hpt_rule_base = mkRuleBase home_pkg_rules
89 -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
90 -- This is very convienent for the users of the monad (e.g. plugins do not have to
91 -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
92 -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
93 -- would mean our cached value would go out of date.
96 type CorePass = CoreToDo
98 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
99 doCorePasses passes guts
100 = foldM do_pass guts passes
102 do_pass guts CoreDoNothing = return guts
103 do_pass guts (CoreDoPasses ps) = doCorePasses ps guts
105 = do { dflags <- getDynFlags
106 ; liftIO $ showPass dflags pass
107 ; guts' <- doCorePass pass guts
108 ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts')
111 doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
112 doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-}
115 doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-}
118 doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-}
121 doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
124 doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}
125 doPassDUM (floatOutwards f)
127 doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
130 doCorePass CoreDoStrictness = {-# SCC "Stranal" #-}
133 doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
136 doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}
139 doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
142 doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-}
145 doCorePass CoreDoGlomBinds = doPassDM glomBinds
146 doCorePass CoreDoPrintCore = observe printCore
147 doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
148 doCorePass CoreDoNothing = return
149 doCorePass (CoreDoPasses passes) = doCorePasses passes
152 %************************************************************************
154 \subsection{Core pass combinators}
156 %************************************************************************
159 printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
161 ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
162 ruleCheck current_phase pat guts = do
164 dflags <- getDynFlags
165 liftIO $ Err.showPass dflags "RuleCheck"
166 liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts))
170 doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts
171 doPassDMS do_pass = doPassM $ \binds -> do
172 dflags <- getDynFlags
173 liftIOWithCount $ do_pass dflags binds
175 doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
176 doPassDUM do_pass = doPassM $ \binds -> do
177 dflags <- getDynFlags
178 us <- getUniqueSupplyM
179 liftIO $ do_pass dflags us binds
181 doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
182 doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
184 doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
185 doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
187 doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
188 doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
190 doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
191 doPassU do_pass = doPassDU (const do_pass)
193 -- Most passes return no stats and don't change rules: these combinators
194 -- let us lift them to the full blown ModGuts+CoreM world
195 doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
196 doPassM bind_f guts = do
197 binds' <- bind_f (mg_binds guts)
198 return (guts { mg_binds = binds' })
200 doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts
201 doPassMG bind_f guts = do
202 binds' <- bind_f guts
203 return (guts { mg_binds = binds' })
205 doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
206 doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
208 -- Observer passes just peek; don't modify the bindings at all
209 observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
210 observe do_pass = doPassM $ \binds -> do
211 dflags <- getDynFlags
212 liftIO $ do_pass dflags binds
217 %************************************************************************
219 Gentle simplification
221 %************************************************************************
224 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
227 -- simplifyExpr is called by the driver to simplify an
228 -- expression typed in at the interactive prompt
230 -- Also used by Template Haskell
231 simplifyExpr dflags expr
233 ; Err.showPass dflags "Simplify"
235 ; us <- mkSplitUniqSupply 's'
237 ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
238 simplExprGently simplEnvForGHCi expr
240 ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
246 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
247 -- Simplifies an expression
248 -- does occurrence analysis, then simplification
249 -- and repeats (twice currently) because one pass
250 -- alone leaves tons of crud.
251 -- Used (a) for user expressions typed in at the interactive prompt
252 -- (b) the LHS and RHS of a RULE
253 -- (c) Template Haskell splices
255 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
256 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
257 -- enforce that; it just simplifies the expression twice
259 -- It's important that simplExprGently does eta reduction; see
260 -- Note [Simplifying the left-hand side of a RULE] above. The
261 -- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
262 -- but only if -O is on.
264 simplExprGently env expr = do
265 expr1 <- simplExpr env (occurAnalyseExpr expr)
266 simplExpr env (occurAnalyseExpr expr1)
270 %************************************************************************
272 \subsection{Glomming}
274 %************************************************************************
277 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
278 -- Glom all binds together in one Rec, in case any
279 -- transformations have introduced any new dependencies
281 -- NB: the global invariant is this:
282 -- *** the top level bindings are never cloned, and are always unique ***
284 -- We sort them into dependency order, but applying transformation rules may
285 -- make something at the top refer to something at the bottom:
289 -- RULE: p (q x) = h x
291 -- Applying this rule makes f refer to h,
292 -- although it doesn't appear to in the source program.
293 -- This pass lets us control where it happens.
295 -- NOTICE that this cannot happen for rules whose head is a locally-defined
296 -- function. It only happens for rules whose head is an imported function
297 -- (p in the example above). So, for example, the rule had been
298 -- RULE: f (p x) = h x
299 -- then the rule for f would be attached to f itself (in its IdInfo)
300 -- by prepareLocalRuleBase and h would be regarded by the occurrency
301 -- analyser as free in f.
303 glomBinds dflags binds
304 = do { Err.showPass dflags "GlomBinds" ;
305 let { recd_binds = [Rec (flattenBinds binds)] } ;
307 -- Not much point in printing the result...
308 -- just consumes output bandwidth
312 %************************************************************************
314 \subsection{The driver for the simplifier}
316 %************************************************************************
319 simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
320 simplifyPgm pass guts
321 = do { hsc_env <- getHscEnv
322 ; us <- getUniqueSupplyM
325 simplifyPgmIO pass hsc_env us rb guts }
327 simplifyPgmIO :: CoreToDo
332 -> IO (SimplCount, ModGuts) -- New bindings
334 simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
335 hsc_env us hpt_rule_base
336 guts@(ModGuts { mg_binds = binds, mg_rules = rules
337 , mg_fam_inst_env = fam_inst_env })
338 = do { (termination_msg, it_count, counts_out, guts')
339 <- do_iteration us 1 [] binds rules
341 ; Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
342 "Simplifier statistics for following pass"
343 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
345 pprSimplCount counts_out])
347 ; return (counts_out, guts')
350 dflags = hsc_dflags hsc_env
351 dump_phase = dumpSimplPhase dflags mode
352 sw_chkr = isAmongSimpl switches
353 do_iteration :: UniqSupply
354 -> Int -- Counts iterations
355 -> [SimplCount] -- Counts from earlier iterations, reversed
356 -> [CoreBind] -- Bindings in
357 -> [CoreRule] -- and orphan rules
358 -> IO (String, Int, SimplCount, ModGuts)
360 do_iteration us iteration_no counts_so_far binds rules
361 -- iteration_no is the number of the iteration we are
362 -- about to begin, with '1' for the first
363 | iteration_no > max_iterations -- Stop if we've run out of iterations
364 = WARN( debugIsOn && (max_iterations > 2)
365 , ptext (sLit "Simplifier baling out after") <+> int max_iterations
366 <+> ptext (sLit "iterations")
367 <+> (brackets $ hsep $ punctuate comma $
368 map (int . simplCountN) (reverse counts_so_far))
369 <+> ptext (sLit "Size =") <+> int (coreBindsSize binds) )
371 -- Subtract 1 from iteration_no to get the
372 -- number of iterations we actually completed
373 return ( "Simplifier baled out", iteration_no - 1
374 , totalise counts_so_far
375 , guts { mg_binds = binds, mg_rules = rules } )
377 -- Try and force thunks off the binds; significantly reduces
378 -- space usage, especially with -O. JRS, 000620.
379 | let sz = coreBindsSize binds in sz == sz
381 -- Occurrence analysis
382 let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;
383 Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
384 (pprCoreBindings tagged_binds);
386 -- Get any new rules, and extend the rule base
387 -- See Note [Overall plumbing for rules] in Rules.lhs
388 -- We need to do this regularly, because simplification can
389 -- poke on IdInfo thunks, which in turn brings in new rules
390 -- behind the scenes. Otherwise there's a danger we'll simply
391 -- miss the rules for Ids hidden inside imported inlinings
392 eps <- hscEPS hsc_env ;
393 let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
394 ; rule_base2 = extendRuleBaseList rule_base1 rules
395 ; simpl_env = mkSimplEnv sw_chkr mode
396 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
397 simplTopBinds simpl_env tagged_binds
398 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
400 -- Simplify the program
401 -- We do this with a *case* not a *let* because lazy pattern
402 -- matching bit us with bad space leak!
403 -- With a let, we ended up with
408 -- case t of {(_,counts1) -> if counts1=0 then ... }
409 -- So the conditional didn't force counts1, because the
410 -- selection got duplicated. Sigh!
411 case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
412 (env1, counts1) -> do {
414 let { binds1 = getFloats env1
415 ; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules
418 -- Stop if nothing happened; don't dump output
419 if isZeroSimplCount counts1 then
420 return ( "Simplifier reached fixed point", iteration_no
421 , totalise (counts1 : counts_so_far) -- Include "free" ticks
422 , guts { mg_binds = binds1, mg_rules = rules1 } )
424 -- Short out indirections
425 -- We do this *after* at least one run of the simplifier
426 -- because indirection-shorting uses the export flag on *occurrences*
427 -- and that isn't guaranteed to be ok until after the first run propagates
428 -- stuff from the binding site to its occurrences
430 -- ToDo: alas, this means that indirection-shorting does not happen at all
431 -- if the simplifier does nothing (not common, I know, but unsavoury)
432 let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
434 -- Dump the result of this iteration
435 end_iteration dflags pass iteration_no counts1 binds2 rules1 ;
438 do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
441 (us1, us2) = splitUniqSupply us
443 -- Remember the counts_so_far are reversed
444 totalise :: [SimplCount] -> SimplCount
445 totalise = foldr (\c acc -> acc `plusSimplCount` c)
446 (zeroSimplCount dflags)
449 end_iteration :: DynFlags -> CoreToDo -> Int
450 -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
451 -- Same as endIteration but with simplifier counts
452 end_iteration dflags pass iteration_no counts binds rules
453 = do { dumpIfSet (dopt Opt_D_dump_simpl_iterations dflags)
454 pass (ptext (sLit "Simplifier counts"))
455 (pprSimplCount counts)
457 ; endIteration dflags pass iteration_no binds rules }
461 %************************************************************************
463 Shorting out indirections
465 %************************************************************************
469 x_local = <expression>
473 where x_exported is exported, and x_local is not, then we replace it with this:
475 x_exported = <expression>
479 Without this we never get rid of the x_exported = x_local thing. This
480 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
481 makes strictness information propagate better. This used to happen in
482 the final phase, but it's tidier to do it here.
484 Note [Transferring IdInfo]
485 ~~~~~~~~~~~~~~~~~~~~~~~~~~
486 We want to propagage any useful IdInfo on x_local to x_exported.
488 STRICTNESS: if we have done strictness analysis, we want the strictness info on
489 x_local to transfer to x_exported. Hence the copyIdInfo call.
491 RULES: we want to *add* any RULES for x_local to x_exported.
494 Note [Messing up the exported Id's RULES]
495 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
496 We must be careful about discarding (obviously) or even merging the
497 RULES on the exported Id. The example that went bad on me at one stage
500 iterate :: (a -> a) -> a -> [a]
502 iterate = iterateList
504 iterateFB c f x = x `c` iterateFB c f (f x)
505 iterateList f x = x : iterateList f (f x)
509 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
510 "iterateFB" iterateFB (:) = iterateList
513 This got shorted out to:
515 iterateList :: (a -> a) -> a -> [a]
516 iterateList = iterate
518 iterateFB c f x = x `c` iterateFB c f (f x)
519 iterate f x = x : iterate f (f x)
522 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
523 "iterateFB" iterateFB (:) = iterate
526 And now we get an infinite loop in the rule system
527 iterate f x -> build (\cn -> iterateFB c f x)
532 use rule switching-off pragmas to get rid
533 of iterateList in the first place
535 But in principle the user *might* want rules that only apply to the Id
536 he says. And inline pragmas are similar
540 Then we do not want to get rid of the NOINLINE.
542 Hence hasShortableIdinfo.
545 Note [Rules and indirection-zapping]
546 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
547 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
548 Then the things mentioned can be out of scope! Solution
549 a) Make sure that in this pass the usage-info from x_exported is
550 available for ...bindings...
551 b) If there are any such RULES, rec-ify the entire top-level.
552 It'll get sorted out next time round
556 If more than one exported thing is equal to a local thing (i.e., the
557 local thing really is shared), then we do one only:
560 x_exported1 = x_local
561 x_exported2 = x_local
565 x_exported2 = x_exported1
568 We rely on prior eta reduction to simplify things like
570 x_exported = /\ tyvars -> x_local tyvars
574 Hence,there's a possibility of leaving unchanged something like this:
577 x_exported1 = x_local Int
579 By the time we've thrown away the types in STG land this
580 could be eliminated. But I don't think it's very common
581 and it's dangerous to do this fiddling in STG land
582 because we might elminate a binding that's mentioned in the
583 unfolding for something.
586 type IndEnv = IdEnv Id -- Maps local_id -> exported_id
588 shortOutIndirections :: [CoreBind] -> [CoreBind]
589 shortOutIndirections binds
590 | isEmptyVarEnv ind_env = binds
591 | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]
592 | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
594 ind_env = makeIndEnv binds
595 exp_ids = varSetElems ind_env -- These exported Ids are the subjects
596 exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
597 no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
598 binds' = concatMap zap binds
600 zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
601 zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
604 | bndr `elemVarSet` exp_id_set = []
605 | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
607 | otherwise = [(bndr,rhs)]
609 makeIndEnv :: [CoreBind] -> IndEnv
611 = foldr add_bind emptyVarEnv binds
613 add_bind :: CoreBind -> IndEnv -> IndEnv
614 add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
615 add_bind (Rec pairs) env = foldr add_pair env pairs
617 add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
618 add_pair (exported_id, Var local_id) env
619 | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
620 add_pair (exported_id, rhs) env
624 shortMeOut ind_env exported_id local_id
625 -- The if-then-else stuff is just so I can get a pprTrace to see
626 -- how often I don't get shorting out becuase of IdInfo stuff
627 = if isExportedId exported_id && -- Only if this is exported
629 isLocalId local_id && -- Only if this one is defined in this
630 -- module, so that we *can* change its
631 -- binding to be the exported thing!
633 not (isExportedId local_id) && -- Only if this one is not itself exported,
634 -- since the transformation will nuke it
636 not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
638 if hasShortableIdInfo exported_id
639 then True -- See Note [Messing up the exported Id's IdInfo]
640 else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
646 hasShortableIdInfo :: Id -> Bool
647 -- True if there is no user-attached IdInfo on exported_id,
648 -- so we can safely discard it
649 -- See Note [Messing up the exported Id's IdInfo]
650 hasShortableIdInfo id
651 = isEmptySpecInfo (specInfo info)
652 && isDefaultInlinePragma (inlinePragInfo info)
657 transferIdInfo :: Id -> Id -> Id
658 -- See Note [Transferring IdInfo]
660 -- lcl_id = e; exp_id = lcl_id
661 -- and lcl_id has useful IdInfo, we don't want to discard it by going
662 -- gbl_id = e; lcl_id = gbl_id
663 -- Instead, transfer IdInfo from lcl_id to exp_id
664 -- Overwriting, rather than merging, seems to work ok.
665 transferIdInfo exported_id local_id
666 = modifyIdInfo transfer exported_id
668 local_info = idInfo local_id
669 transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info
670 `setUnfoldingInfo` unfoldingInfo local_info
671 `setInlinePragInfo` inlinePragInfo local_info
672 `setSpecInfo` addSpecInfo (specInfo exp_info) new_info
673 new_info = setSpecInfoHead (idName exported_id)
674 (specInfo local_info)
675 -- Remember to set the function-name field of the
676 -- rules as we transfer them from one function to another