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 )
  22 import Subst            ( substBndrs, substBndr, substIds )
  23 import Id               ( Id, idType, getIdArity, isId, idName,
  24                           getInlinePragma, setInlinePragma,
  25                           getIdDemandInfo, mkId
  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,
  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     setSubst subst'     $
  58     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     setSubst subst'     $
  67     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     setSubst subst'     $
  80     thing_inside bndrs'
  81 \end{code}
  82
  83
  84 %************************************************************************
  85 %*                                                                      *
  86 \subsection{Transform a RHS}
  87 %*                                                                      *
  88 %************************************************************************
  89
  90 Try (a) eta expansion
  91     (b) type-lambda swizzling
  92
  93 \begin{code}
  94 transformRhs :: InExpr -> SimplM InExpr
  95 transformRhs rhs
  96   = tryEtaExpansion body                `thenSmpl` \ body' ->
  97     mkRhsTyLam tyvars body'
  98   where
  99     (tyvars, body) = collectTyBinders rhs
 100 \end{code}
 101
 102
 103 %************************************************************************
 104 %*                                                                      *
 105 \subsection{Local tyvar-lifting}
 106 %*                                                                      *
 107 %************************************************************************
 108
 109 mkRhsTyLam tries this transformation, when the big lambda appears as
 110 the RHS of a let(rec) binding:
 111
 112         /\abc -> let(rec) x = e in b
 113    ==>
 114         let(rec) x' = /\abc -> let x = x' a b c in e
 115         in
 116         /\abc -> let x = x' a b c in b
 117
 118 This is good because it can turn things like:
 119
 120         let f = /\a -> letrec g = ... g ... in g
 121 into
 122         letrec g' = /\a -> ... g' a ...
 123         in
 124         let f = /\ a -> g' a
 125
 126 which is better.  In effect, it means that big lambdas don't impede
 127 let-floating.
 128
 129 This optimisation is CRUCIAL in eliminating the junk introduced by
 130 desugaring mutually recursive definitions.  Don't eliminate it lightly!
 131
 132 So far as the implemtation is concerned:
 133
 134         Invariant: go F e = /\tvs -> F e
 135
 136         Equalities:
 137                 go F (Let x=e in b)
 138                 = Let x' = /\tvs -> F e
 139                   in
 140                   go G b
 141                 where
 142                     G = F . Let x = x' tvs
 143
 144                 go F (Letrec xi=ei in b)
 145                 = Letrec {xi' = /\tvs -> G ei}
 146                   in
 147                   go G b
 148                 where
 149                   G = F . Let {xi = xi' tvs}
 150
 151 [May 1999]  If we do this transformation *regardless* then we can
 152 end up with some pretty silly stuff.  For example,
 153
 154         let
 155             st = /\ s -> let { x1=r1 ; x2=r2 } in ...
 156         in ..
 157 becomes
 158         let y1 = /\s -> r1
 159             y2 = /\s -> r2
 160             st = /\s -> ...[y1 s/x1, y2 s/x2]
 161         in ..
 162
 163 Unless the "..." is a WHNF there is really no point in doing this.
 164 Indeed it can make things worse.  Suppose x1 is used strictly,
 165 and is of the form
 166
 167         x1* = case f y of { (a,b) -> e }
 168
 169 If we abstract this wrt the tyvar we then can't do the case inline
 170 as we would normally do.
 171
 172
 173 \begin{code}
 174 mkRhsTyLam tyvars body                  -- Only does something if there's a let
 175   | null tyvars || not (worth_it body)  -- inside a type lambda, and a WHNF inside that
 176   = returnSmpl (mkLams tyvars body)
 177   | otherwise
 178   = go (\x -> x) body
 179   where
 180     worth_it (Let _ e)       = whnf_in_middle e
 181     worth_it other           = False
 182     whnf_in_middle (Let _ e) = whnf_in_middle e
 183     whnf_in_middle e         = exprIsCheap e
 184
 185     main_tyvar_set = mkVarSet tyvars
 186
 187     go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
 188       = go (fn . Let bind) body
 189
 190     go fn (Let bind@(NonRec var rhs) body)
 191       = mk_poly tyvars_here var                         `thenSmpl` \ (var', rhs') ->
 192         go (fn . Let (mk_silly_bind var rhs')) body     `thenSmpl` \ body' ->
 193         returnSmpl (Let (NonRec var' (mkLams tyvars_here (fn rhs))) body')
 194       where
 195         tyvars_here = tyvars
 196                 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfType var_ty)
 197                 -- tyvars_here was an attempt to reduce the number of tyvars
 198                 -- wrt which the new binding is abstracted.  But the naive
 199                 -- approach of abstract wrt the tyvars free in the Id's type
 200                 -- fails. Consider:
 201                 --      /\ a b -> let t :: (a,b) = (e1, e2)
 202                 --                    x :: a     = fst t
 203                 --                in ...
 204                 -- Here, b isn't free in x's type, but we must nevertheless
 205                 -- abstract wrt b as well, because t's type mentions b.
 206                 -- Since t is floated too, we'd end up with the bogus:
 207                 --      poly_t = /\ a b -> (e1, e2)
 208                 --      poly_x = /\ a   -> fst (poly_t a *b*)
 209                 -- So for now we adopt the even more naive approach of
 210                 -- abstracting wrt *all* the tyvars.  We'll see if that
 211                 -- gives rise to problems.   SLPJ June 98
 212
 213         var_ty = idType var
 214
 215     go fn (Let (Rec prs) body)
 216        = mapAndUnzipSmpl (mk_poly tyvars_here) vars     `thenSmpl` \ (vars', rhss') ->
 217          let
 218             gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss')
 219          in
 220          go gn body                             `thenSmpl` \ body' ->
 221          returnSmpl (Let (Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss])) body')
 222        where
 223          (vars,rhss) = unzip prs
 224          tyvars_here = tyvars
 225                 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfTypes var_tys)
 226                 -- See notes with tyvars_here above
 227
 228          var_tys     = map idType vars
 229
 230     go fn body = returnSmpl (mkLams tyvars (fn body))
 231
 232     mk_poly tyvars_here var
 233       = getUniqueSmpl           `thenSmpl` \ uniq ->
 234         let
 235             poly_name = setNameUnique (idName var) uniq         -- Keep same name
 236             poly_ty   = mkForAllTys tyvars_here (idType var)    -- But new type of course
 237
 238                 -- It's crucial to copy the inline-prag of the original var, because
 239                 -- we're looking at occurrence-analysed but as yet unsimplified code!
 240                 -- In particular, we mustn't lose the loop breakers.
 241                 --
 242                 -- It's even right to retain single-occurrence or dead-var info:
 243                 -- Suppose we started with  /\a -> let x = E in B
 244                 -- where x occurs once in E. Then we transform to:
 245                 --      let x' = /\a -> E in /\a -> let x* = x' a in B
 246                 -- where x* has an INLINE prag on it.  Now, once x* is inlined,
 247                 -- the occurrences of x' will be just the occurrences originaly
 248                 -- pinned on x.
 249             poly_info = vanillaIdInfo `setInlinePragInfo` getInlinePragma var
 250
 251             poly_id   = mkId poly_name poly_ty poly_info
 252         in
 253         returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
 254
 255     mk_silly_bind var rhs = NonRec (setInlinePragma var IMustBeINLINEd) rhs
 256                 -- The addInlinePragma is really important!  If we don't say
 257                 -- INLINE on these silly little bindings then look what happens!
 258                 -- Suppose we start with:
 259                 --
 260                 --      x = let g = /\a -> \x -> f x x
 261                 --          in
 262                 --          /\ b -> let g* = g b in E
 263                 --
 264                 -- Then:        * the binding for g gets floated out
 265                 --              * but then it gets inlined into the rhs of g*
 266                 --              * then the binding for g* is floated out of the /\b
 267                 --              * so we're back to square one
 268                 -- The silly binding for g* must be IMustBeINLINEs, so that
 269                 -- we simply substitute for g* throughout.
 270 \end{code}
 271
 272
 273 %************************************************************************
 274 %*                                                                      *
 275 \subsection{Eta expansion}
 276 %*                                                                      *
 277 %************************************************************************
 278
 279         Try eta expansion for RHSs
 280
 281 We go for:
 282                 \x1..xn -> N    ==>   \x1..xn y1..ym -> N y1..ym
 283         AND
 284                 N E1..En        ==>   let z1=E1 .. zn=En in \y1..ym -> N z1..zn y1..ym
 285
 286 where (in both cases) N is a NORMAL FORM (i.e. no redexes anywhere)
 287 wanting a suitable number of extra args.
 288
 289 NB: the Ei may have unlifted type, but the simplifier (which is applied
 290 to the result) deals OK with this).
 291
 292 There is no point in looking for a combination of the two,
 293 because that would leave use with some lets sandwiched between lambdas;
 294 that's what the final test in the first equation is for.
 295
 296 \begin{code}
 297 tryEtaExpansion :: InExpr -> SimplM InExpr
 298 tryEtaExpansion rhs
 299   |  not opt_SimplDoLambdaEtaExpansion
 300   || exprIsTrivial rhs                          -- Don't eta-expand a trival RHS
 301   || null y_tys                                 -- No useful expansion
 302   || not (null x_bndrs || and trivial_args)     -- Not (no x-binders or no z-binds)
 303   = returnSmpl rhs
 304
 305   | otherwise   -- Consider eta expansion
 306   = newIds y_tys                                                $ ( \ y_bndrs ->
 307     tick (EtaExpansion (head y_bndrs))                          `thenSmpl_`
 308     mapAndUnzipSmpl bind_z_arg (args `zip` trivial_args)        `thenSmpl` (\ (maybe_z_binds, z_args) ->
 309     returnSmpl (mkLams x_bndrs                          $
 310                 mkLets (catMaybes maybe_z_binds)        $
 311                 mkLams y_bndrs                          $
 312                 mkApps (mkApps fun z_args) (map Var y_bndrs))))
 313   where
 314     (x_bndrs, body) = collectValBinders rhs
 315     (fun, args)     = collectArgs body
 316     trivial_args    = map exprIsTrivial args
 317     fun_arity       = case fun of
 318                         Var v -> arityLowerBound (getIdArity v)
 319                         other -> 0
 320
 321     bind_z_arg (arg, trivial_arg)
 322         | trivial_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}