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          -- Local Id; this is its rhs
 530              | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
 531              = unfolding    -- Imported Id; this is its unfolding
 532                             -- Use realIdUnfolding so we get the unfolding
 533                             -- even when it is a loop breaker.
 534                             -- We want to specialise recursive functions!
 535              | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
 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 {-   [Dec 10: TEMPORARILY commented out, until we can straighten out how to
 541               generate unfoldings for specialised DFuns
 542
 543 specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
 544   = do { let spec_rhss = map wrap_fn ops
 545        ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
 546        ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
 547 -}
 548 specUnfolding _ _ _
 549   = return (noUnfolding, nilOL)
 550
 551 dsMkArbitraryType :: TcTyVar -> Type
 552 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
 553 \end{code}
 554
 555 %************************************************************************
 556 %*                                                                      *
 557 \subsection{Adding inline pragmas}
 558 %*                                                                      *
 559 %************************************************************************
 560
 561 \begin{code}
 562 decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
 563 -- Take apart the LHS of a RULE.  It's suuposed to look like
 564 --     /\a. f a Int dOrdInt
 565 -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
 566 -- That is, the RULE binders are lambda-bound
 567 -- Returns Nothing if the LHS isn't of the expected shape
 568 decomposeRuleLhs bndrs lhs
 569   =  -- Note [Simplifying the left-hand side of a RULE]
 570     case collectArgs opt_lhs of
 571         (Var fn, args) -> check_bndrs fn args
 572
 573         (Case scrut bndr ty [(DEFAULT, _, body)], args)
 574                 | isDeadBinder bndr     -- Note [Matching seqId]
 575                 -> check_bndrs seqId (args' ++ args)
 576                 where
 577                    args' = [Type (idType bndr), Type ty, scrut, body]
 578
 579         _other -> Left bad_shape_msg
 580  where
 581    opt_lhs = simpleOptExpr lhs
 582
 583    check_bndrs fn args
 584      | null (dead_bndrs) = Right (extra_dict_bndrs ++ bndrs, fn, args)
 585      | otherwise         = Left (vcat (map dead_msg dead_bndrs))
 586      where
 587        arg_fvs = exprsFreeVars args
 588
 589             -- Check for dead binders: Note [Unused spec binders]
 590        dead_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
 591
 592             -- Add extra dict binders: Note [Constant rule dicts]
 593        extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
 594                           | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
 595                           , isDictId d]
 596
 597
 598    bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
 599                       2 (ppr opt_lhs)
 600    dead_msg bndr = hang (ptext (sLit "Forall'd") <+> pp_bndr bndr
 601                                  <+> ptext (sLit "is not bound in RULE lhs"))
 602                       2 (ppr opt_lhs)
 603    pp_bndr bndr
 604     | isTyVar bndr = ptext (sLit "type variable") <+> ppr bndr
 605     | isCoVar bndr = ptext (sLit "coercion variable") <+> ppr bndr
 606     | isDictId bndr = ptext (sLit "constraint") <+> ppr (get_pred bndr)
 607     | otherwise     = ptext (sLit "variable") <+> ppr bndr
 608
 609    get_pred b = ASSERT( isId b ) expectJust "decomposeRuleLhs"
 610                                  (tcSplitPredTy_maybe (idType b))
 611 \end{code}
 612
 613 Note [Simplifying the left-hand side of a RULE]
 614 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 615 simpleOptExpr occurrence-analyses and simplifies the lhs
 616 and thereby
 617 (a) sorts dict bindings into NonRecs and inlines them
 618 (b) substitute trivial lets so that they don't get in the way
 619     Note that we substitute the function too; we might
 620     have this as a LHS:  let f71 = M.f Int in f71
 621 (c) does eta reduction
 622
 623 For (c) consider the fold/build rule, which without simplification
 624 looked like:
 625         fold k z (build (/\a. g a))  ==>  ...
 626 This doesn't match unless you do eta reduction on the build argument.
 627 Similarly for a LHS like
 628         augment g (build h)
 629 we do not want to get
 630         augment (\a. g a) (build h)
 631 otherwise we don't match when given an argument like
 632         augment (\a. h a a) (build h)
 633
 634 NB: tcSimplifyRuleLhs is very careful not to generate complicated
 635     dictionary expressions that we might have to match
 636
 637
 638 Note [Matching seqId]
 639 ~~~~~~~~~~~~~~~~~~~
 640 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
 641 and this code turns it back into an application of seq!
 642 See Note [Rules for seq] in MkId for the details.
 643
 644 Note [Unused spec binders]
 645 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 646 Consider
 647         f :: a -> a
 648         {-# SPECIALISE f :: Eq a => a -> a #-}
 649 It's true that this *is* a more specialised type, but the rule
 650 we get is something like this:
 651         f_spec d = f
 652         RULE: f = f_spec d
 653 Note that the rule is bogus, becuase it mentions a 'd' that is
 654 not bound on the LHS!  But it's a silly specialisation anyway, becuase
 655 the constraint is unused.  We could bind 'd' to (error "unused")
 656 but it seems better to reject the program because it's almost certainly
 657 a mistake.  That's what the isDeadBinder call detects.
 658
 659 Note [Constant rule dicts]
 660 ~~~~~~~~~~~~~~~~~~~~~~~
 661 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
 662 which is presumably in scope at the function definition site, we can quantify
 663 over it too.  *Any* dict with that type will do.
 664
 665 So for example when you have
 666         f :: Eq a => a -> a
 667         f = <rhs>
 668         {-# SPECIALISE f :: Int -> Int #-}
 669
 670 Then we get the SpecPrag
 671         SpecPrag (f Int dInt)
 672
 673 And from that we want the rule
 674
 675         RULE forall dInt. f Int dInt = f_spec
 676         f_spec = let f = <rhs> in f Int dInt
 677
 678 But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
 679 Name, and you can't bind them in a lambda or forall without getting things
 680 confused.   Likewise it might have an InlineRule or something, which would be
 681 utterly bogus. So we really make a fresh Id, with the same unique and type
 682 as the old one, but with an Internal name and no IdInfo.
 683
 684
 685 %************************************************************************
 686 %*                                                                      *
 687 \subsection[addAutoScc]{Adding automatic sccs}
 688 %*                                                                      *
 689 %************************************************************************
 690
 691 \begin{code}
 692 data AutoScc = NoSccs
 693              | AddSccs Module (Id -> Bool)
 694 -- The (Id->Bool) says which Ids to add SCCs to
 695 -- But we never add a SCC to function marked INLINE
 696
 697 addAutoScc :: AutoScc
 698            -> Id        -- Binder
 699            -> CoreExpr  -- Rhs
 700            -> CoreExpr  -- Scc'd Rhs
 701
 702 addAutoScc NoSccs _ rhs
 703   = rhs
 704 addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
 705   = rhs
 706 addAutoScc (AddSccs mod add_scc) id rhs
 707   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
 708   | otherwise  = rhs
 709 \end{code}
 710
 711 If profiling and dealing with a dict binding,
 712 wrap the dict in @_scc_ DICT <dict>@:
 713
 714 \begin{code}
 715 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
 716 addDictScc _ rhs = return rhs
 717
 718 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
 719   | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
 720     || not (isDictId var)
 721   = return rhs                          -- That's easy: do nothing
 722
 723   | otherwise
 724   = do (mod, grp) <- getModuleAndGroupDs
 725         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
 726        return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
 727 -}
 728 \end{code}
 729
 730
 731 %************************************************************************
 732 %*                                                                      *
 733                 Desugaring coercions
 734 %*                                                                      *
 735 %************************************************************************
 736
 737
 738 \begin{code}
 739 dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
 740 dsHsWrapper WpHole            = return (\e -> e)
 741 dsHsWrapper (WpTyApp ty)      = return (\e -> App e (Type ty))
 742 dsHsWrapper (WpLet ev_binds)  = do { ds_ev_binds <- dsTcEvBinds ev_binds
 743                                    ; return (wrapDsEvBinds ds_ev_binds) }
 744 dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1
 745                                    ; k2 <- dsHsWrapper c2
 746                                    ; return (k1 . k2) }
 747 dsHsWrapper (WpCast co)       = return (\e -> Cast e co)
 748 dsHsWrapper (WpEvLam ev)      = return (\e -> Lam ev e)
 749 dsHsWrapper (WpTyLam tv)      = return (\e -> Lam tv e)
 750 dsHsWrapper (WpEvApp evtrm)   = return (\e -> App e (dsEvTerm evtrm))
 751 \end{code}