ghc/compiler/simplCore/FloatIn.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   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 #include "HsVersions.h"
  16
  17 module FloatIn (
  18         floatInwards
  19
  20         -- and to make the interface self-sufficient...
  21     ) where
  22
  23 import Ubiq{-uitous-}
  24
  25 import AnnCoreSyn
  26 import CoreSyn
  27
  28 import FreeVars
  29 import Id               ( emptyIdSet, unionIdSets, unionManyIdSets,
  30                           elementOfIdSet, IdSet(..)
  31                         )
  32 import Util             ( panic )
  33 \end{code}
  34
  35 Top-level interface function, @floatInwards@.  Note that we do not
  36 actually float any bindings downwards from the top-level.
  37
  38 \begin{code}
  39 floatInwards :: [CoreBinding] -> [CoreBinding]
  40
  41 floatInwards binds
  42   = map fi_top_bind binds
  43   where
  44     fi_top_bind (NonRec binder rhs)
  45       = NonRec binder (fiExpr [] (freeVars rhs))
  46     fi_top_bind (Rec pairs)
  47       = Rec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ]
  48 \end{code}
  49
  50 %************************************************************************
  51 %*                                                                      *
  52 \subsection{Mail from Andr\'e [edited]}
  53 %*                                                                      *
  54 %************************************************************************
  55
  56 {\em Will wrote: What??? I thought the idea was to float as far
  57 inwards as possible, no matter what.  This is dropping all bindings
  58 every time it sees a lambda of any kind.  Help! }
  59
  60 You are assuming we DO DO full laziness AFTER floating inwards!  We
  61 have to [not float inside lambdas] if we don't.
  62
  63 If we indeed do full laziness after the floating inwards (we could
  64 check the compilation flags for that) then I agree we could be more
  65 aggressive and do float inwards past lambdas.
  66
  67 Actually we are not doing a proper full laziness (see below), which
  68 was another reason for not floating inwards past a lambda.
  69
  70 This can easily be fixed.
  71 The problem is that we float lets outwards,
  72 but there are a few expressions which are not
  73 let bound, like case scrutinees and case alternatives.
  74 After floating inwards the simplifier could decide to inline
  75 the let and the laziness would be lost, e.g.
  76 \begin{verbatim}
  77 let a = expensive             ==> \b -> case expensive of ...
  78 in \ b -> case a of ...
  79 \end{verbatim}
  80 The fix is
  81 \begin{enumerate}
  82 \item
  83 to let bind the algebraic case scrutinees (done, I think) and
  84 the case alternatives (except the ones with an
  85 unboxed type)(not done, I think). This is best done in the
  86 SetLevels.lhs module, which tags things with their level numbers.
  87 \item
  88 do the full laziness pass (floating lets outwards).
  89 \item
  90 simplify. The simplifier inlines the (trivial) lets that were
  91  created but were not floated outwards.
  92 \end{enumerate}
  93
  94 With the fix I think Will's suggestion that we can gain even more from
  95 strictness by floating inwards past lambdas makes sense.
  96
  97 We still gain even without going past lambdas, as things may be
  98 strict in the (new) context of a branch (where it was floated to) or
  99 of a let rhs, e.g.
 100 \begin{verbatim}
 101 let a = something            case x of
 102 in case x of                   alt1 -> case something of a -> a + a
 103      alt1 -> a + a      ==>    alt2 -> b
 104      alt2 -> b
 105
 106 let a = something           let b = case something of a -> a + a
 107 in let b = a + a        ==> in (b,b)
 108 in (b,b)
 109 \end{verbatim}
 110 Also, even if a is not found to be strict in the new context and is
 111 still left as a let, if the branch is not taken (or b is not entered)
 112 the closure for a is not built.
 113
 114 %************************************************************************
 115 %*                                                                      *
 116 \subsection{Main floating-inwards code}
 117 %*                                                                      *
 118 %************************************************************************
 119
 120 \begin{code}
 121 type FreeVarsSet   = IdSet
 122
 123 type FloatingBinds = [(CoreBinding, FreeVarsSet)]
 124         -- In dependency order (outermost first)
 125
 126         -- The FreeVarsSet is the free variables of the binding.  In the case
 127         -- of recursive bindings, the set doesn't include the bound
 128         -- variables.
 129
 130 fiExpr :: FloatingBinds         -- binds we're trying to drop
 131                                 -- as far "inwards" as possible
 132        -> CoreExprWithFVs       -- input expr
 133        -> CoreExpr              -- result
 134
 135 fiExpr to_drop (_,AnnVar v) = mkCoLets' to_drop (Var v)
 136
 137 fiExpr to_drop (_,AnnLit k) = mkCoLets' to_drop (Lit k)
 138
 139 fiExpr to_drop (_,AnnCon c atoms)
 140   = mkCoLets' to_drop (Con c atoms)
 141
 142 fiExpr to_drop (_,AnnPrim c atoms)
 143   = mkCoLets' to_drop (Prim c atoms)
 144 \end{code}
 145
 146 Here we are not floating inside lambda (type lambdas are OK):
 147 \begin{code}
 148 fiExpr to_drop (_,AnnLam (UsageBinder binder) body)
 149   = panic "FloatIn.fiExpr:AnnLam UsageBinder"
 150
 151 fiExpr to_drop (_,AnnLam b@(ValBinder binder) body)
 152   = mkCoLets' to_drop (Lam b (fiExpr [] body))
 153
 154 fiExpr to_drop (_,AnnLam b@(TyBinder tyvar) body)
 155   | whnf body
 156   -- we do not float into type lambdas if they are followed by
 157   -- a whnf (actually we check for lambdas and constructors).
 158   -- The reason is that a let binding will get stuck
 159   -- in between the type lambda and the whnf and the simplifier
 160   -- does not know how to pull it back out from a type lambda.
 161   -- Ex:
 162   --    let v = ...
 163   --    in let f = /\t -> \a -> ...
 164   --       ==>
 165   --    let f = /\t -> let v = ... in \a -> ...
 166   -- which is bad as now f is an updatable closure (update PAP)
 167   -- and has arity 0. This example comes from cichelli.
 168
 169   = mkCoLets' to_drop (Lam b (fiExpr [] body))
 170   | otherwise
 171   = Lam b (fiExpr to_drop body)
 172   where
 173     whnf :: CoreExprWithFVs -> Bool
 174
 175     whnf (_,AnnLit _)   = True
 176     whnf (_,AnnCon _ _) = True
 177     whnf (_,AnnLam x e) = if isValBinder x then True else whnf e
 178     whnf (_,AnnSCC _ e) = whnf e
 179     whnf _              = False
 180 \end{code}
 181
 182 Applications: we could float inside applications, but it's probably
 183 not worth it (a purely practical choice, hunch- [not experience-]
 184 based).
 185 \begin{code}
 186 fiExpr to_drop (_,AnnApp fun arg)
 187   | isValArg arg
 188   = mkCoLets' to_drop (App (fiExpr [] fun) arg)
 189   | otherwise
 190   = App (fiExpr to_drop fun) arg
 191 \end{code}
 192
 193 We don't float lets inwards past an SCC.
 194
 195 ToDo: SCC: {\em should} keep info on current cc, and when passing
 196 one, if it is not the same, annotate all lets in binds with current
 197 cc, change current cc to the new one and float binds into expr.
 198 \begin{code}
 199 fiExpr to_drop (_, AnnSCC cc expr)
 200   = mkCoLets' to_drop (SCC cc (fiExpr [] expr))
 201 \end{code}
 202
 203 \begin{code}
 204 fiExpr to_drop (_, AnnCoerce c ty expr)
 205   = _trace "fiExpr:Coerce:wimping out" $
 206     mkCoLets' to_drop (Coerce c ty (fiExpr [] 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     ([rhs_binds, body_binds], shared_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 `unionIdSets` 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     (body_binds:rhss_binds, shared_binds)
 257       = sepBindsByDropPoint (body_fvs:rhss_fvs) to_drop
 258
 259     new_to_drop = -- the bindings used only in the body
 260                   body_binds ++
 261                   -- the new binding itself
 262                   [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++
 263                   -- the bindings used both in rhs and body or in more than one rhs
 264                   shared_binds
 265
 266     rhs_fvs' = unionIdSets (unionManyIdSets rhss_fvs)
 267                      (unionManyIdSets (map floatedBindsFVs rhss_binds))
 268
 269     -- Push rhs_binds into the right hand side of the binding
 270     fi_bind :: [FloatingBinds]      -- one per "drop pt" conjured w/ fvs_of_rhss
 271             -> [(Id, CoreExprWithFVs)]
 272             -> [(Id, CoreExpr)]
 273
 274     fi_bind to_drops pairs
 275       = [ (binder, fiExpr to_drop rhs) | ((binder, rhs), to_drop) <- zip 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 alts)
 284   = let
 285         fvs_scrut    = freeVarsOf scrut
 286         drop_pts_fvs = fvs_scrut : (get_fvs_from_deflt_and_alts alts)
 287     in
 288     case (sepBindsByDropPoint drop_pts_fvs to_drop)
 289                 of (scrut_drops : deflt_drops : alts_drops, drop_here) ->
 290                      mkCoLets' drop_here (Case (fiExpr scrut_drops scrut)
 291                                                 (fi_alts deflt_drops alts_drops alts))
 292
 293   where
 294     ----------------------------
 295     -- pin default FVs on first!
 296     --
 297     get_fvs_from_deflt_and_alts (AnnAlgAlts alts deflt)
 298       = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, _, rhs) <- alts ]
 299
 300     get_fvs_from_deflt_and_alts (AnnPrimAlts alts deflt)
 301       = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, rhs) <- alts]
 302
 303     get_deflt_fvs AnnNoDefault     = emptyIdSet
 304     get_deflt_fvs (AnnBindDefault b rhs) = freeVarsOf rhs
 305
 306     ----------------------------
 307     fi_alts to_drop_deflt to_drop_alts (AnnAlgAlts alts deflt)
 308       = AlgAlts
 309             [ (con, params, fiExpr to_drop rhs)
 310             | ((con, params, rhs), to_drop) <- alts `zip` to_drop_alts ]
 311             (fi_default to_drop_deflt deflt)
 312
 313     fi_alts to_drop_deflt to_drop_alts (AnnPrimAlts alts deflt)
 314       = PrimAlts
 315             [ (lit, fiExpr to_drop rhs)
 316             | ((lit, rhs), to_drop) <- alts `zip` to_drop_alts ]
 317             (fi_default to_drop_deflt deflt)
 318
 319     fi_default to_drop AnnNoDefault           = NoDefault
 320     fi_default to_drop (AnnBindDefault b e) = BindDefault b (fiExpr to_drop e)
 321 \end{code}
 322
 323 %************************************************************************
 324 %*                                                                      *
 325 \subsection{@sepBindsByDropPoint@}
 326 %*                                                                      *
 327 %************************************************************************
 328
 329 This is the crucial function.  The idea is: We have a wad of bindings
 330 that we'd like to distribute inside a collection of {\em drop points};
 331 insides the alternatives of a \tr{case} would be one example of some
 332 drop points; the RHS and body of a non-recursive \tr{let} binding
 333 would be another (2-element) collection.
 334
 335 So: We're given a list of sets-of-free-variables, one per drop point,
 336 and a list of floating-inwards bindings.  If a binding can go into
 337 only one drop point (without suddenly making something out-of-scope),
 338 in it goes.  If a binding is used inside {\em multiple} drop points,
 339 then it has to go in a you-must-drop-it-above-all-these-drop-points
 340 point.
 341
 342 We have to maintain the order on these drop-point-related lists.
 343
 344 \begin{code}
 345 sepBindsByDropPoint
 346     :: [FreeVarsSet]        -- one set of FVs per drop point
 347     -> FloatingBinds        -- candidate floaters
 348     -> ([FloatingBinds],    -- floaters that *can* be floated into
 349                             -- the corresponding drop point
 350         FloatingBinds)      -- everything else, bindings which must
 351                             -- not be floated inside any drop point
 352
 353 sepBindsByDropPoint drop_pts []
 354   = ([[] | p <- drop_pts], []) -- cut to the chase scene; it happens
 355
 356 sepBindsByDropPoint drop_pts floaters
 357   = let
 358         (per_drop_pt, must_stay_here, _)
 359             --= sep drop_pts emptyIdSet{-fvs of prev drop_pts-} floaters
 360             = split' drop_pts floaters [] empty_boxes
 361         empty_boxes = take (length drop_pts) (repeat [])
 362
 363     in
 364     (map reverse per_drop_pt, reverse must_stay_here)
 365   where
 366     split' drop_pts_fvs [] mult_branch drop_boxes
 367       = (drop_boxes, mult_branch, drop_pts_fvs)
 368
 369     -- only in a or unused
 370     split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
 371       | all (\b -> {-b `elementOfIdSet` a &&-}
 372                    not (b `elementOfIdSet` (unionManyIdSets as)))
 373             (bindersOf (fst bind))
 374       = split' (a':as) binds mult_branch ((bind:drop_box_a):drop_boxes)
 375       where
 376         a' = a `unionIdSets` fvsOfBind bind
 377
 378     -- not in a
 379     split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
 380       | all (\b -> not (b `elementOfIdSet` a)) (bindersOf (fst bind))
 381       = split' (a:as') binds mult_branch' (drop_box_a:drop_boxes')
 382       where
 383         (drop_boxes',mult_branch',as') = split' as [bind] mult_branch drop_boxes
 384
 385     -- in a and in as
 386     split' aas@(a:as) (bind:binds) mult_branch drop_boxes
 387       = split' aas' binds (bind : mult_branch) drop_boxes
 388       where
 389         aas' = map (unionIdSets (fvsOfBind bind)) aas
 390
 391     -------------------------
 392     fvsOfBind (_,fvs)   = fvs
 393
 394 --floatedBindsFVs ::
 395 floatedBindsFVs binds = unionManyIdSets (map snd binds)
 396
 397 --mkCoLets' :: [FloatingBinds] -> CoreExpr -> CoreExpr
 398 mkCoLets' to_drop e = mkCoLetsNoUnboxed (reverse (map fst to_drop)) e
 399 \end{code}