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, SYN_IE(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 * (,) -} )
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 SimplMonad ( zeroSimplCount, showSimplCount, SimplCount )
58 import SimplPgm ( simplifyPgm )
59 import SimplVar ( leastItCouldCost )
61 import SpecUtils ( pprSpecErrs )
62 import StrictAnal ( saWwTopBinds )
63 import TyVar ( nullTyVarEnv, GenTyVar{-instance Eq-} )
64 import Unique ( Unique{-instance Eq-} )
65 import UniqSupply ( splitUniqSupply )
66 import Util ( panic{-ToDo:rm-} )
69 import Deforest ( deforestProgram )
70 import DefUtils ( deforestable )
73 isWrapperFor = panic "SimplCore.isWrapperFor (ToDo)"
74 isWrapperId = panic "SimplCore.isWrapperId (ToDo)"
78 core2core :: [CoreToDo] -- spec of what core-to-core passes to do
79 -> FAST_STRING -- module name (profiling only)
80 -> PprStyle -- printing style (for debugging only)
81 -> UniqSupply -- a name supply
82 -> [TyCon] -- local data tycons and tycon specialisations
83 -> FiniteMap TyCon [(Bool, [Maybe Type])]
84 -> [CoreBinding] -- input...
86 ([CoreBinding], -- results: program, plus...
87 IdEnv UnfoldingDetails, -- unfoldings to be exported from here
88 SpecialiseData) -- specialisation data
90 core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
91 = if null core_todos then -- very rare, I suspect...
92 -- well, we still must do some renumbering
94 (substCoreBindings nullIdEnv nullTyVarEnv binds us,
99 (if do_verbose_core2core then
100 hPutStr stderr "VERBOSE CORE-TO-CORE:\n"
103 -- better do the main business
104 foldl_mn do_core_pass
105 (binds, us, nullIdEnv, init_specdata, zeroSimplCount)
107 >>= \ (processed_binds, _, inline_env, spec_data, simpl_stats) ->
109 (if opt_D_simplifier_stats
110 then hPutStr stderr ("\nSimplifier Stats:\n")
112 hPutStr stderr (showSimplCount simpl_stats)
118 return (processed_binds, inline_env, spec_data)
120 init_specdata = initSpecData local_tycons tycon_specs
122 do_verbose_core2core = opt_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 opt_UnfoldingOverrideThreshold of
127 Nothing -> 4 * uNFOLDING_USE_THRESHOLD
131 core_linter = if opt_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 -> _scc_ "CoreSimplify"
143 begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
144 then " (foldr/build)" else "") >>
145 case (simplifyPgm binds 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 "")
152 CoreDoFoldrBuildWorkerWrapper
153 -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
155 case (mkFoldrBuildWW us1 binds) of { binds2 ->
156 end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW" }
158 CoreDoFoldrBuildWWAnal
159 -> _scc_ "CoreDoFoldrBuildWWAnal"
160 begin_pass "AnalFBWW" >>
161 case (analFBWW binds) of { binds2 ->
162 end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW" }
165 -> _scc_ "LiberateCase"
166 begin_pass "LiberateCase" >>
167 case (liberateCase lib_case_threshold binds) of { binds2 ->
168 end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase" }
170 CoreDoCalcInlinings1 -- avoid inlinings w/ cost-centres
171 -> _scc_ "CoreInlinings1"
172 begin_pass "CalcInlinings" >>
173 case (calcInlinings False inline_env binds) of { inline_env2 ->
174 end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" }
176 CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres
177 -> _scc_ "CoreInlinings2"
178 begin_pass "CalcInlinings" >>
179 case (calcInlinings True inline_env binds) of { inline_env2 ->
180 end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" }
183 -> _scc_ "FloatInwards"
184 begin_pass "FloatIn" >>
185 case (floatInwards binds) of { binds2 ->
186 end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn" }
189 -> _scc_ "CoreFloating"
190 begin_pass "FloatOut" >>
191 case (floatOutwards us1 binds) of { binds2 ->
192 end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut" }
195 -> _scc_ "CoreStaticArgs"
196 begin_pass "StaticArgs" >>
197 case (doStaticArgs binds us1) of { binds2 ->
198 end_pass False us2 binds2 inline_env spec_data simpl_stats "StaticArgs" }
199 -- Binds really should be dependency-analysed for static-
200 -- arg transformation... Not to worry, they probably are.
201 -- (I don't think it *dies* if they aren't [WDP 94/04/15])
204 -> _scc_ "CoreStranal"
205 begin_pass "StrAnal" >>
206 case (saWwTopBinds us1 binds) of { binds2 ->
207 end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal" }
210 -> _scc_ "Specialise"
211 begin_pass "Specialise" >>
212 case (specProgram us1 binds spec_data) of {
213 (p, spec_data2@(SpecData _ spec_noerrs _ _ _
214 spec_errs spec_warn spec_tyerrs)) ->
216 -- if we got errors, we die straight away
217 (if not spec_noerrs ||
218 (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then
219 hPutStr stderr (ppShow 1000 {-pprCols-}
220 (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
221 >> hPutStr stderr "\n"
225 (if not spec_noerrs then -- Stop here if specialisation errors occured
230 end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise"
235 -> error "ERROR: CoreDoDeforest: not built into compiler\n"
237 -> _scc_ "Deforestation"
238 begin_pass "Deforestation" >>
239 case (deforestProgram binds us1) of { binds2 ->
240 end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation" }
243 CoreDoPrintCore -- print result of last pass
244 -> end_pass True us2 binds inline_env spec_data simpl_stats "Print"
246 -------------------------------------------------
249 = if opt_D_show_passes
250 then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n")
251 else \ what -> return ()
253 end_pass print us2 binds2 inline_env2
254 spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
256 = -- report verbosely, if required
257 (if (do_verbose_core2core && not print) ||
258 (print && not do_verbose_core2core)
260 hPutStr stderr ("\n*** "++what++":\n")
262 hPutStr stderr (ppShow 1000
263 (ppAboves (map (pprCoreBinding ppr_style) binds2)))
269 linted_binds = core_linter what spec_done binds2
272 (linted_binds, -- processed binds, possibly run thru CoreLint
273 us2, -- UniqueSupply for the next guy
274 inline_env2, -- possibly-updated inline env
275 spec_data2, -- possibly-updated specialisation info
276 simpl_stats2 -- accumulated simplifier stats
279 -- here so it can be inlined...
280 foldl_mn f z [] = return z
281 foldl_mn f z (x:xs) = f z x >>= \ zz ->
285 --- ToDo: maybe move elsewhere ---
287 For top-level, exported binders that either (a)~have been INLINEd by
288 the programmer or (b)~are sufficiently ``simple'' that they should be
289 inlined, we want to record this info in a suitable IdEnv.
291 But: if something has a ``wrapper unfolding,'' we do NOT automatically
292 give it a regular unfolding (exception below). We usually assume its
293 worker will get a ``regular'' unfolding. We can then treat these two
294 levels of unfolding separately (we tend to be very friendly towards
295 wrapper unfoldings, for example), giving more fine-tuned control.
297 The exception is: If the ``regular unfolding'' mentions no other
298 global Ids (i.e., it's all PrimOps and cases and local Ids) then we
299 assume it must be really good and we take it anyway.
301 We also need to check that everything in the RHS (values and types)
302 will be visible on the other side of an interface, too.
305 calcInlinings :: Bool -- True => inlinings with _scc_s are OK
306 -> IdEnv UnfoldingDetails
308 -> IdEnv UnfoldingDetails
310 calcInlinings scc_s_OK inline_env_so_far top_binds
312 result = foldl calci inline_env_so_far top_binds
314 --pprTrace "inline env:\n" (ppAboves (map pp_item (getIdEnvMapping result)))
317 pp_item (binder, details)
318 = ppCat [ppr PprDebug binder, ppStr "=>", pp_det details]
320 pp_det NoUnfoldingDetails = ppStr "_N_"
321 --LATER: pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
322 pp_det (GenForm _ expr guide)
323 = ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
324 pp_det other = ppStr "???"
327 my_trace = if opt_ReportWhyUnfoldingsDisallowed
329 else \ msg stuff -> stuff
331 (unfolding_creation_threshold, explicit_creation_threshold)
332 = case opt_UnfoldingCreationThreshold of
333 Nothing -> (uNFOLDING_CREATION_THRESHOLD, False)
334 Just xx -> (xx, True)
337 = case opt_UnfoldingUseThreshold of
338 Nothing -> uNFOLDING_USE_THRESHOLD
341 unfold_override_threshold
342 = case opt_UnfoldingOverrideThreshold of
343 Nothing -> uNFOLDING_OVERRIDE_THRESHOLD
346 con_discount_weight = uNFOLDING_CON_DISCOUNT_WEIGHT
348 calci inline_env (Rec pairs)
349 = foldl (calc True{-recursive-}) inline_env pairs
351 calci inline_env bind@(NonRec binder rhs)
352 = calc False{-not recursive-} inline_env (binder, rhs)
354 ---------------------------------------
356 calc is_recursive inline_env (binder, rhs)
357 | not (toplevelishId binder)
358 = --pprTrace "giving up on not top-level:" (ppr PprDebug binder)
361 | rhs_mentions_an_unmentionable
362 || (not explicit_INLINE_requested
363 && (rhs_looks_like_a_caf || guidance_says_don't || guidance_size_too_big))
366 = if explicit_INLINE_requested
367 && not (isWrapperId binder) -- these always claim to be INLINEd
368 && not have_inlining_already
369 then trace -- we'd better have a look...
372 which = if scc_s_OK then " (late):" else " (early):"
374 my_my_trace ("unfolding disallowed for"++which++(ppShow 80 (ppr PprDebug binder))) (
378 | rhs `isWrapperFor` binder
379 -- Don't add an explicit "unfolding"; let the worker/wrapper
380 -- stuff do its thing. INLINE things don't get w/w'd, so
384 #if ! OMIT_DEFORESTER
385 -- For the deforester: bypass the barbed wire for recursive
386 -- functions that want to be inlined and are tagged deforestable
387 -- by the user, allowing these things to be communicated
388 -- across module boundaries.
391 explicit_INLINE_requested &&
392 deforestable binder &&
393 scc_s_OK -- hack, only get them in
395 = glorious_success UnfoldAlways
398 | is_recursive && not rhs_looks_like_a_data_val
399 -- The only recursive defns we are prepared to tolerate at the
400 -- moment is top-level very-obviously-a-data-value ones.
401 -- We *need* these for dictionaries to be exported!
402 = --pprTrace "giving up on rec:" (ppr PprDebug binder)
405 -- Not really interested unless it's exported, but doing it
406 -- this way (not worrying about export-ness) gets us all the
407 -- workers/specs, etc., too; which we will need for generating
408 -- interfaces. We are also not interested if this binder is
409 -- in the environment we already have (perhaps from a previous
410 -- run of calcInlinings -- "earlier" is presumed to mean
413 | explicit_INLINE_requested
414 = glorious_success UnfoldAlways
417 = glorious_success guidance
421 = calcUnfoldingGuidance scc_s_OK max_out_threshold rhs
423 max_out_threshold = if explicit_INLINE_requested
424 then 100000 -- you asked for it, you got it
425 else unfolding_creation_threshold
429 UnfoldAlways -> 0 -- *extremely* small
430 EssentialUnfolding -> 0 -- ditto
431 UnfoldIfGoodArgs _ _ _ size -> size
433 guidance_says_don't = case guidance of { UnfoldNever -> True; _ -> False }
435 guidance_size_too_big
436 -- Does the guidance suggest that this unfolding will
437 -- be of no use *no matter* the arguments given to it?
438 -- Could be more sophisticated...
440 UnfoldAlways -> False
441 EssentialUnfolding -> False
442 UnfoldIfGoodArgs _ no_val_args arg_info_vec size
444 -> if explicit_creation_threshold then
445 False -- user set threshold; don't second-guess...
447 else if no_val_args == 0 && rhs_looks_like_a_data_val then
448 False -- we'd like a top-level data constr to be
449 -- visible even if it is never unfolded
453 = leastItCouldCost con_discount_weight size no_val_args
454 arg_info_vec rhs_arg_tys
456 -- (if (unfold_use_threshold < cost) then (pprTrace "cost:" (ppInt cost)) else \x->x ) (
457 unfold_use_threshold < cost
461 rhs_looks_like_a_caf = not (manifestlyWHNF rhs)
463 rhs_looks_like_a_data_val
464 = case (collectBinders rhs) of
465 (_, _, [], Con _ _) -> True
469 = case (collectBinders rhs) of
470 (_, _, val_binders, _) -> map idType val_binders
472 (mentioned_ids, _, _, mentions_litlit)
473 = mentionedInUnfolding (\x -> x) rhs
475 rhs_mentions_an_unmentionable
476 = foldBag (||) unfoldingUnfriendlyId False mentioned_ids
478 -- ToDo: probably need to chk tycons/classes...
480 mentions_no_other_ids = isEmptyBag mentioned_ids
482 explicit_INLINE_requested
483 -- did it come from a user {-# INLINE ... #-}?
484 -- (Warning: must avoid including wrappers.)
485 = idWantsToBeINLINEd binder
486 && not (rhs `isWrapperFor` binder)
488 have_inlining_already = maybeToBool (lookupIdEnv inline_env binder)
490 ignominious_defeat = inline_env -- just give back what we got
493 "glorious_success" is ours if we've found a suitable unfolding.
495 But we check for a couple of fine points.
497 (1) If this Id already has an inlining in the inline_env,
498 we don't automatically take it -- the earlier one is
499 "likely" to be better.
501 But if the new one doesn't mention any other global
502 Ids, and it's pretty small (< UnfoldingOverrideThreshold),
503 then we take the chance that the new one *is* better.
505 (2) If we have an Id w/ a worker/wrapper split (with
506 an unfolding for the wrapper), we tend to want to keep
507 it -- and *nuke* any inlining that we conjured up
510 But, again, if this unfolding doesn't mention any
511 other global Ids (and small enough), then it is
512 probably better than the worker/wrappery, so we take
515 glorious_success guidance
517 new_env = addOneToIdEnv inline_env binder (mkUnfolding guidance rhs)
519 foldr_building = opt_FoldrBuildOn
521 if (not have_inlining_already) then
522 -- Not in env: we take it no matter what
523 -- NB: we could check for worker/wrapper-ness,
524 -- but the truth is we probably haven't run
525 -- the strictness analyser yet.
528 else if explicit_INLINE_requested then
529 -- If it was a user INLINE, then we know it's already
530 -- in the inline_env; we stick with what we already
532 --pprTrace "giving up on INLINE:" (ppr PprDebug binder)
535 else if isWrapperId binder then
536 -- It's in the env, but we have since worker-wrapperised;
537 -- we either take this new one (because it's so good),
538 -- or we *undo* the one in the inline_env, so the
539 -- wrapper-inlining will take over.
541 if mentions_no_other_ids {- *** && size <= unfold_override_threshold -} then
544 delOneFromIdEnv inline_env binder
547 -- It's in the env, nothing to do w/ worker wrapper;
548 -- we'll take it if it is better.
550 if not foldr_building -- ANDY hates us... (see below)
551 && mentions_no_other_ids
552 && guidance_size <= unfold_override_threshold then
555 --pprTrace "giving up on final hurdle:" (ppCat [ppr PprDebug binder, ppInt guidance_size, ppInt unfold_override_threshold])
556 ignominious_defeat -- and at the last hurdle, too!
559 ANDY, on the hatred of the check above; why obliterate it? Consider
561 head xs = foldr (\ x _ -> x) (_|_) xs
563 This then is exported via a pragma. However,
564 *if* you include the extra code above, you will
565 export the non-foldr/build version.