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 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         ; arby_env <- mkArbitraryTypeEnv tyvars exports
 196         ; let (lg_binds, core_prs') = mapAndUnzip do_one core_prs
 197               bndrs = mkVarSet (map fst core_prs)
 198
 199               add_lets | core_prs `lengthExceeds` 10 = add_some
 200                        | otherwise                   = mkLets lg_binds
 201               add_some rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
 202                                     , b `elemVarSet` fvs] rhs
 203                 where
 204                   fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
 205
 206               env = mkABEnv exports
 207
 208               do_one (lcl_id, rhs)
 209                 | Just (id_tvs, gbl_id, _, prags) <- lookupVarEnv env lcl_id
 210                 = (NonRec lcl_id (mkTyApps (Var gbl_id) (mkTyVarTys id_tvs)),
 211                    addInlinePrags prags gbl_id $
 212                    addAutoScc auto_scc gbl_id  $
 213                    mkLams id_tvs $
 214                    mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
 215                           | tv <- tyvars, not (tv `elem` id_tvs)] $
 216                    add_lets rhs)
 217                 | otherwise
 218                 = (NonRec lcl_id (mkTyApps (Var non_exp_gbl_id) (mkTyVarTys tyvars)),
 219                    (non_exp_gbl_id, mkLams tyvars (add_lets rhs)))
 220                 where
 221                   non_exp_gbl_id = setIdType lcl_id (mkForAllTys tyvars (idType lcl_id))
 222
 223         ; return (core_prs' ++ rest) }
 224
 225         -- Another common case: one exported variable
 226         -- Non-recursive bindings come through this way
 227 dsHsBind auto_scc rest
 228      (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
 229   = ASSERT( all (`elem` tyvars) all_tyvars ) do
 230     core_prs <- ds_lhs_binds NoSccs binds
 231     let
 232         -- Always treat the binds as recursive, because the typechecker
 233         -- makes rather mixed-up dictionary bindings
 234         core_bind = Rec core_prs
 235
 236     mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) prags
 237     let
 238         (spec_binds, rules) = unzip (catMaybes mb_specs)
 239         global' = addIdSpecialisations global rules
 240         rhs'    = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
 241         bind    = addInlinePrags prags global' $ addAutoScc auto_scc global' rhs'
 242
 243     return (bind  : spec_binds ++ rest)
 244
 245 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 246   = do  { core_prs <- ds_lhs_binds NoSccs binds
 247         ; let env = mkABEnv exports
 248               do_one (lcl_id,rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
 249                                   = addInlinePrags prags lcl_id $
 250                                     addAutoScc auto_scc gbl_id rhs
 251                                   | otherwise = (lcl_id,rhs)
 252
 253                 -- Rec because of mixed-up dictionary bindings
 254               core_bind = Rec (map do_one core_prs)
 255
 256               tup_expr      = mkBigCoreVarTup locals
 257               tup_ty        = exprType tup_expr
 258               poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
 259                               Let core_bind tup_expr
 260               locals        = [local | (_, _, local, _) <- exports]
 261               local_tys     = map idType locals
 262
 263         ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
 264
 265         ; let dict_args = map Var dicts
 266
 267               mk_bind ((tyvars, global, local, prags), n)       -- locals !! n == local
 268                 =       -- Need to make fresh locals to bind in the selector, because
 269                         -- some of the tyvars will be bound to 'Any'
 270                   do { ty_args <- mapM mk_ty_arg all_tyvars
 271                      ; let substitute = substTyWith all_tyvars ty_args
 272                      ; locals' <- newSysLocalsDs (map substitute local_tys)
 273                      ; tup_id  <- newSysLocalDs  (substitute tup_ty)
 274                      ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global 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                                  mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
 281                      ; return ((global', rhs) : spec_binds) }
 282                 where
 283                   mk_ty_arg all_tyvar
 284                         | all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar)
 285                         | otherwise               = dsMkArbitraryType all_tyvar
 286
 287         ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
 288              -- don't scc (auto-)annotate the tuple itself.
 289
 290         ; return ((poly_tup_id, poly_tup_expr) :
 291                     (concat export_binds_s ++ rest)) }
 292
 293 mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> VarEnv ([TyVar], Id, Id, [LPrag])
 294 -- Takes the exports of a AbsBinds, and returns a mapping
 295 --      lcl_id -> (tyvars, gbl_id, lcl_id, prags)
 296 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
 297
 298
 299 dsSpec :: [TyVar] -> [DictId] -> [TyVar]
 300        -> Id -> Id              -- Global, local
 301        -> CoreBind -> LPrag
 302        -> DsM (Maybe ((Id,CoreExpr),    -- Binding for specialised Id
 303                       CoreRule))        -- Rule for the Global Id
 304
 305 -- Example:
 306 --      f :: (Eq a, Ix b) => a -> b -> b
 307 --      {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
 308 --
 309 --      AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
 310 --
 311 --      SpecPrag (/\b.\(d:Ix b). f Int b dInt d)
 312 --               (forall b. Ix b => Int -> b -> b)
 313 --
 314 -- Rule:        forall b,(d:Ix b). f Int b dInt d = f_spec b d
 315 --
 316 -- Spec bind:   f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono
 317 --                       /\b.\(d:Ix b). in f Int b dInt d
 318 --              The idea is that f occurs just once, so it'll be
 319 --              inlined and specialised
 320 --
 321 -- Given SpecPrag (/\as.\ds. f es) t, we have
 322 -- the defn             f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = <f-rhs> in f_mono
 323 --                                     in f es
 324 -- and the RULE         forall as, ds. f es = f_spec as ds
 325 --
 326 -- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
 327 -- (a bit silly, because then the
 328 dsSpec _ _ _ _ _ _ (L _ (InlinePrag {}))
 329   = return Nothing
 330
 331 dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
 332        (L loc (SpecPrag spec_expr spec_ty inl))
 333   = putSrcSpanDs loc $
 334     do  { let poly_name = idName poly_id
 335         ; spec_name <- newLocalName poly_name
 336         ; ds_spec_expr  <- dsExpr spec_expr
 337         ; case (decomposeRuleLhs ds_spec_expr) of {
 338             Nothing -> do { warnDs decomp_msg; return Nothing } ;
 339
 340             Just (bndrs, _fn, args) ->
 341
 342         -- Check for dead binders: Note [Unused spec binders]
 343           case filter isDeadBinder bndrs of {
 344                 bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
 345                    | otherwise -> do
 346
 347         { f_body <- fix_up (Let mono_bind (Var mono_id))
 348
 349         ; let     local_poly  = setIdNotExported poly_id
 350                         -- Very important to make the 'f' non-exported,
 351                         -- else it won't be inlined!
 352                   spec_id     = mkLocalId spec_name spec_ty
 353                   spec_rhs    = Let (NonRec local_poly poly_f_body) ds_spec_expr
 354                   poly_f_body = mkLams (tvs ++ dicts) f_body
 355
 356                   extra_dict_bndrs = [localiseId d  -- See Note [Constant rule dicts]
 357                                      | d <- varSetElems (exprFreeVars ds_spec_expr)
 358                                      , isDictId d]
 359                         -- Note [Const rule dicts]
 360
 361                   rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
 362                                 AlwaysActive poly_name
 363                                 (extra_dict_bndrs ++ bndrs) args
 364                                 (mkVarApps (Var spec_id) bndrs)
 365         ; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
 366         } } } }
 367   where
 368         -- Bind to Any any of all_ptvs that aren't
 369         -- relevant for this particular function
 370     fix_up body | null void_tvs = return body
 371                 | otherwise     = do { void_tys <- mapM dsMkArbitraryType void_tvs
 372                                      ; return (mkTyApps (mkLams void_tvs body) void_tys) }
 373
 374     void_tvs = all_tvs \\ tvs
 375
 376     dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
 377                                  <+> ptext (sLit "in specialied type:"),
 378                              nest 2 (pprTheta (map get_pred bs))]
 379                        , ptext (sLit "SPECIALISE pragma ignored")]
 380     get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
 381
 382     decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
 383                     2 (ppr spec_expr)
 384
 385
 386 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> DsM (TyVarEnv Type)
 387 -- If any of the tyvars is missing from any of the lists in
 388 -- the second arg, return a binding in the result
 389 mkArbitraryTypeEnv tyvars exports
 390   = go emptyVarEnv exports
 391   where
 392     go env [] = return env
 393     go env ((ltvs, _, _, _) : exports)
 394         = do { env' <- foldlM extend env [tv | tv <- tyvars
 395                                         , not (tv `elem` ltvs)
 396                                         , not (tv `elemVarEnv` env)]
 397              ; go env' exports }
 398
 399     extend env tv = do { ty <- dsMkArbitraryType tv
 400                        ; return (extendVarEnv env tv ty) }
 401
 402
 403 dsMkArbitraryType :: TcTyVar -> DsM Type
 404 dsMkArbitraryType tv = mkArbitraryType warn tv
 405   where
 406     warn span msg = putSrcSpanDs span (warnDs msg)
 407 \end{code}
 408
 409 Note [Unused spec binders]
 410 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 411 Consider
 412         f :: a -> a
 413         {-# SPECIALISE f :: Eq a => a -> a #-}
 414 It's true that this *is* a more specialised type, but the rule
 415 we get is something like this:
 416         f_spec d = f
 417         RULE: f = f_spec d
 418 Note that the rule is bogus, becuase it mentions a 'd' that is
 419 not bound on the LHS!  But it's a silly specialisation anyway, becuase
 420 the constraint is unused.  We could bind 'd' to (error "unused")
 421 but it seems better to reject the program because it's almost certainly
 422 a mistake.  That's what the isDeadBinder call detects.
 423
 424 Note [Const rule dicts]
 425 ~~~~~~~~~~~~~~~~~~~~~~~
 426 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
 427 which is presumably in scope at the function definition site, we can quantify
 428 over it too.  *Any* dict with that type will do.
 429
 430 So for example when you have
 431         f :: Eq a => a -> a
 432         f = <rhs>
 433         {-# SPECIALISE f :: Int -> Int #-}
 434
 435 Then we get the SpecPrag
 436         SpecPrag (f Int dInt) Int
 437
 438 And from that we want the rule
 439
 440         RULE forall dInt. f Int dInt = f_spec
 441         f_spec = let f = <rhs> in f Int dInt
 442
 443 But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
 444 Name, and you can't bind them in a lambda or forall without getting things
 445 confused. Hence the use of 'localiseId' to make it Internal.
 446
 447
 448 %************************************************************************
 449 %*                                                                      *
 450 \subsection{Adding inline pragmas}
 451 %*                                                                      *
 452 %************************************************************************
 453
 454 \begin{code}
 455 decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
 456 -- Take apart the LHS of a RULE.  It's suuposed to look like
 457 --     /\a. f a Int dOrdInt
 458 -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
 459 -- That is, the RULE binders are lambda-bound
 460 -- Returns Nothing if the LHS isn't of the expected shape
 461 decomposeRuleLhs lhs
 462   = case (decomp emptyVarEnv body) of
 463         Nothing         -> Nothing
 464         Just (fn, args) -> Just (bndrs, fn, args)
 465   where
 466     occ_lhs = occurAnalyseExpr lhs
 467                 -- The occurrence-analysis does two things
 468                 -- (a) identifies unused binders: Note [Unused spec binders]
 469                 -- (b) sorts dict bindings into NonRecs
 470                 --      so they can be inlined by 'decomp'
 471     (bndrs, body) = collectBinders occ_lhs
 472
 473         -- Substitute dicts in the LHS args, so that there
 474         -- aren't any lets getting in the way
 475         -- Note that we substitute the function too; we might have this as
 476         -- a LHS:       let f71 = M.f Int in f71
 477     decomp env (Let (NonRec dict rhs) body)
 478         = decomp (extendVarEnv env dict (simpleSubst env rhs)) body
 479
 480     decomp env (Case scrut bndr ty [(DEFAULT, _, body)])
 481         | isDeadBinder bndr     -- Note [Matching seqId]
 482         = Just (seqId, [Type (idType bndr), Type ty,
 483                         simpleSubst env scrut, simpleSubst env body])
 484
 485     decomp env body
 486         = case collectArgs (simpleSubst env body) of
 487             (Var fn, args) -> Just (fn, args)
 488             _              -> Nothing
 489
 490 simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
 491 -- Similar to CoreSubst.substExpr, except that
 492 -- (a) Takes no account of capture; at this point there is no shadowing
 493 -- (b) Can have a GlobalId (imported) in its domain
 494 -- (c) Ids only; no types are substituted
 495 -- (d) Does not insist (as does CoreSubst.lookupIdSubst) that the
 496 --     in-scope set mentions all LocalIds mentioned in the argument of the subst
 497 --
 498 -- (b) and (d) are the reasons we can't use CoreSubst
 499 --
 500 -- (I had a note that (b) is "no longer relevant", and indeed it doesn't
 501 --  look relevant here. Perhaps there was another caller of simpleSubst.)
 502
 503 simpleSubst subst expr
 504   = go expr
 505   where
 506     go (Var v)         = lookupVarEnv subst v `orElse` Var v
 507     go (Cast e co)     = Cast (go e) co
 508     go (Type ty)       = Type ty
 509     go (Lit lit)       = Lit lit
 510     go (App fun arg)   = App (go fun) (go arg)
 511     go (Note note e)   = Note note (go e)
 512     go (Lam bndr body) = Lam bndr (go body)
 513     go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
 514     go (Let (Rec pairs) body)       = Let (Rec (mapSnd go pairs)) (go body)
 515     go (Case scrut bndr ty alts)    = Case (go scrut) bndr ty
 516                                            [(c,bs,go r) | (c,bs,r) <- alts]
 517
 518 addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr)
 519 addInlinePrags prags bndr rhs
 520   = case [inl | L _ (InlinePrag inl) <- prags] of
 521         []      -> (bndr, rhs)
 522         (inl:_) -> addInlineInfo inl bndr rhs
 523
 524 addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
 525 addInlineInfo (Inline prag is_inline) bndr rhs
 526   = (attach_pragma bndr prag, wrap_inline is_inline rhs)
 527   where
 528     attach_pragma bndr prag
 529         | isDefaultInlinePragma prag = bndr
 530         | otherwise                  = bndr `setInlinePragma` prag
 531
 532     wrap_inline True  body = mkInlineMe body
 533     wrap_inline False body = body
 534 \end{code}
 535
 536 Note [Matching seq]
 537 ~~~~~~~~~~~~~~~~~~~
 538 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
 539 and this code turns it back into an application of seq!
 540 See Note [Rules for seq] in MkId for the details.
 541
 542
 543 %************************************************************************
 544 %*                                                                      *
 545 \subsection[addAutoScc]{Adding automatic sccs}
 546 %*                                                                      *
 547 %************************************************************************
 548
 549 \begin{code}
 550 data AutoScc = NoSccs
 551              | AddSccs Module (Id -> Bool)
 552 -- The (Id->Bool) says which Ids to add SCCs to
 553
 554 addAutoScc :: AutoScc
 555            -> Id        -- Binder
 556            -> CoreExpr  -- Rhs
 557            -> CoreExpr  -- Scc'd Rhs
 558
 559 addAutoScc NoSccs _ rhs
 560   = rhs
 561 addAutoScc (AddSccs mod add_scc) id rhs
 562   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
 563   | otherwise  = rhs
 564 \end{code}
 565
 566 If profiling and dealing with a dict binding,
 567 wrap the dict in @_scc_ DICT <dict>@:
 568
 569 \begin{code}
 570 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
 571 addDictScc _ rhs = return rhs
 572
 573 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
 574   | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
 575     || not (isDictId var)
 576   = return rhs                          -- That's easy: do nothing
 577
 578   | otherwise
 579   = do (mod, grp) <- getModuleAndGroupDs
 580         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
 581        return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
 582 -}
 583 \end{code}
 584
 585
 586 %************************************************************************
 587 %*                                                                      *
 588                 Desugaring coercions
 589 %*                                                                      *
 590 %************************************************************************
 591
 592
 593 \begin{code}
 594 dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr
 595 dsCoercion WpHole            thing_inside = thing_inside
 596 dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
 597 dsCoercion (WpCast co)       thing_inside = do { expr <- thing_inside
 598                                                ; return (Cast expr co) }
 599 dsCoercion (WpLam id)        thing_inside = do { expr <- thing_inside
 600                                                ; return (Lam id expr) }
 601 dsCoercion (WpTyLam tv)      thing_inside = do { expr <- thing_inside
 602                                                ; return (Lam tv expr) }
 603 dsCoercion (WpApp v)         thing_inside
 604            | isTyVar v                    = do { expr <- thing_inside
 605                 {- Probably a coercion var -}  ; return (App expr (Type (mkTyVarTy v))) }
 606            | otherwise                    = do { expr <- thing_inside
 607                 {- An Id -}                    ; return (App expr (Var v)) }
 608 dsCoercion (WpTyApp ty)      thing_inside = do { expr <- thing_inside
 609                                                ; return (App expr (Type ty)) }
 610 dsCoercion WpInline          thing_inside = do { expr <- thing_inside
 611                                                ; return (mkInlineMe expr) }
 612 dsCoercion (WpLet bs)        thing_inside = do { prs <- dsLHsBinds bs
 613                                                ; expr <- thing_inside
 614                                                ; return (Let (Rec prs) expr) }
 615 \end{code}