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   | not (isInlinePragma inline_prag)
 359   = (gbl_id, rhs)
 360
 361   | Just arity <- inlinePragmaSat inline_prag
 362         -- Add an Unfolding for an INLINE (but not for NOINLINE)
 363         -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
 364   , let real_arity = dict_arity + arity
 365         -- NB: The arity in the InlineRule takes account of the dictionaries
 366   = (gbl_id `setIdUnfolding` mkInlineRule rhs (Just real_arity),
 367      etaExpand real_arity rhs)
 368
 369   | otherwise
 370   = (gbl_id `setIdUnfolding` mkInlineRule rhs Nothing, rhs)
 371   where
 372     inline_prag = idInlinePragma gbl_id
 373
 374 dictArity :: [Var] -> Arity
 375 -- Don't count coercion variables in arity
 376 dictArity dicts = count isId dicts
 377
 378
 379 ------------------------
 380 type AbsBindEnv = VarEnv ([TyVar], Id, Id, TcSpecPrags)
 381         -- Maps the "lcl_id" for an AbsBind to
 382         -- its "gbl_id" and associated pragmas, if any
 383
 384 mkABEnv :: [([TyVar], Id, Id, TcSpecPrags)] -> AbsBindEnv
 385 -- Takes the exports of a AbsBinds, and returns a mapping
 386 --      lcl_id -> (tyvars, gbl_id, lcl_id, prags)
 387 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
 388 \end{code}
 389
 390 Note [Rules and inlining]
 391 ~~~~~~~~~~~~~~~~~~~~~~~~~
 392 Common special case: no type or dictionary abstraction
 393 This is a bit less trivial than you might suppose
 394 The naive way woudl be to desguar to something like
 395         f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
 396         M.f = f_lcl             -- Generated from "exports"
 397 But we don't want that, because if M.f isn't exported,
 398 it'll be inlined unconditionally at every call site (its rhs is
 399 trivial).  That would be ok unless it has RULES, which would
 400 thereby be completely lost.  Bad, bad, bad.
 401
 402 Instead we want to generate
 403         M.f = ...f_lcl...
 404         f_lcl = M.f
 405 Now all is cool. The RULES are attached to M.f (by SimplCore),
 406 and f_lcl is rapidly inlined away.
 407
 408 This does not happen in the same way to polymorphic binds,
 409 because they desugar to
 410         M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
 411 Although I'm a bit worried about whether full laziness might
 412 float the f_lcl binding out and then inline M.f at its call site -}
 413
 414 Note [Specialising in no-dict case]
 415 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 416 Even if there are no tyvars or dicts, we may have specialisation pragmas.
 417 Class methods can generate
 418       AbsBinds [] [] [( ... spec-prag]
 419          { AbsBinds [tvs] [dicts] ...blah }
 420 So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
 421
 422   class  (Real a, Fractional a) => RealFrac a  where
 423     round :: (Integral b) => a -> b
 424
 425   instance  RealFrac Float  where
 426     {-# SPECIALIZE round :: Float -> Int #-}
 427
 428 The top-level AbsBinds for $cround has no tyvars or dicts (because the
 429 instance does not).  But the method is locally overloaded!
 430
 431 Note [Abstracting over tyvars only]
 432 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 433 When abstracting over type variable only (not dictionaries), we don't really need to
 434 built a tuple and select from it, as we do in the general case. Instead we can take
 435
 436         AbsBinds [a,b] [ ([a,b], fg, fl, _),
 437                          ([b],   gg, gl, _) ]
 438                 { fl = e1
 439                   gl = e2
 440                    h = e3 }
 441
 442 and desugar it to
 443
 444         fg = /\ab. let B in e1
 445         gg = /\b. let a = () in let B in S(e2)
 446         h  = /\ab. let B in e3
 447
 448 where B is the *non-recursive* binding
 449         fl = fg a b
 450         gl = gg b
 451         h  = h a b    -- See (b); note shadowing!
 452
 453 Notice (a) g has a different number of type variables to f, so we must
 454              use the mkArbitraryType thing to fill in the gaps.
 455              We use a type-let to do that.
 456
 457          (b) The local variable h isn't in the exports, and rather than
 458              clone a fresh copy we simply replace h by (h a b), where
 459              the two h's have different types!  Shadowing happens here,
 460              which looks confusing but works fine.
 461
 462          (c) The result is *still* quadratic-sized if there are a lot of
 463              small bindings.  So if there are more than some small
 464              number (10), we filter the binding set B by the free
 465              variables of the particular RHS.  Tiresome.
 466
 467 Why got to this trouble?  It's a common case, and it removes the
 468 quadratic-sized tuple desugaring.  Less clutter, hopefullly faster
 469 compilation, especially in a case where there are a *lot* of
 470 bindings.
 471
 472
 473 Note [Eta-expanding INLINE things]
 474 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 475 Consider
 476    foo :: Eq a => a -> a
 477    {-# INLINE foo #-}
 478    foo x = ...
 479
 480 If (foo d) ever gets floated out as a common sub-expression (which can
 481 happen as a result of method sharing), there's a danger that we never
 482 get to do the inlining, which is a Terribly Bad thing given that the
 483 user said "inline"!
 484
 485 To avoid this we pre-emptively eta-expand the definition, so that foo
 486 has the arity with which it is declared in the source code.  In this
 487 example it has arity 2 (one for the Eq and one for x). Doing this
 488 should mean that (foo d) is a PAP and we don't share it.
 489
 490 Note [Nested arities]
 491 ~~~~~~~~~~~~~~~~~~~~~
 492 For reasons that are not entirely clear, method bindings come out looking like
 493 this:
 494
 495   AbsBinds [] [] [$cfromT <= [] fromT]
 496     $cfromT [InlPrag=INLINE] :: T Bool -> Bool
 497     { AbsBinds [] [] [fromT <= [] fromT_1]
 498         fromT :: T Bool -> Bool
 499         { fromT_1 ((TBool b)) = not b } } }
 500
 501 Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be
 502 gotten from the binding for fromT_1.
 503
 504 It might be better to have just one level of AbsBinds, but that requires more
 505 thought!
 506
 507 Note [Implementing SPECIALISE pragmas]
 508 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 509 Example:
 510         f :: (Eq a, Ix b) => a -> b -> Bool
 511         {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
 512         f = <poly_rhs>
 513
 514 From this the typechecker generates
 515
 516     AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
 517
 518     SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
 519                       -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
 520
 521 Note that wrap_fn can transform *any* function with the right type prefix
 522     forall ab. (Eq a, Ix b) => XXX
 523 regardless of XXX.  It's sort of polymorphic in XXX.  This is
 524 useful: we use the same wrapper to transform each of the class ops, as
 525 well as the dict.
 526
 527 From these we generate:
 528
 529     Rule:       forall p, q, (dp:Ix p), (dq:Ix q).
 530                     f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
 531
 532     Spec bind:  f_spec = wrap_fn <poly_rhs>
 533
 534 Note that
 535
 536   * The LHS of the rule may mention dictionary *expressions* (eg
 537     $dfIxPair dp dq), and that is essential because the dp, dq are
 538     needed on the RHS.
 539
 540   * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
 541     can fully specialise it.
 542
 543 \begin{code}
 544 ------------------------
 545 dsSpecs :: Id           -- The polymorphic Id
 546         -> CoreExpr     -- Its rhs
 547         -> TcSpecPrags
 548         -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids
 549                , [CoreRule] )           -- Rules for the Global Ids
 550 -- See Note [Implementing SPECIALISE pragmas]
 551 dsSpecs poly_id poly_rhs prags
 552   = case prags of
 553       IsDefaultMethod      -> return (nilOL, [])
 554       SpecPrags sps -> do { pairs <- mapMaybeM spec_one sps
 555                           ; let (spec_binds_s, rules) = unzip pairs
 556                           ; return (concatOL spec_binds_s, rules) }
 557  where
 558     spec_one :: Located TcSpecPrag -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
 559     spec_one (L loc (SpecPrag spec_co spec_inl))
 560       = putSrcSpanDs loc $
 561         do { let poly_name = idName poly_id
 562            ; spec_name <- newLocalName poly_name
 563            ; wrap_fn   <- dsHsWrapper spec_co
 564            ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
 565                  spec_ty = mkPiTypes bndrs (exprType ds_lhs)
 566            ; case decomposeRuleLhs ds_lhs of {
 567                Nothing -> do { warnDs (decomp_msg spec_co)
 568                              ; return Nothing } ;
 569
 570                Just (_fn, args) ->
 571
 572            -- Check for dead binders: Note [Unused spec binders]
 573              let arg_fvs = exprsFreeVars args
 574                  bad_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
 575              in if not (null bad_bndrs)
 576                 then do { warnDs (dead_msg bad_bndrs); return Nothing }
 577                 else do
 578
 579            { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
 580
 581            ; let spec_id  = mkLocalId spec_name spec_ty
 582                             `setInlinePragma` inl_prag
 583                             `setIdUnfolding`  spec_unf
 584                  inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
 585                           | otherwise                      = spec_inl
 586                       -- Get the INLINE pragma from SPECIALISE declaration, or,
 587                       -- failing that, from the original Id
 588
 589                  extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
 590                                             -- See Note [Constant rule dicts]
 591                                     | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
 592                                     , isDictId d]
 593
 594                  rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
 595                                 AlwaysActive poly_name
 596                                 (extra_dict_bndrs ++ bndrs) args
 597                                 (mkVarApps (Var spec_id) bndrs)
 598
 599                  spec_rhs  = wrap_fn poly_rhs
 600                  spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
 601
 602             ; return (Just (spec_pair `consOL` unf_pairs, rule))
 603             } } }
 604
 605     dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
 606                                  <+> ptext (sLit "in specialied type:"),
 607                              nest 2 (pprTheta (map get_pred bs))]
 608                        , ptext (sLit "SPECIALISE pragma ignored")]
 609     get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
 610
 611     decomp_msg spec_co
 612         = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
 613              2 (pprHsWrapper (ppr poly_id) spec_co)
 614
 615
 616 specUnfolding :: (CoreExpr -> CoreExpr) -> Type
 617               -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
 618 specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
 619   = do { let spec_rhss = map wrap_fn ops
 620        ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
 621        ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
 622 specUnfolding _ _ _
 623   = return (noUnfolding, nilOL)
 624
 625 {-
 626 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
 627 -- If any of the tyvars is missing from any of the lists in
 628 -- the second arg, return a binding in the result
 629 mkArbitraryTypeEnv tyvars exports
 630   = go emptyVarEnv exports
 631   where
 632     go env [] = env
 633     go env ((ltvs, _, _, _) : exports)
 634         = go env' exports
 635         where
 636           env' = foldl extend env [tv | tv <- tyvars
 637                                       , not (tv `elem` ltvs)
 638                                       , not (tv `elemVarEnv` env)]
 639
 640     extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
 641 -}
 642
 643 dsMkArbitraryType :: TcTyVar -> Type
 644 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
 645 \end{code}
 646
 647 Note [Unused spec binders]
 648 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 649 Consider
 650         f :: a -> a
 651         {-# SPECIALISE f :: Eq a => a -> a #-}
 652 It's true that this *is* a more specialised type, but the rule
 653 we get is something like this:
 654         f_spec d = f
 655         RULE: f = f_spec d
 656 Note that the rule is bogus, becuase it mentions a 'd' that is
 657 not bound on the LHS!  But it's a silly specialisation anyway, becuase
 658 the constraint is unused.  We could bind 'd' to (error "unused")
 659 but it seems better to reject the program because it's almost certainly
 660 a mistake.  That's what the isDeadBinder call detects.
 661
 662 Note [Constant rule dicts]
 663 ~~~~~~~~~~~~~~~~~~~~~~~
 664 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
 665 which is presumably in scope at the function definition site, we can quantify
 666 over it too.  *Any* dict with that type will do.
 667
 668 So for example when you have
 669         f :: Eq a => a -> a
 670         f = <rhs>
 671         {-# SPECIALISE f :: Int -> Int #-}
 672
 673 Then we get the SpecPrag
 674         SpecPrag (f Int dInt)
 675
 676 And from that we want the rule
 677
 678         RULE forall dInt. f Int dInt = f_spec
 679         f_spec = let f = <rhs> in f Int dInt
 680
 681 But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
 682 Name, and you can't bind them in a lambda or forall without getting things
 683 confused.   Likewise it might have an InlineRule or something, which would be
 684 utterly bogus. So we really make a fresh Id, with the same unique and type
 685 as the old one, but with an Internal name and no IdInfo.
 686
 687 %************************************************************************
 688 %*                                                                      *
 689 \subsection{Adding inline pragmas}
 690 %*                                                                      *
 691 %************************************************************************
 692
 693 \begin{code}
 694 decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr])
 695 -- Take apart the LHS of a RULE.  It's suuposed to look like
 696 --     /\a. f a Int dOrdInt
 697 -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
 698 -- That is, the RULE binders are lambda-bound
 699 -- Returns Nothing if the LHS isn't of the expected shape
 700 decomposeRuleLhs lhs
 701   =  -- Note [Simplifying the left-hand side of a RULE]
 702     case collectArgs (simpleOptExpr lhs) of
 703         (Var fn, args) -> Just (fn, args)
 704
 705         (Case scrut bndr ty [(DEFAULT, _, body)], args)
 706                 | isDeadBinder bndr     -- Note [Matching seqId]
 707                 -> Just (seqId, args' ++ args)
 708                 where
 709                    args' = [Type (idType bndr), Type ty, scrut, body]
 710
 711         _other -> Nothing       -- Unexpected shape
 712 \end{code}
 713
 714 Note [Simplifying the left-hand side of a RULE]
 715 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 716 simpleOptExpr occurrence-analyses and simplifies the lhs
 717 and thereby
 718 (a) sorts dict bindings into NonRecs and inlines them
 719 (b) substitute trivial lets so that they don't get in the way
 720     Note that we substitute the function too; we might
 721     have this as a LHS:  let f71 = M.f Int in f71
 722 (c) does eta reduction
 723
 724 For (c) consider the fold/build rule, which without simplification
 725 looked like:
 726         fold k z (build (/\a. g a))  ==>  ...
 727 This doesn't match unless you do eta reduction on the build argument.
 728 Similarly for a LHS like
 729         augment g (build h)
 730 we do not want to get
 731         augment (\a. g a) (build h)
 732 otherwise we don't match when given an argument like
 733         augment (\a. h a a) (build h)
 734
 735 NB: tcSimplifyRuleLhs is very careful not to generate complicated
 736     dictionary expressions that we might have to match
 737
 738
 739 Note [Matching seqId]
 740 ~~~~~~~~~~~~~~~~~~~
 741 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
 742 and this code turns it back into an application of seq!
 743 See Note [Rules for seq] in MkId for the details.
 744
 745
 746 %************************************************************************
 747 %*                                                                      *
 748 \subsection[addAutoScc]{Adding automatic sccs}
 749 %*                                                                      *
 750 %************************************************************************
 751
 752 \begin{code}
 753 data AutoScc = NoSccs
 754              | AddSccs Module (Id -> Bool)
 755 -- The (Id->Bool) says which Ids to add SCCs to
 756 -- But we never add a SCC to function marked INLINE
 757
 758 addAutoScc :: AutoScc
 759            -> Id        -- Binder
 760            -> CoreExpr  -- Rhs
 761            -> CoreExpr  -- Scc'd Rhs
 762
 763 addAutoScc NoSccs _ rhs
 764   = rhs
 765 addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
 766   = rhs
 767 addAutoScc (AddSccs mod add_scc) id rhs
 768   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
 769   | otherwise  = rhs
 770 \end{code}
 771
 772 If profiling and dealing with a dict binding,
 773 wrap the dict in @_scc_ DICT <dict>@:
 774
 775 \begin{code}
 776 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
 777 addDictScc _ rhs = return rhs
 778
 779 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
 780   | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
 781     || not (isDictId var)
 782   = return rhs                          -- That's easy: do nothing
 783
 784   | otherwise
 785   = do (mod, grp) <- getModuleAndGroupDs
 786         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
 787        return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
 788 -}
 789 \end{code}
 790
 791
 792 %************************************************************************
 793 %*                                                                      *
 794                 Desugaring coercions
 795 %*                                                                      *
 796 %************************************************************************
 797
 798
 799 \begin{code}
 800 dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
 801 dsHsWrapper WpHole            = return (\e -> e)
 802 dsHsWrapper (WpTyApp ty)      = return (\e -> App e (Type ty))
 803 dsHsWrapper (WpLet ev_binds)  = do { ds_ev_binds <- dsTcEvBinds ev_binds
 804                                    ; return (wrapDsEvBinds ds_ev_binds) }
 805 dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1
 806                                    ; k2 <- dsHsWrapper c2
 807                                    ; return (k1 . k2) }
 808 dsHsWrapper (WpCast co)       = return (\e -> Cast e co)
 809 dsHsWrapper (WpEvLam ev)      = return (\e -> Lam ev e)
 810 dsHsWrapper (WpTyLam tv)      = return (\e -> Lam tv e)
 811 dsHsWrapper (WpEvApp evtrm)   = return (\e -> App e (dsEvTerm evtrm))
 812 \end{code}