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