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 Id               ( idType, isBottomingId, mkSysLocal,
  29                           addInlinePragma, addIdDemandInfo,
  30                           idWantsToBeINLINEd, dataConArgTys, Id,
  31                           getIdArity,
  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         -> Bool                 -- OK to duplicate code
  86         -> GenCoreExpr bdr Id flexi
  87         -> Bool
  88
  89 floatExposesHNF float_lets float_primops ok_to_dup rhs
  90   = try rhs
  91   where
  92     try (Case (Prim _ _) (PrimAlts alts deflt) )
  93       | float_primops && (null alts || ok_to_dup)
  94       = or (try_deflt deflt : map try_alt alts)
  95
  96     try (Let bind body) | float_lets = try body
  97
  98     --    `build g'
  99     -- is like a HNF,
 100     -- because it *will* become one.
 101     -- likewise for `augment g h'
 102     --
 103     try (App (App (Var bld) _) _)         | bld == buildId   = True
 104     try (App (App (App (Var aug) _) _) _) | aug == augmentId = True
 105
 106     try other = case mkFormSummary other of
 107                         VarForm   -> True
 108                         ValueForm -> True
 109                         other     -> False
 110         {- but *not* necessarily "BottomForm"...
 111
 112            We may want to float a let out of a let to expose WHNFs,
 113             but to do that to expose a "bottom" is a Bad Idea:
 114             let x = let y = ...
 115                     in ...error ...y... --  manifestly bottom using y
 116             in ...
 117             =/=>
 118             let y = ...
 119             in let x = ...error ...y...
 120                in ...
 121
 122             as y is only used in case of an error, we do not want
 123             to allocate it eagerly as that's a waste.
 124         -}
 125
 126     try_alt (lit,rhs) = try rhs
 127
 128     try_deflt NoDefault           = False
 129     try_deflt (BindDefault _ rhs) = try rhs
 130 \end{code}
 131
 132
 133 Local tyvar-lifting
 134 ~~~~~~~~~~~~~~~~~~~
 135 mkRhsTyLam tries this transformation, when the big lambda appears as
 136 the RHS of a let(rec) binding:
 137
 138         /\abc -> let(rec) x = e in b
 139    ==>
 140         let(rec) x' = /\abc -> let x = x' a b c in e
 141         in
 142         /\abc -> let x = x' a b c in b
 143
 144 This is good because it can turn things like:
 145
 146         let f = /\a -> letrec g = ... g ... in g
 147 into
 148         letrec g' = /\a -> ... g' a ...
 149         in
 150         let f = /\ a -> f a
 151
 152 which is better.  In effect, it means that big lambdas don't impede
 153 let-floating.
 154
 155 This optimisation is CRUCIAL in eliminating the junk introduced by
 156 desugaring mutually recursive definitions.  Don't eliminate it lightly!
 157
 158 So far as the implemtation is concerned:
 159
 160         Invariant: go F e = /\tvs -> F e
 161
 162         Equalities:
 163                 go F (Let x=e in b)
 164                 = Let x' = /\tvs -> F e
 165                   in
 166                   go G b
 167                 where
 168                     G = F . Let x = x' tvs
 169
 170                 go F (Letrec xi=ei in b)
 171                 = Letrec {xi' = /\tvs -> G ei}
 172                   in
 173                   go G b
 174                 where
 175                   G = F . Let {xi = xi' tvs}
 176
 177 \begin{code}
 178 mkRhsTyLam [] body = returnSmpl body
 179
 180 mkRhsTyLam tyvars body
 181   = go (\x -> x) body
 182   where
 183     tyvar_tys = mkTyVarTys tyvars
 184
 185     go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
 186       = go (fn . Let bind) body
 187
 188     go fn (Let bind@(NonRec var rhs) body)
 189       = mk_poly var                             `thenSmpl` \ (var', rhs') ->
 190         go (fn . Let (mk_silly_bind var rhs')) body     `thenSmpl` \ body' ->
 191         returnSmpl (Let (NonRec var' (mkTyLam tyvars (fn rhs))) body')
 192
 193     go fn (Let (Rec prs) body)
 194        = mapAndUnzipSmpl mk_poly vars           `thenSmpl` \ (vars', rhss') ->
 195          let
 196             gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss')
 197          in
 198          go gn body                             `thenSmpl` \ body' ->
 199          returnSmpl (Let (Rec (vars' `zip` [mkTyLam tyvars (gn rhs) | rhs <- rhss])) body')
 200        where
 201          (vars,rhss) = unzip prs
 202
 203     go fn body = returnSmpl (mkTyLam tyvars (fn body))
 204
 205     mk_poly var
 206       = newId (mkForAllTys tyvars (idType var)) `thenSmpl` \ poly_id ->
 207         returnSmpl (poly_id, mkTyApp (Var poly_id) tyvar_tys)
 208
 209     mk_silly_bind var rhs = NonRec (addInlinePragma var) rhs
 210                 -- The addInlinePragma is really important!  If we don't say
 211                 -- INLINE on these silly little bindings then look what happens!
 212                 -- Suppose we start with:
 213                 --
 214                 --      x = let g = /\a -> \x -> f x x
 215                 --          in
 216                 --          /\ b -> let g* = g b in E
 217                 --
 218                 -- Then:        * the binding for g gets floated out
 219                 --              * but then it gets inlined into the rhs of g*
 220                 --              * then the binding for g* is floated out of the /\b
 221                 --              * so we're back to square one
 222                 -- The silly binding for g* must be INLINE, so that no inlining
 223                 -- will happen in its RHS.
 224 \end{code}
 225
 226 Eta reduction
 227 ~~~~~~~~~~~~~
 228 @etaCoreExpr@ trys an eta reduction at the top level of a Core Expr.
 229
 230 e.g.    \ x y -> f x y  ===>  f
 231
 232 It is used
 233         a) Before constructing an Unfolding, to
 234            try to make the unfolding smaller;
 235         b) In tidyCoreExpr, which is done just before converting to STG.
 236
 237 But we only do this if it gets rid of a whole lambda, not part.
 238 The idea is that lambdas are often quite helpful: they indicate
 239 head normal forms, so we don't want to chuck them away lightly.
 240 But if they expose a simple variable then we definitely win.  Even
 241 if they expose a type application we win.  So we check for this special
 242 case.
 243
 244 It does arise:
 245
 246         f xs = [y | (y,_) <- xs]
 247
 248 gives rise to a recursive function for the list comprehension, and
 249 f turns out to be just a single call to this recursive function.
 250
 251 Doing eta on type lambdas is useful too:
 252
 253         /\a -> <expr> a    ===>     <expr>
 254
 255 where <expr> doesn't mention a.
 256 This is sometimes quite useful, because we can get the sequence:
 257
 258         f ab d = let d1 = ...d... in
 259                  letrec f' b x = ...d...(f' b)... in
 260                  f' b
 261 specialise ==>
 262
 263         f.Int b = letrec f' b x = ...dInt...(f' b)... in
 264                   f' b
 265
 266 float ==>
 267
 268         f' b x = ...dInt...(f' b)...
 269         f.Int b = f' b
 270
 271 Now we really want to simplify to
 272
 273         f.Int = f'
 274
 275 and then replace all the f's with f.Ints.
 276
 277 N.B. We are careful not to partially eta-reduce a sequence of type
 278 applications since this breaks the specialiser:
 279
 280         /\ a -> f Char# a       =NO=> f Char#
 281
 282 \begin{code}
 283 etaCoreExpr :: CoreExpr -> CoreExpr
 284
 285
 286 etaCoreExpr expr@(Lam bndr body)
 287   | opt_DoEtaReduction
 288   = case etaCoreExpr body of
 289         App fun arg | eta_match bndr arg &&
 290                       residual_ok fun
 291                     -> fun                      -- Eta
 292         other       -> expr                     -- Can't eliminate it, so do nothing at all
 293   where
 294     eta_match (ValBinder v) (VarArg v') = v == v'
 295     eta_match (TyBinder tv) (TyArg  ty) = case getTyVar_maybe ty of
 296                                                 Nothing  -> False
 297                                                 Just tv' -> tv == tv'
 298     eta_match bndr          arg         = False
 299
 300     residual_ok :: CoreExpr -> Bool     -- Checks for type application
 301                                         -- and function not one of the
 302                                         -- bound vars
 303
 304     (VarArg v) `mentions` (ValBinder v') = v == v'
 305     (TyArg ty) `mentions` (TyBinder tv)  = tv `elementOfTyVarSet` tyVarsOfType ty
 306     bndr       `mentions` arg            = False
 307
 308     residual_ok (Var v)
 309         = not (VarArg v `mentions` bndr)
 310     residual_ok (App fun arg)
 311         | arg `mentions` bndr = False
 312         | otherwise           = residual_ok fun
 313     residual_ok (Coerce coercion ty body)
 314         | TyArg 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 (SCC _ e)      = manifestlyCheap e
 416 manifestlyCheap (Coerce _ _ e) = manifestlyCheap e
 417 manifestlyCheap (Lam x e)      = if isValBinder x then True else manifestlyCheap e
 418 manifestlyCheap (Prim op _)    = primOpIsCheap op
 419
 420 manifestlyCheap (Let bind body)
 421   = manifestlyCheap body && all manifestlyCheap (rhssOfBind bind)
 422
 423 manifestlyCheap (Case scrut alts)
 424   = manifestlyCheap scrut && all manifestlyCheap (rhssOfAlts alts)
 425
 426 manifestlyCheap other_expr   -- look for manifest partial application
 427   = case (collectArgs other_expr) of { (fun, _, vargs) ->
 428     case fun of
 429
 430       Var f | isBottomingId f -> True   -- Application of a function which
 431                                         -- always gives bottom; we treat this as
 432                                         -- a WHNF, because it certainly doesn't
 433                                         -- need to be shared!
 434
 435       Var f -> let
 436                     num_val_args = length vargs
 437                in
 438                num_val_args == 0 ||     -- Just a type application of
 439                                         -- a variable (f t1 t2 t3)
 440                                         -- counts as WHNF
 441                num_val_args < idMinArity f
 442
 443       _ -> False
 444     }
 445
 446 \end{code}
 447
 448
 449 \begin{code}
 450 simplIdWantsToBeINLINEd :: Id -> SimplEnv -> Bool
 451
 452 simplIdWantsToBeINLINEd id env
 453   = {-  We used to arrange that in the final simplification pass we'd switch
 454         off all INLINE pragmas, so that we'd inline workers back into the
 455         body of their wrapper if the wrapper hadn't itself been inlined by then.
 456         This occurred especially for methods in dictionaries.
 457
 458         We no longer do this:
 459                 a) there's a good chance that the exported wrapper will get
 460                 inlined in some importing scope, in which case we don't
 461                 want to lose the w/w idea.
 462
 463                 b) The occurrence analyser must agree about what has an
 464                 INLINE pragma.  Not hard, but delicate.
 465
 466                 c) if the worker gets inlined we have to tell the wrapepr
 467                 that it's no longer a wrapper, else the interface file stuff
 468                 asks for a worker that no longer exists.
 469
 470     if switchIsSet env IgnoreINLINEPragma
 471     then False
 472     else
 473     -}
 474
 475     idWantsToBeINLINEd id
 476
 477 idMinArity id = case getIdArity id of
 478                         UnknownArity   -> 0
 479                         ArityAtLeast n -> n
 480                         ArityExactly n -> n
 481
 482 singleConstructorType :: Type -> Bool
 483 singleConstructorType ty
 484   = case (splitAlgTyConApp_maybe ty) of
 485       Just (tycon, ty_args, [con]) | isDataTyCon tycon -> True
 486       other                                            -> False
 487
 488 typeOkForCase :: Type -> Bool
 489 typeOkForCase ty
 490   = case (splitAlgTyConApp_maybe ty) of
 491       Just (tycon, ty_args, [])                                     -> False
 492       Just (tycon, ty_args, non_null_data_cons) | isDataTyCon tycon -> True
 493       other                                                         -> False
 494       -- Null data cons => type is abstract, which code gen can't
 495       -- currently handle.  (ToDo: when return-in-heap is universal we
 496       -- don't need to worry about this.)
 497 \end{code}