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