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