ghc/compiler/simplCore/SimplCore.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[SimplCore]{Driver for simplifying @Core@ programs}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module SimplCore ( core2core ) where
  10
  11 IMP_Ubiq(){-uitous-}
  12 IMPORT_1_3(IO(hPutStr,stderr))
  13
  14 import AnalFBWW         ( analFBWW )
  15 import Bag              ( isEmptyBag, foldBag )
  16 import BinderInfo       ( BinderInfo{-instance Outputable-} )
  17 import CgCompInfo       ( uNFOLDING_CREATION_THRESHOLD,
  18                           uNFOLDING_USE_THRESHOLD,
  19                           uNFOLDING_OVERRIDE_THRESHOLD,
  20                           uNFOLDING_CON_DISCOUNT_WEIGHT
  21                         )
  22 import CmdLineOpts      ( CoreToDo(..), SimplifierSwitch(..), switchIsOn,
  23                           opt_D_show_passes,
  24                           opt_D_simplifier_stats,
  25                           opt_D_verbose_core2core,
  26                           opt_DoCoreLinting,
  27                           opt_FoldrBuildOn,
  28                           opt_ReportWhyUnfoldingsDisallowed,
  29                           opt_ShowImportSpecs,
  30                           opt_UnfoldingCreationThreshold,
  31                           opt_UnfoldingOverrideThreshold,
  32                           opt_UnfoldingUseThreshold
  33                         )
  34 import CoreLint         ( lintCoreBindings )
  35 import CoreSyn
  36 import CoreUnfold
  37 import CoreUtils        ( substCoreBindings, whnfOrBottom )
  38 import ErrUtils         ( ghcExit )
  39 import FiniteMap        ( FiniteMap )
  40 import FloatIn          ( floatInwards )
  41 import FloatOut         ( floatOutwards )
  42 import FoldrBuildWW     ( mkFoldrBuildWW )
  43 import Id               ( idType, toplevelishId, idWantsToBeINLINEd,
  44                           unfoldingUnfriendlyId,
  45                           nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
  46                           lookupIdEnv, SYN_IE(IdEnv),
  47                           GenId{-instance Outputable-}
  48                         )
  49 import IdInfo           ( mkUnfolding )
  50 import LiberateCase     ( liberateCase )
  51 import MagicUFs         ( MagicUnfoldingFun )
  52 import Maybes           ( maybeToBool )
  53 import Outputable       ( Outputable(..){-instance * (,) -} )
  54 import PprCore
  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 SimplMonad       ( zeroSimplCount, showSimplCount, SimplCount )
  60 import SimplPgm         ( simplifyPgm )
  61 import Specialise
  62 import SpecUtils        ( pprSpecErrs )
  63 import StrictAnal       ( saWwTopBinds )
  64 import TyVar            ( nullTyVarEnv, GenTyVar{-instance Eq-} )
  65 import Unique           ( Unique{-instance Eq-} )
  66 import UniqSupply       ( splitUniqSupply )
  67 import Util             ( panic{-ToDo:rm-} )
  68
  69 #if ! OMIT_DEFORESTER
  70 import Deforest         ( deforestProgram )
  71 import DefUtils         ( deforestable )
  72 #endif
  73
  74 isWrapperFor = panic "SimplCore.isWrapperFor (ToDo)"
  75 isWrapperId = panic "SimplCore.isWrapperId (ToDo)"
  76 \end{code}
  77
  78 \begin{code}
  79 core2core :: [CoreToDo]                 -- spec of what core-to-core passes to do
  80           -> FAST_STRING                -- module name (profiling only)
  81           -> PprStyle                   -- printing style (for debugging only)
  82           -> UniqSupply         -- a name supply
  83           -> [TyCon]                    -- local data tycons and tycon specialisations
  84           -> FiniteMap TyCon [(Bool, [Maybe Type])]
  85           -> [CoreBinding]              -- input...
  86           -> IO
  87               ([CoreBinding],   -- results: program, plus...
  88                IdEnv Unfolding, --  unfoldings to be exported from here
  89               SpecialiseData)           --  specialisation data
  90
  91 core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
  92   = if null core_todos then -- very rare, I suspect...
  93         -- well, we still must do some renumbering
  94         return (
  95         (substCoreBindings nullIdEnv nullTyVarEnv binds us,
  96          nullIdEnv,
  97          init_specdata)
  98         )
  99     else
 100         (if do_verbose_core2core then
 101             hPutStr stderr "VERBOSE CORE-TO-CORE:\n"
 102          else return ()) >>
 103
 104         -- better do the main business
 105         foldl_mn do_core_pass
 106                 (binds, us, nullIdEnv, init_specdata, zeroSimplCount)
 107                 core_todos
 108                 >>= \ (processed_binds, _, inline_env, spec_data, simpl_stats) ->
 109
 110         (if  opt_D_simplifier_stats
 111          then hPutStr stderr ("\nSimplifier Stats:\n")
 112                 >>
 113               hPutStr stderr (showSimplCount simpl_stats)
 114                 >>
 115               hPutStr stderr "\n"
 116          else return ()
 117         ) >>
 118
 119         return (processed_binds, inline_env, spec_data)
 120   where
 121     init_specdata = initSpecData local_tycons tycon_specs
 122
 123     do_verbose_core2core = opt_D_verbose_core2core
 124
 125     lib_case_threshold  -- ToDo: HACK HACK HACK : FIX ME FIX ME FIX ME
 126                         -- Use 4x a known threshold
 127       = case opt_UnfoldingOverrideThreshold of
 128           Nothing -> 4 * uNFOLDING_USE_THRESHOLD
 129           Just xx -> 4 * xx
 130
 131     -------------
 132     core_linter = if opt_DoCoreLinting
 133                   then lintCoreBindings ppr_style
 134                   else ( \ whodunnit spec_done binds -> binds )
 135
 136     --------------
 137     do_core_pass info@(binds, us, inline_env, spec_data, simpl_stats) to_do
 138       = let
 139             (us1, us2) = splitUniqSupply us
 140         in
 141         case to_do of
 142           CoreDoSimplify simpl_sw_chkr
 143             -> _scc_ "CoreSimplify"
 144                begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
 145                                          then " (foldr/build)" else "") >>
 146                case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
 147                  (p, it_cnt, simpl_stats2)
 148                    -> end_pass False us2 p inline_env spec_data simpl_stats2
 149                                ("Simplify (" ++ show it_cnt ++ ")"
 150                                  ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
 151                                     then " foldr/build" else "")
 152
 153           CoreDoFoldrBuildWorkerWrapper
 154             -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
 155                begin_pass "FBWW" >>
 156                case (mkFoldrBuildWW us1 binds) of { binds2 ->
 157                end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW" }
 158
 159           CoreDoFoldrBuildWWAnal
 160             -> _scc_ "CoreDoFoldrBuildWWAnal"
 161                begin_pass "AnalFBWW" >>
 162                case (analFBWW binds) of { binds2 ->
 163                end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW" }
 164
 165           CoreLiberateCase
 166             -> _scc_ "LiberateCase"
 167                begin_pass "LiberateCase" >>
 168                case (liberateCase lib_case_threshold binds) of { binds2 ->
 169                end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase" }
 170
 171           CoreDoCalcInlinings1  -- avoid inlinings w/ cost-centres
 172             -> _scc_ "CoreInlinings1"
 173                begin_pass "CalcInlinings" >>
 174                case (calcInlinings False inline_env binds) of { inline_env2 ->
 175                end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" }
 176
 177           CoreDoCalcInlinings2  -- allow inlinings w/ cost-centres
 178             -> _scc_ "CoreInlinings2"
 179                begin_pass "CalcInlinings" >>
 180                case (calcInlinings True inline_env binds) of { inline_env2 ->
 181                end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" }
 182
 183           CoreDoFloatInwards
 184             -> _scc_ "FloatInwards"
 185                begin_pass "FloatIn" >>
 186                case (floatInwards binds) of { binds2 ->
 187                end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn" }
 188
 189           CoreDoFullLaziness
 190             -> _scc_ "CoreFloating"
 191                begin_pass "FloatOut" >>
 192                case (floatOutwards us1 binds) of { binds2 ->
 193                end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut" }
 194
 195           CoreDoStaticArgs
 196             -> _scc_ "CoreStaticArgs"
 197                begin_pass "StaticArgs" >>
 198                case (doStaticArgs binds us1) of { binds2 ->
 199                end_pass False us2 binds2 inline_env spec_data simpl_stats "StaticArgs" }
 200                 -- Binds really should be dependency-analysed for static-
 201                 -- arg transformation... Not to worry, they probably are.
 202                 -- (I don't think it *dies* if they aren't [WDP 94/04/15])
 203
 204           CoreDoStrictness
 205             -> _scc_ "CoreStranal"
 206                begin_pass "StrAnal" >>
 207                case (saWwTopBinds us1 binds) of { binds2 ->
 208                end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal" }
 209
 210           CoreDoSpecialising
 211             -> _scc_ "Specialise"
 212                begin_pass "Specialise" >>
 213                case (specProgram us1 binds spec_data) of {
 214                  (p, spec_data2@(SpecData _ spec_noerrs _ _ _
 215                                           spec_errs spec_warn spec_tyerrs)) ->
 216
 217                    -- if we got errors, we die straight away
 218                    (if not spec_noerrs ||
 219                        (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then
 220                         hPutStr stderr (ppShow 1000 {-pprCols-}
 221                             (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
 222                         >> hPutStr stderr "\n"
 223                     else
 224                         return ()) >>
 225
 226                    (if not spec_noerrs then -- Stop here if specialisation errors occured
 227                         ghcExit 1
 228                    else
 229                         return ()) >>
 230
 231                    end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise"
 232                }
 233
 234           CoreDoDeforest
 235 #if OMIT_DEFORESTER
 236             -> error "ERROR: CoreDoDeforest: not built into compiler\n"
 237 #else
 238             -> _scc_ "Deforestation"
 239                begin_pass "Deforestation" >>
 240                case (deforestProgram binds us1) of { binds2 ->
 241                end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation" }
 242 #endif
 243
 244           CoreDoPrintCore       -- print result of last pass
 245             -> end_pass True us2 binds inline_env spec_data simpl_stats "Print"
 246
 247     -------------------------------------------------
 248
 249     begin_pass
 250       = if opt_D_show_passes
 251         then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n")
 252         else \ what -> return ()
 253
 254     end_pass print us2 binds2 inline_env2
 255              spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
 256              simpl_stats2 what
 257       = -- report verbosely, if required
 258         (if (do_verbose_core2core && not print) ||
 259             (print && not do_verbose_core2core)
 260          then
 261             hPutStr stderr ("\n*** "++what++":\n")
 262                 >>
 263             hPutStr stderr (ppShow 1000
 264                 (ppAboves (map (pprCoreBinding ppr_style) binds2)))
 265                 >>
 266             hPutStr stderr "\n"
 267          else
 268             return ()) >>
 269         let
 270             linted_binds = core_linter what spec_done binds2
 271         in
 272         return
 273         (linted_binds,  -- processed binds, possibly run thru CoreLint
 274          us2,           -- UniqueSupply for the next guy
 275          inline_env2,   -- possibly-updated inline env
 276          spec_data2,    -- possibly-updated specialisation info
 277          simpl_stats2   -- accumulated simplifier stats
 278         )
 279
 280 -- here so it can be inlined...
 281 foldl_mn f z []     = return z
 282 foldl_mn f z (x:xs) = f z x     >>= \ zz ->
 283                      foldl_mn f zz xs
 284 \end{code}
 285
 286 --- ToDo: maybe move elsewhere ---
 287
 288 For top-level, exported binders that either (a)~have been INLINEd by
 289 the programmer or (b)~are sufficiently ``simple'' that they should be
 290 inlined, we want to record this info in a suitable IdEnv.
 291
 292 But: if something has a ``wrapper unfolding,'' we do NOT automatically
 293 give it a regular unfolding (exception below).  We usually assume its
 294 worker will get a ``regular'' unfolding.  We can then treat these two
 295 levels of unfolding separately (we tend to be very friendly towards
 296 wrapper unfoldings, for example), giving more fine-tuned control.
 297
 298 The exception is: If the ``regular unfolding'' mentions no other
 299 global Ids (i.e., it's all PrimOps and cases and local Ids) then we
 300 assume it must be really good and we take it anyway.
 301
 302 We also need to check that everything in the RHS (values and types)
 303 will be visible on the other side of an interface, too.
 304
 305 \begin{code}
 306 calcInlinings :: Bool   -- True => inlinings with _scc_s are OK
 307               -> IdEnv Unfolding
 308               -> [CoreBinding]
 309               -> IdEnv Unfolding
 310
 311 calcInlinings scc_s_OK inline_env_so_far top_binds
 312   = let
 313         result = foldl calci inline_env_so_far top_binds
 314     in
 315     --pprTrace "inline env:\n" (ppAboves (map pp_item (getIdEnvMapping result)))
 316     result
 317   where
 318     pp_item (binder, details)
 319       = ppCat [ppr PprDebug binder, ppStr "=>", pp_det details]
 320       where
 321         pp_det NoUnfolding   = ppStr "_N_"
 322 --LATER:        pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
 323         pp_det (CoreUnfolding (SimpleUnfolding _ guide expr))
 324           = ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
 325         pp_det other                = ppStr "???"
 326
 327     ------------
 328     my_trace =  if opt_ReportWhyUnfoldingsDisallowed
 329                 then trace
 330                 else \ msg stuff -> stuff
 331
 332     (unfolding_creation_threshold, explicit_creation_threshold)
 333       = case opt_UnfoldingCreationThreshold of
 334           Nothing -> (uNFOLDING_CREATION_THRESHOLD, False)
 335           Just xx -> (xx, True)
 336
 337     unfold_use_threshold
 338       = case opt_UnfoldingUseThreshold of
 339           Nothing -> uNFOLDING_USE_THRESHOLD
 340           Just xx -> xx
 341
 342     unfold_override_threshold
 343       = case opt_UnfoldingOverrideThreshold of
 344           Nothing -> uNFOLDING_OVERRIDE_THRESHOLD
 345           Just xx -> xx
 346
 347     con_discount_weight = uNFOLDING_CON_DISCOUNT_WEIGHT
 348
 349     calci inline_env (Rec pairs)
 350       = foldl (calc True{-recursive-}) inline_env pairs
 351
 352     calci inline_env bind@(NonRec binder rhs)
 353       = calc False{-not recursive-} inline_env (binder, rhs)
 354
 355     ---------------------------------------
 356
 357     calc is_recursive inline_env (binder, rhs)
 358       | not (toplevelishId binder)
 359       = --pprTrace "giving up on not top-level:" (ppr PprDebug binder)
 360         ignominious_defeat
 361
 362       | rhs_mentions_an_unmentionable
 363       || (not explicit_INLINE_requested
 364           && (rhs_looks_like_a_caf || guidance_size_too_big))
 365       = let
 366             my_my_trace
 367               = if explicit_INLINE_requested
 368                 && not (isWrapperId binder) -- these always claim to be INLINEd
 369                 && not have_inlining_already
 370                 then trace                  -- we'd better have a look...
 371                 else my_trace
 372
 373             which = if scc_s_OK then " (late):" else " (early):"
 374         in
 375         my_my_trace ("unfolding disallowed for"++which++(ppShow 80 (ppr PprDebug binder))) (
 376         ignominious_defeat
 377         )
 378
 379       | rhs `isWrapperFor` binder
 380         -- Don't add an explicit "unfolding"; let the worker/wrapper
 381         -- stuff do its thing.  INLINE things don't get w/w'd, so
 382         -- they will be OK.
 383       = ignominious_defeat
 384
 385 #if ! OMIT_DEFORESTER
 386         -- For the deforester: bypass the barbed wire for recursive
 387         -- functions that want to be inlined and are tagged deforestable
 388         -- by the user, allowing these things to be communicated
 389         -- across module boundaries.
 390
 391       | is_recursive &&
 392         explicit_INLINE_requested &&
 393         deforestable binder &&
 394         scc_s_OK                        -- hack, only get them in
 395                                         -- calc_inlinings2
 396       = glorious_success UnfoldAlways
 397 #endif
 398
 399       | is_recursive && not rhs_looks_like_a_data_val
 400         -- The only recursive defns we are prepared to tolerate at the
 401         -- moment is top-level very-obviously-a-data-value ones.
 402         -- We *need* these for dictionaries to be exported!
 403       = --pprTrace "giving up on rec:" (ppr PprDebug binder)
 404         ignominious_defeat
 405
 406         -- Not really interested unless it's exported, but doing it
 407         -- this way (not worrying about export-ness) gets us all the
 408         -- workers/specs, etc., too; which we will need for generating
 409         -- interfaces.  We are also not interested if this binder is
 410         -- in the environment we already have (perhaps from a previous
 411         -- run of calcInlinings -- "earlier" is presumed to mean
 412         -- "better").
 413
 414       | explicit_INLINE_requested
 415       = glorious_success UnfoldAlways
 416
 417       | otherwise
 418       = glorious_success guidance
 419
 420       where
 421         guidance
 422           = calcUnfoldingGuidance scc_s_OK max_out_threshold rhs
 423           where
 424             max_out_threshold = if explicit_INLINE_requested
 425                                 then 100000 -- you asked for it, you got it
 426                                 else unfolding_creation_threshold
 427
 428         guidance_size
 429           = case guidance of
 430               UnfoldAlways                -> 0 -- *extremely* small
 431               UnfoldIfGoodArgs _ _ _ size -> size
 432
 433         guidance_size_too_big
 434             -- Does the guidance suggest that this unfolding will
 435             -- be of no use *no matter* the arguments given to it?
 436             -- Could be more sophisticated...
 437           = not (couldBeSmallEnoughToInline con_discount_weight unfold_use_threshold guidance)
 438
 439
 440         rhs_looks_like_a_caf = not (whnfOrBottom rhs)
 441
 442         rhs_looks_like_a_data_val
 443           = case (collectBinders rhs) of
 444               (_, _, [], Con _ _) -> True
 445               other               -> False
 446
 447         rhs_arg_tys
 448           = case (collectBinders rhs) of
 449               (_, _, val_binders, _) -> map idType val_binders
 450
 451         (mentioned_ids, _, _, mentions_litlit)
 452           = mentionedInUnfolding (\x -> x) rhs
 453
 454         rhs_mentions_an_unmentionable
 455           = foldBag (||) unfoldingUnfriendlyId False mentioned_ids
 456             || mentions_litlit
 457             -- ToDo: probably need to chk tycons/classes...
 458
 459         mentions_no_other_ids = isEmptyBag mentioned_ids
 460
 461         explicit_INLINE_requested
 462             -- did it come from a user {-# INLINE ... #-}?
 463             -- (Warning: must avoid including wrappers.)
 464           = idWantsToBeINLINEd binder
 465             && not (rhs `isWrapperFor` binder)
 466
 467         have_inlining_already = maybeToBool (lookupIdEnv inline_env binder)
 468
 469         ignominious_defeat = inline_env  -- just give back what we got
 470
 471         {-
 472             "glorious_success" is ours if we've found a suitable unfolding.
 473
 474             But we check for a couple of fine points.
 475
 476             (1) If this Id already has an inlining in the inline_env,
 477                 we don't automatically take it -- the earlier one is
 478                 "likely" to be better.
 479
 480                 But if the new one doesn't mention any other global
 481                 Ids, and it's pretty small (< UnfoldingOverrideThreshold),
 482                 then we take the chance that the new one *is* better.
 483
 484             (2) If we have an Id w/ a worker/wrapper split (with
 485                 an unfolding for the wrapper), we tend to want to keep
 486                 it -- and *nuke* any inlining that we conjured up
 487                 earlier.
 488
 489                 But, again, if this unfolding doesn't mention any
 490                 other global Ids (and small enough), then it is
 491                 probably better than the worker/wrappery, so we take
 492                 it.
 493         -}
 494         glorious_success guidance
 495           = let
 496                 new_env = addOneToIdEnv inline_env binder (mkUnfolding guidance rhs)
 497
 498                 foldr_building = opt_FoldrBuildOn
 499             in
 500             if (not have_inlining_already) then
 501                 -- Not in env: we take it no matter what
 502                 -- NB: we could check for worker/wrapper-ness,
 503                 -- but the truth is we probably haven't run
 504                 -- the strictness analyser yet.
 505                 new_env
 506
 507             else if explicit_INLINE_requested then
 508                 -- If it was a user INLINE, then we know it's already
 509                 -- in the inline_env; we stick with what we already
 510                 -- have.
 511                 --pprTrace "giving up on INLINE:" (ppr PprDebug binder)
 512                 ignominious_defeat
 513
 514             else if isWrapperId binder then
 515                 -- It's in the env, but we have since worker-wrapperised;
 516                 -- we either take this new one (because it's so good),
 517                 -- or we *undo* the one in the inline_env, so the
 518                 -- wrapper-inlining will take over.
 519
 520                 if mentions_no_other_ids {- *** && size <= unfold_override_threshold -} then
 521                     new_env
 522                 else
 523                     delOneFromIdEnv inline_env binder
 524
 525             else
 526                 -- It's in the env, nothing to do w/ worker wrapper;
 527                 -- we'll take it if it is better.
 528
 529                 if not foldr_building   -- ANDY hates us... (see below)
 530                 && mentions_no_other_ids
 531                 && guidance_size <= unfold_override_threshold then
 532                     new_env
 533                 else
 534                     --pprTrace "giving up on final hurdle:" (ppCat [ppr PprDebug binder, ppInt guidance_size, ppInt unfold_override_threshold])
 535                     ignominious_defeat -- and at the last hurdle, too!
 536 \end{code}
 537
 538 ANDY, on the hatred of the check above; why obliterate it?  Consider
 539
 540  head xs = foldr (\ x _ -> x) (_|_) xs
 541
 542 This then is exported via a pragma. However,
 543 *if* you include the extra code above, you will
 544 export the non-foldr/build version.