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