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