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