ghc/compiler/simplCore/FloatOut.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[FloatOut]{Float bindings outwards (towards the top level)}
   5
   6 ``Long-distance'' floating of bindings towards the top level.
   7
   8 \begin{code}
   9 module FloatOut ( floatOutwards ) where
  10
  11 #include "HsVersions.h"
  12
  13 import CoreSyn
  14
  15 import CmdLineOpts      ( opt_D_verbose_core2core, opt_D_simplifier_stats )
  16 import ErrUtils         ( dumpIfSet )
  17 import CostCentre       ( dupifyCC, CostCentre )
  18 import Id               ( Id )
  19 import Const            ( isWHNFCon )
  20 import VarEnv
  21 import CoreLint         ( beginPass, endPass )
  22 import PprCore
  23 import SetLevels        ( setLevels,
  24                           Level(..), tOP_LEVEL, ltMajLvl, ltLvl, isTopLvl
  25                         )
  26 import BasicTypes       ( Unused )
  27 import Var              ( TyVar )
  28 import UniqSupply       ( UniqSupply )
  29 import List             ( partition )
  30 import Outputable
  31 \end{code}
  32
  33 Random comments
  34 ~~~~~~~~~~~~~~~
  35
  36 At the moment we never float a binding out to between two adjacent
  37 lambdas.  For example:
  38
  39 @
  40         \x y -> let t = x+x in ...
  41 ===>
  42         \x -> let t = x+x in \y -> ...
  43 @
  44 Reason: this is less efficient in the case where the original lambda
  45 is never partially applied.
  46
  47 But there's a case I've seen where this might not be true.  Consider:
  48 @
  49 elEm2 x ys
  50   = elem' x ys
  51   where
  52     elem' _ []  = False
  53     elem' x (y:ys)      = x==y || elem' x ys
  54 @
  55 It turns out that this generates a subexpression of the form
  56 @
  57         \deq x ys -> let eq = eqFromEqDict deq in ...
  58 @
  59 vwhich might usefully be separated to
  60 @
  61         \deq -> let eq = eqFromEqDict deq in \xy -> ...
  62 @
  63 Well, maybe.  We don't do this at the moment.
  64
  65 \begin{code}
  66 type LevelledExpr  = TaggedExpr Level
  67 type LevelledBind  = TaggedBind Level
  68 type FloatBind     = (Level, CoreBind)
  69 type FloatBinds    = [FloatBind]
  70 \end{code}
  71
  72 %************************************************************************
  73 %*                                                                      *
  74 \subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
  75 %*                                                                      *
  76 %************************************************************************
  77
  78 \begin{code}
  79 floatOutwards :: UniqSupply -> [CoreBind] -> IO [CoreBind]
  80
  81 floatOutwards us pgm
  82   = do {
  83         beginPass "Float out";
  84
  85         let { annotated_w_levels = setLevels pgm us ;
  86               (fss, binds_s')    = unzip (map floatTopBind annotated_w_levels)
  87             } ;
  88
  89         dumpIfSet opt_D_verbose_core2core "Levels added:"
  90                   (vcat (map ppr annotated_w_levels));
  91
  92         let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };
  93
  94         dumpIfSet opt_D_simplifier_stats "FloatOut stats:"
  95                 (hcat [ int tlets,  ptext SLIT(" Lets floated to top level; "),
  96                         int ntlets, ptext SLIT(" Lets floated elsewhere; from "),
  97                         int lams,   ptext SLIT(" Lambda groups")]);
  98
  99         endPass "Float out"
 100                 opt_D_verbose_core2core         {- no specific flag for dumping float-out -}
 101                 (concat binds_s')
 102     }
 103
 104 floatTopBind bind@(NonRec _ _)
 105   = case (floatBind emptyVarEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
 106     (fs, floatsToBinds floats ++ [bind'])
 107     }
 108
 109 floatTopBind bind@(Rec _)
 110   = case (floatBind emptyVarEnv tOP_LEVEL bind) of { (fs, floats, Rec pairs', _) ->
 111         -- Actually floats will be empty
 112     --false:ASSERT(null floats)
 113     (fs, [Rec (floatsToBindPairs floats ++ pairs')])
 114     }
 115 \end{code}
 116
 117 %************************************************************************
 118 %*                                                                      *
 119 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
 120 %*                                                                      *
 121 %************************************************************************
 122
 123
 124 \begin{code}
 125 floatBind :: IdEnv Level
 126           -> Level
 127           -> LevelledBind
 128           -> (FloatStats, FloatBinds, CoreBind, IdEnv Level)
 129
 130 floatBind env lvl (NonRec (name,level) rhs)
 131   = case (floatExpr env level rhs) of { (fs, rhs_floats, rhs') ->
 132
 133         -- A good dumping point
 134     case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
 135
 136     (fs, rhs_floats',
 137      NonRec name (install heres rhs'),
 138      extendVarEnv env name level)
 139     }}
 140
 141 floatBind env lvl bind@(Rec pairs)
 142   = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
 143
 144     if not (isTopLvl bind_level) then
 145         -- Standard case
 146         (sum_stats fss, concat rhss_floats, Rec new_pairs, new_env)
 147     else
 148         {- In a recursive binding, destined for the top level (only),
 149            the rhs floats may contain
 150            references to the bound things.  For example
 151
 152                 f = ...(let v = ...f... in b) ...
 153
 154            might get floated to
 155
 156                 v = ...f...
 157                 f = ... b ...
 158
 159            and hence we must (pessimistically) make all the floats recursive
 160            with the top binding.  Later dependency analysis will unravel it.
 161         -}
 162
 163         (sum_stats fss,
 164          [],
 165          Rec (new_pairs ++ floatsToBindPairs (concat rhss_floats)),
 166          new_env)
 167
 168     }
 169   where
 170     new_env = extendVarEnvList env (map fst pairs)
 171
 172     bind_level = getBindLevel bind
 173
 174     do_pair ((name, level), rhs)
 175       = case (floatExpr new_env level rhs) of { (fs, rhs_floats, rhs') ->
 176
 177                 -- A good dumping point
 178         case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
 179
 180         (fs, rhs_floats', (name, install heres rhs'))
 181         }}
 182 \end{code}
 183
 184 %************************************************************************
 185
 186 \subsection[FloatOut-Expr]{Floating in expressions}
 187 %*                                                                      *
 188 %************************************************************************
 189
 190 \begin{code}
 191 floatExpr :: IdEnv Level
 192           -> Level
 193           -> LevelledExpr
 194           -> (FloatStats, FloatBinds, CoreExpr)
 195
 196 floatExpr env _ (Var v)      = (zeroStats, [], Var v)
 197 floatExpr env _ (Type ty)    = (zeroStats, [], Type ty)
 198 floatExpr env lvl (Con con as)
 199   = case floatList (floatExpr env lvl) as of { (stats, floats, as') ->
 200     (stats, floats, Con con as') }
 201
 202 floatExpr env lvl (App e a)
 203   = case (floatExpr env lvl e) of { (fse, floats_e, e') ->
 204     case (floatExpr env lvl a) of { (fsa, floats_a, a') ->
 205     (fse `add_stats` fsa, floats_e ++ floats_a, App e' a') }}
 206
 207 floatExpr env lvl (Lam (tv,incd_lvl) e)
 208   | isTyVar tv
 209   = case (floatExpr env incd_lvl e) of { (fs, floats, e') ->
 210
 211         -- Dump any bindings which absolutely cannot go any further
 212     case (partitionByLevel incd_lvl floats)     of { (floats', heres) ->
 213
 214     (fs, floats', Lam tv (install heres e'))
 215     }}
 216
 217 floatExpr env lvl (Lam (arg,incd_lvl) rhs)
 218   = ASSERT( isId arg )
 219     let
 220         new_env  = extendVarEnv env arg incd_lvl
 221     in
 222     case (floatExpr new_env incd_lvl rhs) of { (fs, floats, rhs') ->
 223
 224         -- Dump any bindings which absolutely cannot go any further
 225     case (partitionByLevel incd_lvl floats)     of { (floats', heres) ->
 226
 227     (add_to_stats fs floats',
 228      floats',
 229      Lam arg (install heres rhs'))
 230     }}
 231
 232 floatExpr env lvl (Note note@(SCC cc) expr)
 233   = case (floatExpr env lvl expr)    of { (fs, floating_defns, expr') ->
 234     let
 235         -- Annotate bindings floated outwards past an scc expression
 236         -- with the cc.  We mark that cc as "duplicated", though.
 237
 238         annotated_defns = annotate (dupifyCC cc) floating_defns
 239     in
 240     (fs, annotated_defns, Note note expr') }
 241   where
 242     annotate :: CostCentre -> FloatBinds -> FloatBinds
 243
 244     annotate dupd_cc defn_groups
 245       = [ (level, ann_bind floater) | (level, floater) <- defn_groups ]
 246       where
 247         ann_bind (NonRec binder rhs)
 248           = NonRec binder (ann_rhs rhs)
 249
 250         ann_bind (Rec pairs)
 251           = Rec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs]
 252
 253         ann_rhs (Lam arg e)     = Lam arg (ann_rhs e)
 254         ann_rhs rhs@(Con con _) | isWHNFCon con = rhs   -- no point in scc'ing WHNF data
 255         ann_rhs rhs             = Note (SCC dupd_cc) rhs
 256
 257         -- Note: Nested SCC's are preserved for the benefit of
 258         --       cost centre stack profiling (Durham)
 259
 260 floatExpr env lvl (Note note expr)      -- Other than SCCs
 261   = case (floatExpr env lvl expr)    of { (fs, floating_defns, expr') ->
 262     (fs, floating_defns, Note note expr') }
 263
 264 floatExpr env lvl (Let bind body)
 265   = case (floatBind env     lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
 266     case (floatExpr new_env lvl body) of { (fse, body_floats, body') ->
 267     (add_stats fsb fse,
 268      rhs_floats ++ [(bind_lvl, bind')] ++ body_floats,
 269      body')
 270     }}
 271   where
 272     bind_lvl = getBindLevel bind
 273
 274 floatExpr env lvl (Case scrut (case_bndr, case_lvl) alts)
 275   = case floatExpr env lvl scrut        of { (fse, fde, scrut') ->
 276     case floatList float_alt alts       of { (fsa, fda, alts')  ->
 277     (add_stats fse fsa, fda ++ fde, Case scrut' case_bndr alts')
 278     }}
 279   where
 280       alts_env = extendVarEnv env case_bndr case_lvl
 281
 282       partition_fn = partitionByMajorLevel
 283
 284       float_alt (con, bs, rhs)
 285         = let
 286               bs' = map fst bs
 287               new_env = extendVarEnvList alts_env bs
 288           in
 289           case (floatExpr new_env case_lvl rhs)         of { (fs, rhs_floats, rhs') ->
 290           case (partition_fn case_lvl rhs_floats)       of { (rhs_floats', heres) ->
 291           (fs, rhs_floats', (con, bs', install heres rhs')) }}
 292
 293
 294 floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
 295 floatList f [] = (zeroStats, [], [])
 296 floatList f (a:as) = case f a            of { (fs_a,  binds_a,  b)  ->
 297                      case floatList f as of { (fs_as, binds_as, bs) ->
 298                      (fs_a `add_stats` fs_as, binds_a ++ binds_as, b:bs) }}
 299 \end{code}
 300
 301 %************************************************************************
 302 %*                                                                      *
 303 \subsection{Utility bits for floating stats}
 304 %*                                                                      *
 305 %************************************************************************
 306
 307 I didn't implement this with unboxed numbers.  I don't want to be too
 308 strict in this stuff, as it is rarely turned on.  (WDP 95/09)
 309
 310 \begin{code}
 311 data FloatStats
 312   = FlS Int  -- Number of top-floats * lambda groups they've been past
 313         Int  -- Number of non-top-floats * lambda groups they've been past
 314         Int  -- Number of lambda (groups) seen
 315
 316 get_stats (FlS a b c) = (a, b, c)
 317
 318 zeroStats = FlS 0 0 0
 319
 320 sum_stats xs = foldr add_stats zeroStats xs
 321
 322 add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
 323   = FlS (a1 + a2) (b1 + b2) (c1 + c2)
 324
 325 add_to_stats (FlS a b c) floats
 326   = FlS (a + length top_floats) (b + length other_floats) (c + 1)
 327   where
 328     (top_floats, other_floats) = partition to_very_top floats
 329
 330     to_very_top (my_lvl, _) = isTopLvl my_lvl
 331 \end{code}
 332
 333
 334 %************************************************************************
 335 %*                                                                      *
 336 \subsection{Utility bits for floating}
 337 %*                                                                      *
 338 %************************************************************************
 339
 340 \begin{code}
 341 getBindLevel (NonRec (_, lvl) _)      = lvl
 342 getBindLevel (Rec (((_,lvl), _) : _)) = lvl
 343 \end{code}
 344
 345 \begin{code}
 346 partitionByMajorLevel, partitionByLevel
 347         :: Level                -- Partitioning level
 348
 349         -> FloatBinds           -- Defns to be divided into 2 piles...
 350
 351         -> (FloatBinds, -- Defns  with level strictly < partition level,
 352             FloatBinds) -- The rest
 353
 354
 355 partitionByMajorLevel ctxt_lvl defns
 356   = partition float_further defns
 357   where
 358     float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl ||
 359                                 isTopLvl my_lvl
 360
 361 partitionByLevel ctxt_lvl defns
 362   = partition float_further defns
 363   where
 364     float_further (my_lvl, _) = my_lvl `ltLvl` ctxt_lvl
 365 \end{code}
 366
 367 \begin{code}
 368 floatsToBinds :: FloatBinds -> [CoreBind]
 369 floatsToBinds floats = map snd floats
 370
 371 floatsToBindPairs :: FloatBinds -> [(Id,CoreExpr)]
 372
 373 floatsToBindPairs floats = concat (map mk_pairs floats)
 374   where
 375    mk_pairs (_, Rec pairs)         = pairs
 376    mk_pairs (_, NonRec binder rhs) = [(binder,rhs)]
 377
 378 install :: FloatBinds -> CoreExpr -> CoreExpr
 379
 380 install defn_groups expr
 381   = foldr install_group expr defn_groups
 382   where
 383     install_group (_, defns) body = Let defns body
 384 \end{code}