ghc/compiler/simplCore/SimplCase.lhs

   1 `%
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   3 %
   4 \section[SimplCase]{Simplification of `case' expression}
   5
   6 Support code for @Simplify@.
   7
   8 \begin{code}
   9 module SimplCase ( simplCase, bindLargeRhs ) where
  10
  11 #include "HsVersions.h"
  12
  13 import {-# SOURCE #-} Simplify ( simplBind, simplExpr )
  14
  15 import BinderInfo       -- too boring to try to select things...
  16 import CmdLineOpts      ( SimplifierSwitch(..) )
  17 import CoreSyn
  18 import CoreUnfold       ( Unfolding(..) )
  19 import CoreUtils        ( coreAltsType, nonErrorRHSs, maybeErrorApp,
  20                           unTagBindersAlts, unTagBinders, coreExprType
  21                         )
  22 import Id               ( idType, isDataCon, getIdDemandInfo, dataConArgTys,
  23                           DataCon, GenId{-instance Eq-},
  24                           Id
  25                         )
  26 import IdInfo           ( willBeDemanded, DemandInfo )
  27 import Literal          ( isNoRepLit, Literal{-instance Eq-} )
  28 import Maybes           ( maybeToBool )
  29 import PrelVals         ( voidId )
  30 import PrimOp           ( primOpOkForSpeculation, PrimOp{-instance Eq-} )
  31 import SimplVar         ( simplBinder, simplBinders )
  32 import SimplUtils       ( newId, newIds )
  33 import SimplEnv
  34 import SimplMonad
  35 import Type             ( isUnpointedType, splitAlgTyConApp_maybe, splitAlgTyConApp, mkFunTy, mkFunTys )
  36 import TyCon            ( isDataTyCon )
  37 import TysPrim          ( voidTy )
  38 import Util             ( Eager, runEager, appEager,
  39                           isIn, isSingleton, zipEqual, panic, assertPanic )
  40 \end{code}
  41
  42 Float let out of case.
  43
  44 \begin{code}
  45 simplCase :: SimplEnv
  46           -> InExpr     -- Scrutinee
  47           -> InAlts     -- Alternatives
  48           -> (SimplEnv -> InExpr -> SmplM OutExpr)      -- Rhs handler
  49           -> OutType                                    -- Type of result expression
  50           -> SmplM OutExpr
  51
  52 simplCase env (Let bind body) alts rhs_c result_ty
  53   | not (switchIsSet env SimplNoLetFromCase)
  54   =     -- Float the let outside the case scrutinee (if not disabled by flag)
  55     tick LetFloatFromCase               `thenSmpl_`
  56     simplBind env bind (\env -> simplCase env body alts rhs_c result_ty) result_ty
  57 \end{code}
  58
  59 OK to do case-of-case if
  60
  61 * we allow arbitrary code duplication
  62
  63 OR
  64
  65 * the inner case has one alternative
  66         case (case e of (a,b) -> rhs) of
  67          ...
  68          pi -> rhsi
  69          ...
  70   ===>
  71         case e of
  72           (a,b) -> case rhs of
  73                         ...
  74                         pi -> rhsi
  75                         ...
  76
  77 IF neither of these two things are the case, we avoid code-duplication
  78 by abstracting the outer rhss wrt the pattern variables.  For example
  79
  80         case (case e of { p1->rhs1; ...; pn -> rhsn }) of
  81           (x,y) -> body
  82 ===>
  83         let b = \ x y -> body
  84         in
  85         case e of
  86           p1 -> case rhs1 of (x,y) -> b x y
  87           ...
  88           pn -> case rhsn of (x,y) -> b x y
  89
  90
  91 OK, so outer case expression gets duplicated, but that's all.  Furthermore,
  92   (a) the binding for "b" will be let-no-escaped, so no heap allocation
  93         will take place; the "call" to b will simply be a stack adjustment
  94         and a jump
  95   (b) very commonly, at least some of the rhsi's will be constructors, which
  96         makes life even simpler.
  97
  98 All of this works equally well if the outer case has multiple rhss.
  99
 100
 101 \begin{code}
 102 simplCase env (Case inner_scrut inner_alts) outer_alts rhs_c result_ty
 103   | switchIsSet env SimplCaseOfCase
 104   =     -- Ha!  Do case-of-case
 105     tick CaseOfCase     `thenSmpl_`
 106
 107     if no_need_to_bind_large_alts
 108     then
 109         simplCase env inner_scrut inner_alts
 110                   (\env rhs -> simplCase env rhs outer_alts rhs_c result_ty) result_ty
 111     else
 112         bindLargeAlts env outer_alts rhs_c result_ty    `thenSmpl` \ (extra_bindings, outer_alts') ->
 113         let
 114            rhs_c' = \env rhs -> simplExpr env rhs [] result_ty
 115         in
 116         simplCase env inner_scrut inner_alts
 117                   (\env rhs -> simplCase env rhs outer_alts' rhs_c' result_ty)
 118                   result_ty
 119                                                 `thenSmpl` \ case_expr ->
 120         returnSmpl (mkCoLetsNoUnboxed extra_bindings case_expr)
 121
 122   where
 123     no_need_to_bind_large_alts = switchIsSet env SimplOkToDupCode ||
 124                                  isSingleton (nonErrorRHSs inner_alts)
 125 \end{code}
 126
 127 Case of an application of error.
 128
 129 \begin{code}
 130 simplCase env scrut alts rhs_c result_ty
 131   | maybeToBool maybe_error_app
 132   =     -- Look for an application of an error id
 133     tick CaseOfError    `thenSmpl_`
 134     simplExpr env retyped_error_app [] result_ty
 135                 -- Ignore rhs_c!
 136                 -- We must apply simplExpr because "rhs" isn't yet simplified.
 137                 -- The ice is a little thin because body_ty is an OutType; but it's ok really
 138   where
 139     maybe_error_app        = maybeErrorApp scrut (Just result_ty)
 140     Just retyped_error_app = maybe_error_app
 141 \end{code}
 142
 143 Finally the default case
 144
 145 \begin{code}
 146 simplCase env other_scrut alts rhs_c result_ty
 147   = simplTy env scrut_ty                        `appEager` \ scrut_ty' ->
 148     simplExpr env' other_scrut [] scrut_ty      `thenSmpl` \ scrut' ->
 149     completeCase env scrut' alts rhs_c
 150   where
 151         -- When simplifying the scrutinee of a complete case that
 152         -- has no default alternative
 153     env' = case alts of
 154                 AlgAlts _ NoDefault  -> setCaseScrutinee env
 155                 PrimAlts _ NoDefault -> setCaseScrutinee env
 156                 other                -> env
 157
 158     scrut_ty = coreExprType (unTagBinders other_scrut)
 159 \end{code}
 160
 161
 162 %************************************************************************
 163 %*                                                                      *
 164 \subsection[Simplify-case]{Completing case-expression simplification}
 165 %*                                                                      *
 166 %************************************************************************
 167
 168 \begin{code}
 169 completeCase
 170         :: SimplEnv
 171         -> OutExpr                                      -- The already-simplified scrutinee
 172         -> InAlts                                       -- The un-simplified alternatives
 173         -> (SimplEnv -> InExpr -> SmplM OutExpr)        -- Rhs handler
 174         -> SmplM OutExpr        -- The whole case expression
 175 \end{code}
 176
 177 Scrutinising a literal or constructor.
 178 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 179 It's an obvious win to do:
 180
 181         case (C a b) of {...; C p q -> rhs; ...}  ===>   rhs[a/p,b/q]
 182
 183 and the similar thing for primitive case.  If we have
 184
 185         case x of ...
 186
 187 and x is known to be of constructor form, then we'll already have
 188 inlined the constructor to give (case (C a b) of ...), so we don't
 189 need to check for the variable case separately.
 190
 191 Sanity check: we don't have a good
 192 story to tell about case analysis on NoRep things.  ToDo.
 193
 194 \begin{code}
 195 completeCase env (Lit lit) alts rhs_c
 196   | not (isNoRepLit lit)
 197   =     -- Ha!  Select the appropriate alternative
 198     tick KnownBranch            `thenSmpl_`
 199     completePrimCaseWithKnownLit env lit alts rhs_c
 200
 201 completeCase env expr@(Con con con_args) alts rhs_c
 202   =     -- Ha! Staring us in the face -- select the appropriate alternative
 203     tick KnownBranch            `thenSmpl_`
 204     completeAlgCaseWithKnownCon env con con_args alts rhs_c
 205 \end{code}
 206
 207 Case elimination
 208 ~~~~~~~~~~~~~~~~
 209 Start with a simple situation:
 210
 211         case x# of      ===>   e[x#/y#]
 212           y# -> e
 213
 214 (when x#, y# are of primitive type, of course).
 215 We can't (in general) do this for algebraic cases, because we might
 216 turn bottom into non-bottom!
 217
 218 Actually, we generalise this idea to look for a case where we're
 219 scrutinising a variable, and we know that only the default case can
 220 match.  For example:
 221 \begin{verbatim}
 222         case x of
 223           0#    -> ...
 224           other -> ...(case x of
 225                          0#    -> ...
 226                          other -> ...) ...
 227 \end{code}
 228 Here the inner case can be eliminated.  This really only shows up in
 229 eliminating error-checking code.
 230
 231 Lastly, we generalise the transformation to handle this:
 232
 233         case e of       ===> r
 234            True  -> r
 235            False -> r
 236
 237 We only do this for very cheaply compared r's (constructors, literals
 238 and variables).  If pedantic bottoms is on, we only do it when the
 239 scrutinee is a PrimOp which can't fail.
 240
 241 We do it *here*, looking at un-simplified alternatives, because we
 242 have to check that r doesn't mention the variables bound by the
 243 pattern in each alternative, so the binder-info is rather useful.
 244
 245 So the case-elimination algorithm is:
 246
 247         1. Eliminate alternatives which can't match
 248
 249         2. Check whether all the remaining alternatives
 250                 (a) do not mention in their rhs any of the variables bound in their pattern
 251            and  (b) have equal rhss
 252
 253         3. Check we can safely ditch the case:
 254                    * PedanticBottoms is off,
 255                 or * the scrutinee is an already-evaluated variable
 256                 or * the scrutinee is a primop which is ok for speculation
 257                         -- ie we want to preserve divide-by-zero errors, and
 258                         -- calls to error itself!
 259
 260                 or * [Prim cases] the scrutinee is a primitive variable
 261
 262                 or * [Alg cases] the scrutinee is a variable and
 263                      either * the rhs is the same variable
 264                         (eg case x of C a b -> x  ===>   x)
 265                      or     * there is only one alternative, the default alternative,
 266                                 and the binder is used strictly in its scope.
 267                                 [NB this is helped by the "use default binder where
 268                                  possible" transformation; see below.]
 269
 270
 271 If so, then we can replace the case with one of the rhss.
 272
 273 \begin{code}
 274 completeCase env scrut alts rhs_c
 275   | switchIsSet env SimplDoCaseElim &&
 276
 277     binders_unused &&
 278
 279     all_rhss_same &&
 280
 281     (not  (switchIsSet env SimplPedanticBottoms) ||
 282      scrut_is_evald ||
 283      scrut_is_eliminable_primitive ||
 284      rhs1_is_scrutinee ||
 285      scrut_is_var_and_single_strict_default
 286      )
 287
 288   = tick CaseElim       `thenSmpl_`
 289     rhs_c new_env rhs1
 290   where
 291         -- Find the non-excluded rhss of the case; always at least one
 292     (rhs1:rhss)   = possible_rhss
 293     all_rhss_same = all (cheap_eq rhs1) rhss
 294
 295         -- Find the reduced set of possible rhss, along with an indication of
 296         -- whether none of their binders are used
 297     (binders_unused, possible_rhss, new_env)
 298       = case alts of
 299           PrimAlts alts deflt -> (deflt_binder_unused,  -- No binders other than deflt
 300                                     deflt_rhs ++ rhss,
 301                                     new_env)
 302             where
 303               (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
 304
 305                 -- Eliminate unused rhss if poss
 306               rhss = case scrut_form of
 307                         OtherLit not_these -> [rhs | (alt_lit,rhs) <- alts,
 308                                                      not (alt_lit `is_elem` not_these)
 309                                               ]
 310                         other -> [rhs | (_,rhs) <- alts]
 311
 312           AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
 313                                    deflt_rhs ++ [rhs | (_,_,rhs) <- possible_alts],
 314                                    new_env)
 315             where
 316               (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
 317
 318                 -- Eliminate unused alts if poss
 319               possible_alts = case scrut_form of
 320                                 OtherCon not_these ->
 321                                                 -- Remove alts which can't match
 322                                         [alt | alt@(alt_con,_,_) <- alts,
 323                                                not (alt_con `is_elem` not_these)]
 324
 325                                 other -> alts
 326
 327               alt_binders_unused (con, args, rhs) = all is_dead args
 328               is_dead (_, DeadCode) = True
 329               is_dead other_arg     = False
 330
 331         -- If the scrutinee is a variable, look it up to see what we know about it
 332     scrut_form = case scrut of
 333                   Var v -> lookupUnfolding env v
 334                   other -> NoUnfolding
 335
 336         -- If the scrut is already eval'd then there's no worry about
 337         -- eliminating the case
 338     scrut_is_evald = isEvaluated scrut_form
 339
 340     scrut_is_eliminable_primitive
 341       = case scrut of
 342            Prim op _ -> primOpOkForSpeculation op
 343            Var _     -> case alts of
 344                           PrimAlts _ _ -> True  -- Primitive, hence non-bottom
 345                           AlgAlts _ _  -> False -- Not primitive
 346            other     -> False
 347
 348         -- case v of w -> e{strict in w}  ===>   e[v/w]
 349     scrut_is_var_and_single_strict_default
 350       = case scrut of
 351           Var _ -> case alts of
 352                         AlgAlts [] (BindDefault (v,_) _) -> willBeDemanded (getIdDemandInfo v)
 353                         other -> False
 354           other -> False
 355
 356     elim_deflt_binder NoDefault                          -- No Binder
 357         = (True, [], env)
 358     elim_deflt_binder (BindDefault (id, DeadCode) rhs) -- Binder unused
 359         = (True, [rhs], env)
 360     elim_deflt_binder (BindDefault used_binder rhs)      -- Binder used
 361         = case scrut of
 362                 Var v ->        -- Binder used, but can be eliminated in favour of scrut
 363                            (True, [rhs], bindIdToAtom env used_binder (VarArg v))
 364                 non_var ->      -- Binder used, and can't be elimd
 365                            (False, [rhs], env)
 366
 367         -- Check whether the chosen unique rhs (ie rhs1) is the same as
 368         -- the scrutinee.  Remember that the rhs is as yet unsimplified.
 369     rhs1_is_scrutinee = case (scrut, rhs1) of
 370                           (Var scrut_var, Var rhs_var)
 371                                 -> case (lookupIdSubst env rhs_var) of
 372                                     Nothing                  -> rhs_var  == scrut_var
 373                                     Just (SubstVar rhs_var') -> rhs_var' == scrut_var
 374                                     other                    -> False
 375                           other -> False
 376
 377     is_elem x ys = isIn "completeCase" x ys
 378 \end{code}
 379
 380 Scrutinising anything else.  If it's a variable, it can't be bound to a
 381 constructor or literal, because that would have been inlined
 382
 383 \begin{code}
 384 completeCase env scrut alts rhs_c
 385   = simplAlts env scrut alts rhs_c      `thenSmpl` \ alts' ->
 386     mkCoCase env scrut alts'
 387 \end{code}
 388
 389
 390
 391
 392 \begin{code}
 393 bindLargeAlts :: SimplEnv
 394               -> InAlts
 395               -> (SimplEnv -> InExpr -> SmplM OutExpr)          -- Old rhs handler
 396               -> OutType                                        -- Result type
 397               -> SmplM ([OutBinding],   -- Extra bindings
 398                         InAlts)         -- Modified alts
 399
 400 bindLargeAlts env the_lot@(AlgAlts alts deflt) rhs_c rhs_ty
 401   = mapAndUnzipSmpl do_alt alts                 `thenSmpl` \ (alt_bindings, alts') ->
 402     bindLargeDefault env deflt rhs_ty rhs_c     `thenSmpl` \ (deflt_bindings, deflt') ->
 403     returnSmpl (deflt_bindings ++ alt_bindings, AlgAlts alts' deflt')
 404   where
 405     do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty
 406                                 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
 407                             returnSmpl (bind, (con,args,rhs'))
 408
 409 bindLargeAlts env the_lot@(PrimAlts alts deflt) rhs_c rhs_ty
 410   = mapAndUnzipSmpl do_alt alts                 `thenSmpl` \ (alt_bindings, alts') ->
 411     bindLargeDefault env deflt rhs_ty rhs_c     `thenSmpl` \ (deflt_bindings, deflt') ->
 412     returnSmpl (deflt_bindings ++ alt_bindings, PrimAlts alts' deflt')
 413   where
 414     do_alt (lit,rhs) = bindLargeRhs env [] rhs_ty
 415                                 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
 416                        returnSmpl (bind, (lit,rhs'))
 417
 418 bindLargeDefault env NoDefault rhs_ty rhs_c
 419   = returnSmpl ([], NoDefault)
 420 bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c
 421   = bindLargeRhs env [binder] rhs_ty
 422                  (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
 423     returnSmpl ([bind], BindDefault binder rhs')
 424 \end{code}
 425
 426         bindLargeRhs env [x1,..,xn] rhs rhs_ty rhs_c
 427          | otherwise        = (rhs_id = \x1..xn -> rhs_c rhs,
 428                                rhs_id x1 .. xn)
 429
 430 \begin{code}
 431 bindLargeRhs :: SimplEnv
 432              -> [InBinder]      -- The args wrt which the rhs should be abstracted
 433              -> OutType
 434              -> (SimplEnv -> SmplM OutExpr)             -- Rhs handler
 435              -> SmplM (OutBinding,      -- New bindings (singleton or empty)
 436                        InExpr)          -- Modified rhs
 437
 438 bindLargeRhs env args rhs_ty rhs_c
 439   | null used_args && isUnpointedType rhs_ty
 440         -- If we try to lift a primitive-typed something out
 441         -- for let-binding-purposes, we will *caseify* it (!),
 442         -- with potentially-disastrous strictness results.  So
 443         -- instead we turn it into a function: \v -> e
 444         -- where v::Void.  Since arguments of type
 445         -- VoidPrim don't generate any code, this gives the
 446         -- desired effect.
 447         --
 448         -- The general structure is just the same as for the common "otherwise~ case
 449   = newId prim_rhs_fun_ty       `thenSmpl` \ prim_rhs_fun_id ->
 450     newId voidTy                `thenSmpl` \ void_arg_id ->
 451     rhs_c env                   `thenSmpl` \ prim_new_body ->
 452
 453     returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
 454                 App (Var prim_rhs_fun_id) (VarArg voidId))
 455
 456   | otherwise
 457   =     -- Generate the rhs
 458     simplBinders env used_args  `thenSmpl` \ (new_env, used_args') ->
 459     let
 460         rhs_fun_ty :: OutType
 461         rhs_fun_ty = mkFunTys (map idType used_args') rhs_ty
 462     in
 463
 464         -- Make the new binding Id.  NB: it's an OutId
 465     newId rhs_fun_ty            `thenSmpl` \ rhs_fun_id ->
 466     rhs_c new_env               `thenSmpl` \ rhs' ->
 467     let
 468         final_rhs = mkValLam used_args' rhs'
 469     in
 470     returnSmpl (NonRec rhs_fun_id final_rhs,
 471                 foldl App (Var rhs_fun_id) used_arg_atoms)
 472         -- This is slightly wierd. We're retuning an OutId as part of the
 473         -- modified rhs, which is meant to be an InExpr. However, that's ok, because when
 474         -- it's processed the OutId won't be found in the environment, so it
 475         -- will be left unmodified.
 476   where
 477
 478     used_args      = [arg | arg@(_,usage) <- args, not (dead usage)]
 479     used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
 480     dead DeadCode  = True
 481     dead other     = False
 482
 483     prim_rhs_fun_ty = mkFunTy voidTy rhs_ty
 484 \end{code}
 485
 486 Case alternatives when we don't know the scrutinee
 487 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 488
 489 A special case for case default.  If we have
 490 \begin{verbatim}
 491 case x of
 492   p1 -> e1
 493   y  -> default_e
 494 \end{verbatim}
 495 it is best to make sure that \tr{default_e} mentions \tr{x} in
 496 preference to \tr{y}.  The code generator can do a cheaper job if it
 497 doesn't have to come up with a binding for \tr{y}.
 498
 499 \begin{code}
 500 simplAlts :: SimplEnv
 501           -> OutExpr                    -- Simplified scrutinee;
 502                                         -- only of interest if its a var,
 503                                         -- in which case we record its form
 504           -> InAlts
 505           -> (SimplEnv -> InExpr -> SmplM OutExpr)      -- Rhs handler
 506           -> SmplM OutAlts
 507 -- For single-constructor types
 508 --      case e of y -> b    ===>   case e of (a,b) -> let y = (a,b) in b
 509
 510 simplAlts env scrut (AlgAlts [] (BindDefault bndr@(id,occ_info) rhs)) rhs_c
 511   | maybeToBool maybe_data_ty &&
 512     not (null cons)           && -- Not an abstract type (can arise if we're pruning tydecl imports)
 513     null other_cons           &&
 514     isDataTyCon tycon  -- doesn't apply to (constructor-less) newtypes
 515   = newIds inst_con_arg_tys     `thenSmpl` \ new_bindees ->
 516     let
 517         new_args = [ (b, bad_occ_info) | b <- new_bindees ]
 518         con_app  = mkCon con ty_args (map VarArg new_bindees)
 519         new_rhs  = Let (NonRec bndr con_app) rhs
 520     in
 521     simplAlts env scrut (AlgAlts [(con,new_args,new_rhs)] NoDefault) rhs_c
 522   where
 523     maybe_data_ty               = splitAlgTyConApp_maybe (idType id)
 524     Just (tycon, ty_args, cons) = maybe_data_ty
 525     (con:other_cons)            = cons
 526     inst_con_arg_tys            = dataConArgTys con ty_args
 527     bad_occ_info                = ManyOcc 0     -- Non-committal!
 528
 529 simplAlts env scrut (AlgAlts alts deflt) rhs_c
 530   = mapSmpl do_alt alts                                 `thenSmpl` \ alts' ->
 531     simplDefault env scrut deflt deflt_form rhs_c       `thenSmpl` \ deflt' ->
 532     returnSmpl (AlgAlts alts' deflt')
 533   where
 534     deflt_form = OtherCon [con | (con,_,_) <- alts]
 535     do_alt (con, con_args, rhs)
 536       = simplBinders env con_args                               `thenSmpl` \ (env1, con_args') ->
 537         let
 538             new_env = case scrut of
 539                        Var v -> extendEnvGivenNewRhs env1 v (Con con args)
 540                              where
 541                                 (_, ty_args, _) = splitAlgTyConApp (idType v)
 542                                 args = map TyArg ty_args ++ map VarArg con_args'
 543
 544                        other -> env1
 545         in
 546         rhs_c new_env rhs                               `thenSmpl` \ rhs' ->
 547         returnSmpl (con, con_args', rhs')
 548
 549 simplAlts env scrut (PrimAlts alts deflt) rhs_c
 550   = mapSmpl do_alt alts                                 `thenSmpl` \ alts' ->
 551     simplDefault env scrut deflt deflt_form rhs_c       `thenSmpl` \ deflt' ->
 552     returnSmpl (PrimAlts alts' deflt')
 553   where
 554     deflt_form = OtherLit [lit | (lit,_) <- alts]
 555     do_alt (lit, rhs)
 556       = let
 557             new_env = case scrut of
 558                         Var v -> extendEnvGivenNewRhs env v (Lit lit)
 559                         other -> env
 560         in
 561         rhs_c new_env rhs                               `thenSmpl` \ rhs' ->
 562         returnSmpl (lit, rhs')
 563 \end{code}
 564
 565 Use default binder where possible
 566 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 567 There's one complication when simplifying the default clause of
 568 a case expression.  If we see
 569
 570         case x of
 571           x' -> ...x...x'...
 572
 573 we'd like to convert it to
 574
 575         case x of
 576           x' -> ...x'...x'...
 577
 578 Reason 1: then there might be just one occurrence of x, and it can be
 579 inlined as the case scrutinee.  So we spot this case when dealing with
 580 the default clause, and add a binding to the environment mapping x to
 581 x'.
 582
 583 Reason 2: if the body is strict in x' then we can eliminate the
 584 case altogether. By using x' in preference to x we give the max chance
 585 of the strictness analyser finding that the body is strict in x'.
 586
 587 On the other hand, if x does *not* get inlined, then we'll actually
 588 get somewhat better code from the former expression.  So when
 589 doing Core -> STG we convert back!
 590
 591 \begin{code}
 592 simplDefault
 593         :: SimplEnv
 594         -> OutExpr                      -- Simplified scrutinee
 595         -> InDefault                    -- Default alternative to be completed
 596         -> Unfolding                    -- Gives form of scrutinee
 597         -> (SimplEnv -> InExpr -> SmplM OutExpr)                -- Old rhs handler
 598         -> SmplM OutDefault
 599
 600 simplDefault env scrut NoDefault form rhs_c
 601   = returnSmpl NoDefault
 602
 603 -- Special case for variable scrutinee; see notes above.
 604 simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs)
 605              info_from_this_case rhs_c
 606   = simplBinder env binder      `thenSmpl` \ (env1, binder') ->
 607     let
 608       env2    = extendEnvGivenUnfolding env1 binder' occ_info info_from_this_case
 609
 610         -- Add form details for the default binder
 611       scrut_info = lookupUnfolding env scrut_var
 612       env3       = extendEnvGivenUnfolding env2 binder' occ_info scrut_info
 613       new_env    = extendEnvGivenNewRhs env3 scrut_var (Var binder')
 614     in
 615     rhs_c new_env rhs                   `thenSmpl` \ rhs' ->
 616     returnSmpl (BindDefault binder' rhs')
 617
 618 simplDefault env scrut (BindDefault binder@(_,occ_info) rhs)
 619              info_from_this_case rhs_c
 620   = simplBinder env binder      `thenSmpl` \ (env1, binder') ->
 621     let
 622         new_env = extendEnvGivenUnfolding env1 binder' occ_info info_from_this_case
 623     in
 624     rhs_c new_env rhs                   `thenSmpl` \ rhs' ->
 625     returnSmpl (BindDefault binder' rhs')
 626 \end{code}
 627
 628 Case alternatives when we know what the scrutinee is
 629 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 630
 631 \begin{code}
 632 completePrimCaseWithKnownLit
 633         :: SimplEnv
 634         -> Literal
 635         -> InAlts
 636         -> (SimplEnv -> InExpr -> SmplM OutExpr)        -- Rhs handler
 637         -> SmplM OutExpr
 638
 639 completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c
 640   = search_alts alts
 641   where
 642     search_alts :: [(Literal, InExpr)] -> SmplM OutExpr
 643
 644     search_alts ((alt_lit, rhs) : _)
 645       | alt_lit == lit
 646       =         -- Matching alternative!
 647         rhs_c env rhs
 648
 649     search_alts (_ : other_alts)
 650       =         -- This alternative doesn't match; keep looking
 651         search_alts other_alts
 652
 653     search_alts []
 654       = case deflt of
 655           NoDefault      ->     -- Blargh!
 656             panic "completePrimCaseWithKnownLit: No matching alternative and no default"
 657
 658           BindDefault binder rhs ->     -- OK, there's a default case
 659                                         -- Just bind the Id to the atom and continue
 660             let
 661                 new_env = bindIdToAtom env binder (LitArg lit)
 662             in
 663             rhs_c new_env rhs
 664 \end{code}
 665
 666 @completeAlgCaseWithKnownCon@: We know the constructor, so we can
 667 select one case alternative (or default).  If we choose the default:
 668 we do different things depending on whether the constructor was
 669 staring us in the face (e.g., \tr{case (p:ps) of {y -> ...}})
 670 [let-bind it] or we just know the \tr{y} is now the same as some other
 671 var [substitute \tr{y} out of existence].
 672
 673 \begin{code}
 674 completeAlgCaseWithKnownCon
 675         :: SimplEnv
 676         -> DataCon -> [InArg]
 677                 -- Scrutinee is (con, type, value arguments)
 678         -> InAlts
 679         -> (SimplEnv -> InExpr -> SmplM OutExpr)        -- Rhs handler
 680         -> SmplM OutExpr
 681
 682 completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
 683   = ASSERT(isDataCon con)
 684     search_alts alts
 685   where
 686     search_alts :: [(Id, [InBinder], InExpr)] -> SmplM OutExpr
 687
 688     search_alts ((alt_con, alt_args, rhs) : _)
 689       | alt_con == con
 690       =         -- Matching alternative!
 691         let
 692             val_args = filter isValArg con_args
 693             new_env  = foldr bind env (zipEqual "SimplCase" alt_args val_args)
 694             bind (bndr, atom) env = bindIdToAtom env bndr atom
 695         in
 696         rhs_c new_env rhs
 697
 698     search_alts (_ : other_alts)
 699       =         -- This alternative doesn't match; keep looking
 700         search_alts other_alts
 701
 702     search_alts []
 703       =         -- No matching alternative
 704         case deflt of
 705           NoDefault      ->     -- Blargh!
 706             panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
 707
 708           BindDefault binder@(_,occ_info) rhs ->        -- OK, there's a default case
 709                         -- let-bind the binder to the constructor
 710                 simplBinder env binder          `thenSmpl` \ (env1, id') ->
 711                 let
 712                     new_env = extendEnvGivenBinding env1 occ_info id' (Con con con_args)
 713                 in
 714                 rhs_c new_env rhs               `thenSmpl` \ rhs' ->
 715                 returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
 716 \end{code}
 717
 718 Case absorption and identity-case elimination
 719 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 720
 721 \begin{code}
 722 mkCoCase :: SimplEnv -> OutExpr -> OutAlts -> SmplM OutExpr
 723 \end{code}
 724
 725 @mkCoCase@ tries the following transformation (if possible):
 726
 727 case v of                 ==>   case v of
 728   p1 -> rhs1                      p1 -> rhs1
 729   ...                             ...
 730   pm -> rhsm                      pm -> rhsm
 731   d  -> case v of                 pn -> rhsn[v/d]  {or (alg)  let d=v in rhsn}
 732                                                    {or (prim) case v of d -> rhsn}
 733           pn -> rhsn              ...
 734           ...                     po -> rhso[v/d]
 735           po -> rhso              d  -> rhsd[d/d'] {or let d'=d in rhsd}
 736           d' -> rhsd
 737
 738 which merges two cases in one case when -- the default alternative of
 739 the outer case scrutises the same variable as the outer case This
 740 transformation is called Case Merging.  It avoids that the same
 741 variable is scrutinised multiple times.
 742
 743 There's a closely-related transformation:
 744
 745 case e of                 ==>   case e of
 746   p1 -> rhs1                      p1 -> rhs1
 747   ...                             ...
 748   pm -> rhsm                      pm -> rhsm
 749   d  -> case d of                 pn -> let d = pn in rhsn
 750           pn -> rhsn              ...
 751           ...                     po -> let d = po in rhso
 752           po -> rhso              d  -> rhsd[d/d'] {or let d'=d in rhsd}
 753           d' -> rhsd
 754
 755 Here, the let's are essential, because d isn't in scope any more.
 756 Sigh.  Of course, they may be unused, in which case they'll be
 757 eliminated on the next round.  Unfortunately, we can't figure out
 758 whether or not they are used at this juncture.
 759
 760 NB: The binder in a BindDefault USED TO BE guaranteed unused if the
 761 scrutinee is a variable, because it'll be mapped to the scrutinised
 762 variable.  Hence the [v/d] substitions can be omitted.
 763
 764 ALAS, now the default binder is used by preference, so we have to
 765 generate trivial lets to express the substitutions, which will be
 766 eliminated on the next pass.
 767
 768 The following code handles *both* these transformations (one
 769 equation for AlgAlts, one for PrimAlts):
 770
 771 \begin{code}
 772 mkCoCase env scrut (AlgAlts outer_alts
 773                           (BindDefault deflt_var
 774                                          (Case (Var scrut_var')
 775                                                  (AlgAlts inner_alts inner_deflt))))
 776   |  switchIsSet env SimplCaseMerge &&
 777      ((scrut_is_var && scrut_var == scrut_var') ||      -- First transformation
 778       deflt_var == scrut_var')                          -- Second transformation
 779   =     -- Aha! The default-absorption rule applies
 780     tick CaseMerge      `thenSmpl_`
 781     returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
 782                              (munge_alg_deflt deflt_var inner_deflt)))
 783         -- NB: see comment in this location for the PrimAlts case
 784   where
 785         -- Check scrutinee
 786     scrut_is_var = case scrut of {Var v -> True; other -> False}
 787     scrut_var    = case scrut of Var v -> v
 788
 789         --  Eliminate any inner alts which are shadowed by the outer ones
 790     reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
 791                                 not (con `is_elem` outer_cons)]
 792     outer_cons = [con | (con,_,_) <- outer_alts]
 793     is_elem = isIn "mkAlgAlts"
 794
 795         -- Add the lets if necessary
 796     munged_reduced_inner_alts = map munge_alt reduced_inner_alts
 797
 798     munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
 799        where
 800          v | scrut_is_var = Var scrut_var
 801            | otherwise    = Con con (map TyArg arg_tys ++ map VarArg args)
 802
 803     arg_tys = case (splitAlgTyConApp (idType deflt_var)) of
 804                 (_, arg_tys, _) -> arg_tys
 805
 806 mkCoCase env scrut (PrimAlts
 807                   outer_alts
 808                   (BindDefault deflt_var (Case
 809                                               (Var scrut_var')
 810                                               (PrimAlts inner_alts inner_deflt))))
 811   |  switchIsSet env SimplCaseMerge &&
 812      ((scrut_is_var && scrut_var == scrut_var') ||
 813       deflt_var == scrut_var')
 814   =     -- Aha! The default-absorption rule applies
 815     tick CaseMerge      `thenSmpl_`
 816     returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
 817                              (munge_prim_deflt deflt_var inner_deflt)))
 818
 819         -- Nota Bene: we don't recurse to mkCoCase again, because the
 820         -- default will now have a binding in it that prevents
 821         -- mkCoCase doing anything useful.  Much worse, in this
 822         -- PrimAlts case the binding in the default branch is another
 823         -- Case, so if we recurse to mkCoCase we will get into an
 824         -- infinite loop.
 825         --
 826         -- ToDo: think of a better way to do this.  At the moment
 827         -- there is at most one case merge per round.  That's probably
 828         -- plenty but it seems unclean somehow.
 829   where
 830         -- Check scrutinee
 831     scrut_is_var = case scrut of {Var v -> True; other -> False}
 832     scrut_var    = case scrut of Var v -> v
 833
 834         --  Eliminate any inner alts which are shadowed by the outer ones
 835     reduced_inner_alts = [alt | alt@(lit,_) <- inner_alts,
 836                                 not (lit `is_elem` outer_lits)]
 837     outer_lits = [lit | (lit,_) <- outer_alts]
 838     is_elem = isIn "mkPrimAlts"
 839
 840         -- Add the lets (well cases actually) if necessary
 841         -- The munged alternative looks like
 842         --      lit -> case lit of d -> rhs
 843         -- The next pass will certainly eliminate the inner case, but
 844         -- it isn't easy to do so right away.
 845     munged_reduced_inner_alts = map munge_alt reduced_inner_alts
 846
 847     munge_alt (lit, rhs)
 848       | scrut_is_var = (lit, Case (Var scrut_var)
 849                                     (PrimAlts [] (BindDefault deflt_var rhs)))
 850       | otherwise = (lit, Case (Lit lit)
 851                                  (PrimAlts [] (BindDefault deflt_var rhs)))
 852 \end{code}
 853
 854 Now the identity-case transformation:
 855
 856         case e of               ===> e
 857                 True -> True;
 858                 False -> False
 859
 860 and similar friends.
 861
 862 \begin{code}
 863 mkCoCase env scrut alts
 864   | identity_alts alts
 865   = tick CaseIdentity           `thenSmpl_`
 866     returnSmpl scrut
 867   where
 868     identity_alts (AlgAlts alts deflt)  = all identity_alg_alt  alts && identity_deflt deflt
 869     identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
 870
 871     identity_alg_alt (con, args, Con con' args')
 872          = con == con'
 873            && and (zipWith eq_arg args args')
 874            && length args == length args'
 875     identity_alg_alt other
 876          = False
 877
 878     identity_prim_alt (lit, Lit lit') = lit == lit'
 879     identity_prim_alt other            = False
 880
 881          -- For the default case we want to spot both
 882          --     x -> x
 883          -- and
 884          --     case y of { ... ; x -> y }
 885          -- as "identity" defaults
 886     identity_deflt NoDefault = True
 887     identity_deflt (BindDefault binder (Var x)) = x == binder ||
 888                                                       case scrut of
 889                                                          Var y -> y == x
 890                                                          other   -> False
 891     identity_deflt _ = False
 892
 893     eq_arg binder (VarArg x) = binder == x
 894     eq_arg _      _            = False
 895 \end{code}
 896
 897 The catch-all case
 898
 899 \begin{code}
 900 mkCoCase env other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
 901 \end{code}
 902
 903 Boring local functions used above.  They simply introduce a trivial binding
 904 for the binder, d', in an inner default; either
 905         let d' = deflt_var in rhs
 906 or
 907         case deflt_var of d' -> rhs
 908 depending on whether it's an algebraic or primitive case.
 909
 910 \begin{code}
 911 munge_prim_deflt _ NoDefault = NoDefault
 912
 913 munge_prim_deflt deflt_var (BindDefault d' rhs)
 914   =   BindDefault deflt_var (Case (Var deflt_var)
 915                                       (PrimAlts [] (BindDefault d' rhs)))
 916
 917 munge_alg_deflt _ NoDefault = NoDefault
 918
 919 munge_alg_deflt deflt_var (BindDefault d' rhs)
 920   =   BindDefault deflt_var (Let (NonRec d' (Var deflt_var)) rhs)
 921
 922 -- This line caused a generic version of munge_deflt (ie one used for
 923 -- both alg and prim) to space leak massively.  No idea why.
 924 --  = BindDefault deflt_var (mkCoLetUnboxedToCase (NonRec d' (Var deflt_var)) rhs)
 925 \end{code}
 926
 927 \begin{code}
 928 cheap_eq :: InExpr -> InExpr -> Bool
 929         -- A cheap equality test which bales out fast!
 930
 931 cheap_eq (Var v1) (Var v2) = v1==v2
 932 cheap_eq (Lit l1) (Lit l2) = l1==l2
 933 cheap_eq (Con con1 args1) (Con con2 args2)
 934   = con1 == con2 && args1 `eq_args` args2
 935
 936 cheap_eq (Prim op1 args1) (Prim op2 args2)
 937   = op1 ==op2 && args1 `eq_args` args2
 938
 939 cheap_eq (App f1 a1) (App f2 a2)
 940   = f1 `cheap_eq` f2 && a1 `eq_arg` a2
 941
 942 cheap_eq _ _ = False
 943
 944 -- ToDo: make CoreArg an instance of Eq
 945 eq_args (a1:as1) (a2:as2) = a1 `eq_arg` a2 && as1 `eq_args` as2
 946 eq_args []       []       = True
 947 eq_args _        _        = False
 948
 949 eq_arg (LitArg   l1) (LitArg   l2) = l1 == l2
 950 eq_arg (VarArg   v1) (VarArg   v2) = v1 == v2
 951 eq_arg (TyArg    t1) (TyArg    t2) = t1 == t2
 952 eq_arg _             _             =  False
 953 \end{code}