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