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         transformRhs,
  10         etaCoreExpr,
  11         mkCase, findAlt, findDefault,
  12         mkCoerce
  13     ) where
  14
  15 #include "HsVersions.h"
  16
  17 import BinderInfo
  18 import CmdLineOpts      ( opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge )
  19 import CoreSyn
  20 import CoreFVs          ( exprFreeVars )
  21 import CoreUtils        ( exprIsTrivial, cheapEqExpr, coreExprType, exprIsCheap, exprGenerousArity )
  22 import Subst            ( substBndrs, substBndr, substIds )
  23 import Id               ( Id, idType, getIdArity, isId, idName,
  24                           getInlinePragma, setInlinePragma,
  25                           getIdDemandInfo, mkId, idInfo
  26                         )
  27 import IdInfo           ( arityLowerBound, InlinePragInfo(..), setInlinePragInfo, vanillaIdInfo )
  28 import Maybes           ( maybeToBool, catMaybes )
  29 import Const            ( Con(..) )
  30 import Name             ( isLocalName, setNameUnique )
  31 import SimplMonad
  32 import Type             ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType,
  33                           splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
  34                         )
  35 import TysPrim          ( statePrimTyCon )
  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 \begin{code}
  51 simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
  52 simplBinders bndrs thing_inside
  53   = getSubst            `thenSmpl` \ subst ->
  54     let
  55         (subst', bndrs') = substBndrs subst bndrs
  56     in
  57     seqBndrs bndrs'     `seq`
  58     setSubst subst' (thing_inside bndrs')
  59
  60 simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
  61 simplBinder bndr thing_inside
  62   = getSubst            `thenSmpl` \ subst ->
  63     let
  64         (subst', bndr') = substBndr subst bndr
  65     in
  66     seqBndr bndr'       `seq`
  67     setSubst subst' (thing_inside bndr')
  68
  69
  70 -- Same semantics as simplBinders, but a little less
  71 -- plumbing and hence a little more efficient.
  72 -- Maybe not worth the candle?
  73 simplIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
  74 simplIds ids thing_inside
  75   = getSubst            `thenSmpl` \ subst ->
  76     let
  77         (subst', bndrs') = substIds subst ids
  78     in
  79     seqBndrs bndrs'     `seq`
  80     setSubst subst' (thing_inside bndrs')
  81
  82 seqBndrs [] = ()
  83 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
  84
  85 seqBndr b | isTyVar b = b `seq` ()
  86           | otherwise = seqType (idType b)      `seq`
  87                         idInfo b                `seq`
  88                         ()
  89 \end{code}
  90
  91
  92 %************************************************************************
  93 %*                                                                      *
  94 \subsection{Transform a RHS}
  95 %*                                                                      *
  96 %************************************************************************
  97
  98 Try (a) eta expansion
  99     (b) type-lambda swizzling
 100
 101 \begin{code}
 102 transformRhs :: InExpr -> SimplM InExpr
 103 transformRhs rhs
 104   = tryEtaExpansion body                `thenSmpl` \ body' ->
 105     mkRhsTyLam tyvars body'
 106   where
 107     (tyvars, body) = collectTyBinders rhs
 108 \end{code}
 109
 110
 111 %************************************************************************
 112 %*                                                                      *
 113 \subsection{Local tyvar-lifting}
 114 %*                                                                      *
 115 %************************************************************************
 116
 117 mkRhsTyLam tries this transformation, when the big lambda appears as
 118 the RHS of a let(rec) binding:
 119
 120         /\abc -> let(rec) x = e in b
 121    ==>
 122         let(rec) x' = /\abc -> let x = x' a b c in e
 123         in
 124         /\abc -> let x = x' a b c in b
 125
 126 This is good because it can turn things like:
 127
 128         let f = /\a -> letrec g = ... g ... in g
 129 into
 130         letrec g' = /\a -> ... g' a ...
 131         in
 132         let f = /\ a -> g' a
 133
 134 which is better.  In effect, it means that big lambdas don't impede
 135 let-floating.
 136
 137 This optimisation is CRUCIAL in eliminating the junk introduced by
 138 desugaring mutually recursive definitions.  Don't eliminate it lightly!
 139
 140 So far as the implemtation is concerned:
 141
 142         Invariant: go F e = /\tvs -> F e
 143
 144         Equalities:
 145                 go F (Let x=e in b)
 146                 = Let x' = /\tvs -> F e
 147                   in
 148                   go G b
 149                 where
 150                     G = F . Let x = x' tvs
 151
 152                 go F (Letrec xi=ei in b)
 153                 = Letrec {xi' = /\tvs -> G ei}
 154                   in
 155                   go G b
 156                 where
 157                   G = F . Let {xi = xi' tvs}
 158
 159 [May 1999]  If we do this transformation *regardless* then we can
 160 end up with some pretty silly stuff.  For example,
 161
 162         let
 163             st = /\ s -> let { x1=r1 ; x2=r2 } in ...
 164         in ..
 165 becomes
 166         let y1 = /\s -> r1
 167             y2 = /\s -> r2
 168             st = /\s -> ...[y1 s/x1, y2 s/x2]
 169         in ..
 170
 171 Unless the "..." is a WHNF there is really no point in doing this.
 172 Indeed it can make things worse.  Suppose x1 is used strictly,
 173 and is of the form
 174
 175         x1* = case f y of { (a,b) -> e }
 176
 177 If we abstract this wrt the tyvar we then can't do the case inline
 178 as we would normally do.
 179
 180
 181 \begin{code}
 182 mkRhsTyLam tyvars body                  -- Only does something if there's a let
 183   | null tyvars || not (worth_it body)  -- inside a type lambda, and a WHNF inside that
 184   = returnSmpl (mkLams tyvars body)
 185   | otherwise
 186   = go (\x -> x) body
 187   where
 188     worth_it (Let _ e)       = whnf_in_middle e
 189     worth_it other           = False
 190     whnf_in_middle (Let _ e) = whnf_in_middle e
 191     whnf_in_middle e         = exprIsCheap e
 192
 193     main_tyvar_set = mkVarSet tyvars
 194
 195     go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
 196       = go (fn . Let bind) body
 197
 198     go fn (Let bind@(NonRec var rhs) body)
 199       = mk_poly tyvars_here var                         `thenSmpl` \ (var', rhs') ->
 200         go (fn . Let (mk_silly_bind var rhs')) body     `thenSmpl` \ body' ->
 201         returnSmpl (Let (NonRec var' (mkLams tyvars_here (fn rhs))) body')
 202       where
 203         tyvars_here = tyvars
 204                 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfType var_ty)
 205                 -- tyvars_here was an attempt to reduce the number of tyvars
 206                 -- wrt which the new binding is abstracted.  But the naive
 207                 -- approach of abstract wrt the tyvars free in the Id's type
 208                 -- fails. Consider:
 209                 --      /\ a b -> let t :: (a,b) = (e1, e2)
 210                 --                    x :: a     = fst t
 211                 --                in ...
 212                 -- Here, b isn't free in x's type, but we must nevertheless
 213                 -- abstract wrt b as well, because t's type mentions b.
 214                 -- Since t is floated too, we'd end up with the bogus:
 215                 --      poly_t = /\ a b -> (e1, e2)
 216                 --      poly_x = /\ a   -> fst (poly_t a *b*)
 217                 -- So for now we adopt the even more naive approach of
 218                 -- abstracting wrt *all* the tyvars.  We'll see if that
 219                 -- gives rise to problems.   SLPJ June 98
 220
 221         var_ty = idType var
 222
 223     go fn (Let (Rec prs) body)
 224        = mapAndUnzipSmpl (mk_poly tyvars_here) vars     `thenSmpl` \ (vars', rhss') ->
 225          let
 226             gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss')
 227          in
 228          go gn body                             `thenSmpl` \ body' ->
 229          returnSmpl (Let (Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss])) body')
 230        where
 231          (vars,rhss) = unzip prs
 232          tyvars_here = tyvars
 233                 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfTypes var_tys)
 234                 -- See notes with tyvars_here above
 235
 236          var_tys     = map idType vars
 237
 238     go fn body = returnSmpl (mkLams tyvars (fn body))
 239
 240     mk_poly tyvars_here var
 241       = getUniqueSmpl           `thenSmpl` \ uniq ->
 242         let
 243             poly_name = setNameUnique (idName var) uniq         -- Keep same name
 244             poly_ty   = mkForAllTys tyvars_here (idType var)    -- But new type of course
 245
 246                 -- It's crucial to copy the inline-prag of the original var, because
 247                 -- we're looking at occurrence-analysed but as yet unsimplified code!
 248                 -- In particular, we mustn't lose the loop breakers.
 249                 --
 250                 -- It's even right to retain single-occurrence or dead-var info:
 251                 -- Suppose we started with  /\a -> let x = E in B
 252                 -- where x occurs once in E. Then we transform to:
 253                 --      let x' = /\a -> E in /\a -> let x* = x' a in B
 254                 -- where x* has an INLINE prag on it.  Now, once x* is inlined,
 255                 -- the occurrences of x' will be just the occurrences originaly
 256                 -- pinned on x.
 257             poly_info = vanillaIdInfo `setInlinePragInfo` getInlinePragma var
 258
 259             poly_id   = mkId poly_name poly_ty poly_info
 260         in
 261         returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
 262
 263     mk_silly_bind var rhs = NonRec (setInlinePragma var IMustBeINLINEd) rhs
 264                 -- The addInlinePragma is really important!  If we don't say
 265                 -- INLINE on these silly little bindings then look what happens!
 266                 -- Suppose we start with:
 267                 --
 268                 --      x = let g = /\a -> \x -> f x x
 269                 --          in
 270                 --          /\ b -> let g* = g b in E
 271                 --
 272                 -- Then:        * the binding for g gets floated out
 273                 --              * but then it gets inlined into the rhs of g*
 274                 --              * then the binding for g* is floated out of the /\b
 275                 --              * so we're back to square one
 276                 -- The silly binding for g* must be IMustBeINLINEs, so that
 277                 -- we simply substitute for g* throughout.
 278 \end{code}
 279
 280
 281 %************************************************************************
 282 %*                                                                      *
 283 \subsection{Eta expansion}
 284 %*                                                                      *
 285 %************************************************************************
 286
 287         Try eta expansion for RHSs
 288
 289 We go for:
 290                 \x1..xn -> N    ==>   \x1..xn y1..ym -> N y1..ym
 291         AND
 292                 N E1..En        ==>   let z1=E1 .. zn=En in \y1..ym -> N z1..zn y1..ym
 293
 294 where (in both cases) N is a NORMAL FORM (i.e. no redexes anywhere)
 295 wanting a suitable number of extra args.
 296
 297 NB: the Ei may have unlifted type, but the simplifier (which is applied
 298 to the result) deals OK with this.
 299
 300 There is no point in looking for a combination of the two,
 301 because that would leave use with some lets sandwiched between lambdas;
 302 that's what the final test in the first equation is for.
 303
 304 \begin{code}
 305 tryEtaExpansion :: InExpr -> SimplM InExpr
 306 tryEtaExpansion rhs
 307   |  not opt_SimplDoLambdaEtaExpansion
 308   || exprIsTrivial rhs                          -- Don't eta-expand a trival RHS
 309   || null y_tys                                 -- No useful expansion
 310   || not (null x_bndrs || and trivial_args)     -- Not (no x-binders or no z-binds)
 311   = returnSmpl rhs
 312
 313   | otherwise   -- Consider eta expansion
 314   = newIds y_tys                                                $ ( \ y_bndrs ->
 315     tick (EtaExpansion (head y_bndrs))                          `thenSmpl_`
 316     mapAndUnzipSmpl bind_z_arg (args `zip` trivial_args)        `thenSmpl` (\ (maybe_z_binds, z_args) ->
 317     returnSmpl (mkLams x_bndrs                          $
 318                 mkLets (catMaybes maybe_z_binds)        $
 319                 mkLams y_bndrs                          $
 320                 mkApps (mkApps fun z_args) (map Var y_bndrs))))
 321   where
 322     (x_bndrs, body) = collectValBinders rhs
 323     (fun, args)     = collectArgs body
 324     trivial_args    = map exprIsTrivial args
 325     fun_arity       = exprGenerousArity fun
 326
 327     bind_z_arg (arg, trivial_arg)
 328         | trivial_arg = returnSmpl (Nothing, arg)
 329         | otherwise   = newId (coreExprType arg)        $ \ z ->
 330                         returnSmpl (Just (NonRec z arg), Var z)
 331
 332         -- Note: I used to try to avoid the coreExprType call by using
 333         -- the type of the binder.  But this type doesn't necessarily
 334         -- belong to the same substitution environment as this rhs;
 335         -- and we are going to make extra term binders (y_bndrs) from the type
 336         -- which will be processed with the rhs substitution environment.
 337         -- This only went wrong in a mind bendingly complicated case.
 338     (potential_extra_arg_tys, inner_ty) = splitFunTys (coreExprType body)
 339
 340     y_tys :: [InType]
 341     y_tys  = take no_extras_wanted potential_extra_arg_tys
 342
 343     no_extras_wanted :: Int
 344     no_extras_wanted = 0 `max`
 345
 346         -- We used to expand the arity to the previous arity fo the
 347         -- function; but this is pretty dangerous.  Consdier
 348         --      f = \xy -> e
 349         -- so that f has arity 2.  Now float something into f's RHS:
 350         --      f = let z = BIG in \xy -> e
 351         -- The last thing we want to do now is to put some lambdas
 352         -- outside, to get
 353         --      f = \xy -> let z = BIG in e
 354         --
 355         -- (bndr_arity - no_of_xs)              `max`
 356
 357         -- See if the body could obviously do with more args
 358         (fun_arity - valArgCount args)
 359
 360 -- This case is now deal with by exprGenerousArity
 361         -- Finally, see if it's a state transformer, and xs is non-null
 362         -- (so it's also a function not a thunk) in which
 363         -- case we eta-expand on principle! This can waste work,
 364         -- but usually doesn't.
 365         -- I originally checked for a singleton type [ty] in this case
 366         -- but then I found a situation in which I had
 367         --      \ x -> let {..} in \ s -> f (...) s
 368         -- AND f RETURNED A FUNCTION.  That is, 's' wasn't the only
 369         -- potential extra arg.
 370 --      case (x_bndrs, potential_extra_arg_tys) of
 371 --          (_:_, ty:_)  -> case splitTyConApp_maybe ty of
 372 --                                Just (tycon,_) | tycon == statePrimTyCon -> 1
 373 --                                other                                    -> 0
 374 --          other -> 0
 375 \end{code}
 376
 377
 378 %************************************************************************
 379 %*                                                                      *
 380 \subsection{Eta reduction}
 381 %*                                                                      *
 382 %************************************************************************
 383
 384 @etaCoreExpr@ trys an eta reduction at the top level of a Core Expr.
 385
 386 e.g.    \ x y -> f x y  ===>  f
 387
 388 It is used
 389 -- OLD
 390 --      a) Before constructing an Unfolding, to
 391 --         try to make the unfolding smaller;
 392         b) In tidyCoreExpr, which is done just before converting to STG.
 393
 394 But we only do this if
 395         i) It gets rid of a whole lambda, not part.
 396            The idea is that lambdas are often quite helpful: they indicate
 397            head normal forms, so we don't want to chuck them away lightly.
 398
 399 -- OLD: in core2stg we want to do this even if the result isn't trivial
 400 --      ii) It exposes a simple variable or a type application; in short
 401 --          it exposes a "trivial" expression. (exprIsTrivial)
 402
 403 \begin{code}
 404 etaCoreExpr :: CoreExpr -> CoreExpr
 405                 -- ToDo: we should really check that we don't turn a non-bottom
 406                 -- lambda into a bottom variable.  Sigh
 407
 408 etaCoreExpr expr@(Lam bndr body)
 409   = check (reverse binders) body
 410   where
 411     (binders, body) = collectBinders expr
 412
 413     check [] body
 414         | not (any (`elemVarSet` body_fvs) binders)
 415         = body                  -- Success!
 416         where
 417           body_fvs = exprFreeVars body
 418
 419     check (b : bs) (App fun arg)
 420         |  (varToCoreExpr b `cheapEqExpr` arg)
 421         = check bs fun
 422
 423     check _ _ = expr    -- Bale out
 424
 425 etaCoreExpr expr = expr         -- The common case
 426 \end{code}
 427
 428
 429 %************************************************************************
 430 %*                                                                      *
 431 \subsection{Case absorption and identity-case elimination}
 432 %*                                                                      *
 433 %************************************************************************
 434
 435 \begin{code}
 436 mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
 437 \end{code}
 438
 439 @mkCase@ tries the following transformation (if possible):
 440
 441 case e of b {             ==>   case e of b {
 442   p1 -> rhs1                      p1 -> rhs1
 443   ...                             ...
 444   pm -> rhsm                      pm -> rhsm
 445   _  -> case b of b' {            pn -> rhsn[b/b'] {or (alg)  let b=b' in rhsn}
 446                                                    {or (prim) case b of b' { _ -> rhsn}}
 447               pn -> rhsn          ...
 448               ...                 po -> rhso[b/b']
 449               po -> rhso          _  -> rhsd[b/b'] {or let b'=b in rhsd}
 450               _  -> rhsd
 451 }
 452
 453 which merges two cases in one case when -- the default alternative of
 454 the outer case scrutises the same variable as the outer case This
 455 transformation is called Case Merging.  It avoids that the same
 456 variable is scrutinised multiple times.
 457
 458 \begin{code}
 459 mkCase scrut outer_bndr outer_alts
 460   |  opt_SimplCaseMerge
 461   && maybeToBool maybe_case_in_default
 462
 463   = tick (CaseMerge outer_bndr)         `thenSmpl_`
 464     returnSmpl (Case scrut outer_bndr new_alts)
 465         -- Warning: don't call mkCase recursively!
 466         -- Firstly, there's no point, because inner alts have already had
 467         -- mkCase applied to them, so they won't have a case in their default
 468         -- Secondly, if you do, you get an infinite loop, because the bindNonRec
 469         -- in munge_rhs puts a case into the DEFAULT branch!
 470   where
 471     new_alts = outer_alts_without_deflt ++ munged_inner_alts
 472     maybe_case_in_default = case findDefault outer_alts of
 473                                 (outer_alts_without_default,
 474                                  Just (Case (Var scrut_var) inner_bndr inner_alts))
 475
 476                                    | outer_bndr == scrut_var
 477                                    -> Just (outer_alts_without_default, inner_bndr, inner_alts)
 478                                 other -> Nothing
 479
 480     Just (outer_alts_without_deflt, inner_bndr, inner_alts) = maybe_case_in_default
 481
 482                 --  Eliminate any inner alts which are shadowed by the outer ones
 483     outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
 484
 485     munged_inner_alts = [ (con, args, munge_rhs rhs)
 486                         | (con, args, rhs) <- inner_alts,
 487                            not (con `elem` outer_cons)  -- Eliminate shadowed inner alts
 488                         ]
 489     munge_rhs rhs = bindNonRec inner_bndr (Var outer_bndr) rhs
 490 \end{code}
 491
 492 Now the identity-case transformation:
 493
 494         case e of               ===> e
 495                 True -> True;
 496                 False -> False
 497
 498 and similar friends.
 499
 500 \begin{code}
 501 mkCase scrut case_bndr alts
 502   | all identity_alt alts
 503   = tick (CaseIdentity case_bndr)               `thenSmpl_`
 504     returnSmpl scrut
 505   where
 506     identity_alt (DEFAULT, [], Var v)        = v == case_bndr
 507     identity_alt (con, args, Con con' args') = con == con' &&
 508                                                and (zipWithEqual "mkCase"
 509                                                         cheapEqExpr
 510                                                         (map Type arg_tys ++ map varToCoreExpr args)
 511                                                         args')
 512     identity_alt other                       = False
 513
 514     arg_tys = case splitTyConApp_maybe (idType case_bndr) of
 515                 Just (tycon, arg_tys) -> arg_tys
 516 \end{code}
 517
 518 The catch-all case
 519
 520 \begin{code}
 521 mkCase other_scrut case_bndr other_alts
 522   = returnSmpl (Case other_scrut case_bndr other_alts)
 523 \end{code}
 524
 525
 526 \begin{code}
 527 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
 528 findDefault []                          = ([], Nothing)
 529 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args )
 530                                           ([], Just rhs)
 531 findDefault (alt : alts)                = case findDefault alts of
 532                                             (alts', deflt) -> (alt : alts', deflt)
 533
 534 findAlt :: Con -> [CoreAlt] -> CoreAlt
 535 findAlt con alts
 536   = go alts
 537   where
 538     go []           = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
 539     go (alt : alts) | matches alt = alt
 540                     | otherwise   = go alts
 541
 542     matches (DEFAULT, _, _) = True
 543     matches (con1, _, _)    = con == con1
 544
 545
 546 mkCoerce to_ty (Note (Coerce _ from_ty) expr)
 547   | to_ty == from_ty = expr
 548   | otherwise        = Note (Coerce to_ty from_ty) expr
 549 mkCoerce to_ty expr
 550   = Note (Coerce to_ty (coreExprType expr)) expr
 551 \end{code}