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