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 Var      ( Var, TyVar )
  40 import VarSet
  41 import Rules
  42 import VarEnv
  43 import Type
  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
 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).
 174
 175          (c) The result is *still* quadratic-sized if there are a lot of
 176              small bindings.  So if there are more than some small
 177              number (10), we filter the binding set B by the free
 178              variables of the particular RHS.  Tiresome.
 179
 180   Why got to this trouble?  It's a common case, and it removes the
 181   quadratic-sized tuple desugaring.  Less clutter, hopefullly faster
 182   compilation, especially in a case where there are a *lot* of
 183   bindings.
 184 -}
 185
 186
 187 dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
 188   | opt_DsMultiTyVar    -- This (static) debug flag just lets us
 189                         -- switch on and off this optimisation to
 190                         -- see if it has any impact; it is on by default
 191   =     -- Note [Abstracting over tyvars only]
 192     do  { core_prs <- ds_lhs_binds NoSccs binds
 193         ; arby_env <- mkArbitraryTypeEnv tyvars exports
 194         ; let (lg_binds, core_prs') = mapAndUnzip do_one core_prs
 195               bndrs = mkVarSet (map fst core_prs)
 196
 197               add_lets | core_prs `lengthExceeds` 10 = add_some
 198                        | otherwise                   = mkLets lg_binds
 199               add_some rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
 200                                     , b `elemVarSet` fvs] rhs
 201                 where
 202                   fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
 203
 204               env = mkABEnv exports
 205
 206               do_one (lcl_id, rhs)
 207                 | Just (id_tvs, gbl_id, _, prags) <- lookupVarEnv env lcl_id
 208                 = (NonRec lcl_id (mkTyApps (Var gbl_id) (mkTyVarTys id_tvs)),
 209                    addInlinePrags prags gbl_id $
 210                    addAutoScc auto_scc gbl_id  $
 211                    mkLams id_tvs $
 212                    mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
 213                           | tv <- tyvars, not (tv `elem` id_tvs)] $
 214                    add_lets rhs)
 215                 | otherwise
 216                 = (NonRec lcl_id (mkTyApps (Var non_exp_gbl_id) (mkTyVarTys tyvars)),
 217                    (non_exp_gbl_id, mkLams tyvars (add_lets rhs)))
 218                 where
 219                   non_exp_gbl_id = setIdType lcl_id (mkForAllTys tyvars (idType lcl_id))
 220
 221         ; return (core_prs' ++ rest) }
 222
 223         -- Another common case: one exported variable
 224         -- Non-recursive bindings come through this way
 225 dsHsBind auto_scc rest
 226      (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
 227   = ASSERT( all (`elem` tyvars) all_tyvars ) do
 228     core_prs <- ds_lhs_binds NoSccs binds
 229     let
 230         -- Always treat the binds as recursive, because the typechecker
 231         -- makes rather mixed-up dictionary bindings
 232         core_bind = Rec core_prs
 233
 234     mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) prags
 235     let
 236         (spec_binds, rules) = unzip (catMaybes mb_specs)
 237         global' = addIdSpecialisations global rules
 238         rhs'    = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
 239         bind    = addInlinePrags prags global' $ addAutoScc auto_scc global' rhs'
 240
 241     return (bind  : spec_binds ++ rest)
 242
 243 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 244   = do  { core_prs <- ds_lhs_binds NoSccs binds
 245         ; let env = mkABEnv exports
 246               do_one (lcl_id,rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
 247                                   = addInlinePrags prags lcl_id $
 248                                     addAutoScc auto_scc gbl_id rhs
 249                                   | otherwise = (lcl_id,rhs)
 250
 251                 -- Rec because of mixed-up dictionary bindings
 252               core_bind = Rec (map do_one core_prs)
 253
 254               tup_expr      = mkBigCoreVarTup locals
 255               tup_ty        = exprType tup_expr
 256               poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
 257                               Let core_bind tup_expr
 258               locals        = [local | (_, _, local, _) <- exports]
 259               local_tys     = map idType locals
 260
 261         ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
 262
 263         ; let dict_args = map Var dicts
 264
 265               mk_bind ((tyvars, global, local, prags), n)       -- locals !! n == local
 266                 =       -- Need to make fresh locals to bind in the selector, because
 267                         -- some of the tyvars will be bound to 'Any'
 268                   do { ty_args <- mapM mk_ty_arg all_tyvars
 269                      ; let substitute = substTyWith all_tyvars ty_args
 270                      ; locals' <- newSysLocalsDs (map substitute local_tys)
 271                      ; tup_id  <- newSysLocalDs  (substitute tup_ty)
 272                      ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind)
 273                                          prags
 274                      ; let (spec_binds, rules) = unzip (catMaybes mb_specs)
 275                            global' = addIdSpecialisations global rules
 276                            rhs = mkLams tyvars $ mkLams dicts $
 277                                  mkTupleSelector locals' (locals' !! n) tup_id $
 278                                  mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
 279                      ; return ((global', rhs) : spec_binds) }
 280                 where
 281                   mk_ty_arg all_tyvar
 282                         | all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar)
 283                         | otherwise               = dsMkArbitraryType all_tyvar
 284
 285         ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
 286              -- don't scc (auto-)annotate the tuple itself.
 287
 288         ; return ((poly_tup_id, poly_tup_expr) :
 289                     (concat export_binds_s ++ rest)) }
 290
 291 mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> VarEnv ([TyVar], Id, Id, [LPrag])
 292 -- Takes the exports of a AbsBinds, and returns a mapping
 293 --      lcl_id -> (tyvars, gbl_id, lcl_id, prags)
 294 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
 295
 296
 297 dsSpec :: [TyVar] -> [DictId] -> [TyVar]
 298        -> Id -> Id              -- Global, local
 299        -> CoreBind -> LPrag
 300        -> DsM (Maybe ((Id,CoreExpr),    -- Binding for specialised Id
 301                       CoreRule))        -- Rule for the Global Id
 302
 303 -- Example:
 304 --      f :: (Eq a, Ix b) => a -> b -> b
 305 --      {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
 306 --
 307 --      AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
 308 --
 309 --      SpecPrag (/\b.\(d:Ix b). f Int b dInt d)
 310 --               (forall b. Ix b => Int -> b -> b)
 311 --
 312 -- Rule:        forall b,(d:Ix b). f Int b dInt d = f_spec b d
 313 --
 314 -- Spec bind:   f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono
 315 --                       /\b.\(d:Ix b). in f Int b dInt d
 316 --              The idea is that f occurs just once, so it'll be
 317 --              inlined and specialised
 318 --
 319 -- Given SpecPrag (/\as.\ds. f es) t, we have
 320 -- the defn             f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = <f-rhs> in f_mono
 321 --                                     in f es
 322 -- and the RULE         forall as, ds. f es = f_spec as ds
 323 --
 324 -- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
 325 -- (a bit silly, because then the
 326 dsSpec _ _ _ _ _ _ (L _ (InlinePrag {}))
 327   = return Nothing
 328
 329 dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
 330        (L loc (SpecPrag spec_expr spec_ty inl))
 331   = putSrcSpanDs loc $
 332     do  { let poly_name = idName poly_id
 333         ; spec_name <- newLocalName poly_name
 334         ; ds_spec_expr  <- dsExpr spec_expr
 335         ; case (decomposeRuleLhs ds_spec_expr) of {
 336             Nothing -> do { warnDs decomp_msg; return Nothing } ;
 337
 338             Just (bndrs, _fn, args) ->
 339
 340         -- Check for dead binders: Note [Unused spec binders]
 341           case filter isDeadBinder bndrs of {
 342                 bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
 343                    | otherwise -> do
 344
 345         { f_body <- fix_up (Let mono_bind (Var mono_id))
 346
 347         ; let     local_poly  = setIdNotExported poly_id
 348                         -- Very important to make the 'f' non-exported,
 349                         -- else it won't be inlined!
 350                   spec_id     = mkLocalId spec_name spec_ty
 351                   spec_rhs    = Let (NonRec local_poly poly_f_body) ds_spec_expr
 352                   poly_f_body = mkLams (tvs ++ dicts) f_body
 353
 354                   extra_dict_bndrs = [localiseId d  -- See Note [Constant rule dicts]
 355                                      | d <- varSetElems (exprFreeVars ds_spec_expr)
 356                                      , isDictId d]
 357                         -- Note [Const rule dicts]
 358
 359                   rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
 360                                 AlwaysActive poly_name
 361                                 (extra_dict_bndrs ++ bndrs) args
 362                                 (mkVarApps (Var spec_id) bndrs)
 363         ; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
 364         } } } }
 365   where
 366         -- Bind to Any any of all_ptvs that aren't
 367         -- relevant for this particular function
 368     fix_up body | null void_tvs = return body
 369                 | otherwise     = do { void_tys <- mapM dsMkArbitraryType void_tvs
 370                                      ; return (mkTyApps (mkLams void_tvs body) void_tys) }
 371
 372     void_tvs = all_tvs \\ tvs
 373
 374     dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
 375                                  <+> ptext (sLit "in specialied type:"),
 376                              nest 2 (pprTheta (map get_pred bs))]
 377                        , ptext (sLit "SPECIALISE pragma ignored")]
 378     get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
 379
 380     decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
 381                     2 (ppr spec_expr)
 382
 383
 384 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> DsM (TyVarEnv Type)
 385 -- If any of the tyvars is missing from any of the lists in
 386 -- the second arg, return a binding in the result
 387 mkArbitraryTypeEnv tyvars exports
 388   = go emptyVarEnv exports
 389   where
 390     go env [] = return env
 391     go env ((ltvs, _, _, _) : exports)
 392         = do { env' <- foldlM extend env [tv | tv <- tyvars
 393                                         , not (tv `elem` ltvs)
 394                                         , not (tv `elemVarEnv` env)]
 395              ; go env' exports }
 396
 397     extend env tv = do { ty <- dsMkArbitraryType tv
 398                        ; return (extendVarEnv env tv ty) }
 399
 400
 401 dsMkArbitraryType :: TcTyVar -> DsM Type
 402 dsMkArbitraryType tv = mkArbitraryType warn tv
 403   where
 404     warn span msg = putSrcSpanDs span (warnDs msg)
 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     decomp env body
 478         = case collectArgs (simpleSubst env body) of
 479             (Var fn, args) -> Just (fn, args)
 480             _              -> Nothing
 481
 482 simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
 483 -- Similar to CoreSubst.substExpr, except that
 484 -- (a) Takes no account of capture; at this point there is no shadowing
 485 -- (b) Can have a GlobalId (imported) in its domain
 486 -- (c) Ids only; no types are substituted
 487 -- (d) Does not insist (as does CoreSubst.lookupIdSubst) that the
 488 --     in-scope set mentions all LocalIds mentioned in the argument of the subst
 489 --
 490 -- (b) and (d) are the reasons we can't use CoreSubst
 491 --
 492 -- (I had a note that (b) is "no longer relevant", and indeed it doesn't
 493 --  look relevant here. Perhaps there was another caller of simpleSubst.)
 494
 495 simpleSubst subst expr
 496   = go expr
 497   where
 498     go (Var v)         = lookupVarEnv subst v `orElse` Var v
 499     go (Cast e co)     = Cast (go e) co
 500     go (Type ty)       = Type ty
 501     go (Lit lit)       = Lit lit
 502     go (App fun arg)   = App (go fun) (go arg)
 503     go (Note note e)   = Note note (go e)
 504     go (Lam bndr body) = Lam bndr (go body)
 505     go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
 506     go (Let (Rec pairs) body)       = Let (Rec (mapSnd go pairs)) (go body)
 507     go (Case scrut bndr ty alts)    = Case (go scrut) bndr ty
 508                                            [(c,bs,go r) | (c,bs,r) <- alts]
 509
 510 addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr)
 511 addInlinePrags prags bndr rhs
 512   = case [inl | L _ (InlinePrag inl) <- prags] of
 513         []      -> (bndr, rhs)
 514         (inl:_) -> addInlineInfo inl bndr rhs
 515
 516 addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
 517 addInlineInfo (Inline phase is_inline) bndr rhs
 518   = (attach_phase bndr phase, wrap_inline is_inline rhs)
 519   where
 520     attach_phase bndr phase
 521         | isAlwaysActive phase = bndr   -- Default phase
 522         | otherwise            = bndr `setInlinePragma` phase
 523
 524     wrap_inline True  body = mkInlineMe body
 525     wrap_inline False body = body
 526 \end{code}
 527
 528
 529 %************************************************************************
 530 %*                                                                      *
 531 \subsection[addAutoScc]{Adding automatic sccs}
 532 %*                                                                      *
 533 %************************************************************************
 534
 535 \begin{code}
 536 data AutoScc = NoSccs
 537              | AddSccs Module (Id -> Bool)
 538 -- The (Id->Bool) says which Ids to add SCCs to
 539
 540 addAutoScc :: AutoScc
 541            -> Id        -- Binder
 542            -> CoreExpr  -- Rhs
 543            -> CoreExpr  -- Scc'd Rhs
 544
 545 addAutoScc NoSccs _ rhs
 546   = rhs
 547 addAutoScc (AddSccs mod add_scc) id rhs
 548   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
 549   | otherwise  = rhs
 550 \end{code}
 551
 552 If profiling and dealing with a dict binding,
 553 wrap the dict in @_scc_ DICT <dict>@:
 554
 555 \begin{code}
 556 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
 557 addDictScc _ rhs = return rhs
 558
 559 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
 560   | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
 561     || not (isDictId var)
 562   = return rhs                          -- That's easy: do nothing
 563
 564   | otherwise
 565   = do (mod, grp) <- getModuleAndGroupDs
 566         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
 567        return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
 568 -}
 569 \end{code}
 570
 571
 572 %************************************************************************
 573 %*                                                                      *
 574                 Desugaring coercions
 575 %*                                                                      *
 576 %************************************************************************
 577
 578
 579 \begin{code}
 580 dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr
 581 dsCoercion WpHole            thing_inside = thing_inside
 582 dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
 583 dsCoercion (WpCast co)       thing_inside = do { expr <- thing_inside
 584                                                ; return (Cast expr co) }
 585 dsCoercion (WpLam id)        thing_inside = do { expr <- thing_inside
 586                                                ; return (Lam id expr) }
 587 dsCoercion (WpTyLam tv)      thing_inside = do { expr <- thing_inside
 588                                                ; return (Lam tv expr) }
 589 dsCoercion (WpApp v)         thing_inside
 590            | isTyVar v                    = do { expr <- thing_inside
 591                 {- Probably a coercion var -}  ; return (App expr (Type (mkTyVarTy v))) }
 592            | otherwise                    = do { expr <- thing_inside
 593                 {- An Id -}                    ; return (App expr (Var v)) }
 594 dsCoercion (WpTyApp ty)      thing_inside = do { expr <- thing_inside
 595                                                ; return (App expr (Type ty)) }
 596 dsCoercion WpInline          thing_inside = do { expr <- thing_inside
 597                                                ; return (mkInlineMe expr) }
 598 dsCoercion (WpLet bs)        thing_inside = do { prs <- dsLHsBinds bs
 599                                                ; expr <- thing_inside
 600                                                ; return (Let (Rec prs) expr) }
 601 \end{code}