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