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, dsExpr )
  21 import {-# SOURCE #-}   Match( matchWrapper )
  22
  23 import DsMonad
  24 import DsGRHSs
  25 import DsUtils
  26 import OccurAnal
  27
  28 import HsSyn            -- lots of things
  29 import CoreSyn          -- lots of things
  30 import MkCore
  31 import CoreUtils
  32 import CoreUnfold
  33 import CoreFVs
  34
  35 import TcHsSyn  ( mkArbitraryType )     -- Mis-placed?
  36 import TcType
  37 import CostCentre
  38 import Module
  39 import Id
  40 import Var      ( Var, TyVar )
  41 import VarSet
  42 import Rules
  43 import VarEnv
  44 import Type
  45 import Outputable
  46 import SrcLoc
  47 import Maybes
  48 import Bag
  49 import BasicTypes hiding ( TopLevel )
  50 import FastString
  51 import StaticFlags      ( opt_DsMultiTyVar )
  52 import Util             ( mapSnd, count, mapAndUnzip, lengthExceeds )
  53
  54 import Control.Monad
  55 import Data.List
  56 \end{code}
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 \begin{code}
  65 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
  66 dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
  67
  68 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
  69 dsLHsBinds binds = ds_lhs_binds NoSccs binds
  70
  71
  72 ------------------------
  73 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
  74
  75          -- scc annotation policy (see below)
  76 ds_lhs_binds auto_scc binds =  foldM (dsLHsBind auto_scc) [] (bagToList binds)
  77
  78 dsLHsBind :: AutoScc
  79          -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
  80          -> LHsBind Id
  81          -> DsM [(Id,CoreExpr)] -- Result
  82 dsLHsBind auto_scc rest (L loc bind)
  83   = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
  84
  85 dsHsBind :: AutoScc
  86          -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
  87          -> HsBind Id
  88          -> DsM [(Id,CoreExpr)] -- Result
  89
  90 dsHsBind _ rest (VarBind var expr inline_regardless)
  91   = do  { core_expr <- dsLExpr expr
  92
  93                 -- Dictionary bindings are always VarBinds,
  94                 -- so we only need do this here
  95         ; core_expr' <- addDictScc var core_expr
  96         ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr'
  97                    | otherwise         = var
  98
  99         ; return ((var', core_expr') : rest) }
 100
 101 dsHsBind _ rest
 102          (FunBind { fun_id = L _ fun, fun_matches = matches,
 103                     fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf })
 104  = do   { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
 105         ; body' <- mkOptTickBox tick body
 106         ; rhs   <- dsCoercion co_fn (return (mkLams args body'))
 107         ; return ((fun,rhs) : rest) }
 108
 109 dsHsBind _ rest
 110          (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
 111   = do  { body_expr <- dsGuarded grhss ty
 112         ; sel_binds <- mkSelectorBinds pat body_expr
 113         ; return (sel_binds ++ rest) }
 114
 115 {-  Note [Rules and inlining]
 116     ~~~~~~~~~~~~~~~~~~~~~~~~~
 117     Common special case: no type or dictionary abstraction
 118     This is a bit less trivial than you might suppose
 119     The naive way woudl be to desguar to something like
 120         f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
 121         M.f = f_lcl             -- Generated from "exports"
 122     But we don't want that, because if M.f isn't exported,
 123     it'll be inlined unconditionally at every call site (its rhs is
 124     trivial).  That would be ok unless it has RULES, which would
 125     thereby be completely lost.  Bad, bad, bad.
 126
 127     Instead we want to generate
 128         M.f = ...f_lcl...
 129         f_lcl = M.f
 130     Now all is cool. The RULES are attached to M.f (by SimplCore),
 131     and f_lcl is rapidly inlined away.
 132
 133     This does not happen in the same way to polymorphic binds,
 134     because they desugar to
 135         M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
 136     Although I'm a bit worried about whether full laziness might
 137     float the f_lcl binding out and then inline M.f at its call site -}
 138
 139 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
 140   = do  { core_prs <- ds_lhs_binds NoSccs binds
 141         ; let env = mkABEnv exports
 142               ar_env = mkArityEnv binds
 143               do_one (lcl_id, rhs)
 144                 | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
 145                 = makeCorePair gbl_id (lookupArity ar_env lcl_id) prags $
 146                   addAutoScc auto_scc gbl_id rhs
 147
 148                 | otherwise = (lcl_id, rhs)
 149
 150               locals'  = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
 151                         -- Note [Rules and inlining]
 152         ; return (map do_one core_prs ++ locals' ++ rest) }
 153                 -- No Rec needed here (contrast the other AbsBinds cases)
 154                 -- because we can rely on the enclosing dsBind to wrap in Rec
 155
 156
 157 {- Note [Abstracting over tyvars only]
 158    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 159    When abstracting over type variable only (not dictionaries), we don't really need to
 160    built a tuple and select from it, as we do in the general case. Instead we can take
 161
 162         AbsBinds [a,b] [ ([a,b], fg, fl, _),
 163                          ([b],   gg, gl, _) ]
 164                 { fl = e1
 165                   gl = e2
 166                    h = e3 }
 167
 168    and desugar it to
 169
 170         fg = /\ab. let B in e1
 171         gg = /\b. let a = () in let B in S(e2)
 172         h  = /\ab. let B in e3
 173
 174   where B is the *non-recursive* binding
 175         fl = fg a b
 176         gl = gg b
 177         h  = h a b    -- See (b); note shadowing!
 178
 179   Notice (a) g has a different number of type variables to f, so we must
 180              use the mkArbitraryType thing to fill in the gaps.
 181              We use a type-let to do that.
 182
 183          (b) The local variable h isn't in the exports, and rather than
 184              clone a fresh copy we simply replace h by (h a b), where
 185              the two h's have different types!  Shadowing happens here,
 186              which looks confusing but works fine.
 187
 188          (c) The result is *still* quadratic-sized if there are a lot of
 189              small bindings.  So if there are more than some small
 190              number (10), we filter the binding set B by the free
 191              variables of the particular RHS.  Tiresome.
 192
 193   Why got to this trouble?  It's a common case, and it removes the
 194   quadratic-sized tuple desugaring.  Less clutter, hopefullly faster
 195   compilation, especially in a case where there are a *lot* of
 196   bindings.
 197 -}
 198
 199
 200 dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
 201   | opt_DsMultiTyVar    -- This (static) debug flag just lets us
 202                         -- switch on and off this optimisation to
 203                         -- see if it has any impact; it is on by default
 204   =     -- Note [Abstracting over tyvars only]
 205     do  { core_prs <- ds_lhs_binds NoSccs binds
 206         ; arby_env <- mkArbitraryTypeEnv tyvars exports
 207         ; let (lg_binds, core_prs') = mapAndUnzip do_one core_prs
 208               bndrs = mkVarSet (map fst core_prs)
 209
 210               add_lets | core_prs `lengthExceeds` 10 = add_some
 211                        | otherwise                   = mkLets lg_binds
 212               add_some rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
 213                                     , b `elemVarSet` fvs] rhs
 214                 where
 215                   fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
 216
 217               ar_env = mkArityEnv binds
 218               env = mkABEnv exports
 219
 220               do_one (lcl_id, rhs)
 221                 | Just (id_tvs, gbl_id, _, prags) <- lookupVarEnv env lcl_id
 222                 = let rhs' = addAutoScc auto_scc gbl_id  $
 223                              mkLams id_tvs $
 224                              mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
 225                                     | tv <- tyvars, not (tv `elem` id_tvs)] $
 226                              add_lets rhs
 227                   in (NonRec lcl_id (mkTyApps (Var gbl_id) (mkTyVarTys id_tvs)),
 228                       makeCorePair gbl_id (lookupArity ar_env lcl_id) prags rhs')
 229                 | otherwise
 230                 = (NonRec lcl_id (mkTyApps (Var non_exp_gbl_id) (mkTyVarTys tyvars)),
 231                    (non_exp_gbl_id, mkLams tyvars (add_lets rhs)))
 232                 where
 233                   non_exp_gbl_id = setIdType lcl_id (mkForAllTys tyvars (idType lcl_id))
 234
 235         ; return (core_prs' ++ rest) }
 236
 237         -- Another common case: one exported variable
 238         -- Non-recursive bindings come through this way
 239         -- So do self-recursive bindings, and recursive bindings
 240         -- that have been chopped up with type signatures
 241 dsHsBind auto_scc rest
 242      (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
 243   = ASSERT( all (`elem` tyvars) all_tyvars )
 244     do  { core_prs <- ds_lhs_binds NoSccs binds
 245
 246         ; let   -- Always treat the binds as recursive, because the typechecker
 247                 -- makes rather mixed-up dictionary bindings
 248                 core_bind = Rec core_prs
 249                 inl_arity = lookupArity (mkArityEnv binds) local
 250
 251         ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global
 252                                    local inl_arity core_bind) prags
 253
 254         ; let   (spec_binds, rules) = unzip (catMaybes mb_specs)
 255                 global'   = addIdSpecialisations global rules
 256                 rhs       = addAutoScc auto_scc global $
 257                             mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
 258                 main_bind = makeCorePair global' (inl_arity + length dicts) prags rhs
 259
 260         ; return (main_bind : spec_binds ++ rest) }
 261
 262 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 263   = do  { core_prs <- ds_lhs_binds NoSccs binds
 264         ; let env = mkABEnv exports
 265               ar_env = mkArityEnv binds
 266               do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
 267                                   = (lcl_id, addAutoScc auto_scc gbl_id rhs)
 268                                   | otherwise = (lcl_id,rhs)
 269
 270                 -- Rec because of mixed-up dictionary bindings
 271               core_bind = Rec (map do_one core_prs)
 272
 273               tup_expr      = mkBigCoreVarTup locals
 274               tup_ty        = exprType tup_expr
 275               poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
 276                               Let core_bind tup_expr
 277               locals        = [local | (_, _, local, _) <- exports]
 278               local_tys     = map idType locals
 279
 280               inl_prags :: [(Id, SrcSpan)]
 281               inl_prags = [(id, loc) | (_, id, _, prags) <- exports
 282                                      , L loc (InlinePrag {}) <- prags ]
 283
 284         ; mapM_ discardedInlineWarning inl_prags
 285
 286         ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
 287
 288         ; let dict_args = map Var dicts
 289
 290               mk_bind ((tyvars, global, local, prags), n)       -- locals !! n == local
 291                 =       -- Need to make fresh locals to bind in the selector, because
 292                         -- some of the tyvars will be bound to 'Any'
 293                   do { ty_args <- mapM mk_ty_arg all_tyvars
 294                      ; let substitute = substTyWith all_tyvars ty_args
 295                      ; locals' <- newSysLocalsDs (map substitute local_tys)
 296                      ; tup_id  <- newSysLocalDs  (substitute tup_ty)
 297                      ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local
 298                                                 (lookupArity ar_env local) core_bind)
 299                                          prags
 300                      ; let (spec_binds, rules) = unzip (catMaybes mb_specs)
 301                            global' = addIdSpecialisations global rules
 302                            rhs = mkLams tyvars $ mkLams dicts $
 303                                  mkTupleSelector locals' (locals' !! n) tup_id $
 304                                  mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
 305                      ; return ((global', rhs) : spec_binds) }
 306                 where
 307                   mk_ty_arg all_tyvar
 308                         | all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar)
 309                         | otherwise               = dsMkArbitraryType all_tyvar
 310
 311         ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
 312              -- Don't scc (auto-)annotate the tuple itself.
 313
 314         ; return ((poly_tup_id, poly_tup_expr) :
 315                     (concat export_binds_s ++ rest)) }
 316
 317 ------------------------
 318 makeCorePair :: Id-> Arity -> [LPrag] -> CoreExpr -> (Id, CoreExpr)
 319 makeCorePair gbl_id arity prags rhs
 320   = (addInline gbl_id arity rhs prags, rhs)
 321
 322 ------------------------
 323 discardedInlineWarning :: (Id, SrcSpan) -> DsM ()
 324 discardedInlineWarning (id, loc)
 325   = putSrcSpanDs loc $
 326     warnDs $ sep [ ptext (sLit "Discarding INLINE pragma for") <+> ppr id
 327                  , ptext (sLit "because it is bound by a pattern, or a mutual recursion") ]
 328
 329 ------------------------
 330 type AbsBindEnv = VarEnv ([TyVar], Id, Id, [LPrag])
 331         -- Maps the "lcl_id" for an AbsBind to
 332         -- its "gbl_id" and associated pragmas, if any
 333
 334 mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> AbsBindEnv
 335 -- Takes the exports of a AbsBinds, and returns a mapping
 336 --      lcl_id -> (tyvars, gbl_id, lcl_id, prags)
 337 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
 338
 339 mkArityEnv :: LHsBinds Id -> IdEnv Arity
 340         -- Maps a local to the arity of its definition
 341 mkArityEnv binds = mkVarEnv (mapCatMaybes get_arity (bagToList binds))
 342   where
 343     get_arity (L _ (FunBind { fun_id = id, fun_matches = ms })) = Just (unLoc id, matchGroupArity ms)
 344     get_arity _ = Nothing
 345
 346 lookupArity :: IdEnv Arity -> Id -> Arity
 347 lookupArity ar_env id = lookupVarEnv ar_env id `orElse` 0
 348
 349 addInline :: Id -> Arity -> CoreExpr -> [LPrag] -> Id
 350 addInline id arity rhs prags
 351   = case [inl | L _ (InlinePrag inl) <- prags] of
 352       []             -> id
 353       (inl_spec : _) -> addInlineToId id arity rhs inl_spec
 354
 355 addInlineToId :: Id -> Arity -> CoreExpr -> InlineSpec -> Id
 356 addInlineToId id inl_arity rhs (Inline phase is_inline)
 357   = id `setInlinePragma` phase
 358        `setIdUnfolding`  inline_rule
 359   where
 360     inline_rule | is_inline = mkInlineRule rhs inl_arity
 361                 | otherwise = noUnfolding
 362
 363 ------------------------
 364 dsSpec :: [TyVar] -> [DictId] -> [TyVar]
 365        -> Id -> Id -> Arity             -- Global, local, arity of local
 366        -> CoreBind -> LPrag
 367        -> DsM (Maybe ((Id,CoreExpr),    -- Binding for specialised Id
 368                       CoreRule))        -- Rule for the Global Id
 369
 370 -- Example:
 371 --      f :: (Eq a, Ix b) => a -> b -> b
 372 --      {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
 373 --
 374 --      AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
 375 --
 376 --      SpecPrag (/\b.\(d:Ix b). f Int b dInt d)
 377 --               (forall b. Ix b => Int -> b -> b)
 378 --
 379 -- Rule:        forall b,(d:Ix b). f Int b dInt d = f_spec b d
 380 --
 381 -- Spec bind:   f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono
 382 --                       /\b.\(d:Ix b). in f Int b dInt d
 383 --              The idea is that f occurs just once, so it'll be
 384 --              inlined and specialised
 385 --
 386 -- Given SpecPrag (/\as.\ds. f es) t, we have
 387 -- the defn             f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = <f-rhs> in f_mono
 388 --                                     in f es
 389 -- and the RULE         forall as, ds. f es = f_spec as ds
 390 --
 391 -- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
 392 -- (a bit silly, because then the
 393 dsSpec _ _ _ _ _ _ _ (L _ (InlinePrag {}))
 394   = return Nothing
 395
 396 dsSpec all_tvs dicts tvs poly_id mono_id inl_arity mono_bind
 397        (L loc (SpecPrag spec_expr spec_ty inl))
 398   = putSrcSpanDs loc $
 399     do  { let poly_name = idName poly_id
 400         ; spec_name <- newLocalName poly_name
 401         ; ds_spec_expr  <- dsExpr spec_expr
 402         ; case (decomposeRuleLhs ds_spec_expr) of {
 403             Nothing -> do { warnDs decomp_msg; return Nothing } ;
 404
 405             Just (bndrs, _fn, args) ->
 406
 407         -- Check for dead binders: Note [Unused spec binders]
 408           case filter isDeadBinder bndrs of {
 409                 bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
 410                    | otherwise -> do
 411
 412         { f_body <- fix_up (Let mono_bind (Var mono_id))
 413
 414         ; let     local_poly  = setIdNotExported poly_id
 415                         -- Very important to make the 'f' non-exported,
 416                         -- else it won't be inlined!
 417                   spec_id     = mkLocalId spec_name spec_ty
 418                   spec_id1    = addInlineToId spec_id (inl_arity + count isDictId bndrs)
 419                                               spec_rhs inl
 420                   spec_rhs    = Let (NonRec local_poly poly_f_body) ds_spec_expr
 421                   poly_f_body = mkLams (tvs ++ dicts) f_body
 422
 423                   extra_dict_bndrs = [localiseId d  -- See Note [Constant rule dicts]
 424                                      | d <- varSetElems (exprFreeVars ds_spec_expr)
 425                                      , isDictId d]
 426                         -- Note [Const rule dicts]
 427
 428                   rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
 429                                 AlwaysActive poly_name
 430                                 (extra_dict_bndrs ++ bndrs) args
 431                                 (mkVarApps (Var spec_id) bndrs)
 432         ; return (Just ((spec_id1, spec_rhs), rule))
 433         } } } }
 434   where
 435         -- Bind to Any any of all_ptvs that aren't
 436         -- relevant for this particular function
 437     fix_up body | null void_tvs = return body
 438                 | otherwise     = do { void_tys <- mapM dsMkArbitraryType void_tvs
 439                                      ; return (mkTyApps (mkLams void_tvs body) void_tys) }
 440
 441     void_tvs = all_tvs \\ tvs
 442
 443     dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
 444                                  <+> ptext (sLit "in specialied type:"),
 445                              nest 2 (pprTheta (map get_pred bs))]
 446                        , ptext (sLit "SPECIALISE pragma ignored")]
 447     get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
 448
 449     decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
 450                     2 (ppr spec_expr)
 451
 452
 453 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> DsM (TyVarEnv Type)
 454 -- If any of the tyvars is missing from any of the lists in
 455 -- the second arg, return a binding in the result
 456 mkArbitraryTypeEnv tyvars exports
 457   = go emptyVarEnv exports
 458   where
 459     go env [] = return env
 460     go env ((ltvs, _, _, _) : exports)
 461         = do { env' <- foldlM extend env [tv | tv <- tyvars
 462                                         , not (tv `elem` ltvs)
 463                                         , not (tv `elemVarEnv` env)]
 464              ; go env' exports }
 465
 466     extend env tv = do { ty <- dsMkArbitraryType tv
 467                        ; return (extendVarEnv env tv ty) }
 468
 469
 470 dsMkArbitraryType :: TcTyVar -> DsM Type
 471 dsMkArbitraryType tv = mkArbitraryType warn tv
 472   where
 473     warn span msg = putSrcSpanDs span (warnDs msg)
 474 \end{code}
 475
 476 Note [Unused spec binders]
 477 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 478 Consider
 479         f :: a -> a
 480         {-# SPECIALISE f :: Eq a => a -> a #-}
 481 It's true that this *is* a more specialised type, but the rule
 482 we get is something like this:
 483         f_spec d = f
 484         RULE: f = f_spec d
 485 Note that the rule is bogus, becuase it mentions a 'd' that is
 486 not bound on the LHS!  But it's a silly specialisation anyway, becuase
 487 the constraint is unused.  We could bind 'd' to (error "unused")
 488 but it seems better to reject the program because it's almost certainly
 489 a mistake.  That's what the isDeadBinder call detects.
 490
 491 Note [Const rule dicts]
 492 ~~~~~~~~~~~~~~~~~~~~~~~
 493 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
 494 which is presumably in scope at the function definition site, we can quantify
 495 over it too.  *Any* dict with that type will do.
 496
 497 So for example when you have
 498         f :: Eq a => a -> a
 499         f = <rhs>
 500         {-# SPECIALISE f :: Int -> Int #-}
 501
 502 Then we get the SpecPrag
 503         SpecPrag (f Int dInt) Int
 504
 505 And from that we want the rule
 506
 507         RULE forall dInt. f Int dInt = f_spec
 508         f_spec = let f = <rhs> in f Int dInt
 509
 510 But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
 511 Name, and you can't bind them in a lambda or forall without getting things
 512 confused. Hence the use of 'localiseId' to make it Internal.
 513
 514
 515 %************************************************************************
 516 %*                                                                      *
 517 \subsection{Adding inline pragmas}
 518 %*                                                                      *
 519 %************************************************************************
 520
 521 \begin{code}
 522 decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
 523 -- Take apart the LHS of a RULE.  It's suuposed to look like
 524 --     /\a. f a Int dOrdInt
 525 -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
 526 -- That is, the RULE binders are lambda-bound
 527 -- Returns Nothing if the LHS isn't of the expected shape
 528 decomposeRuleLhs lhs
 529   = case (decomp emptyVarEnv body) of
 530         Nothing         -> Nothing
 531         Just (fn, args) -> Just (bndrs, fn, args)
 532   where
 533     occ_lhs = occurAnalyseExpr lhs
 534                 -- The occurrence-analysis does two things
 535                 -- (a) identifies unused binders: Note [Unused spec binders]
 536                 -- (b) sorts dict bindings into NonRecs
 537                 --      so they can be inlined by 'decomp'
 538     (bndrs, body) = collectBinders occ_lhs
 539
 540         -- Substitute dicts in the LHS args, so that there
 541         -- aren't any lets getting in the way
 542         -- Note that we substitute the function too; we might have this as
 543         -- a LHS:       let f71 = M.f Int in f71
 544     decomp env (Let (NonRec dict rhs) body)
 545         = decomp (extendVarEnv env dict (simpleSubst env rhs)) body
 546     decomp env body
 547         = case collectArgs (simpleSubst env body) of
 548             (Var fn, args) -> Just (fn, args)
 549             _              -> Nothing
 550
 551 simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
 552 -- Similar to CoreSubst.substExpr, except that
 553 -- (a) Takes no account of capture; at this point there is no shadowing
 554 -- (b) Can have a GlobalId (imported) in its domain
 555 -- (c) Ids only; no types are substituted
 556 -- (d) Does not insist (as does CoreSubst.lookupIdSubst) that the
 557 --     in-scope set mentions all LocalIds mentioned in the argument of the subst
 558 --
 559 -- (b) and (d) are the reasons we can't use CoreSubst
 560 --
 561 -- (I had a note that (b) is "no longer relevant", and indeed it doesn't
 562 --  look relevant here. Perhaps there was another caller of simpleSubst.)
 563
 564 simpleSubst subst expr
 565   = go expr
 566   where
 567     go (Var v)         = lookupVarEnv subst v `orElse` Var v
 568     go (Cast e co)     = Cast (go e) co
 569     go (Type ty)       = Type ty
 570     go (Lit lit)       = Lit lit
 571     go (App fun arg)   = App (go fun) (go arg)
 572     go (Note note e)   = Note note (go e)
 573     go (Lam bndr body) = Lam bndr (go body)
 574     go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
 575     go (Let (Rec pairs) body)       = Let (Rec (mapSnd go pairs)) (go body)
 576     go (Case scrut bndr ty alts)    = Case (go scrut) bndr ty
 577                                            [(c,bs,go r) | (c,bs,r) <- alts]
 578 \end{code}
 579
 580
 581 %************************************************************************
 582 %*                                                                      *
 583 \subsection[addAutoScc]{Adding automatic sccs}
 584 %*                                                                      *
 585 %************************************************************************
 586
 587 \begin{code}
 588 data AutoScc = NoSccs
 589              | AddSccs Module (Id -> Bool)
 590 -- The (Id->Bool) says which Ids to add SCCs to
 591
 592 addAutoScc :: AutoScc
 593            -> Id        -- Binder
 594            -> CoreExpr  -- Rhs
 595            -> CoreExpr  -- Scc'd Rhs
 596
 597 addAutoScc NoSccs _ rhs
 598   = rhs
 599 addAutoScc (AddSccs mod add_scc) id rhs
 600   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
 601   | otherwise  = rhs
 602 \end{code}
 603
 604 If profiling and dealing with a dict binding,
 605 wrap the dict in @_scc_ DICT <dict>@:
 606
 607 \begin{code}
 608 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
 609 addDictScc _ rhs = return rhs
 610
 611 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
 612   | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
 613     || not (isDictId var)
 614   = return rhs                          -- That's easy: do nothing
 615
 616   | otherwise
 617   = do (mod, grp) <- getModuleAndGroupDs
 618         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
 619        return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
 620 -}
 621 \end{code}
 622
 623
 624 %************************************************************************
 625 %*                                                                      *
 626                 Desugaring coercions
 627 %*                                                                      *
 628 %************************************************************************
 629
 630
 631 \begin{code}
 632 dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr
 633 dsCoercion WpHole            thing_inside = thing_inside
 634 dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
 635 dsCoercion (WpCast co)       thing_inside = do { expr <- thing_inside
 636                                                ; return (Cast expr co) }
 637 dsCoercion (WpLam id)        thing_inside = do { expr <- thing_inside
 638                                                ; return (Lam id expr) }
 639 dsCoercion (WpTyLam tv)      thing_inside = do { expr <- thing_inside
 640                                                ; return (Lam tv expr) }
 641 dsCoercion (WpApp v)         thing_inside
 642            | isTyVar v                    = do { expr <- thing_inside
 643                 {- Probably a coercion var -}  ; return (App expr (Type (mkTyVarTy v))) }
 644            | otherwise                    = do { expr <- thing_inside
 645                 {- An Id -}                    ; return (App expr (Var v)) }
 646 dsCoercion (WpTyApp ty)      thing_inside = do { expr <- thing_inside
 647                                                ; return (App expr (Type ty)) }
 648 dsCoercion (WpLet bs)        thing_inside = do { prs <- dsLHsBinds bs
 649                                                ; expr <- thing_inside
 650                                                ; return (Let (Rec prs) expr) }
 651 \end{code}