ghc/compiler/simplCore/FloatOut.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   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 #include "HsVersions.h"
  10
  11 module FloatOut ( floatOutwards ) where
  12
  13 IMPORT_Trace            -- ToDo: rm (debugging)
  14 import Pretty
  15 import Outputable
  16
  17 import PlainCore
  18
  19 import BasicLit         ( BasicLit(..), PrimKind )
  20 import CmdLineOpts      ( GlobalSwitch(..) )
  21 import CostCentre       ( dupifyCC, CostCentre )
  22 import SetLevels
  23 import Id               ( eqId )
  24 import IdEnv
  25 import Maybes           ( Maybe(..), catMaybes, maybeToBool )
  26 import SplitUniq
  27 import Util
  28 \end{code}
  29
  30 Random comments
  31 ~~~~~~~~~~~~~~~
  32 At the moment we never float a binding out to between two adjacent lambdas.  For
  33 example:
  34 @
  35         \x y -> let t = x+x in ...
  36 ===>
  37         \x -> let t = x+x in \y -> ...
  38 @
  39 Reason: this is less efficient in the case where the original lambda is
  40 never partially applied.
  41
  42 But there's a case I've seen where this might not be true.  Consider:
  43 @
  44 elEm2 x ys
  45   = elem' x ys
  46   where
  47     elem' _ []  = False
  48     elem' x (y:ys)      = x==y || elem' x ys
  49 @
  50 It turns out that this generates a subexpression of the form
  51 @
  52         \deq x ys -> let eq = eqFromEqDict deq in ...
  53 @
  54 which might usefully be separated to
  55 @
  56         \deq -> let eq = eqFromEqDict deq in \xy -> ...
  57 @
  58 Well, maybe.  We don't do this at the moment.
  59
  60
  61 \begin{code}
  62 type LevelledExpr  = CoreExpr    (Id, Level) Id
  63 type LevelledBind  = CoreBinding (Id, Level) Id
  64 type FloatingBind  = (Level, Floater)
  65 type FloatingBinds = [FloatingBind]
  66
  67 data Floater = LetFloater     PlainCoreBinding
  68
  69              | CaseFloater   (PlainCoreExpr -> PlainCoreExpr)
  70                                 -- Give me a right-hand side of the
  71                                 -- (usually single) alternative, and
  72                                 -- I'll build the case
  73 \end{code}
  74
  75 %************************************************************************
  76 %*                                                                      *
  77 \subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
  78 %*                                                                      *
  79 %************************************************************************
  80
  81 \begin{code}
  82 floatOutwards :: (GlobalSwitch -> Bool)  -- access to all global cmd-line opts
  83               -> SplitUniqSupply
  84               -> PlainCoreProgram
  85               -> PlainCoreProgram
  86
  87 floatOutwards sw_chker us pgm
  88   = case (setLevels pgm sw_chker us) of { annotated_w_levels ->
  89
  90     case unzip3 (map (floatTopBind sw_chker) annotated_w_levels)
  91                 of { (fcs, lcs, final_toplev_binds_s) ->
  92
  93     (if sw_chker D_verbose_core2core
  94      then pprTrace "Levels added:\n" (ppr PprDebug annotated_w_levels)
  95      else id
  96     )
  97     ( if  sw_chker D_simplifier_stats
  98       then pprTrace "FloatOut stats: " (ppBesides [
  99                 ppInt (sum fcs), ppStr " Lets floated out of ",
 100                 ppInt (sum lcs), ppStr " Lambdas"])
 101       else id
 102     )
 103     concat final_toplev_binds_s
 104     }}
 105
 106 floatTopBind sw bind@(CoNonRec _ _)
 107   = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fc,lc, floats, bind', _) ->
 108     (fc,lc, floatsToBinds floats ++ [bind'])
 109     }
 110
 111 floatTopBind sw bind@(CoRec _)
 112   = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fc,lc, floats, CoRec pairs', _) ->
 113         -- Actually floats will be empty
 114     --false:ASSERT(null floats)
 115     (fc,lc, [CoRec (floatsToBindPairs floats ++ pairs')])
 116     }
 117 \end{code}
 118
 119 %************************************************************************
 120 %*                                                                      *
 121 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
 122 %*                                                                      *
 123 %************************************************************************
 124
 125
 126 \begin{code}
 127 floatBind :: (GlobalSwitch -> Bool)
 128           -> IdEnv Level
 129           -> Level
 130           -> LevelledBind
 131           -> (Int,Int, FloatingBinds, PlainCoreBinding, IdEnv Level)
 132
 133 floatBind sw env lvl (CoNonRec (name,level) rhs)
 134   = case (floatExpr sw env level rhs) of { (fc,lc, rhs_floats, rhs') ->
 135
 136         -- A good dumping point
 137     case (partitionByMajorLevel level rhs_floats)       of { (rhs_floats', heres) ->
 138
 139     (fc,lc, rhs_floats',CoNonRec name (install heres rhs'), addOneToIdEnv env name level)
 140     }}
 141
 142 floatBind sw env lvl bind@(CoRec pairs)
 143   = case (unzip4 (map do_pair pairs)) of { (fcs,lcs, rhss_floats, new_pairs) ->
 144
 145     if not (isTopLvl bind_level) then
 146         -- Standard case
 147         (sum fcs,sum lcs, concat rhss_floats, CoRec new_pairs, new_env)
 148     else
 149         {- In a recursive binding, destined for the top level (only),
 150            the rhs floats may contain
 151            references to the bound things.  For example
 152
 153                 f = ...(let v = ...f... in b) ...
 154
 155            might get floated to
 156
 157                 v = ...f...
 158                 f = ... b ...
 159
 160            and hence we must (pessimistically) make all the floats recursive
 161            with the top binding.  Later dependency analysis will unravel it.
 162         -}
 163
 164         (sum fcs,sum lcs, [],
 165          CoRec (new_pairs ++ floatsToBindPairs (concat rhss_floats)),
 166          new_env)
 167
 168     }
 169   where
 170     new_env = growIdEnvList env (map fst pairs)
 171
 172     bind_level = getBindLevel bind
 173
 174     do_pair ((name, level), rhs)
 175       = case (floatExpr sw new_env level rhs) of { (fc,lc, rhs_floats, rhs') ->
 176
 177                 -- A good dumping point
 178         case (partitionByMajorLevel level rhs_floats)   of { (rhs_floats', heres) ->
 179
 180         (fc,lc, 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 :: (GlobalSwitch -> Bool)
 192           -> IdEnv Level
 193           -> Level
 194           -> LevelledExpr
 195           -> (Int,Int, FloatingBinds, PlainCoreExpr)
 196
 197 floatExpr sw env _ (CoVar v)         = (0,0, [], CoVar v)
 198
 199 floatExpr sw env _ (CoLit l)     = (0,0, [], CoLit l)
 200
 201 floatExpr sw env _ (CoPrim op ty as) = (0,0, [], CoPrim op ty as)
 202 floatExpr sw env _ (CoCon con ty as) = (0,0, [], CoCon con ty as)
 203
 204 floatExpr sw env lvl (CoApp e a)
 205   = case (floatExpr sw env lvl e) of { (fc,lc, floating_defns, e') ->
 206     (fc,lc, floating_defns, CoApp e' a) }
 207
 208 floatExpr sw env lvl (CoTyApp e ty)
 209   = case (floatExpr sw env lvl e) of { (fc,lc, floating_defns, e') ->
 210     (fc,lc, floating_defns, CoTyApp e' ty) }
 211
 212 floatExpr sw env lvl (CoTyLam tv e)
 213   = let
 214         incd_lvl = incMinorLvl lvl
 215     in
 216     case (floatExpr sw env incd_lvl e) of { (fc,lc, floats, e') ->
 217
 218         -- Dump any bindings which absolutely cannot go any further
 219     case (partitionByLevel incd_lvl floats)     of { (floats', heres) ->
 220
 221     (fc,lc, floats', CoTyLam tv (install heres e'))
 222     }}
 223
 224 floatExpr sw env lvl (CoLam args@((_,incd_lvl):_) rhs)
 225   = let
 226         args'    = map fst args
 227         new_env  = growIdEnvList env args
 228     in
 229     case (floatExpr sw new_env incd_lvl rhs) of { (fc,lc, floats, rhs') ->
 230
 231         -- Dump any bindings which absolutely cannot go any further
 232     case (partitionByLevel incd_lvl floats)     of { (floats', heres) ->
 233
 234     (fc +  length floats', lc + 1,
 235      floats', mkCoLam args' (install heres rhs'))
 236     }}
 237
 238 floatExpr sw env lvl (CoSCC cc expr)
 239   = case (floatExpr sw env lvl expr)    of { (fc,lc, floating_defns, expr') ->
 240     let
 241         -- annotate bindings floated outwards past an scc expression
 242         -- with the cc.  We mark that cc as "duplicated", though.
 243
 244         annotated_defns = annotate (dupifyCC cc) floating_defns
 245     in
 246     (fc,lc, annotated_defns, CoSCC cc expr') }
 247   where
 248     annotate :: CostCentre -> FloatingBinds -> FloatingBinds
 249
 250     annotate dupd_cc defn_groups
 251       = [ (level, ann_bind floater) | (level, floater) <- defn_groups ]
 252       where
 253         ann_bind (LetFloater (CoNonRec binder rhs))
 254           = LetFloater (CoNonRec binder (ann_rhs rhs))
 255
 256         ann_bind (LetFloater (CoRec pairs))
 257           = LetFloater (CoRec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs])
 258
 259         ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> CoSCC dupd_cc (fn rhs) )
 260
 261         ann_rhs (CoLam   args e) = CoLam   args (ann_rhs e)
 262         ann_rhs (CoTyLam tv   e) = CoTyLam tv   (ann_rhs e)
 263         ann_rhs rhs@(CoCon _ _ _)= rhs  -- no point in scc'ing WHNF data
 264         ann_rhs rhs              = CoSCC dupd_cc rhs
 265
 266         -- Note: Nested SCC's are preserved for the benefit of
 267         --       cost centre stack profiling (Durham)
 268
 269 floatExpr sw env lvl (CoLet bind body)
 270   = case (floatBind sw env     lvl bind) of { (fcb,lcb, rhs_floats, bind', new_env) ->
 271     case (floatExpr sw new_env lvl body) of { (fce,lce, body_floats, body') ->
 272     (fcb + fce, lcb + lce,
 273      rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats, body')
 274     }}
 275   where
 276     bind_lvl = getBindLevel bind
 277
 278 floatExpr sw env lvl (CoCase scrut alts)
 279   = case (floatExpr sw env lvl scrut) of { (fce,lce, fde, scrut') ->
 280
 281     case (scrut', float_alts alts) of
 282
 283 {-      CASE-FLOATING DROPPED FOR NOW.  (SLPJ 7/2/94)
 284
 285         (CoVar scrut_var, (fda, CoAlgAlts [(con,bs,rhs')] CoNoDefault))
 286                 | scrut_var_lvl `ltMajLvl` lvl ->
 287
 288                 -- Candidate for case floater; scrutinising a variable; it can
 289                 -- escape outside a lambda; there's only one alternative.
 290                 (fda ++ fde ++ [case_floater], rhs')
 291
 292                 where
 293                 case_floater = (scrut_var_lvl, CaseFloater fn)
 294                 fn body = CoCase scrut' (CoAlgAlts [(con,bs,body)] CoNoDefault)
 295                 scrut_var_lvl = case lookupIdEnv env scrut_var of
 296                                   Nothing  -> Level 0 0
 297                                   Just lvl -> unTopify lvl
 298
 299  END OF CASE FLOATING DROPPED   -}
 300
 301         (_, (fca,lca, fda, alts')) ->
 302
 303                 (fce + fca, lce + lca, fda ++ fde, CoCase scrut' alts')
 304     }
 305   where
 306       incd_lvl = incMinorLvl lvl
 307
 308       partition_fn = partitionByMajorLevel
 309
 310 {-      OMITTED
 311         We don't want to be too keen about floating lets out of case alternatives
 312         because they may benefit from seeing the evaluation done by the case.
 313
 314         The main reason for doing this is to allocate in fewer larger blocks
 315         but that's really an STG-level issue.
 316
 317                         case alts of
 318                                 -- Just one alternative, then dump only
 319                                 -- what *has* to be dumped
 320                         CoAlgAlts  [_] CoNoDefault         -> partitionByLevel
 321                         CoAlgAlts  []  (CoBindDefault _ _) -> partitionByLevel
 322                         CoPrimAlts [_] CoNoDefault         -> partitionByLevel
 323                         CoPrimAlts []  (CoBindDefault _ _) -> partitionByLevel
 324
 325                                 -- If there's more than one alternative, then
 326                                 -- this is a dumping point
 327                         other                              -> partitionByMajorLevel
 328 -}
 329
 330       float_alts (CoAlgAlts alts deflt)
 331         = case (float_deflt  deflt)              of { (fcd,lcd,   fdd,  deflt') ->
 332           case (unzip4 (map float_alg_alt alts)) of { (fcas,lcas, fdas, alts') ->
 333           (fcd + sum fcas, lcd + sum lcas,
 334            concat fdas ++ fdd, CoAlgAlts alts' deflt') }}
 335
 336       float_alts (CoPrimAlts alts deflt)
 337         = case (float_deflt deflt)                of { (fcd,lcd,   fdd, deflt') ->
 338           case (unzip4 (map float_prim_alt alts)) of { (fcas,lcas, fdas, alts') ->
 339           (fcd + sum fcas, lcd + sum lcas,
 340            concat fdas ++ fdd, CoPrimAlts alts' deflt') }}
 341
 342       -------------
 343       float_alg_alt (con, bs, rhs)
 344         = let
 345               bs' = map fst bs
 346               new_env = growIdEnvList env bs
 347           in
 348           case (floatExpr sw new_env incd_lvl rhs)      of { (fc,lc, rhs_floats, rhs') ->
 349           case (partition_fn incd_lvl rhs_floats)       of { (rhs_floats', heres) ->
 350           (fc, lc, rhs_floats', (con, bs', install heres rhs'))
 351           }}
 352
 353       --------------
 354       float_prim_alt (lit, rhs)
 355         = case (floatExpr sw env incd_lvl rhs)          of { (fc,lc, rhs_floats, rhs') ->
 356           case (partition_fn incd_lvl rhs_floats)       of { (rhs_floats', heres) ->
 357           (fc,lc, rhs_floats', (lit, install heres rhs'))
 358           }}
 359
 360       --------------
 361       float_deflt CoNoDefault = (0,0, [], CoNoDefault)
 362
 363       float_deflt (CoBindDefault (b,lvl) rhs)
 364         = case (floatExpr sw new_env lvl rhs)           of { (fc,lc, rhs_floats, rhs') ->
 365           case (partition_fn incd_lvl rhs_floats)       of { (rhs_floats', heres) ->
 366           (fc,lc, rhs_floats', CoBindDefault b (install heres rhs'))
 367           }}
 368         where
 369           new_env = addOneToIdEnv env b lvl
 370 \end{code}
 371
 372 %************************************************************************
 373 %*                                                                      *
 374 \subsection[FloatOut-utils]{Utility bits for floating}
 375 %*                                                                      *
 376 %************************************************************************
 377
 378 \begin{code}
 379 getBindLevel (CoNonRec (_, lvl) _)      = lvl
 380 getBindLevel (CoRec (((_,lvl), _) : _)) = lvl
 381 \end{code}
 382
 383 \begin{code}
 384 partitionByMajorLevel, partitionByLevel
 385         :: Level                -- Partitioning level
 386
 387         -> FloatingBinds        -- Defns to be divided into 2 piles...
 388
 389         -> (FloatingBinds,      -- Defns  with level strictly < partition level,
 390             FloatingBinds)      -- The rest
 391
 392
 393 partitionByMajorLevel ctxt_lvl defns
 394   = partition float_further defns
 395   where
 396     float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl ||
 397                                 isTopLvl my_lvl
 398
 399 partitionByLevel ctxt_lvl defns
 400   = partition float_further defns
 401   where
 402     float_further (my_lvl, _) = my_lvl `ltLvl` ctxt_lvl
 403 \end{code}
 404
 405 \begin{code}
 406 floatsToBinds :: FloatingBinds -> [PlainCoreBinding]
 407 floatsToBinds floats = map get_bind floats
 408                      where
 409                        get_bind (_, LetFloater bind) = bind
 410                        get_bind (_, CaseFloater _)   = panic "floatsToBinds"
 411
 412 floatsToBindPairs :: FloatingBinds -> [(Id,PlainCoreExpr)]
 413
 414 floatsToBindPairs floats = concat (map mk_pairs floats)
 415   where
 416    mk_pairs (_, LetFloater (CoRec pairs))         = pairs
 417    mk_pairs (_, LetFloater (CoNonRec binder rhs)) = [(binder,rhs)]
 418    mk_pairs (_, CaseFloater _)                    = panic "floatsToBindPairs"
 419
 420 install :: FloatingBinds -> PlainCoreExpr -> PlainCoreExpr
 421
 422 install defn_groups expr
 423   = foldr install_group expr defn_groups
 424   where
 425     install_group (_, LetFloater defns) body = CoLet defns body
 426     install_group (_, CaseFloater fn)   body = fn body
 427 \end{code}