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