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