ghc/compiler/simplCore/SimplUtils.lhs

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