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