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