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