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