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