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