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