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