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