2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[SimplCore]{Driver for simplifying @Core@ programs}
7 #include "HsVersions.h"
9 module SimplCore ( core2core ) where
13 import AnalFBWW ( analFBWW )
14 import Bag ( isEmptyBag, foldBag )
15 import BinderInfo ( BinderInfo{-instance Outputable-} )
16 import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD,
17 uNFOLDING_USE_THRESHOLD,
18 uNFOLDING_OVERRIDE_THRESHOLD,
19 uNFOLDING_CON_DISCOUNT_WEIGHT
21 import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), switchIsOn,
23 opt_D_simplifier_stats,
24 opt_D_verbose_core2core,
27 opt_ReportWhyUnfoldingsDisallowed,
29 opt_UnfoldingCreationThreshold,
30 opt_UnfoldingOverrideThreshold,
31 opt_UnfoldingUseThreshold
33 import CoreLint ( lintCoreBindings )
36 import CoreUtils ( substCoreBindings, manifestlyWHNF )
37 import ErrUtils ( ghcExit )
38 import FloatIn ( floatInwards )
39 import FloatOut ( floatOutwards )
40 import FoldrBuildWW ( mkFoldrBuildWW )
41 import Id ( idType, toplevelishId, idWantsToBeINLINEd,
42 unfoldingUnfriendlyId,
43 nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
44 lookupIdEnv, IdEnv(..),
45 GenId{-instance Outputable-}
47 import IdInfo ( mkUnfolding )
48 import LiberateCase ( liberateCase )
49 import MagicUFs ( MagicUnfoldingFun )
50 import Maybes ( maybeToBool )
51 import Outputable ( Outputable(..){-instance * (,) -} )
52 import PprCore ( pprCoreBinding, GenCoreExpr{-instance Outputable-} )
53 import PprStyle ( PprStyle(..) )
54 import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
55 import Pretty ( ppShow, ppAboves, ppAbove, ppCat, ppStr )
56 import SAT ( doStaticArgs )
57 import SCCauto ( addAutoCostCentres )
58 import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount )
59 import SimplPgm ( simplifyPgm )
60 import SimplVar ( leastItCouldCost )
62 import SpecUtils ( pprSpecErrs )
63 import StrictAnal ( saWwTopBinds )
64 import TyVar ( nullTyVarEnv, GenTyVar{-instance Eq-} )
65 import Unique ( Unique{-instance Eq-} )
66 import UniqSupply ( splitUniqSupply )
67 import Util ( panic{-ToDo:rm-} )
70 import Deforest ( deforestProgram )
71 import DefUtils ( deforestable )
74 isWrapperFor = panic "SimplCore.isWrapperFor (ToDo)"
75 isWrapperId = panic "SimplCore.isWrapperId (ToDo)"
79 core2core :: [CoreToDo] -- spec of what core-to-core passes to do
80 -> FAST_STRING -- module name (profiling only)
81 -> PprStyle -- printing style (for debugging only)
82 -> UniqSupply -- a name supply
83 -> [TyCon] -- local data tycons and tycon specialisations
84 -> FiniteMap TyCon [(Bool, [Maybe Type])]
85 -> [CoreBinding] -- input...
87 ([CoreBinding], -- results: program, plus...
88 IdEnv UnfoldingDetails, -- unfoldings to be exported from here
89 SpecialiseData) -- specialisation data
91 core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
92 = if null core_todos then -- very rare, I suspect...
93 -- well, we still must do some renumbering
95 (substCoreBindings nullIdEnv nullTyVarEnv binds us,
100 (if do_verbose_core2core then
101 hPutStr stderr "VERBOSE CORE-TO-CORE:\n"
104 -- better do the main business
105 foldl_mn do_core_pass
106 (binds, us, nullIdEnv, init_specdata, zeroSimplCount)
108 >>= \ (processed_binds, _, inline_env, spec_data, simpl_stats) ->
110 (if opt_D_simplifier_stats
111 then hPutStr stderr ("\nSimplifier Stats:\n")
113 hPutStr stderr (showSimplCount simpl_stats)
119 return (processed_binds, inline_env, spec_data)
121 init_specdata = initSpecData local_tycons tycon_specs
123 do_verbose_core2core = opt_D_verbose_core2core
125 lib_case_threshold -- ToDo: HACK HACK HACK : FIX ME FIX ME FIX ME
126 -- Use 4x a known threshold
127 = case opt_UnfoldingOverrideThreshold of
128 Nothing -> 4 * uNFOLDING_USE_THRESHOLD
132 core_linter = if opt_DoCoreLinting
133 then lintCoreBindings ppr_style
134 else ( \ whodunnit spec_done binds -> binds )
137 do_core_pass info@(binds, us, inline_env, spec_data, simpl_stats) to_do
139 (us1, us2) = splitUniqSupply us
142 CoreDoSimplify simpl_sw_chkr
143 -> _scc_ "CoreSimplify"
144 begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
145 then " (foldr/build)" else "") >>
146 case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
147 (p, it_cnt, simpl_stats2)
148 -> end_pass False us2 p inline_env spec_data simpl_stats2
149 ("Simplify (" ++ show it_cnt ++ ")"
150 ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
151 then " foldr/build" else "")
153 CoreDoFoldrBuildWorkerWrapper
154 -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
156 case (mkFoldrBuildWW us1 binds) of { binds2 ->
157 end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW" }
159 CoreDoFoldrBuildWWAnal
160 -> _scc_ "CoreDoFoldrBuildWWAnal"
161 begin_pass "AnalFBWW" >>
162 case (analFBWW binds) of { binds2 ->
163 end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW" }
166 -> _scc_ "LiberateCase"
167 begin_pass "LiberateCase" >>
168 case (liberateCase lib_case_threshold binds) of { binds2 ->
169 end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase" }
171 CoreDoCalcInlinings1 -- avoid inlinings w/ cost-centres
172 -> _scc_ "CoreInlinings1"
173 begin_pass "CalcInlinings" >>
174 case (calcInlinings False inline_env binds) of { inline_env2 ->
175 end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" }
177 CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres
178 -> _scc_ "CoreInlinings2"
179 begin_pass "CalcInlinings" >>
180 case (calcInlinings True inline_env binds) of { inline_env2 ->
181 end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" }
184 -> _scc_ "FloatInwards"
185 begin_pass "FloatIn" >>
186 case (floatInwards binds) of { binds2 ->
187 end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn" }
190 -> _scc_ "CoreFloating"
191 begin_pass "FloatOut" >>
192 case (floatOutwards us1 binds) of { binds2 ->
193 end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut" }
196 -> _scc_ "CoreStaticArgs"
197 begin_pass "StaticArgs" >>
198 case (doStaticArgs binds us1) of { binds2 ->
199 end_pass False us2 binds2 inline_env spec_data simpl_stats "StaticArgs" }
200 -- Binds really should be dependency-analysed for static-
201 -- arg transformation... Not to worry, they probably are.
202 -- (I don't think it *dies* if they aren't [WDP 94/04/15])
205 -> _scc_ "CoreStranal"
206 begin_pass "StrAnal" >>
207 case (saWwTopBinds us1 binds) of { binds2 ->
208 end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal" }
211 -> _scc_ "Specialise"
212 begin_pass "Specialise" >>
213 case (specProgram us1 binds spec_data) of {
214 (p, spec_data2@(SpecData _ spec_noerrs _ _ _
215 spec_errs spec_warn spec_tyerrs)) ->
217 -- if we got errors, we die straight away
218 (if not spec_noerrs ||
219 (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then
220 hPutStr stderr (ppShow 1000 {-pprCols-}
221 (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
222 >> hPutStr stderr "\n"
226 (if not spec_noerrs then -- Stop here if specialisation errors occured
231 end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise"
236 -> error "ERROR: CoreDoDeforest: not built into compiler\n"
238 -> _scc_ "Deforestation"
239 begin_pass "Deforestation" >>
240 case (deforestProgram binds us1) of { binds2 ->
241 end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation" }
244 CoreDoAutoCostCentres
246 begin_pass "AutoSCCs" >>
247 case (addAutoCostCentres module_name binds) of { binds2 ->
248 end_pass False us2 binds2 inline_env spec_data simpl_stats "AutoSCCs" }
250 CoreDoPrintCore -- print result of last pass
251 -> end_pass True us2 binds inline_env spec_data simpl_stats "Print"
254 -------------------------------------------------
257 = if opt_D_show_passes
258 then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n")
259 else \ what -> return ()
261 end_pass print us2 binds2 inline_env2
262 spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
264 = -- report verbosely, if required
265 (if (do_verbose_core2core && not print) ||
266 (print && not do_verbose_core2core)
268 hPutStr stderr ("\n*** "++what++":\n")
270 hPutStr stderr (ppShow 1000
271 (ppAboves (map (pprCoreBinding ppr_style) binds2)))
277 linted_binds = core_linter what spec_done binds2
280 (linted_binds, -- processed binds, possibly run thru CoreLint
281 us2, -- UniqueSupply for the next guy
282 inline_env2, -- possibly-updated inline env
283 spec_data2, -- possibly-updated specialisation info
284 simpl_stats2 -- accumulated simplifier stats
287 -- here so it can be inlined...
288 foldl_mn f z [] = return z
289 foldl_mn f z (x:xs) = f z x >>= \ zz ->
293 --- ToDo: maybe move elsewhere ---
295 For top-level, exported binders that either (a)~have been INLINEd by
296 the programmer or (b)~are sufficiently ``simple'' that they should be
297 inlined, we want to record this info in a suitable IdEnv.
299 But: if something has a ``wrapper unfolding,'' we do NOT automatically
300 give it a regular unfolding (exception below). We usually assume its
301 worker will get a ``regular'' unfolding. We can then treat these two
302 levels of unfolding separately (we tend to be very friendly towards
303 wrapper unfoldings, for example), giving more fine-tuned control.
305 The exception is: If the ``regular unfolding'' mentions no other
306 global Ids (i.e., it's all PrimOps and cases and local Ids) then we
307 assume it must be really good and we take it anyway.
309 We also need to check that everything in the RHS (values and types)
310 will be visible on the other side of an interface, too.
313 calcInlinings :: Bool -- True => inlinings with _scc_s are OK
314 -> IdEnv UnfoldingDetails
316 -> IdEnv UnfoldingDetails
318 calcInlinings scc_s_OK inline_env_so_far top_binds
320 result = foldl calci inline_env_so_far top_binds
322 --pprTrace "inline env:\n" (ppAboves (map pp_item (getIdEnvMapping result)))
325 pp_item (binder, details)
326 = ppCat [ppr PprDebug binder, ppStr "=>", pp_det details]
328 pp_det NoUnfoldingDetails = ppStr "_N_"
329 --LATER: pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
330 pp_det (GenForm _ expr guide)
331 = ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
332 pp_det other = ppStr "???"
335 my_trace = if opt_ReportWhyUnfoldingsDisallowed
337 else \ msg stuff -> stuff
339 (unfolding_creation_threshold, explicit_creation_threshold)
340 = case opt_UnfoldingCreationThreshold of
341 Nothing -> (uNFOLDING_CREATION_THRESHOLD, False)
342 Just xx -> (xx, True)
345 = case opt_UnfoldingUseThreshold of
346 Nothing -> uNFOLDING_USE_THRESHOLD
349 unfold_override_threshold
350 = case opt_UnfoldingOverrideThreshold of
351 Nothing -> uNFOLDING_OVERRIDE_THRESHOLD
354 con_discount_weight = uNFOLDING_CON_DISCOUNT_WEIGHT
356 calci inline_env (Rec pairs)
357 = foldl (calc True{-recursive-}) inline_env pairs
359 calci inline_env bind@(NonRec binder rhs)
360 = calc False{-not recursive-} inline_env (binder, rhs)
362 ---------------------------------------
364 calc is_recursive inline_env (binder, rhs)
365 | not (toplevelishId binder)
366 = --pprTrace "giving up on not top-level:" (ppr PprDebug binder)
369 | rhs_mentions_an_unmentionable
370 || (not explicit_INLINE_requested
371 && (rhs_looks_like_a_caf || guidance_says_don't || guidance_size_too_big))
374 = if explicit_INLINE_requested
375 && not (isWrapperId binder) -- these always claim to be INLINEd
376 && not have_inlining_already
377 then trace -- we'd better have a look...
380 which = if scc_s_OK then " (late):" else " (early):"
382 my_my_trace ("unfolding disallowed for"++which++(ppShow 80 (ppr PprDebug binder))) (
386 | rhs `isWrapperFor` binder
387 -- Don't add an explicit "unfolding"; let the worker/wrapper
388 -- stuff do its thing. INLINE things don't get w/w'd, so
392 #if ! OMIT_DEFORESTER
393 -- For the deforester: bypass the barbed wire for recursive
394 -- functions that want to be inlined and are tagged deforestable
395 -- by the user, allowing these things to be communicated
396 -- across module boundaries.
399 explicit_INLINE_requested &&
400 deforestable binder &&
401 scc_s_OK -- hack, only get them in
403 = glorious_success UnfoldAlways
406 | is_recursive && not rhs_looks_like_a_data_val
407 -- The only recursive defns we are prepared to tolerate at the
408 -- moment is top-level very-obviously-a-data-value ones.
409 -- We *need* these for dictionaries to be exported!
410 = --pprTrace "giving up on rec:" (ppr PprDebug binder)
413 -- Not really interested unless it's exported, but doing it
414 -- this way (not worrying about export-ness) gets us all the
415 -- workers/specs, etc., too; which we will need for generating
416 -- interfaces. We are also not interested if this binder is
417 -- in the environment we already have (perhaps from a previous
418 -- run of calcInlinings -- "earlier" is presumed to mean
421 | explicit_INLINE_requested
422 = glorious_success UnfoldAlways
425 = glorious_success guidance
429 = calcUnfoldingGuidance scc_s_OK max_out_threshold rhs
431 max_out_threshold = if explicit_INLINE_requested
432 then 100000 -- you asked for it, you got it
433 else unfolding_creation_threshold
437 UnfoldAlways -> 0 -- *extremely* small
438 EssentialUnfolding -> 0 -- ditto
439 UnfoldIfGoodArgs _ _ _ size -> size
441 guidance_says_don't = case guidance of { UnfoldNever -> True; _ -> False }
443 guidance_size_too_big
444 -- Does the guidance suggest that this unfolding will
445 -- be of no use *no matter* the arguments given to it?
446 -- Could be more sophisticated...
448 UnfoldAlways -> False
449 EssentialUnfolding -> False
450 UnfoldIfGoodArgs _ no_val_args arg_info_vec size
452 -> if explicit_creation_threshold then
453 False -- user set threshold; don't second-guess...
455 else if no_val_args == 0 && rhs_looks_like_a_data_val then
456 False -- we'd like a top-level data constr to be
457 -- visible even if it is never unfolded
461 = leastItCouldCost con_discount_weight size no_val_args
462 arg_info_vec rhs_arg_tys
464 -- (if (unfold_use_threshold < cost) then (pprTrace "cost:" (ppInt cost)) else \x->x ) (
465 unfold_use_threshold < cost
469 rhs_looks_like_a_caf = not (manifestlyWHNF rhs)
471 rhs_looks_like_a_data_val
472 = case (collectBinders rhs) of
473 (_, _, [], Con _ _) -> True
477 = case (collectBinders rhs) of
478 (_, _, val_binders, _) -> map idType val_binders
480 (mentioned_ids, _, _, mentions_litlit)
481 = mentionedInUnfolding (\x -> x) rhs
483 rhs_mentions_an_unmentionable
484 = foldBag (||) unfoldingUnfriendlyId False mentioned_ids
486 -- ToDo: probably need to chk tycons/classes...
488 mentions_no_other_ids = isEmptyBag mentioned_ids
490 explicit_INLINE_requested
491 -- did it come from a user {-# INLINE ... #-}?
492 -- (Warning: must avoid including wrappers.)
493 = idWantsToBeINLINEd binder
494 && not (rhs `isWrapperFor` binder)
496 have_inlining_already = maybeToBool (lookupIdEnv inline_env binder)
498 ignominious_defeat = inline_env -- just give back what we got
501 "glorious_success" is ours if we've found a suitable unfolding.
503 But we check for a couple of fine points.
505 (1) If this Id already has an inlining in the inline_env,
506 we don't automatically take it -- the earlier one is
507 "likely" to be better.
509 But if the new one doesn't mention any other global
510 Ids, and it's pretty small (< UnfoldingOverrideThreshold),
511 then we take the chance that the new one *is* better.
513 (2) If we have an Id w/ a worker/wrapper split (with
514 an unfolding for the wrapper), we tend to want to keep
515 it -- and *nuke* any inlining that we conjured up
518 But, again, if this unfolding doesn't mention any
519 other global Ids (and small enough), then it is
520 probably better than the worker/wrappery, so we take
523 glorious_success guidance
525 new_env = addOneToIdEnv inline_env binder (mkUnfolding guidance rhs)
527 foldr_building = opt_FoldrBuildOn
529 if (not have_inlining_already) then
530 -- Not in env: we take it no matter what
531 -- NB: we could check for worker/wrapper-ness,
532 -- but the truth is we probably haven't run
533 -- the strictness analyser yet.
536 else if explicit_INLINE_requested then
537 -- If it was a user INLINE, then we know it's already
538 -- in the inline_env; we stick with what we already
540 --pprTrace "giving up on INLINE:" (ppr PprDebug binder)
543 else if isWrapperId binder then
544 -- It's in the env, but we have since worker-wrapperised;
545 -- we either take this new one (because it's so good),
546 -- or we *undo* the one in the inline_env, so the
547 -- wrapper-inlining will take over.
549 if mentions_no_other_ids {- *** && size <= unfold_override_threshold -} then
552 delOneFromIdEnv inline_env binder
555 -- It's in the env, nothing to do w/ worker wrapper;
556 -- we'll take it if it is better.
558 if not foldr_building -- ANDY hates us... (see below)
559 && mentions_no_other_ids
560 && guidance_size <= unfold_override_threshold then
563 --pprTrace "giving up on final hurdle:" (ppCat [ppr PprDebug binder, ppInt guidance_size, ppInt unfold_override_threshold])
564 ignominious_defeat -- and at the last hurdle, too!
567 ANDY, on the hatred of the check above; why obliterate it? Consider
569 head xs = foldr (\ x _ -> x) (_|_) xs
571 This then is exported via a pragma. However,
572 *if* you include the extra code above, you will
573 export the non-foldr/build version.