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