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, manifestlyWHNF, manifestlyBottom )
  30 import FreeVars         -- all of it
  31 import Id               ( idType, mkSysLocal, toplevelishId,
  32                           nullIdEnv, addOneToIdEnv, growIdEnvList,
  33                           unionManyIdSets, minusIdSet, mkIdSet,
  34                           idSetToList,
  35                           lookupIdEnv, SYN_IE(IdEnv)
  36                         )
  37 import Pretty           ( ppStr, ppBesides, ppChar, ppInt )
  38 import SrcLoc           ( mkUnknownSrcLoc )
  39 import Type             ( isPrimType, mkTyVarTys, mkForAllTys )
  40 import TyVar            ( nullTyVarEnv, addOneToTyVarEnv,
  41                           growTyVarEnvList, lookupTyVarEnv,
  42                           tyVarSetToList,
  43                           SYN_IE(TyVarEnv),
  44                           unionManyTyVarSets
  45                         )
  46 import UniqSupply       ( thenUs, returnUs, mapUs, mapAndUnzipUs,
  47                           mapAndUnzip3Us, getUnique, SYN_IE(UniqSM),
  48                           UniqSupply
  49                         )
  50 import Usage            ( SYN_IE(UVar) )
  51 import Util             ( mapAccumL, zipWithEqual, zipEqual, panic, assertPanic )
  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 TyVar UVar
  96 type LevelledArg   = GenCoreArg                 Id TyVar UVar
  97 type LevelledBind  = GenCoreBinding (Id, Level) Id TyVar UVar
  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 sty Top             = ppStr "<Top>"
 146   ppr sty (Level maj min) = ppBesides [ ppChar '<', ppInt maj, ppChar ',', ppInt min, ppChar '>' ]
 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, nullTyVarEnv)
 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 TyVar UVar 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 True {- 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 (_, AnnSCC cc expr)
 264   = lvlExpr ctxt_lvl envs expr          `thenLvl` \ expr' ->
 265     returnLvl (SCC cc expr')
 266
 267 lvlExpr ctxt_lvl envs (_, AnnCoerce c ty expr)
 268   = lvlExpr ctxt_lvl envs expr          `thenLvl` \ expr' ->
 269     returnLvl (Coerce c ty expr')
 270
 271 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnLam (ValBinder arg) rhs)
 272   = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' ->
 273     returnLvl (Lam (ValBinder (arg,incd_lvl)) rhs')
 274   where
 275     incd_lvl = incMajorLvl ctxt_lvl
 276     new_venv = growIdEnvList venv [(arg,incd_lvl)]
 277
 278 lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) e)
 279   = lvlExpr incd_lvl (venv, new_tenv) e `thenLvl` \ e' ->
 280     returnLvl (Lam (TyBinder tyvar) e')
 281   where
 282     incd_lvl   = incMinorLvl ctxt_lvl
 283     new_tenv   = addOneToTyVarEnv tenv tyvar incd_lvl
 284
 285 lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (UsageBinder u) e)
 286   = panic "SetLevels.lvlExpr:AnnLam UsageBinder"
 287
 288 lvlExpr ctxt_lvl envs (_, AnnLet bind body)
 289   = lvlBind ctxt_lvl envs bind          `thenLvl` \ (binds', new_envs) ->
 290     lvlExpr ctxt_lvl new_envs body      `thenLvl` \ body' ->
 291     returnLvl (foldr Let body' binds') -- mkCoLet* requires Core...
 292
 293 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCase expr alts)
 294   = lvlMFE ctxt_lvl envs expr   `thenLvl` \ expr' ->
 295     lvl_alts alts               `thenLvl` \ alts' ->
 296     returnLvl (Case expr' alts')
 297     where
 298       expr_type = coreExprType (deAnnotate expr)
 299       incd_lvl  = incMinorLvl ctxt_lvl
 300
 301       lvl_alts (AnnAlgAlts alts deflt)
 302         = mapLvl lvl_alt alts   `thenLvl` \ alts' ->
 303           lvl_deflt deflt       `thenLvl` \ deflt' ->
 304           returnLvl (AlgAlts alts' deflt')
 305         where
 306           lvl_alt (con, bs, e)
 307             = let
 308                   bs'  = [ (b, incd_lvl) | b <- bs ]
 309                   new_envs = (growIdEnvList venv bs', tenv)
 310               in
 311               lvlMFE incd_lvl new_envs e        `thenLvl` \ e' ->
 312               returnLvl (con, bs', e')
 313
 314       lvl_alts (AnnPrimAlts alts deflt)
 315         = mapLvl lvl_alt alts   `thenLvl` \ alts' ->
 316           lvl_deflt deflt       `thenLvl` \ deflt' ->
 317           returnLvl (PrimAlts alts' deflt')
 318         where
 319           lvl_alt (lit, e)
 320             = lvlMFE incd_lvl envs e `thenLvl` \ e' ->
 321               returnLvl (lit, e')
 322
 323       lvl_deflt AnnNoDefault = returnLvl NoDefault
 324
 325       lvl_deflt (AnnBindDefault b expr)
 326         = let
 327               new_envs = (addOneToIdEnv venv b incd_lvl, tenv)
 328           in
 329           lvlMFE incd_lvl new_envs expr `thenLvl` \ expr' ->
 330           returnLvl (BindDefault (b, incd_lvl) expr')
 331 \end{code}
 332
 333 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
 334 the expression, so that it can itself be floated.
 335
 336 \begin{code}
 337 lvlMFE ::  Level                -- Level of innermost enclosing lambda/tylam
 338         -> LevelEnvs            -- Level of in-scope names/tyvars
 339         -> CoreExprWithFVs      -- input expression
 340         -> LvlM LevelledExpr    -- Result expression
 341
 342 lvlMFE ctxt_lvl envs@(venv,_) ann_expr
 343   | isPrimType ty       -- Can't let-bind it
 344   = lvlExpr ctxt_lvl envs ann_expr
 345
 346   | otherwise           -- Not primitive type so could be let-bound
 347   = setFloatLevel False {- Not already let-bound -}
 348         ctxt_lvl envs ann_expr ty       `thenLvl` \ (final_lvl, expr') ->
 349     returnLvl expr'
 350   where
 351     ty = coreExprType (deAnnotate ann_expr)
 352 \end{code}
 353
 354
 355 %************************************************************************
 356 %*                                                                      *
 357 \subsection{Deciding floatability}
 358 %*                                                                      *
 359 %************************************************************************
 360
 361 @setFloatLevel@ is used for let-bound right-hand-sides, or for MFEs which
 362 are being created as let-bindings
 363
 364 Decision tree:
 365 Let Bound?
 366   YES. -> (a) try abstracting type variables.
 367        If we abstract type variables it will go further, that is, past more
 368        lambdas. same as asking if the level number given by the free
 369        variables is less than the level number given by free variables
 370        and type variables together.
 371        Abstract offending type variables, e.g.
 372        change f ty a b
 373        to let v = /\ty' -> f ty' a b
 374           in v ty
 375        so that v' is not stopped by the level number of ty
 376        tag the original let with its level number
 377        (from its variables and type variables)
 378   NO.  is a WHNF?
 379          YES. -> No point in let binding to float a WHNF.
 380                  Pin (leave) expression here.
 381          NO. -> Will float past a lambda?
 382                 (check using free variables only, not type variables)
 383                   YES. -> do the same as (a) above.
 384                   NO. -> No point in let binding if it is not going anywhere
 385                          Pin (leave) expression here.
 386
 387 \begin{code}
 388 setFloatLevel :: Bool                   -- True <=> the expression is already let-bound
 389                                         -- False <=> it's a possible MFE
 390               -> Level                  -- of context
 391               -> LevelEnvs
 392
 393               -> CoreExprWithFVs        -- Original rhs
 394               -> Type           -- Type of rhs
 395
 396               -> LvlM (Level,           -- Level to attribute to this let-binding
 397                        LevelledExpr)    -- Final rhs
 398
 399 setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
 400               expr@(FVInfo fvs tfvs might_leak, _) ty
 401 -- Invariant: ctxt_lvl is never = Top
 402 -- Beautiful ASSERT, dudes (WDP 95/04)...
 403
 404 -- Now deal with (by not floating) trivial non-let-bound expressions
 405 -- which just aren't worth let-binding in order to float.  We always
 406 -- choose to float even trivial let-bound things because it doesn't do
 407 -- any harm, and not floating it may pin something important.  For
 408 -- example
 409 --
 410 --      x = let v = []
 411 --              w = 1:v
 412 --          in ...
 413 --
 414 -- Here, if we don't float v we won't float w, which is Bad News.
 415 -- If this gives any problems we could restrict the idea to things destined
 416 -- for top level.
 417
 418   | not alreadyLetBound
 419     && (manifestly_whnf || not will_float_past_lambda)
 420   =   -- Pin whnf non-let-bound expressions,
 421       -- or ones which aren't going anywhere useful
 422     lvlExpr ctxt_lvl envs expr        `thenLvl` \ expr' ->
 423     returnLvl (ctxt_lvl, expr')
 424
 425   | alreadyLetBound && not worth_type_abstraction
 426   =   -- Process the expression with a new ctxt_lvl, obtained from
 427       -- the free vars of the expression itself
 428     lvlExpr (unTopify expr_lvl) envs expr `thenLvl` \ expr' ->
 429     returnLvl (maybe_unTopify expr_lvl, expr')
 430
 431   | otherwise -- This will create a let anyway, even if there is no
 432               -- type variable to abstract, so we try to abstract anyway
 433   = abstractWrtTyVars offending_tyvars ty envs lvl_after_ty_abstr expr
 434                                               `thenLvl` \ final_expr ->
 435     returnLvl (expr_lvl, final_expr)
 436       -- OLD LIE: The body of the let, just a type application, isn't worth floating
 437       --          so pin it with ctxt_lvl
 438       -- The truth: better to give it expr_lvl in case it is pinning
 439       -- something non-trivial which depends on it.
 440   where
 441     fv_list = idSetToList    fvs
 442     tv_list = tyVarSetToList tfvs
 443     expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
 444     ids_only_lvl    = foldr (maxLvl . idLevel venv)    tOP_LEVEL fv_list
 445     tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
 446     lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl
 447
 448     will_float_past_lambda =    -- Will escape lambda if let-bound
 449                             ids_only_lvl `ltMajLvl` ctxt_lvl
 450
 451     worth_type_abstraction = -- Will escape (more) lambda(s)/type lambda(s)
 452                              -- if type abstracted
 453       (ids_only_lvl `ltLvl` tyvars_only_lvl)
 454       && not (is_trivial de_ann_expr) -- avoids abstracting trivial type applications
 455
 456     de_ann_expr = deAnnotate expr
 457
 458     is_trivial (App e a)
 459       | notValArg a     = is_trivial e
 460     is_trivial (Var _)  = True
 461     is_trivial _        = False
 462
 463     offending_tyvars = filter offending tv_list
 464     --non_offending_tyvars = filter (not . offending) tv_list
 465     --non_offending_tyvars_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL non_offending_tyvars
 466
 467     offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
 468
 469     manifestly_whnf = manifestlyWHNF de_ann_expr || manifestlyBottom de_ann_expr
 470
 471     maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
 472     maybe_unTopify lvl                                  = lvl
 473         {- ToDo [Andre]: the line above (maybe) should be Level 1 0,
 474         -- so that the let will not go past the *last* lambda if it can
 475         -- generate a space leak. If it is already in major level 0
 476         -- It won't do any harm to give it a Level 1 0.
 477         -- we should do the same test not only for things with level Top,
 478         -- but also for anything that gets a major level 0.
 479            the problem is that
 480            f = \a -> let x = [1..1000]
 481                      in zip a x
 482            ==>
 483            f = let x = [1..1000]
 484                in \a -> zip a x
 485            is just as bad as floating x to the top level.
 486            Notice it would be OK in cases like
 487            f = \a -> let x = [1..1000]
 488                          y = length x
 489                      in a + y
 490            ==>
 491            f = let x = [1..1000]
 492                    y = length x
 493                in \a -> a + y
 494            as x will be gc'd after y is updated.
 495            [We did not hit any problems with the above (Level 0 0) code
 496             in nofib benchmark]
 497         -}
 498 \end{code}
 499
 500 Abstract wrt tyvars, by making it just as if we had seen
 501
 502      let v = /\a1..an. E
 503      in v a1 ... an
 504
 505 instead of simply E. The idea is that v can be freely floated, since it
 506 has no free type variables. Of course, if E has no free type
 507 variables, then we just return E.
 508
 509 \begin{code}
 510 abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr
 511   = lvlExpr incd_lvl new_envs expr      `thenLvl` \ expr' ->
 512     newLvlVar poly_ty                   `thenLvl` \ poly_var ->
 513     let
 514        poly_var_rhs     = mkTyLam offending_tyvars expr'
 515        poly_var_binding = NonRec (poly_var, lvl) poly_var_rhs
 516        poly_var_app     = mkTyApp (Var poly_var) (mkTyVarTys offending_tyvars)
 517        final_expr       = Let poly_var_binding poly_var_app -- mkCoLet* requires Core
 518     in
 519     returnLvl final_expr
 520   where
 521     poly_ty = mkForAllTys offending_tyvars ty
 522
 523         -- These defns are just like those in the TyLam case of lvlExpr
 524     (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify lvl) offending_tyvars
 525
 526     next lvl tyvar = (lvl1, (tyvar,lvl1))
 527                      where lvl1 = incMinorLvl lvl
 528
 529     new_tenv = growTyVarEnvList tenv tyvar_lvls
 530     new_envs = (venv, new_tenv)
 531 \end{code}
 532
 533 Recursive definitions.  We want to transform
 534
 535         letrec
 536            x1 = e1
 537            ...
 538            xn = en
 539         in
 540         body
 541
 542 to
 543
 544         letrec
 545            x1' = /\ ab -> let D' in e1
 546            ...
 547            xn' = /\ ab -> let D' in en
 548         in
 549         let D in body
 550
 551 where ab are the tyvars pinning the defn further in than it
 552 need be, and D  is a bunch of simple type applications:
 553
 554                 x1_cl = x1' ab
 555                 ...
 556                 xn_cl = xn' ab
 557
 558 The "_cl" indicates that in D, the level numbers on the xi are the context level
 559 number; type applications aren't worth floating.  The D' decls are
 560 similar:
 561
 562                 x1_ll = x1' ab
 563                 ...
 564                 xn_ll = xn' ab
 565
 566 but differ in their level numbers; here the ab are the newly-introduced
 567 type lambdas.
 568
 569 \begin{code}
 570 decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
 571   | isTopMajLvl ids_only_lvl   &&               -- Destination = top
 572     not (all canFloatToTop (zipEqual "decideRec" tys rhss)) -- Some can't float to top
 573   =     -- Pin it here
 574     let
 575         ids_w_lvls = ids `zip` repeat ctxt_lvl
 576         new_envs   = (growIdEnvList venv ids_w_lvls, tenv)
 577     in
 578     mapLvl (lvlExpr ctxt_lvl new_envs) rhss     `thenLvl` \ rhss' ->
 579     returnLvl (ctxt_lvl, [], rhss')
 580
 581 {- OMITTED; see comments above near isWorthFloatingExpr
 582
 583   | not (any (isWorthFloating True . deAnnotate) rhss)
 584   =     -- Pin it here
 585     mapLvl (lvlExpr ctxt_lvl envs) rhss `thenLvl` \ rhss' ->
 586     returnLvl (ctxt_lvl, [], rhss')
 587
 588 -}
 589
 590   | ids_only_lvl `ltLvl` tyvars_only_lvl
 591   =     -- Abstract wrt tyvars;
 592         -- offending_tyvars is definitely non-empty
 593         -- (I love the ASSERT to check this...  WDP 95/02)
 594     let
 595         -- These defns are just like those in the TyLam case of lvlExpr
 596        (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify ids_only_lvl) offending_tyvars
 597
 598        next lvl tyvar = (lvl1, (tyvar,lvl1))
 599                      where lvl1 = incMinorLvl lvl
 600
 601        ids_w_incd_lvl = [(id,incd_lvl) | id <- ids]
 602        new_tenv       = growTyVarEnvList tenv tyvar_lvls
 603        new_venv       = growIdEnvList    venv ids_w_incd_lvl
 604        new_envs       = (new_venv, new_tenv)
 605     in
 606     mapLvl (lvlExpr incd_lvl new_envs) rhss     `thenLvl` \ rhss' ->
 607     mapLvl newLvlVar poly_tys                   `thenLvl` \ poly_vars ->
 608     let
 609         ids_w_poly_vars = zipEqual "decideRec2" ids poly_vars
 610
 611                 -- The "d_rhss" are the right-hand sides of "D" and "D'"
 612                 -- in the documentation above
 613         d_rhss = [ mkTyApp (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
 614
 615                 -- "local_binds" are "D'" in the documentation above
 616         local_binds = zipWithEqual "SetLevels" NonRec ids_w_incd_lvl d_rhss
 617
 618         poly_var_rhss = [ mkTyLam offending_tyvars (foldr Let rhs' local_binds)
 619                         | rhs' <- rhss' -- mkCoLet* requires Core...
 620                         ]
 621
 622         poly_binds  = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars] poly_var_rhss
 623
 624     in
 625     returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss)
 626         -- The new right-hand sides, just a type application, aren't worth floating
 627         -- so pin it with ctxt_lvl
 628
 629   | otherwise
 630   =     -- Let it float freely
 631     let
 632         ids_w_lvls = ids `zip` repeat expr_lvl
 633         new_envs   = (growIdEnvList venv ids_w_lvls, tenv)
 634     in
 635     mapLvl (lvlExpr (unTopify expr_lvl) new_envs) rhss  `thenLvl` \ rhss' ->
 636     returnLvl (expr_lvl, [], rhss')
 637
 638   where
 639     tys  = map idType ids
 640
 641     fvs  = unionManyIdSets [freeVarsOf   rhs | rhs <- rhss] `minusIdSet` mkIdSet ids
 642     tfvs = unionManyTyVarSets [freeTyVarsOf rhs | rhs <- rhss]
 643     fv_list = idSetToList fvs
 644     tv_list = tyVarSetToList tfvs
 645
 646     ids_only_lvl    = foldr (maxLvl . idLevel venv)    tOP_LEVEL fv_list
 647     tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
 648     expr_lvl        = ids_only_lvl `maxLvl` tyvars_only_lvl
 649
 650     offending_tyvars
 651         | ids_only_lvl `ltLvl` tyvars_only_lvl = filter offending tv_list
 652         | otherwise                            = []
 653
 654     offending_tyvar_tys = mkTyVarTys offending_tyvars
 655     poly_tys = map (mkForAllTys offending_tyvars) tys
 656
 657     offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
 658 \end{code}
 659
 660
 661 \begin{code}
 662 {- ******** OMITTED NOW
 663
 664 isWorthFloating :: Bool         -- True <=> already let-bound
 665                 -> CoreExpr     -- The expression
 666                 -> Bool
 667
 668 isWorthFloating alreadyLetBound expr
 669
 670   | alreadyLetBound = isWorthFloatingExpr expr
 671
 672   | otherwise       =   -- No point in adding a fresh let-binding for a WHNF, because
 673                         -- floating it isn't beneficial enough.
 674                       isWorthFloatingExpr expr &&
 675                       not (manifestlyWHNF expr || manifestlyBottom expr)
 676 ********** -}
 677
 678 isWorthFloatingExpr :: CoreExpr -> Bool
 679
 680 isWorthFloatingExpr (Var v)     = False
 681 isWorthFloatingExpr (Lit lit)   = False
 682 isWorthFloatingExpr (App e arg)
 683   | notValArg arg               = isWorthFloatingExpr e
 684 isWorthFloatingExpr (Con con as)
 685   | all notValArg as            = False -- Just a type application
 686 isWorthFloatingExpr _           = True
 687
 688 canFloatToTop :: (Type, CoreExprWithFVs) -> Bool
 689
 690 canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True
 691 canFloatToTop (ty, (FVInfo _ _ MightLeak,    expr)) = isLeakFreeType [] ty
 692
 693 valSuggestsLeakFree expr = manifestlyWHNF expr || manifestlyBottom expr
 694 \end{code}
 695
 696
 697
 698 %************************************************************************
 699 %*                                                                      *
 700 \subsection{Help functions}
 701 %*                                                                      *
 702 %************************************************************************
 703
 704 \begin{code}
 705 idLevel :: IdEnv Level -> Id -> Level
 706 idLevel venv v
 707   = case lookupIdEnv venv v of
 708       Just level -> level
 709       Nothing    -> ASSERT(toplevelishId v)
 710                     tOP_LEVEL
 711
 712 tyvarLevel :: TyVarEnv Level -> TyVar -> Level
 713 tyvarLevel tenv tyvar
 714   = case lookupTyVarEnv tenv tyvar of
 715       Just level -> level
 716       Nothing    -> tOP_LEVEL
 717 \end{code}
 718
 719 %************************************************************************
 720 %*                                                                      *
 721 \subsection{Free-To-Level Monad}
 722 %*                                                                      *
 723 %************************************************************************
 724
 725 \begin{code}
 726 type LvlM result = UniqSM result
 727
 728 thenLvl         = thenUs
 729 returnLvl       = returnUs
 730 mapLvl          = mapUs
 731 mapAndUnzipLvl  = mapAndUnzipUs
 732 mapAndUnzip3Lvl = mapAndUnzip3Us
 733 \end{code}
 734
 735 We create a let-binding for `interesting' (non-utterly-trivial)
 736 applications, to give them a fighting chance of being floated.
 737
 738 \begin{code}
 739 newLvlVar :: Type -> LvlM Id
 740
 741 newLvlVar ty us
 742   = mkSysLocal SLIT("lvl") (getUnique us) ty mkUnknownSrcLoc
 743 \end{code}