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 CoreUtils
  30 import CoreFVs
  31
  32 import TcHsSyn          ( mkArbitraryType )     -- Mis-placed?
  33 import TcType
  34 import OccurAnal
  35 import CostCentre
  36 import Module
  37 import Id
  38 import Var      ( TyVar )
  39 import VarSet
  40 import Rules
  41 import VarEnv
  42 import Type
  43 import Outputable
  44 import SrcLoc
  45 import Maybes
  46 import Bag
  47 import BasicTypes hiding ( TopLevel )
  48 import FastString
  49 import StaticFlags      ( opt_DsMultiTyVar )
  50 import Util             ( mapSnd, mapAndUnzip, lengthExceeds )
  51
  52 import Control.Monad
  53 import Data.List
  54 \end{code}
  55
  56 %************************************************************************
  57 %*                                                                      *
  58 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
  59 %*                                                                      *
  60 %************************************************************************
  61
  62 \begin{code}
  63 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
  64 dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
  65
  66 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
  67 dsLHsBinds binds = ds_lhs_binds NoSccs binds
  68
  69
  70 ------------------------
  71 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
  72          -- scc annotation policy (see below)
  73 ds_lhs_binds auto_scc binds =  foldM (dsLHsBind auto_scc) [] (bagToList binds)
  74
  75 dsLHsBind :: AutoScc
  76          -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
  77          -> LHsBind Id
  78          -> DsM [(Id,CoreExpr)] -- Result
  79 dsLHsBind auto_scc rest (L loc bind)
  80   = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
  81
  82 dsHsBind :: AutoScc
  83          -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
  84          -> HsBind Id
  85          -> DsM [(Id,CoreExpr)] -- Result
  86
  87 dsHsBind _ rest (VarBind var expr) = do
  88     core_expr <- dsLExpr expr
  89
  90         -- Dictionary bindings are always VarMonoBinds, so
  91         -- we only need do this here
  92     core_expr' <- addDictScc var core_expr
  93     return ((var, core_expr') : rest)
  94
  95 dsHsBind _ rest (FunBind { fun_id = L _ fun, fun_matches = matches,
  96                                   fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) = do
  97     (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
  98     body' <- mkOptTickBox tick body
  99     rhs <- dsCoercion co_fn (return (mkLams args body'))
 100     return ((fun,rhs) : rest)
 101
 102 dsHsBind _ rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) = do
 103     body_expr <- dsGuarded grhss ty
 104     sel_binds <- mkSelectorBinds pat body_expr
 105     return (sel_binds ++ rest)
 106
 107 {-  Note [Rules and inlining]
 108     ~~~~~~~~~~~~~~~~~~~~~~~~~
 109     Common special case: no type or dictionary abstraction
 110     This is a bit less trivial than you might suppose
 111     The naive way woudl be to desguar to something like
 112         f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
 113         M.f = f_lcl             -- Generated from "exports"
 114     But we don't want that, because if M.f isn't exported,
 115     it'll be inlined unconditionally at every call site (its rhs is
 116     trivial).  That would be ok unless it has RULES, which would
 117     thereby be completely lost.  Bad, bad, bad.
 118
 119     Instead we want to generate
 120         M.f = ...f_lcl...
 121         f_lcl = M.f
 122     Now all is cool. The RULES are attached to M.f (by SimplCore),
 123     and f_lcl is rapidly inlined away.
 124
 125     This does not happen in the same way to polymorphic binds,
 126     because they desugar to
 127         M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
 128     Although I'm a bit worried about whether full laziness might
 129     float the f_lcl binding out and then inline M.f at its call site -}
 130
 131 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
 132   = do  { core_prs <- ds_lhs_binds NoSccs binds
 133         ; let env = mkABEnv exports
 134               do_one (lcl_id, rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
 135                                    = addInlinePrags prags gbl_id $
 136                                      addAutoScc auto_scc gbl_id rhs
 137                                    | otherwise = (lcl_id, rhs)
 138               locals'  = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
 139                         -- Note [Rules and inlining]
 140         ; return (map do_one core_prs ++ locals' ++ rest) }
 141                 -- No Rec needed here (contrast the other AbsBinds cases)
 142                 -- because we can rely on the enclosing dsBind to wrap in Rec
 143
 144
 145 {- Note [Abstracting over tyvars only]
 146    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 147    When abstracting over type variable only (not dictionaries), we don't really need to
 148    built a tuple and select from it, as we do in the general case. Instead we can take
 149
 150         AbsBinds [a,b] [ ([a,b], fg, fl, _),
 151                          ([b],   gg, gl, _) ]
 152                 { fl = e1
 153                   gl = e2
 154                    h = e3 }
 155
 156    and desugar it to
 157
 158         fg = /\ab. let B in e1
 159         gg = /\b. let a = () in let B in S(e2)
 160         h  = /\ab. let B in e3
 161
 162   where B is the *non-recursive* binding
 163         fl = fg a b
 164         gl = gg b
 165         h  = h a b
 166
 167   Notice (a) g has a different number of type variables to f, so we must
 168              use the mkArbitraryType thing to fill in the gaps.
 169              We use a type-let to do that.
 170
 171          (b) The local variable h isn't in the exports, and rather than
 172              clone a fresh copy we simply replace h by (h a b).
 173
 174          (c) The result is *still* quadratic-sized if there are a lot of
 175              small bindings.  So if there are more than some small
 176              number (10), we filter the binding set B by the free
 177              variables of the particular RHS.  Tiresome.
 178
 179   Why got to this trouble?  It's a common case, and it removes the
 180   quadratic-sized tuple desugaring.  Less clutter, hopefullly faster
 181   compilation, especially in a case where there are a *lot* of
 182   bindings.
 183 -}
 184
 185
 186 dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
 187   | opt_DsMultiTyVar    -- This (static) debug flag just lets us
 188                         -- switch on and off this optimisation to
 189                         -- see if it has any impact; it is on by default
 190   =     -- Note [Abstracting over tyvars only]
 191     do  { core_prs <- ds_lhs_binds NoSccs binds
 192         ; arby_env <- mkArbitraryTypeEnv tyvars exports
 193         ; let (lg_binds, core_prs') = mapAndUnzip do_one core_prs
 194               bndrs = mkVarSet (map fst core_prs)
 195
 196               add_lets | core_prs `lengthExceeds` 10 = add_some
 197                        | otherwise                   = mkLets lg_binds
 198               add_some rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
 199                                     , b `elemVarSet` fvs] rhs
 200                 where
 201                   fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
 202
 203               env = mkABEnv exports
 204
 205               do_one (lcl_id, rhs)
 206                 | Just (id_tvs, gbl_id, _, prags) <- lookupVarEnv env lcl_id
 207                 = (NonRec lcl_id (mkTyApps (Var gbl_id) (mkTyVarTys id_tvs)),
 208                    addInlinePrags prags gbl_id $
 209                    addAutoScc auto_scc gbl_id  $
 210                    mkLams id_tvs $
 211                    mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
 212                           | tv <- tyvars, not (tv `elem` id_tvs)] $
 213                    add_lets rhs)
 214                 | otherwise
 215                 = (NonRec lcl_id (mkTyApps (Var non_exp_gbl_id) (mkTyVarTys tyvars)),
 216                    (non_exp_gbl_id, mkLams tyvars (add_lets rhs)))
 217                 where
 218                   non_exp_gbl_id = setIdType lcl_id (mkForAllTys tyvars (idType lcl_id))
 219
 220         ; return (core_prs' ++ rest) }
 221
 222         -- Another common case: one exported variable
 223         -- Non-recursive bindings come through this way
 224 dsHsBind auto_scc rest
 225      (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
 226   = ASSERT( all (`elem` tyvars) all_tyvars ) do
 227     core_prs <- ds_lhs_binds NoSccs binds
 228     let
 229         -- Always treat the binds as recursive, because the typechecker
 230         -- makes rather mixed-up dictionary bindings
 231         core_bind = Rec core_prs
 232
 233     mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) prags
 234     let
 235         (spec_binds, rules) = unzip (catMaybes mb_specs)
 236         global' = addIdSpecialisations global rules
 237         rhs'    = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
 238         bind    = addInlinePrags prags global' $ addAutoScc auto_scc global' rhs'
 239
 240     return (bind  : spec_binds ++ rest)
 241
 242 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 243   = do  { core_prs <- ds_lhs_binds NoSccs binds
 244         ; let env = mkABEnv exports
 245               do_one (lcl_id,rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
 246                                   = addInlinePrags prags lcl_id $
 247                                     addAutoScc auto_scc gbl_id rhs
 248                                   | otherwise = (lcl_id,rhs)
 249
 250                 -- Rec because of mixed-up dictionary bindings
 251               core_bind = Rec (map do_one core_prs)
 252
 253               tup_expr      = mkBigCoreVarTup locals
 254               tup_ty        = exprType tup_expr
 255               poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
 256                               Let core_bind tup_expr
 257               locals        = [local | (_, _, local, _) <- exports]
 258               local_tys     = map idType locals
 259
 260         ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
 261
 262         ; let dict_args = map Var dicts
 263
 264               mk_bind ((tyvars, global, local, prags), n)       -- locals !! n == local
 265                 =       -- Need to make fresh locals to bind in the selector, because
 266                         -- some of the tyvars will be bound to 'Any'
 267                   do { ty_args <- mapM mk_ty_arg all_tyvars
 268                      ; let substitute = substTyWith all_tyvars ty_args
 269                      ; locals' <- newSysLocalsDs (map substitute local_tys)
 270                      ; tup_id  <- newSysLocalDs  (substitute tup_ty)
 271                      ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind)
 272                                          prags
 273                      ; let (spec_binds, rules) = unzip (catMaybes mb_specs)
 274                            global' = addIdSpecialisations global rules
 275                            rhs = mkLams tyvars $ mkLams dicts $
 276                                  mkTupleSelector locals' (locals' !! n) tup_id $
 277                                  mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
 278                      ; return ((global', rhs) : spec_binds) }
 279                 where
 280                   mk_ty_arg all_tyvar
 281                         | all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar)
 282                         | otherwise               = dsMkArbitraryType all_tyvar
 283
 284         ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
 285              -- don't scc (auto-)annotate the tuple itself.
 286
 287         ; return ((poly_tup_id, poly_tup_expr) :
 288                     (concat export_binds_s ++ rest)) }
 289
 290 mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> VarEnv ([TyVar], Id, Id, [LPrag])
 291 -- Takes the exports of a AbsBinds, and returns a mapping
 292 --      lcl_id -> (tyvars, gbl_id, lcl_id, prags)
 293 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
 294
 295
 296 dsSpec :: [TyVar] -> [DictId] -> [TyVar]
 297        -> Id -> Id              -- Global, local
 298        -> CoreBind -> LPrag
 299        -> DsM (Maybe ((Id,CoreExpr),    -- Binding for specialised Id
 300                       CoreRule))        -- Rule for the Global Id
 301
 302 -- Example:
 303 --      f :: (Eq a, Ix b) => a -> b -> b
 304 --      {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
 305 --
 306 --      AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
 307 --
 308 --      SpecPrag (/\b.\(d:Ix b). f Int b dInt d)
 309 --               (forall b. Ix b => Int -> b -> b)
 310 --
 311 -- Rule:        forall b,(d:Ix b). f Int b dInt d = f_spec b d
 312 --
 313 -- Spec bind:   f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono
 314 --                       /\b.\(d:Ix b). in f Int b dInt d
 315 --              The idea is that f occurs just once, so it'll be
 316 --              inlined and specialised
 317 --
 318 -- Given SpecPrag (/\as.\ds. f es) t, we have
 319 -- the defn             f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = <f-rhs> in f_mono
 320 --                                     in f es
 321 -- and the RULE         forall as, ds. f es = f_spec as ds
 322 --
 323 -- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
 324 -- (a bit silly, because then the
 325 dsSpec _ _ _ _ _ _ (L _ (InlinePrag {}))
 326   = return Nothing
 327
 328 dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
 329        (L loc (SpecPrag spec_expr spec_ty inl))
 330   = putSrcSpanDs loc $
 331     do  { let poly_name = idName poly_id
 332         ; spec_name <- newLocalName poly_name
 333         ; ds_spec_expr  <- dsExpr spec_expr
 334         ; let (bndrs, body) = collectBinders (occurAnalyseExpr ds_spec_expr)
 335                 -- The occurrence-analysis does two things
 336                 -- (a) identifies unused binders: Note [Unused spec binders]
 337                 -- (b) sorts dict bindings into NonRecs
 338                 --      so they can be inlined by decomposeRuleLhs
 339               mb_lhs = decomposeRuleLhs body
 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 ->
 345
 346           case mb_lhs of
 347             Nothing -> do { warnDs decomp_msg; return Nothing }
 348
 349             Just (_, args) -> do
 350
 351         { f_body <- fix_up (Let mono_bind (Var mono_id))
 352
 353         ; let     local_poly  = setIdNotExported poly_id
 354                         -- Very important to make the 'f' non-exported,
 355                         -- else it won't be inlined!
 356                   spec_id     = mkLocalId spec_name spec_ty
 357                   spec_rhs    = Let (NonRec local_poly poly_f_body) ds_spec_expr
 358                   poly_f_body = mkLams (tvs ++ dicts) f_body
 359
 360                   extra_dict_bndrs = filter isDictId (varSetElems (exprFreeVars ds_spec_expr))
 361                         -- Note [Const rule dicts]
 362
 363                   rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
 364                                 AlwaysActive poly_name
 365                                 (extra_dict_bndrs ++ bndrs) args
 366                                 (mkVarApps (Var spec_id) bndrs)
 367         ; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
 368         } } }
 369   where
 370         -- Bind to Any any of all_ptvs that aren't
 371         -- relevant for this particular function
 372     fix_up body | null void_tvs = return body
 373                 | otherwise     = do { void_tys <- mapM dsMkArbitraryType void_tvs
 374                                      ; return (mkTyApps (mkLams void_tvs body) void_tys) }
 375
 376     void_tvs = all_tvs \\ tvs
 377
 378     dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
 379                                  <+> ptext (sLit "in specialied type:"),
 380                              nest 2 (pprTheta (map get_pred bs))]
 381                        , ptext (sLit "SPECIALISE pragma ignored")]
 382     get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
 383
 384     decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
 385                     2 (ppr spec_expr)
 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
 445
 446 %************************************************************************
 447 %*                                                                      *
 448 \subsection{Adding inline pragmas}
 449 %*                                                                      *
 450 %************************************************************************
 451
 452 \begin{code}
 453 decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr])
 454 -- Returns Nothing if the LHS isn't of the expected shape
 455 decomposeRuleLhs lhs
 456   = go emptyVarEnv (occurAnalyseExpr lhs)       -- Occurrence analysis sorts out the dict
 457                                                 -- bindings so we know if they are recursive
 458   where
 459         -- Substitute dicts in the LHS args, so that there
 460         -- aren't any lets getting in the way
 461         -- Note that we substitute the function too; we might have this as
 462         -- a LHS:       let f71 = M.f Int in f71
 463     go env (Let (NonRec dict rhs) body)
 464         = go (extendVarEnv env dict (simpleSubst env rhs)) body
 465     go env body
 466         = case collectArgs (simpleSubst env body) of
 467             (Var fn, args) -> Just (fn, args)
 468             _              -> Nothing
 469
 470 simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
 471 -- Similar to CoreSubst.substExpr, except that
 472 -- (a) Takes no account of capture; at this point there is no shadowing
 473 -- (b) Can have a GlobalId (imported) in its domain
 474 -- (c) Ids only; no types are substituted
 475 -- (d) Does not insist (as does CoreSubst.lookupIdSubst) that the
 476 --     in-scope set mentions all LocalIds mentioned in the argument of the subst
 477 --
 478 -- (b) and (d) are the reasons we can't use CoreSubst
 479 --
 480 -- (I had a note that (b) is "no longer relevant", and indeed it doesn't
 481 --  look relevant here. Perhaps there was another caller of simpleSubst.)
 482
 483 simpleSubst subst expr
 484   = go expr
 485   where
 486     go (Var v)         = lookupVarEnv subst v `orElse` Var v
 487     go (Cast e co)     = Cast (go e) co
 488     go (Type ty)       = Type ty
 489     go (Lit lit)       = Lit lit
 490     go (App fun arg)   = App (go fun) (go arg)
 491     go (Note note e)   = Note note (go e)
 492     go (Lam bndr body) = Lam bndr (go body)
 493     go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
 494     go (Let (Rec pairs) body)       = Let (Rec (mapSnd go pairs)) (go body)
 495     go (Case scrut bndr ty alts)    = Case (go scrut) bndr ty
 496                                            [(c,bs,go r) | (c,bs,r) <- alts]
 497
 498 addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr)
 499 addInlinePrags prags bndr rhs
 500   = case [inl | L _ (InlinePrag inl) <- prags] of
 501         []      -> (bndr, rhs)
 502         (inl:_) -> addInlineInfo inl bndr rhs
 503
 504 addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
 505 addInlineInfo (Inline phase is_inline) bndr rhs
 506   = (attach_phase bndr phase, wrap_inline is_inline rhs)
 507   where
 508     attach_phase bndr phase
 509         | isAlwaysActive phase = bndr   -- Default phase
 510         | otherwise            = bndr `setInlinePragma` phase
 511
 512     wrap_inline True  body = mkInlineMe body
 513     wrap_inline False body = body
 514 \end{code}
 515
 516
 517 %************************************************************************
 518 %*                                                                      *
 519 \subsection[addAutoScc]{Adding automatic sccs}
 520 %*                                                                      *
 521 %************************************************************************
 522
 523 \begin{code}
 524 data AutoScc = NoSccs
 525              | AddSccs Module (Id -> Bool)
 526 -- The (Id->Bool) says which Ids to add SCCs to
 527
 528 addAutoScc :: AutoScc
 529            -> Id        -- Binder
 530            -> CoreExpr  -- Rhs
 531            -> CoreExpr  -- Scc'd Rhs
 532
 533 addAutoScc NoSccs _ rhs
 534   = rhs
 535 addAutoScc (AddSccs mod add_scc) id rhs
 536   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
 537   | otherwise  = rhs
 538 \end{code}
 539
 540 If profiling and dealing with a dict binding,
 541 wrap the dict in @_scc_ DICT <dict>@:
 542
 543 \begin{code}
 544 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
 545 addDictScc _ rhs = return rhs
 546
 547 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
 548   | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
 549     || not (isDictId var)
 550   = return rhs                          -- That's easy: do nothing
 551
 552   | otherwise
 553   = do (mod, grp) <- getModuleAndGroupDs
 554         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
 555        return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
 556 -}
 557 \end{code}
 558
 559
 560 %************************************************************************
 561 %*                                                                      *
 562                 Desugaring coercions
 563 %*                                                                      *
 564 %************************************************************************
 565
 566
 567 \begin{code}
 568 dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr
 569 dsCoercion WpHole            thing_inside = thing_inside
 570 dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
 571 dsCoercion (WpCast co)       thing_inside = do { expr <- thing_inside
 572                                                ; return (Cast expr co) }
 573 dsCoercion (WpLam id)        thing_inside = do { expr <- thing_inside
 574                                                ; return (Lam id expr) }
 575 dsCoercion (WpTyLam tv)      thing_inside = do { expr <- thing_inside
 576                                                ; return (Lam tv expr) }
 577 dsCoercion (WpApp id)        thing_inside = do { expr <- thing_inside
 578                                                ; return (App expr (Var id)) }
 579 dsCoercion (WpTyApp ty)      thing_inside = do { expr <- thing_inside
 580                                                ; return (App expr (Type ty)) }
 581 dsCoercion WpInline          thing_inside = do { expr <- thing_inside
 582                                                ; return (mkInlineMe expr) }
 583 dsCoercion (WpLet bs)        thing_inside = do { prs <- dsLHsBinds bs
 584                                                ; expr <- thing_inside
 585                                                ; return (Let (Rec prs) expr) }
 586 \end{code}