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 import Literal          ( Literal(..) )
  14 import CmdLineOpts      ( GlobalSwitch(..) )
  15 import CostCentre       ( dupifyCC, CostCentre )
  16 import SetLevels
  17 import Id               ( eqId )
  18 import Maybes           ( Maybe(..), catMaybes, maybeToBool )
  19 import UniqSupply
  20 import Util
  21 \end{code}
  22
  23 Random comments
  24 ~~~~~~~~~~~~~~~
  25 At the moment we never float a binding out to between two adjacent lambdas.  For
  26 example:
  27 @
  28         \x y -> let t = x+x in ...
  29 ===>
  30         \x -> let t = x+x in \y -> ...
  31 @
  32 Reason: this is less efficient in the case where the original lambda is
  33 never partially applied.
  34
  35 But there's a case I've seen where this might not be true.  Consider:
  36 @
  37 elEm2 x ys
  38   = elem' x ys
  39   where
  40     elem' _ []  = False
  41     elem' x (y:ys)      = x==y || elem' x ys
  42 @
  43 It turns out that this generates a subexpression of the form
  44 @
  45         \deq x ys -> let eq = eqFromEqDict deq in ...
  46 @
  47 which might usefully be separated to
  48 @
  49         \deq -> let eq = eqFromEqDict deq in \xy -> ...
  50 @
  51 Well, maybe.  We don't do this at the moment.
  52
  53
  54 \begin{code}
  55 type LevelledExpr  = GenCoreExpr         (Id, Level) Id
  56 type LevelledBind  = GenCoreBinding (Id, Level) Id
  57 type FloatingBind  = (Level, Floater)
  58 type FloatingBinds = [FloatingBind]
  59
  60 data Floater = LetFloater     CoreBinding
  61
  62              | CaseFloater   (CoreExpr -> CoreExpr)
  63                                 -- Give me a right-hand side of the
  64                                 -- (usually single) alternative, and
  65                                 -- I'll build the case
  66 \end{code}
  67
  68 %************************************************************************
  69 %*                                                                      *
  70 \subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
  71 %*                                                                      *
  72 %************************************************************************
  73
  74 \begin{code}
  75 floatOutwards :: (GlobalSwitch -> Bool)  -- access to all global cmd-line opts
  76               -> UniqSupply
  77               -> [CoreBinding]
  78               -> [CoreBinding]
  79
  80 floatOutwards sw_chker us pgm
  81   = case (setLevels pgm sw_chker us) of { annotated_w_levels ->
  82
  83     case unzip (map (floatTopBind sw_chker) annotated_w_levels)
  84                 of { (fss, final_toplev_binds_s) ->
  85
  86     (if sw_chker D_verbose_core2core
  87      then pprTrace "Levels added:\n" (ppr PprDebug annotated_w_levels)
  88      else id
  89     )
  90     ( if not (sw_chker D_simplifier_stats) then
  91          id
  92       else
  93          let
  94             (tlets, ntlets, lams) = get_stats (sum_stats fss)
  95          in
  96          pprTrace "FloatOut stats: " (ppBesides [
  97                 ppInt tlets,  ppStr " Lets floated to top level; ",
  98                 ppInt ntlets, ppStr " Lets floated elsewhere; from ",
  99                 ppInt lams,   ppStr " Lambda groups"])
 100     )
 101     concat final_toplev_binds_s
 102     }}
 103
 104 floatTopBind sw bind@(NonRec _ _)
 105   = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
 106     (fs, floatsToBinds floats ++ [bind'])
 107     }
 108
 109 floatTopBind sw bind@(Rec _)
 110   = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, Rec pairs', _) ->
 111         -- Actually floats will be empty
 112     --false:ASSERT(null floats)
 113     (fs, [Rec (floatsToBindPairs floats ++ pairs')])
 114     }
 115 \end{code}
 116
 117 %************************************************************************
 118 %*                                                                      *
 119 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
 120 %*                                                                      *
 121 %************************************************************************
 122
 123
 124 \begin{code}
 125 floatBind :: (GlobalSwitch -> Bool)
 126           -> IdEnv Level
 127           -> Level
 128           -> LevelledBind
 129           -> (FloatStats, FloatingBinds, CoreBinding, IdEnv Level)
 130
 131 floatBind sw env lvl (NonRec (name,level) rhs)
 132   = case (floatExpr sw env level rhs) of { (fs, rhs_floats, rhs') ->
 133
 134         -- A good dumping point
 135     case (partitionByMajorLevel level rhs_floats)       of { (rhs_floats', heres) ->
 136
 137     (fs, rhs_floats',NonRec name (install heres rhs'), addOneToIdEnv env name level)
 138     }}
 139
 140 floatBind sw env lvl bind@(Rec pairs)
 141   = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
 142
 143     if not (isTopLvl bind_level) then
 144         -- Standard case
 145         (sum_stats fss, concat rhss_floats, Rec new_pairs, new_env)
 146     else
 147         {- In a recursive binding, destined for the top level (only),
 148            the rhs floats may contain
 149            references to the bound things.  For example
 150
 151                 f = ...(let v = ...f... in b) ...
 152
 153            might get floated to
 154
 155                 v = ...f...
 156                 f = ... b ...
 157
 158            and hence we must (pessimistically) make all the floats recursive
 159            with the top binding.  Later dependency analysis will unravel it.
 160         -}
 161
 162         (sum_stats fss,
 163          [],
 164          Rec (new_pairs ++ floatsToBindPairs (concat rhss_floats)),
 165          new_env)
 166
 167     }
 168   where
 169     new_env = growIdEnvList env (map fst pairs)
 170
 171     bind_level = getBindLevel bind
 172
 173     do_pair ((name, level), rhs)
 174       = case (floatExpr sw new_env level rhs) of { (fs, rhs_floats, rhs') ->
 175
 176                 -- A good dumping point
 177         case (partitionByMajorLevel level rhs_floats)   of { (rhs_floats', heres) ->
 178
 179         (fs, rhs_floats', (name, install heres rhs'))
 180         }}
 181 \end{code}
 182
 183 %************************************************************************
 184
 185 \subsection[FloatOut-Expr]{Floating in expressions}
 186 %*                                                                      *
 187 %************************************************************************
 188
 189 \begin{code}
 190 floatExpr :: (GlobalSwitch -> Bool)
 191           -> IdEnv Level
 192           -> Level
 193           -> LevelledExpr
 194           -> (FloatStats, FloatingBinds, CoreExpr)
 195
 196 floatExpr sw env _ (Var v)           = (zero_stats, [], Var v)
 197
 198 floatExpr sw env _ (Lit l)     = (zero_stats, [], Lit l)
 199
 200 floatExpr sw env _ (Prim op ty as) = (zero_stats, [], Prim op ty as)
 201 floatExpr sw env _ (Con con ty as) = (zero_stats, [], Con con ty as)
 202
 203 floatExpr sw env lvl (App e a)
 204   = case (floatExpr sw env lvl e) of { (fs, floating_defns, e') ->
 205     (fs, floating_defns, App e' a) }
 206
 207 floatExpr sw env lvl (CoTyApp e ty)
 208   = case (floatExpr sw env lvl e) of { (fs, floating_defns, e') ->
 209     (fs, floating_defns, CoTyApp e' ty) }
 210
 211 floatExpr sw env lvl (CoTyLam tv e)
 212   = let
 213         incd_lvl = incMinorLvl lvl
 214     in
 215     case (floatExpr sw 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', CoTyLam tv (install heres e'))
 221     }}
 222
 223 floatExpr sw env lvl (Lam (arg,incd_lvl) rhs)
 224   = let
 225         new_env  = addOneToIdEnv env arg incd_lvl
 226     in
 227     case (floatExpr sw 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 args' (install heres rhs'))
 235     }}
 236
 237 floatExpr sw env lvl (SCC cc expr)
 238   = case (floatExpr sw 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, SCC cc 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 -> SCC dupd_cc (fn rhs) )
 259
 260         ann_rhs (Lam     arg e)  = Lam   arg (ann_rhs e)
 261         ann_rhs (CoTyLam tv  e)  = CoTyLam tv  (ann_rhs e)
 262         ann_rhs rhs@(Con _ _ _)= rhs    -- no point in scc'ing WHNF data
 263         ann_rhs rhs              = SCC dupd_cc rhs
 264
 265         -- Note: Nested SCC's are preserved for the benefit of
 266         --       cost centre stack profiling (Durham)
 267
 268 floatExpr sw env lvl (Let bind body)
 269   = case (floatBind sw env     lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
 270     case (floatExpr sw new_env lvl body) of { (fse, body_floats, body') ->
 271     (add_stats fsb fse,
 272      rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats,
 273      body')
 274     }}
 275   where
 276     bind_lvl = getBindLevel bind
 277
 278 floatExpr sw env lvl (Case scrut alts)
 279   = case (floatExpr sw env lvl scrut) of { (fse, fde, scrut') ->
 280
 281     case (scrut', float_alts alts) of
 282
 283 {-      CASE-FLOATING DROPPED FOR NOW.  (SLPJ 7/2/94)
 284
 285         (Var scrut_var, (fda, AlgAlts [(con,bs,rhs')] NoDefault))
 286                 | scrut_var_lvl `ltMajLvl` lvl ->
 287
 288                 -- Candidate for case floater; scrutinising a variable; it can
 289                 -- escape outside a lambda; there's only one alternative.
 290                 (fda ++ fde ++ [case_floater], rhs')
 291
 292                 where
 293                 case_floater = (scrut_var_lvl, CaseFloater fn)
 294                 fn body = Case scrut' (AlgAlts [(con,bs,body)] NoDefault)
 295                 scrut_var_lvl = case lookupIdEnv env scrut_var of
 296                                   Nothing  -> Level 0 0
 297                                   Just lvl -> unTopify lvl
 298
 299  END OF CASE FLOATING DROPPED   -}
 300
 301         (_, (fsa, fda, alts')) ->
 302
 303                 (add_stats fse fsa, fda ++ fde, Case scrut' alts')
 304     }
 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 sw 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 sw 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 sw 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}