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,
  14
  15         etaExpandCount,
  16
  17         mkIdentityAlts,
  18
  19         simplIdWantsToBeINLINEd,
  20
  21         type_ok_for_let_to_case
  22     ) where
  23
  24 IMP_Ubiq(){-uitous-}
  25 IMPORT_DELOOPER(SmplLoop)               -- paranoia checking
  26
  27 import BinderInfo
  28 import CmdLineOpts      ( opt_DoEtaReduction, SimplifierSwitch(..) )
  29 import CoreSyn
  30 import CoreUnfold       ( SimpleUnfolding, mkFormSummary, FormSummary(..) )
  31 import Id               ( idType, isBottomingId, idWantsToBeINLINEd, dataConArgTys,
  32                           getIdArity, GenId{-instance Eq-}
  33                         )
  34 import IdInfo           ( ArityInfo(..) )
  35 import Maybes           ( maybeToBool )
  36 import PrelVals         ( augmentId, buildId )
  37 import PrimOp           ( primOpIsCheap )
  38 import SimplEnv
  39 import SimplMonad
  40 import Type             ( tyVarsOfType, isPrimType, maybeAppDataTyConExpandingDicts )
  41 import TysWiredIn       ( realWorldStateTy )
  42 import TyVar            ( elementOfTyVarSet,
  43                           GenTyVar{-instance Eq-} )
  44 import Util             ( isIn, panic )
  45
  46 \end{code}
  47
  48
  49 Floating
  50 ~~~~~~~~
  51 The function @floatExposesHNF@ tells whether let/case floating will
  52 expose a head normal form.  It is passed booleans indicating the
  53 desired strategy.
  54
  55 \begin{code}
  56 floatExposesHNF
  57         :: Bool                 -- Float let(rec)s out of rhs
  58         -> Bool                 -- Float cheap primops out of rhs
  59         -> Bool                 -- OK to duplicate code
  60         -> GenCoreExpr bdr Id tyvar uvar
  61         -> Bool
  62
  63 floatExposesHNF float_lets float_primops ok_to_dup rhs
  64   = try rhs
  65   where
  66     try (Case (Prim _ _) (PrimAlts alts deflt) )
  67       | float_primops && (null alts || ok_to_dup)
  68       = or (try_deflt deflt : map try_alt alts)
  69
  70     try (Let bind body) | float_lets = try body
  71
  72     --    `build g'
  73     -- is like a HNF,
  74     -- because it *will* become one.
  75     -- likewise for `augment g h'
  76     --
  77     try (App (App (Var bld) _) _)         | bld == buildId   = True
  78     try (App (App (App (Var aug) _) _) _) | aug == augmentId = True
  79
  80     try other = case mkFormSummary other of
  81                         VarForm   -> True
  82                         ValueForm -> True
  83                         other     -> False
  84         {- but *not* necessarily "BottomForm"...
  85
  86            We may want to float a let out of a let to expose WHNFs,
  87             but to do that to expose a "bottom" is a Bad Idea:
  88             let x = let y = ...
  89                     in ...error ...y... --  manifestly bottom using y
  90             in ...
  91             =/=>
  92             let y = ...
  93             in let x = ...error ...y...
  94                in ...
  95
  96             as y is only used in case of an error, we do not want
  97             to allocate it eagerly as that's a waste.
  98         -}
  99
 100     try_alt (lit,rhs) = try rhs
 101
 102     try_deflt NoDefault           = False
 103     try_deflt (BindDefault _ rhs) = try rhs
 104 \end{code}
 105
 106 Eta reduction
 107 ~~~~~~~~~~~~~
 108 @etaCoreExpr@ trys an eta reduction at the top level of a Core Expr.
 109
 110 e.g.    \ x y -> f x y  ===>  f
 111
 112 It is used
 113         a) Before constructing an Unfolding, to
 114            try to make the unfolding smaller;
 115         b) In tidyCoreExpr, which is done just before converting to STG.
 116
 117 But we only do this if it gets rid of a whole lambda, not part.
 118 The idea is that lambdas are often quite helpful: they indicate
 119 head normal forms, so we don't want to chuck them away lightly.
 120 But if they expose a simple variable then we definitely win.  Even
 121 if they expose a type application we win.  So we check for this special
 122 case.
 123
 124 It does arise:
 125
 126         f xs = [y | (y,_) <- xs]
 127
 128 gives rise to a recursive function for the list comprehension, and
 129 f turns out to be just a single call to this recursive function.
 130
 131 Doing eta on type lambdas is useful too:
 132
 133         /\a -> <expr> a    ===>     <expr>
 134
 135 where <expr> doesn't mention a.
 136 This is sometimes quite useful, because we can get the sequence:
 137
 138         f ab d = let d1 = ...d... in
 139                  letrec f' b x = ...d...(f' b)... in
 140                  f' b
 141 specialise ==>
 142
 143         f.Int b = letrec f' b x = ...dInt...(f' b)... in
 144                   f' b
 145
 146 float ==>
 147
 148         f' b x = ...dInt...(f' b)...
 149         f.Int b = f' b
 150
 151 Now we really want to simplify to
 152
 153         f.Int = f'
 154
 155 and then replace all the f's with f.Ints.
 156
 157 N.B. We are careful not to partially eta-reduce a sequence of type
 158 applications since this breaks the specialiser:
 159
 160         /\ a -> f Char# a       =NO=> f Char#
 161
 162 \begin{code}
 163 etaCoreExpr :: CoreExpr -> CoreExpr
 164
 165
 166 etaCoreExpr expr@(Lam bndr body)
 167   | opt_DoEtaReduction
 168   = case etaCoreExpr body of
 169         App fun arg | eta_match bndr arg &&
 170                       residual_ok fun
 171                     -> fun                      -- Eta
 172         other       -> expr                     -- Can't eliminate it, so do nothing at all
 173   where
 174     eta_match (ValBinder v) (VarArg v') = v == v'
 175     eta_match (TyBinder tv) (TyArg  ty) = tv `elementOfTyVarSet` tyVarsOfType ty
 176     eta_match bndr          arg         = False
 177
 178     residual_ok :: CoreExpr -> Bool     -- Checks for type application
 179                                         -- and function not one of the
 180                                         -- bound vars
 181
 182     residual_ok (Var v)
 183         = not (eta_match bndr (VarArg v))
 184     residual_ok (App fun arg)
 185         | eta_match bndr arg = False
 186         | otherwise          = residual_ok fun
 187     residual_ok (Coerce coercion ty body)
 188         | eta_match bndr (TyArg ty) = False
 189         | otherwise                 = residual_ok body
 190
 191     residual_ok other        = False            -- Safe answer
 192         -- This last clause may seem conservative, but consider:
 193         --      primops, constructors, and literals, are impossible here
 194         --      let and case are unlikely (the argument would have been floated inside)
 195         --      SCCs we probably want to be conservative about (not sure, but it's safe to be)
 196
 197 etaCoreExpr expr = expr         -- The common case
 198 \end{code}
 199
 200
 201 Eta expansion
 202 ~~~~~~~~~~~~~
 203 @etaExpandCount@ takes an expression, E, and returns an integer n,
 204 such that
 205
 206         E  ===>   (\x1::t1 x1::t2 ... xn::tn -> E x1 x2 ... xn)
 207
 208 is a safe transformation.  In particular, the transformation should
 209 not cause work to be duplicated, unless it is ``cheap'' (see
 210 @manifestlyCheap@ below).
 211
 212 @etaExpandCount@ errs on the conservative side.  It is always safe to
 213 return 0.
 214
 215 An application of @error@ is special, because it can absorb as many
 216 arguments as you care to give it.  For this special case we return
 217 100, to represent "infinity", which is a bit of a hack.
 218
 219 \begin{code}
 220 etaExpandCount :: GenCoreExpr bdr Id tyvar uvar
 221                -> Int   -- Number of extra args you can safely abstract
 222
 223 etaExpandCount (Lam (ValBinder _) body)
 224   = 1 + etaExpandCount body
 225
 226 etaExpandCount (Let bind body)
 227   | all manifestlyCheap (rhssOfBind bind)
 228   = etaExpandCount body
 229
 230 etaExpandCount (Case scrut alts)
 231   | manifestlyCheap scrut
 232   = minimum [etaExpandCount rhs | rhs <- rhssOfAlts alts]
 233
 234 etaExpandCount fun@(Var _)     = eta_fun fun
 235 etaExpandCount (App fun arg)
 236   | notValArg arg = eta_fun fun
 237   | otherwise     = case etaExpandCount fun of
 238                       0 -> 0
 239                       n -> n-1  -- Knock off one
 240
 241 etaExpandCount other = 0    -- Give up
 242         -- Lit, Con, Prim,
 243         -- non-val Lam,
 244         -- Scc (pessimistic; ToDo),
 245         -- Let with non-whnf rhs(s),
 246         -- Case with non-whnf scrutinee
 247
 248 -----------------------------
 249 eta_fun :: GenCoreExpr bdr Id tv uv -- The function
 250         -> Int                      -- How many args it can safely be applied to
 251
 252 eta_fun (App fun arg) | notValArg arg = eta_fun fun
 253
 254 eta_fun expr@(Var v)
 255   | isBottomingId v             -- Bottoming ids have "infinite arity"
 256   = 10000                       -- Blargh.  Infinite enough!
 257
 258 eta_fun expr@(Var v) = idMinArity v
 259
 260 eta_fun other = 0               -- Give up
 261 \end{code}
 262
 263 @manifestlyCheap@ looks at a Core expression and returns \tr{True} if
 264 it is obviously in weak head normal form, or is cheap to get to WHNF.
 265 By ``cheap'' we mean a computation we're willing to duplicate in order
 266 to bring a couple of lambdas together.  The main examples of things
 267 which aren't WHNF but are ``cheap'' are:
 268
 269   *     case e of
 270           pi -> ei
 271
 272         where e, and all the ei are cheap; and
 273
 274   *     let x = e
 275         in b
 276
 277         where e and b are cheap; and
 278
 279   *     op x1 ... xn
 280
 281         where op is a cheap primitive operator
 282
 283 \begin{code}
 284 manifestlyCheap :: GenCoreExpr bndr Id tv uv -> Bool
 285
 286 manifestlyCheap (Var _)        = True
 287 manifestlyCheap (Lit _)        = True
 288 manifestlyCheap (Con _ _)      = True
 289 manifestlyCheap (SCC _ e)      = manifestlyCheap e
 290 manifestlyCheap (Coerce _ _ e) = manifestlyCheap e
 291 manifestlyCheap (Lam x e)      = if isValBinder x then True else manifestlyCheap e
 292 manifestlyCheap (Prim op _)    = primOpIsCheap op
 293
 294 manifestlyCheap (Let bind body)
 295   = manifestlyCheap body && all manifestlyCheap (rhssOfBind bind)
 296
 297 manifestlyCheap (Case scrut alts)
 298   = manifestlyCheap scrut && all manifestlyCheap (rhssOfAlts alts)
 299
 300 manifestlyCheap other_expr   -- look for manifest partial application
 301   = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
 302     case fun of
 303
 304       Var f | isBottomingId f -> True   -- Application of a function which
 305                                         -- always gives bottom; we treat this as
 306                                         -- a WHNF, because it certainly doesn't
 307                                         -- need to be shared!
 308
 309       Var f -> let
 310                     num_val_args = length vargs
 311                in
 312                num_val_args == 0 ||     -- Just a type application of
 313                                         -- a variable (f t1 t2 t3)
 314                                         -- counts as WHNF
 315                num_val_args < idMinArity f
 316
 317       _ -> False
 318     }
 319
 320 \end{code}
 321
 322
 323 Let to case
 324 ~~~~~~~~~~~
 325
 326 Given a type generate the case alternatives
 327
 328         C a b -> C a b
 329
 330 if there's one constructor, or
 331
 332         x -> x
 333
 334 if there's many, or if it's a primitive type.
 335
 336
 337 \begin{code}
 338 mkIdentityAlts
 339         :: Type         -- type of RHS
 340         -> SmplM InAlts         -- result
 341
 342 mkIdentityAlts rhs_ty
 343   | isPrimType rhs_ty
 344   = newId rhs_ty        `thenSmpl` \ binder ->
 345     returnSmpl (PrimAlts [] (BindDefault (binder, bad_occ_info) (Var binder)))
 346
 347   | otherwise
 348   = case (maybeAppDataTyConExpandingDicts rhs_ty) of
 349         Just (tycon, ty_args, [data_con]) ->  -- algebraic type suitable for unpacking
 350             let
 351                 inst_con_arg_tys = dataConArgTys data_con ty_args
 352             in
 353             newIds inst_con_arg_tys     `thenSmpl` \ new_bindees ->
 354             let
 355                 new_binders = [ (b, bad_occ_info) | b <- new_bindees ]
 356             in
 357             returnSmpl (
 358               AlgAlts
 359                 [(data_con, new_binders, mkCon data_con [] ty_args (map VarArg new_bindees))]
 360                 NoDefault
 361             )
 362
 363         _ -> -- Multi-constructor or abstract algebraic type
 364              newId rhs_ty       `thenSmpl` \ binder ->
 365              returnSmpl (AlgAlts [] (BindDefault (binder,bad_occ_info) (Var binder)))
 366   where
 367     bad_occ_info = ManyOcc 0    -- Non-committal!
 368 \end{code}
 369
 370 \begin{code}
 371 simplIdWantsToBeINLINEd :: Id -> SimplEnv -> Bool
 372
 373 simplIdWantsToBeINLINEd id env
 374   = if switchIsSet env IgnoreINLINEPragma
 375     then False
 376     else idWantsToBeINLINEd id
 377
 378 idMinArity id = case getIdArity id of
 379                         UnknownArity   -> 0
 380                         ArityAtLeast n -> n
 381                         ArityExactly n -> n
 382
 383 type_ok_for_let_to_case :: Type -> Bool
 384
 385 type_ok_for_let_to_case ty
 386   = case (maybeAppDataTyConExpandingDicts ty) of
 387       Nothing                                   -> False
 388       Just (tycon, ty_args, [])                 -> False
 389       Just (tycon, ty_args, non_null_data_cons) -> True
 390       -- Null data cons => type is abstract
 391 \end{code}