ghc/compiler/simplCore/SetLevels.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section{SetLevels}
   5
   6 We attach binding levels to Core bindings, in preparation for floating
   7 outwards (@FloatOut@).
   8
   9 We also let-ify many applications (notably case scrutinees), so they
  10 will have a fighting chance of being floated sensible.
  11
  12 \begin{code}
  13 #include "HsVersions.h"
  14
  15 module SetLevels (
  16         setLevels,
  17
  18         Level(..), tOP_LEVEL,
  19
  20         incMinorLvl, ltMajLvl, ltLvl, isTopLvl
  21 -- not exported: , incMajorLvl, isTopMajLvl, unTopify
  22     ) where
  23
  24 import Type             ( isPrimType, isLeakFreeType, mkTyVarTy,
  25                           quantifyTy, TyVarTemplate -- Needed for quantifyTy
  26                         )
  27 import AnnCoreSyn
  28 import Literal          ( Literal(..) )
  29 import CmdLineOpts      ( GlobalSwitch(..) )
  30 import FreeVars
  31 import Id               ( mkSysLocal, idType, eqId,
  32                           isBottomingId, toplevelishId, DataCon(..)
  33                           IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
  34                         )
  35 import Maybes           ( Maybe(..) )
  36 import Pretty           -- debugging only
  37 import UniqSet
  38 import SrcLoc           ( mkUnknownSrcLoc, SrcLoc )
  39 import UniqSupply
  40 import Util
  41 \end{code}
  42
  43 %************************************************************************
  44 %*                                                                      *
  45 \subsection{Level numbers}
  46 %*                                                                      *
  47 %************************************************************************
  48
  49 \begin{code}
  50 data Level = Level
  51                 Int     -- Level number of enclosing lambdas
  52                 Int     -- Number of big-lambda and/or case expressions between
  53                         -- here and the nearest enclosing lambda
  54
  55            | Top        -- Means *really* the top level.
  56 \end{code}
  57
  58 The {\em level number} on a (type-)lambda-bound variable is the
  59 nesting depth of the (type-)lambda which binds it.  On an expression, it's the
  60 maximum level number of its free (type-)variables.  On a let(rec)-bound
  61 variable, it's the level of its RHS.  On a case-bound variable, it's
  62 the number of enclosing lambdas.
  63
  64 Top-level variables: level~0.  Those bound on the RHS of a top-level
  65 definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
  66 as ``subscripts'')...
  67 \begin{verbatim}
  68 a_0 = let  b_? = ...  in
  69            x_1 = ... b ... in ...
  70 \end{verbatim}
  71
  72 Level 0 0 will make something get floated to a top-level "equals", @Top@
  73 makes it go right to the top.
  74
  75 The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@).  That's
  76 meant to be the level number of the enclosing binder in the final (floated)
  77 program.  If the level number of a sub-expression is less than that of the
  78 context, then it might be worth let-binding the sub-expression so that it
  79 will indeed float. This context level starts at @Level 0 0@; it is never @Top@.
  80
  81 \begin{code}
  82 type LevelledExpr  = GenCoreExpr         (Id, Level) Id
  83 type LevelledAtom  = GenCoreAtom    Id
  84 type LevelledBind  = GenCoreBinding (Id, Level) Id
  85
  86 type LevelEnvs = (IdEnv    Level, -- bind Ids to levels
  87                   TyVarEnv Level) -- bind type variables to levels
  88
  89 tOP_LEVEL     = Top
  90
  91 incMajorLvl :: Level -> Level
  92 incMajorLvl Top                 = Level 1 0
  93 incMajorLvl (Level major minor) = Level (major+1) 0
  94
  95 incMinorLvl :: Level -> Level
  96 incMinorLvl Top                 = Level 0 1
  97 incMinorLvl (Level major minor) = Level major (minor+1)
  98
  99 maxLvl :: Level -> Level -> Level
 100 maxLvl Top l2 = l2
 101 maxLvl l1 Top = l1
 102 maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)
 103   | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
 104   | otherwise                                      = l2
 105
 106 ltLvl :: Level -> Level -> Bool
 107 ltLvl l1                Top               = False
 108 ltLvl Top               (Level _ _)       = True
 109 ltLvl (Level maj1 min1) (Level maj2 min2) = (maj1 < maj2) ||
 110                                             (maj1 == maj2 && min1 < min2)
 111
 112 ltMajLvl :: Level -> Level -> Bool      -- Tells if one level belongs to a difft
 113                                         -- *lambda* level to another
 114 ltMajLvl l1             Top            = False
 115 ltMajLvl Top            (Level 0 _)    = False
 116 ltMajLvl Top            (Level _ _)    = True
 117 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
 118
 119 isTopLvl :: Level -> Bool
 120 isTopLvl Top   = True
 121 isTopLvl other = False
 122
 123 isTopMajLvl :: Level -> Bool            -- Tells if it's the top *lambda* level
 124 isTopMajLvl Top           = True
 125 isTopMajLvl (Level maj _) = maj == 0
 126
 127 unTopify :: Level -> Level
 128 unTopify Top = Level 0 0
 129 unTopify lvl = lvl
 130
 131 instance Outputable Level where
 132   ppr sty Top             = ppStr "<Top>"
 133   ppr sty (Level maj min) = ppBesides [ ppChar '<', ppInt maj, ppChar ',', ppInt min, ppChar '>' ]
 134 \end{code}
 135
 136 %************************************************************************
 137 %*                                                                      *
 138 \subsection{Main level-setting code}
 139 %*                                                                      *
 140 %************************************************************************
 141
 142 \begin{code}
 143 setLevels :: [CoreBinding]
 144           -> (GlobalSwitch -> Bool)      -- access to all global cmd-line opts
 145           -> UniqSupply
 146           -> [LevelledBind]
 147
 148 setLevels binds sw us
 149   = do_them binds sw us
 150   where
 151     -- "do_them"'s main business is to thread the monad along
 152     -- It gives each top binding the same empty envt, because
 153     -- things unbound in the envt have level number zero implicitly
 154     do_them :: [CoreBinding] -> LvlM [LevelledBind]
 155
 156     do_them [] = returnLvl []
 157     do_them (b:bs)
 158       = lvlTopBind b    `thenLvl` \ (lvld_bind, _) ->
 159         do_them bs       `thenLvl` \ lvld_binds ->
 160         returnLvl (lvld_bind ++ lvld_binds)
 161
 162 initial_envs = (nullIdEnv, nullTyVarEnv)
 163
 164 -- OLDER:
 165 lvlTopBind (NonRec binder rhs)
 166   = lvlBind (Level 0 0) initial_envs (AnnCoNonRec binder (freeVars rhs))
 167                                         -- Rhs can have no free vars!
 168
 169 lvlTopBind (Rec pairs)
 170   = lvlBind (Level 0 0) initial_envs (AnnCoRec [(b,freeVars rhs) | (b,rhs) <- pairs])
 171
 172 {- NEWER: Too bad about the types: WDP:
 173 lvlTopBind (NonRec binder rhs)
 174   = {-SIGH:wrong type: ASSERT(isEmptyUniqSet (freeVarsOf rhs))-} -- Rhs can have no free vars!
 175     lvlBind (Level 0 0) initial_envs (AnnCoNonRec binder emptyUniqSet)
 176
 177 lvlTopBind (Rec pairs)
 178   = lvlBind (Level 0 0) initial_envs
 179         (AnnCoRec [(b, emptyUniqSet)
 180                   | (b, rhs) <- pairs,
 181                     {-SIGH:ditto:ASSERT(isEmptyUniqSet (freeVarsOf rhs))-} True])
 182 -}
 183 \end{code}
 184
 185 %************************************************************************
 186 %*                                                                      *
 187 \subsection{Bindings}
 188 %*                                                                      *
 189 %************************************************************************
 190
 191 The binding stuff works for top level too.
 192
 193 \begin{code}
 194 type CoreBindingWithFVs = AnnCoreBinding Id Id FVInfo
 195
 196 lvlBind :: Level
 197         -> LevelEnvs
 198         -> CoreBindingWithFVs
 199         -> LvlM ([LevelledBind], LevelEnvs)
 200
 201 lvlBind ctxt_lvl envs@(venv, tenv) (AnnCoNonRec name rhs)
 202   = setFloatLevel True {- Already let-bound -}
 203         ctxt_lvl envs rhs ty    `thenLvl` \ (final_lvl, rhs') ->
 204     let
 205         new_envs = (addOneToIdEnv venv name final_lvl, tenv)
 206     in
 207     returnLvl ([NonRec (name, final_lvl) rhs'], new_envs)
 208   where
 209     ty = idType name
 210
 211
 212 lvlBind ctxt_lvl envs@(venv, tenv) (AnnCoRec pairs)
 213   = decideRecFloatLevel ctxt_lvl envs binders rhss
 214                                 `thenLvl` \ (final_lvl, extra_binds, rhss') ->
 215     let
 216         binders_w_lvls = binders `zip` repeat final_lvl
 217         new_envs       = (growIdEnvList venv binders_w_lvls, tenv)
 218     in
 219     returnLvl (extra_binds ++ [Rec (binders_w_lvls `zip` rhss')], new_envs)
 220   where
 221     (binders,rhss) = unzip pairs
 222 \end{code}
 223
 224 %************************************************************************
 225 %*                                                                      *
 226 \subsection{Setting expression levels}
 227 %*                                                                      *
 228 %************************************************************************
 229
 230 \begin{code}
 231 lvlExpr :: Level                -- ctxt_lvl: Level of enclosing expression
 232         -> LevelEnvs            -- Level of in-scope names/tyvars
 233         -> CoreExprWithFVs      -- input expression
 234         -> LvlM LevelledExpr    -- Result expression
 235 \end{code}
 236
 237 The @ctxt_lvl@ is, roughly, the level of the innermost enclosing
 238 binder.
 239
 240 Here's an example
 241
 242         v = \x -> ...\y -> let r = case (..x..) of
 243                                         ..x..
 244                            in ..
 245
 246 When looking at the rhs of @r@, @ctxt_lvl@ will be 1 because that's
 247 the level of @r@, even though it's inside a level-2 @\y@.  It's
 248 important that @ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
 249 don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
 250 --- because it isn't a *maximal* free expression.
 251
 252 If there were another lambda in @r@'s rhs, it would get level-2 as well.
 253
 254 \begin{code}
 255 lvlExpr _ _ (_, AnnCoVar v)               = returnLvl (Var v)
 256 lvlExpr _ _ (_, AnnCoLit l)       = returnLvl (Lit l)
 257 lvlExpr _ _ (_, AnnCoCon con tys atoms) = returnLvl (Con con tys atoms)
 258 lvlExpr _ _ (_, AnnCoPrim op tys atoms) = returnLvl (Prim op tys atoms)
 259
 260 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoTyApp expr ty)
 261   = lvlExpr ctxt_lvl envs expr          `thenLvl` \ expr' ->
 262     returnLvl (CoTyApp expr' ty)
 263
 264 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoApp fun arg)
 265   = lvlExpr ctxt_lvl envs fun           `thenLvl` \ fun' ->
 266     returnLvl (App fun' arg)
 267
 268 lvlExpr ctxt_lvl envs (_, AnnCoSCC cc expr)
 269   = lvlExpr ctxt_lvl envs expr          `thenLvl` \ expr' ->
 270     returnLvl (SCC cc expr')
 271
 272 lvlExpr ctxt_lvl (venv, tenv) (_, AnnCoTyLam tyvar e)
 273   = lvlExpr incd_lvl (venv, new_tenv) e `thenLvl` \ e' ->
 274     returnLvl (CoTyLam tyvar e')
 275   where
 276     incd_lvl = incMinorLvl ctxt_lvl
 277     new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl
 278
 279 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam arg rhs)
 280   = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' ->
 281     returnLvl (Lam (arg,incd_lvl) rhs')
 282   where
 283     incd_lvl = incMajorLvl ctxt_lvl
 284     new_venv = growIdEnvList venv [(arg,incd_lvl)]
 285
 286 lvlExpr ctxt_lvl envs (_, AnnCoLet bind body)
 287   = lvlBind ctxt_lvl envs bind          `thenLvl` \ (binds', new_envs) ->
 288     lvlExpr ctxt_lvl new_envs body      `thenLvl` \ body' ->
 289     returnLvl (foldr Let body' binds') -- mkCoLet* requires Core...
 290
 291 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoCase expr alts)
 292   = lvlMFE ctxt_lvl envs expr   `thenLvl` \ expr' ->
 293     lvl_alts alts               `thenLvl` \ alts' ->
 294     returnLvl (Case expr' alts')
 295     where
 296       expr_type = coreExprType (deAnnotate expr)
 297       incd_lvl  = incMinorLvl ctxt_lvl
 298
 299       lvl_alts (AnnCoAlgAlts alts deflt)
 300         = mapLvl lvl_alt alts   `thenLvl` \ alts' ->
 301           lvl_deflt deflt       `thenLvl` \ deflt' ->
 302           returnLvl (AlgAlts alts' deflt')
 303         where
 304           lvl_alt (con, bs, e)
 305             = let
 306                   bs'  = [ (b, incd_lvl) | b <- bs ]
 307                   new_envs = (growIdEnvList venv bs', tenv)
 308               in
 309               lvlMFE incd_lvl new_envs e        `thenLvl` \ e' ->
 310               returnLvl (con, bs', e')
 311
 312       lvl_alts (AnnCoPrimAlts alts deflt)
 313         = mapLvl lvl_alt alts   `thenLvl` \ alts' ->
 314           lvl_deflt deflt       `thenLvl` \ deflt' ->
 315           returnLvl (PrimAlts alts' deflt')
 316         where
 317           lvl_alt (lit, e)
 318             = lvlMFE incd_lvl envs e `thenLvl` \ e' ->
 319               returnLvl (lit, e')
 320
 321       lvl_deflt AnnCoNoDefault = returnLvl NoDefault
 322
 323       lvl_deflt (AnnCoBindDefault b expr)
 324         = let
 325               new_envs = (addOneToIdEnv venv b incd_lvl, tenv)
 326           in
 327           lvlMFE incd_lvl new_envs expr `thenLvl` \ expr' ->
 328           returnLvl (BindDefault (b, incd_lvl) expr')
 329 \end{code}
 330
 331 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
 332 the expression, so that it can itself be floated.
 333
 334 \begin{code}
 335 lvlMFE ::  Level                -- Level of innermost enclosing lambda/tylam
 336         -> LevelEnvs            -- Level of in-scope names/tyvars
 337         -> CoreExprWithFVs      -- input expression
 338         -> LvlM LevelledExpr    -- Result expression
 339
 340 lvlMFE ctxt_lvl envs@(venv,_) ann_expr
 341   | isPrimType ty       -- Can't let-bind it
 342   = lvlExpr ctxt_lvl envs ann_expr
 343
 344   | otherwise           -- Not primitive type so could be let-bound
 345   = setFloatLevel False {- Not already let-bound -}
 346         ctxt_lvl envs ann_expr ty       `thenLvl` \ (final_lvl, expr') ->
 347     returnLvl expr'
 348   where
 349     ty = coreExprType (deAnnotate ann_expr)
 350 \end{code}
 351
 352
 353 %************************************************************************
 354 %*                                                                      *
 355 \subsection{Deciding floatability}
 356 %*                                                                      *
 357 %************************************************************************
 358
 359 @setFloatLevel@ is used for let-bound right-hand-sides, or for MFEs which
 360 are being created as let-bindings
 361
 362 Decision tree:
 363 Let Bound?
 364   YES. -> (a) try abstracting type variables.
 365        If we abstract type variables it will go further, that is, past more
 366        lambdas. same as asking if the level number given by the free
 367        variables is less than the level number given by free variables
 368        and type variables together.
 369        Abstract offending type variables, e.g.
 370        change f ty a b
 371        to let v = /\ty' -> f ty' a b
 372           in v ty
 373        so that v' is not stopped by the level number of ty
 374        tag the original let with its level number
 375        (from its variables and type variables)
 376   NO.  is a WHNF?
 377          YES. -> No point in let binding to float a WHNF.
 378                  Pin (leave) expression here.
 379          NO. -> Will float past a lambda?
 380                 (check using free variables only, not type variables)
 381                   YES. -> do the same as (a) above.
 382                   NO. -> No point in let binding if it is not going anywhere
 383                          Pin (leave) expression here.
 384
 385 \begin{code}
 386 setFloatLevel :: Bool                   -- True <=> the expression is already let-bound
 387                                         -- False <=> it's a possible MFE
 388               -> Level                  -- of context
 389               -> LevelEnvs
 390
 391               -> CoreExprWithFVs        -- Original rhs
 392               -> Type           -- Type of rhs
 393
 394               -> LvlM (Level,           -- Level to attribute to this let-binding
 395                        LevelledExpr)    -- Final rhs
 396
 397 setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
 398               expr@(FVInfo fvs tfvs might_leak, _) ty
 399 -- Invariant: ctxt_lvl is never = Top
 400 -- Beautiful ASSERT, dudes (WDP 95/04)...
 401
 402 -- Now deal with (by not floating) trivial non-let-bound expressions
 403 -- which just aren't worth let-binding in order to float.  We always
 404 -- choose to float even trivial let-bound things because it doesn't do
 405 -- any harm, and not floating it may pin something important.  For
 406 -- example
 407 --
 408 --      x = let v = Nil
 409 --              w = 1:v
 410 --          in ...
 411 --
 412 -- Here, if we don't float v we won't float w, which is Bad News.
 413 -- If this gives any problems we could restrict the idea to things destined
 414 -- for top level.
 415
 416   | not alreadyLetBound
 417     && (manifestly_whnf || not will_float_past_lambda)
 418   =   -- Pin whnf non-let-bound expressions,
 419       -- or ones which aren't going anywhere useful
 420     lvlExpr ctxt_lvl envs expr        `thenLvl` \ expr' ->
 421     returnLvl (ctxt_lvl, expr')
 422
 423   | alreadyLetBound && not worth_type_abstraction
 424   =   -- Process the expression with a new ctxt_lvl, obtained from
 425       -- the free vars of the expression itself
 426     lvlExpr (unTopify expr_lvl) envs expr `thenLvl` \ expr' ->
 427     returnLvl (maybe_unTopify expr_lvl, expr')
 428
 429   | otherwise -- This will create a let anyway, even if there is no
 430               -- type variable to abstract, so we try to abstract anyway
 431   = abstractWrtTyVars offending_tyvars ty envs lvl_after_ty_abstr expr
 432                                               `thenLvl` \ final_expr ->
 433     returnLvl (expr_lvl, final_expr)
 434       -- OLD LIE: The body of the let, just a type application, isn't worth floating
 435       --          so pin it with ctxt_lvl
 436       -- The truth: better to give it expr_lvl in case it is pinning
 437       -- something non-trivial which depends on it.
 438   where
 439     fv_list = uniqSetToList fvs
 440     tv_list = uniqSetToList tfvs
 441     expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
 442     ids_only_lvl    = foldr (maxLvl . idLevel venv)    tOP_LEVEL fv_list
 443     tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
 444     lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl
 445
 446     will_float_past_lambda =    -- Will escape lambda if let-bound
 447                             ids_only_lvl `ltMajLvl` ctxt_lvl
 448
 449     worth_type_abstraction = -- Will escape (more) lambda(s)/type lambda(s)
 450                              -- if type abstracted
 451       (ids_only_lvl `ltLvl` tyvars_only_lvl)
 452       && not (is_trivial de_ann_expr) -- avoids abstracting trivial type applications
 453
 454     de_ann_expr = deAnnotate expr
 455
 456     is_trivial (CoTyApp e _) = is_trivial e
 457     is_trivial (Var _)     = True
 458     is_trivial _             = False
 459
 460     offending_tyvars = filter offending tv_list
 461     --non_offending_tyvars = filter (not . offending) tv_list
 462     --non_offending_tyvars_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL non_offending_tyvars
 463
 464     offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
 465
 466     manifestly_whnf = manifestlyWHNF de_ann_expr || manifestlyBottom de_ann_expr
 467
 468     maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
 469     maybe_unTopify lvl                                  = lvl
 470         {- ToDo [Andre]: the line above (maybe) should be Level 1 0,
 471         -- so that the let will not go past the *last* lambda if it can
 472         -- generate a space leak. If it is already in major level 0
 473         -- It won't do any harm to give it a Level 1 0.
 474         -- we should do the same test not only for things with level Top,
 475         -- but also for anything that gets a major level 0.
 476            the problem is that
 477            f = \a -> let x = [1..1000]
 478                      in zip a x
 479            ==>
 480            f = let x = [1..1000]
 481                in \a -> zip a x
 482            is just as bad as floating x to the top level.
 483            Notice it would be OK in cases like
 484            f = \a -> let x = [1..1000]
 485                          y = length x
 486                      in a + y
 487            ==>
 488            f = let x = [1..1000]
 489                    y = length x
 490                in \a -> a + y
 491            as x will be gc'd after y is updated.
 492            [We did not hit any problems with the above (Level 0 0) code
 493             in nofib benchmark]
 494         -}
 495 \end{code}
 496
 497 Abstract wrt tyvars, by making it just as if we had seen
 498
 499      let v = /\a1..an. E
 500      in v a1 ... an
 501
 502 instead of simply E. The idea is that v can be freely floated, since it
 503 has no free type variables. Of course, if E has no free type
 504 variables, then we just return E.
 505
 506 \begin{code}
 507 abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr
 508   = lvlExpr incd_lvl new_envs expr      `thenLvl` \ expr' ->
 509     newLvlVar poly_ty                   `thenLvl` \ poly_var ->
 510     let
 511        poly_var_rhs     = mkCoTyLam offending_tyvars expr'
 512        poly_var_binding = NonRec (poly_var, lvl) poly_var_rhs
 513        poly_var_app     = mkCoTyApps (Var poly_var) (map mkTyVarTy offending_tyvars)
 514        final_expr       = Let poly_var_binding poly_var_app -- mkCoLet* requires Core
 515     in
 516     returnLvl final_expr
 517   where
 518     poly_ty         = snd (quantifyTy offending_tyvars ty)
 519
 520         -- These defns are just like those in the TyLam case of lvlExpr
 521     (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify lvl) offending_tyvars
 522
 523     next lvl tyvar = (lvl1, (tyvar,lvl1))
 524                      where lvl1 = incMinorLvl lvl
 525
 526     new_tenv = growTyVarEnvList tenv tyvar_lvls
 527     new_envs = (venv, new_tenv)
 528 \end{code}
 529
 530 Recursive definitions.  We want to transform
 531
 532         letrec
 533            x1 = e1
 534            ...
 535            xn = en
 536         in
 537         body
 538
 539 to
 540
 541         letrec
 542            x1' = /\ ab -> let D' in e1
 543            ...
 544            xn' = /\ ab -> let D' in en
 545         in
 546         let D in body
 547
 548 where ab are the tyvars pinning the defn further in than it
 549 need be, and D  is a bunch of simple type applications:
 550
 551                 x1_cl = x1' ab
 552                 ...
 553                 xn_cl = xn' ab
 554
 555 The "_cl" indicates that in D, the level numbers on the xi are the context level
 556 number; type applications aren't worth floating.  The D' decls are
 557 similar:
 558
 559                 x1_ll = x1' ab
 560                 ...
 561                 xn_ll = xn' ab
 562
 563 but differ in their level numbers; here the ab are the newly-introduced
 564 type lambdas.
 565
 566 \begin{code}
 567 decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
 568   | isTopMajLvl ids_only_lvl   &&               -- Destination = top
 569     not (all canFloatToTop (tys `zip` rhss))    -- Some can't float to top
 570   =     -- Pin it here
 571     let
 572         ids_w_lvls = ids `zip` repeat ctxt_lvl
 573         new_envs       = (growIdEnvList venv ids_w_lvls, tenv)
 574     in
 575     mapLvl (lvlExpr ctxt_lvl new_envs) rhss     `thenLvl` \ rhss' ->
 576     returnLvl (ctxt_lvl, [], rhss')
 577
 578 {- OMITTED; see comments above near isWorthFloatingExpr
 579
 580   | not (any (isWorthFloating True . deAnnotate) rhss)
 581   =     -- Pin it here
 582     mapLvl (lvlExpr ctxt_lvl envs) rhss `thenLvl` \ rhss' ->
 583     returnLvl (ctxt_lvl, [], rhss')
 584
 585 -}
 586
 587   | ids_only_lvl `ltLvl` tyvars_only_lvl
 588   =     -- Abstract wrt tyvars;
 589         -- offending_tyvars is definitely non-empty
 590         -- (I love the ASSERT to check this...  WDP 95/02)
 591     let
 592         -- These defns are just like those in the TyLam case of lvlExpr
 593        (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify ids_only_lvl) offending_tyvars
 594
 595        next lvl tyvar = (lvl1, (tyvar,lvl1))
 596                      where lvl1 = incMinorLvl lvl
 597
 598        ids_w_incd_lvl = [(id,incd_lvl) | id <- ids]
 599        new_tenv       = growTyVarEnvList tenv tyvar_lvls
 600        new_venv       = growIdEnvList    venv ids_w_incd_lvl
 601        new_envs       = (new_venv, new_tenv)
 602     in
 603     mapLvl (lvlExpr incd_lvl new_envs) rhss     `thenLvl` \ rhss' ->
 604     mapLvl newLvlVar poly_tys                   `thenLvl` \ poly_vars ->
 605     let
 606         ids_w_poly_vars = ids `zip` poly_vars
 607
 608                 -- The "d_rhss" are the right-hand sides of "D" and "D'"
 609                 -- in the documentation above
 610         d_rhss = [ mkCoTyApps (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
 611
 612                 -- "local_binds" are "D'" in the documentation above
 613         local_binds = zipWithEqual NonRec ids_w_incd_lvl d_rhss
 614
 615         poly_var_rhss = [ mkCoTyLam offending_tyvars (foldr Let rhs' local_binds)
 616                         | rhs' <- rhss' -- mkCoLet* requires Core...
 617                         ]
 618
 619         poly_binds  = [(poly_var, ids_only_lvl) | poly_var <- poly_vars] `zip` poly_var_rhss
 620
 621     in
 622     returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss)
 623         -- The new right-hand sides, just a type application, aren't worth floating
 624         -- so pin it with ctxt_lvl
 625
 626   | otherwise
 627   =     -- Let it float freely
 628     let
 629         ids_w_lvls = ids `zip` repeat expr_lvl
 630         new_envs   = (growIdEnvList venv ids_w_lvls, tenv)
 631     in
 632     mapLvl (lvlExpr (unTopify expr_lvl) new_envs) rhss  `thenLvl` \ rhss' ->
 633     returnLvl (expr_lvl, [], rhss')
 634
 635   where
 636     tys  = map idType ids
 637
 638     fvs  = unionManyUniqSets [freeVarsOf   rhs | rhs <- rhss] `minusUniqSet` mkUniqSet ids
 639     tfvs = unionManyUniqSets [freeTyVarsOf rhs | rhs <- rhss]
 640     fv_list = uniqSetToList fvs
 641     tv_list = uniqSetToList tfvs
 642
 643     ids_only_lvl    = foldr (maxLvl . idLevel venv)    tOP_LEVEL fv_list
 644     tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
 645     expr_lvl        = ids_only_lvl `maxLvl` tyvars_only_lvl
 646
 647     offending_tyvars
 648         | ids_only_lvl `ltLvl` tyvars_only_lvl = filter offending tv_list
 649         | otherwise                            = []
 650
 651     offending_tyvar_tys = map mkTyVarTy offending_tyvars
 652     poly_tys            = [ snd (quantifyTy offending_tyvars ty)
 653                           | ty <- tys
 654                           ]
 655
 656     offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
 657 \end{code}
 658
 659
 660 \begin{code}
 661 {- ******** OMITTED NOW
 662
 663 isWorthFloating :: Bool         -- True <=> already let-bound
 664                 -> CoreExpr     -- The expression
 665                 -> Bool
 666
 667 isWorthFloating alreadyLetBound expr
 668
 669   | alreadyLetBound = isWorthFloatingExpr expr
 670
 671   | otherwise       =   -- No point in adding a fresh let-binding for a WHNF, because
 672                         -- floating it isn't beneficial enough.
 673                       isWorthFloatingExpr expr &&
 674                       not (manifestlyWHNF expr || manifestlyBottom expr)
 675 ********** -}
 676
 677 isWorthFloatingExpr :: CoreExpr -> Bool
 678 isWorthFloatingExpr (Var v)             = False
 679 isWorthFloatingExpr (Lit lit)           = False
 680 isWorthFloatingExpr (Con con tys [])  = False   -- Just a type application
 681 isWorthFloatingExpr (CoTyApp expr ty)   = isWorthFloatingExpr expr
 682 isWorthFloatingExpr  other              = True
 683
 684 canFloatToTop :: (Type, CoreExprWithFVs) -> Bool
 685
 686 canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True
 687 canFloatToTop (ty, (FVInfo _ _ MightLeak,    expr)) = isLeakFreeType [] ty
 688
 689 valSuggestsLeakFree expr = manifestlyWHNF expr || manifestlyBottom expr
 690 \end{code}
 691
 692
 693
 694 %************************************************************************
 695 %*                                                                      *
 696 \subsection{Help functions}
 697 %*                                                                      *
 698 %************************************************************************
 699
 700 \begin{code}
 701 idLevel :: IdEnv Level -> Id -> Level
 702 idLevel venv v
 703   = case lookupIdEnv venv v of
 704       Just level -> level
 705       Nothing    -> ASSERT(toplevelishId v)
 706                     tOP_LEVEL
 707
 708 tyvarLevel :: TyVarEnv Level -> TyVar -> Level
 709 tyvarLevel tenv tyvar
 710   = case lookupTyVarEnv tenv tyvar of
 711       Just level -> level
 712       Nothing    -> tOP_LEVEL
 713 \end{code}
 714
 715 %************************************************************************
 716 %*                                                                      *
 717 \subsection{Free-To-Level Monad}
 718 %*                                                                      *
 719 %************************************************************************
 720
 721 \begin{code}
 722 type LvlM result
 723   = (GlobalSwitch -> Bool) -> UniqSupply -> result
 724
 725 thenLvl m k sw us
 726   = case splitUniqSupply us     of { (s1, s2) ->
 727     case m sw s1                of { m_result ->
 728     k m_result sw s2 }}
 729
 730 returnLvl v sw us = v
 731
 732 mapLvl f []     = returnLvl []
 733 mapLvl f (x:xs)
 734   = f x         `thenLvl` \ r  ->
 735     mapLvl f xs `thenLvl` \ rs ->
 736     returnLvl (r:rs)
 737
 738 mapAndUnzipLvl f [] = returnLvl ([], [])
 739 mapAndUnzipLvl f (x:xs)
 740   = f x                  `thenLvl` \ (r1,  r2) ->
 741     mapAndUnzipLvl f xs `thenLvl` \ (rs1, rs2) ->
 742     returnLvl (r1:rs1, r2:rs2)
 743
 744 mapAndUnzip3Lvl f [] = returnLvl ([], [], [])
 745 mapAndUnzip3Lvl f (x:xs)
 746   = f x                  `thenLvl` \ (r1,  r2,  r3)  ->
 747     mapAndUnzip3Lvl f xs `thenLvl` \ (rs1, rs2, rs3) ->
 748     returnLvl (r1:rs1, r2:rs2, r3:rs3)
 749 \end{code}
 750
 751 We create a let-binding for `interesting' (non-utterly-trivial)
 752 applications, to give them a fighting chance of being floated.
 753
 754 \begin{code}
 755 newLvlVar :: Type -> LvlM Id
 756
 757 newLvlVar ty sw us
 758   = id
 759   where
 760     id = mkSysLocal SLIT("lvl") uniq ty mkUnknownSrcLoc
 761     uniq = getUnique us
 762 \end{code}