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