2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[SimplCore]{Driver for simplifying @Core@ programs}
7 #include "HsVersions.h"
13 import Type ( getTyConDataCons )
14 --SAVE:import ArityAnal ( arityAnalProgram )
16 import BinderInfo ( BinderInfo) -- instances only
17 import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD,
18 uNFOLDING_USE_THRESHOLD,
19 uNFOLDING_OVERRIDE_THRESHOLD,
20 uNFOLDING_CON_DISCOUNT_WEIGHT
23 import CoreLint ( lintCoreBindings )
24 import FloatIn ( floatInwards )
25 import FloatOut ( floatOutwards )
26 import Id ( getIdUnfolding,
27 idType, toplevelishId,
29 unfoldingUnfriendlyId, isWrapperId,
33 import LiberateCase ( liberateCase )
36 import SAT ( doStaticArgs )
39 --import SimplHaskell ( coreToHaskell )
40 import SimplMonad ( zeroSimplCount, showSimplCount, TickType, SimplCount )
41 import SimplPgm ( simplifyPgm )
42 import SimplVar ( leastItCouldCost )
44 import SpecUtils ( pprSpecErrs )
45 import StrictAnal ( saWwTopBinds )
49 import Deforest ( deforestProgram )
50 import DefUtils ( deforestable )
57 core2core :: [CoreToDo] -- spec of what core-to-core passes to do
58 -> (GlobalSwitch->SwitchResult)-- "global" command-line info lookup fn
59 -> FAST_STRING -- module name (profiling only)
60 -> PprStyle -- printing style (for debugging only)
61 -> UniqSupply -- a name supply
62 -> [TyCon] -- local data tycons and tycon specialisations
63 -> FiniteMap TyCon [(Bool, [Maybe Type])]
64 -> [CoreBinding] -- input...
66 ([CoreBinding], -- results: program, plus...
67 IdEnv UnfoldingDetails, -- unfoldings to be exported from here
68 SpecialiseData) -- specialisation data
70 core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs binds
72 if null core_todos then -- very rare, I suspect...
73 -- well, we still must do some renumbering
75 (snd (instCoreBindings (mkUniqueSupplyGrimily us) binds), nullIdEnv, init_specdata)
78 (if do_verbose_core2core then
79 writeMn stderr "VERBOSE CORE-TO-CORE:\n"
80 else returnMn ()) `thenMn_`
82 -- better do the main business
84 (binds, us, nullIdEnv, init_specdata, zeroSimplCount)
86 `thenMn` \ (processed_binds, _, inline_env, spec_data, simpl_stats) ->
88 (if switch_is_on D_simplifier_stats
89 then writeMn stderr ("\nSimplifier Stats:\n")
91 writeMn stderr (showSimplCount simpl_stats)
97 returnMn (processed_binds, inline_env, spec_data)
100 init_specdata = initSpecData local_tycons tycon_specs
102 switch_is_on = switchIsOn sw_chkr
104 do_verbose_core2core = switch_is_on D_verbose_core2core
106 lib_case_threshold -- ToDo: HACK HACK HACK : FIX ME FIX ME FIX ME
107 -- Use 4x a known threshold
108 = case (intSwitchSet sw_chkr UnfoldingOverrideThreshold) of
109 Nothing -> 4 * uNFOLDING_USE_THRESHOLD
113 core_linter = if switch_is_on DoCoreLinting
114 then lintCoreBindings ppr_style
115 else ( \ whodunnit spec_done binds -> binds )
118 do_core_pass info@(binds, us, inline_env, spec_data, simpl_stats) to_do
120 (us1, us2) = splitUniqSupply us
123 CoreDoSimplify simpl_sw_chkr
124 -> BSCC("CoreSimplify")
125 begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
126 then " (foldr/build)" else "") `thenMn_`
127 case (simplifyPgm binds sw_chkr simpl_sw_chkr simpl_stats us1) of
128 (p, it_cnt, simpl_stats2)
129 -> end_pass False us2 p inline_env spec_data simpl_stats2
130 ("Simplify (" ++ show it_cnt ++ ")"
131 ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
132 then " foldr/build" else "")
135 CoreDoFoldrBuildWorkerWrapper
136 -> BSCC("CoreDoFoldrBuildWorkerWrapper")
137 begin_pass "FBWW" `thenMn_`
138 case (mkFoldrBuildWW switch_is_on us1 binds) of { binds2 ->
139 end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW"
142 CoreDoFoldrBuildWWAnal
143 -> BSCC("CoreDoFoldrBuildWWAnal")
144 begin_pass "AnalFBWW" `thenMn_`
145 case (analFBWW switch_is_on binds) of { binds2 ->
146 end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW"
150 -> BSCC("LiberateCase")
151 begin_pass "LiberateCase" `thenMn_`
152 case (liberateCase lib_case_threshold binds) of { binds2 ->
153 end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase"
156 CoreDoCalcInlinings1 -- avoid inlinings w/ cost-centres
157 -> BSCC("CoreInlinings1")
158 begin_pass "CalcInlinings" `thenMn_`
159 case (calcInlinings False sw_chkr inline_env binds) of { inline_env2 ->
160 end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings"
163 CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres
164 -> BSCC("CoreInlinings2")
165 begin_pass "CalcInlinings" `thenMn_`
166 case (calcInlinings True sw_chkr inline_env binds) of { inline_env2 ->
167 end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings"
171 -> BSCC("FloatInwards")
172 begin_pass "FloatIn" `thenMn_`
173 case (floatInwards binds) of { binds2 ->
174 end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn"
178 -> BSCC("CoreFloating")
179 begin_pass "FloatOut" `thenMn_`
180 case (floatOutwards switch_is_on us1 binds) of { binds2 ->
181 end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut"
185 -> BSCC("CoreStaticArgs")
186 begin_pass "StaticArgs" `thenMn_`
187 case (doStaticArgs binds us1) of { binds2 ->
188 end_pass False us2 binds2 inline_env spec_data simpl_stats "StaticArgs"
189 -- Binds really should be dependency-analysed for static-
190 -- arg transformation... Not to worry, they probably are.
191 -- (I don't think it *dies* if they aren't [WDP 94/04/15])
195 -> BSCC("CoreStranal")
196 begin_pass "StrAnal" `thenMn_`
197 case (saWwTopBinds us1 switch_is_on binds) of { binds2 ->
198 end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal"
202 -> BSCC("Specialise")
203 begin_pass "Specialise" `thenMn_`
204 case (specProgram switch_is_on us1 binds spec_data) of {
205 (p, spec_data2@(SpecData _ spec_noerrs _ _ _
206 spec_errs spec_warn spec_tyerrs)) ->
208 -- if we got errors, we die straight away
209 (if not spec_noerrs ||
210 (switch_is_on ShowImportSpecs && not (isEmptyBag spec_warn)) then
211 writeMn stderr (ppShow 1000 {-pprCols-}
212 (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
213 `thenMn_` writeMn stderr "\n"
215 returnMn ()) `thenMn_`
217 (if not spec_noerrs then -- Stop here if specialisation errors occured
220 returnMn ()) `thenMn_`
222 end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise"
228 -> error "ERROR: CoreDoDeforest: not built into compiler\n"
230 -> BSCC("Deforestation")
231 begin_pass "Deforestation" `thenMn_`
232 case (deforestProgram sw_chkr binds us1) of { binds2 ->
233 end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation"
238 CoreDoAutoCostCentres
240 begin_pass "AutoSCCs" `thenMn_`
241 case (addAutoCostCentres sw_chkr module_name binds) of { binds2 ->
242 end_pass False us2 binds2 inline_env spec_data simpl_stats "AutoSCCs"
246 CoreDoPrintCore -- print result of last pass
247 -> end_pass True us2 binds inline_env spec_data simpl_stats "Print"
250 -------------------------------------------------
253 = if switch_is_on D_show_passes
254 then \ what -> writeMn stderr ("*** Core2Core: "++what++"\n")
255 else \ what -> returnMn ()
257 end_pass print us2 binds2 inline_env2
258 spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
260 = -- report verbosely, if required
261 (if (do_verbose_core2core && not print) ||
262 (print && not do_verbose_core2core)
264 writeMn stderr ("\n*** "++what++":\n")
266 writeMn stderr (ppShow 1000
267 (ppAboves (map (pprPlainCoreBinding ppr_style) binds2)))
271 returnMn ()) `thenMn_`
273 linted_binds = core_linter what spec_done binds2
276 (linted_binds, -- processed binds, possibly run thru CoreLint
277 us2, -- UniqueSupply for the next guy
278 inline_env2, -- possibly-updated inline env
279 spec_data2, -- possibly-updated specialisation info
280 simpl_stats2 -- accumulated simplifier stats
283 -- here so it can be inlined...
284 foldl_mn f z [] = returnMn z
285 foldl_mn f z (x:xs) = f z x `thenMn` \ zz ->
289 --- ToDo: maybe move elsewhere ---
291 For top-level, exported binders that either (a)~have been INLINEd by
292 the programmer or (b)~are sufficiently ``simple'' that they should be
293 inlined, we want to record this info in a suitable IdEnv.
295 But: if something has a ``wrapper unfolding,'' we do NOT automatically
296 give it a regular unfolding (exception below). We usually assume its
297 worker will get a ``regular'' unfolding. We can then treat these two
298 levels of unfolding separately (we tend to be very friendly towards
299 wrapper unfoldings, for example), giving more fine-tuned control.
301 The exception is: If the ``regular unfolding'' mentions no other
302 global Ids (i.e., it's all PrimOps and cases and local Ids) then we
303 assume it must be really good and we take it anyway.
305 We also need to check that everything in the RHS (values and types)
306 will be visible on the other side of an interface, too.
309 calcInlinings :: Bool -- True => inlinings with _scc_s are OK
310 -> (GlobalSwitch -> SwitchResult)
311 -> IdEnv UnfoldingDetails
313 -> IdEnv UnfoldingDetails
315 calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
317 result = foldl calci inline_env_so_far top_binds
319 --pprTrace "inline env:\n" (ppAboves (map pp_item (getIdEnvMapping result)))
322 pp_item (binder, details)
323 = ppCat [ppr PprDebug binder, ppStr "=>", pp_det details]
325 pp_det NoUnfoldingDetails = ppStr "_N_"
326 pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
327 pp_det (GenForm _ _ expr guide)
328 = ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
329 pp_det other = ppStr "???"
332 switch_is_on = switchIsOn sw_chkr
334 my_trace = if (switch_is_on ReportWhyUnfoldingsDisallowed)
336 else \ msg stuff -> stuff
338 (unfolding_creation_threshold, explicit_creation_threshold)
339 = case (intSwitchSet sw_chkr UnfoldingCreationThreshold) of
340 Nothing -> (uNFOLDING_CREATION_THRESHOLD, False)
341 Just xx -> (xx, True)
344 = case (intSwitchSet sw_chkr UnfoldingUseThreshold) of
345 Nothing -> uNFOLDING_USE_THRESHOLD
348 unfold_override_threshold
349 = case (intSwitchSet sw_chkr UnfoldingOverrideThreshold) of
350 Nothing -> uNFOLDING_OVERRIDE_THRESHOLD
353 con_discount_weight = uNFOLDING_CON_DISCOUNT_WEIGHT
355 calci inline_env (Rec pairs)
356 = foldl (calc True{-recursive-}) inline_env pairs
358 calci inline_env bind@(NonRec binder rhs)
359 = calc False{-not recursive-} inline_env (binder, rhs)
361 ---------------------------------------
363 calc is_recursive inline_env (binder, rhs)
364 | not (toplevelishId binder)
365 = --pprTrace "giving up on not top-level:" (ppr PprDebug binder)
368 | rhs_mentions_an_unmentionable
369 || (not explicit_INLINE_requested
370 && (rhs_looks_like_a_caf || guidance_says_don't || guidance_size_too_big))
373 = if explicit_INLINE_requested
374 && not (isWrapperId binder) -- these always claim to be INLINEd
375 && not have_inlining_already
376 then trace -- we'd better have a look...
379 which = if scc_s_OK then " (late):" else " (early):"
381 --pprTrace "giving up on size:" (ppCat [ppr PprDebug binder, ppr PprDebug
382 -- [rhs_mentions_an_unmentionable, explicit_INLINE_requested,
383 -- rhs_looks_like_a_caf, guidance_says_don't, guidance_size_too_big]]) (
384 my_my_trace ("unfolding disallowed for"++which++(ppShow 80 (ppr PprDebug binder))) (
389 | rhs `isWrapperFor` binder
390 -- Don't add an explicit "unfolding"; let the worker/wrapper
391 -- stuff do its thing. INLINE things don't get w/w'd, so
393 = --pprTrace "giving up on isWrapperFor:" (ppr PprDebug binder)
396 #if ! OMIT_DEFORESTER
397 -- For the deforester: bypass the barbed wire for recursive
398 -- functions that want to be inlined and are tagged deforestable
399 -- by the user, allowing these things to be communicated
400 -- across module boundaries.
403 explicit_INLINE_requested &&
404 deforestable binder &&
405 scc_s_OK -- hack, only get them in
407 = glorious_success UnfoldAlways
410 | is_recursive && not rhs_looks_like_a_data_val
411 -- The only recursive defns we are prepared to tolerate at the
412 -- moment is top-level very-obviously-a-data-value ones.
413 -- We *need* these for dictionaries to be exported!
414 = --pprTrace "giving up on rec:" (ppr PprDebug binder)
417 -- Not really interested unless it's exported, but doing it
418 -- this way (not worrying about export-ness) gets us all the
419 -- workers/specs, etc., too; which we will need for generating
420 -- interfaces. We are also not interested if this binder is
421 -- in the environment we already have (perhaps from a previous
422 -- run of calcInlinings -- "earlier" is presumed to mean
425 | explicit_INLINE_requested
426 = glorious_success UnfoldAlways
429 = glorious_success guidance
433 = calcUnfoldingGuidance scc_s_OK max_out_threshold rhs
435 max_out_threshold = if explicit_INLINE_requested
436 then 100000 -- you asked for it, you got it
437 else unfolding_creation_threshold
441 UnfoldAlways -> 0 -- *extremely* small
442 EssentialUnfolding -> 0 -- ditto
443 UnfoldIfGoodArgs _ _ _ size -> size
445 guidance_says_don't = case guidance of { UnfoldNever -> True; _ -> False }
447 guidance_size_too_big
448 -- Does the guidance suggest that this unfolding will
449 -- be of no use *no matter* the arguments given to it?
450 -- Could be more sophisticated...
452 UnfoldAlways -> False
453 EssentialUnfolding -> False
454 UnfoldIfGoodArgs _ no_val_args arg_info_vec size
456 -> if explicit_creation_threshold then
457 False -- user set threshold; don't second-guess...
459 else if no_val_args == 0 && rhs_looks_like_a_data_val then
460 False -- we'd like a top-level data constr to be
461 -- visible even if it is never unfolded
465 = leastItCouldCost con_discount_weight size no_val_args
466 arg_info_vec rhs_arg_tys
468 -- (if (unfold_use_threshold < cost) then (pprTrace "cost:" (ppInt cost)) else \x->x ) (
469 unfold_use_threshold < cost
473 rhs_looks_like_a_caf = not (manifestlyWHNF rhs)
475 rhs_looks_like_a_data_val
476 = case (digForLambdas rhs) of
477 (_, _, [], Con _ _ _) -> True
481 = case (digForLambdas rhs) of
482 (_, _, val_binders, _) -> map idType val_binders
484 (mentioned_ids, _, _, mentions_litlit)
485 = mentionedInUnfolding (\x -> x) rhs
487 rhs_mentions_an_unmentionable
488 = --pprTrace "mentions:" (ppCat [ppr PprDebug binder, ppr PprDebug [(i,unfoldingUnfriendlyId i) | i <- mentioned_ids ]]) (
489 any unfoldingUnfriendlyId mentioned_ids
492 -- ToDo: probably need to chk tycons/classes...
494 mentions_no_other_ids = null mentioned_ids
496 explicit_INLINE_requested
497 -- did it come from a user {-# INLINE ... #-}?
498 -- (Warning: must avoid including wrappers.)
499 = idWantsToBeINLINEd binder
500 && not (rhs `isWrapperFor` binder)
502 have_inlining_already = maybeToBool (lookupIdEnv inline_env binder)
504 ignominious_defeat = inline_env -- just give back what we got
507 "glorious_success" is ours if we've found a suitable unfolding.
509 But we check for a couple of fine points.
511 (1) If this Id already has an inlining in the inline_env,
512 we don't automatically take it -- the earlier one is
513 "likely" to be better.
515 But if the new one doesn't mention any other global
516 Ids, and it's pretty small (< UnfoldingOverrideThreshold),
517 then we take the chance that the new one *is* better.
519 (2) If we have an Id w/ a worker/wrapper split (with
520 an unfolding for the wrapper), we tend to want to keep
521 it -- and *nuke* any inlining that we conjured up
524 But, again, if this unfolding doesn't mention any
525 other global Ids (and small enough), then it is
526 probably better than the worker/wrappery, so we take
529 glorious_success guidance
531 new_env = addOneToIdEnv inline_env binder (mkUnfolding guidance rhs)
533 foldr_building = switch_is_on FoldrBuildOn
535 if (not have_inlining_already) then
536 -- Not in env: we take it no matter what
537 -- NB: we could check for worker/wrapper-ness,
538 -- but the truth is we probably haven't run
539 -- the strictness analyser yet.
542 else if explicit_INLINE_requested then
543 -- If it was a user INLINE, then we know it's already
544 -- in the inline_env; we stick with what we already
546 --pprTrace "giving up on INLINE:" (ppr PprDebug binder)
549 else if isWrapperId binder then
550 -- It's in the env, but we have since worker-wrapperised;
551 -- we either take this new one (because it's so good),
552 -- or we *undo* the one in the inline_env, so the
553 -- wrapper-inlining will take over.
555 if mentions_no_other_ids {- *** && size <= unfold_override_threshold -} then
558 delOneFromIdEnv inline_env binder
561 -- It's in the env, nothing to do w/ worker wrapper;
562 -- we'll take it if it is better.
564 if not foldr_building -- ANDY hates us... (see below)
565 && mentions_no_other_ids
566 && guidance_size <= unfold_override_threshold then
569 --pprTrace "giving up on final hurdle:" (ppCat [ppr PprDebug binder, ppInt guidance_size, ppInt unfold_override_threshold])
570 ignominious_defeat -- and at the last hurdle, too!
573 ANDY, on the hatred of the check above; why obliterate it? Consider
575 head xs = foldr (\ x _ -> x) (_|_) xs
577 This then is exported via a pragma. However,
578 *if* you include the extra code above, you will
579 export the non-foldr/build version.