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