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