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