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