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