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