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 CoreLint         ( beginPass, endPass )
  22 import Const            ( isDataCon )
  23 import CoreFVs          ( CoreExprWithFVs, freeVars, freeVarsOf )
  24 import Var              ( Id, idType )
  25 import Type             ( isUnLiftedType )
  26 import VarSet
  27 import Util             ( zipEqual )
  28 import Outputable
  29 \end{code}
  30
  31 Top-level interface function, @floatInwards@.  Note that we do not
  32 actually float any bindings downwards from the top-level.
  33
  34 \begin{code}
  35 floatInwards :: [CoreBind] -> IO [CoreBind]
  36
  37 floatInwards binds
  38   = do {
  39         beginPass "Float inwards";
  40         let { binds' = map fi_top_bind binds };
  41         endPass "Float inwards"
  42                 opt_D_verbose_core2core         {- no specific flag for dumping float-in -}
  43                 binds'
  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 (_, AnnCon c args)
 144    = mkCoLets' drop_here (Con c args')
 145    where
 146      (drop_here : arg_drops) = sepBindsByDropPoint (map freeVarsOf args) to_drop
 147      args'                   = zipWith fiExpr arg_drops args
 148 \end{code}
 149
 150 Applications: we do float inside applications, mainly because we
 151 need to get at all the arguments.  The next simplifier run will
 152 pull out any silly ones.
 153
 154 \begin{code}
 155 fiExpr to_drop (_,AnnApp fun arg)
 156   = mkCoLets' drop_here (App (fiExpr fun_drop fun) (fiExpr arg_drop arg))
 157   where
 158     [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint [freeVarsOf fun, freeVarsOf arg] to_drop
 159 \end{code}
 160
 161 We are careful about lambdas:
 162
 163 * We never float inside a value lambda.  That risks losing laziness.
 164   The float-out pass might rescue us, but then again it might not.
 165
 166 * We don't float inside type lambdas either.  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 So the simple thing is never to float inside big lambda either.
 178 Maybe we'll find cases when that loses something important; if
 179 so we can modify the decision.
 180
 181 \begin{code}
 182 fiExpr to_drop (_, AnnLam b body)
 183   = mkCoLets' to_drop (Lam b (fiExpr [] body))
 184 \end{code}
 185
 186 We don't float lets inwards past an SCC.
 187         ToDo: keep info on current cc, and when passing
 188         one, if it is not the same, annotate all lets in binds with current
 189         cc, change current cc to the new one and float binds into expr.
 190
 191 \begin{code}
 192 fiExpr to_drop (_, AnnNote note@(SCC cc) expr)
 193   =     -- Wimp out for now
 194     mkCoLets' to_drop (Note note (fiExpr [] expr))
 195
 196 fiExpr to_drop (_, AnnNote InlineCall expr)
 197   =     -- Wimp out for InlineCall; keep it close
 198         -- the the call it annotates
 199     mkCoLets' to_drop (Note InlineCall (fiExpr [] expr))
 200
 201 fiExpr to_drop (_, AnnNote InlineMe expr)
 202   =     -- Ditto... don't float anything into an INLINE expression
 203     mkCoLets' to_drop (Note InlineMe (fiExpr [] expr))
 204
 205 fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr)
 206   =     -- Just float in past coercion
 207     Note note (fiExpr to_drop expr)
 208
 209 fiExpr to_drop (_, AnnNote note@(TermUsg _) expr)
 210   =     -- Float in past term usage annotation
 211         -- (for now; not sure if this is correct: KSW 1999-05)
 212     Note note (fiExpr to_drop expr)
 213 \end{code}
 214
 215 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
 216 bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
 217 or~(b2), in each of the RHSs of the pairs of a @Rec@.
 218
 219 Note that we do {\em weird things} with this let's binding.  Consider:
 220 \begin{verbatim}
 221 let
 222     w = ...
 223 in {
 224     let v = ... w ...
 225     in ... v .. w ...
 226 }
 227 \end{verbatim}
 228 Look at the inner \tr{let}.  As \tr{w} is used in both the bind and
 229 body of the inner let, we could panic and leave \tr{w}'s binding where
 230 it is.  But \tr{v} is floatable further into the body of the inner let, and
 231 {\em then} \tr{w} will also be only in the body of that inner let.
 232
 233 So: rather than drop \tr{w}'s binding here, we add it onto the list of
 234 things to drop in the outer let's body, and let nature take its
 235 course.
 236
 237 \begin{code}
 238 fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
 239   = fiExpr new_to_drop body
 240   where
 241     body_fvs = freeVarsOf body
 242
 243     final_body_fvs | noFloatIntoRhs ann_rhs
 244                    || isUnLiftedType (idType id) = body_fvs `unionVarSet` rhs_fvs
 245                    | otherwise                   = body_fvs
 246         -- See commments with letrec below
 247         -- No point in floating in only to float straight out again
 248         -- Ditto ok-for-speculation unlifted RHSs
 249
 250     [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint [rhs_fvs, final_body_fvs] to_drop
 251
 252     new_to_drop = body_binds ++                         -- the bindings used only in the body
 253                   [(NonRec id rhs', rhs_fvs')] ++       -- the new binding itself
 254                   shared_binds                          -- the bindings used both in rhs and body
 255
 256         -- Push rhs_binds into the right hand side of the binding
 257     rhs'     = fiExpr rhs_binds rhs
 258     rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds
 259
 260 fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
 261   = fiExpr new_to_drop body
 262   where
 263     (binders, rhss) = unzip bindings
 264
 265     rhss_fvs = map freeVarsOf rhss
 266     body_fvs = freeVarsOf body
 267
 268         -- Add to body_fvs the free vars of any RHS that has
 269         -- a lambda at the top.  This has the effect of making it seem
 270         -- that such things are used in the body as well, and hence prevents
 271         -- them getting floated in.  The big idea is to avoid turning:
 272         --      let x# = y# +# 1#
 273         --      in
 274         --      letrec f = \z. ...x#...f...
 275         --      in ...
 276         -- into
 277         --      letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...
 278         --
 279         -- Because now we can't float the let out again, because a letrec
 280         -- can't have unboxed bindings.
 281
 282     final_body_fvs = foldr (unionVarSet . get_extras) body_fvs rhss
 283     get_extras (rhs_fvs, rhs) | noFloatIntoRhs rhs = rhs_fvs
 284                               | otherwise          = emptyVarSet
 285
 286     (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint (final_body_fvs:rhss_fvs) to_drop
 287
 288     new_to_drop = -- the bindings used only in the body
 289                   body_binds ++
 290                   -- the new binding itself
 291                   [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++
 292                   -- the bindings used both in rhs and body or in more than one rhs
 293                   shared_binds
 294
 295     rhs_fvs' = unionVarSet (unionVarSets rhss_fvs)
 296                            (unionVarSets (map floatedBindsFVs rhss_binds))
 297
 298     -- Push rhs_binds into the right hand side of the binding
 299     fi_bind :: [FloatingBinds]      -- one per "drop pt" conjured w/ fvs_of_rhss
 300             -> [(Id, CoreExprWithFVs)]
 301             -> [(Id, CoreExpr)]
 302
 303     fi_bind to_drops pairs
 304       = [ (binder, fiExpr to_drop rhs)
 305         | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
 306 \end{code}
 307
 308 For @Case@, the possible ``drop points'' for the \tr{to_drop}
 309 bindings are: (a)~inside the scrutinee, (b)~inside one of the
 310 alternatives/default [default FVs always {\em first}!].
 311
 312 \begin{code}
 313 fiExpr to_drop (_, AnnCase scrut case_bndr alts)
 314   = mkCoLets' drop_here (Case (fiExpr scrut_drops scrut) case_bndr
 315                               (zipWith fi_alt alts_drops alts))
 316   where
 317     (drop_here : scrut_drops : alts_drops) = sepBindsByDropPoint (scrut_fvs : alts_fvs) to_drop
 318     scrut_fvs = freeVarsOf scrut
 319     alts_fvs  = map alt_fvs alts
 320     alt_fvs (con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args)
 321                                 -- Delete case_bndr and args from free vars of rhs
 322                                 -- to get free vars of alt
 323
 324     fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
 325
 326 noFloatIntoRhs (AnnNote InlineMe _) = True
 327 noFloatIntoRhs (AnnLam _ _)         = True
 328 noFloatIntoRhs (AnnCon con _)       = isDataCon con
 329 noFloatIntoRhs other                = False
 330 \end{code}
 331
 332
 333 %************************************************************************
 334 %*                                                                      *
 335 \subsection{@sepBindsByDropPoint@}
 336 %*                                                                      *
 337 %************************************************************************
 338
 339 This is the crucial function.  The idea is: We have a wad of bindings
 340 that we'd like to distribute inside a collection of {\em drop points};
 341 insides the alternatives of a \tr{case} would be one example of some
 342 drop points; the RHS and body of a non-recursive \tr{let} binding
 343 would be another (2-element) collection.
 344
 345 So: We're given a list of sets-of-free-variables, one per drop point,
 346 and a list of floating-inwards bindings.  If a binding can go into
 347 only one drop point (without suddenly making something out-of-scope),
 348 in it goes.  If a binding is used inside {\em multiple} drop points,
 349 then it has to go in a you-must-drop-it-above-all-these-drop-points
 350 point.
 351
 352 We have to maintain the order on these drop-point-related lists.
 353
 354 \begin{code}
 355 sepBindsByDropPoint
 356     :: [FreeVarsSet]        -- One set of FVs per drop point
 357     -> FloatingBinds        -- Candidate floaters
 358     -> [FloatingBinds]      -- FIRST one is bindings which must not be floated
 359                             -- inside any drop point; the rest correspond
 360                             -- one-to-one with the input list of FV sets
 361
 362 -- Every input floater is returned somewhere in the result;
 363 -- none are dropped, not even ones which don't seem to be
 364 -- free in *any* of the drop-point fvs.  Why?  Because, for example,
 365 -- a binding (let x = E in B) might have a specialised version of
 366 -- x (say x') stored inside x, but x' isn't free in E or B.
 367
 368 sepBindsByDropPoint drop_pts []
 369   = [] : [[] | p <- drop_pts]   -- cut to the chase scene; it happens
 370
 371 sepBindsByDropPoint drop_pts floaters
 372   = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts))
 373   where
 374     go :: FloatingBinds -> [(FreeVarsSet, FloatingBinds)] -> [FloatingBinds]
 375         -- The *first* one in the argument list is the drop_here set
 376         -- The FloatingBinds in the lists are in the reverse of
 377         -- the normal FloatingBinds order; that is, they are the right way round!
 378
 379     go [] drop_boxes = map (reverse . snd) drop_boxes
 380
 381     go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes
 382         = go binds (insert drop_boxes (drop_here : used_in_flags))
 383                 -- insert puts the find in box whose True flag comes first
 384         where
 385           (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind)
 386                                         | (fvs, drops) <- drop_boxes]
 387
 388           drop_here = used_here || not (exactlyOneTrue used_in_flags)
 389
 390           insert ((fvs,drops) : drop_boxes) (True : _)
 391                 = ((fvs `unionVarSet` bind_fvs, bind_w_fvs:drops) : drop_boxes)
 392           insert (drop_box : drop_boxes) (False : others)
 393                 = drop_box : insert drop_boxes others
 394           insert _ _ = panic "sepBindsByDropPoint"      -- Should never happen
 395
 396 exactlyOneTrue :: [Bool] -> Bool
 397 exactlyOneTrue flags = case [() | True <- flags] of
 398                         [_]   -> True
 399                         other -> False
 400
 401 floatedBindsFVs :: FloatingBinds -> FreeVarsSet
 402 floatedBindsFVs binds = unionVarSets (map snd binds)
 403
 404 mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
 405 mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop
 406         -- Remember to_drop is in *reverse* dependency order
 407 \end{code}