2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[SimplCore]{Driver for simplifying @Core@ programs}
7 module SimplCore ( core2core, simplifyExpr ) where
9 #include "HsVersions.h"
11 import DynFlags ( DynFlags, DynFlag(..), dopt )
15 import CSE ( cseProgram )
16 import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
17 extendRuleBaseList, ruleCheckProgram, addSpecInfo, )
18 import PprCore ( pprCoreBindings, pprCoreExpr )
19 import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
21 import CoreUtils ( coreBindsSize )
22 import Simplify ( simplTopBinds, simplExpr )
23 import SimplUtils ( simplEnvForGHCi, activeRule )
27 import qualified ErrUtils as Err
28 import FloatIn ( floatInwards )
29 import FloatOut ( floatOutwards )
35 import LiberateCase ( liberateCase )
36 import SAT ( doStaticArgs )
37 import Specialise ( specProgram)
38 import SpecConstr ( specConstrProgram)
39 import DmdAnal ( dmdAnalPgm )
40 import WorkWrap ( wwTopBinds )
41 import Vectorise ( vectorise )
45 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
50 %************************************************************************
52 \subsection{The driver for the simplifier}
54 %************************************************************************
57 core2core :: HscEnv -> ModGuts -> IO ModGuts
58 core2core hsc_env guts
59 = do { us <- mkSplitUniqSupply 's'
60 ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $
61 doCorePasses (getCoreToDo dflags) guts
63 ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
64 "Grand total simplifier statistics"
69 dflags = hsc_dflags hsc_env
70 home_pkg_rules = hptRules hsc_env (dep_mods (mg_deps guts))
71 hpt_rule_base = mkRuleBase home_pkg_rules
73 -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
74 -- This is very convienent for the users of the monad (e.g. plugins do not have to
75 -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
76 -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
77 -- would mean our cached value would go out of date.
80 type CorePass = CoreToDo
82 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
83 doCorePasses passes guts
84 = foldM do_pass guts passes
86 do_pass guts CoreDoNothing = return guts
87 do_pass guts (CoreDoPasses ps) = doCorePasses ps guts
89 = do { dflags <- getDynFlags
90 ; liftIO $ showPass dflags pass
91 ; guts' <- doCorePass pass guts
92 ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts')
95 doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
96 doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-}
99 doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-}
102 doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-}
105 doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
108 doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}
109 doPassDUM (floatOutwards f)
111 doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
114 doCorePass CoreDoStrictness = {-# SCC "Stranal" #-}
117 doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
120 doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}
123 doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
126 doCorePass CoreDoVectorisation = {-# SCC "Vectorise" #-}
129 doCorePass CoreDoGlomBinds = doPassDM glomBinds
130 doCorePass CoreDoPrintCore = observe printCore
131 doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
132 doCorePass CoreDoNothing = return
133 doCorePass (CoreDoPasses passes) = doCorePasses passes
134 doCorePass pass = pprPanic "doCorePass" (ppr pass)
137 %************************************************************************
139 \subsection{Core pass combinators}
141 %************************************************************************
144 printCore :: a -> [CoreBind] -> IO ()
145 printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
147 ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
148 ruleCheck current_phase pat guts = do
150 dflags <- getDynFlags
151 liftIO $ Err.showPass dflags "RuleCheck"
152 liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts))
156 doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
157 doPassDUM do_pass = doPassM $ \binds -> do
158 dflags <- getDynFlags
159 us <- getUniqueSupplyM
160 liftIO $ do_pass dflags us binds
162 doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
163 doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
165 doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
166 doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
168 doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
169 doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
171 doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
172 doPassU do_pass = doPassDU (const do_pass)
174 -- Most passes return no stats and don't change rules: these combinators
175 -- let us lift them to the full blown ModGuts+CoreM world
176 doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
177 doPassM bind_f guts = do
178 binds' <- bind_f (mg_binds guts)
179 return (guts { mg_binds = binds' })
181 doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
182 doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
184 -- Observer passes just peek; don't modify the bindings at all
185 observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
186 observe do_pass = doPassM $ \binds -> do
187 dflags <- getDynFlags
188 _ <- liftIO $ do_pass dflags binds
193 %************************************************************************
195 Gentle simplification
197 %************************************************************************
200 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
203 -- simplifyExpr is called by the driver to simplify an
204 -- expression typed in at the interactive prompt
206 -- Also used by Template Haskell
207 simplifyExpr dflags expr
209 ; Err.showPass dflags "Simplify"
211 ; us <- mkSplitUniqSupply 's'
213 ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
214 simplExprGently (simplEnvForGHCi dflags) expr
216 ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
222 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
223 -- Simplifies an expression
224 -- does occurrence analysis, then simplification
225 -- and repeats (twice currently) because one pass
226 -- alone leaves tons of crud.
227 -- Used (a) for user expressions typed in at the interactive prompt
228 -- (b) the LHS and RHS of a RULE
229 -- (c) Template Haskell splices
231 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
232 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
233 -- enforce that; it just simplifies the expression twice
235 -- It's important that simplExprGently does eta reduction; see
236 -- Note [Simplifying the left-hand side of a RULE] above. The
237 -- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
238 -- but only if -O is on.
240 simplExprGently env expr = do
241 expr1 <- simplExpr env (occurAnalyseExpr expr)
242 simplExpr env (occurAnalyseExpr expr1)
246 %************************************************************************
248 \subsection{Glomming}
250 %************************************************************************
253 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
254 -- Glom all binds together in one Rec, in case any
255 -- transformations have introduced any new dependencies
257 -- NB: the global invariant is this:
258 -- *** the top level bindings are never cloned, and are always unique ***
260 -- We sort them into dependency order, but applying transformation rules may
261 -- make something at the top refer to something at the bottom:
265 -- RULE: p (q x) = h x
267 -- Applying this rule makes f refer to h,
268 -- although it doesn't appear to in the source program.
269 -- This pass lets us control where it happens.
271 -- NOTICE that this cannot happen for rules whose head is a locally-defined
272 -- function. It only happens for rules whose head is an imported function
273 -- (p in the example above). So, for example, the rule had been
274 -- RULE: f (p x) = h x
275 -- then the rule for f would be attached to f itself (in its IdInfo)
276 -- by prepareLocalRuleBase and h would be regarded by the occurrency
277 -- analyser as free in f.
279 glomBinds dflags binds
280 = do { Err.showPass dflags "GlomBinds" ;
281 let { recd_binds = [Rec (flattenBinds binds)] } ;
283 -- Not much point in printing the result...
284 -- just consumes output bandwidth
288 %************************************************************************
290 \subsection{The driver for the simplifier}
292 %************************************************************************
295 simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
296 simplifyPgm pass guts
297 = do { hsc_env <- getHscEnv
298 ; us <- getUniqueSupplyM
301 simplifyPgmIO pass hsc_env us rb guts }
303 simplifyPgmIO :: CoreToDo
308 -> IO (SimplCount, ModGuts) -- New bindings
310 simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
311 hsc_env us hpt_rule_base
312 guts@(ModGuts { mg_binds = binds, mg_rules = rules
313 , mg_fam_inst_env = fam_inst_env })
314 = do { (termination_msg, it_count, counts_out, guts')
315 <- do_iteration us 1 [] binds rules
317 ; Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
318 "Simplifier statistics for following pass"
319 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
321 pprSimplCount counts_out])
323 ; return (counts_out, guts')
326 dflags = hsc_dflags hsc_env
327 dump_phase = dumpSimplPhase dflags mode
328 simpl_env = mkSimplEnv mode
329 active_rule = activeRule dflags simpl_env
331 do_iteration :: UniqSupply
332 -> Int -- Counts iterations
333 -> [SimplCount] -- Counts from earlier iterations, reversed
334 -> [CoreBind] -- Bindings in
335 -> [CoreRule] -- and orphan rules
336 -> IO (String, Int, SimplCount, ModGuts)
338 do_iteration us iteration_no counts_so_far binds rules
339 -- iteration_no is the number of the iteration we are
340 -- about to begin, with '1' for the first
341 | iteration_no > max_iterations -- Stop if we've run out of iterations
342 = WARN( debugIsOn && (max_iterations > 2)
343 , ptext (sLit "Simplifier baling out after") <+> int max_iterations
344 <+> ptext (sLit "iterations")
345 <+> (brackets $ hsep $ punctuate comma $
346 map (int . simplCountN) (reverse counts_so_far))
347 <+> ptext (sLit "Size =") <+> int (coreBindsSize binds) )
349 -- Subtract 1 from iteration_no to get the
350 -- number of iterations we actually completed
351 return ( "Simplifier baled out", iteration_no - 1
352 , totalise counts_so_far
353 , guts { mg_binds = binds, mg_rules = rules } )
355 -- Try and force thunks off the binds; significantly reduces
356 -- space usage, especially with -O. JRS, 000620.
357 | let sz = coreBindsSize binds in sz == sz
359 -- Occurrence analysis
360 let { -- During the 'InitialPhase' (i.e., before vectorisation), we need to make sure
361 -- that the right-hand sides of vectorisation declarations are taken into
362 -- account during occurence analysis.
363 maybeVects = case sm_phase mode of
364 InitialPhase -> mg_vect_decls guts
366 ; tagged_binds = {-# SCC "OccAnal" #-}
367 occurAnalysePgm active_rule rules maybeVects binds
369 Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
370 (pprCoreBindings tagged_binds);
372 -- Get any new rules, and extend the rule base
373 -- See Note [Overall plumbing for rules] in Rules.lhs
374 -- We need to do this regularly, because simplification can
375 -- poke on IdInfo thunks, which in turn brings in new rules
376 -- behind the scenes. Otherwise there's a danger we'll simply
377 -- miss the rules for Ids hidden inside imported inlinings
378 eps <- hscEPS hsc_env ;
379 let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
380 ; rule_base2 = extendRuleBaseList rule_base1 rules
381 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
382 simplTopBinds simpl_env tagged_binds
383 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
385 -- Simplify the program
386 -- We do this with a *case* not a *let* because lazy pattern
387 -- matching bit us with bad space leak!
388 -- With a let, we ended up with
393 -- case t of {(_,counts1) -> if counts1=0 then ... }
394 -- So the conditional didn't force counts1, because the
395 -- selection got duplicated. Sigh!
396 case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
397 (env1, counts1) -> do {
399 let { binds1 = getFloats env1
400 ; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules
403 -- Stop if nothing happened; don't dump output
404 if isZeroSimplCount counts1 then
405 return ( "Simplifier reached fixed point", iteration_no
406 , totalise (counts1 : counts_so_far) -- Include "free" ticks
407 , guts { mg_binds = binds1, mg_rules = rules1 } )
409 -- Short out indirections
410 -- We do this *after* at least one run of the simplifier
411 -- because indirection-shorting uses the export flag on *occurrences*
412 -- and that isn't guaranteed to be ok until after the first run propagates
413 -- stuff from the binding site to its occurrences
415 -- ToDo: alas, this means that indirection-shorting does not happen at all
416 -- if the simplifier does nothing (not common, I know, but unsavoury)
417 let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
419 -- Dump the result of this iteration
420 end_iteration dflags pass iteration_no counts1 binds2 rules1 ;
423 do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
425 | otherwise = panic "do_iteration"
427 (us1, us2) = splitUniqSupply us
429 -- Remember the counts_so_far are reversed
430 totalise :: [SimplCount] -> SimplCount
431 totalise = foldr (\c acc -> acc `plusSimplCount` c)
432 (zeroSimplCount dflags)
434 simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"
437 end_iteration :: DynFlags -> CoreToDo -> Int
438 -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
439 -- Same as endIteration but with simplifier counts
440 end_iteration dflags pass iteration_no counts binds rules
441 = do { dumpIfSet (dopt Opt_D_dump_simpl_iterations dflags)
442 pass (ptext (sLit "Simplifier counts"))
443 (pprSimplCount counts)
445 ; endIteration dflags pass iteration_no binds rules }
449 %************************************************************************
451 Shorting out indirections
453 %************************************************************************
457 x_local = <expression>
461 where x_exported is exported, and x_local is not, then we replace it with this:
463 x_exported = <expression>
467 Without this we never get rid of the x_exported = x_local thing. This
468 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
469 makes strictness information propagate better. This used to happen in
470 the final phase, but it's tidier to do it here.
472 Note [Transferring IdInfo]
473 ~~~~~~~~~~~~~~~~~~~~~~~~~~
474 We want to propagage any useful IdInfo on x_local to x_exported.
476 STRICTNESS: if we have done strictness analysis, we want the strictness info on
477 x_local to transfer to x_exported. Hence the copyIdInfo call.
479 RULES: we want to *add* any RULES for x_local to x_exported.
482 Note [Messing up the exported Id's RULES]
483 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
484 We must be careful about discarding (obviously) or even merging the
485 RULES on the exported Id. The example that went bad on me at one stage
488 iterate :: (a -> a) -> a -> [a]
490 iterate = iterateList
492 iterateFB c f x = x `c` iterateFB c f (f x)
493 iterateList f x = x : iterateList f (f x)
497 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
498 "iterateFB" iterateFB (:) = iterateList
501 This got shorted out to:
503 iterateList :: (a -> a) -> a -> [a]
504 iterateList = iterate
506 iterateFB c f x = x `c` iterateFB c f (f x)
507 iterate f x = x : iterate f (f x)
510 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
511 "iterateFB" iterateFB (:) = iterate
514 And now we get an infinite loop in the rule system
515 iterate f x -> build (\cn -> iterateFB c f x)
520 use rule switching-off pragmas to get rid
521 of iterateList in the first place
523 But in principle the user *might* want rules that only apply to the Id
524 he says. And inline pragmas are similar
528 Then we do not want to get rid of the NOINLINE.
530 Hence hasShortableIdinfo.
533 Note [Rules and indirection-zapping]
534 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
535 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
536 Then the things mentioned can be out of scope! Solution
537 a) Make sure that in this pass the usage-info from x_exported is
538 available for ...bindings...
539 b) If there are any such RULES, rec-ify the entire top-level.
540 It'll get sorted out next time round
544 If more than one exported thing is equal to a local thing (i.e., the
545 local thing really is shared), then we do one only:
548 x_exported1 = x_local
549 x_exported2 = x_local
553 x_exported2 = x_exported1
556 We rely on prior eta reduction to simplify things like
558 x_exported = /\ tyvars -> x_local tyvars
562 Hence,there's a possibility of leaving unchanged something like this:
565 x_exported1 = x_local Int
567 By the time we've thrown away the types in STG land this
568 could be eliminated. But I don't think it's very common
569 and it's dangerous to do this fiddling in STG land
570 because we might elminate a binding that's mentioned in the
571 unfolding for something.
574 type IndEnv = IdEnv Id -- Maps local_id -> exported_id
576 shortOutIndirections :: [CoreBind] -> [CoreBind]
577 shortOutIndirections binds
578 | isEmptyVarEnv ind_env = binds
579 | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]
580 | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
582 ind_env = makeIndEnv binds
583 exp_ids = varSetElems ind_env -- These exported Ids are the subjects
584 exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
585 no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
586 binds' = concatMap zap binds
588 zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
589 zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
592 | bndr `elemVarSet` exp_id_set = []
593 | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
595 | otherwise = [(bndr,rhs)]
597 makeIndEnv :: [CoreBind] -> IndEnv
599 = foldr add_bind emptyVarEnv binds
601 add_bind :: CoreBind -> IndEnv -> IndEnv
602 add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
603 add_bind (Rec pairs) env = foldr add_pair env pairs
605 add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
606 add_pair (exported_id, Var local_id) env
607 | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
611 shortMeOut :: IndEnv -> Id -> Id -> Bool
612 shortMeOut ind_env exported_id local_id
613 -- The if-then-else stuff is just so I can get a pprTrace to see
614 -- how often I don't get shorting out becuase of IdInfo stuff
615 = if isExportedId exported_id && -- Only if this is exported
617 isLocalId local_id && -- Only if this one is defined in this
618 -- module, so that we *can* change its
619 -- binding to be the exported thing!
621 not (isExportedId local_id) && -- Only if this one is not itself exported,
622 -- since the transformation will nuke it
624 not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
626 if hasShortableIdInfo exported_id
627 then True -- See Note [Messing up the exported Id's IdInfo]
628 else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
634 hasShortableIdInfo :: Id -> Bool
635 -- True if there is no user-attached IdInfo on exported_id,
636 -- so we can safely discard it
637 -- See Note [Messing up the exported Id's IdInfo]
638 hasShortableIdInfo id
639 = isEmptySpecInfo (specInfo info)
640 && isDefaultInlinePragma (inlinePragInfo info)
645 transferIdInfo :: Id -> Id -> Id
646 -- See Note [Transferring IdInfo]
648 -- lcl_id = e; exp_id = lcl_id
649 -- and lcl_id has useful IdInfo, we don't want to discard it by going
650 -- gbl_id = e; lcl_id = gbl_id
651 -- Instead, transfer IdInfo from lcl_id to exp_id
652 -- Overwriting, rather than merging, seems to work ok.
653 transferIdInfo exported_id local_id
654 = modifyIdInfo transfer exported_id
656 local_info = idInfo local_id
657 transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info
658 `setUnfoldingInfo` unfoldingInfo local_info
659 `setInlinePragInfo` inlinePragInfo local_info
660 `setSpecInfo` addSpecInfo (specInfo exp_info) new_info
661 new_info = setSpecInfoHead (idName exported_id)
662 (specInfo local_info)
663 -- Remember to set the function-name field of the
664 -- rules as we transfer them from one function to another