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