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