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