2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[SimplCore]{Driver for simplifying @Core@ programs}
7 #include "HsVersions.h"
24 import AbsUniType ( getTyConDataCons, alpha_ty, alpha_tyvar, beta_ty, beta_tyvar )
25 --SAVE:import ArityAnal ( arityAnalProgram )
27 import BinderInfo ( BinderInfo) -- instances only
28 import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD,
29 uNFOLDING_USE_THRESHOLD,
30 uNFOLDING_OVERRIDE_THRESHOLD,
31 uNFOLDING_CON_DISCOUNT_WEIGHT
34 import CoreLint ( lintCoreBindings )
35 import FloatIn ( floatInwards )
36 import FloatOut ( floatOutwards )
37 import Id ( getIdUnfolding,
38 getIdUniType, toplevelishId,
40 unfoldingUnfriendlyId, isWrapperId,
42 IF_ATTACK_PRAGMAS(COMMA getIdStrictness)
46 import LiberateCase ( liberateCase )
49 import SAT ( doStaticArgs )
51 import SimplEnv ( UnfoldingGuidance(..), SwitchChecker(..) ) -- instances
53 --import SimplHaskell ( coreToHaskell )
54 import SimplMonad ( zeroSimplCount, showSimplCount, TickType, SimplCount )
55 import SimplPgm ( simplifyPgm )
56 import SimplVar ( leastItCouldCost )
58 import SpecTyFuns ( pprSpecErrs )
59 import StrictAnal ( saWwTopBinds )
60 #if ! OMIT_FOLDR_BUILD
65 import Deforest ( deforestProgram )
66 import DefUtils ( deforestable )
68 import TyVarEnv ( nullTyVarEnv )
75 core2core :: [CoreToDo] -- spec of what core-to-core passes to do
76 -> (GlobalSwitch->SwitchResult)-- "global" command-line info lookup fn
77 -> FAST_STRING -- module name (profiling only)
78 -> PprStyle -- printing style (for debugging only)
79 -> SplitUniqSupply -- a name supply
80 -> [TyCon] -- local data tycons and tycon specialisations
81 -> FiniteMap TyCon [(Bool, [Maybe UniType])]
82 -> [PlainCoreBinding] -- input...
84 ([PlainCoreBinding], -- results: program, plus...
85 IdEnv UnfoldingDetails, -- unfoldings to be exported from here
86 SpecialiseData) -- specialisation data
88 core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs binds
90 if null core_todos then -- very rare, I suspect...
91 -- well, we still must do some renumbering
93 (snd (instCoreBindings (mkUniqueSupplyGrimily us) binds), nullIdEnv, init_specdata)
96 (if do_verbose_core2core then
97 writeMn stderr "VERBOSE CORE-TO-CORE:\n"
98 else returnMn ()) `thenMn_`
100 -- better do the main business
101 foldl_mn do_core_pass
102 (binds, us, nullIdEnv, init_specdata, zeroSimplCount)
104 `thenMn` \ (processed_binds, _, inline_env, spec_data, simpl_stats) ->
106 (if switch_is_on D_simplifier_stats
107 then writeMn stderr ("\nSimplifier Stats:\n")
109 writeMn stderr (showSimplCount simpl_stats)
115 returnMn (processed_binds, inline_env, spec_data)
118 init_specdata = initSpecData local_tycons tycon_specs
120 switch_is_on = switchIsOn sw_chkr
122 do_verbose_core2core = switch_is_on D_verbose_core2core
124 lib_case_threshold -- ToDo: HACK HACK HACK : FIX ME FIX ME FIX ME
125 -- Use 4x a known threshold
126 = case (intSwitchSet sw_chkr UnfoldingOverrideThreshold) of
127 Nothing -> 4 * uNFOLDING_USE_THRESHOLD
131 core_linter = if switch_is_on DoCoreLinting
132 then lintCoreBindings ppr_style
133 else ( \ whodunnit spec_done binds -> binds )
136 do_core_pass info@(binds, us, inline_env, spec_data, simpl_stats) to_do
138 (us1, us2) = splitUniqSupply us
141 CoreDoSimplify simpl_sw_chkr
142 -> BSCC("CoreSimplify")
143 begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
144 then " (foldr/build)" else "") `thenMn_`
145 case (simplifyPgm binds sw_chkr simpl_sw_chkr simpl_stats us1) of
146 (p, it_cnt, simpl_stats2)
147 -> end_pass False us2 p inline_env spec_data simpl_stats2
148 ("Simplify (" ++ show it_cnt ++ ")"
149 ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
150 then " foldr/build" else "")
153 CoreDoFoldrBuildWorkerWrapper
155 -> error "ERROR: CoreDoFoldrBuildWorkerWrapper: not built into compiler\n"
157 -> BSCC("CoreDoFoldrBuildWorkerWrapper")
158 begin_pass "FBWW" `thenMn_`
159 case (mkFoldrBuildWW switch_is_on us1 binds) of { binds2 ->
160 end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW"
164 CoreDoFoldrBuildWWAnal
166 -> error "ERROR: CoreDoFoldrBuildWWAnal: not built into compiler\n"
168 -> BSCC("CoreDoFoldrBuildWWAnal")
169 begin_pass "AnalFBWW" `thenMn_`
170 case (analFBWW switch_is_on binds) of { binds2 ->
171 end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW"
176 -> BSCC("LiberateCase")
177 begin_pass "LiberateCase" `thenMn_`
178 case (liberateCase lib_case_threshold binds) of { binds2 ->
179 end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase"
182 CoreDoCalcInlinings1 -- avoid inlinings w/ cost-centres
183 -> BSCC("CoreInlinings1")
184 begin_pass "CalcInlinings" `thenMn_`
185 case (calcInlinings False sw_chkr inline_env binds) of { inline_env2 ->
186 end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings"
189 CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres
190 -> BSCC("CoreInlinings2")
191 begin_pass "CalcInlinings" `thenMn_`
192 case (calcInlinings True sw_chkr inline_env binds) of { inline_env2 ->
193 end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings"
197 -> BSCC("FloatInwards")
198 begin_pass "FloatIn" `thenMn_`
199 case (floatInwards binds) of { binds2 ->
200 end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn"
204 -> BSCC("CoreFloating")
205 begin_pass "FloatOut" `thenMn_`
206 case (floatOutwards switch_is_on us1 binds) of { binds2 ->
207 end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut"
211 -> BSCC("CoreStaticArgs")
212 begin_pass "StaticArgs" `thenMn_`
213 case (doStaticArgs binds us1) of { binds2 ->
214 end_pass False us2 binds2 inline_env spec_data simpl_stats "StaticArgs"
215 -- Binds really should be dependency-analysed for static-
216 -- arg transformation... Not to worry, they probably are.
217 -- (I don't think it *dies* if they aren't [WDP 94/04/15])
221 -> BSCC("CoreStranal")
222 begin_pass "StrAnal" `thenMn_`
223 case (saWwTopBinds us1 switch_is_on binds) of { binds2 ->
224 end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal"
228 -> BSCC("Specialise")
229 begin_pass "Specialise" `thenMn_`
230 case (specProgram switch_is_on us1 binds spec_data) of {
231 (p, spec_data2@(SpecData _ spec_noerrs _ _ _
232 spec_errs spec_warn spec_tyerrs)) ->
234 -- if we got errors, we die straight away
235 (if not spec_noerrs ||
236 (switch_is_on ShowImportSpecs && not (isEmptyBag spec_warn)) then
237 writeMn stderr (ppShow 1000 {-pprCols-}
238 (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
239 `thenMn_` writeMn stderr "\n"
241 returnMn ()) `thenMn_`
243 (if not spec_noerrs then -- Stop here if specialisation errors occured
246 returnMn ()) `thenMn_`
248 end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise"
254 -> error "ERROR: CoreDoDeforest: not built into compiler\n"
256 -> BSCC("Deforestation")
257 begin_pass "Deforestation" `thenMn_`
258 case (deforestProgram sw_chkr binds us1) of { binds2 ->
259 end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation"
264 CoreDoAutoCostCentres
266 begin_pass "AutoSCCs" `thenMn_`
267 case (addAutoCostCentres sw_chkr module_name binds) of { binds2 ->
268 end_pass False us2 binds2 inline_env spec_data simpl_stats "AutoSCCs"
272 CoreDoPrintCore -- print result of last pass
273 -> end_pass True us2 binds inline_env spec_data simpl_stats "Print"
276 -------------------------------------------------
279 = if switch_is_on D_show_passes
280 then \ what -> writeMn stderr ("*** Core2Core: "++what++"\n")
281 else \ what -> returnMn ()
283 end_pass print us2 binds2 inline_env2
284 spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
286 = -- report verbosely, if required
287 (if (do_verbose_core2core && not print) ||
288 (print && not do_verbose_core2core)
290 writeMn stderr ("\n*** "++what++":\n")
292 writeMn stderr (ppShow 1000
293 (ppAboves (map (pprPlainCoreBinding ppr_style) binds2)))
297 returnMn ()) `thenMn_`
299 linted_binds = core_linter what spec_done binds2
302 (linted_binds, -- processed binds, possibly run thru CoreLint
303 us2, -- UniqueSupply for the next guy
304 inline_env2, -- possibly-updated inline env
305 spec_data2, -- possibly-updated specialisation info
306 simpl_stats2 -- accumulated simplifier stats
309 -- here so it can be inlined...
310 foldl_mn f z [] = returnMn z
311 foldl_mn f z (x:xs) = f z x `thenMn` \ zz ->
315 --- ToDo: maybe move elsewhere ---
317 For top-level, exported binders that either (a)~have been INLINEd by
318 the programmer or (b)~are sufficiently ``simple'' that they should be
319 inlined, we want to record this info in a suitable IdEnv.
321 But: if something has a ``wrapper unfolding,'' we do NOT automatically
322 give it a regular unfolding (exception below). We usually assume its
323 worker will get a ``regular'' unfolding. We can then treat these two
324 levels of unfolding separately (we tend to be very friendly towards
325 wrapper unfoldings, for example), giving more fine-tuned control.
327 The exception is: If the ``regular unfolding'' mentions no other
328 global Ids (i.e., it's all PrimOps and cases and local Ids) then we
329 assume it must be really good and we take it anyway.
331 We also need to check that everything in the RHS (values and types)
332 will be visible on the other side of an interface, too.
335 calcInlinings :: Bool -- True => inlinings with _scc_s are OK
336 -> (GlobalSwitch -> SwitchResult)
337 -> IdEnv UnfoldingDetails
338 -> [PlainCoreBinding]
339 -> IdEnv UnfoldingDetails
341 calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
343 result = foldl calci inline_env_so_far top_binds
345 --pprTrace "inline env:\n" (ppAboves (map pp_item (getIdEnvMapping result)))
348 pp_item (binder, details)
349 = ppCat [ppr PprDebug binder, ppStr "=>", pp_det details]
351 pp_det NoUnfoldingDetails = ppStr "_N_"
352 pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
353 pp_det (GeneralForm _ _ expr guide)
354 = ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
355 pp_det other = ppStr "???"
358 switch_is_on = switchIsOn sw_chkr
360 my_trace = if (switch_is_on ReportWhyUnfoldingsDisallowed)
362 else \ msg stuff -> stuff
364 (unfolding_creation_threshold, explicit_creation_threshold)
365 = case (intSwitchSet sw_chkr UnfoldingCreationThreshold) of
366 Nothing -> (uNFOLDING_CREATION_THRESHOLD, False)
367 Just xx -> (xx, True)
370 = case (intSwitchSet sw_chkr UnfoldingUseThreshold) of
371 Nothing -> uNFOLDING_USE_THRESHOLD
374 unfold_override_threshold
375 = case (intSwitchSet sw_chkr UnfoldingOverrideThreshold) of
376 Nothing -> uNFOLDING_OVERRIDE_THRESHOLD
379 con_discount_weight = uNFOLDING_CON_DISCOUNT_WEIGHT
381 calci inline_env (CoRec pairs)
382 = foldl (calc True{-recursive-}) inline_env pairs
384 calci inline_env bind@(CoNonRec binder rhs)
385 = calc False{-not recursive-} inline_env (binder, rhs)
387 ---------------------------------------
389 calc is_recursive inline_env (binder, rhs)
390 | not (toplevelishId binder)
391 = --pprTrace "giving up on not top-level:" (ppr PprDebug binder)
394 | rhs_mentions_an_unmentionable
395 || (not explicit_INLINE_requested
396 && (rhs_looks_like_a_caf || guidance_says_don't || guidance_size_too_big))
399 = if explicit_INLINE_requested
400 && not (isWrapperId binder) -- these always claim to be INLINEd
401 && not have_inlining_already
402 then trace -- we'd better have a look...
405 which = if scc_s_OK then " (late):" else " (early):"
407 --pprTrace "giving up on size:" (ppCat [ppr PprDebug binder, ppr PprDebug
408 -- [rhs_mentions_an_unmentionable, explicit_INLINE_requested,
409 -- rhs_looks_like_a_caf, guidance_says_don't, guidance_size_too_big]]) (
410 my_my_trace ("unfolding disallowed for"++which++(ppShow 80 (ppr PprDebug binder))) (
415 | rhs `isWrapperFor` binder
416 -- Don't add an explicit "unfolding"; let the worker/wrapper
417 -- stuff do its thing. INLINE things don't get w/w'd, so
419 = --pprTrace "giving up on isWrapperFor:" (ppr PprDebug binder)
422 #if ! OMIT_DEFORESTER
423 -- For the deforester: bypass the barbed wire for recursive
424 -- functions that want to be inlined and are tagged deforestable
425 -- by the user, allowing these things to be communicated
426 -- across module boundaries.
429 explicit_INLINE_requested &&
430 deforestable binder &&
431 scc_s_OK -- hack, only get them in
433 = glorious_success UnfoldAlways
436 | is_recursive && not rhs_looks_like_a_data_val
437 -- The only recursive defns we are prepared to tolerate at the
438 -- moment is top-level very-obviously-a-data-value ones.
439 -- We *need* these for dictionaries to be exported!
440 = --pprTrace "giving up on rec:" (ppr PprDebug binder)
443 -- Not really interested unless it's exported, but doing it
444 -- this way (not worrying about export-ness) gets us all the
445 -- workers/specs, etc., too; which we will need for generating
446 -- interfaces. We are also not interested if this binder is
447 -- in the environment we already have (perhaps from a previous
448 -- run of calcInlinings -- "earlier" is presumed to mean
451 | explicit_INLINE_requested
452 = glorious_success UnfoldAlways
455 = glorious_success guidance
459 = calcUnfoldingGuidance scc_s_OK max_out_threshold rhs
461 max_out_threshold = if explicit_INLINE_requested
462 then 100000 -- you asked for it, you got it
463 else unfolding_creation_threshold
467 UnfoldAlways -> 0 -- *extremely* small
468 EssentialUnfolding -> 0 -- ditto
469 UnfoldIfGoodArgs _ _ _ size -> size
471 guidance_says_don't = case guidance of { UnfoldNever -> True; _ -> False }
473 guidance_size_too_big
474 -- Does the guidance suggest that this unfolding will
475 -- be of no use *no matter* the arguments given to it?
476 -- Could be more sophisticated...
478 UnfoldAlways -> False
479 EssentialUnfolding -> False
480 UnfoldIfGoodArgs _ no_val_args arg_info_vec size
482 -> if explicit_creation_threshold then
483 False -- user set threshold; don't second-guess...
485 else if no_val_args == 0 && rhs_looks_like_a_data_val then
486 False -- we'd like a top-level data constr to be
487 -- visible even if it is never unfolded
491 = leastItCouldCost con_discount_weight size no_val_args
492 arg_info_vec rhs_arg_tys
494 -- (if (unfold_use_threshold < cost) then (pprTrace "cost:" (ppInt cost)) else \x->x ) (
495 unfold_use_threshold < cost
499 rhs_looks_like_a_caf = not (manifestlyWHNF rhs)
501 rhs_looks_like_a_data_val
502 = case digForLambdas rhs of
503 (_, [], CoCon _ _ _) -> True
507 = case digForLambdas rhs of
508 (_, val_binders, _) -> map getIdUniType val_binders
510 (mentioned_ids, _, _, mentions_litlit)
511 = mentionedInUnfolding (\x -> x) rhs
513 rhs_mentions_an_unmentionable
514 = --pprTrace "mentions:" (ppCat [ppr PprDebug binder, ppr PprDebug [(i,unfoldingUnfriendlyId i) | i <- mentioned_ids ]]) (
515 any unfoldingUnfriendlyId mentioned_ids
518 -- ToDo: probably need to chk tycons/classes...
520 mentions_no_other_ids = null mentioned_ids
522 explicit_INLINE_requested
523 -- did it come from a user {-# INLINE ... #-}?
524 -- (Warning: must avoid including wrappers.)
525 = idWantsToBeINLINEd binder
526 && not (rhs `isWrapperFor` binder)
528 have_inlining_already = maybeToBool (lookupIdEnv inline_env binder)
530 ignominious_defeat = inline_env -- just give back what we got
533 "glorious_success" is ours if we've found a suitable unfolding.
535 But we check for a couple of fine points.
537 (1) If this Id already has an inlining in the inline_env,
538 we don't automatically take it -- the earlier one is
539 "likely" to be better.
541 But if the new one doesn't mention any other global
542 Ids, and it's pretty small (< UnfoldingOverrideThreshold),
543 then we take the chance that the new one *is* better.
545 (2) If we have an Id w/ a worker/wrapper split (with
546 an unfolding for the wrapper), we tend to want to keep
547 it -- and *nuke* any inlining that we conjured up
550 But, again, if this unfolding doesn't mention any
551 other global Ids (and small enough), then it is
552 probably better than the worker/wrappery, so we take
555 glorious_success guidance
557 new_env = addOneToIdEnv inline_env binder (mkUnfolding guidance rhs)
559 foldr_building = switch_is_on FoldrBuildOn
561 if (not have_inlining_already) then
562 -- Not in env: we take it no matter what
563 -- NB: we could check for worker/wrapper-ness,
564 -- but the truth is we probably haven't run
565 -- the strictness analyser yet.
568 else if explicit_INLINE_requested then
569 -- If it was a user INLINE, then we know it's already
570 -- in the inline_env; we stick with what we already
572 --pprTrace "giving up on INLINE:" (ppr PprDebug binder)
575 else if isWrapperId binder then
576 -- It's in the env, but we have since worker-wrapperised;
577 -- we either take this new one (because it's so good),
578 -- or we *undo* the one in the inline_env, so the
579 -- wrapper-inlining will take over.
581 if mentions_no_other_ids {- *** && size <= unfold_override_threshold -} then
584 delOneFromIdEnv inline_env binder
587 -- It's in the env, nothing to do w/ worker wrapper;
588 -- we'll take it if it is better.
590 if not foldr_building -- ANDY hates us... (see below)
591 && mentions_no_other_ids
592 && guidance_size <= unfold_override_threshold then
595 --pprTrace "giving up on final hurdle:" (ppCat [ppr PprDebug binder, ppInt guidance_size, ppInt unfold_override_threshold])
596 ignominious_defeat -- and at the last hurdle, too!
599 ANDY, on the hatred of the check above; why obliterate it? Consider
601 head xs = foldr (\ x _ -> x) (_|_) xs
603 This then is exported via a pragma. However,
604 *if* you include the extra code above, you will
605 export the non-foldr/build version.