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 FreeVars         ( CoreExprWithFVs, freeVars, freeVarsOf )
  23 import Var              ( Id )
  24 import VarSet
  25 import Util             ( zipEqual )
  26 import Outputable
  27 \end{code}
  28
  29 Top-level interface function, @floatInwards@.  Note that we do not
  30 actually float any bindings downwards from the top-level.
  31
  32 \begin{code}
  33 floatInwards :: [CoreBind] -> IO [CoreBind]
  34
  35 floatInwards binds
  36   = do {
  37         beginPass "Float inwards";
  38         let { binds' = map fi_top_bind binds };
  39         endPass "Float inwards"
  40                 opt_D_verbose_core2core         {- no specific flag for dumping float-in -}
  41                 binds'
  42     }
  43
  44   where
  45     fi_top_bind (NonRec binder rhs)
  46       = NonRec binder (fiExpr [] (freeVars rhs))
  47     fi_top_bind (Rec pairs)
  48       = Rec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ]
  49 \end{code}
  50
  51 %************************************************************************
  52 %*                                                                      *
  53 \subsection{Mail from Andr\'e [edited]}
  54 %*                                                                      *
  55 %************************************************************************
  56
  57 {\em Will wrote: What??? I thought the idea was to float as far
  58 inwards as possible, no matter what.  This is dropping all bindings
  59 every time it sees a lambda of any kind.  Help! }
  60
  61 You are assuming we DO DO full laziness AFTER floating inwards!  We
  62 have to [not float inside lambdas] if we don't.
  63
  64 If we indeed do full laziness after the floating inwards (we could
  65 check the compilation flags for that) then I agree we could be more
  66 aggressive and do float inwards past lambdas.
  67
  68 Actually we are not doing a proper full laziness (see below), which
  69 was another reason for not floating inwards past a lambda.
  70
  71 This can easily be fixed.  The problem is that we float lets outwards,
  72 but there are a few expressions which are not let bound, like case
  73 scrutinees and case alternatives.  After floating inwards the
  74 simplifier could decide to inline the let and the laziness would be
  75 lost, e.g.
  76
  77 \begin{verbatim}
  78 let a = expensive             ==> \b -> case expensive of ...
  79 in \ b -> case a of ...
  80 \end{verbatim}
  81 The fix is
  82 \begin{enumerate}
  83 \item
  84 to let bind the algebraic case scrutinees (done, I think) and
  85 the case alternatives (except the ones with an
  86 unboxed type)(not done, I think). This is best done in the
  87 SetLevels.lhs module, which tags things with their level numbers.
  88 \item
  89 do the full laziness pass (floating lets outwards).
  90 \item
  91 simplify. The simplifier inlines the (trivial) lets that were
  92  created but were not floated outwards.
  93 \end{enumerate}
  94
  95 With the fix I think Will's suggestion that we can gain even more from
  96 strictness by floating inwards past lambdas makes sense.
  97
  98 We still gain even without going past lambdas, as things may be
  99 strict in the (new) context of a branch (where it was floated to) or
 100 of a let rhs, e.g.
 101 \begin{verbatim}
 102 let a = something            case x of
 103 in case x of                   alt1 -> case something of a -> a + a
 104      alt1 -> a + a      ==>    alt2 -> b
 105      alt2 -> b
 106
 107 let a = something           let b = case something of a -> a + a
 108 in let b = a + a        ==> in (b,b)
 109 in (b,b)
 110 \end{verbatim}
 111 Also, even if a is not found to be strict in the new context and is
 112 still left as a let, if the branch is not taken (or b is not entered)
 113 the closure for a is not built.
 114
 115 %************************************************************************
 116 %*                                                                      *
 117 \subsection{Main floating-inwards code}
 118 %*                                                                      *
 119 %************************************************************************
 120
 121 \begin{code}
 122 type FreeVarsSet   = IdSet
 123
 124 type FloatingBinds = [(CoreBind, FreeVarsSet)]
 125         -- In reverse dependency order (innermost bindiner first)
 126
 127         -- The FreeVarsSet is the free variables of the binding.  In the case
 128         -- of recursive bindings, the set doesn't include the bound
 129         -- variables.
 130
 131 fiExpr :: FloatingBinds         -- Binds we're trying to drop
 132                                 -- as far "inwards" as possible
 133        -> CoreExprWithFVs       -- Input expr
 134        -> CoreExpr              -- Result
 135
 136 fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v)
 137
 138 fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
 139                                  Type ty
 140
 141 fiExpr to_drop (_, AnnCon c args)
 142    = mkCoLets' drop_here (Con c args')
 143    where
 144      (drop_here : arg_drops) = sepBindsByDropPoint (map freeVarsOf args) to_drop
 145      args'                   = zipWith fiExpr arg_drops args
 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 [freeVarsOf fun, freeVarsOf arg] to_drop
 157 \end{code}
 158
 159 We are careful about lambdas:
 160
 161 * We never float inside a value lambda.  That risks losing laziness.
 162   The float-out pass might rescue us, but then again it might not.
 163
 164 * We don't float inside type lambdas either.  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 the simple thing is never to float inside big lambda either.
 176 Maybe we'll find cases when that loses something important; if
 177 so we can modify the decision.
 178
 179 \begin{code}
 180 fiExpr to_drop (_, AnnLam b body)
 181   = mkCoLets' to_drop (Lam b (fiExpr [] body))
 182 \end{code}
 183
 184 We don't float lets inwards past an SCC.
 185         ToDo: keep info on current cc, and when passing
 186         one, if it is not the same, annotate all lets in binds with current
 187         cc, change current cc to the new one and float binds into expr.
 188
 189 \begin{code}
 190 fiExpr to_drop (_, AnnNote note@(SCC cc) expr)
 191   =     -- Wimp out for now
 192     mkCoLets' to_drop (Note note (fiExpr [] expr))
 193
 194 fiExpr to_drop (_, AnnNote InlineCall expr)
 195   =     -- Wimp out for InlineCall; keep it close
 196         -- the the call it annotates
 197     mkCoLets' to_drop (Note InlineCall (fiExpr [] expr))
 198
 199 fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr)
 200   =     -- Just float in past coercion
 201     Note note (fiExpr to_drop expr)
 202
 203 fiExpr to_drop (_, AnnNote note@(TermUsg _) expr)
 204   =     -- Float in past term usage annotation
 205         -- (for now; not sure if this is correct: KSW 1999-05)
 206     Note note (fiExpr to_drop expr)
 207 \end{code}
 208
 209 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
 210 bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
 211 or~(b2), in each of the RHSs of the pairs of a @Rec@.
 212
 213 Note that we do {\em weird things} with this let's binding.  Consider:
 214 \begin{verbatim}
 215 let
 216     w = ...
 217 in {
 218     let v = ... w ...
 219     in ... w ...
 220 }
 221 \end{verbatim}
 222 Look at the inner \tr{let}.  As \tr{w} is used in both the bind and
 223 body of the inner let, we could panic and leave \tr{w}'s binding where
 224 it is.  But \tr{v} is floatable into the body of the inner let, and
 225 {\em then} \tr{w} will also be only in the body of that inner let.
 226
 227 So: rather than drop \tr{w}'s binding here, we add it onto the list of
 228 things to drop in the outer let's body, and let nature take its
 229 course.
 230
 231 \begin{code}
 232 fiExpr to_drop (_,AnnLet (AnnNonRec id rhs) body)
 233   = fiExpr new_to_drop body
 234   where
 235     rhs_fvs  = freeVarsOf rhs
 236     body_fvs = freeVarsOf body
 237
 238     [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint [rhs_fvs, body_fvs] to_drop
 239
 240     new_to_drop = body_binds ++                         -- the bindings used only in the body
 241                   [(NonRec id rhs', rhs_fvs')] ++       -- the new binding itself
 242                   shared_binds                          -- the bindings used both in rhs and body
 243
 244         -- Push rhs_binds into the right hand side of the binding
 245     rhs'     = fiExpr rhs_binds rhs
 246     rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds
 247
 248 fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
 249   = fiExpr new_to_drop body
 250   where
 251     (binders, rhss) = unzip bindings
 252
 253     rhss_fvs = map freeVarsOf rhss
 254     body_fvs = freeVarsOf body
 255
 256     (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint (body_fvs:rhss_fvs) to_drop
 257
 258     new_to_drop = -- the bindings used only in the body
 259                   body_binds ++
 260                   -- the new binding itself
 261                   [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++
 262                   -- the bindings used both in rhs and body or in more than one rhs
 263                   shared_binds
 264
 265     rhs_fvs' = unionVarSet (unionVarSets rhss_fvs)
 266                            (unionVarSets (map floatedBindsFVs rhss_binds))
 267
 268     -- Push rhs_binds into the right hand side of the binding
 269     fi_bind :: [FloatingBinds]      -- one per "drop pt" conjured w/ fvs_of_rhss
 270             -> [(Id, CoreExprWithFVs)]
 271             -> [(Id, CoreExpr)]
 272
 273     fi_bind to_drops pairs
 274       = [ (binder, fiExpr to_drop rhs)
 275         | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
 276 \end{code}
 277
 278 For @Case@, the possible ``drop points'' for the \tr{to_drop}
 279 bindings are: (a)~inside the scrutinee, (b)~inside one of the
 280 alternatives/default [default FVs always {\em first}!].
 281
 282 \begin{code}
 283 fiExpr to_drop (_, AnnCase scrut case_bndr alts)
 284   = mkCoLets' drop_here (Case (fiExpr scrut_drops scrut) case_bndr
 285                               (zipWith fi_alt alts_drops alts))
 286   where
 287     (drop_here : scrut_drops : alts_drops) = sepBindsByDropPoint (scrut_fvs : alts_fvs) to_drop
 288     scrut_fvs = freeVarsOf scrut
 289     alts_fvs  = map alt_fvs alts
 290     alt_fvs (con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args)
 291                                 -- Delete case_bndr and args from free vars of rhs
 292                                 -- to get free vars of alt
 293
 294     fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
 295 \end{code}
 296
 297
 298 %************************************************************************
 299 %*                                                                      *
 300 \subsection{@sepBindsByDropPoint@}
 301 %*                                                                      *
 302 %************************************************************************
 303
 304 This is the crucial function.  The idea is: We have a wad of bindings
 305 that we'd like to distribute inside a collection of {\em drop points};
 306 insides the alternatives of a \tr{case} would be one example of some
 307 drop points; the RHS and body of a non-recursive \tr{let} binding
 308 would be another (2-element) collection.
 309
 310 So: We're given a list of sets-of-free-variables, one per drop point,
 311 and a list of floating-inwards bindings.  If a binding can go into
 312 only one drop point (without suddenly making something out-of-scope),
 313 in it goes.  If a binding is used inside {\em multiple} drop points,
 314 then it has to go in a you-must-drop-it-above-all-these-drop-points
 315 point.
 316
 317 We have to maintain the order on these drop-point-related lists.
 318
 319 \begin{code}
 320 sepBindsByDropPoint
 321     :: [FreeVarsSet]        -- One set of FVs per drop point
 322     -> FloatingBinds        -- Candidate floaters
 323     -> [FloatingBinds]      -- FIRST one is bindings which must not be floated
 324                             -- inside any drop point; the rest correspond
 325                             -- one-to-one with the input list of FV sets
 326
 327 -- Every input floater is returned somewhere in the result;
 328 -- none are dropped, not even ones which don't seem to be
 329 -- free in *any* of the drop-point fvs.  Why?  Because, for example,
 330 -- a binding (let x = E in B) might have a specialised version of
 331 -- x (say x') stored inside x, but x' isn't free in E or B.
 332
 333 sepBindsByDropPoint drop_pts []
 334   = [] : [[] | p <- drop_pts]   -- cut to the chase scene; it happens
 335
 336 sepBindsByDropPoint drop_pts floaters
 337   = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts))
 338   where
 339     go :: FloatingBinds -> [(FreeVarsSet, FloatingBinds)] -> [FloatingBinds]
 340         -- The *first* one in the argument list is the drop_here set
 341         -- The FloatingBinds in the lists are in the reverse of
 342         -- the normal FloatingBinds order; that is, they are the right way round!
 343
 344     go [] drop_boxes = map (reverse . snd) drop_boxes
 345
 346     go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes
 347         = go binds (insert drop_boxes (drop_here : used_in_flags))
 348                 -- insert puts the find in box whose True flag comes first
 349         where
 350           (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind)
 351                                         | (fvs, drops) <- drop_boxes]
 352
 353           drop_here = used_here || not (exactlyOneTrue used_in_flags)
 354
 355           insert ((fvs,drops) : drop_boxes) (True : _)
 356                 = ((fvs `unionVarSet` bind_fvs, bind_w_fvs:drops) : drop_boxes)
 357           insert (drop_box : drop_boxes) (False : others)
 358                 = drop_box : insert drop_boxes others
 359           insert _ _ = panic "sepBindsByDropPoint"      -- Should never happen
 360
 361 exactlyOneTrue :: [Bool] -> Bool
 362 exactlyOneTrue flags = case [() | True <- flags] of
 363                         [_]   -> True
 364                         other -> False
 365
 366 floatedBindsFVs :: FloatingBinds -> FreeVarsSet
 367 floatedBindsFVs binds = unionVarSets (map snd binds)
 368
 369 mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
 370 mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop
 371         -- Remember to_drop is in *reverse* dependency order
 372 \end{code}