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(..), UnfoldingGuidance(..), SimpleUnfolding
  20                         )
  21 import CoreUtils        ( coreAltsType, nonErrorRHSs, maybeErrorApp,
  22                           unTagBindersAlts
  23                         )
  24 import Id               ( idType, isDataCon, getIdDemandInfo,
  25                           SYN_IE(DataCon), GenId{-instance Eq-}
  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 SimplUtils       ( mkValLamTryingEta )
  35 import Type             ( isPrimType, getAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqTy )
  36 import TysPrim          ( voidTy )
  37 import Unique           ( Unique{-instance Eq-} )
  38 import Usage            ( GenUsage{-instance Eq-} )
  39 import Util             ( 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 []
 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     rhs_c env retyped_error_app
 135   where
 136     alts_ty                = coreAltsType (unTagBindersAlts alts)
 137     maybe_error_app        = maybeErrorApp scrut (Just alts_ty)
 138     Just retyped_error_app = maybe_error_app
 139 \end{code}
 140
 141 Finally the default case
 142
 143 \begin{code}
 144 simplCase env other_scrut alts rhs_c result_ty
 145   =     -- Float the let outside the case scrutinee
 146     simplExpr env other_scrut []        `thenSmpl` \ scrut' ->
 147     completeCase env scrut' alts rhs_c
 148 \end{code}
 149
 150
 151 %************************************************************************
 152 %*                                                                      *
 153 \subsection[Simplify-case]{Completing case-expression simplification}
 154 %*                                                                      *
 155 %************************************************************************
 156
 157 \begin{code}
 158 completeCase
 159         :: SimplEnv
 160         -> OutExpr                                      -- The already-simplified scrutinee
 161         -> InAlts                                       -- The un-simplified alternatives
 162         -> (SimplEnv -> InExpr -> SmplM OutExpr)        -- Rhs handler
 163         -> SmplM OutExpr        -- The whole case expression
 164 \end{code}
 165
 166 Scrutinising a literal or constructor.
 167 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 168 It's an obvious win to do:
 169
 170         case (C a b) of {...; C p q -> rhs; ...}  ===>   rhs[a/p,b/q]
 171
 172 and the similar thing for primitive case.  If we have
 173
 174         case x of ...
 175
 176 and x is known to be of constructor form, then we'll already have
 177 inlined the constructor to give (case (C a b) of ...), so we don't
 178 need to check for the variable case separately.
 179
 180 Sanity check: we don't have a good
 181 story to tell about case analysis on NoRep things.  ToDo.
 182
 183 \begin{code}
 184 completeCase env (Lit lit) alts rhs_c
 185   | not (isNoRepLit lit)
 186   =     -- Ha!  Select the appropriate alternative
 187     tick KnownBranch            `thenSmpl_`
 188     completePrimCaseWithKnownLit env lit alts rhs_c
 189
 190 completeCase env expr@(Con con con_args) alts rhs_c
 191   =     -- Ha! Staring us in the face -- select the appropriate alternative
 192     tick KnownBranch            `thenSmpl_`
 193     completeAlgCaseWithKnownCon env con con_args alts rhs_c
 194 \end{code}
 195
 196 Case elimination
 197 ~~~~~~~~~~~~~~~~
 198 Start with a simple situation:
 199
 200         case x# of      ===>   e[x#/y#]
 201           y# -> e
 202
 203 (when x#, y# are of primitive type, of course).
 204 We can't (in general) do this for algebraic cases, because we might
 205 turn bottom into non-bottom!
 206
 207 Actually, we generalise this idea to look for a case where we're
 208 scrutinising a variable, and we know that only the default case can
 209 match.  For example:
 210 \begin{verbatim}
 211         case x of
 212           0#    -> ...
 213           other -> ...(case x of
 214                          0#    -> ...
 215                          other -> ...) ...
 216 \end{code}
 217 Here the inner case can be eliminated.  This really only shows up in
 218 eliminating error-checking code.
 219
 220 Lastly, we generalise the transformation to handle this:
 221
 222         case e of       ===> r
 223            True  -> r
 224            False -> r
 225
 226 We only do this for very cheaply compared r's (constructors, literals
 227 and variables).  If pedantic bottoms is on, we only do it when the
 228 scrutinee is a PrimOp which can't fail.
 229
 230 We do it *here*, looking at un-simplified alternatives, because we
 231 have to check that r doesn't mention the variables bound by the
 232 pattern in each alternative, so the binder-info is rather useful.
 233
 234 So the case-elimination algorithm is:
 235
 236         1. Eliminate alternatives which can't match
 237
 238         2. Check whether all the remaining alternatives
 239                 (a) do not mention in their rhs any of the variables bound in their pattern
 240            and  (b) have equal rhss
 241
 242         3. Check we can safely ditch the case:
 243                    * PedanticBottoms is off,
 244                 or * the scrutinee is an already-evaluated variable
 245                 or * the scrutinee is a primop which is ok for speculation
 246                         -- ie we want to preserve divide-by-zero errors, and
 247                         -- calls to error itself!
 248
 249                 or * [Prim cases] the scrutinee is a primitive variable
 250
 251                 or * [Alg cases] the scrutinee is a variable and
 252                      either * the rhs is the same variable
 253                         (eg case x of C a b -> x  ===>   x)
 254                      or     * there is only one alternative, the default alternative,
 255                                 and the binder is used strictly in its scope.
 256                                 [NB this is helped by the "use default binder where
 257                                  possible" transformation; see below.]
 258
 259
 260 If so, then we can replace the case with one of the rhss.
 261
 262 \begin{code}
 263 completeCase env scrut alts rhs_c
 264   | switchIsSet env SimplDoCaseElim &&
 265
 266     binders_unused &&
 267
 268     all_rhss_same &&
 269
 270     (not  (switchIsSet env SimplPedanticBottoms) ||
 271      scrut_is_evald ||
 272      scrut_is_eliminable_primitive ||
 273      rhs1_is_scrutinee ||
 274      scrut_is_var_and_single_strict_default
 275      )
 276
 277   = tick CaseElim       `thenSmpl_`
 278     rhs_c new_env rhs1
 279   where
 280         -- Find the non-excluded rhss of the case; always at least one
 281     (rhs1:rhss)   = possible_rhss
 282     all_rhss_same = all (cheap_eq rhs1) rhss
 283
 284         -- Find the reduced set of possible rhss, along with an indication of
 285         -- whether none of their binders are used
 286     (binders_unused, possible_rhss, new_env)
 287       = case alts of
 288           PrimAlts alts deflt -> (deflt_binder_unused,  -- No binders other than deflt
 289                                     deflt_rhs ++ rhss,
 290                                     new_env)
 291             where
 292               (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
 293
 294                 -- Eliminate unused rhss if poss
 295               rhss = case scrut_form of
 296                         OtherLit not_these -> [rhs | (alt_lit,rhs) <- alts,
 297                                                      not (alt_lit `is_elem` not_these)
 298                                               ]
 299                         other -> [rhs | (_,rhs) <- alts]
 300
 301           AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
 302                                    deflt_rhs ++ [rhs | (_,_,rhs) <- possible_alts],
 303                                    new_env)
 304             where
 305               (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
 306
 307                 -- Eliminate unused alts if poss
 308               possible_alts = case scrut_form of
 309                                 OtherCon not_these ->
 310                                                 -- Remove alts which can't match
 311                                         [alt | alt@(alt_con,_,_) <- alts,
 312                                                not (alt_con `is_elem` not_these)]
 313
 314                                 other -> alts
 315
 316               alt_binders_unused (con, args, rhs) = all is_dead args
 317               is_dead (_, DeadCode) = True
 318               is_dead other_arg     = False
 319
 320         -- If the scrutinee is a variable, look it up to see what we know about it
 321     scrut_form = case scrut of
 322                   Var v -> lookupRhsInfo env v
 323                   other -> NoRhsInfo
 324
 325         -- If the scrut is already eval'd then there's no worry about
 326         -- eliminating the case
 327     scrut_is_evald = isEvaluated scrut_form
 328
 329     scrut_is_eliminable_primitive
 330       = case scrut of
 331            Prim op _ -> primOpOkForSpeculation op
 332            Var _     -> case alts of
 333                           PrimAlts _ _ -> True  -- Primitive, hence non-bottom
 334                           AlgAlts _ _  -> False -- Not primitive
 335            other     -> False
 336
 337         -- case v of w -> e{strict in w}  ===>   e[v/w]
 338     scrut_is_var_and_single_strict_default
 339       = case scrut of
 340           Var _ -> case alts of
 341                         AlgAlts [] (BindDefault (v,_) _) -> willBeDemanded (getIdDemandInfo v)
 342                         other -> False
 343           other -> False
 344
 345     elim_deflt_binder NoDefault                          -- No Binder
 346         = (True, [], env)
 347     elim_deflt_binder (BindDefault (id, DeadCode) rhs) -- Binder unused
 348         = (True, [rhs], env)
 349     elim_deflt_binder (BindDefault used_binder rhs)      -- Binder used
 350         = case scrut of
 351                 Var v ->        -- Binder used, but can be eliminated in favour of scrut
 352                            (True, [rhs], extendIdEnvWithAtom env used_binder (VarArg v))
 353                 non_var ->      -- Binder used, and can't be elimd
 354                            (False, [rhs], env)
 355
 356         -- Check whether the chosen unique rhs (ie rhs1) is the same as
 357         -- the scrutinee.  Remember that the rhs is as yet unsimplified.
 358     rhs1_is_scrutinee = case (scrut, rhs1) of
 359                           (Var scrut_var, Var rhs_var)
 360                                 -> case lookupId env rhs_var of
 361                                     VarArg rhs_var' -> rhs_var' == scrut_var
 362                                     other           -> False
 363                           other -> False
 364
 365     is_elem x ys = isIn "completeCase" x ys
 366 \end{code}
 367
 368 Scrutinising anything else.  If it's a variable, it can't be bound to a
 369 constructor or literal, because that would have been inlined
 370
 371 \begin{code}
 372 completeCase env scrut alts rhs_c
 373   = simplAlts env scrut alts rhs_c      `thenSmpl` \ alts' ->
 374     mkCoCase scrut alts'
 375 \end{code}
 376
 377
 378
 379
 380 \begin{code}
 381 bindLargeAlts :: SimplEnv
 382               -> InAlts
 383               -> (SimplEnv -> InExpr -> SmplM OutExpr)          -- Old rhs handler
 384               -> OutType                                        -- Result type
 385               -> SmplM ([OutBinding],   -- Extra bindings
 386                         InAlts)         -- Modified alts
 387
 388 bindLargeAlts env the_lot@(AlgAlts alts deflt) rhs_c rhs_ty
 389   = mapAndUnzipSmpl do_alt alts                 `thenSmpl` \ (alt_bindings, alts') ->
 390     bindLargeDefault env deflt rhs_ty rhs_c     `thenSmpl` \ (deflt_bindings, deflt') ->
 391     returnSmpl (deflt_bindings ++ alt_bindings, AlgAlts alts' deflt')
 392   where
 393     do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty
 394                                 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
 395                             returnSmpl (bind, (con,args,rhs'))
 396
 397 bindLargeAlts env the_lot@(PrimAlts alts deflt) rhs_c rhs_ty
 398   = mapAndUnzipSmpl do_alt alts                 `thenSmpl` \ (alt_bindings, alts') ->
 399     bindLargeDefault env deflt rhs_ty rhs_c     `thenSmpl` \ (deflt_bindings, deflt') ->
 400     returnSmpl (deflt_bindings ++ alt_bindings, PrimAlts alts' deflt')
 401   where
 402     do_alt (lit,rhs) = bindLargeRhs env [] rhs_ty
 403                                 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
 404                        returnSmpl (bind, (lit,rhs'))
 405
 406 bindLargeDefault env NoDefault rhs_ty rhs_c
 407   = returnSmpl ([], NoDefault)
 408 bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c
 409   = bindLargeRhs env [binder] rhs_ty
 410                  (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
 411     returnSmpl ([bind], BindDefault binder rhs')
 412 \end{code}
 413
 414         bindLargeRhs env [x1,..,xn] rhs rhs_ty rhs_c
 415          | otherwise        = (rhs_id = \x1..xn -> rhs_c rhs,
 416                                rhs_id x1 .. xn)
 417
 418 \begin{code}
 419 bindLargeRhs :: SimplEnv
 420              -> [InBinder]      -- The args wrt which the rhs should be abstracted
 421              -> OutType
 422              -> (SimplEnv -> SmplM OutExpr)             -- Rhs handler
 423              -> SmplM (OutBinding,      -- New bindings (singleton or empty)
 424                        InExpr)          -- Modified rhs
 425
 426 bindLargeRhs env args rhs_ty rhs_c
 427   | null used_args && isPrimType rhs_ty
 428         -- If we try to lift a primitive-typed something out
 429         -- for let-binding-purposes, we will *caseify* it (!),
 430         -- with potentially-disastrous strictness results.  So
 431         -- instead we turn it into a function: \v -> e
 432         -- where v::Void.  Since arguments of type
 433         -- VoidPrim don't generate any code, this gives the
 434         -- desired effect.
 435         --
 436         -- The general structure is just the same as for the common "otherwise~ case
 437   = newId prim_rhs_fun_ty       `thenSmpl` \ prim_rhs_fun_id ->
 438     newId voidTy                `thenSmpl` \ void_arg_id ->
 439     rhs_c env                   `thenSmpl` \ prim_new_body ->
 440
 441     returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
 442                 App (Var prim_rhs_fun_id) (VarArg voidId))
 443
 444   | otherwise
 445   =     -- Make the new binding Id.  NB: it's an OutId
 446     newId rhs_fun_ty            `thenSmpl` \ rhs_fun_id ->
 447
 448         -- Generate its rhs
 449     cloneIds env used_args      `thenSmpl` \ used_args' ->
 450     let
 451         new_env = extendIdEnvWithClones env used_args used_args'
 452     in
 453     rhs_c new_env               `thenSmpl` \ rhs' ->
 454     let
 455         final_rhs
 456           = (if switchIsSet new_env SimplDoEtaReduction
 457              then mkValLamTryingEta
 458              else mkValLam) used_args' rhs'
 459     in
 460     returnSmpl (NonRec rhs_fun_id final_rhs,
 461                 foldl App (Var rhs_fun_id) used_arg_atoms)
 462         -- This is slightly wierd. We're retuning an OutId as part of the
 463         -- modified rhs, which is meant to be an InExpr. However, that's ok, because when
 464         -- it's processed the OutId won't be found in the environment, so it
 465         -- will be left unmodified.
 466   where
 467     rhs_fun_ty :: OutType
 468     rhs_fun_ty = mkFunTys [simplTy env (idType id) | (id,_) <- used_args] rhs_ty
 469
 470     used_args      = [arg | arg@(_,usage) <- args, not (dead usage)]
 471     used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
 472     dead DeadCode  = True
 473     dead other     = False
 474
 475     prim_rhs_fun_ty = mkFunTy voidTy rhs_ty
 476 \end{code}
 477
 478 Case alternatives when we don't know the scrutinee
 479 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 480
 481 A special case for case default.  If we have
 482 \begin{verbatim}
 483 case x of
 484   p1 -> e1
 485   y  -> default_e
 486 \end{verbatim}
 487 it is best to make sure that \tr{default_e} mentions \tr{x} in
 488 preference to \tr{y}.  The code generator can do a cheaper job if it
 489 doesn't have to come up with a binding for \tr{y}.
 490
 491 \begin{code}
 492 simplAlts :: SimplEnv
 493           -> OutExpr                    -- Simplified scrutinee;
 494                                         -- only of interest if its a var,
 495                                         -- in which case we record its form
 496           -> InAlts
 497           -> (SimplEnv -> InExpr -> SmplM OutExpr)      -- Rhs handler
 498           -> SmplM OutAlts
 499
 500 simplAlts env scrut (AlgAlts alts deflt) rhs_c
 501   = mapSmpl do_alt alts                                 `thenSmpl` \ alts' ->
 502     simplDefault env scrut deflt deflt_form rhs_c       `thenSmpl` \ deflt' ->
 503     returnSmpl (AlgAlts alts' deflt')
 504   where
 505     deflt_form = OtherCon [con | (con,_,_) <- alts]
 506     do_alt (con, con_args, rhs)
 507       = cloneIds env con_args                           `thenSmpl` \ con_args' ->
 508         let
 509             env1    = extendIdEnvWithClones env con_args con_args'
 510             new_env = case scrut of
 511                        Var v -> extendEnvGivenNewRhs env1 v (Con con args)
 512                              where
 513                                 (_, ty_args, _) = 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                     new_env = extendEnvGivenBinding env occ_info id' (Con con con_args)
 686                 in
 687                 rhs_c new_env rhs               `thenSmpl` \ rhs' ->
 688                 returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
 689 \end{code}
 690
 691 Case absorption and identity-case elimination
 692 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 693
 694 \begin{code}
 695 mkCoCase :: OutExpr -> OutAlts -> SmplM OutExpr
 696 \end{code}
 697
 698 @mkCoCase@ tries the following transformation (if possible):
 699
 700 case v of                 ==>   case v of
 701   p1 -> rhs1                      p1 -> rhs1
 702   ...                             ...
 703   pm -> rhsm                      pm -> rhsm
 704   d  -> case v of                 pn -> rhsn[v/d]  {or (alg)  let d=v in rhsn}
 705                                                    {or (prim) case v of d -> rhsn}
 706           pn -> rhsn              ...
 707           ...                     po -> rhso[v/d]
 708           po -> rhso              d  -> rhsd[d/d'] {or let d'=d in rhsd}
 709           d' -> rhsd
 710
 711 which merges two cases in one case when -- the default alternative of
 712 the outer case scrutises the same variable as the outer case This
 713 transformation is called Case Merging.  It avoids that the same
 714 variable is scrutinised multiple times.
 715
 716 There's a closely-related transformation:
 717
 718 case e of                 ==>   case e of
 719   p1 -> rhs1                      p1 -> rhs1
 720   ...                             ...
 721   pm -> rhsm                      pm -> rhsm
 722   d  -> case d of                 pn -> let d = pn in rhsn
 723           pn -> rhsn              ...
 724           ...                     po -> let d = po in rhso
 725           po -> rhso              d  -> rhsd[d/d'] {or let d'=d in rhsd}
 726           d' -> rhsd
 727
 728 Here, the let's are essential, because d isn't in scope any more.
 729 Sigh.  Of course, they may be unused, in which case they'll be
 730 eliminated on the next round.  Unfortunately, we can't figure out
 731 whether or not they are used at this juncture.
 732
 733 NB: The binder in a BindDefault USED TO BE guaranteed unused if the
 734 scrutinee is a variable, because it'll be mapped to the scrutinised
 735 variable.  Hence the [v/d] substitions can be omitted.
 736
 737 ALAS, now the default binder is used by preference, so we have to
 738 generate trivial lets to express the substitutions, which will be
 739 eliminated on the next pass.
 740
 741 The following code handles *both* these transformations (one
 742 equation for AlgAlts, one for PrimAlts):
 743
 744 \begin{code}
 745 mkCoCase scrut (AlgAlts outer_alts
 746                           (BindDefault deflt_var
 747                                          (Case (Var scrut_var')
 748                                                  (AlgAlts inner_alts inner_deflt))))
 749   |  (scrut_is_var && scrut_var == scrut_var')  -- First transformation
 750   || deflt_var == scrut_var'                    -- Second transformation
 751   =     -- Aha! The default-absorption rule applies
 752     tick CaseMerge      `thenSmpl_`
 753     returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
 754                              (munge_alg_deflt deflt_var inner_deflt)))
 755         -- NB: see comment in this location for the PrimAlts case
 756   where
 757         -- Check scrutinee
 758     scrut_is_var = case scrut of {Var v -> True; other -> False}
 759     scrut_var    = case scrut of Var v -> v
 760
 761         --  Eliminate any inner alts which are shadowed by the outer ones
 762     reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
 763                                 not (con `is_elem` outer_cons)]
 764     outer_cons = [con | (con,_,_) <- outer_alts]
 765     is_elem = isIn "mkAlgAlts"
 766
 767         -- Add the lets if necessary
 768     munged_reduced_inner_alts = map munge_alt reduced_inner_alts
 769
 770     munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
 771        where
 772          v | scrut_is_var = Var scrut_var
 773            | otherwise    = Con con (map TyArg arg_tys ++ map VarArg args)
 774
 775     arg_tys = case (getAppDataTyConExpandingDicts (idType deflt_var)) of
 776                 (_, arg_tys, _) -> arg_tys
 777
 778 mkCoCase scrut (PrimAlts
 779                   outer_alts
 780                   (BindDefault deflt_var (Case
 781                                               (Var scrut_var')
 782                                               (PrimAlts inner_alts inner_deflt))))
 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 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 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}