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 FloatIn ( floatInwards )
38 import FloatOut ( floatOutwards )
39 import FoldrBuildWW ( mkFoldrBuildWW )
40 import Id ( idType, toplevelishId, idWantsToBeINLINEd,
41 unfoldingUnfriendlyId,
42 nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
43 lookupIdEnv, IdEnv(..),
44 GenId{-instance Outputable-}
46 import IdInfo ( mkUnfolding )
47 import LiberateCase ( liberateCase )
48 import MagicUFs ( MagicUnfoldingFun )
49 import MainMonad ( writeMn, exitMn, thenMn, thenMn_, returnMn,
52 import Maybes ( maybeToBool )
53 import Outputable ( Outputable(..){-instance * (,) -} )
54 import PprCore ( pprCoreBinding, GenCoreExpr{-instance Outputable-} )
55 import PprStyle ( PprStyle(..) )
56 import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
57 import Pretty ( ppShow, ppAboves, ppAbove, ppCat, ppStr )
58 import SAT ( doStaticArgs )
59 import SCCauto ( addAutoCostCentres )
60 import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount )
61 import SimplPgm ( simplifyPgm )
62 import SimplVar ( leastItCouldCost )
64 import SpecUtils ( pprSpecErrs )
65 import StrictAnal ( saWwTopBinds )
66 import TyVar ( nullTyVarEnv, GenTyVar{-instance Eq-} )
67 import Unique ( Unique{-instance Eq-} )
68 import UniqSupply ( splitUniqSupply )
69 import Util ( panic{-ToDo:rm-} )
72 import Deforest ( deforestProgram )
73 import DefUtils ( deforestable )
76 isWrapperFor = panic "SimplCore.isWrapperFor (ToDo)"
77 isWrapperId = panic "SimplCore.isWrapperId (ToDo)"
81 core2core :: [CoreToDo] -- spec of what core-to-core passes to do
82 -> FAST_STRING -- module name (profiling only)
83 -> PprStyle -- printing style (for debugging only)
84 -> UniqSupply -- a name supply
85 -> [TyCon] -- local data tycons and tycon specialisations
86 -> FiniteMap TyCon [(Bool, [Maybe Type])]
87 -> [CoreBinding] -- input...
89 ([CoreBinding], -- results: program, plus...
90 IdEnv UnfoldingDetails, -- unfoldings to be exported from here
91 SpecialiseData) -- specialisation data
93 core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
95 if null core_todos then -- very rare, I suspect...
96 -- well, we still must do some renumbering
98 (substCoreBindings nullIdEnv nullTyVarEnv binds us,
103 (if do_verbose_core2core then
104 writeMn stderr "VERBOSE CORE-TO-CORE:\n"
105 else returnMn ()) `thenMn_`
107 -- better do the main business
108 foldl_mn do_core_pass
109 (binds, us, nullIdEnv, init_specdata, zeroSimplCount)
111 `thenMn` \ (processed_binds, _, inline_env, spec_data, simpl_stats) ->
113 (if opt_D_simplifier_stats
114 then writeMn stderr ("\nSimplifier Stats:\n")
116 writeMn stderr (showSimplCount simpl_stats)
122 returnMn (processed_binds, inline_env, spec_data)
125 init_specdata = initSpecData local_tycons tycon_specs
127 do_verbose_core2core = opt_D_verbose_core2core
129 lib_case_threshold -- ToDo: HACK HACK HACK : FIX ME FIX ME FIX ME
130 -- Use 4x a known threshold
131 = case opt_UnfoldingOverrideThreshold of
132 Nothing -> 4 * uNFOLDING_USE_THRESHOLD
136 core_linter = if opt_DoCoreLinting
137 then lintCoreBindings ppr_style
138 else ( \ whodunnit spec_done binds -> binds )
141 do_core_pass info@(binds, us, inline_env, spec_data, simpl_stats) to_do
143 (us1, us2) = splitUniqSupply us
146 CoreDoSimplify simpl_sw_chkr
147 -> BSCC("CoreSimplify")
148 begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
149 then " (foldr/build)" else "") `thenMn_`
150 case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
151 (p, it_cnt, simpl_stats2)
152 -> end_pass False us2 p inline_env spec_data simpl_stats2
153 ("Simplify (" ++ show it_cnt ++ ")"
154 ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
155 then " foldr/build" else "")
158 CoreDoFoldrBuildWorkerWrapper
159 -> BSCC("CoreDoFoldrBuildWorkerWrapper")
160 begin_pass "FBWW" `thenMn_`
161 case (mkFoldrBuildWW us1 binds) of { binds2 ->
162 end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW"
165 CoreDoFoldrBuildWWAnal
166 -> BSCC("CoreDoFoldrBuildWWAnal")
167 begin_pass "AnalFBWW" `thenMn_`
168 case (analFBWW binds) of { binds2 ->
169 end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW"
173 -> BSCC("LiberateCase")
174 begin_pass "LiberateCase" `thenMn_`
175 case (liberateCase lib_case_threshold binds) of { binds2 ->
176 end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase"
179 CoreDoCalcInlinings1 -- avoid inlinings w/ cost-centres
180 -> BSCC("CoreInlinings1")
181 begin_pass "CalcInlinings" `thenMn_`
182 case (calcInlinings False inline_env binds) of { inline_env2 ->
183 end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings"
186 CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres
187 -> BSCC("CoreInlinings2")
188 begin_pass "CalcInlinings" `thenMn_`
189 case (calcInlinings True inline_env binds) of { inline_env2 ->
190 end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings"
194 -> BSCC("FloatInwards")
195 begin_pass "FloatIn" `thenMn_`
196 case (floatInwards binds) of { binds2 ->
197 end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn"
201 -> BSCC("CoreFloating")
202 begin_pass "FloatOut" `thenMn_`
203 case (floatOutwards us1 binds) of { binds2 ->
204 end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut"
208 -> BSCC("CoreStaticArgs")
209 begin_pass "StaticArgs" `thenMn_`
210 case (doStaticArgs binds us1) of { binds2 ->
211 end_pass False us2 binds2 inline_env spec_data simpl_stats "StaticArgs"
212 -- Binds really should be dependency-analysed for static-
213 -- arg transformation... Not to worry, they probably are.
214 -- (I don't think it *dies* if they aren't [WDP 94/04/15])
218 -> BSCC("CoreStranal")
219 begin_pass "StrAnal" `thenMn_`
220 case (saWwTopBinds us1 binds) of { binds2 ->
221 end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal"
225 -> BSCC("Specialise")
226 begin_pass "Specialise" `thenMn_`
227 case (specProgram us1 binds spec_data) of {
228 (p, spec_data2@(SpecData _ spec_noerrs _ _ _
229 spec_errs spec_warn spec_tyerrs)) ->
231 -- if we got errors, we die straight away
232 (if not spec_noerrs ||
233 (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then
234 writeMn stderr (ppShow 1000 {-pprCols-}
235 (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
236 `thenMn_` writeMn stderr "\n"
238 returnMn ()) `thenMn_`
240 (if not spec_noerrs then -- Stop here if specialisation errors occured
243 returnMn ()) `thenMn_`
245 end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise"
251 -> error "ERROR: CoreDoDeforest: not built into compiler\n"
253 -> BSCC("Deforestation")
254 begin_pass "Deforestation" `thenMn_`
255 case (deforestProgram binds us1) of { binds2 ->
256 end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation"
261 CoreDoAutoCostCentres
263 begin_pass "AutoSCCs" `thenMn_`
264 case (addAutoCostCentres module_name binds) of { binds2 ->
265 end_pass False us2 binds2 inline_env spec_data simpl_stats "AutoSCCs"
269 CoreDoPrintCore -- print result of last pass
270 -> end_pass True us2 binds inline_env spec_data simpl_stats "Print"
273 -------------------------------------------------
276 = if opt_D_show_passes
277 then \ what -> writeMn stderr ("*** Core2Core: "++what++"\n")
278 else \ what -> returnMn ()
280 end_pass print us2 binds2 inline_env2
281 spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
283 = -- report verbosely, if required
284 (if (do_verbose_core2core && not print) ||
285 (print && not do_verbose_core2core)
287 writeMn stderr ("\n*** "++what++":\n")
289 writeMn stderr (ppShow 1000
290 (ppAboves (map (pprCoreBinding ppr_style) binds2)))
294 returnMn ()) `thenMn_`
296 linted_binds = core_linter what spec_done binds2
299 (linted_binds, -- processed binds, possibly run thru CoreLint
300 us2, -- UniqueSupply for the next guy
301 inline_env2, -- possibly-updated inline env
302 spec_data2, -- possibly-updated specialisation info
303 simpl_stats2 -- accumulated simplifier stats
306 -- here so it can be inlined...
307 foldl_mn f z [] = returnMn z
308 foldl_mn f z (x:xs) = f z x `thenMn` \ zz ->
312 --- ToDo: maybe move elsewhere ---
314 For top-level, exported binders that either (a)~have been INLINEd by
315 the programmer or (b)~are sufficiently ``simple'' that they should be
316 inlined, we want to record this info in a suitable IdEnv.
318 But: if something has a ``wrapper unfolding,'' we do NOT automatically
319 give it a regular unfolding (exception below). We usually assume its
320 worker will get a ``regular'' unfolding. We can then treat these two
321 levels of unfolding separately (we tend to be very friendly towards
322 wrapper unfoldings, for example), giving more fine-tuned control.
324 The exception is: If the ``regular unfolding'' mentions no other
325 global Ids (i.e., it's all PrimOps and cases and local Ids) then we
326 assume it must be really good and we take it anyway.
328 We also need to check that everything in the RHS (values and types)
329 will be visible on the other side of an interface, too.
332 calcInlinings :: Bool -- True => inlinings with _scc_s are OK
333 -> IdEnv UnfoldingDetails
335 -> IdEnv UnfoldingDetails
337 calcInlinings scc_s_OK inline_env_so_far top_binds
339 result = foldl calci inline_env_so_far top_binds
341 --pprTrace "inline env:\n" (ppAboves (map pp_item (getIdEnvMapping result)))
344 pp_item (binder, details)
345 = ppCat [ppr PprDebug binder, ppStr "=>", pp_det details]
347 pp_det NoUnfoldingDetails = ppStr "_N_"
348 --LATER: pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
349 pp_det (GenForm _ _ expr guide)
350 = ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
351 pp_det other = ppStr "???"
354 my_trace = if opt_ReportWhyUnfoldingsDisallowed
356 else \ msg stuff -> stuff
358 (unfolding_creation_threshold, explicit_creation_threshold)
359 = case opt_UnfoldingCreationThreshold of
360 Nothing -> (uNFOLDING_CREATION_THRESHOLD, False)
361 Just xx -> (xx, True)
364 = case opt_UnfoldingUseThreshold of
365 Nothing -> uNFOLDING_USE_THRESHOLD
368 unfold_override_threshold
369 = case opt_UnfoldingOverrideThreshold of
370 Nothing -> uNFOLDING_OVERRIDE_THRESHOLD
373 con_discount_weight = uNFOLDING_CON_DISCOUNT_WEIGHT
375 calci inline_env (Rec pairs)
376 = foldl (calc True{-recursive-}) inline_env pairs
378 calci inline_env bind@(NonRec 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 && (rhs_looks_like_a_caf || guidance_says_don't || guidance_size_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 my_my_trace ("unfolding disallowed for"++which++(ppShow 80 (ppr PprDebug binder))) (
405 | rhs `isWrapperFor` binder
406 -- Don't add an explicit "unfolding"; let the worker/wrapper
407 -- stuff do its thing. INLINE things don't get w/w'd, so
411 #if ! OMIT_DEFORESTER
412 -- For the deforester: bypass the barbed wire for recursive
413 -- functions that want to be inlined and are tagged deforestable
414 -- by the user, allowing these things to be communicated
415 -- across module boundaries.
418 explicit_INLINE_requested &&
419 deforestable binder &&
420 scc_s_OK -- hack, only get them in
422 = glorious_success UnfoldAlways
425 | is_recursive && not rhs_looks_like_a_data_val
426 -- The only recursive defns we are prepared to tolerate at the
427 -- moment is top-level very-obviously-a-data-value ones.
428 -- We *need* these for dictionaries to be exported!
429 = --pprTrace "giving up on rec:" (ppr PprDebug binder)
432 -- Not really interested unless it's exported, but doing it
433 -- this way (not worrying about export-ness) gets us all the
434 -- workers/specs, etc., too; which we will need for generating
435 -- interfaces. We are also not interested if this binder is
436 -- in the environment we already have (perhaps from a previous
437 -- run of calcInlinings -- "earlier" is presumed to mean
440 | explicit_INLINE_requested
441 = glorious_success UnfoldAlways
444 = glorious_success guidance
448 = calcUnfoldingGuidance scc_s_OK max_out_threshold rhs
450 max_out_threshold = if explicit_INLINE_requested
451 then 100000 -- you asked for it, you got it
452 else unfolding_creation_threshold
456 UnfoldAlways -> 0 -- *extremely* small
457 EssentialUnfolding -> 0 -- ditto
458 UnfoldIfGoodArgs _ _ _ size -> size
460 guidance_says_don't = case guidance of { UnfoldNever -> True; _ -> False }
462 guidance_size_too_big
463 -- Does the guidance suggest that this unfolding will
464 -- be of no use *no matter* the arguments given to it?
465 -- Could be more sophisticated...
467 UnfoldAlways -> False
468 EssentialUnfolding -> False
469 UnfoldIfGoodArgs _ no_val_args arg_info_vec size
471 -> if explicit_creation_threshold then
472 False -- user set threshold; don't second-guess...
474 else if no_val_args == 0 && rhs_looks_like_a_data_val then
475 False -- we'd like a top-level data constr to be
476 -- visible even if it is never unfolded
480 = leastItCouldCost con_discount_weight size no_val_args
481 arg_info_vec rhs_arg_tys
483 -- (if (unfold_use_threshold < cost) then (pprTrace "cost:" (ppInt cost)) else \x->x ) (
484 unfold_use_threshold < cost
488 rhs_looks_like_a_caf = not (manifestlyWHNF rhs)
490 rhs_looks_like_a_data_val
491 = case (collectBinders rhs) of
492 (_, _, [], Con _ _) -> True
496 = case (collectBinders rhs) of
497 (_, _, val_binders, _) -> map idType val_binders
499 (mentioned_ids, _, _, mentions_litlit)
500 = mentionedInUnfolding (\x -> x) rhs
502 rhs_mentions_an_unmentionable
503 = foldBag (||) unfoldingUnfriendlyId False mentioned_ids
505 -- ToDo: probably need to chk tycons/classes...
507 mentions_no_other_ids = isEmptyBag mentioned_ids
509 explicit_INLINE_requested
510 -- did it come from a user {-# INLINE ... #-}?
511 -- (Warning: must avoid including wrappers.)
512 = idWantsToBeINLINEd binder
513 && not (rhs `isWrapperFor` binder)
515 have_inlining_already = maybeToBool (lookupIdEnv inline_env binder)
517 ignominious_defeat = inline_env -- just give back what we got
520 "glorious_success" is ours if we've found a suitable unfolding.
522 But we check for a couple of fine points.
524 (1) If this Id already has an inlining in the inline_env,
525 we don't automatically take it -- the earlier one is
526 "likely" to be better.
528 But if the new one doesn't mention any other global
529 Ids, and it's pretty small (< UnfoldingOverrideThreshold),
530 then we take the chance that the new one *is* better.
532 (2) If we have an Id w/ a worker/wrapper split (with
533 an unfolding for the wrapper), we tend to want to keep
534 it -- and *nuke* any inlining that we conjured up
537 But, again, if this unfolding doesn't mention any
538 other global Ids (and small enough), then it is
539 probably better than the worker/wrappery, so we take
542 glorious_success guidance
544 new_env = addOneToIdEnv inline_env binder (mkUnfolding guidance rhs)
546 foldr_building = opt_FoldrBuildOn
548 if (not have_inlining_already) then
549 -- Not in env: we take it no matter what
550 -- NB: we could check for worker/wrapper-ness,
551 -- but the truth is we probably haven't run
552 -- the strictness analyser yet.
555 else if explicit_INLINE_requested then
556 -- If it was a user INLINE, then we know it's already
557 -- in the inline_env; we stick with what we already
559 --pprTrace "giving up on INLINE:" (ppr PprDebug binder)
562 else if isWrapperId binder then
563 -- It's in the env, but we have since worker-wrapperised;
564 -- we either take this new one (because it's so good),
565 -- or we *undo* the one in the inline_env, so the
566 -- wrapper-inlining will take over.
568 if mentions_no_other_ids {- *** && size <= unfold_override_threshold -} then
571 delOneFromIdEnv inline_env binder
574 -- It's in the env, nothing to do w/ worker wrapper;
575 -- we'll take it if it is better.
577 if not foldr_building -- ANDY hates us... (see below)
578 && mentions_no_other_ids
579 && guidance_size <= unfold_override_threshold then
582 --pprTrace "giving up on final hurdle:" (ppCat [ppr PprDebug binder, ppInt guidance_size, ppInt unfold_override_threshold])
583 ignominious_defeat -- and at the last hurdle, too!
586 ANDY, on the hatred of the check above; why obliterate it? Consider
588 head xs = foldr (\ x _ -> x) (_|_) xs
590 This then is exported via a pragma. However,
591 *if* you include the extra code above, you will
592 export the non-foldr/build version.