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