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