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