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