ghc/compiler/simplCore/SimplCase.lhs

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