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