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 [[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 trace ("Simplifier Stats:\n" ++ showSimplCount simpl_stats) (returnMn ())
112 (if do_dump_core_passes
113 then trace (unlines (
116 : "+------------------------------+"
117 : reverse [ " " ++ take (30::Int) (what ++ repeat ' ') ++ "|"
118 | what <- simpl_whats ])
119 ++ ["+------------------------------+"]))
120 else \x -> x) -- to the end
122 returnMn (processed_binds, inline_env, spec_data)
125 init_specdata = initSpecData local_tycons tycon_specs
127 switch_is_on = switchIsOn sw_chkr
129 do_dump_core_passes = switch_is_on D_dump_core_passes -- an Andy flag
130 do_verbose_core2core = switch_is_on D_verbose_core2core
132 lib_case_threshold -- ToDo: HACK HACK HACK : FIX ME FIX ME FIX ME
133 -- Use 4x a known threshold
134 = case (intSwitchSet sw_chkr UnfoldingOverrideThreshold) of
135 Nothing -> 4 * uNFOLDING_USE_THRESHOLD
139 core_linter = if switch_is_on DoCoreLinting
140 then lintCoreBindings ppr_style
141 else ( \ whodunnit spec_done binds -> binds )
144 do_core_pass info@(binds, us, inline_env, spec_data, simpl_stats) to_do
146 (us1, us2) = splitUniqSupply us
149 CoreDoSimplify simpl_sw_chkr
150 -> BSCC("CoreSimplify")
151 case (simplifyPgm binds sw_chkr simpl_sw_chkr simpl_stats us1) of
152 (p, it_cnt, simpl_stats2)
153 -> end_pass us2 p inline_env spec_data simpl_stats2 ("Simplify (" ++ show it_cnt ++ ")")
156 CoreDoFoldrBuildWorkerWrapper
158 -> error "ERROR: CoreDoFoldrBuildWorkerWrapper: not built into compiler\n"
160 -> BSCC("CoreDoFoldrBuildWorkerWrapper")
161 end_pass us2 (mkFoldrBuildWW switch_is_on us1 binds) inline_env spec_data simpl_stats "FBWW"
165 CoreDoFoldrBuildWWAnal
167 -> error "ERROR: CoreDoFoldrBuildWWAnal: not built into compiler\n"
169 -> BSCC("CoreDoFoldrBuildWWAnal")
170 end_pass us2 (analFBWW switch_is_on binds) inline_env spec_data simpl_stats "AnalFBWW"
175 -> BSCC("LiberateCase")
176 case (liberateCase lib_case_threshold binds) of { binds2 ->
177 end_pass us2 binds2 inline_env spec_data simpl_stats "LiberateCase"
181 CoreDoCalcInlinings1 -- avoid inlinings w/ cost-centres
182 -> BSCC("CoreInlinings1")
183 case (calcInlinings False sw_chkr inline_env binds) of { inline_env2 ->
184 end_pass us2 binds inline_env2 spec_data simpl_stats "Calc Inlinings"
187 CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres
188 -> BSCC("CoreInlinings2")
189 case (calcInlinings True sw_chkr inline_env binds) of { inline_env2 ->
190 end_pass us2 binds inline_env2 spec_data simpl_stats "Calc Inlinings"
194 -> BSCC("FloatInwards")
195 end_pass us2 (floatInwards binds) inline_env spec_data simpl_stats "FloatIn"
199 -> BSCC("CoreFloating")
200 case (floatOutwards switch_is_on us1 binds) of { p ->
201 end_pass us2 p inline_env spec_data simpl_stats "FloatOut"
206 printed = ppShow 80 (ppr ppr_style binds)
208 strict (s:ss) a | ord s == 0 = error "0 in output string"
209 | otherwise = strict ss a
211 end_pass us2 (strict printed (trace ("PrintCore:\n" ++ printed) binds)) inline_env spec_data simpl_stats "Print"
216 printed = coreToHaskell binds
218 strict (s:ss) a | ord s == 0 = error "0 in output string"
219 | otherwise = strict ss a
221 strict printed (trace ("PrintCore:\n" ++ printed) binds), inline_env, spec_data, simpl_stats, "PrintHask"
225 -> BSCC("CoreStaticArgs")
226 end_pass us2 (doStaticArgs binds us1) inline_env spec_data simpl_stats "SAT"
227 -- Binds really should be dependency-analysed for static-
228 -- arg transformation... Not to worry, they probably are.
229 -- (I don't think it *dies* if they aren't [WDP 94/04/15])
233 -> BSCC("CoreStranal")
234 end_pass us2 (saWwTopBinds us1 switch_is_on binds) inline_env spec_data simpl_stats "StrAnal"
238 -> BSCC("Specialise")
239 case (specProgram switch_is_on us1 binds spec_data) of {
240 (p, spec_data2@(SpecData _ spec_noerrs _ _ _
241 spec_errs spec_warn spec_tyerrs)) ->
243 -- if we got errors, we die straight away
244 (if not spec_noerrs ||
245 (switch_is_on ShowImportSpecs && not (isEmptyBag spec_warn)) then
246 writeMn stderr (ppShow 1000 {-pprCols-}
247 (pprSpecErrs PprForUser spec_errs spec_warn spec_tyerrs))
248 `thenMn_` writeMn stderr "\n"
250 returnMn ()) `thenMn_`
252 (if not spec_noerrs then -- Stop here if specialisation errors occured
255 returnMn ()) `thenMn_`
257 end_pass us2 p inline_env spec_data2 simpl_stats "Specialise"
263 -> error "ERROR: CoreDoDeforest: not built into compiler\n"
265 -> BSCC("Deforestation")
266 case (deforestProgram sw_chkr binds us1) of { binds ->
267 end_pass us2 binds inline_env spec_data simpl_stats "Deforestation"
272 CoreDoAutoCostCentres
274 end_pass us2 (addAutoCostCentres sw_chkr module_name binds) inline_env spec_data simpl_stats "AutoSCCs"
277 -------------------------------------------------
279 end_pass us2 binds2 inline_env2
280 spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
282 = -- report verbosely, if required
283 (if do_verbose_core2core then
284 writeMn stderr ("\n*** "++what++":\n")
286 writeMn stderr (ppShow 1000
287 (ppAboves (map (pprPlainCoreBinding ppr_style) binds2)))
291 returnMn ()) `thenMn_`
293 linted_binds = core_linter what spec_done binds2
296 (linted_binds, -- processed binds, possibly run thru CoreLint
297 us2, -- UniqueSupply for the next guy
298 inline_env2, -- possibly-updated inline env
299 spec_data2, -- possibly-updated specialisation info
300 simpl_stats2 -- accumulated simplifier stats
303 -- here so it can be inlined...
304 foldl_mn f z [] = returnMn z
305 foldl_mn f z (x:xs) = f z x `thenMn` \ zz ->
309 --- ToDo: maybe move elsewhere ---
311 For top-level, exported binders that either (a)~have been INLINEd by
312 the programmer or (b)~are sufficiently ``simple'' that they should be
313 inlined, we want to record this info in a suitable IdEnv.
315 But: if something has a ``wrapper unfolding,'' we do NOT automatically
316 give it a regular unfolding (exception below). We usually assume its
317 worker will get a ``regular'' unfolding. We can then treat these two
318 levels of unfolding separately (we tend to be very friendly towards
319 wrapper unfoldings, for example), giving more fine-tuned control.
321 The exception is: If the ``regular unfolding'' mentions no other
322 global Ids (i.e., it's all PrimOps and cases and local Ids) then we
323 assume it must be really good and we take it anyway.
325 We also need to check that everything in the RHS (values and types)
326 will be visible on the other side of an interface, too.
329 calcInlinings :: Bool -- True => inlinings with _scc_s are OK
330 -> (GlobalSwitch -> SwitchResult)
331 -> IdEnv UnfoldingDetails
332 -> [PlainCoreBinding]
333 -> IdEnv UnfoldingDetails
335 calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
337 result = foldl calci inline_env_so_far top_binds
339 --pprTrace "inline env:\n" (ppAboves (map pp_item (getIdEnvMapping result)))
342 pp_item (binder, details)
343 = ppCat [ppr PprDebug binder, ppStr "=>", pp_det details]
345 pp_det NoUnfoldingDetails = ppStr "_N_"
346 pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
347 pp_det (GeneralForm _ _ expr guide)
348 = ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
349 pp_det other = ppStr "???"
352 switch_is_on = switchIsOn sw_chkr
354 my_trace = if (switch_is_on ReportWhyUnfoldingsDisallowed)
356 else \ msg stuff -> stuff
358 (unfolding_creation_threshold, explicit_creation_threshold)
359 = case (intSwitchSet sw_chkr UnfoldingCreationThreshold) of
360 Nothing -> (uNFOLDING_CREATION_THRESHOLD, False)
361 Just xx -> (xx, True)
364 = case (intSwitchSet sw_chkr UnfoldingUseThreshold) of
365 Nothing -> uNFOLDING_USE_THRESHOLD
368 unfold_override_threshold
369 = case (intSwitchSet sw_chkr UnfoldingOverrideThreshold) of
370 Nothing -> uNFOLDING_OVERRIDE_THRESHOLD
373 con_discount_weight = uNFOLDING_CON_DISCOUNT_WEIGHT
375 calci inline_env (CoRec pairs)
376 = foldl (calc True{-recursive-}) inline_env pairs
378 calci inline_env bind@(CoNonRec binder rhs)
379 = calc False{-not recursive-} inline_env (binder, rhs)
381 ---------------------------------------
383 calc is_recursive inline_env (binder, rhs)
384 | not (toplevelishId binder)
385 = --pprTrace "giving up on not top-level:" (ppr PprDebug binder)
388 | rhs_mentions_an_unmentionable
389 || (not explicit_INLINE_requested
390 && (guidance_says_don't || guidance_size_just_too_big))
393 = if explicit_INLINE_requested
394 && not (isWrapperId binder) -- these always claim to be INLINEd
395 && not have_inlining_already
396 then trace -- we'd better have a look...
399 which = if scc_s_OK then " (late):" else " (early):"
401 --pprTrace "giving up on size:" (ppCat [ppr PprDebug binder, ppr PprDebug [rhs_mentions_an_unmentionable, explicit_INLINE_requested, guidance_says_don't, guidance_size_just_too_big]]) (
402 my_my_trace ("unfolding disallowed for"++which++(ppShow 80 (ppr PprDebug binder))) (
407 | rhs `isWrapperFor` binder
408 -- Don't add an explicit "unfolding"; let the worker/wrapper
409 -- stuff do its thing. INLINE things don't get w/w'd, so
411 = --pprTrace "giving up on isWrapperFor:" (ppr PprDebug binder)
414 #if ! OMIT_DEFORESTER
415 -- For the deforester: bypass the barbed wire for recursive
416 -- functions that want to be inlined and are tagged deforestable
417 -- by the user, allowing these things to be communicated
418 -- across module boundaries.
421 explicit_INLINE_requested &&
422 deforestable binder &&
423 scc_s_OK -- hack, only get them in
425 = glorious_success UnfoldAlways
428 | is_recursive && not rhs_looks_like_a_data_val_to_me
429 -- The only recursive defns we are prepared to tolerate at the
430 -- moment is top-level very-obviously-a-data-value ones.
431 -- We *need* these for dictionaries to be exported!
432 = --pprTrace "giving up on rec:" (ppr PprDebug binder)
435 -- Not really interested unless it's exported, but doing it
436 -- this way (not worrying about export-ness) gets us all the
437 -- workers/specs, etc., too; which we will need for generating
438 -- interfaces. We are also not interested if this binder is
439 -- in the environment we already have (perhaps from a previous
440 -- run of calcInlinings -- "earlier" is presumed to mean
443 | explicit_INLINE_requested
444 = glorious_success UnfoldAlways
447 = glorious_success guidance
451 = calcUnfoldingGuidance scc_s_OK max_out_threshold rhs
453 max_out_threshold = if explicit_INLINE_requested
454 then 100000 -- you asked for it, you got it
455 else unfolding_creation_threshold
457 guidance_says_don't = case guidance of { UnfoldNever -> True; _ -> False }
461 UnfoldAlways -> 0 -- *extremely* small
462 EssentialUnfolding -> 0 -- ditto
463 UnfoldIfGoodArgs _ _ _ size -> size
465 guidance_size_just_too_big
466 -- Does the guidance suggest that this unfolding will
467 -- be of no use *no matter* the arguments given to it?
468 -- Could be more sophisticated...
470 UnfoldNever -> False -- debugging only (ToDo:rm)
471 UnfoldAlways -> False
472 EssentialUnfolding -> False
473 UnfoldIfGoodArgs _ no_val_args arg_info_vec size
475 -> if explicit_creation_threshold then
476 False -- user set threshold; don't second-guess...
478 else if no_val_args == 0 && rhs_looks_like_a_data_val_to_me then
479 False -- probably a data value; we'd like the
480 -- other guy to see the value, even if
481 -- s/he doesn't unfold it.
485 = leastItCouldCost con_discount_weight size no_val_args
486 arg_info_vec rhs_arg_tys
488 -- (if (unfold_use_threshold < cost) then (pprTrace "cost:" (ppInt cost)) else \x->x ) (
489 unfold_use_threshold < cost
495 (_, val_binders, _) = digForLambdas rhs
497 map getIdUniType val_binders
499 rhs_looks_like_a_data_val_to_me
501 (_,val_binders,body) = digForLambdas rhs
503 case (val_binders, body) of
504 ([], CoCon _ _ _) -> True
507 (mentioned_ids, _, _, mentions_litlit)
508 = mentionedInUnfolding (\x -> x) rhs
510 rhs_mentions_an_unmentionable
511 = --pprTrace "mentions:" (ppCat [ppr PprDebug binder, ppr PprDebug [(i,unfoldingUnfriendlyId i) | i <- mentioned_ids ]]) (
512 any unfoldingUnfriendlyId mentioned_ids
515 -- ToDo: probably need to chk tycons/classes...
517 mentions_no_other_ids = null mentioned_ids
519 explicit_INLINE_requested
520 -- did it come from a user {-# INLINE ... #-}?
521 -- (Warning: must avoid including wrappers.)
522 = idWantsToBeINLINEd binder
523 && not (rhs `isWrapperFor` binder)
525 have_inlining_already = maybeToBool (lookupIdEnv inline_env binder)
527 ignominious_defeat = inline_env -- just give back what we got
530 "glorious_success" is ours if we've found a suitable unfolding.
532 But we check for a couple of fine points.
534 (1) If this Id already has an inlining in the inline_env,
535 we don't automatically take it -- the earlier one is
536 "likely" to be better.
538 But if the new one doesn't mention any other global
539 Ids, and it's pretty small (< UnfoldingOverrideThreshold),
540 then we take the chance that the new one *is* better.
542 (2) If we have an Id w/ a worker/wrapper split (with
543 an unfolding for the wrapper), we tend to want to keep
544 it -- and *nuke* any inlining that we conjured up
547 But, again, if this unfolding doesn't mention any
548 other global Ids (and small enough), then it is
549 probably better than the worker/wrappery, so we take
552 glorious_success guidance
554 new_env = addOneToIdEnv inline_env binder (mkUnfolding guidance rhs)
556 foldr_building = switch_is_on FoldrBuildOn
558 if (not have_inlining_already) then
559 -- Not in env: we take it no matter what
560 -- NB: we could check for worker/wrapper-ness,
561 -- but the truth is we probably haven't run
562 -- the strictness analyser yet.
565 else if explicit_INLINE_requested then
566 -- If it was a user INLINE, then we know it's already
567 -- in the inline_env; we stick with what we already
569 --pprTrace "giving up on INLINE:" (ppr PprDebug binder)
572 else if isWrapperId binder then
573 -- It's in the env, but we have since worker-wrapperised;
574 -- we either take this new one (because it's so good),
575 -- or we *undo* the one in the inline_env, so the
576 -- wrapper-inlining will take over.
578 if mentions_no_other_ids {- *** && size <= unfold_override_threshold -} then
581 delOneFromIdEnv inline_env binder
584 -- It's in the env, nothing to do w/ worker wrapper;
585 -- we'll take it if it is better.
587 if not foldr_building -- ANDY hates us... (see below)
588 && mentions_no_other_ids
589 && guidance_size <= unfold_override_threshold then
592 --pprTrace "giving up on final hurdle:" (ppCat [ppr PprDebug binder, ppInt guidance_size, ppInt unfold_override_threshold])
593 ignominious_defeat -- and at the last hurdle, too!
596 ANDY, on the hatred of the check above; why obliterate it? Consider
598 head xs = foldr (\ x _ -> x) (_|_) xs
600 This then is exported via a pragma. However,
601 *if* you include the extra code above, you will
602 export the non-foldr/build version.