ghc/compiler/simplCore/SimplUtils.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section[SimplUtils]{The simplifier utilities}
   5
   6 \begin{code}
   7 module SimplUtils (
   8
   9         newId, newIds,
  10
  11         floatExposesHNF,
  12
  13         etaCoreExpr, mkRhsTyLam,
  14
  15         etaExpandCount,
  16
  17         simplIdWantsToBeINLINEd,
  18
  19         singleConstructorType, typeOkForCase,
  20
  21         substSpecEnvRhs
  22     ) where
  23
  24 #include "HsVersions.h"
  25
  26 import BinderInfo
  27 import CmdLineOpts      ( opt_DoEtaReduction, SimplifierSwitch(..) )
  28 import CoreSyn
  29 import CoreUnfold       ( mkFormSummary, exprIsTrivial, FormSummary(..) )
  30 import MkId             ( mkSysLocal )
  31 import Id               ( idType, isBottomingId, getIdArity,
  32                           addInlinePragma, addIdDemandInfo,
  33                           idWantsToBeINLINEd, dataConArgTys, Id,
  34                           lookupIdEnv, delOneFromIdEnv
  35                         )
  36 import IdInfo           ( ArityInfo(..), DemandInfo )
  37 import Maybes           ( maybeToBool )
  38 import PrelVals         ( augmentId, buildId )
  39 import PrimOp           ( primOpIsCheap )
  40 import SimplEnv
  41 import SimplMonad
  42 import Type             ( tyVarsOfType, tyVarsOfTypes, mkForAllTys, mkTyVarTys, getTyVar_maybe,
  43                           splitAlgTyConApp_maybe, instantiateTy, Type
  44                         )
  45 import TyCon            ( isDataTyCon )
  46 import TyVar            ( mkTyVarSet, intersectTyVarSets, elementOfTyVarSet, tyVarSetToList,
  47                           delFromTyVarEnv
  48                         )
  49 import SrcLoc           ( noSrcLoc )
  50 import Util             ( isIn, zipWithEqual, panic, assertPanic )
  51
  52 \end{code}
  53
  54
  55 %************************************************************************
  56 %*                                                                      *
  57 \subsection{New ids}
  58 %*                                                                      *
  59 %************************************************************************
  60
  61 \begin{code}
  62 newId :: Type -> SmplM Id
  63 newId ty
  64   = getUniqueSmpl     `thenSmpl`  \ uniq ->
  65     returnSmpl (mkSysLocal SLIT("s") uniq ty noSrcLoc)
  66
  67 newIds :: [Type] -> SmplM [Id]
  68 newIds tys
  69   = getUniquesSmpl (length tys)    `thenSmpl`  \ uniqs ->
  70     returnSmpl (zipWithEqual "newIds" mk_id tys uniqs)
  71   where
  72     mk_id ty uniq = mkSysLocal SLIT("s") uniq ty noSrcLoc
  73 \end{code}
  74
  75
  76 %************************************************************************
  77 %*                                                                      *
  78 \subsection{Floating}
  79 %*                                                                      *
  80 %************************************************************************
  81
  82 The function @floatExposesHNF@ tells whether let/case floating will
  83 expose a head normal form.  It is passed booleans indicating the
  84 desired strategy.
  85
  86 \begin{code}
  87 floatExposesHNF
  88         :: Bool                 -- Float let(rec)s out of rhs
  89         -> Bool                 -- Float cheap primops out of rhs
  90         -> GenCoreExpr bdr Id flexi
  91         -> Bool
  92
  93 floatExposesHNF float_lets float_primops rhs
  94   = try rhs
  95   where
  96     try (Case (Prim _ _) (PrimAlts alts deflt) )
  97       | float_primops && null alts
  98       = or (try_deflt deflt : map try_alt alts)
  99
 100     try (Let bind body) | float_lets = try body
 101
 102     --    `build g'
 103     -- is like a HNF,
 104     -- because it *will* become one.
 105     -- likewise for `augment g h'
 106     --
 107     try (App (App (Var bld) _) _)         | bld == buildId   = True
 108     try (App (App (App (Var aug) _) _) _) | aug == augmentId = True
 109
 110     try other = case mkFormSummary other of
 111                         VarForm   -> True
 112                         ValueForm -> True
 113                         other     -> False
 114         {- but *not* necessarily "BottomForm"...
 115
 116            We may want to float a let out of a let to expose WHNFs,
 117             but to do that to expose a "bottom" is a Bad Idea:
 118             let x = let y = ...
 119                     in ...error ...y... --  manifestly bottom using y
 120             in ...
 121             =/=>
 122             let y = ...
 123             in let x = ...error ...y...
 124                in ...
 125
 126             as y is only used in case of an error, we do not want
 127             to allocate it eagerly as that's a waste.
 128         -}
 129
 130     try_alt (lit,rhs) = try rhs
 131
 132     try_deflt NoDefault           = False
 133     try_deflt (BindDefault _ rhs) = try rhs
 134 \end{code}
 135
 136
 137 Local tyvar-lifting
 138 ~~~~~~~~~~~~~~~~~~~
 139 mkRhsTyLam tries this transformation, when the big lambda appears as
 140 the RHS of a let(rec) binding:
 141
 142         /\abc -> let(rec) x = e in b
 143    ==>
 144         let(rec) x' = /\abc -> let x = x' a b c in e
 145         in
 146         /\abc -> let x = x' a b c in b
 147
 148 This is good because it can turn things like:
 149
 150         let f = /\a -> letrec g = ... g ... in g
 151 into
 152         letrec g' = /\a -> ... g' a ...
 153         in
 154         let f = /\ a -> f a
 155
 156 which is better.  In effect, it means that big lambdas don't impede
 157 let-floating.
 158
 159 This optimisation is CRUCIAL in eliminating the junk introduced by
 160 desugaring mutually recursive definitions.  Don't eliminate it lightly!
 161
 162 So far as the implemtation is concerned:
 163
 164         Invariant: go F e = /\tvs -> F e
 165
 166         Equalities:
 167                 go F (Let x=e in b)
 168                 = Let x' = /\tvs -> F e
 169                   in
 170                   go G b
 171                 where
 172                     G = F . Let x = x' tvs
 173
 174                 go F (Letrec xi=ei in b)
 175                 = Letrec {xi' = /\tvs -> G ei}
 176                   in
 177                   go G b
 178                 where
 179                   G = F . Let {xi = xi' tvs}
 180
 181 \begin{code}
 182 mkRhsTyLam [] body = returnSmpl body
 183
 184 mkRhsTyLam tyvars body
 185   = go (\x -> x) body
 186   where
 187     main_tyvar_set = mkTyVarSet tyvars
 188
 189     go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
 190       = go (fn . Let bind) body
 191
 192     go fn (Let bind@(NonRec var rhs) body)
 193       = mk_poly tyvars_here var_ty                      `thenSmpl` \ (var', rhs') ->
 194         go (fn . Let (mk_silly_bind var rhs')) body     `thenSmpl` \ body' ->
 195         returnSmpl (Let (NonRec var' (mkTyLam tyvars_here (fn rhs))) body')
 196       where
 197         tyvars_here = tyVarSetToList (main_tyvar_set `intersectTyVarSets` tyVarsOfType var_ty)
 198         var_ty = idType var
 199
 200     go fn (Let (Rec prs) body)
 201        = mapAndUnzipSmpl (mk_poly tyvars_here) var_tys  `thenSmpl` \ (vars', rhss') ->
 202          let
 203             gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss')
 204          in
 205          go gn body                             `thenSmpl` \ body' ->
 206          returnSmpl (Let (Rec (vars' `zip` [mkTyLam tyvars_here (gn rhs) | rhs <- rhss])) body')
 207        where
 208          (vars,rhss) = unzip prs
 209          tyvars_here = tyVarSetToList (main_tyvar_set `intersectTyVarSets` tyVarsOfTypes var_tys)
 210          var_tys     = map idType vars
 211
 212     go fn body = returnSmpl (mkTyLam tyvars (fn body))
 213
 214     mk_poly tyvars_here var_ty
 215       = newId (mkForAllTys tyvars_here var_ty)  `thenSmpl` \ poly_id ->
 216         returnSmpl (poly_id, mkTyApp (Var poly_id) (mkTyVarTys tyvars_here))
 217
 218     mk_silly_bind var rhs = NonRec (addInlinePragma var) rhs
 219                 -- The addInlinePragma is really important!  If we don't say
 220                 -- INLINE on these silly little bindings then look what happens!
 221                 -- Suppose we start with:
 222                 --
 223                 --      x = let g = /\a -> \x -> f x x
 224                 --          in
 225                 --          /\ b -> let g* = g b in E
 226                 --
 227                 -- Then:        * the binding for g gets floated out
 228                 --              * but then it gets inlined into the rhs of g*
 229                 --              * then the binding for g* is floated out of the /\b
 230                 --              * so we're back to square one
 231                 -- The silly binding for g* must be INLINE, so that no inlining
 232                 -- will happen in its RHS.
 233 \end{code}
 234
 235 Eta reduction
 236 ~~~~~~~~~~~~~
 237 @etaCoreExpr@ trys an eta reduction at the top level of a Core Expr.
 238
 239 e.g.    \ x y -> f x y  ===>  f
 240
 241 It is used
 242         a) Before constructing an Unfolding, to
 243            try to make the unfolding smaller;
 244         b) In tidyCoreExpr, which is done just before converting to STG.
 245
 246 But we only do this if it gets rid of a whole lambda, not part.
 247 The idea is that lambdas are often quite helpful: they indicate
 248 head normal forms, so we don't want to chuck them away lightly.
 249 But if they expose a simple variable then we definitely win.  Even
 250 if they expose a type application we win.  So we check for this special
 251 case.
 252
 253 It does arise:
 254
 255         f xs = [y | (y,_) <- xs]
 256
 257 gives rise to a recursive function for the list comprehension, and
 258 f turns out to be just a single call to this recursive function.
 259
 260 Doing eta on type lambdas is useful too:
 261
 262         /\a -> <expr> a    ===>     <expr>
 263
 264 where <expr> doesn't mention a.
 265 This is sometimes quite useful, because we can get the sequence:
 266
 267         f ab d = let d1 = ...d... in
 268                  letrec f' b x = ...d...(f' b)... in
 269                  f' b
 270 specialise ==>
 271
 272         f.Int b = letrec f' b x = ...dInt...(f' b)... in
 273                   f' b
 274
 275 float ==>
 276
 277         f' b x = ...dInt...(f' b)...
 278         f.Int b = f' b
 279
 280 Now we really want to simplify to
 281
 282         f.Int = f'
 283
 284 and then replace all the f's with f.Ints.
 285
 286 N.B. We are careful not to partially eta-reduce a sequence of type
 287 applications since this breaks the specialiser:
 288
 289         /\ a -> f Char# a       =NO=> f Char#
 290
 291 \begin{code}
 292 etaCoreExpr :: CoreExpr -> CoreExpr
 293
 294
 295 etaCoreExpr expr@(Lam bndr body)
 296   | opt_DoEtaReduction
 297   = case etaCoreExpr body of
 298         App fun arg | eta_match bndr arg &&
 299                       residual_ok fun
 300                     -> fun                      -- Eta
 301         other       -> expr                     -- Can't eliminate it, so do nothing at all
 302   where
 303     eta_match (ValBinder v) (VarArg v') = v == v'
 304     eta_match (TyBinder tv) (TyArg  ty) = case getTyVar_maybe ty of
 305                                                 Nothing  -> False
 306                                                 Just tv' -> tv == tv'
 307     eta_match bndr          arg         = False
 308
 309     residual_ok :: CoreExpr -> Bool     -- Checks for type application
 310                                         -- and function not one of the
 311                                         -- bound vars
 312
 313     (VarArg v) `mentions` (ValBinder v') = v == v'
 314     (TyArg ty) `mentions` (TyBinder tv)  = tv `elementOfTyVarSet` tyVarsOfType ty
 315     bndr       `mentions` arg            = False
 316
 317     residual_ok (Var v)
 318         = not (VarArg v `mentions` bndr)
 319     residual_ok (App fun arg)
 320         | arg `mentions` bndr = False
 321         | otherwise           = residual_ok fun
 322     residual_ok (Note (Coerce to_ty from_ty) body)
 323         |  TyArg to_ty   `mentions` bndr
 324         || TyArg from_ty `mentions` bndr = False
 325         | otherwise                      = residual_ok body
 326
 327     residual_ok other        = False            -- Safe answer
 328         -- This last clause may seem conservative, but consider:
 329         --      primops, constructors, and literals, are impossible here
 330         --      let and case are unlikely (the argument would have been floated inside)
 331         --      SCCs we probably want to be conservative about (not sure, but it's safe to be)
 332
 333 etaCoreExpr expr = expr         -- The common case
 334 \end{code}
 335
 336
 337 Eta expansion
 338 ~~~~~~~~~~~~~
 339 @etaExpandCount@ takes an expression, E, and returns an integer n,
 340 such that
 341
 342         E  ===>   (\x1::t1 x1::t2 ... xn::tn -> E x1 x2 ... xn)
 343
 344 is a safe transformation.  In particular, the transformation should
 345 not cause work to be duplicated, unless it is ``cheap'' (see
 346 @manifestlyCheap@ below).
 347
 348 @etaExpandCount@ errs on the conservative side.  It is always safe to
 349 return 0.
 350
 351 An application of @error@ is special, because it can absorb as many
 352 arguments as you care to give it.  For this special case we return
 353 100, to represent "infinity", which is a bit of a hack.
 354
 355 \begin{code}
 356 etaExpandCount :: GenCoreExpr bdr Id flexi
 357                -> Int   -- Number of extra args you can safely abstract
 358
 359 etaExpandCount (Lam (ValBinder _) body)
 360   = 1 + etaExpandCount body
 361
 362 etaExpandCount (Let bind body)
 363   | all manifestlyCheap (rhssOfBind bind)
 364   = etaExpandCount body
 365
 366 etaExpandCount (Case scrut alts)
 367   | manifestlyCheap scrut
 368   = minimum [etaExpandCount rhs | rhs <- rhssOfAlts alts]
 369
 370 etaExpandCount fun@(Var _)     = eta_fun fun
 371 etaExpandCount (App fun arg)
 372   | notValArg arg = eta_fun fun
 373   | otherwise     = case etaExpandCount fun of
 374                       0 -> 0
 375                       n -> n-1  -- Knock off one
 376
 377 etaExpandCount other = 0    -- Give up
 378         -- Lit, Con, Prim,
 379         -- non-val Lam,
 380         -- Scc (pessimistic; ToDo),
 381         -- Let with non-whnf rhs(s),
 382         -- Case with non-whnf scrutinee
 383
 384 -----------------------------
 385 eta_fun :: GenCoreExpr bdr Id flexi -- The function
 386         -> Int                      -- How many args it can safely be applied to
 387
 388 eta_fun (App fun arg) | notValArg arg = eta_fun fun
 389
 390 eta_fun expr@(Var v)
 391   | isBottomingId v             -- Bottoming ids have "infinite arity"
 392   = 10000                       -- Blargh.  Infinite enough!
 393
 394 eta_fun expr@(Var v) = idMinArity v
 395
 396 eta_fun other = 0               -- Give up
 397 \end{code}
 398
 399 @manifestlyCheap@ looks at a Core expression and returns \tr{True} if
 400 it is obviously in weak head normal form, or is cheap to get to WHNF.
 401 By ``cheap'' we mean a computation we're willing to duplicate in order
 402 to bring a couple of lambdas together.  The main examples of things
 403 which aren't WHNF but are ``cheap'' are:
 404
 405   *     case e of
 406           pi -> ei
 407
 408         where e, and all the ei are cheap; and
 409
 410   *     let x = e
 411         in b
 412
 413         where e and b are cheap; and
 414
 415   *     op x1 ... xn
 416
 417         where op is a cheap primitive operator
 418
 419 \begin{code}
 420 manifestlyCheap :: GenCoreExpr bndr Id flexi -> Bool
 421
 422 manifestlyCheap (Var _)      = True
 423 manifestlyCheap (Lit _)      = True
 424 manifestlyCheap (Con _ _)    = True
 425 manifestlyCheap (Note _ e)   = manifestlyCheap e
 426 manifestlyCheap (Lam x e)    = if isValBinder x then True else manifestlyCheap e
 427 manifestlyCheap (Prim op _)  = primOpIsCheap op
 428
 429 manifestlyCheap (Let bind body)
 430   = manifestlyCheap body && all manifestlyCheap (rhssOfBind bind)
 431
 432 manifestlyCheap (Case scrut alts)
 433   = manifestlyCheap scrut && all manifestlyCheap (rhssOfAlts alts)
 434
 435 manifestlyCheap other_expr   -- look for manifest partial application
 436   = case (collectArgs other_expr) of { (fun, _, vargs) ->
 437     case fun of
 438
 439       Var f | isBottomingId f -> True   -- Application of a function which
 440                                         -- always gives bottom; we treat this as
 441                                         -- a WHNF, because it certainly doesn't
 442                                         -- need to be shared!
 443
 444       Var f -> let
 445                     num_val_args = length vargs
 446                in
 447                num_val_args == 0 ||     -- Just a type application of
 448                                         -- a variable (f t1 t2 t3)
 449                                         -- counts as WHNF
 450                num_val_args < idMinArity f
 451
 452       _ -> False
 453     }
 454
 455 \end{code}
 456
 457
 458 \begin{code}
 459 simplIdWantsToBeINLINEd :: Id -> SimplEnv -> Bool
 460
 461 simplIdWantsToBeINLINEd id env
 462   = {-  We used to arrange that in the final simplification pass we'd switch
 463         off all INLINE pragmas, so that we'd inline workers back into the
 464         body of their wrapper if the wrapper hadn't itself been inlined by then.
 465         This occurred especially for methods in dictionaries.
 466
 467         We no longer do this:
 468                 a) there's a good chance that the exported wrapper will get
 469                 inlined in some importing scope, in which case we don't
 470                 want to lose the w/w idea.
 471
 472                 b) The occurrence analyser must agree about what has an
 473                 INLINE pragma.  Not hard, but delicate.
 474
 475                 c) if the worker gets inlined we have to tell the wrapepr
 476                 that it's no longer a wrapper, else the interface file stuff
 477                 asks for a worker that no longer exists.
 478
 479     if switchIsSet env IgnoreINLINEPragma
 480     then False
 481     else
 482     -}
 483
 484     idWantsToBeINLINEd id
 485
 486 idMinArity id = case getIdArity id of
 487                         UnknownArity   -> 0
 488                         ArityAtLeast n -> n
 489                         ArityExactly n -> n
 490
 491 singleConstructorType :: Type -> Bool
 492 singleConstructorType ty
 493   = case (splitAlgTyConApp_maybe ty) of
 494       Just (tycon, ty_args, [con]) | isDataTyCon tycon -> True
 495       other                                            -> False
 496
 497 typeOkForCase :: Type -> Bool
 498 typeOkForCase ty
 499   = case (splitAlgTyConApp_maybe ty) of
 500       Just (tycon, ty_args, [])                                     -> False
 501       Just (tycon, ty_args, non_null_data_cons) | isDataTyCon tycon -> True
 502       other                                                         -> False
 503       -- Null data cons => type is abstract, which code gen can't
 504       -- currently handle.  (ToDo: when return-in-heap is universal we
 505       -- don't need to worry about this.)
 506 \end{code}
 507
 508
 509
 510 substSpecEnvRhs applies a substitution to the RHS's of a SpecEnv
 511 It exploits the known structure of a SpecEnv's RHS to have fewer
 512 equations.
 513
 514 \begin{code}
 515 substSpecEnvRhs te ve rhs
 516   = go te ve rhs
 517   where
 518     go te ve (App f (TyArg ty)) = App (go te ve f) (TyArg (instantiateTy te ty))
 519     go te ve (App f (VarArg v)) = App (go te ve f) (case lookupIdEnv ve v of
 520                                                         Just (SubstVar v') -> VarArg v'
 521                                                         Just (SubstLit l)  -> LitArg l
 522                                                         Nothing            -> VarArg v)
 523     go te ve (Var v)              = case lookupIdEnv ve v of
 524                                                 Just (SubstVar v') -> Var v'
 525                                                 Just (SubstLit l)  -> Lit l
 526                                                 Nothing            -> Var v
 527
 528         -- These equations are a bit half baked, because
 529         -- they don't deal properly wih capture.
 530         -- But I'm sure it'll never matter... sigh.
 531     go te ve (Lam b@(TyBinder tyvar) e) = Lam b (go te' ve e)
 532                                         where
 533                                           te' = delFromTyVarEnv te tyvar
 534
 535     go te ve (Lam b@(ValBinder v) e) = Lam b (go te ve' e)
 536                                      where
 537                                        ve' = delOneFromIdEnv ve v
 538 \end{code}