compiler/deSugar/DsBinds.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Pattern-matching bindings (HsBinds and MonoBinds)
   7
   8 Handles @HsBinds@; those at the top level require different handling,
   9 in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
  10 lower levels it is preserved with @let@/@letrec@s).
  11
  12 \begin{code}
  13 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs,
  14                  dsCoercion,
  15                  AutoScc(..)
  16   ) where
  17
  18 #include "HsVersions.h"
  19
  20 import {-# SOURCE #-}   DsExpr( dsLExpr, dsExpr )
  21 import {-# SOURCE #-}   Match( matchWrapper )
  22
  23 import DsMonad
  24 import DsGRHSs
  25 import DsUtils
  26 import OccurAnal
  27
  28 import HsSyn            -- lots of things
  29 import CoreSyn          -- lots of things
  30 import MkCore
  31 import CoreUtils
  32 import CoreFVs
  33
  34 import TcType
  35 import TysPrim  ( anyTypeOfKind )
  36 import CostCentre
  37 import Module
  38 import Id
  39 import MkId     ( seqId )
  40 import Var      ( Var, TyVar, tyVarKind )
  41 import VarSet
  42 import Rules
  43 import VarEnv
  44 import Outputable
  45 import SrcLoc
  46 import Maybes
  47 import Bag
  48 import BasicTypes hiding ( TopLevel )
  49 import FastString
  50 import StaticFlags      ( opt_DsMultiTyVar )
  51 import Util             ( mapSnd, mapAndUnzip, lengthExceeds )
  52
  53 import Control.Monad
  54 import Data.List
  55 \end{code}
  56
  57 %************************************************************************
  58 %*                                                                      *
  59 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
  60 %*                                                                      *
  61 %************************************************************************
  62
  63 \begin{code}
  64 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
  65 dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
  66
  67 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
  68 dsLHsBinds binds = ds_lhs_binds NoSccs binds
  69
  70
  71 ------------------------
  72 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
  73          -- scc annotation policy (see below)
  74 ds_lhs_binds auto_scc binds =  foldM (dsLHsBind auto_scc) [] (bagToList binds)
  75
  76 dsLHsBind :: AutoScc
  77          -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
  78          -> LHsBind Id
  79          -> DsM [(Id,CoreExpr)] -- Result
  80 dsLHsBind auto_scc rest (L loc bind)
  81   = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
  82
  83 dsHsBind :: AutoScc
  84          -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
  85          -> HsBind Id
  86          -> DsM [(Id,CoreExpr)] -- Result
  87
  88 dsHsBind _ rest (VarBind var expr) = do
  89     core_expr <- dsLExpr expr
  90
  91         -- Dictionary bindings are always VarMonoBinds, so
  92         -- we only need do this here
  93     core_expr' <- addDictScc var core_expr
  94     return ((var, core_expr') : rest)
  95
  96 dsHsBind _ rest (FunBind { fun_id = L _ fun, fun_matches = matches,
  97                                   fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) = do
  98     (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
  99     body' <- mkOptTickBox tick body
 100     rhs <- dsCoercion co_fn (return (mkLams args body'))
 101     return ((fun,rhs) : rest)
 102
 103 dsHsBind _ rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) = do
 104     body_expr <- dsGuarded grhss ty
 105     sel_binds <- mkSelectorBinds pat body_expr
 106     return (sel_binds ++ rest)
 107
 108 {-  Note [Rules and inlining]
 109     ~~~~~~~~~~~~~~~~~~~~~~~~~
 110     Common special case: no type or dictionary abstraction
 111     This is a bit less trivial than you might suppose
 112     The naive way woudl be to desguar to something like
 113         f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
 114         M.f = f_lcl             -- Generated from "exports"
 115     But we don't want that, because if M.f isn't exported,
 116     it'll be inlined unconditionally at every call site (its rhs is
 117     trivial).  That would be ok unless it has RULES, which would
 118     thereby be completely lost.  Bad, bad, bad.
 119
 120     Instead we want to generate
 121         M.f = ...f_lcl...
 122         f_lcl = M.f
 123     Now all is cool. The RULES are attached to M.f (by SimplCore),
 124     and f_lcl is rapidly inlined away.
 125
 126     This does not happen in the same way to polymorphic binds,
 127     because they desugar to
 128         M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
 129     Although I'm a bit worried about whether full laziness might
 130     float the f_lcl binding out and then inline M.f at its call site -}
 131
 132 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
 133   = do  { core_prs <- ds_lhs_binds NoSccs binds
 134         ; let env = mkABEnv exports
 135               do_one (lcl_id, rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
 136                                    = addInlinePrags prags gbl_id $
 137                                      addAutoScc auto_scc gbl_id rhs
 138                                    | otherwise = (lcl_id, rhs)
 139               locals'  = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
 140                         -- Note [Rules and inlining]
 141         ; return (map do_one core_prs ++ locals' ++ rest) }
 142                 -- No Rec needed here (contrast the other AbsBinds cases)
 143                 -- because we can rely on the enclosing dsBind to wrap in Rec
 144
 145
 146 {- Note [Abstracting over tyvars only]
 147    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 148    When abstracting over type variable only (not dictionaries), we don't really need to
 149    built a tuple and select from it, as we do in the general case. Instead we can take
 150
 151         AbsBinds [a,b] [ ([a,b], fg, fl, _),
 152                          ([b],   gg, gl, _) ]
 153                 { fl = e1
 154                   gl = e2
 155                    h = e3 }
 156
 157    and desugar it to
 158
 159         fg = /\ab. let B in e1
 160         gg = /\b. let a = () in let B in S(e2)
 161         h  = /\ab. let B in e3
 162
 163   where B is the *non-recursive* binding
 164         fl = fg a b
 165         gl = gg b
 166         h  = h a b    -- See (b); note shadowing!
 167
 168   Notice (a) g has a different number of type variables to f, so we must
 169              use the mkArbitraryType thing to fill in the gaps.
 170              We use a type-let to do that.
 171
 172          (b) The local variable h isn't in the exports, and rather than
 173              clone a fresh copy we simply replace h by (h a b), where
 174              the two h's have different types!  Shadowing happens here,
 175              which looks confusing but works fine.
 176
 177          (c) The result is *still* quadratic-sized if there are a lot of
 178              small bindings.  So if there are more than some small
 179              number (10), we filter the binding set B by the free
 180              variables of the particular RHS.  Tiresome.
 181
 182   Why got to this trouble?  It's a common case, and it removes the
 183   quadratic-sized tuple desugaring.  Less clutter, hopefullly faster
 184   compilation, especially in a case where there are a *lot* of
 185   bindings.
 186 -}
 187
 188
 189 dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
 190   | opt_DsMultiTyVar    -- This (static) debug flag just lets us
 191                         -- switch on and off this optimisation to
 192                         -- see if it has any impact; it is on by default
 193   =     -- Note [Abstracting over tyvars only]
 194     do  { core_prs <- ds_lhs_binds NoSccs binds
 195         ;
 196         ; let arby_env = mkArbitraryTypeEnv tyvars exports
 197               (lg_binds, core_prs') = mapAndUnzip do_one core_prs
 198               bndrs = mkVarSet (map fst core_prs)
 199
 200               add_lets | core_prs `lengthExceeds` 10 = add_some
 201                        | otherwise                   = mkLets lg_binds
 202               add_some rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
 203                                     , b `elemVarSet` fvs] rhs
 204                 where
 205                   fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
 206
 207               env = mkABEnv exports
 208
 209               do_one (lcl_id, rhs)
 210                 | Just (id_tvs, gbl_id, _, prags) <- lookupVarEnv env lcl_id
 211                 = (NonRec lcl_id (mkTyApps (Var gbl_id) (mkTyVarTys id_tvs)),
 212                    addInlinePrags prags gbl_id $
 213                    addAutoScc auto_scc gbl_id  $
 214                    mkLams id_tvs $
 215                    mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
 216                           | tv <- tyvars, not (tv `elem` id_tvs)] $
 217                    add_lets rhs)
 218                 | otherwise
 219                 = (NonRec lcl_id (mkTyApps (Var non_exp_gbl_id) (mkTyVarTys tyvars)),
 220                    (non_exp_gbl_id, mkLams tyvars (add_lets rhs)))
 221                 where
 222                   non_exp_gbl_id = setIdType lcl_id (mkForAllTys tyvars (idType lcl_id))
 223
 224         ; return (core_prs' ++ rest) }
 225
 226         -- Another common case: one exported variable
 227         -- Non-recursive bindings come through this way
 228 dsHsBind auto_scc rest
 229      (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
 230   = ASSERT( all (`elem` tyvars) all_tyvars ) do
 231     core_prs <- ds_lhs_binds NoSccs binds
 232     let
 233         -- Always treat the binds as recursive, because the typechecker
 234         -- makes rather mixed-up dictionary bindings
 235         core_bind = Rec core_prs
 236
 237     mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) prags
 238     let
 239         (spec_binds, rules) = unzip (catMaybes mb_specs)
 240         global' = addIdSpecialisations global rules
 241         rhs'    = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
 242         bind    = addInlinePrags prags global' $ addAutoScc auto_scc global' rhs'
 243
 244     return (bind  : spec_binds ++ rest)
 245
 246 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 247   = do  { core_prs <- ds_lhs_binds NoSccs binds
 248         ; let env = mkABEnv exports
 249               do_one (lcl_id,rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
 250                                   = addInlinePrags prags lcl_id $
 251                                     addAutoScc auto_scc gbl_id rhs
 252                                   | otherwise = (lcl_id,rhs)
 253
 254                 -- Rec because of mixed-up dictionary bindings
 255               core_bind = Rec (map do_one core_prs)
 256
 257               tup_expr      = mkBigCoreVarTup locals
 258               tup_ty        = exprType tup_expr
 259               poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
 260                               Let core_bind tup_expr
 261               locals        = [local | (_, _, local, _) <- exports]
 262               local_tys     = map idType locals
 263
 264         ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
 265
 266         ; let mk_bind ((tyvars, global, local, prags), n)  -- locals!!n == local
 267                 =       -- Need to make fresh locals to bind in the selector,
 268                         -- because some of the tyvars will be bound to 'Any'
 269                   do { let ty_args = map mk_ty_arg all_tyvars
 270                            substitute = substTyWith all_tyvars ty_args
 271                      ; locals' <- newSysLocalsDs (map substitute local_tys)
 272                      ; tup_id  <- newSysLocalDs  (substitute tup_ty)
 273                      ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global
 274                                          local core_bind)
 275                                          prags
 276                      ; let (spec_binds, rules) = unzip (catMaybes mb_specs)
 277                            global' = addIdSpecialisations global rules
 278                            rhs = mkLams tyvars $ mkLams dicts $
 279                                  mkTupleSelector locals' (locals' !! n) tup_id $
 280                                  mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
 281                                            dicts
 282                      ; return ((global', rhs) : spec_binds) }
 283                 where
 284                   mk_ty_arg all_tyvar
 285                         | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
 286                         | otherwise               = dsMkArbitraryType all_tyvar
 287
 288         ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
 289              -- don't scc (auto-)annotate the tuple itself.
 290
 291         ; return ((poly_tup_id, poly_tup_expr) :
 292                     (concat export_binds_s ++ rest)) }
 293
 294 mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> VarEnv ([TyVar], Id, Id, [LPrag])
 295 -- Takes the exports of a AbsBinds, and returns a mapping
 296 --      lcl_id -> (tyvars, gbl_id, lcl_id, prags)
 297 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
 298
 299
 300 dsSpec :: [TyVar] -> [DictId] -> [TyVar]
 301        -> Id -> Id              -- Global, local
 302        -> CoreBind -> LPrag
 303        -> DsM (Maybe ((Id,CoreExpr),    -- Binding for specialised Id
 304                       CoreRule))        -- Rule for the Global Id
 305
 306 -- Example:
 307 --      f :: (Eq a, Ix b) => a -> b -> b
 308 --      {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
 309 --
 310 --      AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
 311 --
 312 --      SpecPrag (/\b.\(d:Ix b). f Int b dInt d)
 313 --               (forall b. Ix b => Int -> b -> b)
 314 --
 315 -- Rule:        forall b,(d:Ix b). f Int b dInt d = f_spec b d
 316 --
 317 -- Spec bind:   f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono
 318 --                       /\b.\(d:Ix b). in f Int b dInt d
 319 --              The idea is that f occurs just once, so it'll be
 320 --              inlined and specialised
 321 --
 322 -- Given SpecPrag (/\as.\ds. f es) t, we have
 323 -- the defn             f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = <f-rhs> in f_mono
 324 --                                     in f es
 325 -- and the RULE         forall as, ds. f es = f_spec as ds
 326 --
 327 -- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
 328 -- (a bit silly, because then the
 329 dsSpec _ _ _ _ _ _ (L _ (InlinePrag {}))
 330   = return Nothing
 331
 332 dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
 333        (L loc (SpecPrag spec_expr spec_ty inl))
 334   = putSrcSpanDs loc $
 335     do  { let poly_name = idName poly_id
 336         ; spec_name <- newLocalName poly_name
 337         ; ds_spec_expr  <- dsExpr spec_expr
 338         ; case (decomposeRuleLhs ds_spec_expr) of {
 339             Nothing -> do { warnDs decomp_msg; return Nothing } ;
 340
 341             Just (bndrs, _fn, args) ->
 342
 343         -- Check for dead binders: Note [Unused spec binders]
 344           case filter isDeadBinder bndrs of {
 345                 bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
 346                    | otherwise -> do
 347
 348         { let     f_body = fix_up (Let mono_bind (Var mono_id))
 349
 350                   local_poly  = setIdNotExported poly_id
 351                         -- Very important to make the 'f' non-exported,
 352                         -- else it won't be inlined!
 353                   spec_id     = mkLocalId spec_name spec_ty
 354                   spec_rhs    = Let (NonRec local_poly poly_f_body) ds_spec_expr
 355                   poly_f_body = mkLams (tvs ++ dicts) f_body
 356
 357                   extra_dict_bndrs = [localiseId d  -- See Note [Constant rule dicts]
 358                                      | d <- varSetElems (exprFreeVars ds_spec_expr)
 359                                      , isDictId d]
 360                         -- Note [Const rule dicts]
 361
 362                   rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
 363                                 AlwaysActive poly_name
 364                                 (extra_dict_bndrs ++ bndrs) args
 365                                 (mkVarApps (Var spec_id) bndrs)
 366         ; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
 367         } } } }
 368   where
 369         -- Bind to Any any of all_ptvs that aren't
 370         -- relevant for this particular function
 371     fix_up body | null void_tvs = body
 372                 | otherwise     = mkTyApps (mkLams void_tvs body) $
 373                                   map dsMkArbitraryType void_tvs
 374
 375     void_tvs = all_tvs \\ tvs
 376
 377     dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
 378                                  <+> ptext (sLit "in specialied type:"),
 379                              nest 2 (pprTheta (map get_pred bs))]
 380                        , ptext (sLit "SPECIALISE pragma ignored")]
 381     get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
 382
 383     decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
 384                     2 (ppr spec_expr)
 385
 386
 387 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
 388 -- If any of the tyvars is missing from any of the lists in
 389 -- the second arg, return a binding in the result
 390 mkArbitraryTypeEnv tyvars exports
 391   = go emptyVarEnv exports
 392   where
 393     go env [] = env
 394     go env ((ltvs, _, _, _) : exports)
 395         = go env' exports
 396         where
 397           env' = foldl extend env [tv | tv <- tyvars
 398                                       , not (tv `elem` ltvs)
 399                                       , not (tv `elemVarEnv` env)]
 400
 401     extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
 402
 403 dsMkArbitraryType :: TcTyVar -> Type
 404 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
 405 \end{code}
 406
 407 Note [Unused spec binders]
 408 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 409 Consider
 410         f :: a -> a
 411         {-# SPECIALISE f :: Eq a => a -> a #-}
 412 It's true that this *is* a more specialised type, but the rule
 413 we get is something like this:
 414         f_spec d = f
 415         RULE: f = f_spec d
 416 Note that the rule is bogus, becuase it mentions a 'd' that is
 417 not bound on the LHS!  But it's a silly specialisation anyway, becuase
 418 the constraint is unused.  We could bind 'd' to (error "unused")
 419 but it seems better to reject the program because it's almost certainly
 420 a mistake.  That's what the isDeadBinder call detects.
 421
 422 Note [Const rule dicts]
 423 ~~~~~~~~~~~~~~~~~~~~~~~
 424 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
 425 which is presumably in scope at the function definition site, we can quantify
 426 over it too.  *Any* dict with that type will do.
 427
 428 So for example when you have
 429         f :: Eq a => a -> a
 430         f = <rhs>
 431         {-# SPECIALISE f :: Int -> Int #-}
 432
 433 Then we get the SpecPrag
 434         SpecPrag (f Int dInt) Int
 435
 436 And from that we want the rule
 437
 438         RULE forall dInt. f Int dInt = f_spec
 439         f_spec = let f = <rhs> in f Int dInt
 440
 441 But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
 442 Name, and you can't bind them in a lambda or forall without getting things
 443 confused. Hence the use of 'localiseId' to make it Internal.
 444
 445
 446 %************************************************************************
 447 %*                                                                      *
 448 \subsection{Adding inline pragmas}
 449 %*                                                                      *
 450 %************************************************************************
 451
 452 \begin{code}
 453 decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
 454 -- Take apart the LHS of a RULE.  It's suuposed to look like
 455 --     /\a. f a Int dOrdInt
 456 -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
 457 -- That is, the RULE binders are lambda-bound
 458 -- Returns Nothing if the LHS isn't of the expected shape
 459 decomposeRuleLhs lhs
 460   = case (decomp emptyVarEnv body) of
 461         Nothing         -> Nothing
 462         Just (fn, args) -> Just (bndrs, fn, args)
 463   where
 464     occ_lhs = occurAnalyseExpr lhs
 465                 -- The occurrence-analysis does two things
 466                 -- (a) identifies unused binders: Note [Unused spec binders]
 467                 -- (b) sorts dict bindings into NonRecs
 468                 --      so they can be inlined by 'decomp'
 469     (bndrs, body) = collectBinders occ_lhs
 470
 471         -- Substitute dicts in the LHS args, so that there
 472         -- aren't any lets getting in the way
 473         -- Note that we substitute the function too; we might have this as
 474         -- a LHS:       let f71 = M.f Int in f71
 475     decomp env (Let (NonRec dict rhs) body)
 476         = decomp (extendVarEnv env dict (simpleSubst env rhs)) body
 477
 478     decomp env (Case scrut bndr ty [(DEFAULT, _, body)])
 479         | isDeadBinder bndr     -- Note [Matching seqId]
 480         = Just (seqId, [Type (idType bndr), Type ty,
 481                         simpleSubst env scrut, simpleSubst env body])
 482
 483     decomp env body
 484         = case collectArgs (simpleSubst env body) of
 485             (Var fn, args) -> Just (fn, args)
 486             _              -> Nothing
 487
 488 simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
 489 -- Similar to CoreSubst.substExpr, except that
 490 -- (a) Takes no account of capture; at this point there is no shadowing
 491 -- (b) Can have a GlobalId (imported) in its domain
 492 -- (c) Ids only; no types are substituted
 493 -- (d) Does not insist (as does CoreSubst.lookupIdSubst) that the
 494 --     in-scope set mentions all LocalIds mentioned in the argument of the subst
 495 --
 496 -- (b) and (d) are the reasons we can't use CoreSubst
 497 --
 498 -- (I had a note that (b) is "no longer relevant", and indeed it doesn't
 499 --  look relevant here. Perhaps there was another caller of simpleSubst.)
 500
 501 simpleSubst subst expr
 502   = go expr
 503   where
 504     go (Var v)         = lookupVarEnv subst v `orElse` Var v
 505     go (Cast e co)     = Cast (go e) co
 506     go (Type ty)       = Type ty
 507     go (Lit lit)       = Lit lit
 508     go (App fun arg)   = App (go fun) (go arg)
 509     go (Note note e)   = Note note (go e)
 510     go (Lam bndr body) = Lam bndr (go body)
 511     go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
 512     go (Let (Rec pairs) body)       = Let (Rec (mapSnd go pairs)) (go body)
 513     go (Case scrut bndr ty alts)    = Case (go scrut) bndr ty
 514                                            [(c,bs,go r) | (c,bs,r) <- alts]
 515
 516 addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr)
 517 addInlinePrags prags bndr rhs
 518   = case [inl | L _ (InlinePrag inl) <- prags] of
 519         []      -> (bndr, rhs)
 520         (inl:_) -> addInlineInfo inl bndr rhs
 521
 522 addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
 523 addInlineInfo (Inline prag is_inline) bndr rhs
 524   = (attach_pragma bndr prag, wrap_inline is_inline rhs)
 525   where
 526     attach_pragma bndr prag
 527         | isDefaultInlinePragma prag = bndr
 528         | otherwise                  = bndr `setInlinePragma` prag
 529
 530     wrap_inline True  body = mkInlineMe body
 531     wrap_inline False body = body
 532 \end{code}
 533
 534 Note [Matching seq]
 535 ~~~~~~~~~~~~~~~~~~~
 536 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
 537 and this code turns it back into an application of seq!
 538 See Note [Rules for seq] in MkId for the details.
 539
 540
 541 %************************************************************************
 542 %*                                                                      *
 543 \subsection[addAutoScc]{Adding automatic sccs}
 544 %*                                                                      *
 545 %************************************************************************
 546
 547 \begin{code}
 548 data AutoScc = NoSccs
 549              | AddSccs Module (Id -> Bool)
 550 -- The (Id->Bool) says which Ids to add SCCs to
 551
 552 addAutoScc :: AutoScc
 553            -> Id        -- Binder
 554            -> CoreExpr  -- Rhs
 555            -> CoreExpr  -- Scc'd Rhs
 556
 557 addAutoScc NoSccs _ rhs
 558   = rhs
 559 addAutoScc (AddSccs mod add_scc) id rhs
 560   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
 561   | otherwise  = rhs
 562 \end{code}
 563
 564 If profiling and dealing with a dict binding,
 565 wrap the dict in @_scc_ DICT <dict>@:
 566
 567 \begin{code}
 568 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
 569 addDictScc _ rhs = return rhs
 570
 571 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
 572   | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
 573     || not (isDictId var)
 574   = return rhs                          -- That's easy: do nothing
 575
 576   | otherwise
 577   = do (mod, grp) <- getModuleAndGroupDs
 578         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
 579        return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
 580 -}
 581 \end{code}
 582
 583
 584 %************************************************************************
 585 %*                                                                      *
 586                 Desugaring coercions
 587 %*                                                                      *
 588 %************************************************************************
 589
 590
 591 \begin{code}
 592 dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr
 593 dsCoercion WpHole            thing_inside = thing_inside
 594 dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
 595 dsCoercion (WpCast co)       thing_inside = do { expr <- thing_inside
 596                                                ; return (Cast expr co) }
 597 dsCoercion (WpLam id)        thing_inside = do { expr <- thing_inside
 598                                                ; return (Lam id expr) }
 599 dsCoercion (WpTyLam tv)      thing_inside = do { expr <- thing_inside
 600                                                ; return (Lam tv expr) }
 601 dsCoercion (WpApp v)         thing_inside
 602            | isTyVar v                    = do { expr <- thing_inside
 603                 {- Probably a coercion var -}  ; return (App expr (Type (mkTyVarTy v))) }
 604            | otherwise                    = do { expr <- thing_inside
 605                 {- An Id -}                    ; return (App expr (Var v)) }
 606 dsCoercion (WpTyApp ty)      thing_inside = do { expr <- thing_inside
 607                                                ; return (App expr (Type ty)) }
 608 dsCoercion WpInline          thing_inside = do { expr <- thing_inside
 609                                                ; return (mkInlineMe expr) }
 610 dsCoercion (WpLet bs)        thing_inside = do { prs <- dsLHsBinds bs
 611                                                ; expr <- thing_inside
 612                                                ; return (Let (Rec prs) expr) }
 613 \end{code}