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