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