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