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 )
  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 CoreSubst
  30 import MkCore
  31 import CoreUtils
  32 import CoreArity ( etaExpand )
  33 import CoreUnfold
  34 import CoreFVs
  35
  36 import TcType
  37 import TysPrim  ( anyTypeOfKind )
  38 import CostCentre
  39 import Module
  40 import Id
  41 import Name     ( localiseName )
  42 import MkId     ( seqId )
  43 import Var      ( Var, TyVar, tyVarKind )
  44 import IdInfo   ( vanillaIdInfo )
  45 import VarSet
  46 import Rules
  47 import VarEnv
  48 import Outputable
  49 import SrcLoc
  50 import Maybes
  51 import Bag
  52 import BasicTypes hiding ( TopLevel )
  53 import FastString
  54 import StaticFlags      ( opt_DsMultiTyVar )
  55 import Util             ( count, lengthExceeds )
  56
  57 import MonadUtils
  58 import Control.Monad
  59 \end{code}
  60
  61 %************************************************************************
  62 %*                                                                      *
  63 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
  64 %*                                                                      *
  65 %************************************************************************
  66
  67 \begin{code}
  68 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
  69 dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
  70
  71 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
  72 dsLHsBinds binds = ds_lhs_binds NoSccs binds
  73
  74
  75 ------------------------
  76 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
  77
  78          -- scc annotation policy (see below)
  79 ds_lhs_binds auto_scc binds =  foldM (dsLHsBind auto_scc) [] (bagToList binds)
  80
  81 dsLHsBind :: AutoScc
  82          -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
  83          -> LHsBind Id
  84          -> DsM [(Id,CoreExpr)] -- Result
  85 dsLHsBind auto_scc rest (L loc bind)
  86   = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
  87
  88 dsHsBind :: AutoScc
  89          -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
  90          -> HsBind Id
  91          -> DsM [(Id,CoreExpr)] -- Result
  92
  93 dsHsBind _ rest (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
  94   = do  { core_expr <- dsLExpr expr
  95
  96                 -- Dictionary bindings are always VarBinds,
  97                 -- so we only need do this here
  98         ; core_expr' <- addDictScc var core_expr
  99         ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr'
 100                    | otherwise         = var
 101
 102         ; return ((var', core_expr') : rest) }
 103
 104 dsHsBind _ rest
 105          (FunBind { fun_id = L _ fun, fun_matches = matches,
 106                     fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf })
 107  = do   { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
 108         ; body'    <- mkOptTickBox tick body
 109         ; wrap_fn' <- dsCoercion co_fn
 110         ; return ((fun, wrap_fn' (mkLams args body')) : rest) }
 111
 112 dsHsBind _ rest
 113          (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
 114   = do  { body_expr <- dsGuarded grhss ty
 115         ; sel_binds <- mkSelectorBinds pat body_expr
 116         ; return (sel_binds ++ rest) }
 117
 118 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
 119   = do  { core_prs <- ds_lhs_binds NoSccs binds
 120         ; let env = mkABEnv exports
 121               do_one (lcl_id, rhs)
 122                 | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
 123                 = do { let rhs' = addAutoScc auto_scc gbl_id rhs
 124                      ; (spec_binds, rules) <- dsSpecs gbl_id (Let (Rec core_prs) rhs') spec_prags
 125                                     -- See Note [Specialising in no-dict case]
 126                      ; let   gbl_id'   = addIdSpecialisations gbl_id rules
 127                              main_bind = makeCorePair gbl_id' False 0 rhs'
 128                      ; return (main_bind : spec_binds) }
 129
 130                 | otherwise = return [(lcl_id, rhs)]
 131
 132               locals'  = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
 133                         -- Note [Rules and inlining]
 134         ; export_binds <- mapM do_one core_prs
 135         ; return (concat export_binds ++ locals' ++ rest) }
 136                 -- No Rec needed here (contrast the other AbsBinds cases)
 137                 -- because we can rely on the enclosing dsBind to wrap in Rec
 138
 139
 140 dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
 141   | opt_DsMultiTyVar    -- This (static) debug flag just lets us
 142                         -- switch on and off this optimisation to
 143                         -- see if it has any impact; it is on by default
 144   =     -- Note [Abstracting over tyvars only]
 145     do  { core_prs <- ds_lhs_binds NoSccs binds
 146         ; let arby_env = mkArbitraryTypeEnv tyvars exports
 147               bndrs = mkVarSet (map fst core_prs)
 148
 149               add_lets | core_prs `lengthExceeds` 10 = add_some
 150                        | otherwise                   = mkLets
 151               add_some lg_binds rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
 152                                                           , b `elemVarSet` fvs] rhs
 153                 where
 154                   fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
 155
 156               env = mkABEnv exports
 157               mk_lg_bind lcl_id gbl_id tyvars
 158                  = NonRec (setIdInfo lcl_id vanillaIdInfo)
 159                                 -- Nuke the IdInfo so that no old unfoldings
 160                                 -- confuse use (it might mention something not
 161                                 -- even in scope at the new site
 162                           (mkTyApps (Var gbl_id) (mkTyVarTys tyvars))
 163
 164               do_one lg_binds (lcl_id, rhs)
 165                 | Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
 166                 = do { let rhs' = addAutoScc auto_scc gbl_id  $
 167                                   mkLams id_tvs $
 168                                   mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
 169                                          | tv <- tyvars, not (tv `elem` id_tvs)] $
 170                                   add_lets lg_binds rhs
 171                      ; (spec_binds, rules) <- dsSpecs gbl_id rhs' spec_prags
 172                      ; let   gbl_id'   = addIdSpecialisations gbl_id rules
 173                              main_bind = makeCorePair gbl_id' False 0 rhs'
 174                      ; return (mk_lg_bind lcl_id gbl_id' id_tvs, main_bind : spec_binds) }
 175                 | otherwise
 176                 = do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id))
 177                      ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars,
 178                                [(non_exp_gbl_id, mkLams tyvars (add_lets lg_binds rhs))]) }
 179
 180         ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs)
 181         ; return (concat core_prs' ++ rest) }
 182
 183         -- Another common case: one exported variable
 184         -- Non-recursive bindings come through this way
 185         -- So do self-recursive bindings, and recursive bindings
 186         -- that have been chopped up with type signatures
 187 dsHsBind auto_scc rest
 188      (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
 189   = ASSERT( all (`elem` tyvars) all_tyvars )
 190     do  { core_prs <- ds_lhs_binds NoSccs binds
 191
 192         ; let   -- Always treat the binds as recursive, because the
 193                 -- typechecker makes rather mixed-up dictionary bindings
 194                 core_bind = Rec core_prs
 195                 rhs       = addAutoScc auto_scc global $
 196                             mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
 197
 198         ; (spec_binds, rules) <- dsSpecs global rhs prags
 199
 200         ; let   global'   = addIdSpecialisations global rules
 201                 main_bind = makeCorePair global' (isDefaultMethod prags)
 202                                          (dictArity dicts) rhs
 203
 204         ; return (main_bind : spec_binds ++ rest) }
 205
 206 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 207   = do  { core_prs <- ds_lhs_binds NoSccs binds
 208         ; let env = mkABEnv exports
 209               do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
 210                                   = (lcl_id, addAutoScc auto_scc gbl_id rhs)
 211                                   | otherwise = (lcl_id,rhs)
 212
 213                 -- Rec because of mixed-up dictionary bindings
 214               core_bind = Rec (map do_one core_prs)
 215
 216               tup_expr     = mkBigCoreVarTup locals
 217               tup_ty       = exprType tup_expr
 218               poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
 219                              Let core_bind tup_expr
 220               locals       = [local | (_, _, local, _) <- exports]
 221               local_tys    = map idType locals
 222
 223         ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
 224
 225         ; let mk_bind ((tyvars, global, _, spec_prags), n)  -- locals!!n == local
 226                 =       -- Need to make fresh locals to bind in the selector,
 227                         -- because some of the tyvars will be bound to 'Any'
 228                   do { let ty_args = map mk_ty_arg all_tyvars
 229                            substitute = substTyWith all_tyvars ty_args
 230                      ; locals' <- newSysLocalsDs (map substitute local_tys)
 231                      ; tup_id  <- newSysLocalDs  (substitute tup_ty)
 232                      ; let rhs = mkLams tyvars $ mkLams dicts $
 233                                  mkTupleSelector locals' (locals' !! n) tup_id $
 234                                  mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
 235                                            dicts
 236                      ; (spec_binds, rules) <- dsSpecs global
 237                                                       (Let (NonRec poly_tup_id poly_tup_rhs) rhs)
 238                                                       spec_prags
 239                      ; let global' = addIdSpecialisations global rules
 240                      ; return ((global', rhs) : spec_binds) }
 241                 where
 242                   mk_ty_arg all_tyvar
 243                         | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
 244                         | otherwise               = dsMkArbitraryType all_tyvar
 245
 246         ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
 247              -- Don't scc (auto-)annotate the tuple itself.
 248
 249         ; return ((poly_tup_id, poly_tup_rhs) :
 250                     (concat export_binds_s ++ rest)) }
 251
 252 ------------------------
 253 makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
 254 makeCorePair gbl_id is_default_method dict_arity rhs
 255   | is_default_method                 -- Default methods are *always* inlined
 256   = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
 257
 258   | not (isInlinePragma inline_prag)
 259   = (gbl_id, rhs)
 260
 261   | Just arity <- inlinePragmaSat inline_prag
 262         -- Add an Unfolding for an INLINE (but not for NOINLINE)
 263         -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
 264   , let real_arity = dict_arity + arity
 265         -- NB: The arity in the InlineRule takes account of the dictionaries
 266   = (gbl_id `setIdUnfolding` mkInlineRule rhs (Just real_arity),
 267      etaExpand real_arity rhs)
 268
 269   | otherwise
 270   = (gbl_id `setIdUnfolding` mkInlineRule rhs Nothing, rhs)
 271   where
 272     inline_prag = idInlinePragma gbl_id
 273
 274 dictArity :: [Var] -> Arity
 275 -- Don't count coercion variables in arity
 276 dictArity dicts = count isId dicts
 277
 278
 279 ------------------------
 280 type AbsBindEnv = VarEnv ([TyVar], Id, Id, TcSpecPrags)
 281         -- Maps the "lcl_id" for an AbsBind to
 282         -- its "gbl_id" and associated pragmas, if any
 283
 284 mkABEnv :: [([TyVar], Id, Id, TcSpecPrags)] -> AbsBindEnv
 285 -- Takes the exports of a AbsBinds, and returns a mapping
 286 --      lcl_id -> (tyvars, gbl_id, lcl_id, prags)
 287 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
 288 \end{code}
 289
 290 Note [Rules and inlining]
 291 ~~~~~~~~~~~~~~~~~~~~~~~~~
 292 Common special case: no type or dictionary abstraction
 293 This is a bit less trivial than you might suppose
 294 The naive way woudl be to desguar to something like
 295         f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
 296         M.f = f_lcl             -- Generated from "exports"
 297 But we don't want that, because if M.f isn't exported,
 298 it'll be inlined unconditionally at every call site (its rhs is
 299 trivial).  That would be ok unless it has RULES, which would
 300 thereby be completely lost.  Bad, bad, bad.
 301
 302 Instead we want to generate
 303         M.f = ...f_lcl...
 304         f_lcl = M.f
 305 Now all is cool. The RULES are attached to M.f (by SimplCore),
 306 and f_lcl is rapidly inlined away.
 307
 308 This does not happen in the same way to polymorphic binds,
 309 because they desugar to
 310         M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
 311 Although I'm a bit worried about whether full laziness might
 312 float the f_lcl binding out and then inline M.f at its call site -}
 313
 314 Note [Specialising in no-dict case]
 315 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 316 Even if there are no tyvars or dicts, we may have specialisation pragmas.
 317 Class methods can generate
 318       AbsBinds [] [] [( ... spec-prag]
 319          { AbsBinds [tvs] [dicts] ...blah }
 320 So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
 321
 322   class  (Real a, Fractional a) => RealFrac a  where
 323     round :: (Integral b) => a -> b
 324
 325   instance  RealFrac Float  where
 326     {-# SPECIALIZE round :: Float -> Int #-}
 327
 328 The top-level AbsBinds for $cround has no tyvars or dicts (because the
 329 instance does not).  But the method is locally overloaded!
 330
 331 Note [Abstracting over tyvars only]
 332 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 333 When abstracting over type variable only (not dictionaries), we don't really need to
 334 built a tuple and select from it, as we do in the general case. Instead we can take
 335
 336         AbsBinds [a,b] [ ([a,b], fg, fl, _),
 337                          ([b],   gg, gl, _) ]
 338                 { fl = e1
 339                   gl = e2
 340                    h = e3 }
 341
 342 and desugar it to
 343
 344         fg = /\ab. let B in e1
 345         gg = /\b. let a = () in let B in S(e2)
 346         h  = /\ab. let B in e3
 347
 348 where B is the *non-recursive* binding
 349         fl = fg a b
 350         gl = gg b
 351         h  = h a b    -- See (b); note shadowing!
 352
 353 Notice (a) g has a different number of type variables to f, so we must
 354              use the mkArbitraryType thing to fill in the gaps.
 355              We use a type-let to do that.
 356
 357          (b) The local variable h isn't in the exports, and rather than
 358              clone a fresh copy we simply replace h by (h a b), where
 359              the two h's have different types!  Shadowing happens here,
 360              which looks confusing but works fine.
 361
 362          (c) The result is *still* quadratic-sized if there are a lot of
 363              small bindings.  So if there are more than some small
 364              number (10), we filter the binding set B by the free
 365              variables of the particular RHS.  Tiresome.
 366
 367 Why got to this trouble?  It's a common case, and it removes the
 368 quadratic-sized tuple desugaring.  Less clutter, hopefullly faster
 369 compilation, especially in a case where there are a *lot* of
 370 bindings.
 371
 372
 373 Note [Eta-expanding INLINE things]
 374 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 375 Consider
 376    foo :: Eq a => a -> a
 377    {-# INLINE foo #-}
 378    foo x = ...
 379
 380 If (foo d) ever gets floated out as a common sub-expression (which can
 381 happen as a result of method sharing), there's a danger that we never
 382 get to do the inlining, which is a Terribly Bad thing given that the
 383 user said "inline"!
 384
 385 To avoid this we pre-emptively eta-expand the definition, so that foo
 386 has the arity with which it is declared in the source code.  In this
 387 example it has arity 2 (one for the Eq and one for x). Doing this
 388 should mean that (foo d) is a PAP and we don't share it.
 389
 390 Note [Nested arities]
 391 ~~~~~~~~~~~~~~~~~~~~~
 392 For reasons that are not entirely clear, method bindings come out looking like
 393 this:
 394
 395   AbsBinds [] [] [$cfromT <= [] fromT]
 396     $cfromT [InlPrag=INLINE] :: T Bool -> Bool
 397     { AbsBinds [] [] [fromT <= [] fromT_1]
 398         fromT :: T Bool -> Bool
 399         { fromT_1 ((TBool b)) = not b } } }
 400
 401 Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be
 402 gotten from the binding for fromT_1.
 403
 404 It might be better to have just one level of AbsBinds, but that requires more
 405 thought!
 406
 407 Note [Implementing SPECIALISE pragmas]
 408 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 409 Example:
 410         f :: (Eq a, Ix b) => a -> b -> Bool
 411         {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
 412         f = <poly_rhs>
 413
 414 From this the typechecker generates
 415
 416     AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
 417
 418     SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
 419                       -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
 420
 421 Note that wrap_fn can transform *any* function with the right type prefix
 422     forall ab. (Eq a, Ix b) => XXX
 423 regardless of XXX.  It's sort of polymorphic in XXX.  This is
 424 useful: we use the same wrapper to transform each of the class ops, as
 425 well as the dict.
 426
 427 From these we generate:
 428
 429     Rule:       forall p, q, (dp:Ix p), (dq:Ix q).
 430                     f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
 431
 432     Spec bind:  f_spec = wrap_fn <poly_rhs>
 433
 434 Note that
 435
 436   * The LHS of the rule may mention dictionary *expressions* (eg
 437     $dfIxPair dp dq), and that is essential because the dp, dq are
 438     needed on the RHS.
 439
 440   * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
 441     can fully specialise it.
 442
 443 \begin{code}
 444 ------------------------
 445 dsSpecs :: Id           -- The polymorphic Id
 446         -> CoreExpr     -- Its rhs
 447         -> TcSpecPrags
 448         -> DsM ( [(Id,CoreExpr)]        -- Binding for specialised Ids
 449                , [CoreRule] )           -- Rules for the Global Ids
 450 -- See Note [Implementing SPECIALISE pragmas]
 451 dsSpecs poly_id poly_rhs prags
 452   = case prags of
 453       IsDefaultMethod      -> return ([], [])
 454       SpecPrags sps -> do { pairs <- mapMaybeM spec_one sps
 455                           ; let (spec_binds_s, rules) = unzip pairs
 456                           ; return (concat spec_binds_s, rules) }
 457  where
 458     spec_one :: Located TcSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule))
 459     spec_one (L loc (SpecPrag spec_co spec_inl))
 460       = putSrcSpanDs loc $
 461         do { let poly_name = idName poly_id
 462            ; spec_name <- newLocalName poly_name
 463            ; wrap_fn   <- dsCoercion spec_co
 464            ; let ds_spec_expr = wrap_fn (Var poly_id)
 465                  spec_ty = exprType ds_spec_expr
 466            ; case decomposeRuleLhs ds_spec_expr of {
 467                Nothing -> do { warnDs (decomp_msg spec_co)
 468                              ; return Nothing } ;
 469
 470                Just (bndrs, _fn, args) ->
 471
 472            -- Check for dead binders: Note [Unused spec binders]
 473              case filter isDeadBinder bndrs of {
 474                 bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
 475                    | otherwise -> do
 476
 477            { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
 478
 479            ; let spec_id  = mkLocalId spec_name spec_ty
 480                             `setInlinePragma` inl_prag
 481                             `setIdUnfolding`  spec_unf
 482                  inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
 483                           | otherwise                      = spec_inl
 484                       -- Get the INLINE pragma from SPECIALISE declaration, or,
 485                       -- failing that, from the original Id
 486
 487                  extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
 488                                             -- See Note [Constant rule dicts]
 489                                     | d <- varSetElems (exprFreeVars ds_spec_expr)
 490                                     , isDictId d]
 491
 492                  rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
 493                                 AlwaysActive poly_name
 494                                 (extra_dict_bndrs ++ bndrs) args
 495                                 (mkVarApps (Var spec_id) bndrs)
 496
 497                  spec_rhs  = wrap_fn poly_rhs
 498                  spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
 499
 500             ; return (Just (spec_pair : unf_pairs, rule))
 501             } } } }
 502
 503     dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
 504                                  <+> ptext (sLit "in specialied type:"),
 505                              nest 2 (pprTheta (map get_pred bs))]
 506                        , ptext (sLit "SPECIALISE pragma ignored")]
 507     get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
 508
 509     decomp_msg spec_co
 510         = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
 511              2 (pprHsWrapper (ppr poly_id) spec_co)
 512
 513
 514 specUnfolding :: (CoreExpr -> CoreExpr) -> Type
 515               -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
 516 specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
 517   = do { let spec_rhss = map wrap_fn ops
 518        ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
 519        ; return (mkDFunUnfolding spec_ty (map Var spec_ids), spec_ids `zip` spec_rhss) }
 520 specUnfolding _ _ _
 521   = return (noUnfolding, [])
 522
 523 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
 524 -- If any of the tyvars is missing from any of the lists in
 525 -- the second arg, return a binding in the result
 526 mkArbitraryTypeEnv tyvars exports
 527   = go emptyVarEnv exports
 528   where
 529     go env [] = env
 530     go env ((ltvs, _, _, _) : exports)
 531         = go env' exports
 532         where
 533           env' = foldl extend env [tv | tv <- tyvars
 534                                       , not (tv `elem` ltvs)
 535                                       , not (tv `elemVarEnv` env)]
 536
 537     extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
 538
 539 dsMkArbitraryType :: TcTyVar -> Type
 540 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
 541 \end{code}
 542
 543 Note [Unused spec binders]
 544 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 545 Consider
 546         f :: a -> a
 547         {-# SPECIALISE f :: Eq a => a -> a #-}
 548 It's true that this *is* a more specialised type, but the rule
 549 we get is something like this:
 550         f_spec d = f
 551         RULE: f = f_spec d
 552 Note that the rule is bogus, becuase it mentions a 'd' that is
 553 not bound on the LHS!  But it's a silly specialisation anyway, becuase
 554 the constraint is unused.  We could bind 'd' to (error "unused")
 555 but it seems better to reject the program because it's almost certainly
 556 a mistake.  That's what the isDeadBinder call detects.
 557
 558 Note [Constant rule dicts]
 559 ~~~~~~~~~~~~~~~~~~~~~~~
 560 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
 561 which is presumably in scope at the function definition site, we can quantify
 562 over it too.  *Any* dict with that type will do.
 563
 564 So for example when you have
 565         f :: Eq a => a -> a
 566         f = <rhs>
 567         {-# SPECIALISE f :: Int -> Int #-}
 568
 569 Then we get the SpecPrag
 570         SpecPrag (f Int dInt)
 571
 572 And from that we want the rule
 573
 574         RULE forall dInt. f Int dInt = f_spec
 575         f_spec = let f = <rhs> in f Int dInt
 576
 577 But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
 578 Name, and you can't bind them in a lambda or forall without getting things
 579 confused.   Likewise it might have an InlineRule or something, which would be
 580 utterly bogus. So we really make a fresh Id, with the same unique and type
 581 as the old one, but with an Internal name and no IdInfo.
 582
 583 %************************************************************************
 584 %*                                                                      *
 585 \subsection{Adding inline pragmas}
 586 %*                                                                      *
 587 %************************************************************************
 588
 589 \begin{code}
 590 decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
 591 -- Take apart the LHS of a RULE.  It's suuposed to look like
 592 --     /\a. f a Int dOrdInt
 593 -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
 594 -- That is, the RULE binders are lambda-bound
 595 -- Returns Nothing if the LHS isn't of the expected shape
 596 decomposeRuleLhs lhs
 597   = case collectArgs body of
 598         (Var fn, args) -> Just (bndrs, fn, args)
 599
 600         (Case scrut bndr ty [(DEFAULT, _, body)], args)
 601                 | isDeadBinder bndr     -- Note [Matching seqId]
 602                 -> Just (bndrs, seqId, args' ++ args)
 603                 where
 604                    args' = [Type (idType bndr), Type ty, scrut, body]
 605
 606         _other -> Nothing       -- Unexpected shape
 607   where
 608     (bndrs, body) = collectBinders (simpleOptExpr lhs)
 609         -- simpleOptExpr occurrence-analyses and simplifies the lhs
 610         -- and thereby
 611         -- (a) identifies unused binders: Note [Unused spec binders]
 612         -- (b) sorts dict bindings into NonRecs
 613         --      so they can be inlined by 'decomp'
 614         -- (c) substitute trivial lets so that they don't get in the way
 615         --     Note that we substitute the function too; we might
 616         --     have this as a LHS:  let f71 = M.f Int in f71
 617         -- NB: tcSimplifyRuleLhs is very careful not to generate complicated
 618         --     dictionary expressions that we might have to match
 619 \end{code}
 620
 621 Note [Matching seqId]
 622 ~~~~~~~~~~~~~~~~~~~
 623 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
 624 and this code turns it back into an application of seq!
 625 See Note [Rules for seq] in MkId for the details.
 626
 627
 628 %************************************************************************
 629 %*                                                                      *
 630 \subsection[addAutoScc]{Adding automatic sccs}
 631 %*                                                                      *
 632 %************************************************************************
 633
 634 \begin{code}
 635 data AutoScc = NoSccs
 636              | AddSccs Module (Id -> Bool)
 637 -- The (Id->Bool) says which Ids to add SCCs to
 638 -- But we never add a SCC to function marked INLINE
 639
 640 addAutoScc :: AutoScc
 641            -> Id        -- Binder
 642            -> CoreExpr  -- Rhs
 643            -> CoreExpr  -- Scc'd Rhs
 644
 645 addAutoScc NoSccs _ rhs
 646   = rhs
 647 addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
 648   = rhs
 649 addAutoScc (AddSccs mod add_scc) id rhs
 650   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
 651   | otherwise  = rhs
 652 \end{code}
 653
 654 If profiling and dealing with a dict binding,
 655 wrap the dict in @_scc_ DICT <dict>@:
 656
 657 \begin{code}
 658 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
 659 addDictScc _ rhs = return rhs
 660
 661 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
 662   | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
 663     || not (isDictId var)
 664   = return rhs                          -- That's easy: do nothing
 665
 666   | otherwise
 667   = do (mod, grp) <- getModuleAndGroupDs
 668         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
 669        return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
 670 -}
 671 \end{code}
 672
 673
 674 %************************************************************************
 675 %*                                                                      *
 676                 Desugaring coercions
 677 %*                                                                      *
 678 %************************************************************************
 679
 680
 681 \begin{code}
 682 dsCoercion :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
 683 dsCoercion WpHole            = return (\e -> e)
 684 dsCoercion (WpCompose c1 c2) = do { k1 <- dsCoercion c1
 685                                   ; k2 <- dsCoercion c2
 686                                   ; return (k1 . k2) }
 687 dsCoercion (WpCast co)       = return (\e -> Cast e co)
 688 dsCoercion (WpLam id)        = return (\e -> Lam id e)
 689 dsCoercion (WpTyLam tv)      = return (\e -> Lam tv e)
 690 dsCoercion (WpApp v)         | isTyVar v   -- Probably a coercion var
 691                              = return (\e -> App e (Type (mkTyVarTy v)))
 692                              | otherwise
 693                              = return (\e -> App e (Var v))
 694 dsCoercion (WpTyApp ty)      = return (\e -> App e (Type ty))
 695 dsCoercion (WpLet bs)        = do { prs <- dsLHsBinds bs
 696                                   ; return (\e -> Let (Rec prs) e) }
 697 \end{code}