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
  27 import HsSyn            -- lots of things
  28 import CoreSyn          -- lots of things
  29 import MkCore
  30 import CoreUtils
  31 import CoreFVs
  32
  33 import TcHsSyn          ( mkArbitraryType )     -- Mis-placed?
  34 import TcType
  35 import OccurAnal
  36 import CostCentre
  37 import Module
  38 import Id
  39 import 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         ; let (bndrs, body) = collectBinders (occurAnalyseExpr ds_spec_expr)
 336                 -- The occurrence-analysis does two things
 337                 -- (a) identifies unused binders: Note [Unused spec binders]
 338                 -- (b) sorts dict bindings into NonRecs
 339                 --      so they can be inlined by decomposeRuleLhs
 340               mb_lhs = decomposeRuleLhs body
 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 ->
 346
 347           case mb_lhs of
 348             Nothing -> do { warnDs decomp_msg; return Nothing }
 349
 350             Just (_, args) -> do {
 351
 352           f_body <- fix_up (Let mono_bind (Var mono_id))
 353
 354         ; let     local_poly  = setIdNotExported poly_id
 355                         -- Very important to make the 'f' non-exported,
 356                         -- else it won't be inlined!
 357                   spec_id     = mkLocalId spec_name spec_ty
 358                   spec_rhs    = Let (NonRec local_poly poly_f_body) ds_spec_expr
 359                   poly_f_body = mkLams (tvs ++ dicts) f_body
 360
 361                   extra_dict_bndrs = filter isDictId (varSetElems (exprFreeVars ds_spec_expr))
 362                         -- Note [Const rule dicts]
 363
 364                   rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
 365                                 AlwaysActive poly_name
 366                                 (extra_dict_bndrs ++ bndrs) args
 367                                 (mkVarApps (Var spec_id) bndrs)
 368         ; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
 369         } } }
 370   where
 371         -- Bind to Any any of all_ptvs that aren't
 372         -- relevant for this particular function
 373     fix_up body | null void_tvs = return body
 374                 | otherwise     = do { void_tys <- mapM dsMkArbitraryType void_tvs
 375                                      ; return (mkTyApps (mkLams void_tvs body) void_tys) }
 376
 377     void_tvs = all_tvs \\ tvs
 378
 379     dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
 380                                  <+> ptext (sLit "in specialied type:"),
 381                              nest 2 (pprTheta (map get_pred bs))]
 382                        , ptext (sLit "SPECIALISE pragma ignored")]
 383     get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
 384
 385     decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
 386                     2 (ppr spec_expr)
 387
 388 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> DsM (TyVarEnv Type)
 389 -- If any of the tyvars is missing from any of the lists in
 390 -- the second arg, return a binding in the result
 391 mkArbitraryTypeEnv tyvars exports
 392   = go emptyVarEnv exports
 393   where
 394     go env [] = return env
 395     go env ((ltvs, _, _, _) : exports)
 396         = do { env' <- foldlM extend env [tv | tv <- tyvars
 397                                         , not (tv `elem` ltvs)
 398                                         , not (tv `elemVarEnv` env)]
 399              ; go env' exports }
 400
 401     extend env tv = do { ty <- dsMkArbitraryType tv
 402                        ; return (extendVarEnv env tv ty) }
 403
 404
 405 dsMkArbitraryType :: TcTyVar -> DsM Type
 406 dsMkArbitraryType tv = mkArbitraryType warn tv
 407   where
 408     warn span msg = putSrcSpanDs span (warnDs msg)
 409 \end{code}
 410
 411 Note [Unused spec binders]
 412 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 413 Consider
 414         f :: a -> a
 415         {-# SPECIALISE f :: Eq a => a -> a #-}
 416 It's true that this *is* a more specialised type, but the rule
 417 we get is something like this:
 418         f_spec d = f
 419         RULE: f = f_spec d
 420 Note that the rule is bogus, becuase it mentions a 'd' that is
 421 not bound on the LHS!  But it's a silly specialisation anyway, becuase
 422 the constraint is unused.  We could bind 'd' to (error "unused")
 423 but it seems better to reject the program because it's almost certainly
 424 a mistake.  That's what the isDeadBinder call detects.
 425
 426 Note [Const rule dicts]
 427 ~~~~~~~~~~~~~~~~~~~~~~~
 428 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
 429 which is presumably in scope at the function definition site, we can quantify
 430 over it too.  *Any* dict with that type will do.
 431
 432 So for example when you have
 433         f :: Eq a => a -> a
 434         f = <rhs>
 435         {-# SPECIALISE f :: Int -> Int #-}
 436
 437 Then we get the SpecPrag
 438         SpecPrag (f Int dInt) Int
 439
 440 And from that we want the rule
 441
 442         RULE forall dInt. f Int dInt = f_spec
 443         f_spec = let f = <rhs> in f Int dInt
 444
 445
 446
 447 %************************************************************************
 448 %*                                                                      *
 449 \subsection{Adding inline pragmas}
 450 %*                                                                      *
 451 %************************************************************************
 452
 453 \begin{code}
 454 decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr])
 455 -- Returns Nothing if the LHS isn't of the expected shape
 456 decomposeRuleLhs lhs
 457   = go emptyVarEnv (occurAnalyseExpr lhs)       -- Occurrence analysis sorts out the dict
 458                                                 -- bindings so we know if they are recursive
 459   where
 460         -- Substitute dicts in the LHS args, so that there
 461         -- aren't any lets getting in the way
 462         -- Note that we substitute the function too; we might have this as
 463         -- a LHS:       let f71 = M.f Int in f71
 464     go env (Let (NonRec dict rhs) body)
 465         = go (extendVarEnv env dict (simpleSubst env rhs)) body
 466     go env body
 467         = case collectArgs (simpleSubst env body) of
 468             (Var fn, args) -> Just (fn, args)
 469             _              -> Nothing
 470
 471 simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
 472 -- Similar to CoreSubst.substExpr, except that
 473 -- (a) Takes no account of capture; at this point there is no shadowing
 474 -- (b) Can have a GlobalId (imported) in its domain
 475 -- (c) Ids only; no types are substituted
 476 -- (d) Does not insist (as does CoreSubst.lookupIdSubst) that the
 477 --     in-scope set mentions all LocalIds mentioned in the argument of the subst
 478 --
 479 -- (b) and (d) are the reasons we can't use CoreSubst
 480 --
 481 -- (I had a note that (b) is "no longer relevant", and indeed it doesn't
 482 --  look relevant here. Perhaps there was another caller of simpleSubst.)
 483
 484 simpleSubst subst expr
 485   = go expr
 486   where
 487     go (Var v)         = lookupVarEnv subst v `orElse` Var v
 488     go (Cast e co)     = Cast (go e) co
 489     go (Type ty)       = Type ty
 490     go (Lit lit)       = Lit lit
 491     go (App fun arg)   = App (go fun) (go arg)
 492     go (Note note e)   = Note note (go e)
 493     go (Lam bndr body) = Lam bndr (go body)
 494     go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
 495     go (Let (Rec pairs) body)       = Let (Rec (mapSnd go pairs)) (go body)
 496     go (Case scrut bndr ty alts)    = Case (go scrut) bndr ty
 497                                            [(c,bs,go r) | (c,bs,r) <- alts]
 498
 499 addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr)
 500 addInlinePrags prags bndr rhs
 501   = case [inl | L _ (InlinePrag inl) <- prags] of
 502         []      -> (bndr, rhs)
 503         (inl:_) -> addInlineInfo inl bndr rhs
 504
 505 addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
 506 addInlineInfo (Inline phase is_inline) bndr rhs
 507   = (attach_phase bndr phase, wrap_inline is_inline rhs)
 508   where
 509     attach_phase bndr phase
 510         | isAlwaysActive phase = bndr   -- Default phase
 511         | otherwise            = bndr `setInlinePragma` phase
 512
 513     wrap_inline True  body = mkInlineMe body
 514     wrap_inline False body = body
 515 \end{code}
 516
 517
 518 %************************************************************************
 519 %*                                                                      *
 520 \subsection[addAutoScc]{Adding automatic sccs}
 521 %*                                                                      *
 522 %************************************************************************
 523
 524 \begin{code}
 525 data AutoScc = NoSccs
 526              | AddSccs Module (Id -> Bool)
 527 -- The (Id->Bool) says which Ids to add SCCs to
 528
 529 addAutoScc :: AutoScc
 530            -> Id        -- Binder
 531            -> CoreExpr  -- Rhs
 532            -> CoreExpr  -- Scc'd Rhs
 533
 534 addAutoScc NoSccs _ rhs
 535   = rhs
 536 addAutoScc (AddSccs mod add_scc) id rhs
 537   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
 538   | otherwise  = rhs
 539 \end{code}
 540
 541 If profiling and dealing with a dict binding,
 542 wrap the dict in @_scc_ DICT <dict>@:
 543
 544 \begin{code}
 545 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
 546 addDictScc _ rhs = return rhs
 547
 548 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
 549   | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
 550     || not (isDictId var)
 551   = return rhs                          -- That's easy: do nothing
 552
 553   | otherwise
 554   = do (mod, grp) <- getModuleAndGroupDs
 555         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
 556        return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
 557 -}
 558 \end{code}
 559
 560
 561 %************************************************************************
 562 %*                                                                      *
 563                 Desugaring coercions
 564 %*                                                                      *
 565 %************************************************************************
 566
 567
 568 \begin{code}
 569 dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr
 570 dsCoercion WpHole            thing_inside = thing_inside
 571 dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
 572 dsCoercion (WpCast co)       thing_inside = do { expr <- thing_inside
 573                                                ; return (Cast expr co) }
 574 dsCoercion (WpLam id)        thing_inside = do { expr <- thing_inside
 575                                                ; return (Lam id expr) }
 576 dsCoercion (WpTyLam tv)      thing_inside = do { expr <- thing_inside
 577                                                ; return (Lam tv expr) }
 578 dsCoercion (WpApp id)        thing_inside = do { expr <- thing_inside
 579                                                ; return (App expr (Var id)) }
 580 dsCoercion (WpTyApp ty)      thing_inside = do { expr <- thing_inside
 581                                                ; return (App expr (Type ty)) }
 582 dsCoercion WpInline          thing_inside = do { expr <- thing_inside
 583                                                ; return (mkInlineMe expr) }
 584 dsCoercion (WpLet bs)        thing_inside = do { prs <- dsLHsBinds bs
 585                                                ; expr <- thing_inside
 586                                                ; return (Let (Rec prs) expr) }
 587 \end{code}