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 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          -- too lazy to type in all the instances
  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 (Let bind body)
 276   = case (floatBind env     lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
 277     case (floatExpr new_env lvl body) of { (fse, body_floats, body') ->
 278     (add_stats fsb fse,
 279      rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats,
 280      body')
 281     }}
 282   where
 283     bind_lvl = getBindLevel bind
 284
 285 floatExpr env lvl (Case scrut alts)
 286   = case (floatExpr env lvl scrut) of { (fse, fde, scrut') ->
 287
 288     case (scrut', float_alts alts) of
 289         (_, (fsa, fda, alts')) ->
 290                 (add_stats fse fsa, fda ++ fde, Case scrut' alts')
 291     }
 292     {-  OLD CASE-FLOATING CODE: DROPPED FOR NOW.  (SLPJ 7/2/94)
 293
 294         (Var scrut_var, (fda, AlgAlts [(con,bs,rhs')] NoDefault))
 295                 | scrut_var_lvl `ltMajLvl` lvl ->
 296
 297                 -- Candidate for case floater; scrutinising a variable; it can
 298                 -- escape outside a lambda; there's only one alternative.
 299                 (fda ++ fde ++ [case_floater], rhs')
 300
 301                 where
 302                 case_floater = (scrut_var_lvl, CaseFloater fn)
 303                 fn body = Case scrut' (AlgAlts [(con,bs,body)] NoDefault)
 304                 scrut_var_lvl = case lookupIdEnv env scrut_var of
 305                                   Nothing  -> Level 0 0
 306                                   Just lvl -> unTopify lvl
 307
 308     END OF CASE FLOATING DROPPED -}
 309   where
 310       incd_lvl = incMinorLvl lvl
 311
 312       partition_fn = partitionByMajorLevel
 313
 314 {-      OMITTED
 315         We don't want to be too keen about floating lets out of case alternatives
 316         because they may benefit from seeing the evaluation done by the case.
 317
 318         The main reason for doing this is to allocate in fewer larger blocks
 319         but that's really an STG-level issue.
 320
 321                         case alts of
 322                                 -- Just one alternative, then dump only
 323                                 -- what *has* to be dumped
 324                         AlgAlts  [_] NoDefault     -> partitionByLevel
 325                         AlgAlts  []  (BindDefault _ _) -> partitionByLevel
 326                         PrimAlts [_] NoDefault     -> partitionByLevel
 327                         PrimAlts []  (BindDefault _ _) -> partitionByLevel
 328
 329                                 -- If there's more than one alternative, then
 330                                 -- this is a dumping point
 331                         other                              -> partitionByMajorLevel
 332 -}
 333
 334       float_alts (AlgAlts alts deflt)
 335         = case (float_deflt  deflt)              of { (fsd,  fdd,  deflt') ->
 336           case (unzip3 (map float_alg_alt alts)) of { (fsas, fdas, alts') ->
 337           (foldr add_stats fsd fsas,
 338            concat fdas ++ fdd,
 339            AlgAlts alts' deflt') }}
 340
 341       float_alts (PrimAlts alts deflt)
 342         = case (float_deflt deflt)                of { (fsd,   fdd, deflt') ->
 343           case (unzip3 (map float_prim_alt alts)) of { (fsas, fdas, alts') ->
 344           (foldr add_stats fsd fsas,
 345            concat fdas ++ fdd,
 346            PrimAlts alts' deflt') }}
 347
 348       -------------
 349       float_alg_alt (con, bs, rhs)
 350         = let
 351               bs' = map fst bs
 352               new_env = growIdEnvList env bs
 353           in
 354           case (floatExpr new_env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
 355           case (partition_fn incd_lvl rhs_floats)       of { (rhs_floats', heres) ->
 356           (fs, rhs_floats', (con, bs', install heres rhs')) }}
 357
 358       --------------
 359       float_prim_alt (lit, rhs)
 360         = case (floatExpr 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', (lit, install heres rhs')) }}
 363
 364       --------------
 365       float_deflt NoDefault = (zero_stats, [], NoDefault)
 366
 367       float_deflt (BindDefault (b,lvl) rhs)
 368         = case (floatExpr new_env lvl rhs)              of { (fs, rhs_floats, rhs') ->
 369           case (partition_fn incd_lvl rhs_floats)       of { (rhs_floats', heres) ->
 370           (fs, rhs_floats', BindDefault b (install heres rhs')) }}
 371         where
 372           new_env = addOneToIdEnv env b lvl
 373 \end{code}
 374
 375 %************************************************************************
 376 %*                                                                      *
 377 \subsection{Utility bits for floating stats}
 378 %*                                                                      *
 379 %************************************************************************
 380
 381 I didn't implement this with unboxed numbers.  I don't want to be too
 382 strict in this stuff, as it is rarely turned on.  (WDP 95/09)
 383
 384 \begin{code}
 385 data FloatStats
 386   = FlS Int  -- Number of top-floats * lambda groups they've been past
 387         Int  -- Number of non-top-floats * lambda groups they've been past
 388         Int  -- Number of lambda (groups) seen
 389
 390 get_stats (FlS a b c) = (a, b, c)
 391
 392 zero_stats = FlS 0 0 0
 393
 394 sum_stats xs = foldr add_stats zero_stats xs
 395
 396 add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
 397   = FlS (a1 + a2) (b1 + b2) (c1 + c2)
 398
 399 add_to_stats (FlS a b c) floats
 400   = FlS (a + length top_floats) (b + length other_floats) (c + 1)
 401   where
 402     (top_floats, other_floats) = partition to_very_top floats
 403
 404     to_very_top (my_lvl, _) = isTopLvl my_lvl
 405 \end{code}
 406
 407 %************************************************************************
 408 %*                                                                      *
 409 \subsection{Utility bits for floating}
 410 %*                                                                      *
 411 %************************************************************************
 412
 413 \begin{code}
 414 getBindLevel (NonRec (_, lvl) _)      = lvl
 415 getBindLevel (Rec (((_,lvl), _) : _)) = lvl
 416 \end{code}
 417
 418 \begin{code}
 419 partitionByMajorLevel, partitionByLevel
 420         :: Level                -- Partitioning level
 421
 422         -> FloatingBinds        -- Defns to be divided into 2 piles...
 423
 424         -> (FloatingBinds,      -- Defns  with level strictly < partition level,
 425             FloatingBinds)      -- The rest
 426
 427
 428 partitionByMajorLevel ctxt_lvl defns
 429   = partition float_further defns
 430   where
 431     float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl ||
 432                                 isTopLvl my_lvl
 433
 434 partitionByLevel ctxt_lvl defns
 435   = partition float_further defns
 436   where
 437     float_further (my_lvl, _) = my_lvl `ltLvl` ctxt_lvl
 438 \end{code}
 439
 440 \begin{code}
 441 floatsToBinds :: FloatingBinds -> [CoreBinding]
 442 floatsToBinds floats = map get_bind floats
 443                      where
 444                        get_bind (_, LetFloater bind) = bind
 445                        get_bind (_, CaseFloater _)   = panic "floatsToBinds"
 446
 447 floatsToBindPairs :: FloatingBinds -> [(Id,CoreExpr)]
 448
 449 floatsToBindPairs floats = concat (map mk_pairs floats)
 450   where
 451    mk_pairs (_, LetFloater (Rec pairs))         = pairs
 452    mk_pairs (_, LetFloater (NonRec binder rhs)) = [(binder,rhs)]
 453    mk_pairs (_, CaseFloater _)                    = panic "floatsToBindPairs"
 454
 455 install :: FloatingBinds -> CoreExpr -> CoreExpr
 456
 457 install defn_groups expr
 458   = foldr install_group expr defn_groups
 459   where
 460     install_group (_, LetFloater defns) body = Let defns body
 461     install_group (_, CaseFloater fn)   body = fn body
 462 \end{code}