compiler/deSugar/DsBinds.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Pattern-matching bindings (HsBinds and MonoBinds)
   7
   8 Handles @HsBinds@; those at the top level require different handling,
   9 in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
  10 lower levels it is preserved with @let@/@letrec@s).
  11
  12 \begin{code}
  13 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs,
  14                  dsCoercion,
  15                  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
  36 import TcType
  37 import TysPrim  ( anyTypeOfKind )
  38 import CostCentre
  39 import Module
  40 import Id
  41 import MkId     ( seqId )
  42 import Var      ( Var, TyVar, tyVarKind )
  43 import IdInfo   ( vanillaIdInfo )
  44 import VarSet
  45 import Rules
  46 import VarEnv
  47 import Outputable
  48 import SrcLoc
  49 import Maybes
  50 import Bag
  51 import BasicTypes hiding ( TopLevel )
  52 import FastString
  53 import StaticFlags      ( opt_DsMultiTyVar )
  54 import Util             ( count, lengthExceeds )
  55
  56 import MonadUtils
  57 import Control.Monad
  58 \end{code}
  59
  60 %************************************************************************
  61 %*                                                                      *
  62 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
  63 %*                                                                      *
  64 %************************************************************************
  65
  66 \begin{code}
  67 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
  68 dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
  69
  70 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
  71 dsLHsBinds binds = ds_lhs_binds NoSccs binds
  72
  73
  74 ------------------------
  75 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
  76
  77          -- scc annotation policy (see below)
  78 ds_lhs_binds auto_scc binds =  foldM (dsLHsBind auto_scc) [] (bagToList binds)
  79
  80 dsLHsBind :: AutoScc
  81          -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
  82          -> LHsBind Id
  83          -> DsM [(Id,CoreExpr)] -- Result
  84 dsLHsBind auto_scc rest (L loc bind)
  85   = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
  86
  87 dsHsBind :: AutoScc
  88          -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
  89          -> HsBind Id
  90          -> DsM [(Id,CoreExpr)] -- Result
  91
  92 dsHsBind _ rest (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 ((var', core_expr') : rest) }
 102
 103 dsHsBind _ rest
 104          (FunBind { fun_id = L _ fun, fun_matches = matches,
 105                     fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf })
 106  = do   { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
 107         ; body'    <- mkOptTickBox tick body
 108         ; wrap_fn' <- dsCoercion co_fn
 109         ; return ((fun, wrap_fn' (mkLams args body')) : rest) }
 110
 111 dsHsBind _ rest
 112          (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
 113   = do  { body_expr <- dsGuarded grhss ty
 114         ; sel_binds <- mkSelectorBinds pat body_expr
 115         ; return (sel_binds ++ rest) }
 116
 117 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
 118   = do  { core_prs <- ds_lhs_binds NoSccs binds
 119         ; let env = mkABEnv exports
 120               do_one (lcl_id, rhs)
 121                 | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
 122                 = do { let rhs' = addAutoScc auto_scc gbl_id rhs
 123                      ; (spec_binds, rules) <- dsSpecs gbl_id (Let (Rec core_prs) rhs') spec_prags
 124                                     -- See Note [Specialising in no-dict case]
 125                      ; let   gbl_id'   = addIdSpecialisations gbl_id rules
 126                              main_bind = makeCorePair gbl_id' False 0 rhs'
 127                      ; return (main_bind : spec_binds) }
 128
 129                 | otherwise = return [(lcl_id, rhs)]
 130
 131               locals'  = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
 132                         -- Note [Rules and inlining]
 133         ; export_binds <- mapM do_one core_prs
 134         ; return (concat export_binds ++ locals' ++ rest) }
 135                 -- No Rec needed here (contrast the other AbsBinds cases)
 136                 -- because we can rely on the enclosing dsBind to wrap in Rec
 137
 138
 139 dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
 140   | opt_DsMultiTyVar    -- This (static) debug flag just lets us
 141                         -- switch on and off this optimisation to
 142                         -- see if it has any impact; it is on by default
 143   =     -- Note [Abstracting over tyvars only]
 144     do  { core_prs <- ds_lhs_binds NoSccs binds
 145         ; let arby_env = mkArbitraryTypeEnv tyvars exports
 146               bndrs = mkVarSet (map fst core_prs)
 147
 148               add_lets | core_prs `lengthExceeds` 10 = add_some
 149                        | otherwise                   = mkLets
 150               add_some lg_binds rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
 151                                                           , b `elemVarSet` fvs] rhs
 152                 where
 153                   fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
 154
 155               env = mkABEnv exports
 156               mk_lg_bind lcl_id gbl_id tyvars
 157                  = NonRec (setIdInfo lcl_id vanillaIdInfo)
 158                                 -- Nuke the IdInfo so that no old unfoldings
 159                                 -- confuse use (it might mention something not
 160                                 -- even in scope at the new site
 161                           (mkTyApps (Var gbl_id) (mkTyVarTys tyvars))
 162
 163               do_one lg_binds (lcl_id, rhs)
 164                 | Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
 165                 = do { let rhs' = addAutoScc auto_scc gbl_id  $
 166                                   mkLams id_tvs $
 167                                   mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
 168                                          | tv <- tyvars, not (tv `elem` id_tvs)] $
 169                                   add_lets lg_binds rhs
 170                      ; (spec_binds, rules) <- dsSpecs gbl_id rhs' spec_prags
 171                      ; let   gbl_id'   = addIdSpecialisations gbl_id rules
 172                              main_bind = makeCorePair gbl_id' False 0 rhs'
 173                      ; return (mk_lg_bind lcl_id gbl_id' id_tvs, main_bind : spec_binds) }
 174                 | otherwise
 175                 = do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id))
 176                      ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars,
 177                                [(non_exp_gbl_id, mkLams tyvars (add_lets lg_binds rhs))]) }
 178
 179         ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs)
 180         ; return (concat core_prs' ++ rest) }
 181
 182         -- Another common case: one exported variable
 183         -- Non-recursive bindings come through this way
 184         -- So do self-recursive bindings, and recursive bindings
 185         -- that have been chopped up with type signatures
 186 dsHsBind auto_scc rest
 187      (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
 188   = ASSERT( all (`elem` tyvars) all_tyvars )
 189     do  { core_prs <- ds_lhs_binds NoSccs binds
 190
 191         ; let   -- Always treat the binds as recursive, because the
 192                 -- typechecker makes rather mixed-up dictionary bindings
 193                 core_bind = Rec core_prs
 194                 rhs       = addAutoScc auto_scc global $
 195                             mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
 196
 197         ; (spec_binds, rules) <- dsSpecs global rhs prags
 198
 199         ; let   global'   = addIdSpecialisations global rules
 200                 main_bind = makeCorePair global' (isDefaultMethod prags)
 201                                          (dictArity dicts) rhs
 202
 203         ; return (main_bind : spec_binds ++ rest) }
 204
 205 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 206   = do  { core_prs <- ds_lhs_binds NoSccs binds
 207         ; let env = mkABEnv exports
 208               do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
 209                                   = (lcl_id, addAutoScc auto_scc gbl_id rhs)
 210                                   | otherwise = (lcl_id,rhs)
 211
 212                 -- Rec because of mixed-up dictionary bindings
 213               core_bind = Rec (map do_one core_prs)
 214
 215               tup_expr     = mkBigCoreVarTup locals
 216               tup_ty       = exprType tup_expr
 217               poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
 218                              Let core_bind tup_expr
 219               locals       = [local | (_, _, local, _) <- exports]
 220               local_tys    = map idType locals
 221
 222         ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
 223
 224         ; let mk_bind ((tyvars, global, _, spec_prags), n)  -- locals!!n == local
 225                 =       -- Need to make fresh locals to bind in the selector,
 226                         -- because some of the tyvars will be bound to 'Any'
 227                   do { let ty_args = map mk_ty_arg all_tyvars
 228                            substitute = substTyWith all_tyvars ty_args
 229                      ; locals' <- newSysLocalsDs (map substitute local_tys)
 230                      ; tup_id  <- newSysLocalDs  (substitute tup_ty)
 231                      ; let rhs = mkLams tyvars $ mkLams dicts $
 232                                  mkTupleSelector locals' (locals' !! n) tup_id $
 233                                  mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
 234                                            dicts
 235                      ; (spec_binds, rules) <- dsSpecs global
 236                                                       (Let (NonRec poly_tup_id poly_tup_rhs) rhs)
 237                                                       spec_prags
 238                      ; let global' = addIdSpecialisations global rules
 239                      ; return ((global', rhs) : spec_binds) }
 240                 where
 241                   mk_ty_arg all_tyvar
 242                         | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
 243                         | otherwise               = dsMkArbitraryType all_tyvar
 244
 245         ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
 246              -- Don't scc (auto-)annotate the tuple itself.
 247
 248         ; return ((poly_tup_id, poly_tup_rhs) :
 249                     (concat export_binds_s ++ rest)) }
 250
 251 ------------------------
 252 makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
 253 makeCorePair gbl_id is_default_method dict_arity rhs
 254   | is_default_method                 -- Default methods are *always* inlined
 255   = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
 256
 257   | not (isInlinePragma inline_prag)
 258   = (gbl_id, rhs)
 259
 260   | Just arity <- inlinePragmaSat inline_prag
 261         -- Add an Unfolding for an INLINE (but not for NOINLINE)
 262         -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
 263   = (gbl_id `setIdUnfolding` mkInlineRule rhs (Just (dict_arity + arity)),
 264             -- NB: The arity in the InlineRule takes account of the dictionaries
 265      etaExpand arity rhs)
 266
 267   | otherwise
 268   = (gbl_id `setIdUnfolding` mkInlineRule rhs Nothing, rhs)
 269   where
 270     inline_prag = idInlinePragma gbl_id
 271
 272 dictArity :: [Var] -> Arity
 273 -- Don't count coercion variables in arity
 274 dictArity dicts = count isId dicts
 275
 276
 277 ------------------------
 278 type AbsBindEnv = VarEnv ([TyVar], Id, Id, TcSpecPrags)
 279         -- Maps the "lcl_id" for an AbsBind to
 280         -- its "gbl_id" and associated pragmas, if any
 281
 282 mkABEnv :: [([TyVar], Id, Id, TcSpecPrags)] -> AbsBindEnv
 283 -- Takes the exports of a AbsBinds, and returns a mapping
 284 --      lcl_id -> (tyvars, gbl_id, lcl_id, prags)
 285 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
 286 \end{code}
 287
 288 Note [Rules and inlining]
 289 ~~~~~~~~~~~~~~~~~~~~~~~~~
 290 Common special case: no type or dictionary abstraction
 291 This is a bit less trivial than you might suppose
 292 The naive way woudl be to desguar to something like
 293         f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
 294         M.f = f_lcl             -- Generated from "exports"
 295 But we don't want that, because if M.f isn't exported,
 296 it'll be inlined unconditionally at every call site (its rhs is
 297 trivial).  That would be ok unless it has RULES, which would
 298 thereby be completely lost.  Bad, bad, bad.
 299
 300 Instead we want to generate
 301         M.f = ...f_lcl...
 302         f_lcl = M.f
 303 Now all is cool. The RULES are attached to M.f (by SimplCore),
 304 and f_lcl is rapidly inlined away.
 305
 306 This does not happen in the same way to polymorphic binds,
 307 because they desugar to
 308         M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
 309 Although I'm a bit worried about whether full laziness might
 310 float the f_lcl binding out and then inline M.f at its call site -}
 311
 312 Note [Specialising in no-dict case]
 313 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 314 Even if there are no tyvars or dicts, we may have specialisation pragmas.
 315 Class methods can generate
 316       AbsBinds [] [] [( ... spec-prag]
 317          { AbsBinds [tvs] [dicts] ...blah }
 318 So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
 319
 320   class  (Real a, Fractional a) => RealFrac a  where
 321     round :: (Integral b) => a -> b
 322
 323   instance  RealFrac Float  where
 324     {-# SPECIALIZE round :: Float -> Int #-}
 325
 326 The top-level AbsBinds for $cround has no tyvars or dicts (because the
 327 instance does not).  But the method is locally overloaded!
 328
 329 Note [Abstracting over tyvars only]
 330 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 331 When abstracting over type variable only (not dictionaries), we don't really need to
 332 built a tuple and select from it, as we do in the general case. Instead we can take
 333
 334         AbsBinds [a,b] [ ([a,b], fg, fl, _),
 335                          ([b],   gg, gl, _) ]
 336                 { fl = e1
 337                   gl = e2
 338                    h = e3 }
 339
 340 and desugar it to
 341
 342         fg = /\ab. let B in e1
 343         gg = /\b. let a = () in let B in S(e2)
 344         h  = /\ab. let B in e3
 345
 346 where B is the *non-recursive* binding
 347         fl = fg a b
 348         gl = gg b
 349         h  = h a b    -- See (b); note shadowing!
 350
 351 Notice (a) g has a different number of type variables to f, so we must
 352              use the mkArbitraryType thing to fill in the gaps.
 353              We use a type-let to do that.
 354
 355          (b) The local variable h isn't in the exports, and rather than
 356              clone a fresh copy we simply replace h by (h a b), where
 357              the two h's have different types!  Shadowing happens here,
 358              which looks confusing but works fine.
 359
 360          (c) The result is *still* quadratic-sized if there are a lot of
 361              small bindings.  So if there are more than some small
 362              number (10), we filter the binding set B by the free
 363              variables of the particular RHS.  Tiresome.
 364
 365 Why got to this trouble?  It's a common case, and it removes the
 366 quadratic-sized tuple desugaring.  Less clutter, hopefullly faster
 367 compilation, especially in a case where there are a *lot* of
 368 bindings.
 369
 370
 371 Note [Eta-expanding INLINE things]
 372 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 373 Consider
 374    foo :: Eq a => a -> a
 375    {-# INLINE foo #-}
 376    foo x = ...
 377
 378 If (foo d) ever gets floated out as a common sub-expression (which can
 379 happen as a result of method sharing), there's a danger that we never
 380 get to do the inlining, which is a Terribly Bad thing given that the
 381 user said "inline"!
 382
 383 To avoid this we pre-emptively eta-expand the definition, so that foo
 384 has the arity with which it is declared in the source code.  In this
 385 example it has arity 2 (one for the Eq and one for x). Doing this
 386 should mean that (foo d) is a PAP and we don't share it.
 387
 388 Note [Nested arities]
 389 ~~~~~~~~~~~~~~~~~~~~~
 390 For reasons that are not entirely clear, method bindings come out looking like
 391 this:
 392
 393   AbsBinds [] [] [$cfromT <= [] fromT]
 394     $cfromT [InlPrag=INLINE] :: T Bool -> Bool
 395     { AbsBinds [] [] [fromT <= [] fromT_1]
 396         fromT :: T Bool -> Bool
 397         { fromT_1 ((TBool b)) = not b } } }
 398
 399 Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be
 400 gotten from the binding for fromT_1.
 401
 402 It might be better to have just one level of AbsBinds, but that requires more
 403 thought!
 404
 405 Note [Implementing SPECIALISE pragmas]
 406 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 407 Example:
 408         f :: (Eq a, Ix b) => a -> b -> Bool
 409         {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
 410         f = <poly_rhs>
 411
 412 From this the typechecker generates
 413
 414     AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
 415
 416     SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
 417                       -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
 418
 419 Note that wrap_fn can transform *any* function with the right type prefix
 420     forall ab. (Eq a, Ix b) => XXX
 421 regardless of XXX.  It's sort of polymorphic in XXX.  This is
 422 useful: we use the same wrapper to transform each of the class ops, as
 423 well as the dict.
 424
 425 From these we generate:
 426
 427     Rule:       forall p, q, (dp:Ix p), (dq:Ix q).
 428                     f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
 429
 430     Spec bind:  f_spec = wrap_fn <poly_rhs>
 431
 432 Note that
 433
 434   * The LHS of the rule may mention dictionary *expressions* (eg
 435     $dfIxPair dp dq), and that is essential because the dp, dq are
 436     needed on the RHS.
 437
 438   * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
 439     can fully specialise it.
 440
 441 \begin{code}
 442 ------------------------
 443 dsSpecs :: Id           -- The polymorphic Id
 444         -> CoreExpr     -- Its rhs
 445         -> TcSpecPrags
 446         -> DsM ( [(Id,CoreExpr)]        -- Binding for specialised Ids
 447                , [CoreRule] )           -- Rules for the Global Ids
 448 -- See Note [Implementing SPECIALISE pragmas]
 449 dsSpecs poly_id poly_rhs prags
 450   = case prags of
 451       IsDefaultMethod      -> return ([], [])
 452       SpecPrags sps -> do { pairs <- mapMaybeM spec_one sps
 453                           ; let (spec_binds_s, rules) = unzip pairs
 454                           ; return (concat spec_binds_s, rules) }
 455  where
 456     spec_one :: Located TcSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule))
 457     spec_one (L loc (SpecPrag spec_co spec_inl))
 458       = putSrcSpanDs loc $
 459         do { let poly_name = idName poly_id
 460            ; spec_name <- newLocalName poly_name
 461            ; wrap_fn   <- dsCoercion spec_co
 462            ; let ds_spec_expr = wrap_fn (Var poly_id)
 463            ; case decomposeRuleLhs ds_spec_expr of {
 464                Nothing -> do { warnDs (decomp_msg spec_co)
 465                              ; return Nothing } ;
 466
 467                Just (bndrs, _fn, args) ->
 468
 469            -- Check for dead binders: Note [Unused spec binders]
 470              case filter isDeadBinder bndrs of {
 471                 bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
 472                    | otherwise -> do
 473
 474            { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (realIdUnfolding poly_id)
 475
 476            ; let spec_ty = exprType ds_spec_expr
 477                  spec_id  = mkLocalId spec_name spec_ty
 478                             `setInlinePragma` inl_prag
 479                             `setIdUnfolding`  spec_unf
 480                  inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
 481                           | otherwise                      = spec_inl
 482                       -- Get the INLINE pragma from SPECIALISE declaration, or,
 483                       -- failing that, from the original Id
 484
 485                  extra_dict_bndrs = [ localiseId d  -- See Note [Constant rule dicts]
 486                                     | d <- varSetElems (exprFreeVars ds_spec_expr)
 487                                     , isDictId d]
 488                                 -- Note [Const rule dicts]
 489
 490                  rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
 491                                 AlwaysActive poly_name
 492                                 (extra_dict_bndrs ++ bndrs) args
 493                                 (mkVarApps (Var spec_id) bndrs)
 494
 495                  spec_rhs  = wrap_fn poly_rhs
 496                  spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
 497
 498             ; return (Just (spec_pair : unf_pairs, rule))
 499             } } } }
 500
 501     dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
 502                                  <+> ptext (sLit "in specialied type:"),
 503                              nest 2 (pprTheta (map get_pred bs))]
 504                        , ptext (sLit "SPECIALISE pragma ignored")]
 505     get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
 506
 507     decomp_msg spec_co
 508         = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
 509              2 (pprHsWrapper (ppr poly_id) spec_co)
 510
 511
 512 specUnfolding :: (CoreExpr -> CoreExpr) -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
 513 specUnfolding wrap_fn (DFunUnfolding con ops)
 514   = do { let spec_rhss = map wrap_fn ops
 515        ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
 516        ; return (DFunUnfolding con (map Var spec_ids), spec_ids `zip` spec_rhss) }
 517 specUnfolding _ _
 518   = return (noUnfolding, [])
 519
 520 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
 521 -- If any of the tyvars is missing from any of the lists in
 522 -- the second arg, return a binding in the result
 523 mkArbitraryTypeEnv tyvars exports
 524   = go emptyVarEnv exports
 525   where
 526     go env [] = env
 527     go env ((ltvs, _, _, _) : exports)
 528         = go env' exports
 529         where
 530           env' = foldl extend env [tv | tv <- tyvars
 531                                       , not (tv `elem` ltvs)
 532                                       , not (tv `elemVarEnv` env)]
 533
 534     extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
 535
 536 dsMkArbitraryType :: TcTyVar -> Type
 537 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
 538 \end{code}
 539
 540 Note [Unused spec binders]
 541 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 542 Consider
 543         f :: a -> a
 544         {-# SPECIALISE f :: Eq a => a -> a #-}
 545 It's true that this *is* a more specialised type, but the rule
 546 we get is something like this:
 547         f_spec d = f
 548         RULE: f = f_spec d
 549 Note that the rule is bogus, becuase it mentions a 'd' that is
 550 not bound on the LHS!  But it's a silly specialisation anyway, becuase
 551 the constraint is unused.  We could bind 'd' to (error "unused")
 552 but it seems better to reject the program because it's almost certainly
 553 a mistake.  That's what the isDeadBinder call detects.
 554
 555 Note [Const rule dicts]
 556 ~~~~~~~~~~~~~~~~~~~~~~~
 557 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
 558 which is presumably in scope at the function definition site, we can quantify
 559 over it too.  *Any* dict with that type will do.
 560
 561 So for example when you have
 562         f :: Eq a => a -> a
 563         f = <rhs>
 564         {-# SPECIALISE f :: Int -> Int #-}
 565
 566 Then we get the SpecPrag
 567         SpecPrag (f Int dInt)
 568
 569 And from that we want the rule
 570
 571         RULE forall dInt. f Int dInt = f_spec
 572         f_spec = let f = <rhs> in f Int dInt
 573
 574 But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
 575 Name, and you can't bind them in a lambda or forall without getting things
 576 confused. Hence the use of 'localiseId' to make it Internal.
 577
 578
 579 %************************************************************************
 580 %*                                                                      *
 581 \subsection{Adding inline pragmas}
 582 %*                                                                      *
 583 %************************************************************************
 584
 585 \begin{code}
 586 decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
 587 -- Take apart the LHS of a RULE.  It's suuposed to look like
 588 --     /\a. f a Int dOrdInt
 589 -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
 590 -- That is, the RULE binders are lambda-bound
 591 -- Returns Nothing if the LHS isn't of the expected shape
 592 decomposeRuleLhs lhs
 593   = case collectArgs body of
 594         (Var fn, args) -> Just (bndrs, fn, args)
 595
 596         (Case scrut bndr ty [(DEFAULT, _, body)], args)
 597                 | isDeadBinder bndr     -- Note [Matching seqId]
 598                 -> Just (bndrs, seqId, args' ++ args)
 599                 where
 600                    args' = [Type (idType bndr), Type ty, scrut, body]
 601
 602         _other -> Nothing       -- Unexpected shape
 603   where
 604     (bndrs, body) = collectBinders (simpleOptExpr lhs)
 605         -- simpleOptExpr occurrence-analyses and simplifies the lhs
 606         -- and thereby
 607         -- (a) identifies unused binders: Note [Unused spec binders]
 608         -- (b) sorts dict bindings into NonRecs
 609         --      so they can be inlined by 'decomp'
 610         -- (c) substitute trivial lets so that they don't get in the way
 611         --     Note that we substitute the function too; we might
 612         --     have this as a LHS:  let f71 = M.f Int in f71
 613         -- NB: tcSimplifyRuleLhs is very careful not to generate complicated
 614         --     dictionary expressions that we might have to match
 615 \end{code}
 616
 617 Note [Matching seqId]
 618 ~~~~~~~~~~~~~~~~~~~
 619 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
 620 and this code turns it back into an application of seq!
 621 See Note [Rules for seq] in MkId for the details.
 622
 623
 624 %************************************************************************
 625 %*                                                                      *
 626 \subsection[addAutoScc]{Adding automatic sccs}
 627 %*                                                                      *
 628 %************************************************************************
 629
 630 \begin{code}
 631 data AutoScc = NoSccs
 632              | AddSccs Module (Id -> Bool)
 633 -- The (Id->Bool) says which Ids to add SCCs to
 634
 635 addAutoScc :: AutoScc
 636            -> Id        -- Binder
 637            -> CoreExpr  -- Rhs
 638            -> CoreExpr  -- Scc'd Rhs
 639
 640 addAutoScc NoSccs _ rhs
 641   = rhs
 642 addAutoScc (AddSccs mod add_scc) id rhs
 643   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
 644   | otherwise  = rhs
 645 \end{code}
 646
 647 If profiling and dealing with a dict binding,
 648 wrap the dict in @_scc_ DICT <dict>@:
 649
 650 \begin{code}
 651 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
 652 addDictScc _ rhs = return rhs
 653
 654 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
 655   | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
 656     || not (isDictId var)
 657   = return rhs                          -- That's easy: do nothing
 658
 659   | otherwise
 660   = do (mod, grp) <- getModuleAndGroupDs
 661         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
 662        return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
 663 -}
 664 \end{code}
 665
 666
 667 %************************************************************************
 668 %*                                                                      *
 669                 Desugaring coercions
 670 %*                                                                      *
 671 %************************************************************************
 672
 673
 674 \begin{code}
 675 dsCoercion :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
 676 dsCoercion WpHole            = return (\e -> e)
 677 dsCoercion (WpCompose c1 c2) = do { k1 <- dsCoercion c1
 678                                   ; k2 <- dsCoercion c2
 679                                   ; return (k1 . k2) }
 680 dsCoercion (WpCast co)       = return (\e -> Cast e co)
 681 dsCoercion (WpLam id)        = return (\e -> Lam id e)
 682 dsCoercion (WpTyLam tv)      = return (\e -> Lam tv e)
 683 dsCoercion (WpApp v)         | isTyVar v   -- Probably a coercion var
 684                              = return (\e -> App e (Type (mkTyVarTy v)))
 685                              | otherwise
 686                              = return (\e -> App e (Var v))
 687 dsCoercion (WpTyApp ty)      = return (\e -> App e (Type ty))
 688 dsCoercion (WpLet bs)        = do { prs <- dsLHsBinds bs
 689                                   ; return (\e -> Let (Rec prs) e) }
 690 \end{code}