compiler/simplCore/FloatIn.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[FloatIn]{Floating Inwards pass}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 The main purpose of @floatInwards@ is floating into branches of a
  11 case, so that we don't allocate things, save them on the stack, and
  12 then discover that they aren't needed in the chosen branch.
  13
  14 \begin{code}
  15 module FloatIn ( floatInwards ) where
  16
  17 #include "HsVersions.h"
  18
  19 import DynFlags ( DynFlags, DynFlag(..) )
  20 import CoreSyn
  21 import CoreUtils        ( exprIsHNF, exprIsDupable )
  22 import CoreLint         ( showPass, endPass )
  23 import CoreFVs          ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleVars )
  24 import Id               ( isOneShotBndr, idType )
  25 import Var
  26 import Type             ( isUnLiftedType )
  27 import VarSet
  28 import Util             ( zipEqual, zipWithEqual, count )
  29 import UniqFM
  30 import Outputable
  31 \end{code}
  32
  33 Top-level interface function, @floatInwards@.  Note that we do not
  34 actually float any bindings downwards from the top-level.
  35
  36 \begin{code}
  37 floatInwards :: DynFlags -> [CoreBind] -> IO [CoreBind]
  38
  39 floatInwards dflags binds
  40   = do {
  41         showPass dflags "Float inwards";
  42         let { binds' = map fi_top_bind binds };
  43         endPass dflags "Float inwards" Opt_D_verbose_core2core binds'
  44                                 {- no specific flag for dumping float-in -}
  45     }
  46
  47   where
  48     fi_top_bind (NonRec binder rhs)
  49       = NonRec binder (fiExpr [] (freeVars rhs))
  50     fi_top_bind (Rec pairs)
  51       = Rec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ]
  52 \end{code}
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection{Mail from Andr\'e [edited]}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 {\em Will wrote: What??? I thought the idea was to float as far
  61 inwards as possible, no matter what.  This is dropping all bindings
  62 every time it sees a lambda of any kind.  Help! }
  63
  64 You are assuming we DO DO full laziness AFTER floating inwards!  We
  65 have to [not float inside lambdas] if we don't.
  66
  67 If we indeed do full laziness after the floating inwards (we could
  68 check the compilation flags for that) then I agree we could be more
  69 aggressive and do float inwards past lambdas.
  70
  71 Actually we are not doing a proper full laziness (see below), which
  72 was another reason for not floating inwards past a lambda.
  73
  74 This can easily be fixed.  The problem is that we float lets outwards,
  75 but there are a few expressions which are not let bound, like case
  76 scrutinees and case alternatives.  After floating inwards the
  77 simplifier could decide to inline the let and the laziness would be
  78 lost, e.g.
  79
  80 \begin{verbatim}
  81 let a = expensive             ==> \b -> case expensive of ...
  82 in \ b -> case a of ...
  83 \end{verbatim}
  84 The fix is
  85 \begin{enumerate}
  86 \item
  87 to let bind the algebraic case scrutinees (done, I think) and
  88 the case alternatives (except the ones with an
  89 unboxed type)(not done, I think). This is best done in the
  90 SetLevels.lhs module, which tags things with their level numbers.
  91 \item
  92 do the full laziness pass (floating lets outwards).
  93 \item
  94 simplify. The simplifier inlines the (trivial) lets that were
  95  created but were not floated outwards.
  96 \end{enumerate}
  97
  98 With the fix I think Will's suggestion that we can gain even more from
  99 strictness by floating inwards past lambdas makes sense.
 100
 101 We still gain even without going past lambdas, as things may be
 102 strict in the (new) context of a branch (where it was floated to) or
 103 of a let rhs, e.g.
 104 \begin{verbatim}
 105 let a = something            case x of
 106 in case x of                   alt1 -> case something of a -> a + a
 107      alt1 -> a + a      ==>    alt2 -> b
 108      alt2 -> b
 109
 110 let a = something           let b = case something of a -> a + a
 111 in let b = a + a        ==> in (b,b)
 112 in (b,b)
 113 \end{verbatim}
 114 Also, even if a is not found to be strict in the new context and is
 115 still left as a let, if the branch is not taken (or b is not entered)
 116 the closure for a is not built.
 117
 118 %************************************************************************
 119 %*                                                                      *
 120 \subsection{Main floating-inwards code}
 121 %*                                                                      *
 122 %************************************************************************
 123
 124 \begin{code}
 125 type FreeVarsSet   = IdSet
 126
 127 type FloatingBinds = [(CoreBind, FreeVarsSet)]
 128         -- In reverse dependency order (innermost binder first)
 129
 130         -- The FreeVarsSet is the free variables of the binding.  In the case
 131         -- of recursive bindings, the set doesn't include the bound
 132         -- variables.
 133
 134 fiExpr :: FloatingBinds         -- Binds we're trying to drop
 135                                 -- as far "inwards" as possible
 136        -> CoreExprWithFVs       -- Input expr
 137        -> CoreExpr              -- Result
 138
 139 fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v)
 140
 141 fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
 142                                  Type ty
 143 fiExpr to_drop (_, AnnCast expr co)
 144   = Cast (fiExpr to_drop expr) co       -- Just float in past coercion
 145
 146 fiExpr _ (_, AnnLit lit) = Lit lit
 147 \end{code}
 148
 149 Applications: we do float inside applications, mainly because we
 150 need to get at all the arguments.  The next simplifier run will
 151 pull out any silly ones.
 152
 153 \begin{code}
 154 fiExpr to_drop (_,AnnApp fun arg)
 155   = mkCoLets' drop_here (App (fiExpr fun_drop fun) (fiExpr arg_drop arg))
 156   where
 157     [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop
 158 \end{code}
 159
 160 Note [Floating in past a lambda group]
 161 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 162 * We must be careful about floating inside inside a value lambda.
 163   That risks losing laziness.
 164   The float-out pass might rescue us, but then again it might not.
 165
 166 * We must be careful about type lambdas too.  At one time we did, and
 167   there is no risk of duplicating work thereby, but we do need to be
 168   careful.  In particular, here is a bad case (it happened in the
 169   cichelli benchmark:
 170         let v = ...
 171         in let f = /\t -> \a -> ...
 172            ==>
 173         let f = /\t -> let v = ... in \a -> ...
 174   This is bad as now f is an updatable closure (update PAP)
 175   and has arity 0.
 176
 177 * Hack alert!  We only float in through one-shot lambdas,
 178   not (as you might guess) through lone big lambdas.
 179   Reason: we float *out* past big lambdas (see the test in the Lam
 180   case of FloatOut.floatExpr) and we don't want to float straight
 181   back in again.
 182
 183   It *is* important to float into one-shot lambdas, however;
 184   see the remarks with noFloatIntoRhs.
 185
 186 So we treat lambda in groups, using the following rule:
 187
 188  Float in if (a) there is at least one Id,
 189          and (b) there are no non-one-shot Ids
 190
 191  Otherwise drop all the bindings outside the group.
 192
 193 This is what the 'go' function in the AnnLam case is doing.
 194
 195 Urk! if all are tyvars, and we don't float in, we may miss an
 196       opportunity to float inside a nested case branch
 197
 198 \begin{code}
 199 fiExpr to_drop lam@(_, AnnLam _ _)
 200   | go False bndrs      -- Float in
 201   = mkLams bndrs (fiExpr to_drop body)
 202
 203   | otherwise           -- Dump it all here
 204   = mkCoLets' to_drop (mkLams bndrs (fiExpr [] body))
 205
 206   where
 207     (bndrs, body) = collectAnnBndrs lam
 208
 209     go seen_one_shot_id [] = seen_one_shot_id
 210     go seen_one_shot_id (b:bs)
 211       | isTyVar       b = go seen_one_shot_id bs
 212       | isOneShotBndr b = go True bs
 213       | otherwise       = False  -- Give up at a non-one-shot Id
 214 \end{code}
 215
 216 We don't float lets inwards past an SCC.
 217         ToDo: keep info on current cc, and when passing
 218         one, if it is not the same, annotate all lets in binds with current
 219         cc, change current cc to the new one and float binds into expr.
 220
 221 \begin{code}
 222 fiExpr to_drop (_, AnnNote note@(SCC _) expr)
 223   =     -- Wimp out for now
 224     mkCoLets' to_drop (Note note (fiExpr [] expr))
 225
 226 fiExpr to_drop (_, AnnNote InlineMe expr)
 227   =     -- Ditto... don't float anything into an INLINE expression
 228     mkCoLets' to_drop (Note InlineMe (fiExpr [] expr))
 229
 230 fiExpr to_drop (_, AnnNote note@(CoreNote _) expr)
 231   = Note note (fiExpr to_drop expr)
 232 \end{code}
 233
 234 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
 235 bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
 236 or~(b2), in each of the RHSs of the pairs of a @Rec@.
 237
 238 Note that we do {\em weird things} with this let's binding.  Consider:
 239 \begin{verbatim}
 240 let
 241     w = ...
 242 in {
 243     let v = ... w ...
 244     in ... v .. w ...
 245 }
 246 \end{verbatim}
 247 Look at the inner \tr{let}.  As \tr{w} is used in both the bind and
 248 body of the inner let, we could panic and leave \tr{w}'s binding where
 249 it is.  But \tr{v} is floatable further into the body of the inner let, and
 250 {\em then} \tr{w} will also be only in the body of that inner let.
 251
 252 So: rather than drop \tr{w}'s binding here, we add it onto the list of
 253 things to drop in the outer let's body, and let nature take its
 254 course.
 255
 256 Note [extra_fvs (1): avoid floating into RHS]
 257 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 258 Consdider let x=\y....t... in body.  We do not necessarily want to float
 259 a binding for t into the RHS, because it'll immediately be floated out
 260 again.  (It won't go inside the lambda else we risk losing work.)
 261 In letrec, we need to be more careful still. We don't want to transform
 262         let x# = y# +# 1#
 263         in
 264         letrec f = \z. ...x#...f...
 265         in ...
 266 into
 267         letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...
 268 because now we can't float the let out again, because a letrec
 269 can't have unboxed bindings.
 270
 271 So we make "extra_fvs" which is the rhs_fvs of such bindings, and
 272 arrange to dump bindings that bind extra_fvs before the entire let.
 273
 274 Note [extra_fvs (s): free variables of rules]
 275 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 276 Consider let x{rule mentioning y} = rhs in body
 277 Here y is not free in rhs or body; but we still want to dump bindings
 278 that bind y outside the let.  So we augment extra_fvs with the
 279 idRuleVars of x.
 280
 281
 282 \begin{code}
 283 fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
 284   = fiExpr new_to_drop body
 285   where
 286     body_fvs = freeVarsOf body
 287
 288     rule_fvs = idRuleVars id    -- See Note [extra_fvs (2): free variables of rules]
 289     extra_fvs | noFloatIntoRhs ann_rhs
 290               || isUnLiftedType (idType id) = rule_fvs `unionVarSet` rhs_fvs
 291               | otherwise                   = rule_fvs
 292         -- See Note [extra_fvs (2): avoid floating into RHS]
 293         -- No point in floating in only to float straight out again
 294         -- Ditto ok-for-speculation unlifted RHSs
 295
 296     [shared_binds, extra_binds, rhs_binds, body_binds]
 297         = sepBindsByDropPoint False [extra_fvs, rhs_fvs, body_fvs] to_drop
 298
 299     new_to_drop = body_binds ++                         -- the bindings used only in the body
 300                   [(NonRec id rhs', rhs_fvs')] ++       -- the new binding itself
 301                   extra_binds ++                        -- bindings from extra_fvs
 302                   shared_binds                          -- the bindings used both in rhs and body
 303
 304         -- Push rhs_binds into the right hand side of the binding
 305     rhs'     = fiExpr rhs_binds rhs
 306     rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds `unionVarSet` rule_fvs
 307                         -- Don't forget the rule_fvs; the binding mentions them!
 308
 309 fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
 310   = fiExpr new_to_drop body
 311   where
 312     (ids, rhss) = unzip bindings
 313     rhss_fvs = map freeVarsOf rhss
 314     body_fvs = freeVarsOf body
 315
 316         -- See Note [extra_fvs (1,2)]
 317     rule_fvs = foldr (unionVarSet . idRuleVars) emptyVarSet ids
 318     extra_fvs = rule_fvs `unionVarSet`
 319                 unionVarSets [ fvs | (fvs, rhs) <- rhss
 320                              , noFloatIntoRhs rhs ]
 321
 322     (shared_binds:extra_binds:body_binds:rhss_binds)
 323         = sepBindsByDropPoint False (extra_fvs:body_fvs:rhss_fvs) to_drop
 324
 325     new_to_drop = body_binds ++         -- the bindings used only in the body
 326                   [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++
 327                                         -- The new binding itself
 328                   extra_binds ++        -- Note [extra_fvs (1,2)]
 329                   shared_binds          -- Used in more than one place
 330
 331     rhs_fvs' = unionVarSets rhss_fvs `unionVarSet`
 332                unionVarSets (map floatedBindsFVs rhss_binds) `unionVarSet`
 333                rule_fvs         -- Don't forget the rule variables!
 334
 335     -- Push rhs_binds into the right hand side of the binding
 336     fi_bind :: [FloatingBinds]      -- one per "drop pt" conjured w/ fvs_of_rhss
 337             -> [(Id, CoreExprWithFVs)]
 338             -> [(Id, CoreExpr)]
 339
 340     fi_bind to_drops pairs
 341       = [ (binder, fiExpr to_drop rhs)
 342         | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
 343 \end{code}
 344
 345 For @Case@, the possible ``drop points'' for the \tr{to_drop}
 346 bindings are: (a)~inside the scrutinee, (b)~inside one of the
 347 alternatives/default [default FVs always {\em first}!].
 348
 349 \begin{code}
 350 fiExpr to_drop (_, AnnCase scrut case_bndr ty alts)
 351   = mkCoLets' drop_here1 $
 352     mkCoLets' drop_here2 $
 353     Case (fiExpr scrut_drops scrut) case_bndr ty
 354          (zipWith fi_alt alts_drops_s alts)
 355   where
 356         -- Float into the scrut and alts-considered-together just like App
 357     [drop_here1, scrut_drops, alts_drops] = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop
 358
 359         -- Float into the alts with the is_case flag set
 360     (drop_here2 : alts_drops_s)           = sepBindsByDropPoint True alts_fvs alts_drops
 361
 362     scrut_fvs    = freeVarsOf scrut
 363     alts_fvs     = map alt_fvs alts
 364     all_alts_fvs = unionVarSets alts_fvs
 365     alt_fvs (_con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args)
 366                                 -- Delete case_bndr and args from free vars of rhs
 367                                 -- to get free vars of alt
 368
 369     fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
 370
 371 noFloatIntoRhs :: AnnExpr' Var (UniqFM Var) -> Bool
 372 noFloatIntoRhs (AnnNote InlineMe _) = True
 373 noFloatIntoRhs (AnnLam b _)         = not (is_one_shot b)
 374         -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top.
 375         -- This makes a big difference for things like
 376         --      f x# = let x = I# x#
 377         --             in let j = \() -> ...x...
 378         --                in if <condition> then normal-path else j ()
 379         -- If x is used only in the error case join point, j, we must float the
 380         -- boxing constructor into it, else we box it every time which is very bad
 381         -- news indeed.
 382
 383 noFloatIntoRhs rhs = exprIsHNF (deAnnotate' rhs)        -- We'd just float right back out again...
 384
 385 is_one_shot :: Var -> Bool
 386 is_one_shot b = isIdVar b && isOneShotBndr b
 387 \end{code}
 388
 389
 390 %************************************************************************
 391 %*                                                                      *
 392 \subsection{@sepBindsByDropPoint@}
 393 %*                                                                      *
 394 %************************************************************************
 395
 396 This is the crucial function.  The idea is: We have a wad of bindings
 397 that we'd like to distribute inside a collection of {\em drop points};
 398 insides the alternatives of a \tr{case} would be one example of some
 399 drop points; the RHS and body of a non-recursive \tr{let} binding
 400 would be another (2-element) collection.
 401
 402 So: We're given a list of sets-of-free-variables, one per drop point,
 403 and a list of floating-inwards bindings.  If a binding can go into
 404 only one drop point (without suddenly making something out-of-scope),
 405 in it goes.  If a binding is used inside {\em multiple} drop points,
 406 then it has to go in a you-must-drop-it-above-all-these-drop-points
 407 point.
 408
 409 We have to maintain the order on these drop-point-related lists.
 410
 411 \begin{code}
 412 sepBindsByDropPoint
 413     :: Bool                 -- True <=> is case expression
 414     -> [FreeVarsSet]        -- One set of FVs per drop point
 415     -> FloatingBinds        -- Candidate floaters
 416     -> [FloatingBinds]      -- FIRST one is bindings which must not be floated
 417                             -- inside any drop point; the rest correspond
 418                             -- one-to-one with the input list of FV sets
 419
 420 -- Every input floater is returned somewhere in the result;
 421 -- none are dropped, not even ones which don't seem to be
 422 -- free in *any* of the drop-point fvs.  Why?  Because, for example,
 423 -- a binding (let x = E in B) might have a specialised version of
 424 -- x (say x') stored inside x, but x' isn't free in E or B.
 425
 426 type DropBox = (FreeVarsSet, FloatingBinds)
 427
 428 sepBindsByDropPoint _is_case drop_pts []
 429   = [] : [[] | _ <- drop_pts]   -- cut to the chase scene; it happens
 430
 431 sepBindsByDropPoint is_case drop_pts floaters
 432   = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts))
 433   where
 434     go :: FloatingBinds -> [DropBox] -> [FloatingBinds]
 435         -- The *first* one in the argument list is the drop_here set
 436         -- The FloatingBinds in the lists are in the reverse of
 437         -- the normal FloatingBinds order; that is, they are the right way round!
 438
 439     go [] drop_boxes = map (reverse . snd) drop_boxes
 440
 441     go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes@(here_box : fork_boxes)
 442         = go binds new_boxes
 443         where
 444           -- "here" means the group of bindings dropped at the top of the fork
 445
 446           (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind)
 447                                         | (fvs, _) <- drop_boxes]
 448
 449           drop_here = used_here || not can_push
 450
 451                 -- For case expressions we duplicate the binding if it is
 452                 -- reasonably small, and if it is not used in all the RHSs
 453                 -- This is good for situations like
 454                 --      let x = I# y in
 455                 --      case e of
 456                 --        C -> error x
 457                 --        D -> error x
 458                 --        E -> ...not mentioning x...
 459
 460           n_alts      = length used_in_flags
 461           n_used_alts = count id used_in_flags -- returns number of Trues in list.
 462
 463           can_push = n_used_alts == 1           -- Used in just one branch
 464                    || (is_case &&               -- We are looking at case alternatives
 465                        n_used_alts > 1 &&       -- It's used in more than one
 466                        n_used_alts < n_alts &&  -- ...but not all
 467                        bindIsDupable bind)      -- and we can duplicate the binding
 468
 469           new_boxes | drop_here = (insert here_box : fork_boxes)
 470                     | otherwise = (here_box : new_fork_boxes)
 471
 472           new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe fork_boxes used_in_flags
 473
 474           insert :: DropBox -> DropBox
 475           insert (fvs,drops) = (fvs `unionVarSet` bind_fvs, bind_w_fvs:drops)
 476
 477           insert_maybe box True  = insert box
 478           insert_maybe box False = box
 479
 480     go _ _ = panic "sepBindsByDropPoint/go"
 481
 482
 483 floatedBindsFVs :: FloatingBinds -> FreeVarsSet
 484 floatedBindsFVs binds = unionVarSets (map snd binds)
 485
 486 mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
 487 mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop
 488         -- Remember to_drop is in *reverse* dependency order
 489
 490 bindIsDupable :: Bind CoreBndr -> Bool
 491 bindIsDupable (Rec prs)    = all (exprIsDupable . snd) prs
 492 bindIsDupable (NonRec _ r) = exprIsDupable r
 493 \end{code}