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