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