ghc/compiler/deSugar/DsBinds.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[DsBinds]{Pattern-matching bindings (HsBinds and MonoBinds)}
   5
   6 Handles @HsBinds@; those at the top level require different handling,
   7 in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
   8 lower levels it is preserved with @let@/@letrec@s).
   9
  10 \begin{code}
  11 #include "HsVersions.h"
  12
  13 module DsBinds ( dsBinds, dsInstBinds ) where
  14
  15 IMP_Ubiq()
  16 IMPORT_DELOOPER(DsLoop)         -- break dsExpr-ish loop
  17
  18 import HsSyn            -- lots of things
  19                         hiding ( collectBinders{-also in CoreSyn-} )
  20 import CoreSyn          -- lots of things
  21 import TcHsSyn          ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
  22                           TypecheckedBind(..), TypecheckedMonoBinds(..),
  23                           TypecheckedPat(..)
  24                         )
  25 import DsHsSyn          ( collectTypedBinders, collectTypedPatBinders )
  26
  27 import DsMonad
  28 import DsGRHSs          ( dsGuarded )
  29 import DsUtils
  30 import Match            ( matchWrapper )
  31
  32 import CmdLineOpts      ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, opt_CompilingGhcInternals )
  33 import CostCentre       ( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre )
  34 import Id               ( idType, SYN_IE(DictVar), GenId )
  35 import ListSetOps       ( minusList, intersectLists )
  36 import Name             ( isExported )
  37 import PprType          ( GenType )
  38 import PprStyle         ( PprStyle(..) )
  39 import Pretty           ( ppShow )
  40 import Type             ( mkTyVarTys, mkForAllTys, splitSigmaTy,
  41                           tyVarsOfType, tyVarsOfTypes
  42                         )
  43 import TyVar            ( tyVarSetToList, GenTyVar{-instance Eq-} )
  44 import Util             ( isIn, panic, pprTrace{-ToDo:rm-} )
  45 import PprCore--ToDo:rm
  46 import PprType          ( GenTyVar ) --ToDo:rm
  47 import Usage--ToDo:rm
  48 import Unique--ToDo:rm
  49
  50 isDictTy = panic "DsBinds.isDictTy"
  51 \end{code}
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be
  60 that some of the binders are of unboxed type.  This is sorted out when
  61 the caller wraps the bindings round an expression.
  62
  63 \begin{code}
  64 dsBinds :: Bool -> TypecheckedHsBinds -> DsM [CoreBinding]
  65 \end{code}
  66
  67 All ``real'' bindings are expressed in terms of the
  68 @AbsBinds@ construct, which is a massively-complicated ``shorthand'',
  69 and its desugaring is the subject of section~9.1 in the static
  70 semantics paper.
  71
  72 (ToDo)  For:
  73 \begin{verbatim}
  74 AbsBinds [a1, ... ,aj]  -- type variables
  75          [d1, ... ,dk]  -- dict variables
  76          [(l1,g1), ..., (lm,gm)]        -- overloaded equivs [Id pairs] (later...)
  77          [db1=..., ..., dbn=...]        -- dict binds
  78          [vb1=..., ..., vbm=...]        -- val binds; note: vb_i = l_i
  79 \end{verbatim}
  80 we want to make, in the general case (non-Fozzie translation):
  81 \begin{verbatim}
  82    -- tupler-upper:
  83    tup a1...aj d1...dk =
  84       let <dict-binds>     in
  85       let(rec) <val-binds> in (vb1,...,vbm)    -- NB: == ... in (l1,...,lm)
  86
  87    -- a bunch of selectors:
  88    g1 a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> x1
  89    ...
  90    gm a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> xm
  91 \end{verbatim}
  92 But there are lots of special cases.
  93
  94
  95 %==============================================
  96 \subsubsection{Structure cases}
  97 %==============================================
  98
  99 \begin{code}
 100 dsBinds auto_scc (BindWith _ _)    = panic "dsBinds:BindWith"
 101 dsBinds auto_scc EmptyBinds        = returnDs []
 102 dsBinds auto_scc (SingleBind bind) = dsBind auto_scc [] [] id [] bind
 103
 104 dsBinds auto_scc (ThenBinds  binds_1 binds_2)
 105   = andDs (++) (dsBinds auto_scc binds_1) (dsBinds auto_scc binds_2)
 106 \end{code}
 107
 108
 109 %==============================================
 110 \subsubsection{AbsBind case: no overloading}
 111 %==============================================
 112
 113 Special case: no overloading.
 114 \begin{verbatim}
 115         x1 = e1
 116         x2 = e2
 117 \end{verbatim}
 118 We abstract each wrt the type variables, giving
 119 \begin{verbatim}
 120         x1' = /\tyvars -> e1[x1' tyvars/x1, x2' tyvars/x2]
 121         x2' = /\tyvars -> e2[x1' tyvars/x1, x2' tyvars/x2]
 122 \end{verbatim}
 123 There are some complications.
 124
 125 (i) The @val_binds@ might mention variable not in @local_global_prs@.
 126 In this case we need to make up new polymorphic versions of them.
 127
 128 (ii) Exactly the same applies to any @inst_binds@ which may be
 129 present.  However, here we expect that mostly they will be simple constant
 130 definitions, which don't mention the type variables at all, so making them
 131 polymorphic is really overkill.  @dsInstBinds@ deals with this case.
 132
 133 \begin{code}
 134 dsBinds auto_scc (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
 135   = mapDs mk_poly_private_binder private_binders
 136                                         `thenDs` \ poly_private_binders ->
 137     let
 138         full_local_global_prs = (private_binders `zip` poly_private_binders)
 139                                 ++ local_global_prs
 140     in
 141     listDs [ mkSatTyApp global tyvar_tys `thenDs` \ app ->
 142              returnDs (local, app)
 143            | (local,global) <- full_local_global_prs
 144            ]                             `thenDs` \ env ->
 145
 146 --    pprTrace "AbsBinds1:" (ppr PprDebug env) $
 147
 148     extendEnvDs env (
 149
 150     dsInstBinds tyvars inst_binds       `thenDs` \ (inst_bind_pairs, inst_env) ->
 151     extendEnvDs inst_env                         (
 152
 153     dsBind auto_scc tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds
 154     ))
 155   where
 156         -- "private_binders" is the list of binders in val_binds
 157         -- which don't appear in the local_global_prs list
 158         -- These only really show up in stuff produced from compiling
 159         -- class and instance declarations.
 160         -- We need to add suitable polymorphic versions of them to the
 161         -- local_global_prs.
 162     private_binders = binders `minusList` [local | (local,_) <- local_global_prs]
 163     binders         = collectTypedBinders val_binds
 164     mk_poly_private_binder id = newSysLocalDs (mkForAllTys tyvars (idType id))
 165
 166     tyvar_tys = mkTyVarTys tyvars
 167 \end{code}
 168
 169
 170 %==============================================
 171 \subsubsection{AbsBind case: overloading}
 172 %==============================================
 173
 174 If there is overloading we go for the general case.
 175
 176 We want the global identifiers to be abstracted wrt all types and
 177 dictionaries; and the local identifiers wrt the non-overloaded types.
 178 That is, we try to avoid global scoping of type abstraction. Example
 179
 180         f :: Eq a => a -> [(a,b)] -> b
 181         f = ...f...
 182
 183 Here, f is fully polymorphic in b.  So we generate
 184
 185         f ab d = let    ...dict defns...
 186                  in
 187                  letrec f' b = ...(f' b)...
 188                  in f' b
 189
 190 *Notice* that we don't clone type variables, and *do* make use of
 191 shadowing.  It is possible to do cloning, but it makes the code quite
 192 a bit more complicated, and the simplifier will clone it all anyway.
 193
 194 Why bother with this gloss?  Because it makes it more likely that
 195 the defn of f' can get floated out, notably if f gets specialised
 196 to a particular type for a.
 197
 198 \begin{code}
 199 dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
 200   =     -- If there is any non-overloaded polymorphism, make new locals with
 201         -- appropriate polymorphism
 202     (if null non_overloaded_tyvars
 203      then
 204         -- No non-overloaded polymorphism, so stay with current envt
 205         returnDs (id, [], [])
 206      else
 207         -- Some local, non-overloaded polymorphism
 208         cloneTyVarsDs non_overloaded_tyvars     `thenDs` \ local_tyvars ->
 209
 210         mapDs mk_binder binders                 `thenDs` \ new_binders ->
 211         let
 212             old_new_pairs   = binders `zip` new_binders
 213         in
 214
 215         listDs  [ mkSatTyApp new non_ov_tyvar_tys `thenDs` \ app ->
 216                   returnDs (old, app)
 217                 | (old,new) <- old_new_pairs
 218                 ]                                       `thenDs` \ extra_env ->
 219         let
 220           local_binds = [NonRec old app | (old,app) <- extra_env, old `is_elem` locals]
 221           is_elem     = isIn "dsBinds"
 222         in
 223         returnDs (lookupId old_new_pairs, extra_env, local_binds)
 224     )
 225                 `thenDs` \ (binder_subst_fn, local_env, local_binds) ->
 226
 227 --    pprTrace "AbsBinds:all:" (ppAbove (ppr PprDebug local_binds) (ppr PprDebug local_env)) $
 228
 229     extendEnvDs local_env (
 230
 231       dsInstBinds non_overloaded_tyvars dict_binds      `thenDs` \ (inst_bind_pairs, inst_env) ->
 232
 233       extendEnvDs inst_env               (
 234
 235         dsBind auto_scc non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds
 236     ))                                                  `thenDs` \ core_binds ->
 237
 238     let
 239         tuple_rhs = mkCoLetsAny core_binds  (
 240                     mkCoLetsAny local_binds (
 241                     mkTupleExpr locals   ))
 242     in
 243     mkTupleBind all_tyvars dicts local_global_prs tuple_rhs  `thenDs` \ core_bind_prs ->
 244
 245     returnDs [ NonRec binder rhs | (binder,rhs) <- core_bind_prs ]
 246   where
 247     locals = [local | (local,global) <- local_global_prs]
 248     non_ov_tyvar_tys = mkTyVarTys non_overloaded_tyvars
 249
 250     overloaded_tyvars     = tyVarsOfTypes (map idType dicts)
 251     non_overloaded_tyvars = all_tyvars `minusList` (tyVarSetToList{-????-} overloaded_tyvars)
 252
 253     binders      = collectTypedBinders val_binds
 254     mk_binder id = newSysLocalDs (mkForAllTys non_overloaded_tyvars (idType id))
 255 \end{code}
 256
 257 @mkSatTyApp id tys@ constructs an expression whose value is (id tys).
 258 However, sometimes id takes more type args than are in tys, and the
 259 specialiser hates that, so we have to eta expand, to
 260 @(/\ a b -> id tys a b)@.
 261
 262 \begin{code}
 263 mkSatTyApp :: Id                -- Id to apply to the types
 264            -> [Type]            -- Types to apply it to
 265            -> DsM CoreExpr
 266
 267 mkSatTyApp id [] = returnDs (Var id)
 268
 269 mkSatTyApp id tys
 270   | null tvs
 271   = returnDs ty_app     -- Common case
 272   | otherwise
 273   = newTyVarsDs (drop (length tys) tvs) `thenDs` \ tyvars ->
 274     returnDs (mkTyLam tyvars (mkTyApp ty_app (mkTyVarTys tyvars)))
 275   where
 276     (tvs, theta, tau_ty) = splitSigmaTy (idType id)
 277     ty_app = mkTyApp (Var id) tys
 278 \end{code}
 279
 280 There are several places where we encounter ``inst binds,''
 281 @(Id, TypecheckedHsExpr)@ pairs.  Many of these are ``trivial'' binds
 282 (a var to a var or literal), which we want to substitute away; so we
 283 return both some desugared bindings {\em and} a substitution
 284 environment for the subbed-away ones.
 285
 286 These dictionary bindings are non-recursive, and ordered, so that
 287 later ones may mention earlier ones, but not vice versa.
 288
 289 \begin{code}
 290 dsInstBinds :: [TyVar]                          -- Abstract wrt these
 291             -> [(Id, TypecheckedHsExpr)]        -- From AbsBinds
 292             -> DsM ([(Id,CoreExpr)],    -- Non-trivial bindings
 293                     [(Id,CoreExpr)])    -- Trivial ones to be substituted away
 294
 295 do_nothing    = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
 296 prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
 297
 298 dsInstBinds tyvars [] = returnDs do_nothing
 299
 300 dsInstBinds tyvars ((inst, expr@(HsVar _)) : bs)
 301   = dsExpr expr                         `thenDs` \ rhs ->
 302     let -- Need to apply dsExpr to the variable in case it
 303         -- has a substitution in the current environment
 304         subst_item = (inst, rhs)
 305     in
 306     extendEnvDs [subst_item] (
 307         dsInstBinds tyvars bs
 308     )                                   `thenDs` \ (binds, subst_env) ->
 309     returnDs (binds, subst_item : subst_env)
 310
 311 dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs)
 312   = dsExpr expr                         `thenDs` \ core_lit ->
 313     let
 314         subst_item = (inst, core_lit)
 315     in
 316     extendEnvDs [subst_item]     (
 317         dsInstBinds tyvars bs
 318     )                                   `thenDs` \ (binds, subst_env) ->
 319     returnDs (binds, subst_item : subst_env)
 320
 321 dsInstBinds tyvars ((inst, expr) : bs)
 322   | null abs_tyvars
 323   = dsExpr expr                 `thenDs` \ core_expr ->
 324     ds_dict_cc core_expr        `thenDs` \ dict_expr ->
 325     dsInstBinds tyvars bs       `thenDs` \ (core_rest, subst_env) ->
 326     returnDs ((inst, dict_expr) : core_rest, subst_env)
 327
 328   | otherwise
 329   =     -- Obscure case.
 330         -- The inst mentions the type vars wrt which we are abstracting,
 331         -- so we have to invent a new polymorphic version, and substitute
 332         -- appropriately.
 333         -- This can occur in, for example:
 334         --      leftPoll :: [FeedBack a] -> FeedBack a
 335         --      leftPoll xs = take poll xs
 336         -- Here there is an instance of take at the type of elts of xs,
 337         -- as well as the type of poll.
 338
 339     dsExpr expr                 `thenDs` \ core_expr ->
 340     ds_dict_cc core_expr        `thenDs` \ dict_expr ->
 341     newSysLocalDs poly_inst_ty  `thenDs` \ poly_inst_id ->
 342     let
 343         subst_item = (inst, mkTyApp (Var poly_inst_id) abs_tys)
 344     in
 345     extendEnvDs [subst_item] (
 346         dsInstBinds tyvars bs
 347     )                           `thenDs` \ (core_rest, subst_env) ->
 348     returnDs ((poly_inst_id, mkTyLam abs_tyvars dict_expr) : core_rest,
 349               subst_item : subst_env)
 350   where
 351     inst_ty    = idType inst
 352     abs_tyvars = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars
 353     abs_tys      = mkTyVarTys  abs_tyvars
 354     poly_inst_ty = mkForAllTys abs_tyvars inst_ty
 355
 356     ------------------------
 357     -- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
 358     -- appropriate.  Uses "inst"'s type.
 359
 360        -- if profiling, wrap the dict in "_scc_ DICT <dict>":
 361     ds_dict_cc expr
 362       | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs)
 363             -- the latter is so that -unprof-auto-scc-all adds dict sccs
 364       || not (isDictTy inst_ty)
 365       = returnDs expr   -- that's easy: do nothing
 366
 367       | opt_CompilingGhcInternals
 368       = returnDs (SCC prel_dicts_cc expr)
 369
 370       | otherwise
 371       = getModuleAndGroupDs     `thenDs` \ (mod, grp) ->
 372
 373         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
 374
 375         returnDs (SCC (mkAllDictsCC mod grp False) expr)
 376 \end{code}
 377
 378 %************************************************************************
 379 %*                                                                      *
 380 \subsection[dsBind]{Desugaring a @Bind@}
 381 %*                                                                      *
 382 %************************************************************************
 383
 384 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be that
 385 some of the binders are of unboxed type.
 386
 387 For an explanation of the first three args, see @dsMonoBinds@.
 388
 389 \begin{code}
 390 dsBind  :: Bool                         -- Add auto sccs to binds
 391         -> [TyVar] -> [DictVar]         -- Abstract wrt these
 392         -> (Id -> Id)                   -- Binder substitution
 393         -> [(Id,CoreExpr)]              -- Inst bindings already dealt with
 394         -> TypecheckedBind
 395         -> DsM [CoreBinding]
 396
 397 dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs EmptyBind
 398   = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
 399
 400 dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds)
 401   = dsMonoBinds auto_scc False tyvars dicts binder_subst monobinds   `thenDs` \ val_bind_pairs ->
 402     returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs]
 403
 404 dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
 405   = dsMonoBinds auto_scc True tyvars dicts binder_subst monobinds   `thenDs` \ val_bind_pairs ->
 406     returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)]
 407 \end{code}
 408
 409
 410 %************************************************************************
 411 %*                                                                      *
 412 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
 413 %*                                                                      *
 414 %************************************************************************
 415
 416 @dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @CoreBinds@.
 417 In addition to desugaring pattern matching, @dsMonoBinds@ takes
 418 a list of type variables and dicts, and adds abstractions for these
 419 to the front of every binding.  That requires that the
 420 binders be altered too (their type has changed,
 421 so @dsMonoBinds@ also takes a function which maps binders into binders.
 422 This mapping gives the binder the correct new type.
 423
 424 Remember, there's also a substitution in the monad which maps occurrences
 425 of these binders into applications of the new binder to suitable type variables
 426 and dictionaries.
 427
 428 \begin{code}
 429 dsMonoBinds :: Bool                     -- True <=> add auto sccs
 430             -> Bool                     -- True <=> recursive binding group
 431             -> [TyVar] -> [DictVar]     -- Abstract wrt these
 432             -> (Id -> Id)               -- Binder substitution
 433             -> TypecheckedMonoBinds
 434             -> DsM [(Id,CoreExpr)]
 435 \end{code}
 436
 437
 438
 439 %==============================================
 440 \subsubsection{Structure cases}
 441 %==============================================
 442
 443 \begin{code}
 444 dsMonoBinds auto_scc is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs []
 445
 446 dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (AndMonoBinds  binds_1 binds_2)
 447   = andDs (++) (dsMonoBinds auto_scc is_rec tyvars dicts binder_subst binds_1)
 448                (dsMonoBinds auto_scc is_rec tyvars dicts binder_subst binds_2)
 449 \end{code}
 450
 451
 452 %==============================================
 453 \subsubsection{Simple base cases: function and variable bindings}
 454 %==============================================
 455
 456 \begin{code}
 457 dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (VarMonoBind var expr)
 458   = dsExpr expr         `thenDs` \ core_expr ->
 459     doSccAuto auto_scc [var] core_expr  `thenDs` \ sccd_core_expr ->
 460     returnDs [(binder_subst var, mkLam tyvars dicts sccd_core_expr)]
 461
 462 dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn)
 463   = putSrcLocDs locn    $
 464     let
 465         new_fun      = binder_subst fun
 466         error_string = "function " ++ showForErr fun
 467     in
 468     matchWrapper (FunMatch fun) matches error_string    `thenDs` \ (args, body) ->
 469     doSccAuto auto_scc [fun] body                       `thenDs` \ sccd_body ->
 470     returnDs [(new_fun,
 471                mkLam tyvars (dicts ++ args) sccd_body)]
 472
 473 dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
 474   = putSrcLocDs locn    $
 475     dsGuarded grhss_and_binds           `thenDs` \ body_expr ->
 476     doSccAuto auto_scc [v] body_expr    `thenDs` \ sccd_body_expr ->
 477     returnDs [(binder_subst v, mkLam tyvars dicts sccd_body_expr)]
 478 \end{code}
 479
 480 %==============================================
 481 \subsubsection{The general base case}
 482 %==============================================
 483
 484 Now the general case of a pattern binding.  The monomorphism restriction
 485 should ensure that if there is a non-simple pattern binding in the
 486 group, then there is no overloading involved, so the dictionaries should
 487 be empty.  (Simple pattern bindings were handled above.)
 488 First, the paranoia check.
 489
 490 \begin{code}
 491 dsMonoBinds auto_scc is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn)
 492   = panic "Non-empty dict list in for pattern binding"
 493 \end{code}
 494
 495 We handle three cases for the binding
 496         pat = rhs
 497
 498 \begin{description}
 499 \item[pat has no binders.]
 500 Then all this is dead code and we return an empty binding.
 501
 502 \item[pat has exactly one binder, v.]
 503 Then we can transform to:
 504 \begin{verbatim}
 505         v' = /\ tyvars -> case rhs of { pat -> v }
 506 \end{verbatim}
 507 where \tr{v'} is gotten by looking up \tr{v} in the \tr{binder_subst}.
 508
 509 \item[pat has more than one binder.]
 510 Then we transform to:
 511 \begin{verbatim}
 512         t  = /\ tyvars -> case rhs of { pat -> (v1, ..., vn) }
 513
 514         vi = /\ tyvars -> case (t tyvars) of { (v1, ..., vn) -> vi }
 515 \end{verbatim}
 516 \end{description}
 517
 518 \begin{code}
 519 dsMonoBinds auto_scc is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
 520   = putSrcLocDs locn $
 521
 522     dsGuarded grhss_and_binds                   `thenDs` \ body_expr ->
 523     doSccAuto auto_scc pat_binders body_expr    `thenDs` \ sccd_body_expr ->
 524
 525 {- KILLED by Sansom. 95/05
 526         -- make *sure* there are no primitive types in the pattern
 527     if any_con_w_prim_arg pat then
 528         error ( "ERROR: Pattern-bindings cannot involve unboxed/primitive types!\n\t"
 529              ++ (ppShow 80 (ppr PprForUser pat)) ++ "\n"
 530              ++ "(We apologise for not reporting this more `cleanly')\n" )
 531
 532         -- Check whether the pattern already is a simple tuple; if so,
 533         -- we can just use the rhs directly
 534     else
 535 -}
 536 --  pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug sccd_body_expr) $
 537
 538     mkSelectorBinds tyvars pat
 539         [(binder, binder_subst binder) | binder <- pat_binders]
 540         sccd_body_expr
 541   where
 542     pat_binders = collectTypedPatBinders pat
 543         -- NB For a simple tuple pattern, these binders
 544         -- will appear in the right order!
 545 \end{code}
 546
 547 Wild-card patterns could be made acceptable here, but it involves some
 548 extra work to benefit only rather unusual constructs like
 549 \begin{verbatim}
 550         let (_,a,b) = ... in ...
 551 \end{verbatim}
 552 Better to extend the whole thing for any irrefutable constructor, at least.
 553
 554 %************************************************************************
 555 %*                                                                      *
 556 \subsection[doSccAuto]{Adding automatic sccs}
 557 %*                                                                      *
 558 %************************************************************************
 559
 560 \begin{code}
 561 doSccAuto :: Bool -> [Id] -> CoreExpr -> DsM CoreExpr
 562
 563 doSccAuto False binders core_expr
 564   = returnDs core_expr
 565
 566 doSccAuto True [] core_expr             -- no binders
 567   = returnDs core_expr
 568
 569 doSccAuto True _ core_expr@(SCC _ _)    -- already sccd
 570   = returnDs core_expr
 571
 572 doSccAuto True _ core_expr@(Con _ _)    -- dont bother for simple Con
 573   = returnDs core_expr
 574
 575 doSccAuto True binders core_expr
 576   = let
 577         scc_all    = opt_AutoSccsOnAllToplevs
 578         scc_export = not (null export_binders)
 579
 580         export_binders = filter isExported binders
 581
 582         scc_binder = head (if scc_all then binders else export_binders)
 583     in
 584     if scc_all || scc_export then
 585         getModuleAndGroupDs `thenDs` \ (mod,grp) ->
 586         returnDs (SCC (mkAutoCC scc_binder mod grp IsNotCafCC) core_expr)
 587     else
 588         returnDs core_expr
 589 \end{code}