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 TcHsSyn  ( mkArbitraryType )     -- Mis-placed?
  35 import TcType
  36 import CostCentre
  37 import Module
  38 import Id
  39 import MkId     ( seqId )
  40 import Var      ( Var, TyVar )
  41 import VarSet
  42 import Rules
  43 import VarEnv
  44 import Type
  45 import Outputable
  46 import SrcLoc
  47 import Maybes
  48 import Bag
  49 import BasicTypes hiding ( TopLevel )
  50 import FastString
  51 import StaticFlags      ( opt_DsMultiTyVar )
  52 import Util             ( mapSnd, mapAndUnzip, lengthExceeds )
  53
  54 import Control.Monad
  55 import Data.List
  56 \end{code}
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 \begin{code}
  65 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
  66 dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
  67
  68 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
  69 dsLHsBinds binds = ds_lhs_binds NoSccs binds
  70
  71
  72 ------------------------
  73 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
  74          -- scc annotation policy (see below)
  75 ds_lhs_binds auto_scc binds =  foldM (dsLHsBind auto_scc) [] (bagToList binds)
  76
  77 dsLHsBind :: AutoScc
  78          -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
  79          -> LHsBind Id
  80          -> DsM [(Id,CoreExpr)] -- Result
  81 dsLHsBind auto_scc rest (L loc bind)
  82   = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
  83
  84 dsHsBind :: AutoScc
  85          -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
  86          -> HsBind Id
  87          -> DsM [(Id,CoreExpr)] -- Result
  88
  89 dsHsBind _ rest (VarBind var expr) = do
  90     core_expr <- dsLExpr expr
  91
  92         -- Dictionary bindings are always VarMonoBinds, so
  93         -- we only need do this here
  94     core_expr' <- addDictScc var core_expr
  95     return ((var, core_expr') : rest)
  96
  97 dsHsBind _ rest (FunBind { fun_id = L _ fun, fun_matches = matches,
  98                                   fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) = do
  99     (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
 100     body' <- mkOptTickBox tick body
 101     rhs <- dsCoercion co_fn (return (mkLams args body'))
 102     return ((fun,rhs) : rest)
 103
 104 dsHsBind _ rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) = do
 105     body_expr <- dsGuarded grhss ty
 106     sel_binds <- mkSelectorBinds pat body_expr
 107     return (sel_binds ++ rest)
 108
 109 {-  Note [Rules and inlining]
 110     ~~~~~~~~~~~~~~~~~~~~~~~~~
 111     Common special case: no type or dictionary abstraction
 112     This is a bit less trivial than you might suppose
 113     The naive way woudl be to desguar to something like
 114         f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
 115         M.f = f_lcl             -- Generated from "exports"
 116     But we don't want that, because if M.f isn't exported,
 117     it'll be inlined unconditionally at every call site (its rhs is
 118     trivial).  That would be ok unless it has RULES, which would
 119     thereby be completely lost.  Bad, bad, bad.
 120
 121     Instead we want to generate
 122         M.f = ...f_lcl...
 123         f_lcl = M.f
 124     Now all is cool. The RULES are attached to M.f (by SimplCore),
 125     and f_lcl is rapidly inlined away.
 126
 127     This does not happen in the same way to polymorphic binds,
 128     because they desugar to
 129         M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
 130     Although I'm a bit worried about whether full laziness might
 131     float the f_lcl binding out and then inline M.f at its call site -}
 132
 133 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
 134   = do  { core_prs <- ds_lhs_binds NoSccs binds
 135         ; let env = mkABEnv exports
 136               do_one (lcl_id, rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
 137                                    = addInlinePrags prags gbl_id $
 138                                      addAutoScc auto_scc gbl_id rhs
 139                                    | otherwise = (lcl_id, rhs)
 140               locals'  = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
 141                         -- Note [Rules and inlining]
 142         ; return (map do_one core_prs ++ locals' ++ rest) }
 143                 -- No Rec needed here (contrast the other AbsBinds cases)
 144                 -- because we can rely on the enclosing dsBind to wrap in Rec
 145
 146
 147 {- Note [Abstracting over tyvars only]
 148    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 149    When abstracting over type variable only (not dictionaries), we don't really need to
 150    built a tuple and select from it, as we do in the general case. Instead we can take
 151
 152         AbsBinds [a,b] [ ([a,b], fg, fl, _),
 153                          ([b],   gg, gl, _) ]
 154                 { fl = e1
 155                   gl = e2
 156                    h = e3 }
 157
 158    and desugar it to
 159
 160         fg = /\ab. let B in e1
 161         gg = /\b. let a = () in let B in S(e2)
 162         h  = /\ab. let B in e3
 163
 164   where B is the *non-recursive* binding
 165         fl = fg a b
 166         gl = gg b
 167         h  = h a b    -- See (b); note shadowing!
 168
 169   Notice (a) g has a different number of type variables to f, so we must
 170              use the mkArbitraryType thing to fill in the gaps.
 171              We use a type-let to do that.
 172
 173          (b) The local variable h isn't in the exports, and rather than
 174              clone a fresh copy we simply replace h by (h a b), where
 175              the two h's have different types!  Shadowing happens here,
 176              which looks confusing but works fine.
 177
 178          (c) The result is *still* quadratic-sized if there are a lot of
 179              small bindings.  So if there are more than some small
 180              number (10), we filter the binding set B by the free
 181              variables of the particular RHS.  Tiresome.
 182
 183   Why got to this trouble?  It's a common case, and it removes the
 184   quadratic-sized tuple desugaring.  Less clutter, hopefullly faster
 185   compilation, especially in a case where there are a *lot* of
 186   bindings.
 187 -}
 188
 189
 190 dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
 191   | opt_DsMultiTyVar    -- This (static) debug flag just lets us
 192                         -- switch on and off this optimisation to
 193                         -- see if it has any impact; it is on by default
 194   =     -- Note [Abstracting over tyvars only]
 195     do  { core_prs <- ds_lhs_binds NoSccs binds
 196         ; arby_env <- mkArbitraryTypeEnv tyvars exports
 197         ; let (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 dict_args = map Var dicts
 267
 268               mk_bind ((tyvars, global, local, prags), n)       -- locals !! n == local
 269                 =       -- Need to make fresh locals to bind in the selector, because
 270                         -- some of the tyvars will be bound to 'Any'
 271                   do { ty_args <- mapM mk_ty_arg all_tyvars
 272                      ; let substitute = substTyWith all_tyvars ty_args
 273                      ; locals' <- newSysLocalsDs (map substitute local_tys)
 274                      ; tup_id  <- newSysLocalDs  (substitute tup_ty)
 275                      ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind)
 276                                          prags
 277                      ; let (spec_binds, rules) = unzip (catMaybes mb_specs)
 278                            global' = addIdSpecialisations global rules
 279                            rhs = mkLams tyvars $ mkLams dicts $
 280                                  mkTupleSelector locals' (locals' !! n) tup_id $
 281                                  mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
 282                      ; return ((global', rhs) : spec_binds) }
 283                 where
 284                   mk_ty_arg all_tyvar
 285                         | all_tyvar `elem` tyvars = return (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         { f_body <- fix_up (Let mono_bind (Var mono_id))
 349
 350         ; let     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 = return body
 372                 | otherwise     = do { void_tys <- mapM dsMkArbitraryType void_tvs
 373                                      ; return (mkTyApps (mkLams void_tvs body) void_tys) }
 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)] -> DsM (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 [] = return env
 394     go env ((ltvs, _, _, _) : exports)
 395         = do { env' <- foldlM extend env [tv | tv <- tyvars
 396                                         , not (tv `elem` ltvs)
 397                                         , not (tv `elemVarEnv` env)]
 398              ; go env' exports }
 399
 400     extend env tv = do { ty <- dsMkArbitraryType tv
 401                        ; return (extendVarEnv env tv ty) }
 402
 403
 404 dsMkArbitraryType :: TcTyVar -> DsM Type
 405 dsMkArbitraryType tv = mkArbitraryType warn tv
 406   where
 407     warn span msg = putSrcSpanDs span (warnDs msg)
 408 \end{code}
 409
 410 Note [Unused spec binders]
 411 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 412 Consider
 413         f :: a -> a
 414         {-# SPECIALISE f :: Eq a => a -> a #-}
 415 It's true that this *is* a more specialised type, but the rule
 416 we get is something like this:
 417         f_spec d = f
 418         RULE: f = f_spec d
 419 Note that the rule is bogus, becuase it mentions a 'd' that is
 420 not bound on the LHS!  But it's a silly specialisation anyway, becuase
 421 the constraint is unused.  We could bind 'd' to (error "unused")
 422 but it seems better to reject the program because it's almost certainly
 423 a mistake.  That's what the isDeadBinder call detects.
 424
 425 Note [Const rule dicts]
 426 ~~~~~~~~~~~~~~~~~~~~~~~
 427 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
 428 which is presumably in scope at the function definition site, we can quantify
 429 over it too.  *Any* dict with that type will do.
 430
 431 So for example when you have
 432         f :: Eq a => a -> a
 433         f = <rhs>
 434         {-# SPECIALISE f :: Int -> Int #-}
 435
 436 Then we get the SpecPrag
 437         SpecPrag (f Int dInt) Int
 438
 439 And from that we want the rule
 440
 441         RULE forall dInt. f Int dInt = f_spec
 442         f_spec = let f = <rhs> in f Int dInt
 443
 444 But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
 445 Name, and you can't bind them in a lambda or forall without getting things
 446 confused. Hence the use of 'localiseId' to make it Internal.
 447
 448
 449 %************************************************************************
 450 %*                                                                      *
 451 \subsection{Adding inline pragmas}
 452 %*                                                                      *
 453 %************************************************************************
 454
 455 \begin{code}
 456 decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
 457 -- Take apart the LHS of a RULE.  It's suuposed to look like
 458 --     /\a. f a Int dOrdInt
 459 -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
 460 -- That is, the RULE binders are lambda-bound
 461 -- Returns Nothing if the LHS isn't of the expected shape
 462 decomposeRuleLhs lhs
 463   = case (decomp emptyVarEnv body) of
 464         Nothing         -> Nothing
 465         Just (fn, args) -> Just (bndrs, fn, args)
 466   where
 467     occ_lhs = occurAnalyseExpr lhs
 468                 -- The occurrence-analysis does two things
 469                 -- (a) identifies unused binders: Note [Unused spec binders]
 470                 -- (b) sorts dict bindings into NonRecs
 471                 --      so they can be inlined by 'decomp'
 472     (bndrs, body) = collectBinders occ_lhs
 473
 474         -- Substitute dicts in the LHS args, so that there
 475         -- aren't any lets getting in the way
 476         -- Note that we substitute the function too; we might have this as
 477         -- a LHS:       let f71 = M.f Int in f71
 478     decomp env (Let (NonRec dict rhs) body)
 479         = decomp (extendVarEnv env dict (simpleSubst env rhs)) body
 480
 481     decomp env (Case scrut bndr ty [(DEFAULT, _, body)])
 482         | isDeadBinder bndr     -- Note [Matching seqId]
 483         = Just (seqId, [Type (idType bndr), Type ty,
 484                         simpleSubst env scrut, simpleSubst env body])
 485
 486     decomp env body
 487         = case collectArgs (simpleSubst env body) of
 488             (Var fn, args) -> Just (fn, args)
 489             _              -> Nothing
 490
 491 simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
 492 -- Similar to CoreSubst.substExpr, except that
 493 -- (a) Takes no account of capture; at this point there is no shadowing
 494 -- (b) Can have a GlobalId (imported) in its domain
 495 -- (c) Ids only; no types are substituted
 496 -- (d) Does not insist (as does CoreSubst.lookupIdSubst) that the
 497 --     in-scope set mentions all LocalIds mentioned in the argument of the subst
 498 --
 499 -- (b) and (d) are the reasons we can't use CoreSubst
 500 --
 501 -- (I had a note that (b) is "no longer relevant", and indeed it doesn't
 502 --  look relevant here. Perhaps there was another caller of simpleSubst.)
 503
 504 simpleSubst subst expr
 505   = go expr
 506   where
 507     go (Var v)         = lookupVarEnv subst v `orElse` Var v
 508     go (Cast e co)     = Cast (go e) co
 509     go (Type ty)       = Type ty
 510     go (Lit lit)       = Lit lit
 511     go (App fun arg)   = App (go fun) (go arg)
 512     go (Note note e)   = Note note (go e)
 513     go (Lam bndr body) = Lam bndr (go body)
 514     go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
 515     go (Let (Rec pairs) body)       = Let (Rec (mapSnd go pairs)) (go body)
 516     go (Case scrut bndr ty alts)    = Case (go scrut) bndr ty
 517                                            [(c,bs,go r) | (c,bs,r) <- alts]
 518
 519 addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr)
 520 addInlinePrags prags bndr rhs
 521   = case [inl | L _ (InlinePrag inl) <- prags] of
 522         []      -> (bndr, rhs)
 523         (inl:_) -> addInlineInfo inl bndr rhs
 524
 525 addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
 526 addInlineInfo (Inline prag is_inline) bndr rhs
 527   = (attach_pragma bndr prag, wrap_inline is_inline rhs)
 528   where
 529     attach_pragma bndr prag
 530         | isDefaultInlinePragma prag = bndr
 531         | otherwise                  = bndr `setInlinePragma` prag
 532
 533     wrap_inline True  body = mkInlineMe body
 534     wrap_inline False body = body
 535 \end{code}
 536
 537 Note [Matching seq]
 538 ~~~~~~~~~~~~~~~~~~~
 539 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
 540 and this code turns it back into an application of seq!
 541 See Note [Rules for seq] in MkId for the details.
 542
 543
 544 %************************************************************************
 545 %*                                                                      *
 546 \subsection[addAutoScc]{Adding automatic sccs}
 547 %*                                                                      *
 548 %************************************************************************
 549
 550 \begin{code}
 551 data AutoScc = NoSccs
 552              | AddSccs Module (Id -> Bool)
 553 -- The (Id->Bool) says which Ids to add SCCs to
 554
 555 addAutoScc :: AutoScc
 556            -> Id        -- Binder
 557            -> CoreExpr  -- Rhs
 558            -> CoreExpr  -- Scc'd Rhs
 559
 560 addAutoScc NoSccs _ rhs
 561   = rhs
 562 addAutoScc (AddSccs mod add_scc) id rhs
 563   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
 564   | otherwise  = rhs
 565 \end{code}
 566
 567 If profiling and dealing with a dict binding,
 568 wrap the dict in @_scc_ DICT <dict>@:
 569
 570 \begin{code}
 571 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
 572 addDictScc _ rhs = return rhs
 573
 574 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
 575   | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
 576     || not (isDictId var)
 577   = return rhs                          -- That's easy: do nothing
 578
 579   | otherwise
 580   = do (mod, grp) <- getModuleAndGroupDs
 581         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
 582        return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
 583 -}
 584 \end{code}
 585
 586
 587 %************************************************************************
 588 %*                                                                      *
 589                 Desugaring coercions
 590 %*                                                                      *
 591 %************************************************************************
 592
 593
 594 \begin{code}
 595 dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr
 596 dsCoercion WpHole            thing_inside = thing_inside
 597 dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
 598 dsCoercion (WpCast co)       thing_inside = do { expr <- thing_inside
 599                                                ; return (Cast expr co) }
 600 dsCoercion (WpLam id)        thing_inside = do { expr <- thing_inside
 601                                                ; return (Lam id expr) }
 602 dsCoercion (WpTyLam tv)      thing_inside = do { expr <- thing_inside
 603                                                ; return (Lam tv expr) }
 604 dsCoercion (WpApp v)         thing_inside
 605            | isTyVar v                    = do { expr <- thing_inside
 606                 {- Probably a coercion var -}  ; return (App expr (Type (mkTyVarTy v))) }
 607            | otherwise                    = do { expr <- thing_inside
 608                 {- An Id -}                    ; return (App expr (Var v)) }
 609 dsCoercion (WpTyApp ty)      thing_inside = do { expr <- thing_inside
 610                                                ; return (App expr (Type ty)) }
 611 dsCoercion WpInline          thing_inside = do { expr <- thing_inside
 612                                                ; return (mkInlineMe expr) }
 613 dsCoercion (WpLet bs)        thing_inside = do { prs <- dsLHsBinds bs
 614                                                ; expr <- thing_inside
 615                                                ; return (Let (Rec prs) expr) }
 616 \end{code}