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