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