ghc/compiler/simplCore/SimplCase.lhs

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