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 = extendEnvGivenNewRhs env1 scrut_var (Var binder')
 614
 615         -- Add form details for the default binder
 616       scrut_unf = lookupUnfolding env scrut_var
 617       new_env   = extendEnvGivenUnfolding env2 binder' noBinderInfo scrut_unf
 618                         -- Use noBinderInfo rather than occ_info because we've
 619                         -- added more occurrences by binding the scrut_var to it
 620     in
 621     rhs_c new_env rhs                   `thenSmpl` \ rhs' ->
 622     returnSmpl (BindDefault binder' rhs')
 623
 624 simplDefault env scrut (BindDefault binder@(_,occ_info) rhs)
 625              info_from_this_case rhs_c
 626   = simplBinder env binder      `thenSmpl` \ (env1, binder') ->
 627     let
 628         new_env = extendEnvGivenUnfolding env1 binder' occ_info info_from_this_case
 629     in
 630     rhs_c new_env rhs                   `thenSmpl` \ rhs' ->
 631     returnSmpl (BindDefault binder' rhs')
 632 \end{code}
 633
 634 Case alternatives when we know what the scrutinee is
 635 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 636
 637 \begin{code}
 638 completePrimCaseWithKnownLit
 639         :: SimplEnv
 640         -> Literal
 641         -> InAlts
 642         -> (SimplEnv -> InExpr -> SmplM OutExpr)        -- Rhs handler
 643         -> SmplM OutExpr
 644
 645 completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c
 646   = search_alts alts
 647   where
 648     search_alts :: [(Literal, InExpr)] -> SmplM OutExpr
 649
 650     search_alts ((alt_lit, rhs) : _)
 651       | alt_lit == lit
 652       =         -- Matching alternative!
 653         rhs_c env rhs
 654
 655     search_alts (_ : other_alts)
 656       =         -- This alternative doesn't match; keep looking
 657         search_alts other_alts
 658
 659     search_alts []
 660       = case deflt of
 661           NoDefault      ->     -- Blargh!
 662             panic "completePrimCaseWithKnownLit: No matching alternative and no default"
 663
 664           BindDefault binder rhs ->     -- OK, there's a default case
 665                                         -- Just bind the Id to the atom and continue
 666             let
 667                 new_env = bindIdToAtom env binder (LitArg lit)
 668             in
 669             rhs_c new_env rhs
 670 \end{code}
 671
 672 @completeAlgCaseWithKnownCon@: We know the constructor, so we can
 673 select one case alternative (or default).  If we choose the default:
 674 we do different things depending on whether the constructor was
 675 staring us in the face (e.g., \tr{case (p:ps) of {y -> ...}})
 676 [let-bind it] or we just know the \tr{y} is now the same as some other
 677 var [substitute \tr{y} out of existence].
 678
 679 \begin{code}
 680 completeAlgCaseWithKnownCon
 681         :: SimplEnv
 682         -> DataCon -> [InArg]
 683                 -- Scrutinee is (con, type, value arguments)
 684         -> InAlts
 685         -> (SimplEnv -> InExpr -> SmplM OutExpr)        -- Rhs handler
 686         -> SmplM OutExpr
 687
 688 completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
 689   = ASSERT(isDataCon con)
 690     search_alts alts
 691   where
 692     search_alts :: [(Id, [InBinder], InExpr)] -> SmplM OutExpr
 693
 694     search_alts ((alt_con, alt_args, rhs) : _)
 695       | alt_con == con
 696       =         -- Matching alternative!
 697         let
 698             val_args = filter isValArg con_args
 699             new_env  = foldr bind env (zipEqual "SimplCase" alt_args val_args)
 700             bind (bndr, atom) env = bindIdToAtom env bndr atom
 701         in
 702         rhs_c new_env rhs
 703
 704     search_alts (_ : other_alts)
 705       =         -- This alternative doesn't match; keep looking
 706         search_alts other_alts
 707
 708     search_alts []
 709       =         -- No matching alternative
 710         case deflt of
 711           NoDefault      ->     -- Blargh!
 712             panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
 713
 714           BindDefault binder@(_,occ_info) rhs ->        -- OK, there's a default case
 715                         -- let-bind the binder to the constructor
 716                 simplBinder env binder          `thenSmpl` \ (env1, id') ->
 717                 let
 718                     new_env = extendEnvGivenBinding env1 occ_info id' (Con con con_args)
 719                 in
 720                 rhs_c new_env rhs               `thenSmpl` \ rhs' ->
 721                 returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
 722 \end{code}
 723
 724 Case absorption and identity-case elimination
 725 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 726
 727 \begin{code}
 728 mkCoCase :: SimplEnv -> OutExpr -> OutAlts -> SmplM OutExpr
 729 \end{code}
 730
 731 @mkCoCase@ tries the following transformation (if possible):
 732
 733 case v of                 ==>   case v of
 734   p1 -> rhs1                      p1 -> rhs1
 735   ...                             ...
 736   pm -> rhsm                      pm -> rhsm
 737   d  -> case v of                 pn -> rhsn[v/d]  {or (alg)  let d=v in rhsn}
 738                                                    {or (prim) case v of d -> rhsn}
 739           pn -> rhsn              ...
 740           ...                     po -> rhso[v/d]
 741           po -> rhso              d  -> rhsd[d/d'] {or let d'=d in rhsd}
 742           d' -> rhsd
 743
 744 which merges two cases in one case when -- the default alternative of
 745 the outer case scrutises the same variable as the outer case This
 746 transformation is called Case Merging.  It avoids that the same
 747 variable is scrutinised multiple times.
 748
 749 There's a closely-related transformation:
 750
 751 case e of                 ==>   case e of
 752   p1 -> rhs1                      p1 -> rhs1
 753   ...                             ...
 754   pm -> rhsm                      pm -> rhsm
 755   d  -> case d of                 pn -> let d = pn in rhsn
 756           pn -> rhsn              ...
 757           ...                     po -> let d = po in rhso
 758           po -> rhso              d  -> rhsd[d/d'] {or let d'=d in rhsd}
 759           d' -> rhsd
 760
 761 Here, the let's are essential, because d isn't in scope any more.
 762 Sigh.  Of course, they may be unused, in which case they'll be
 763 eliminated on the next round.  Unfortunately, we can't figure out
 764 whether or not they are used at this juncture.
 765
 766 NB: The binder in a BindDefault USED TO BE guaranteed unused if the
 767 scrutinee is a variable, because it'll be mapped to the scrutinised
 768 variable.  Hence the [v/d] substitions can be omitted.
 769
 770 ALAS, now the default binder is used by preference, so we have to
 771 generate trivial lets to express the substitutions, which will be
 772 eliminated on the next pass.
 773
 774 The following code handles *both* these transformations (one
 775 equation for AlgAlts, one for PrimAlts):
 776
 777 \begin{code}
 778 mkCoCase env scrut (AlgAlts outer_alts
 779                           (BindDefault deflt_var
 780                                          (Case (Var scrut_var')
 781                                                  (AlgAlts inner_alts inner_deflt))))
 782   |  switchIsSet env SimplCaseMerge &&
 783      ((scrut_is_var && scrut_var == scrut_var') ||      -- First transformation
 784       deflt_var == scrut_var')                          -- Second transformation
 785   =     -- Aha! The default-absorption rule applies
 786     tick CaseMerge      `thenSmpl_`
 787     returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
 788                              (munge_alg_deflt deflt_var inner_deflt)))
 789         -- NB: see comment in this location for the PrimAlts case
 790   where
 791         -- Check scrutinee
 792     scrut_is_var = case scrut of {Var v -> True; other -> False}
 793     scrut_var    = case scrut of Var v -> v
 794
 795         --  Eliminate any inner alts which are shadowed by the outer ones
 796     reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
 797                                 not (con `is_elem` outer_cons)]
 798     outer_cons = [con | (con,_,_) <- outer_alts]
 799     is_elem = isIn "mkAlgAlts"
 800
 801         -- Add the lets if necessary
 802     munged_reduced_inner_alts = map munge_alt reduced_inner_alts
 803
 804     munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
 805        where
 806          v | scrut_is_var = Var scrut_var
 807            | otherwise    = Con con (map TyArg arg_tys ++ map VarArg args)
 808
 809     arg_tys = case (splitAlgTyConApp (idType deflt_var)) of
 810                 (_, arg_tys, _) -> arg_tys
 811
 812 mkCoCase env scrut (PrimAlts
 813                   outer_alts
 814                   (BindDefault deflt_var (Case
 815                                               (Var scrut_var')
 816                                               (PrimAlts inner_alts inner_deflt))))
 817   |  switchIsSet env SimplCaseMerge &&
 818      ((scrut_is_var && scrut_var == scrut_var') ||
 819       deflt_var == scrut_var')
 820   =     -- Aha! The default-absorption rule applies
 821     tick CaseMerge      `thenSmpl_`
 822     returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
 823                              (munge_prim_deflt deflt_var inner_deflt)))
 824
 825         -- Nota Bene: we don't recurse to mkCoCase again, because the
 826         -- default will now have a binding in it that prevents
 827         -- mkCoCase doing anything useful.  Much worse, in this
 828         -- PrimAlts case the binding in the default branch is another
 829         -- Case, so if we recurse to mkCoCase we will get into an
 830         -- infinite loop.
 831         --
 832         -- ToDo: think of a better way to do this.  At the moment
 833         -- there is at most one case merge per round.  That's probably
 834         -- plenty but it seems unclean somehow.
 835   where
 836         -- Check scrutinee
 837     scrut_is_var = case scrut of {Var v -> True; other -> False}
 838     scrut_var    = case scrut of Var v -> v
 839
 840         --  Eliminate any inner alts which are shadowed by the outer ones
 841     reduced_inner_alts = [alt | alt@(lit,_) <- inner_alts,
 842                                 not (lit `is_elem` outer_lits)]
 843     outer_lits = [lit | (lit,_) <- outer_alts]
 844     is_elem = isIn "mkPrimAlts"
 845
 846         -- Add the lets (well cases actually) if necessary
 847         -- The munged alternative looks like
 848         --      lit -> case lit of d -> rhs
 849         -- The next pass will certainly eliminate the inner case, but
 850         -- it isn't easy to do so right away.
 851     munged_reduced_inner_alts = map munge_alt reduced_inner_alts
 852
 853     munge_alt (lit, rhs)
 854       | scrut_is_var = (lit, Case (Var scrut_var)
 855                                     (PrimAlts [] (BindDefault deflt_var rhs)))
 856       | otherwise = (lit, Case (Lit lit)
 857                                  (PrimAlts [] (BindDefault deflt_var rhs)))
 858 \end{code}
 859
 860 Now the identity-case transformation:
 861
 862         case e of               ===> e
 863                 True -> True;
 864                 False -> False
 865
 866 and similar friends.
 867
 868 \begin{code}
 869 mkCoCase env scrut alts
 870   | identity_alts alts
 871   = tick CaseIdentity           `thenSmpl_`
 872     returnSmpl scrut
 873   where
 874     identity_alts (AlgAlts alts deflt)  = all identity_alg_alt  alts && identity_deflt deflt
 875     identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
 876
 877     identity_alg_alt (con, args, Con con' args')
 878          = con == con'
 879            && and (zipWith eq_arg args args')
 880            && length args == length args'
 881     identity_alg_alt other
 882          = False
 883
 884     identity_prim_alt (lit, Lit lit') = lit == lit'
 885     identity_prim_alt other            = False
 886
 887          -- For the default case we want to spot both
 888          --     x -> x
 889          -- and
 890          --     case y of { ... ; x -> y }
 891          -- as "identity" defaults
 892     identity_deflt NoDefault = True
 893     identity_deflt (BindDefault binder (Var x)) = x == binder ||
 894                                                       case scrut of
 895                                                          Var y -> y == x
 896                                                          other   -> False
 897     identity_deflt _ = False
 898
 899     eq_arg binder (VarArg x) = binder == x
 900     eq_arg _      _            = False
 901 \end{code}
 902
 903 The catch-all case
 904
 905 \begin{code}
 906 mkCoCase env other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
 907 \end{code}
 908
 909 Boring local functions used above.  They simply introduce a trivial binding
 910 for the binder, d', in an inner default; either
 911         let d' = deflt_var in rhs
 912 or
 913         case deflt_var of d' -> rhs
 914 depending on whether it's an algebraic or primitive case.
 915
 916 \begin{code}
 917 munge_prim_deflt _ NoDefault = NoDefault
 918
 919 munge_prim_deflt deflt_var (BindDefault d' rhs)
 920   =   BindDefault deflt_var (Case (Var deflt_var)
 921                                       (PrimAlts [] (BindDefault d' rhs)))
 922
 923 munge_alg_deflt _ NoDefault = NoDefault
 924
 925 munge_alg_deflt deflt_var (BindDefault d' rhs)
 926   =   BindDefault deflt_var (Let (NonRec d' (Var deflt_var)) rhs)
 927
 928 -- This line caused a generic version of munge_deflt (ie one used for
 929 -- both alg and prim) to space leak massively.  No idea why.
 930 --  = BindDefault deflt_var (mkCoLetUnboxedToCase (NonRec d' (Var deflt_var)) rhs)
 931 \end{code}
 932
 933 \begin{code}
 934 cheap_eq :: InExpr -> InExpr -> Bool
 935         -- A cheap equality test which bales out fast!
 936
 937 cheap_eq (Var v1) (Var v2) = v1==v2
 938 cheap_eq (Lit l1) (Lit l2) = l1==l2
 939 cheap_eq (Con con1 args1) (Con con2 args2)
 940   = con1 == con2 && args1 `eq_args` args2
 941
 942 cheap_eq (Prim op1 args1) (Prim op2 args2)
 943   = op1 ==op2 && args1 `eq_args` args2
 944
 945 cheap_eq (App f1 a1) (App f2 a2)
 946   = f1 `cheap_eq` f2 && a1 `eq_arg` a2
 947
 948 cheap_eq _ _ = False
 949
 950 -- ToDo: make CoreArg an instance of Eq
 951 eq_args (a1:as1) (a2:as2) = a1 `eq_arg` a2 && as1 `eq_args` as2
 952 eq_args []       []       = True
 953 eq_args _        _        = False
 954
 955 eq_arg (LitArg   l1) (LitArg   l2) = l1 == l2
 956 eq_arg (VarArg   v1) (VarArg   v2) = v1 == v2
 957 eq_arg (TyArg    t1) (TyArg    t2) = t1 == t2
 958 eq_arg _             _             =  False
 959 \end{code}