ghc/compiler/simplCore/FloatOut.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[FloatOut]{Float bindings outwards (towards the top level)}
   5
   6 ``Long-distance'' floating of bindings towards the top level.
   7
   8 \begin{code}
   9 module FloatOut ( floatOutwards ) where
  10
  11 #include "HsVersions.h"
  12
  13 import CoreSyn
  14
  15 import CmdLineOpts      ( opt_D_verbose_core2core, opt_D_simplifier_stats )
  16 import CostCentre       ( dupifyCC, CostCentre )
  17 import Id               ( nullIdEnv, addOneToIdEnv, growIdEnvList, IdEnv,
  18                           Id
  19                         )
  20 import PprCore
  21 import SetLevels        -- all of it
  22 import BasicTypes       ( Unused )
  23 import TyVar            ( TyVar )
  24 import UniqSupply       ( UniqSupply )
  25 import List             ( partition )
  26 import Outputable
  27 \end{code}
  28
  29 Random comments
  30 ~~~~~~~~~~~~~~~
  31
  32 At the moment we never float a binding out to between two adjacent
  33 lambdas.  For example:
  34
  35 @
  36         \x y -> let t = x+x in ...
  37 ===>
  38         \x -> let t = x+x in \y -> ...
  39 @
  40 Reason: this is less efficient in the case where the original lambda
  41 is never partially applied.
  42
  43 But there's a case I've seen where this might not be true.  Consider:
  44 @
  45 elEm2 x ys
  46   = elem' x ys
  47   where
  48     elem' _ []  = False
  49     elem' x (y:ys)      = x==y || elem' x ys
  50 @
  51 It turns out that this generates a subexpression of the form
  52 @
  53         \deq x ys -> let eq = eqFromEqDict deq in ...
  54 @
  55 which might usefully be separated to
  56 @
  57         \deq -> let eq = eqFromEqDict deq in \xy -> ...
  58 @
  59 Well, maybe.  We don't do this at the moment.
  60
  61 \begin{code}
  62 type LevelledExpr  = GenCoreExpr    (Id, Level) Id Unused
  63 type LevelledBind  = GenCoreBinding (Id, Level) Id Unused
  64 type FloatingBind  = (Level, Floater)
  65 type FloatingBinds = [FloatingBind]
  66
  67 data Floater
  68   = LetFloater  CoreBinding
  69   | CaseFloater (CoreExpr -> CoreExpr)
  70                 -- A CoreExpr with a hole in it:
  71                 -- "Give me a right-hand side of the
  72                 -- (usually single) alternative, and
  73                 -- I'll build the case..."
  74 \end{code}
  75
  76 %************************************************************************
  77 %*                                                                      *
  78 \subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
  79 %*                                                                      *
  80 %************************************************************************
  81
  82 \begin{code}
  83 floatOutwards :: UniqSupply -> [CoreBinding] -> [CoreBinding]
  84
  85 floatOutwards us pgm
  86   = case (setLevels pgm us) of { annotated_w_levels ->
  87
  88     case (unzip (map floatTopBind annotated_w_levels))
  89                 of { (fss, final_toplev_binds_s) ->
  90
  91     (if opt_D_verbose_core2core
  92      then pprTrace "Levels added:\n"
  93                    (vcat (map (ppr) annotated_w_levels))
  94      else id
  95     )
  96     ( if not (opt_D_simplifier_stats) then
  97          id
  98       else
  99          let
 100             (tlets, ntlets, lams) = get_stats (sum_stats fss)
 101          in
 102          pprTrace "FloatOut stats: " (hcat [
 103                 int tlets,  ptext SLIT(" Lets floated to top level; "),
 104                 int ntlets, ptext SLIT(" Lets floated elsewhere; from "),
 105                 int lams,   ptext SLIT(" Lambda groups")])
 106     )
 107     concat final_toplev_binds_s
 108     }}
 109
 110 floatTopBind bind@(NonRec _ _)
 111   = case (floatBind nullIdEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
 112     (fs, floatsToBinds floats ++ [bind'])
 113     }
 114
 115 floatTopBind bind@(Rec _)
 116   = case (floatBind nullIdEnv tOP_LEVEL bind) of { (fs, floats, Rec pairs', _) ->
 117         -- Actually floats will be empty
 118     --false:ASSERT(null floats)
 119     (fs, [Rec (floatsToBindPairs floats ++ pairs')])
 120     }
 121 \end{code}
 122
 123 %************************************************************************
 124 %*                                                                      *
 125 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
 126 %*                                                                      *
 127 %************************************************************************
 128
 129
 130 \begin{code}
 131 floatBind :: IdEnv Level
 132           -> Level
 133           -> LevelledBind
 134           -> (FloatStats, FloatingBinds, CoreBinding, IdEnv Level)
 135
 136 floatBind env lvl (NonRec (name,level) rhs)
 137   = case (floatExpr env level rhs) of { (fs, rhs_floats, rhs') ->
 138
 139         -- A good dumping point
 140     case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
 141
 142     (fs, rhs_floats',
 143      NonRec name (install heres rhs'),
 144      addOneToIdEnv env name level)
 145     }}
 146
 147 floatBind env lvl bind@(Rec pairs)
 148   = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
 149
 150     if not (isTopLvl bind_level) then
 151         -- Standard case
 152         (sum_stats fss, concat rhss_floats, Rec new_pairs, new_env)
 153     else
 154         {- In a recursive binding, destined for the top level (only),
 155            the rhs floats may contain
 156            references to the bound things.  For example
 157
 158                 f = ...(let v = ...f... in b) ...
 159
 160            might get floated to
 161
 162                 v = ...f...
 163                 f = ... b ...
 164
 165            and hence we must (pessimistically) make all the floats recursive
 166            with the top binding.  Later dependency analysis will unravel it.
 167         -}
 168
 169         (sum_stats fss,
 170          [],
 171          Rec (new_pairs ++ floatsToBindPairs (concat rhss_floats)),
 172          new_env)
 173
 174     }
 175   where
 176     new_env = growIdEnvList env (map fst pairs)
 177
 178     bind_level = getBindLevel bind
 179
 180     do_pair ((name, level), rhs)
 181       = case (floatExpr new_env level rhs) of { (fs, rhs_floats, rhs') ->
 182
 183                 -- A good dumping point
 184         case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
 185
 186         (fs, rhs_floats', (name, install heres rhs'))
 187         }}
 188 \end{code}
 189
 190 %************************************************************************
 191
 192 \subsection[FloatOut-Expr]{Floating in expressions}
 193 %*                                                                      *
 194 %************************************************************************
 195
 196 \begin{code}
 197 floatExpr :: IdEnv Level
 198           -> Level
 199           -> LevelledExpr
 200           -> (FloatStats, FloatingBinds, CoreExpr)
 201
 202 floatExpr env _ (Var v)      = (zero_stats, [], Var v)
 203 floatExpr env _ (Lit l)      = (zero_stats, [], Lit l)
 204 floatExpr env _ (Prim op as) = (zero_stats, [], Prim op as)
 205 floatExpr env _ (Con con as) = (zero_stats, [], Con con as)
 206
 207 floatExpr env lvl (App e a)
 208   = case (floatExpr env lvl e) of { (fs, floating_defns, e') ->
 209     (fs, floating_defns, App e' a) }
 210
 211 floatExpr env lvl (Lam (TyBinder tv) e)
 212   = let
 213         incd_lvl = incMinorLvl lvl
 214     in
 215     case (floatExpr env incd_lvl e) of { (fs, floats, e') ->
 216
 217         -- Dump any bindings which absolutely cannot go any further
 218     case (partitionByLevel incd_lvl floats)     of { (floats', heres) ->
 219
 220     (fs, floats', Lam (TyBinder tv) (install heres e'))
 221     }}
 222
 223 floatExpr env lvl (Lam (ValBinder (arg,incd_lvl)) rhs)
 224   = let
 225         new_env  = addOneToIdEnv env arg incd_lvl
 226     in
 227     case (floatExpr new_env incd_lvl rhs) of { (fs, floats, rhs') ->
 228
 229         -- Dump any bindings which absolutely cannot go any further
 230     case (partitionByLevel incd_lvl floats)     of { (floats', heres) ->
 231
 232     (add_to_stats fs floats',
 233      floats',
 234      Lam (ValBinder arg) (install heres rhs'))
 235     }}
 236
 237 floatExpr env lvl (Note note@(SCC cc) expr)
 238   = case (floatExpr env lvl expr)    of { (fs, floating_defns, expr') ->
 239     let
 240         -- annotate bindings floated outwards past an scc expression
 241         -- with the cc.  We mark that cc as "duplicated", though.
 242
 243         annotated_defns = annotate (dupifyCC cc) floating_defns
 244     in
 245     (fs, annotated_defns, Note note expr') }
 246   where
 247     annotate :: CostCentre -> FloatingBinds -> FloatingBinds
 248
 249     annotate dupd_cc defn_groups
 250       = [ (level, ann_bind floater) | (level, floater) <- defn_groups ]
 251       where
 252         ann_bind (LetFloater (NonRec binder rhs))
 253           = LetFloater (NonRec binder (ann_rhs rhs))
 254
 255         ann_bind (LetFloater (Rec pairs))
 256           = LetFloater (Rec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs])
 257
 258         ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> Note (SCC dupd_cc) (fn rhs) )
 259
 260         ann_rhs (Lam arg e)   = Lam arg (ann_rhs e)
 261         ann_rhs rhs@(Con _ _) = rhs     -- no point in scc'ing WHNF data
 262         ann_rhs rhs           = Note (SCC dupd_cc) rhs
 263
 264         -- Note: Nested SCC's are preserved for the benefit of
 265         --       cost centre stack profiling (Durham)
 266
 267 floatExpr env lvl (Note note expr)      -- Other than SCCs
 268   = case (floatExpr env lvl expr)    of { (fs, floating_defns, expr') ->
 269     (fs, floating_defns, Note note expr') }
 270
 271 floatExpr env lvl (Let bind body)
 272   = case (floatBind env     lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
 273     case (floatExpr new_env lvl body) of { (fse, body_floats, body') ->
 274     (add_stats fsb fse,
 275      rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats,
 276      body')
 277     }}
 278   where
 279     bind_lvl = getBindLevel bind
 280
 281 floatExpr env lvl (Case scrut alts)
 282   = case (floatExpr env lvl scrut) of { (fse, fde, scrut') ->
 283
 284     case (scrut', float_alts alts) of
 285         (_, (fsa, fda, alts')) ->
 286                 (add_stats fse fsa, fda ++ fde, Case scrut' alts')
 287     }
 288     {-  OLD CASE-FLOATING CODE: DROPPED FOR NOW.  (SLPJ 7/2/94)
 289
 290         (Var scrut_var, (fda, AlgAlts [(con,bs,rhs')] NoDefault))
 291                 | scrut_var_lvl `ltMajLvl` lvl ->
 292
 293                 -- Candidate for case floater; scrutinising a variable; it can
 294                 -- escape outside a lambda; there's only one alternative.
 295                 (fda ++ fde ++ [case_floater], rhs')
 296
 297                 where
 298                 case_floater = (scrut_var_lvl, CaseFloater fn)
 299                 fn body = Case scrut' (AlgAlts [(con,bs,body)] NoDefault)
 300                 scrut_var_lvl = case lookupIdEnv env scrut_var of
 301                                   Nothing  -> Level 0 0
 302                                   Just lvl -> unTopify lvl
 303
 304     END OF CASE FLOATING DROPPED -}
 305   where
 306       incd_lvl = incMinorLvl lvl
 307
 308       partition_fn = partitionByMajorLevel
 309
 310 {-      OMITTED
 311         We don't want to be too keen about floating lets out of case alternatives
 312         because they may benefit from seeing the evaluation done by the case.
 313
 314         The main reason for doing this is to allocate in fewer larger blocks
 315         but that's really an STG-level issue.
 316
 317                         case alts of
 318                                 -- Just one alternative, then dump only
 319                                 -- what *has* to be dumped
 320                         AlgAlts  [_] NoDefault     -> partitionByLevel
 321                         AlgAlts  []  (BindDefault _ _) -> partitionByLevel
 322                         PrimAlts [_] NoDefault     -> partitionByLevel
 323                         PrimAlts []  (BindDefault _ _) -> partitionByLevel
 324
 325                                 -- If there's more than one alternative, then
 326                                 -- this is a dumping point
 327                         other                              -> partitionByMajorLevel
 328 -}
 329
 330       float_alts (AlgAlts alts deflt)
 331         = case (float_deflt  deflt)              of { (fsd,  fdd,  deflt') ->
 332           case (unzip3 (map float_alg_alt alts)) of { (fsas, fdas, alts') ->
 333           (foldr add_stats fsd fsas,
 334            concat fdas ++ fdd,
 335            AlgAlts alts' deflt') }}
 336
 337       float_alts (PrimAlts alts deflt)
 338         = case (float_deflt deflt)                of { (fsd,   fdd, deflt') ->
 339           case (unzip3 (map float_prim_alt alts)) of { (fsas, fdas, alts') ->
 340           (foldr add_stats fsd fsas,
 341            concat fdas ++ fdd,
 342            PrimAlts alts' deflt') }}
 343
 344       -------------
 345       float_alg_alt (con, bs, rhs)
 346         = let
 347               bs' = map fst bs
 348               new_env = growIdEnvList env bs
 349           in
 350           case (floatExpr new_env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
 351           case (partition_fn incd_lvl rhs_floats)       of { (rhs_floats', heres) ->
 352           (fs, rhs_floats', (con, bs', install heres rhs')) }}
 353
 354       --------------
 355       float_prim_alt (lit, rhs)
 356         = case (floatExpr env incd_lvl rhs)             of { (fs, rhs_floats, rhs') ->
 357           case (partition_fn incd_lvl rhs_floats)       of { (rhs_floats', heres) ->
 358           (fs, rhs_floats', (lit, install heres rhs')) }}
 359
 360       --------------
 361       float_deflt NoDefault = (zero_stats, [], NoDefault)
 362
 363       float_deflt (BindDefault (b,lvl) rhs)
 364         = case (floatExpr new_env lvl rhs)              of { (fs, rhs_floats, rhs') ->
 365           case (partition_fn incd_lvl rhs_floats)       of { (rhs_floats', heres) ->
 366           (fs, rhs_floats', BindDefault b (install heres rhs')) }}
 367         where
 368           new_env = addOneToIdEnv env b lvl
 369 \end{code}
 370
 371 %************************************************************************
 372 %*                                                                      *
 373 \subsection{Utility bits for floating stats}
 374 %*                                                                      *
 375 %************************************************************************
 376
 377 I didn't implement this with unboxed numbers.  I don't want to be too
 378 strict in this stuff, as it is rarely turned on.  (WDP 95/09)
 379
 380 \begin{code}
 381 data FloatStats
 382   = FlS Int  -- Number of top-floats * lambda groups they've been past
 383         Int  -- Number of non-top-floats * lambda groups they've been past
 384         Int  -- Number of lambda (groups) seen
 385
 386 get_stats (FlS a b c) = (a, b, c)
 387
 388 zero_stats = FlS 0 0 0
 389
 390 sum_stats xs = foldr add_stats zero_stats xs
 391
 392 add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
 393   = FlS (a1 + a2) (b1 + b2) (c1 + c2)
 394
 395 add_to_stats (FlS a b c) floats
 396   = FlS (a + length top_floats) (b + length other_floats) (c + 1)
 397   where
 398     (top_floats, other_floats) = partition to_very_top floats
 399
 400     to_very_top (my_lvl, _) = isTopLvl my_lvl
 401 \end{code}
 402
 403 %************************************************************************
 404 %*                                                                      *
 405 \subsection{Utility bits for floating}
 406 %*                                                                      *
 407 %************************************************************************
 408
 409 \begin{code}
 410 getBindLevel (NonRec (_, lvl) _)      = lvl
 411 getBindLevel (Rec (((_,lvl), _) : _)) = lvl
 412 \end{code}
 413
 414 \begin{code}
 415 partitionByMajorLevel, partitionByLevel
 416         :: Level                -- Partitioning level
 417
 418         -> FloatingBinds        -- Defns to be divided into 2 piles...
 419
 420         -> (FloatingBinds,      -- Defns  with level strictly < partition level,
 421             FloatingBinds)      -- The rest
 422
 423
 424 partitionByMajorLevel ctxt_lvl defns
 425   = partition float_further defns
 426   where
 427     float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl ||
 428                                 isTopLvl my_lvl
 429
 430 partitionByLevel ctxt_lvl defns
 431   = partition float_further defns
 432   where
 433     float_further (my_lvl, _) = my_lvl `ltLvl` ctxt_lvl
 434 \end{code}
 435
 436 \begin{code}
 437 floatsToBinds :: FloatingBinds -> [CoreBinding]
 438 floatsToBinds floats = map get_bind floats
 439                      where
 440                        get_bind (_, LetFloater bind) = bind
 441                        get_bind (_, CaseFloater _)   = panic "floatsToBinds"
 442
 443 floatsToBindPairs :: FloatingBinds -> [(Id,CoreExpr)]
 444
 445 floatsToBindPairs floats = concat (map mk_pairs floats)
 446   where
 447    mk_pairs (_, LetFloater (Rec pairs))         = pairs
 448    mk_pairs (_, LetFloater (NonRec binder rhs)) = [(binder,rhs)]
 449    mk_pairs (_, CaseFloater _)                    = panic "floatsToBindPairs"
 450
 451 install :: FloatingBinds -> CoreExpr -> CoreExpr
 452
 453 install defn_groups expr
 454   = foldr install_group expr defn_groups
 455   where
 456     install_group (_, LetFloater defns) body = Let defns body
 457     install_group (_, CaseFloater fn)   body = fn body
 458 \end{code}