ghc/compiler/simplCore/SimplUtils.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[SimplUtils]{The simplifier utilities}
   5
   6 \begin{code}
   7 module SimplUtils (
   8         simplBinder, simplBinders, simplIds,
   9         mkRhsTyLam,
  10         etaCoreExpr,
  11         etaExpandCount,
  12         mkCase, findAlt, findDefault
  13     ) where
  14
  15 #include "HsVersions.h"
  16
  17 import BinderInfo
  18 import CmdLineOpts      ( opt_DoEtaReduction, switchIsOn, SimplifierSwitch(..) )
  19 import CoreSyn
  20 import CoreUtils        ( exprIsCheap, exprIsTrivial, exprFreeVars, cheapEqExpr,
  21                           FormSummary(..),
  22                           substId, substIds
  23                         )
  24 import Id               ( Id, idType, getIdArity, isId, idName,
  25                           getInlinePragma, setInlinePragma,
  26                           getIdDemandInfo
  27                         )
  28 import IdInfo           ( arityLowerBound, InlinePragInfo(..) )
  29 import Maybes           ( maybeToBool )
  30 import Const            ( Con(..) )
  31 import Name             ( isLocalName )
  32 import SimplMonad
  33 import Type             ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, mkTyVarTys,
  34                           splitTyConApp_maybe, mkTyVarTy, substTyVar
  35                         )
  36 import Var              ( setVarUnique )
  37 import VarSet
  38 import UniqSupply       ( splitUniqSupply, uniqFromSupply )
  39 import Util             ( zipWithEqual, mapAccumL )
  40 import Outputable
  41 \end{code}
  42
  43
  44 %************************************************************************
  45 %*                                                                      *
  46 \section{Dealing with a single binder}
  47 %*                                                                      *
  48 %************************************************************************
  49
  50 When we hit a binder we may need to
  51   (a) apply the the type envt (if non-empty) to its type
  52   (b) apply the type envt and id envt to its SpecEnv (if it has one)
  53   (c) give it a new unique to avoid name clashes
  54
  55 \begin{code}
  56 simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
  57 simplBinders bndrs thing_inside
  58   = getSwitchChecker    `thenSmpl` \ sw_chkr ->
  59     getSimplBinderStuff `thenSmpl` \ stuff ->
  60     let
  61         must_clone       = switchIsOn sw_chkr SimplPleaseClone
  62         (stuff', bndrs') = mapAccumL (subst_binder must_clone) stuff bndrs
  63     in
  64     setSimplBinderStuff stuff'  $
  65     thing_inside bndrs'
  66
  67 simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
  68 simplBinder bndr thing_inside
  69   = getSwitchChecker    `thenSmpl` \ sw_chkr ->
  70     getSimplBinderStuff `thenSmpl` \ stuff ->
  71     let
  72         must_clone      = switchIsOn sw_chkr SimplPleaseClone
  73         (stuff', bndr') = subst_binder must_clone stuff bndr
  74     in
  75     setSimplBinderStuff stuff'  $
  76     thing_inside bndr'
  77
  78 -- Same semantics as simplBinders, but a little less
  79 -- plumbing and hence a little more efficient.
  80 -- Maybe not worth the candle?
  81 simplIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
  82 simplIds ids thing_inside
  83   = getSwitchChecker    `thenSmpl` \ sw_chkr ->
  84     getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) ->
  85     let
  86         must_clone                        = switchIsOn sw_chkr SimplPleaseClone
  87         (id_subst', in_scope', us', ids') = substIds (simpl_clone_fn must_clone)
  88                                                      ty_subst id_subst in_scope us ids
  89     in
  90     setSimplBinderStuff (ty_subst, id_subst', in_scope', us')   $
  91     thing_inside ids'
  92
  93 subst_binder must_clone (ty_subst, id_subst, in_scope, us) bndr
  94   | isTyVar bndr
  95   = case substTyVar ty_subst in_scope bndr of
  96         (ty_subst', in_scope', bndr') -> ((ty_subst', id_subst, in_scope', us), bndr')
  97
  98   | otherwise
  99   = case substId (simpl_clone_fn must_clone) ty_subst id_subst in_scope us bndr of
 100         (id_subst', in_scope', us', bndr')
 101                 -> ((ty_subst, id_subst', in_scope', us'), bndr')
 102
 103 simpl_clone_fn must_clone in_scope us id
 104   |  (must_clone && isLocalName (idName id))
 105   || id `elemVarSet` in_scope
 106   = case splitUniqSupply us of
 107         (us1, us2) -> Just (us1, setVarUnique id (uniqFromSupply us2))
 108
 109   |  otherwise
 110   =  Nothing
 111 \end{code}
 112
 113
 114 %************************************************************************
 115 %*                                                                      *
 116 \subsection{Local tyvar-lifting}
 117 %*                                                                      *
 118 %************************************************************************
 119
 120 mkRhsTyLam tries this transformation, when the big lambda appears as
 121 the RHS of a let(rec) binding:
 122
 123         /\abc -> let(rec) x = e in b
 124    ==>
 125         let(rec) x' = /\abc -> let x = x' a b c in e
 126         in
 127         /\abc -> let x = x' a b c in b
 128
 129 This is good because it can turn things like:
 130
 131         let f = /\a -> letrec g = ... g ... in g
 132 into
 133         letrec g' = /\a -> ... g' a ...
 134         in
 135         let f = /\ a -> g' a
 136
 137 which is better.  In effect, it means that big lambdas don't impede
 138 let-floating.
 139
 140 This optimisation is CRUCIAL in eliminating the junk introduced by
 141 desugaring mutually recursive definitions.  Don't eliminate it lightly!
 142
 143 So far as the implemtation is concerned:
 144
 145         Invariant: go F e = /\tvs -> F e
 146
 147         Equalities:
 148                 go F (Let x=e in b)
 149                 = Let x' = /\tvs -> F e
 150                   in
 151                   go G b
 152                 where
 153                     G = F . Let x = x' tvs
 154
 155                 go F (Letrec xi=ei in b)
 156                 = Letrec {xi' = /\tvs -> G ei}
 157                   in
 158                   go G b
 159                 where
 160                   G = F . Let {xi = xi' tvs}
 161
 162 \begin{code}
 163 mkRhsTyLam (Lam b e)
 164  | isTyVar b = case collectTyBinders e of
 165                   (bs,body) -> mkRhsTyLam_help (b:bs) body
 166
 167 mkRhsTyLam other_expr           -- No-op if not a type lambda
 168   = returnSmpl other_expr
 169
 170
 171 mkRhsTyLam_help tyvars body
 172   = go (\x -> x) body
 173   where
 174     main_tyvar_set = mkVarSet tyvars
 175
 176     go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
 177       = go (fn . Let bind) body
 178
 179     go fn (Let bind@(NonRec var rhs) body)
 180       = mk_poly tyvars_here var                         `thenSmpl` \ (var', rhs') ->
 181         go (fn . Let (mk_silly_bind var rhs')) body     `thenSmpl` \ body' ->
 182         returnSmpl (Let (NonRec var' (mkLams tyvars_here (fn rhs))) body')
 183       where
 184         tyvars_here = tyvars
 185                 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfType var_ty)
 186                 -- tyvars_here was an attempt to reduce the number of tyvars
 187                 -- wrt which the new binding is abstracted.  But the naive
 188                 -- approach of abstract wrt the tyvars free in the Id's type
 189                 -- fails. Consider:
 190                 --      /\ a b -> let t :: (a,b) = (e1, e2)
 191                 --                    x :: a     = fst t
 192                 --                in ...
 193                 -- Here, b isn't free in a's type, but we must nevertheless
 194                 -- abstract wrt b as well, because t's type mentions b.
 195                 -- Since t is floated too, we'd end up with the bogus:
 196                 --      poly_t = /\ a b -> (e1, e2)
 197                 --      poly_x = /\ a   -> fst (poly_t a *b*)
 198                 -- So for now we adopt the even more naive approach of
 199                 -- abstracting wrt *all* the tyvars.  We'll see if that
 200                 -- gives rise to problems.   SLPJ June 98
 201
 202         var_ty = idType var
 203
 204     go fn (Let (Rec prs) body)
 205        = mapAndUnzipSmpl (mk_poly tyvars_here) vars     `thenSmpl` \ (vars', rhss') ->
 206          let
 207             gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss')
 208          in
 209          go gn body                             `thenSmpl` \ body' ->
 210          returnSmpl (Let (Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss])) body')
 211        where
 212          (vars,rhss) = unzip prs
 213          tyvars_here = tyvars
 214                 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfTypes var_tys)
 215                 -- See notes with tyvars_here above
 216
 217          var_tys     = map idType vars
 218
 219     go fn body = returnSmpl (mkLams tyvars (fn body))
 220
 221     mk_poly tyvars_here var
 222       = newId (mkForAllTys tyvars_here (idType var))    $ \ poly_id ->
 223         let
 224                 -- It's crucial to copy the inline-prag of the original var, because
 225                 -- we're looking at occurrence-analysed but as yet unsimplified code!
 226                 -- In particular, we mustn't lose the loop breakers.
 227                 --
 228                 -- *However* we don't want to retain a single-occurrence or dead-var info
 229                 -- because we're adding a load of "silly bindings" of the form
 230                 --      var _U_ = poly_var t1 t2
 231                 -- with a must-inline pragma on the silly binding to prevent the
 232                 -- poly-var from being inlined right back in.  Since poly_var now
 233                 -- occurs inside an INLINE binding, it should be given a ManyOcc,
 234                 -- else it may get inlined unconditionally
 235             poly_inline_prag = case getInlinePragma var of
 236                                   ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo
 237                                   IAmDead                 -> NoInlinePragInfo
 238                                   var_inline_prag         -> var_inline_prag
 239
 240             poly_id' = setInlinePragma poly_id poly_inline_prag
 241         in
 242         returnSmpl (poly_id', mkTyApps (Var poly_id') (mkTyVarTys tyvars_here))
 243
 244     mk_silly_bind var rhs = NonRec (setInlinePragma var IWantToBeINLINEd) rhs
 245                 -- The addInlinePragma is really important!  If we don't say
 246                 -- INLINE on these silly little bindings then look what happens!
 247                 -- Suppose we start with:
 248                 --
 249                 --      x = let g = /\a -> \x -> f x x
 250                 --          in
 251                 --          /\ b -> let g* = g b in E
 252                 --
 253                 -- Then:        * the binding for g gets floated out
 254                 --              * but then it gets inlined into the rhs of g*
 255                 --              * then the binding for g* is floated out of the /\b
 256                 --              * so we're back to square one
 257                 -- The silly binding for g* must be INLINE, so that no inlining
 258                 -- will happen in its RHS.
 259                 -- PS: Jun 98: actually this isn't important any more;
 260                 --             inlineUnconditionally will catch the type applicn
 261                 --             and inline it unconditionally, without ever trying
 262                 --             to simplify the RHS
 263 \end{code}
 264
 265
 266 %************************************************************************
 267 %*                                                                      *
 268 \subsection{Eta reduction}
 269 %*                                                                      *
 270 %************************************************************************
 271
 272 @etaCoreExpr@ trys an eta reduction at the top level of a Core Expr.
 273
 274 e.g.    \ x y -> f x y  ===>  f
 275
 276 It is used
 277         a) Before constructing an Unfolding, to
 278            try to make the unfolding smaller;
 279         b) In tidyCoreExpr, which is done just before converting to STG.
 280
 281 But we only do this if
 282         i) It gets rid of a whole lambda, not part.
 283            The idea is that lambdas are often quite helpful: they indicate
 284            head normal forms, so we don't want to chuck them away lightly.
 285
 286         ii) It exposes a simple variable or a type application; in short
 287             it exposes a "trivial" expression. (exprIsTrivial)
 288
 289 \begin{code}
 290 etaCoreExpr :: CoreExpr -> CoreExpr
 291                 -- ToDo: we should really check that we don't turn a non-bottom
 292                 -- lambda into a bottom variable.  Sigh
 293
 294 etaCoreExpr expr@(Lam bndr body)
 295   | opt_DoEtaReduction
 296   = check (reverse binders) body
 297   where
 298     (binders, body) = collectBinders expr
 299
 300     check [] body
 301         | exprIsTrivial body && not (any (`elemVarSet` body_fvs) binders)
 302         = body                  -- Success!
 303         where
 304           body_fvs = exprFreeVars body
 305
 306     check (b : bs) (App fun arg)
 307         |  (varToCoreExpr b `cheapEqExpr` arg)
 308         = check bs fun
 309
 310     check _ _ = expr    -- Bale out
 311
 312 etaCoreExpr expr = expr         -- The common case
 313 \end{code}
 314
 315
 316 %************************************************************************
 317 %*                                                                      *
 318 \subsection{Eta expansion}
 319 %*                                                                      *
 320 %************************************************************************
 321
 322 @etaExpandCount@ takes an expression, E, and returns an integer n,
 323 such that
 324
 325         E  ===>   (\x1::t1 x1::t2 ... xn::tn -> E x1 x2 ... xn)
 326
 327 is a safe transformation.  In particular, the transformation should
 328 not cause work to be duplicated, unless it is ``cheap'' (see
 329 @manifestlyCheap@ below).
 330
 331 @etaExpandCount@ errs on the conservative side.  It is always safe to
 332 return 0.
 333
 334 An application of @error@ is special, because it can absorb as many
 335 arguments as you care to give it.  For this special case we return
 336 100, to represent "infinity", which is a bit of a hack.
 337
 338 \begin{code}
 339 etaExpandCount :: CoreExpr
 340                -> Int   -- Number of extra args you can safely abstract
 341
 342 etaExpandCount (Lam b body)
 343   | isId b
 344   = 1 + etaExpandCount body
 345
 346 etaExpandCount (Let bind body)
 347   | all exprIsCheap (rhssOfBind bind)
 348   = etaExpandCount body
 349
 350 etaExpandCount (Case scrut _ alts)
 351   | exprIsCheap scrut
 352   = minimum [etaExpandCount rhs | (_,_,rhs) <- alts]
 353
 354 etaExpandCount fun@(Var _)     = eta_fun fun
 355
 356 etaExpandCount (App fun (Type ty))
 357   = eta_fun fun
 358 etaExpandCount (App fun arg)
 359   | exprIsCheap arg = case etaExpandCount fun of
 360                                 0 -> 0
 361                                 n -> n-1        -- Knock off one
 362
 363 etaExpandCount other = 0    -- Give up
 364         -- Lit, Con, Prim,
 365         -- non-val Lam,
 366         -- Scc (pessimistic; ToDo),
 367         -- Let with non-whnf rhs(s),
 368         -- Case with non-whnf scrutinee
 369
 370 -----------------------------
 371 eta_fun :: CoreExpr      -- The function
 372         -> Int           -- How many args it can safely be applied to
 373
 374 eta_fun (App fun (Type ty)) = eta_fun fun
 375 eta_fun (Var v)             = arityLowerBound (getIdArity v)
 376 eta_fun other               = 0         -- Give up
 377 \end{code}
 378
 379
 380 %************************************************************************
 381 %*                                                                      *
 382 \subsection{Case absorption and identity-case elimination}
 383 %*                                                                      *
 384 %************************************************************************
 385
 386 \begin{code}
 387 mkCase :: SwitchChecker -> OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
 388 \end{code}
 389
 390 @mkCase@ tries the following transformation (if possible):
 391
 392 case e of b {             ==>   case e of b {
 393   p1 -> rhs1                      p1 -> rhs1
 394   ...                             ...
 395   pm -> rhsm                      pm -> rhsm
 396   _  -> case b of b' {            pn -> rhsn[b/b'] {or (alg)  let b=b' in rhsn}
 397                                                    {or (prim) case b of b' { _ -> rhsn}}
 398               pn -> rhsn          ...
 399               ...                 po -> rhso[b/b']
 400               po -> rhso          _  -> rhsd[b/b'] {or let b'=b in rhsd}
 401               _  -> rhsd
 402 }
 403
 404 which merges two cases in one case when -- the default alternative of
 405 the outer case scrutises the same variable as the outer case This
 406 transformation is called Case Merging.  It avoids that the same
 407 variable is scrutinised multiple times.
 408
 409 \begin{code}
 410 mkCase sw_chkr scrut outer_bndr outer_alts
 411   |  switchIsOn sw_chkr SimplCaseMerge
 412   && maybeToBool maybe_case_in_default
 413
 414   = tick CaseMerge                      `thenSmpl_`
 415     returnSmpl (Case scrut outer_bndr new_alts)
 416         -- Warning: don't call mkCase recursively!
 417         -- Firstly, there's no point, because inner alts have already had
 418         -- mkCase applied to them, so they won't have a case in their default
 419         -- Secondly, if you do, you get an infinite loop, because the bindNonRec
 420         -- in munge_rhs puts a case into the DEFAULT branch!
 421   where
 422     new_alts = outer_alts_without_deflt ++ munged_inner_alts
 423     maybe_case_in_default = case findDefault outer_alts of
 424                                 (outer_alts_without_default,
 425                                  Just (Case (Var scrut_var) inner_bndr inner_alts))
 426
 427                                    | outer_bndr == scrut_var
 428                                    -> Just (outer_alts_without_default, inner_bndr, inner_alts)
 429                                 other -> Nothing
 430
 431     Just (outer_alts_without_deflt, inner_bndr, inner_alts) = maybe_case_in_default
 432
 433                 --  Eliminate any inner alts which are shadowed by the outer ones
 434     outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
 435
 436     munged_inner_alts = [ (con, args, munge_rhs rhs)
 437                         | (con, args, rhs) <- inner_alts,
 438                            not (con `elem` outer_cons)  -- Eliminate shadowed inner alts
 439                         ]
 440     munge_rhs rhs = bindNonRec inner_bndr (Var outer_bndr) rhs
 441 \end{code}
 442
 443 Now the identity-case transformation:
 444
 445         case e of               ===> e
 446                 True -> True;
 447                 False -> False
 448
 449 and similar friends.
 450
 451 \begin{code}
 452 mkCase sw_chkr scrut case_bndr alts
 453   | all identity_alt alts
 454   = tick CaseIdentity           `thenSmpl_`
 455     returnSmpl scrut
 456   where
 457     identity_alt (DEFAULT, [], Var v)        = v == case_bndr
 458     identity_alt (con, args, Con con' args') = con == con' &&
 459                                                and (zipWithEqual "mkCase"
 460                                                         cheapEqExpr
 461                                                         (map Type arg_tys ++ map varToCoreExpr args)
 462                                                         args')
 463     identity_alt other                       = False
 464
 465     arg_tys = case splitTyConApp_maybe (idType case_bndr) of
 466                 Just (tycon, arg_tys) -> arg_tys
 467 \end{code}
 468
 469 The catch-all case
 470
 471 \begin{code}
 472 mkCase sw_chkr other_scrut case_bndr other_alts
 473   = returnSmpl (Case other_scrut case_bndr other_alts)
 474 \end{code}
 475
 476
 477 \begin{code}
 478 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
 479 findDefault []                          = ([], Nothing)
 480 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args )
 481                                           ([], Just rhs)
 482 findDefault (alt : alts)                = case findDefault alts of
 483                                             (alts', deflt) -> (alt : alts', deflt)
 484
 485 findAlt :: Con -> [CoreAlt] -> CoreAlt
 486 findAlt con alts
 487   = go alts
 488   where
 489     go []           = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
 490     go (alt : alts) | matches alt = alt
 491                     | otherwise   = go alts
 492
 493     matches (DEFAULT, _, _) = True
 494     matches (con1, _, _)    = con == con1
 495 \end{code}