ghc/compiler/simplCore/FloatOut.lhs

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