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 )
  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, isWrapperId,
  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 \end{code}
  76
  77 \begin{code}
  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...
  85           -> IO
  86               ([CoreBinding],   -- results: program, plus...
  87                IdEnv Unfolding, --  unfoldings to be exported from here
  88               SpecialiseData)           --  specialisation data
  89
  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
  93         return (
  94         (substCoreBindings nullIdEnv nullTyVarEnv binds us,
  95          nullIdEnv,
  96          init_specdata)
  97         )
  98     else
  99         (if do_verbose_core2core then
 100             hPutStr stderr "VERBOSE CORE-TO-CORE:\n"
 101          else return ()) >>
 102
 103         -- better do the main business
 104         foldl_mn do_core_pass
 105                 (binds, us, nullIdEnv, init_specdata, zeroSimplCount)
 106                 core_todos
 107                 >>= \ (processed_binds, _, inline_env, spec_data, simpl_stats) ->
 108
 109         (if  opt_D_simplifier_stats
 110          then hPutStr stderr ("\nSimplifier Stats:\n")
 111                 >>
 112               hPutStr stderr (showSimplCount simpl_stats)
 113                 >>
 114               hPutStr stderr "\n"
 115          else return ()
 116         ) >>
 117
 118         return (processed_binds, inline_env, spec_data)
 119   where
 120     init_specdata = initSpecData local_tycons tycon_specs
 121
 122     do_verbose_core2core = opt_D_verbose_core2core
 123
 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
 128           Just xx -> 4 * xx
 129
 130     -------------
 131     core_linter = if opt_DoCoreLinting
 132                   then lintCoreBindings ppr_style
 133                   else ( \ whodunnit spec_done binds -> binds )
 134
 135     --------------
 136     do_core_pass info@(binds, us, inline_env, spec_data, simpl_stats) to_do
 137       = let
 138             (us1, us2) = splitUniqSupply us
 139         in
 140         case to_do of
 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 "")
 151
 152           CoreDoFoldrBuildWorkerWrapper
 153             -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
 154                begin_pass "FBWW" >>
 155                case (mkFoldrBuildWW us1 binds) of { binds2 ->
 156                end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW" }
 157
 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" }
 163
 164           CoreLiberateCase
 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" }
 169
 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" }
 175
 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" }
 181
 182           CoreDoFloatInwards
 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" }
 187
 188           CoreDoFullLaziness
 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" }
 193
 194           CoreDoStaticArgs
 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])
 202
 203           CoreDoStrictness
 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" }
 208
 209           CoreDoSpecialising
 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)) ->
 215
 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"
 222                     else
 223                         return ()) >>
 224
 225                    (if not spec_noerrs then -- Stop here if specialisation errors occured
 226                         ghcExit 1
 227                    else
 228                         return ()) >>
 229
 230                    end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise"
 231                }
 232
 233           CoreDoDeforest
 234 #if OMIT_DEFORESTER
 235             -> error "ERROR: CoreDoDeforest: not built into compiler\n"
 236 #else
 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" }
 241 #endif
 242
 243           CoreDoPrintCore       -- print result of last pass
 244             -> end_pass True us2 binds inline_env spec_data simpl_stats "Print"
 245
 246     -------------------------------------------------
 247
 248     begin_pass
 249       = if opt_D_show_passes
 250         then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n")
 251         else \ what -> return ()
 252
 253     end_pass print us2 binds2 inline_env2
 254              spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
 255              simpl_stats2 what
 256       = -- report verbosely, if required
 257         (if (do_verbose_core2core && not print) ||
 258             (print && not do_verbose_core2core)
 259          then
 260             hPutStr stderr ("\n*** "++what++":\n")
 261                 >>
 262             hPutStr stderr (ppShow 1000
 263                 (ppAboves (map (pprCoreBinding ppr_style) binds2)))
 264                 >>
 265             hPutStr stderr "\n"
 266          else
 267             return ()) >>
 268         let
 269             linted_binds = core_linter what spec_done binds2
 270         in
 271         return
 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
 277         )
 278
 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 ->
 282                      foldl_mn f zz xs
 283 \end{code}
 284
 285 --- ToDo: maybe move elsewhere ---
 286
 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.
 290
 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.
 296
 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.
 300
 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.
 303
 304 \begin{code}
 305 calcInlinings :: Bool   -- True => inlinings with _scc_s are OK
 306               -> IdEnv Unfolding
 307               -> [CoreBinding]
 308               -> IdEnv Unfolding
 309
 310 calcInlinings scc_s_OK inline_env_so_far top_binds
 311   = let
 312         result = foldl calci inline_env_so_far top_binds
 313     in
 314     --pprTrace "inline env:\n" (ppAboves (map pp_item (getIdEnvMapping result)))
 315     result
 316   where
 317     pp_item (binder, details)
 318       = ppCat [ppr PprDebug binder, ppStr "=>", pp_det details]
 319       where
 320         pp_det NoUnfolding   = ppStr "_N_"
 321 --LATER:        pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
 322         pp_det (CoreUnfolding (SimpleUnfolding _ guide expr))
 323           = ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
 324         pp_det other                = ppStr "???"
 325
 326     ------------
 327     my_trace =  if opt_ReportWhyUnfoldingsDisallowed
 328                 then trace
 329                 else \ msg stuff -> stuff
 330
 331     (unfolding_creation_threshold, explicit_creation_threshold)
 332       = case opt_UnfoldingCreationThreshold of
 333           Nothing -> (uNFOLDING_CREATION_THRESHOLD, False)
 334           Just xx -> (xx, True)
 335
 336     unfold_use_threshold
 337       = case opt_UnfoldingUseThreshold of
 338           Nothing -> uNFOLDING_USE_THRESHOLD
 339           Just xx -> xx
 340
 341     unfold_override_threshold
 342       = case opt_UnfoldingOverrideThreshold of
 343           Nothing -> uNFOLDING_OVERRIDE_THRESHOLD
 344           Just xx -> xx
 345
 346     con_discount_weight = uNFOLDING_CON_DISCOUNT_WEIGHT
 347
 348     calci inline_env (Rec pairs)
 349       = foldl (calc True{-recursive-}) inline_env pairs
 350
 351     calci inline_env bind@(NonRec binder rhs)
 352       = calc False{-not recursive-} inline_env (binder, rhs)
 353
 354     ---------------------------------------
 355
 356     calc is_recursive inline_env (binder, rhs)
 357       | not (toplevelishId binder)
 358       = --pprTrace "giving up on not top-level:" (ppr PprDebug binder)
 359         ignominious_defeat
 360
 361       | rhs_mentions_an_unmentionable
 362       || (not explicit_INLINE_requested
 363           && (rhs_looks_like_a_caf || guidance_size_too_big))
 364       = let
 365             my_my_trace
 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...
 370                 else my_trace
 371
 372             which = if scc_s_OK then " (late):" else " (early):"
 373         in
 374         my_my_trace ("unfolding disallowed for"++which++(ppShow 80 (ppr PprDebug binder))) (
 375         ignominious_defeat
 376         )
 377
 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
 381         -- they will be OK.
 382       = ignominious_defeat
 383
 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.
 389
 390       | is_recursive &&
 391         explicit_INLINE_requested &&
 392         deforestable binder &&
 393         scc_s_OK                        -- hack, only get them in
 394                                         -- calc_inlinings2
 395       = glorious_success UnfoldAlways
 396 #endif
 397
 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)
 403         ignominious_defeat
 404
 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
 411         -- "better").
 412
 413       | explicit_INLINE_requested
 414       = glorious_success UnfoldAlways
 415
 416       | otherwise
 417       = glorious_success guidance
 418
 419       where
 420         guidance
 421           = calcUnfoldingGuidance scc_s_OK max_out_threshold rhs
 422           where
 423             max_out_threshold = if explicit_INLINE_requested
 424                                 then 100000 -- you asked for it, you got it
 425                                 else unfolding_creation_threshold
 426
 427         guidance_size
 428           = case guidance of
 429               UnfoldAlways                -> 0 -- *extremely* small
 430               UnfoldIfGoodArgs _ _ _ size -> size
 431
 432         guidance_size_too_big
 433             -- Does the guidance suggest that this unfolding will
 434             -- be of no use *no matter* the arguments given to it?
 435             -- Could be more sophisticated...
 436           = not (couldBeSmallEnoughToInline con_discount_weight unfold_use_threshold guidance)
 437
 438
 439         rhs_looks_like_a_caf = not (whnfOrBottom rhs)
 440
 441         rhs_looks_like_a_data_val
 442           = case (collectBinders rhs) of
 443               (_, _, [], Con _ _) -> True
 444               other               -> False
 445
 446         rhs_arg_tys
 447           = case (collectBinders rhs) of
 448               (_, _, val_binders, _) -> map idType val_binders
 449
 450         (mentioned_ids, _, _, mentions_litlit)
 451           = mentionedInUnfolding (\x -> x) rhs
 452
 453         rhs_mentions_an_unmentionable
 454           = foldBag (||) unfoldingUnfriendlyId False mentioned_ids
 455             || mentions_litlit
 456             -- ToDo: probably need to chk tycons/classes...
 457
 458         mentions_no_other_ids = isEmptyBag mentioned_ids
 459
 460         explicit_INLINE_requested
 461             -- did it come from a user {-# INLINE ... #-}?
 462             -- (Warning: must avoid including wrappers.)
 463           = idWantsToBeINLINEd binder
 464             && not (rhs `isWrapperFor` binder)
 465
 466         have_inlining_already = maybeToBool (lookupIdEnv inline_env binder)
 467
 468         ignominious_defeat = inline_env  -- just give back what we got
 469
 470         {-
 471             "glorious_success" is ours if we've found a suitable unfolding.
 472
 473             But we check for a couple of fine points.
 474
 475             (1) If this Id already has an inlining in the inline_env,
 476                 we don't automatically take it -- the earlier one is
 477                 "likely" to be better.
 478
 479                 But if the new one doesn't mention any other global
 480                 Ids, and it's pretty small (< UnfoldingOverrideThreshold),
 481                 then we take the chance that the new one *is* better.
 482
 483             (2) If we have an Id w/ a worker/wrapper split (with
 484                 an unfolding for the wrapper), we tend to want to keep
 485                 it -- and *nuke* any inlining that we conjured up
 486                 earlier.
 487
 488                 But, again, if this unfolding doesn't mention any
 489                 other global Ids (and small enough), then it is
 490                 probably better than the worker/wrappery, so we take
 491                 it.
 492         -}
 493         glorious_success guidance
 494           = let
 495                 new_env = addOneToIdEnv inline_env binder (mkUnfolding guidance rhs)
 496
 497                 foldr_building = opt_FoldrBuildOn
 498             in
 499             if (not have_inlining_already) then
 500                 -- Not in env: we take it no matter what
 501                 -- NB: we could check for worker/wrapper-ness,
 502                 -- but the truth is we probably haven't run
 503                 -- the strictness analyser yet.
 504                 new_env
 505
 506             else if explicit_INLINE_requested then
 507                 -- If it was a user INLINE, then we know it's already
 508                 -- in the inline_env; we stick with what we already
 509                 -- have.
 510                 --pprTrace "giving up on INLINE:" (ppr PprDebug binder)
 511                 ignominious_defeat
 512
 513             else if isWrapperId binder then
 514                 -- It's in the env, but we have since worker-wrapperised;
 515                 -- we either take this new one (because it's so good),
 516                 -- or we *undo* the one in the inline_env, so the
 517                 -- wrapper-inlining will take over.
 518
 519                 if mentions_no_other_ids {- *** && size <= unfold_override_threshold -} then
 520                     new_env
 521                 else
 522                     delOneFromIdEnv inline_env binder
 523
 524             else
 525                 -- It's in the env, nothing to do w/ worker wrapper;
 526                 -- we'll take it if it is better.
 527
 528                 if not foldr_building   -- ANDY hates us... (see below)
 529                 && mentions_no_other_ids
 530                 && guidance_size <= unfold_override_threshold then
 531                     new_env
 532                 else
 533                     --pprTrace "giving up on final hurdle:" (ppCat [ppr PprDebug binder, ppInt guidance_size, ppInt unfold_override_threshold])
 534                     ignominious_defeat -- and at the last hurdle, too!
 535 \end{code}
 536
 537 ANDY, on the hatred of the check above; why obliterate it?  Consider
 538
 539  head xs = foldr (\ x _ -> x) (_|_) xs
 540
 541 This then is exported via a pragma. However,
 542 *if* you include the extra code above, you will
 543 export the non-foldr/build version.