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 import Ubiq{-uitous-}
  14 import 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       ( UnfoldingDetails(..), UnfoldingGuidance(..),
  20                           FormSummary(..)
  21                         )
  22 import CoreUtils        ( coreAltsType, nonErrorRHSs, maybeErrorApp,
  23                           unTagBindersAlts
  24                         )
  25 import Id               ( idType, isDataCon, getIdDemandInfo,
  26                           DataCon(..), GenId{-instance Eq-}
  27                         )
  28 import IdInfo           ( willBeDemanded, DemandInfo )
  29 import Literal          ( isNoRepLit, Literal{-instance Eq-} )
  30 import Maybes           ( maybeToBool )
  31 import PrelVals         ( voidPrimId )
  32 import PrimOp           ( primOpOkForSpeculation, PrimOp{-instance Eq-} )
  33 import SimplEnv
  34 import SimplMonad
  35 import SimplUtils       ( mkValLamTryingEta )
  36 import Type             ( isPrimType, maybeAppDataTyConExpandingDicts, mkFunTys, eqTy )
  37 import TysPrim          ( voidPrimTy )
  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                         OtherLitForm 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                                 OtherConForm 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 #ifdef DEBUG
 316 --                              ConForm c v -> pprPanic "completeCase!" (ppAbove (ppCat [ppr PprDebug c, ppStr "<args>"]) (ppr PprDebug alts))
 317                                   -- ConForm can't happen, since we'd have
 318                                   -- inlined it, and be in completeCaseWithKnownCon by now
 319 #endif
 320                                 other -> alts
 321
 322               alt_binders_unused (con, args, rhs) = all is_dead args
 323               is_dead (_, DeadCode) = True
 324               is_dead other_arg     = False
 325
 326         -- If the scrutinee is a variable, look it up to see what we know about it
 327     scrut_form = case scrut of
 328                   Var v -> lookupUnfolding env v
 329                   other   -> NoUnfoldingDetails
 330
 331         -- If the scrut is already eval'd then there's no worry about
 332         -- eliminating the case
 333     scrut_is_evald = case scrut_form of
 334                         OtherLitForm _   -> True
 335                         ConForm      _ _ -> True
 336                         OtherConForm _   -> True
 337                         other            -> False
 338
 339
 340     scrut_is_eliminable_primitive
 341       = case scrut of
 342            Prim op _ -> primOpOkForSpeculation op
 343            Var _     -> case alts of
 344                           PrimAlts _ _ -> True  -- Primitive, hence non-bottom
 345                           AlgAlts _ _  -> False -- Not primitive
 346            other     -> False
 347
 348         -- case v of w -> e{strict in w}  ===>   e[v/w]
 349     scrut_is_var_and_single_strict_default
 350       = case scrut of
 351           Var _ -> case alts of
 352                         AlgAlts [] (BindDefault (v,_) _) -> willBeDemanded (getIdDemandInfo v)
 353                         other -> False
 354           other -> False
 355
 356     elim_deflt_binder NoDefault                          -- No Binder
 357         = (True, [], env)
 358     elim_deflt_binder (BindDefault (id, DeadCode) rhs) -- Binder unused
 359         = (True, [rhs], env)
 360     elim_deflt_binder (BindDefault used_binder rhs)      -- Binder used
 361         = case scrut of
 362                 Var v ->        -- Binder used, but can be eliminated in favour of scrut
 363                            (True, [rhs], extendIdEnvWithAtom env used_binder (VarArg v))
 364                 non_var ->      -- Binder used, and can't be elimd
 365                            (False, [rhs], env)
 366
 367         -- Check whether the chosen unique rhs (ie rhs1) is the same as
 368         -- the scrutinee.  Remember that the rhs is as yet unsimplified.
 369     rhs1_is_scrutinee = case (scrut, rhs1) of
 370                           (Var scrut_var, Var rhs_var)
 371                                 -> case lookupId env rhs_var of
 372                                     Just (ItsAnAtom (VarArg rhs_var'))
 373                                         -> rhs_var' == scrut_var
 374                                     other -> False
 375                           other -> False
 376
 377     is_elem x ys = isIn "completeCase" x ys
 378 \end{code}
 379
 380 Scrutinising anything else.  If it's a variable, it can't be bound to a
 381 constructor or literal, because that would have been inlined
 382
 383 \begin{code}
 384 completeCase env scrut alts rhs_c
 385   = simplAlts env scrut alts rhs_c      `thenSmpl` \ alts' ->
 386     mkCoCase scrut alts'
 387 \end{code}
 388
 389
 390
 391
 392 \begin{code}
 393 bindLargeAlts :: SimplEnv
 394               -> InAlts
 395               -> (SimplEnv -> InExpr -> SmplM OutExpr)          -- Old rhs handler
 396               -> OutType                                        -- Result type
 397               -> SmplM ([OutBinding],   -- Extra bindings
 398                         InAlts)         -- Modified alts
 399
 400 bindLargeAlts env the_lot@(AlgAlts 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, AlgAlts alts' deflt')
 404   where
 405     do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty
 406                                 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
 407                             returnSmpl (bind, (con,args,rhs'))
 408
 409 bindLargeAlts env the_lot@(PrimAlts alts deflt) rhs_c rhs_ty
 410   = mapAndUnzipSmpl do_alt alts                 `thenSmpl` \ (alt_bindings, alts') ->
 411     bindLargeDefault env deflt rhs_ty rhs_c     `thenSmpl` \ (deflt_bindings, deflt') ->
 412     returnSmpl (deflt_bindings ++ alt_bindings, PrimAlts alts' deflt')
 413   where
 414     do_alt (lit,rhs) = bindLargeRhs env [] rhs_ty
 415                                 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
 416                        returnSmpl (bind, (lit,rhs'))
 417
 418 bindLargeDefault env NoDefault rhs_ty rhs_c
 419   = returnSmpl ([], NoDefault)
 420 bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c
 421   = bindLargeRhs env [binder] rhs_ty
 422                  (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
 423     returnSmpl ([bind], BindDefault binder rhs')
 424 \end{code}
 425
 426         bindLargeRhs env [x1,..,xn] rhs rhs_ty rhs_c
 427          | otherwise        = (rhs_id = \x1..xn -> rhs_c rhs,
 428                                rhs_id x1 .. xn)
 429
 430 \begin{code}
 431 bindLargeRhs :: SimplEnv
 432              -> [InBinder]      -- The args wrt which the rhs should be abstracted
 433              -> OutType
 434              -> (SimplEnv -> SmplM OutExpr)             -- Rhs handler
 435              -> SmplM (OutBinding,      -- New bindings (singleton or empty)
 436                        InExpr)          -- Modified rhs
 437
 438 bindLargeRhs env args rhs_ty rhs_c
 439   | null used_args && isPrimType rhs_ty
 440         -- If we try to lift a primitive-typed something out
 441         -- for let-binding-purposes, we will *caseify* it (!),
 442         -- with potentially-disastrous strictness results.  So
 443         -- instead we turn it into a function: \v -> e
 444         -- where v::VoidPrim.  Since arguments of type
 445         -- VoidPrim don't generate any code, this gives the
 446         -- desired effect.
 447         --
 448         -- The general structure is just the same as for the common "otherwise~ case
 449   = newId prim_rhs_fun_ty       `thenSmpl` \ prim_rhs_fun_id ->
 450     newId voidPrimTy            `thenSmpl` \ void_arg_id ->
 451     rhs_c env                   `thenSmpl` \ prim_new_body ->
 452
 453     returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
 454                 App (Var prim_rhs_fun_id) (VarArg voidPrimId))
 455
 456   | otherwise
 457   =     -- Make the new binding Id.  NB: it's an OutId
 458     newId rhs_fun_ty            `thenSmpl` \ rhs_fun_id ->
 459
 460         -- Generate its rhs
 461     cloneIds env used_args      `thenSmpl` \ used_args' ->
 462     let
 463         new_env = extendIdEnvWithClones env used_args used_args'
 464     in
 465     rhs_c new_env               `thenSmpl` \ rhs' ->
 466     let
 467         final_rhs
 468           = (if switchIsSet new_env SimplDoEtaReduction
 469              then mkValLamTryingEta
 470              else mkValLam) used_args' rhs'
 471     in
 472     returnSmpl (NonRec rhs_fun_id final_rhs,
 473                 foldl App (Var rhs_fun_id) used_arg_atoms)
 474         -- This is slightly wierd. We're retuning an OutId as part of the
 475         -- modified rhs, which is meant to be an InExpr. However, that's ok, because when
 476         -- it's processed the OutId won't be found in the environment, so it
 477         -- will be left unmodified.
 478   where
 479     rhs_fun_ty :: OutType
 480     rhs_fun_ty = mkFunTys [simplTy env (idType id) | (id,_) <- used_args] rhs_ty
 481
 482     used_args      = [arg | arg@(_,usage) <- args, not (dead usage)]
 483     used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
 484     dead DeadCode  = True
 485     dead other     = False
 486
 487     prim_rhs_fun_ty = mkFunTys [voidPrimTy] rhs_ty
 488 \end{code}
 489
 490 Case alternatives when we don't know the scrutinee
 491 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 492
 493 A special case for case default.  If we have
 494 \begin{verbatim}
 495 case x of
 496   p1 -> e1
 497   y  -> default_e
 498 \end{verbatim}
 499 it is best to make sure that \tr{default_e} mentions \tr{x} in
 500 preference to \tr{y}.  The code generator can do a cheaper job if it
 501 doesn't have to come up with a binding for \tr{y}.
 502
 503 \begin{code}
 504 simplAlts :: SimplEnv
 505           -> OutExpr                    -- Simplified scrutinee;
 506                                         -- only of interest if its a var,
 507                                         -- in which case we record its form
 508           -> InAlts
 509           -> (SimplEnv -> InExpr -> SmplM OutExpr)      -- Rhs handler
 510           -> SmplM OutAlts
 511
 512 simplAlts env scrut (AlgAlts alts deflt) rhs_c
 513   = mapSmpl do_alt alts                                 `thenSmpl` \ alts' ->
 514     simplDefault env scrut deflt deflt_form rhs_c       `thenSmpl` \ deflt' ->
 515     returnSmpl (AlgAlts alts' deflt')
 516   where
 517     deflt_form = OtherConForm [con | (con,_,_) <- alts]
 518     do_alt (con, con_args, rhs)
 519       = cloneIds env con_args                           `thenSmpl` \ con_args' ->
 520         let
 521             env1    = extendIdEnvWithClones env con_args con_args'
 522             new_env = case scrut of
 523                        Var v -> extendUnfoldEnvGivenConstructor env1 v con con_args'
 524                        other -> env1
 525         in
 526         rhs_c new_env rhs                               `thenSmpl` \ rhs' ->
 527         returnSmpl (con, con_args', rhs')
 528
 529 simplAlts env scrut (PrimAlts alts deflt) rhs_c
 530   = mapSmpl do_alt alts                                 `thenSmpl` \ alts' ->
 531     simplDefault env scrut deflt deflt_form rhs_c       `thenSmpl` \ deflt' ->
 532     returnSmpl (PrimAlts alts' deflt')
 533   where
 534     deflt_form = OtherLitForm [lit | (lit,_) <- alts]
 535     do_alt (lit, rhs)
 536       = let
 537             new_env = case scrut of
 538                         Var v -> extendUnfoldEnvGivenFormDetails env v (LitForm lit)
 539                         other -> env
 540         in
 541         rhs_c new_env rhs                               `thenSmpl` \ rhs' ->
 542         returnSmpl (lit, rhs')
 543 \end{code}
 544
 545 Use default binder where possible
 546 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 547 There's one complication when simplifying the default clause of
 548 a case expression.  If we see
 549
 550         case x of
 551           x' -> ...x...x'...
 552
 553 we'd like to convert it to
 554
 555         case x of
 556           x' -> ...x'...x'...
 557
 558 Reason 1: then there might be just one occurrence of x, and it can be
 559 inlined as the case scrutinee.  So we spot this case when dealing with
 560 the default clause, and add a binding to the environment mapping x to
 561 x'.
 562
 563 Reason 2: if the body is strict in x' then we can eliminate the
 564 case altogether. By using x' in preference to x we give the max chance
 565 of the strictness analyser finding that the body is strict in x'.
 566
 567 On the other hand, if x does *not* get inlined, then we'll actually
 568 get somewhat better code from the former expression.  So when
 569 doing Core -> STG we convert back!
 570
 571 \begin{code}
 572 simplDefault
 573         :: SimplEnv
 574         -> OutExpr                      -- Simplified scrutinee
 575         -> InDefault                    -- Default alternative to be completed
 576         -> UnfoldingDetails             -- Gives form of scrutinee
 577         -> (SimplEnv -> InExpr -> SmplM OutExpr)                -- Old rhs handler
 578         -> SmplM OutDefault
 579
 580 simplDefault env scrut NoDefault form rhs_c
 581   = returnSmpl NoDefault
 582
 583 -- Special case for variable scrutinee; see notes above.
 584 simplDefault env (Var scrut_var) (BindDefault binder rhs) form_from_this_case rhs_c
 585   = cloneId env binder  `thenSmpl` \ binder' ->
 586     let
 587       env1    = extendIdEnvWithAtom env binder (VarArg binder')
 588
 589         -- Add form details for the default binder
 590       scrut_form = lookupUnfolding env scrut_var
 591       final_form
 592         = case (form_from_this_case, scrut_form) of
 593             (OtherConForm cs, OtherConForm ds) -> OtherConForm (cs++ds)
 594             (OtherLitForm cs, OtherLitForm ds) -> OtherLitForm (cs++ds)
 595                         -- ConForm, LitForm impossible
 596                         -- (ASSERT?  ASSERT?  Hello? WDP 95/05)
 597             other                              -> form_from_this_case
 598
 599       env2 = extendUnfoldEnvGivenFormDetails env1 binder' final_form
 600
 601         -- Change unfold details for scrut var.  We now want to unfold it
 602         -- to binder'
 603       new_scrut_var_form = GenForm True {- OK to dup -} WhnfForm
 604                                        (Var binder') UnfoldAlways
 605       new_env    = extendUnfoldEnvGivenFormDetails env2 scrut_var new_scrut_var_form
 606
 607     in
 608     rhs_c new_env rhs                   `thenSmpl` \ rhs' ->
 609     returnSmpl (BindDefault binder' rhs')
 610
 611 simplDefault env scrut (BindDefault binder rhs) form rhs_c
 612   = cloneId env binder  `thenSmpl` \ binder' ->
 613     let
 614         env1    = extendIdEnvWithAtom env binder (VarArg binder')
 615         new_env = extendUnfoldEnvGivenFormDetails env1 binder' form
 616     in
 617     rhs_c new_env rhs                   `thenSmpl` \ rhs' ->
 618     returnSmpl (BindDefault binder' rhs')
 619 \end{code}
 620
 621 Case alternatives when we know what the scrutinee is
 622 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 623
 624 \begin{code}
 625 completePrimCaseWithKnownLit
 626         :: SimplEnv
 627         -> Literal
 628         -> InAlts
 629         -> (SimplEnv -> InExpr -> SmplM OutExpr)        -- Rhs handler
 630         -> SmplM OutExpr
 631
 632 completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c
 633   = search_alts alts
 634   where
 635     search_alts :: [(Literal, InExpr)] -> SmplM OutExpr
 636
 637     search_alts ((alt_lit, rhs) : _)
 638       | alt_lit == lit
 639       =         -- Matching alternative!
 640         rhs_c env rhs
 641
 642     search_alts (_ : other_alts)
 643       =         -- This alternative doesn't match; keep looking
 644         search_alts other_alts
 645
 646     search_alts []
 647       = case deflt of
 648           NoDefault      ->     -- Blargh!
 649             panic "completePrimCaseWithKnownLit: No matching alternative and no default"
 650
 651           BindDefault binder rhs ->     -- OK, there's a default case
 652                                         -- Just bind the Id to the atom and continue
 653             let
 654                 new_env = extendIdEnvWithAtom env binder (LitArg lit)
 655             in
 656             rhs_c new_env rhs
 657 \end{code}
 658
 659 @completeAlgCaseWithKnownCon@: We know the constructor, so we can
 660 select one case alternative (or default).  If we choose the default:
 661 we do different things depending on whether the constructor was
 662 staring us in the face (e.g., \tr{case (p:ps) of {y -> ...}})
 663 [let-bind it] or we just know the \tr{y} is now the same as some other
 664 var [substitute \tr{y} out of existence].
 665
 666 \begin{code}
 667 completeAlgCaseWithKnownCon
 668         :: SimplEnv
 669         -> DataCon -> [InArg]
 670                 -- Scrutinee is (con, type, value arguments)
 671         -> InAlts
 672         -> (SimplEnv -> InExpr -> SmplM OutExpr)        -- Rhs handler
 673         -> SmplM OutExpr
 674
 675 completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
 676   = ASSERT(isDataCon con)
 677     search_alts alts
 678   where
 679     search_alts :: [(Id, [InBinder], InExpr)] -> SmplM OutExpr
 680
 681     search_alts ((alt_con, alt_args, rhs) : _)
 682       | alt_con == con
 683       =         -- Matching alternative!
 684         let
 685             new_env = extendIdEnvWithAtomList env (zipEqual "SimplCase" alt_args (filter isValArg con_args))
 686         in
 687         rhs_c new_env rhs
 688
 689     search_alts (_ : other_alts)
 690       =         -- This alternative doesn't match; keep looking
 691         search_alts other_alts
 692
 693     search_alts []
 694       =         -- No matching alternative
 695         case deflt of
 696           NoDefault      ->     -- Blargh!
 697             panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
 698
 699           BindDefault binder rhs ->     -- OK, there's a default case
 700                         -- let-bind the binder to the constructor
 701                 cloneId env binder              `thenSmpl` \ id' ->
 702                 let
 703                     env1    = extendIdEnvWithClone env binder id'
 704                     new_env = extendUnfoldEnvGivenFormDetails env1 id'
 705                                         (ConForm con con_args)
 706                 in
 707                 rhs_c new_env rhs               `thenSmpl` \ rhs' ->
 708                 returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
 709 \end{code}
 710
 711 Case absorption and identity-case elimination
 712 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 713
 714 \begin{code}
 715 mkCoCase :: OutExpr -> OutAlts -> SmplM OutExpr
 716 \end{code}
 717
 718 @mkCoCase@ tries the following transformation (if possible):
 719
 720 case v of                 ==>   case v of
 721   p1 -> rhs1                      p1 -> rhs1
 722   ...                             ...
 723   pm -> rhsm                      pm -> rhsm
 724   d  -> case v of                 pn -> rhsn[v/d]  {or (alg)  let d=v in rhsn}
 725                                                    {or (prim) case v of d -> rhsn}
 726           pn -> rhsn              ...
 727           ...                     po -> rhso[v/d]
 728           po -> rhso              d  -> rhsd[d/d'] {or let d'=d in rhsd}
 729           d' -> rhsd
 730
 731 which merges two cases in one case when -- the default alternative of
 732 the outer case scrutises the same variable as the outer case This
 733 transformation is called Case Merging.  It avoids that the same
 734 variable is scrutinised multiple times.
 735
 736 There's a closely-related transformation:
 737
 738 case e of                 ==>   case e of
 739   p1 -> rhs1                      p1 -> rhs1
 740   ...                             ...
 741   pm -> rhsm                      pm -> rhsm
 742   d  -> case d of                 pn -> let d = pn in rhsn
 743           pn -> rhsn              ...
 744           ...                     po -> let d = po in rhso
 745           po -> rhso              d  -> rhsd[d/d'] {or let d'=d in rhsd}
 746           d' -> rhsd
 747
 748 Here, the let's are essential, because d isn't in scope any more.
 749 Sigh.  Of course, they may be unused, in which case they'll be
 750 eliminated on the next round.  Unfortunately, we can't figure out
 751 whether or not they are used at this juncture.
 752
 753 NB: The binder in a BindDefault USED TO BE guaranteed unused if the
 754 scrutinee is a variable, because it'll be mapped to the scrutinised
 755 variable.  Hence the [v/d] substitions can be omitted.
 756
 757 ALAS, now the default binder is used by preference, so we have to
 758 generate trivial lets to express the substitutions, which will be
 759 eliminated on the next pass.
 760
 761 The following code handles *both* these transformations (one
 762 equation for AlgAlts, one for PrimAlts):
 763
 764 \begin{code}
 765 mkCoCase scrut (AlgAlts outer_alts
 766                           (BindDefault deflt_var
 767                                          (Case (Var scrut_var')
 768                                                  (AlgAlts inner_alts inner_deflt))))
 769   |  (scrut_is_var && scrut_var == scrut_var')  -- First transformation
 770   || deflt_var == scrut_var'                    -- Second transformation
 771   =     -- Aha! The default-absorption rule applies
 772     tick CaseMerge      `thenSmpl_`
 773     returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
 774                              (munge_alg_deflt deflt_var inner_deflt)))
 775         -- NB: see comment in this location for the PrimAlts case
 776   where
 777         -- Check scrutinee
 778     scrut_is_var = case scrut of {Var v -> True; other -> False}
 779     scrut_var    = case scrut of Var v -> v
 780
 781         --  Eliminate any inner alts which are shadowed by the outer ones
 782     reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
 783                                 not (con `is_elem` outer_cons)]
 784     outer_cons = [con | (con,_,_) <- outer_alts]
 785     is_elem = isIn "mkAlgAlts"
 786
 787         -- Add the lets if necessary
 788     munged_reduced_inner_alts = map munge_alt reduced_inner_alts
 789
 790     munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
 791        where
 792          v | scrut_is_var = Var scrut_var
 793            | otherwise    = Con con (map TyArg arg_tys ++ map VarArg args)
 794
 795     arg_tys = case (maybeAppDataTyConExpandingDicts (idType deflt_var)) of
 796                 Just (_, arg_tys, _) -> arg_tys
 797
 798 mkCoCase scrut (PrimAlts
 799                   outer_alts
 800                   (BindDefault deflt_var (Case
 801                                               (Var scrut_var')
 802                                               (PrimAlts inner_alts inner_deflt))))
 803   | (scrut_is_var && scrut_var == scrut_var') ||
 804     deflt_var == scrut_var'
 805   =     -- Aha! The default-absorption rule applies
 806     tick CaseMerge      `thenSmpl_`
 807     returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
 808                              (munge_prim_deflt deflt_var inner_deflt)))
 809
 810         -- Nota Bene: we don't recurse to mkCoCase again, because the
 811         -- default will now have a binding in it that prevents
 812         -- mkCoCase doing anything useful.  Much worse, in this
 813         -- PrimAlts case the binding in the default branch is another
 814         -- Case, so if we recurse to mkCoCase we will get into an
 815         -- infinite loop.
 816         --
 817         -- ToDo: think of a better way to do this.  At the moment
 818         -- there is at most one case merge per round.  That's probably
 819         -- plenty but it seems unclean somehow.
 820   where
 821         -- Check scrutinee
 822     scrut_is_var = case scrut of {Var v -> True; other -> False}
 823     scrut_var    = case scrut of Var v -> v
 824
 825         --  Eliminate any inner alts which are shadowed by the outer ones
 826     reduced_inner_alts = [alt | alt@(lit,_) <- inner_alts,
 827                                 not (lit `is_elem` outer_lits)]
 828     outer_lits = [lit | (lit,_) <- outer_alts]
 829     is_elem = isIn "mkPrimAlts"
 830
 831         -- Add the lets (well cases actually) if necessary
 832         -- The munged alternative looks like
 833         --      lit -> case lit of d -> rhs
 834         -- The next pass will certainly eliminate the inner case, but
 835         -- it isn't easy to do so right away.
 836     munged_reduced_inner_alts = map munge_alt reduced_inner_alts
 837
 838     munge_alt (lit, rhs)
 839       | scrut_is_var = (lit, Case (Var scrut_var)
 840                                     (PrimAlts [] (BindDefault deflt_var rhs)))
 841       | otherwise = (lit, Case (Lit lit)
 842                                  (PrimAlts [] (BindDefault deflt_var rhs)))
 843 \end{code}
 844
 845 Now the identity-case transformation:
 846
 847         case e of               ===> e
 848                 True -> True;
 849                 False -> False
 850
 851 and similar friends.
 852
 853 \begin{code}
 854 mkCoCase scrut alts
 855   | identity_alts alts
 856   = tick CaseIdentity           `thenSmpl_`
 857     returnSmpl scrut
 858   where
 859     identity_alts (AlgAlts alts deflt)  = all identity_alg_alt  alts && identity_deflt deflt
 860     identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
 861
 862     identity_alg_alt (con, args, Con con' args')
 863          = con == con'
 864            && and (zipWith eq_arg args args')
 865            && length args == length args'
 866     identity_alg_alt other
 867          = False
 868
 869     identity_prim_alt (lit, Lit lit') = lit == lit'
 870     identity_prim_alt other            = False
 871
 872          -- For the default case we want to spot both
 873          --     x -> x
 874          -- and
 875          --     case y of { ... ; x -> y }
 876          -- as "identity" defaults
 877     identity_deflt NoDefault = True
 878     identity_deflt (BindDefault binder (Var x)) = x == binder ||
 879                                                       case scrut of
 880                                                          Var y -> y == x
 881                                                          other   -> False
 882     identity_deflt _ = False
 883
 884     eq_arg binder (VarArg x) = binder == x
 885     eq_arg _      _            = False
 886 \end{code}
 887
 888 The catch-all case
 889
 890 \begin{code}
 891 mkCoCase other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
 892 \end{code}
 893
 894 Boring local functions used above.  They simply introduce a trivial binding
 895 for the binder, d', in an inner default; either
 896         let d' = deflt_var in rhs
 897 or
 898         case deflt_var of d' -> rhs
 899 depending on whether it's an algebraic or primitive case.
 900
 901 \begin{code}
 902 munge_prim_deflt _ NoDefault = NoDefault
 903
 904 munge_prim_deflt deflt_var (BindDefault d' rhs)
 905   =   BindDefault deflt_var (Case (Var deflt_var)
 906                                       (PrimAlts [] (BindDefault d' rhs)))
 907
 908 munge_alg_deflt _ NoDefault = NoDefault
 909
 910 munge_alg_deflt deflt_var (BindDefault d' rhs)
 911   =   BindDefault deflt_var (Let (NonRec d' (Var deflt_var)) rhs)
 912
 913 -- This line caused a generic version of munge_deflt (ie one used for
 914 -- both alg and prim) to space leak massively.  No idea why.
 915 --  = BindDefault deflt_var (mkCoLetUnboxedToCase (NonRec d' (Var deflt_var)) rhs)
 916 \end{code}
 917
 918 \begin{code}
 919 cheap_eq :: InExpr -> InExpr -> Bool
 920         -- A cheap equality test which bales out fast!
 921
 922 cheap_eq (Var v1) (Var v2) = v1==v2
 923 cheap_eq (Lit l1) (Lit l2) = l1==l2
 924 cheap_eq (Con con1 args1) (Con con2 args2)
 925   = con1 == con2 && args1 `eq_args` args2
 926
 927 cheap_eq (Prim op1 args1) (Prim op2 args2)
 928   = op1 ==op2 && args1 `eq_args` args2
 929
 930 cheap_eq (App f1 a1) (App f2 a2)
 931   = f1 `cheap_eq` f2 && a1 `eq_arg` a2
 932
 933 cheap_eq _ _ = False
 934
 935 -- ToDo: make CoreArg an instance of Eq
 936 eq_args (a1:as1) (a2:as2) = a1 `eq_arg` a2 && as1 `eq_args` as2
 937 eq_args []       []       = True
 938 eq_args _        _        = False
 939
 940 eq_arg (LitArg   l1) (LitArg   l2) = l1 == l2
 941 eq_arg (VarArg   v1) (VarArg   v2) = v1 == v2
 942 eq_arg (TyArg    t1) (TyArg    t2) = t1 `eqTy` t2
 943 eq_arg (UsageArg u1) (UsageArg u2) = u1 == u2
 944 eq_arg _             _             =  False
 945 \end{code}