ghc/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 CmdLineOpts      ( opt_D_verbose_core2core )
  20 import CoreSyn
  21 import CoreUtils        ( exprIsValue, exprIsDupable )
  22 import CoreLint         ( beginPass, endPass )
  23 import CoreFVs          ( CoreExprWithFVs, freeVars, freeVarsOf )
  24 import Id               ( isOneShotLambda )
  25 import Var              ( Id, idType, isTyVar )
  26 import Type             ( isUnLiftedType )
  27 import VarSet
  28 import Util             ( zipEqual, zipWithEqual )
  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 :: [CoreBind] -> IO [CoreBind]
  37
  38 floatInwards binds
  39   = do {
  40         beginPass "Float inwards";
  41         let { binds' = map fi_top_bind binds };
  42         endPass "Float inwards"
  43                 opt_D_verbose_core2core         {- no specific flag for dumping float-in -}
  44                 binds'
  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 bindiner 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
 144 fiExpr to_drop (_, AnnLit lit) = Lit lit
 145 \end{code}
 146
 147 Applications: we do float inside applications, mainly because we
 148 need to get at all the arguments.  The next simplifier run will
 149 pull out any silly ones.
 150
 151 \begin{code}
 152 fiExpr to_drop (_,AnnApp fun arg)
 153   = mkCoLets' drop_here (App (fiExpr fun_drop fun) (fiExpr arg_drop arg))
 154   where
 155     [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop
 156 \end{code}
 157
 158 We are careful about lambdas:
 159
 160 * We must be careful about floating inside inside a value lambda.
 161   That risks losing laziness.
 162   The float-out pass might rescue us, but then again it might not.
 163
 164 * We must be careful about type lambdas too.  At one time we did, and
 165   there is no risk of duplicating work thereby, but we do need to be
 166   careful.  In particular, here is a bad case (it happened in the
 167   cichelli benchmark:
 168         let v = ...
 169         in let f = /\t -> \a -> ...
 170            ==>
 171         let f = /\t -> let v = ... in \a -> ...
 172   This is bad as now f is an updatable closure (update PAP)
 173   and has arity 0.
 174
 175 So we treat lambda in groups, using the following rule:
 176
 177         Float inside a group of lambdas only if
 178         they are all either type lambdas or one-shot lambdas.
 179
 180         Otherwise drop all the bindings outside the group.
 181
 182 \begin{code}
 183 fiExpr to_drop (_, AnnLam b body)
 184   = case collect [b] body of
 185       (bndrs, real_body)
 186         | all is_ok bndrs -> mkLams bndrs (fiExpr to_drop real_body)
 187         | otherwise       -> mkCoLets' to_drop (mkLams bndrs (fiExpr [] real_body))
 188   where
 189     collect bs (_, AnnLam b body) = collect (b:bs) body
 190     collect bs body               = (reverse bs, body)
 191
 192     is_ok bndr = isTyVar bndr || isOneShotLambda bndr
 193 \end{code}
 194
 195 We don't float lets inwards past an SCC.
 196         ToDo: keep info on current cc, and when passing
 197         one, if it is not the same, annotate all lets in binds with current
 198         cc, change current cc to the new one and float binds into expr.
 199
 200 \begin{code}
 201 fiExpr to_drop (_, AnnNote note@(SCC cc) expr)
 202   =     -- Wimp out for now
 203     mkCoLets' to_drop (Note note (fiExpr [] expr))
 204
 205 fiExpr to_drop (_, AnnNote InlineCall expr)
 206   =     -- Wimp out for InlineCall; keep it close
 207         -- the the call it annotates
 208     mkCoLets' to_drop (Note InlineCall (fiExpr [] expr))
 209
 210 fiExpr to_drop (_, AnnNote InlineMe expr)
 211   =     -- Ditto... don't float anything into an INLINE expression
 212     mkCoLets' to_drop (Note InlineMe (fiExpr [] expr))
 213
 214 fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr)
 215   =     -- Just float in past coercion
 216     Note note (fiExpr to_drop expr)
 217
 218 fiExpr to_drop (_, AnnNote note@(TermUsg _) expr)
 219   =     -- Float in past term usage annotation
 220         -- (for now; not sure if this is correct: KSW 1999-05)
 221     Note note (fiExpr to_drop expr)
 222 \end{code}
 223
 224 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
 225 bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
 226 or~(b2), in each of the RHSs of the pairs of a @Rec@.
 227
 228 Note that we do {\em weird things} with this let's binding.  Consider:
 229 \begin{verbatim}
 230 let
 231     w = ...
 232 in {
 233     let v = ... w ...
 234     in ... v .. w ...
 235 }
 236 \end{verbatim}
 237 Look at the inner \tr{let}.  As \tr{w} is used in both the bind and
 238 body of the inner let, we could panic and leave \tr{w}'s binding where
 239 it is.  But \tr{v} is floatable further into the body of the inner let, and
 240 {\em then} \tr{w} will also be only in the body of that inner let.
 241
 242 So: rather than drop \tr{w}'s binding here, we add it onto the list of
 243 things to drop in the outer let's body, and let nature take its
 244 course.
 245
 246 \begin{code}
 247 fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
 248   = fiExpr new_to_drop body
 249   where
 250     body_fvs = freeVarsOf body
 251
 252     final_body_fvs | noFloatIntoRhs ann_rhs
 253                    || isUnLiftedType (idType id) = body_fvs `unionVarSet` rhs_fvs
 254                    | otherwise                   = body_fvs
 255         -- See commments with letrec below
 256         -- No point in floating in only to float straight out again
 257         -- Ditto ok-for-speculation unlifted RHSs
 258
 259     [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint False [rhs_fvs, final_body_fvs] to_drop
 260
 261     new_to_drop = body_binds ++                         -- the bindings used only in the body
 262                   [(NonRec id rhs', rhs_fvs')] ++       -- the new binding itself
 263                   shared_binds                          -- the bindings used both in rhs and body
 264
 265         -- Push rhs_binds into the right hand side of the binding
 266     rhs'     = fiExpr rhs_binds rhs
 267     rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds
 268
 269 fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
 270   = fiExpr new_to_drop body
 271   where
 272     (binders, rhss) = unzip bindings
 273
 274     rhss_fvs = map freeVarsOf rhss
 275     body_fvs = freeVarsOf body
 276
 277         -- Add to body_fvs the free vars of any RHS that has
 278         -- a lambda at the top.  This has the effect of making it seem
 279         -- that such things are used in the body as well, and hence prevents
 280         -- them getting floated in.  The big idea is to avoid turning:
 281         --      let x# = y# +# 1#
 282         --      in
 283         --      letrec f = \z. ...x#...f...
 284         --      in ...
 285         -- into
 286         --      letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...
 287         --
 288         -- Because now we can't float the let out again, because a letrec
 289         -- can't have unboxed bindings.
 290
 291     final_body_fvs = foldr (unionVarSet . get_extras) body_fvs rhss
 292     get_extras (rhs_fvs, rhs) | noFloatIntoRhs rhs = rhs_fvs
 293                               | otherwise          = emptyVarSet
 294
 295     (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint False (final_body_fvs:rhss_fvs) to_drop
 296
 297     new_to_drop = -- the bindings used only in the body
 298                   body_binds ++
 299                   -- the new binding itself
 300                   [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++
 301                   -- the bindings used both in rhs and body or in more than one rhs
 302                   shared_binds
 303
 304     rhs_fvs' = unionVarSet (unionVarSets rhss_fvs)
 305                            (unionVarSets (map floatedBindsFVs rhss_binds))
 306
 307     -- Push rhs_binds into the right hand side of the binding
 308     fi_bind :: [FloatingBinds]      -- one per "drop pt" conjured w/ fvs_of_rhss
 309             -> [(Id, CoreExprWithFVs)]
 310             -> [(Id, CoreExpr)]
 311
 312     fi_bind to_drops pairs
 313       = [ (binder, fiExpr to_drop rhs)
 314         | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
 315 \end{code}
 316
 317 For @Case@, the possible ``drop points'' for the \tr{to_drop}
 318 bindings are: (a)~inside the scrutinee, (b)~inside one of the
 319 alternatives/default [default FVs always {\em first}!].
 320
 321 \begin{code}
 322 fiExpr to_drop (_, AnnCase scrut case_bndr alts)
 323   = mkCoLets' drop_here1 $
 324     mkCoLets' drop_here2 $
 325     Case (fiExpr scrut_drops scrut) case_bndr
 326          (zipWith fi_alt alts_drops_s alts)
 327   where
 328         -- Float into the scrut and alts-considered-together just like App
 329     [drop_here1, scrut_drops, alts_drops] = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop
 330
 331         -- Float into the alts with the is_case flag set
 332     (drop_here2 : alts_drops_s)           = sepBindsByDropPoint True alts_fvs alts_drops
 333
 334     scrut_fvs    = freeVarsOf scrut
 335     alts_fvs     = map alt_fvs alts
 336     all_alts_fvs = unionVarSets alts_fvs
 337     alt_fvs (con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args)
 338                                 -- Delete case_bndr and args from free vars of rhs
 339                                 -- to get free vars of alt
 340
 341     fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
 342
 343 noFloatIntoRhs (AnnNote InlineMe _) = True
 344 noFloatIntoRhs (AnnLam b _)         = not (isId b && isOneShotLambda b)
 345         -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top.
 346         -- This makes a big difference for things like
 347         --      f x# = let x = I# x#
 348         --             in let j = \() -> ...x...
 349         --                in if <condition> then normal-path else j ()
 350         -- If x is used only in the error case join point, j, we must float the
 351         -- boxing constructor into it, else we box it every time which is very bad
 352         -- news indeed.
 353
 354 noFloatIntoRhs rhs = exprIsValue (deAnnotate' rhs)      -- We'd just float rigt back out again...
 355 \end{code}
 356
 357
 358 %************************************************************************
 359 %*                                                                      *
 360 \subsection{@sepBindsByDropPoint@}
 361 %*                                                                      *
 362 %************************************************************************
 363
 364 This is the crucial function.  The idea is: We have a wad of bindings
 365 that we'd like to distribute inside a collection of {\em drop points};
 366 insides the alternatives of a \tr{case} would be one example of some
 367 drop points; the RHS and body of a non-recursive \tr{let} binding
 368 would be another (2-element) collection.
 369
 370 So: We're given a list of sets-of-free-variables, one per drop point,
 371 and a list of floating-inwards bindings.  If a binding can go into
 372 only one drop point (without suddenly making something out-of-scope),
 373 in it goes.  If a binding is used inside {\em multiple} drop points,
 374 then it has to go in a you-must-drop-it-above-all-these-drop-points
 375 point.
 376
 377 We have to maintain the order on these drop-point-related lists.
 378
 379 \begin{code}
 380 sepBindsByDropPoint
 381     :: Bool                 -- True <=> is case expression
 382     -> [FreeVarsSet]        -- One set of FVs per drop point
 383     -> FloatingBinds        -- Candidate floaters
 384     -> [FloatingBinds]      -- FIRST one is bindings which must not be floated
 385                             -- inside any drop point; the rest correspond
 386                             -- one-to-one with the input list of FV sets
 387
 388 -- Every input floater is returned somewhere in the result;
 389 -- none are dropped, not even ones which don't seem to be
 390 -- free in *any* of the drop-point fvs.  Why?  Because, for example,
 391 -- a binding (let x = E in B) might have a specialised version of
 392 -- x (say x') stored inside x, but x' isn't free in E or B.
 393
 394 type DropBox = (FreeVarsSet, FloatingBinds)
 395
 396 sepBindsByDropPoint is_case drop_pts []
 397   = [] : [[] | p <- drop_pts]   -- cut to the chase scene; it happens
 398
 399 sepBindsByDropPoint is_case drop_pts floaters
 400   = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts))
 401   where
 402     go :: FloatingBinds -> [DropBox] -> [FloatingBinds]
 403         -- The *first* one in the argument list is the drop_here set
 404         -- The FloatingBinds in the lists are in the reverse of
 405         -- the normal FloatingBinds order; that is, they are the right way round!
 406
 407     go [] drop_boxes = map (reverse . snd) drop_boxes
 408
 409     go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes@(here_box : fork_boxes)
 410         = go binds new_boxes
 411         where
 412           -- "here" means the group of bindings dropped at the top of the fork
 413
 414           (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind)
 415                                         | (fvs, drops) <- drop_boxes]
 416
 417           drop_here = used_here || not can_push
 418
 419                 -- For case expressions we duplicate the binding if it is
 420                 -- reasonably small, and if it is not used in all the RHSs
 421                 -- This is good for situations like
 422                 --      let x = I# y in
 423                 --      case e of
 424                 --        C -> error x
 425                 --        D -> error x
 426                 --        E -> ...not mentioning x...
 427
 428           n_alts      = length used_in_flags
 429           n_used_alts = length [() | True <- used_in_flags]
 430
 431           can_push = n_used_alts == 1           -- Used in just one branch
 432                    || (is_case &&               -- We are looking at case alternatives
 433                        n_used_alts > 1 &&       -- It's used in more than one
 434                        n_used_alts < n_alts &&  -- ...but not all
 435                        bindIsDupable bind)      -- and we can duplicate the binding
 436
 437           new_boxes | drop_here = (insert here_box : fork_boxes)
 438                     | otherwise = (here_box : new_fork_boxes)
 439
 440           new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe fork_boxes used_in_flags
 441
 442           insert :: DropBox -> DropBox
 443           insert (fvs,drops) = (fvs `unionVarSet` bind_fvs, bind_w_fvs:drops)
 444
 445           insert_maybe box True  = insert box
 446           insert_maybe box False = box
 447
 448
 449 floatedBindsFVs :: FloatingBinds -> FreeVarsSet
 450 floatedBindsFVs binds = unionVarSets (map snd binds)
 451
 452 mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
 453 mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop
 454         -- Remember to_drop is in *reverse* dependency order
 455
 456 bindIsDupable (Rec prs)    = all (exprIsDupable . snd) prs
 457 bindIsDupable (NonRec b r) = exprIsDupable r
 458 \end{code}