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