ghc/compiler/simplCore/FloatIn.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   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         CoreExpr, CoreBinding, Id,
  22         PlainCoreProgram(..), PlainCoreExpr(..)
  23     ) where
  24
  25 import Pretty           -- ToDo: debugging only
  26
  27 import PlainCore
  28 import AnnCoreSyn
  29
  30 import FreeVars
  31 import UniqSet
  32 import Util
  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 :: [PlainCoreBinding] -> [PlainCoreBinding]
  40
  41 floatInwards binds
  42   = map fi_top_bind binds
  43   where
  44     fi_top_bind (CoNonRec binder rhs)
  45       = CoNonRec binder (fiExpr [] (freeVars rhs))
  46     fi_top_bind (CoRec pairs)
  47       = CoRec [ (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   = UniqSet Id
 122
 123 type FloatingBinds = [(PlainCoreBinding, 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        -> PlainCoreExpr         -- result
 134
 135 fiExpr to_drop (_,AnnCoVar v) = mkCoLets' to_drop (CoVar v)
 136
 137 fiExpr to_drop (_,AnnCoLit k) = mkCoLets' to_drop (CoLit k)
 138
 139 fiExpr to_drop (_,AnnCoCon c tys atoms)
 140   = mkCoLets' to_drop (CoCon c tys atoms)
 141
 142 fiExpr to_drop (_,AnnCoPrim c tys atoms)
 143   = mkCoLets' to_drop (CoPrim c tys atoms)
 144 \end{code}
 145
 146 Here we are not floating inside lambda (type lambdas are OK):
 147 \begin{code}
 148 fiExpr to_drop (_,AnnCoLam binders body)
 149   = mkCoLets' to_drop (mkCoLam binders (fiExpr [] body))
 150
 151 fiExpr to_drop (_,AnnCoTyLam tyvar body)
 152   | whnf body
 153   -- we do not float into type lambdas if they are followed by
 154   -- a whnf (actually we check for lambdas and constructors).
 155   -- The reason is that a let binding will get stuck
 156   -- in between the type lambda and the whnf and the simplifier
 157   -- does not know how to pull it back out from a type lambda.
 158   -- Ex:
 159   --    let v = ...
 160   --    in let f = /\t -> \a -> ...
 161   --       ==>
 162   --    let f = /\t -> let v = ... in \a -> ...
 163   -- which is bad as now f is an updatable closure (update PAP)
 164   -- and has arity 0. This example comes from cichelli.
 165   = mkCoLets' to_drop (CoTyLam tyvar (fiExpr [] body))
 166   | otherwise
 167   = CoTyLam tyvar (fiExpr to_drop body)
 168   where
 169     whnf :: CoreExprWithFVs -> Bool
 170     whnf (_,AnnCoLit _)     = True
 171     whnf (_,AnnCoCon _ _ _) = True
 172     whnf (_,AnnCoLam _ _)   = True
 173     whnf (_,AnnCoTyLam _ e) = whnf e
 174     whnf (_,AnnCoSCC _ e)   = whnf e
 175     whnf _                  = False
 176
 177 \end{code}
 178
 179 Applications: we could float inside applications, but it's probably
 180 not worth it (a purely practical choice, hunch- [not experience-]
 181 based).
 182 \begin{code}
 183 fiExpr to_drop (_,AnnCoApp fun atom)
 184   = mkCoLets' to_drop (CoApp (fiExpr [] fun) atom)
 185
 186 fiExpr to_drop (_,AnnCoTyApp expr ty)
 187   = CoTyApp (fiExpr to_drop expr) ty
 188 \end{code}
 189
 190 We don't float lets inwards past an SCC.
 191
 192 ToDo: CoSCC: {\em should} keep info on current cc, and when passing
 193 one, if it is not the same, annotate all lets in binds with current
 194 cc, change current cc to the new one and float binds into expr.
 195 \begin{code}
 196 fiExpr to_drop (_, AnnCoSCC cc expr)
 197   = mkCoLets' to_drop (CoSCC cc (fiExpr [] expr))
 198 \end{code}
 199
 200 For @CoLets@, the possible ``drop points'' for the \tr{to_drop}
 201 bindings are: (a)~in the body, (b1)~in the RHS of a CoNonRec binding,
 202 or~(b2), in each of the RHSs of the pairs of a @CoRec@.
 203
 204 Note that we do {\em weird things} with this let's binding.  Consider:
 205 \begin{verbatim}
 206 let
 207     w = ...
 208 in {
 209     let v = ... w ...
 210     in ... w ...
 211 }
 212 \end{verbatim}
 213 Look at the inner \tr{let}.  As \tr{w} is used in both the bind and
 214 body of the inner let, we could panic and leave \tr{w}'s binding where
 215 it is.  But \tr{v} is floatable into the body of the inner let, and
 216 {\em then} \tr{w} will also be only in the body of that inner let.
 217
 218 So: rather than drop \tr{w}'s binding here, we add it onto the list of
 219 things to drop in the outer let's body, and let nature take its
 220 course.
 221
 222 \begin{code}
 223 fiExpr to_drop (_,AnnCoLet (AnnCoNonRec id rhs) body)
 224   = fiExpr new_to_drop body
 225   where
 226     rhs_fvs  = freeVarsOf rhs
 227     body_fvs = freeVarsOf body
 228
 229     ([rhs_binds, body_binds], shared_binds) = sepBindsByDropPoint [rhs_fvs, body_fvs] to_drop
 230
 231     new_to_drop = body_binds ++                         -- the bindings used only in the body
 232                   [(CoNonRec id rhs', rhs_fvs')] ++     -- the new binding itself
 233                   shared_binds                          -- the bindings used both in rhs and body
 234
 235         -- Push rhs_binds into the right hand side of the binding
 236     rhs'     = fiExpr rhs_binds rhs
 237     rhs_fvs' = rhs_fvs `unionUniqSets` (floatedBindsFVs rhs_binds)
 238
 239 fiExpr to_drop (_,AnnCoLet (AnnCoRec bindings) body)
 240   = fiExpr new_to_drop body
 241   where
 242     (binders, rhss) = unzip bindings
 243
 244     rhss_fvs = map freeVarsOf rhss
 245     body_fvs = freeVarsOf body
 246
 247     (body_binds:rhss_binds, shared_binds)
 248       = sepBindsByDropPoint (body_fvs:rhss_fvs) to_drop
 249
 250     new_to_drop = -- the bindings used only in the body
 251                   body_binds ++
 252                   -- the new binding itself
 253                   [(CoRec (fi_bind rhss_binds bindings), rhs_fvs')] ++
 254                   -- the bindings used both in rhs and body or in more than one rhs
 255                   shared_binds
 256
 257     rhs_fvs' = unionUniqSets (unionManyUniqSets rhss_fvs)
 258                      (unionManyUniqSets (map floatedBindsFVs rhss_binds))
 259
 260     -- Push rhs_binds into the right hand side of the binding
 261     fi_bind :: [FloatingBinds]      -- one per "drop pt" conjured w/ fvs_of_rhss
 262             -> [(Id, CoreExprWithFVs)]
 263             -> [(Id, PlainCoreExpr)]
 264
 265     fi_bind to_drops pairs
 266       = [ (binder, fiExpr to_drop rhs) | ((binder, rhs), to_drop) <- zip pairs to_drops ]
 267 \end{code}
 268
 269 For @CoCase@, the possible ``drop points'' for the \tr{to_drop}
 270 bindings are: (a)~inside the scrutinee, (b)~inside one of the
 271 alternatives/default [default FVs always {\em first}!].
 272
 273 \begin{code}
 274 fiExpr to_drop (_, AnnCoCase scrut alts)
 275   = let
 276         fvs_scrut    = freeVarsOf scrut
 277         drop_pts_fvs = fvs_scrut : (get_fvs_from_deflt_and_alts alts)
 278     in
 279     case (sepBindsByDropPoint drop_pts_fvs to_drop)
 280                 of (scrut_drops : deflt_drops : alts_drops, drop_here) ->
 281                      mkCoLets' drop_here (CoCase (fiExpr scrut_drops scrut)
 282                                                 (fi_alts deflt_drops alts_drops alts))
 283
 284   where
 285     ----------------------------
 286     -- pin default FVs on first!
 287     --
 288     get_fvs_from_deflt_and_alts (AnnCoAlgAlts alts deflt)
 289       = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, _, rhs) <- alts ]
 290
 291     get_fvs_from_deflt_and_alts (AnnCoPrimAlts alts deflt)
 292       = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, rhs) <- alts]
 293
 294     get_deflt_fvs AnnCoNoDefault           = emptyUniqSet
 295     get_deflt_fvs (AnnCoBindDefault b rhs) = freeVarsOf rhs
 296
 297     ----------------------------
 298     fi_alts to_drop_deflt to_drop_alts (AnnCoAlgAlts alts deflt)
 299       = CoAlgAlts
 300             [ (con, params, fiExpr to_drop rhs)
 301             | ((con, params, rhs), to_drop) <- alts `zip` to_drop_alts ]
 302             (fi_default to_drop_deflt deflt)
 303
 304     fi_alts to_drop_deflt to_drop_alts (AnnCoPrimAlts alts deflt)
 305       = CoPrimAlts
 306             [ (lit, fiExpr to_drop rhs)
 307             | ((lit, rhs), to_drop) <- alts `zip` to_drop_alts ]
 308             (fi_default to_drop_deflt deflt)
 309
 310     fi_default to_drop AnnCoNoDefault         = CoNoDefault
 311     fi_default to_drop (AnnCoBindDefault b e) = CoBindDefault b (fiExpr to_drop e)
 312 \end{code}
 313
 314 %************************************************************************
 315 %*                                                                      *
 316 \subsection{@sepBindsByDropPoint@}
 317 %*                                                                      *
 318 %************************************************************************
 319
 320 This is the crucial function.  The idea is: We have a wad of bindings
 321 that we'd like to distribute inside a collection of {\em drop points};
 322 insides the alternatives of a \tr{case} would be one example of some
 323 drop points; the RHS and body of a non-recursive \tr{let} binding
 324 would be another (2-element) collection.
 325
 326 So: We're given a list of sets-of-free-variables, one per drop point,
 327 and a list of floating-inwards bindings.  If a binding can go into
 328 only one drop point (without suddenly making something out-of-scope),
 329 in it goes.  If a binding is used inside {\em multiple} drop points,
 330 then it has to go in a you-must-drop-it-above-all-these-drop-points
 331 point.
 332
 333 We have to maintain the order on these drop-point-related lists.
 334
 335 \begin{code}
 336 sepBindsByDropPoint
 337     :: [FreeVarsSet]        -- one set of FVs per drop point
 338     -> FloatingBinds        -- candidate floaters
 339     -> ([FloatingBinds],    -- floaters that *can* be floated into
 340                             -- the corresponding drop point
 341         FloatingBinds)      -- everything else, bindings which must
 342                             -- not be floated inside any drop point
 343
 344 sepBindsByDropPoint drop_pts []
 345   = ([[] | p <- drop_pts], []) -- cut to the chase scene; it happens
 346
 347 sepBindsByDropPoint drop_pts floaters
 348   = let
 349         (per_drop_pt, must_stay_here, _)
 350             --= sep drop_pts emptyUniqSet{-fvs of prev drop_pts-} floaters
 351             = split' drop_pts floaters [] empty_boxes
 352         empty_boxes = take (length drop_pts) (repeat [])
 353
 354     in
 355     (map reverse per_drop_pt, reverse must_stay_here)
 356   where
 357     split' drop_pts_fvs [] mult_branch drop_boxes
 358       = (drop_boxes, mult_branch, drop_pts_fvs)
 359
 360     -- only in a or unused
 361     split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
 362       | all (\b -> {-b `elementOfUniqSet` a &&-}
 363                    not (b `elementOfUniqSet` (unionManyUniqSets as)))
 364             (bindersOf (fst bind))
 365       = split' (a':as) binds mult_branch ((bind:drop_box_a):drop_boxes)
 366       where
 367         a' = a `unionUniqSets` fvsOfBind bind
 368
 369     -- not in a
 370     split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
 371       | all (\b -> not (b `elementOfUniqSet` a)) (bindersOf (fst bind))
 372       = split' (a:as') binds mult_branch' (drop_box_a:drop_boxes')
 373       where
 374         (drop_boxes',mult_branch',as') = split' as [bind] mult_branch drop_boxes
 375
 376     -- in a and in as
 377     split' aas@(a:as) (bind:binds) mult_branch drop_boxes
 378       = split' aas' binds (bind : mult_branch) drop_boxes
 379       where
 380         aas' = map (unionUniqSets (fvsOfBind bind)) aas
 381
 382     -------------------------
 383     fvsOfBind (_,fvs)   = fvs
 384
 385 --floatedBindsFVs ::
 386 floatedBindsFVs binds = foldr unionUniqSets emptyUniqSet (map snd binds)
 387
 388 --mkCoLets' :: [FloatingBinds] -> PlainCoreExpr -> PlainCoreExpr
 389 mkCoLets' to_drop e = mkCoLetsNoUnboxed (reverse (map fst to_drop)) e
 390 \end{code}